/usr/share/perl5/Config/Model/Dpkg/Copyright.pm is in libconfig-model-dpkg-perl 2.090.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 | package Config::Model::Dpkg::Copyright ;
use strict;
use warnings;
use 5.20.0;
use IO::Pipe;
use feature qw/postderef signatures/;
no warnings qw/experimental::postderef experimental::signatures/;
use base qw/Config::Model::Node/;
use Path::Tiny;
use Data::Dumper;
use Config::Model::DumpAsData;
use Dpkg::Copyright::Scanner qw/scan_files __squash __pack_files __create_tree_leaf_from_paths/;
use Software::LicenseUtils;
use Scalar::Util qw/weaken/;
use Storable qw/dclone/;
my $join_path = "\n "; # used to group Files
sub get_joined_path ($self, $paths) {
return join ($join_path, sort @$paths);
}
sub split_path ($self,$path) {
return sort ( ref $path ? @$path : split ( /[\s\n]+/ , $path ) );
}
sub normalize_path ($self,$path) {
my @paths = $self->split_path($path);
return $self->get_joined_path(\@paths);
}
my $dumper = Config::Model::DumpAsData->new;
sub _say ($self,$msg) {
say $msg unless $self->{quiet};
}
sub _get_old_data ($old_split_files, $old_split_dirs, $path) {
my $data = delete $old_split_files->{$path};
if (not $data) {
foreach my $dir (reverse sort keys $old_split_dirs->%*) {
my $re = $dir;
$re =~ s/\*$//;
if ($path =~ /^$re/) {
$data = $old_split_dirs->{$dir}; # do not delete
last;
}
}
}
return defined $data ? dclone($data) : {};
}
# $args{in} can contains the output of licensecheck (for tests)
sub update ($self, %args) {
my $files_obj = $self->grab("Files");
$self->{quiet} = $args{quiet} // 0;
# explode existing path data to track deleted paths
my %old_split_files;
my %old_split_dirs;
my %debian_paths;
foreach my $paths_str ($files_obj->fetch_all_indexes) {
my $node = $files_obj->fetch_with_id($paths_str) ;
my $data = $dumper->dump_as_data( node => $node );
if ($paths_str =~ m!^debian/!) {
$debian_paths{$paths_str} = $data;
}
else {
foreach my $path ($self->split_path($paths_str)) {
$old_split_files{$path} = $data ;
$old_split_dirs{$path} = $data if $path =~ /\*$/;
}
}
}
my ($files, $copyrights_by_id) = scan_files( %args );
# explode new data and merge with existing entries
my %new_split_files;
my @data = (undef);# id 0 is reserved for entries without info
my %data_keys;
foreach my $path ( sort keys $files->%* ) {
my $id = $files->{$path};
next if $id == 0 and not defined $copyrights_by_id->[$id];
my ($c, $l) = $copyrights_by_id->[$id]->@*;
my $new_data = _get_old_data(\%old_split_files, \%old_split_dirs, $path);
my $old_cop = $new_data->{Copyright};
my $old_lic = $new_data->{License}{short_name};
# $self->_say( "load '$path' with '$c' ('$l') old '$old_cop' ('$old_lic')");
# clobber old data
$new_data->{Copyright} = $c if ($c !~ /no-info-found|UNKNOWN/ or not $old_cop);
$new_data->{License}{short_name} = $l if ($l ne 'UNKNOWN' or not $old_lic);
# when all fails
$new_data->{Copyright} ||= 'UNKNOWN';
$new_data->{License}{short_name} ||= 'UNKNOWN';
# skip when no info is found in original data
my $d_key;
if ( $new_data->{Copyright} =~ /no-info-found|unknown/i
and $new_data->{License}{short_name} =~ /unknown/i) {
$data[0] //= $new_data;
$d_key = 0;
}
else {
# create an inventory of different file copyright and license data
# this works like $copyrights_by_id but takes into account data coming
# from old copyright file like comments
my $dumper = Data::Dumper->new([$new_data])->Sortkeys(1)->Indent(0);
my $datum_dump = $dumper->Dump;
$d_key = $data_keys{$datum_dump};
if (not defined $d_key) {
push @data,$new_data;
# id 0 is special and is treated diffrently. It must not be used since
# entries without info are skipped. Hence @data was init with ('');
$d_key = $data_keys{$datum_dump} = $#data ;
}
}
# explode path in subpaths and store id pointing to copyright data in there
__create_tree_leaf_from_paths(\%new_split_files, $path, $d_key);
}
# at this point:
# * $copyrights_by_id is not longer used, its data and merged data are in @data
# * @data contains a list of copyright/license data
# * %new_split_files contains a tree matching a directory tree where each leaf
# is an integer index referencing
# an entry in @data to get the correct copyright/license data
# * %old_split_files contains paths no longer present. Useful to trace deleted files
my $current_dir = $args{from_dir} || path('.');
my %preserved_path;
# warn about old files (data may be redundant or obsolete though)
foreach my $old_path (sort keys %old_split_files) {
# prepare to be able to put back data matching an existing dir
if ($old_path eq '*' or ($old_path =~ m!(.*)/\*$! and $current_dir->child($1)->is_dir )) {
$preserved_path{$old_path} = delete $old_split_files{$old_path};
}
else {
$self->_say( "Note: '$old_path' was removed (or excluded) from new upstream source" );
}
}
$self->_prune_old_dirs(\%new_split_files, \%old_split_files) ;
# implode files entries with same data index
__squash(\%new_split_files) ;
# pack files by copyright id
my @packed = __pack_files(\%new_split_files);
# delete existing data in config tree. A more subtle solution to track which entry is
# deleted or altered (when individual files are removed, renamed) is too complex. The track
# would require to follow split files,
$files_obj->clear;
# count license useage to decide whether to add a global license
# or a single entry. Skip unknown or public-domain licenses
my %lic_usage_count;
map { $lic_usage_count{$_}++ if $_ and not /unknown|public/i}
map {split /\s+or\s+/, $data[$_->[0]]->{License}{short_name} // ''; }
@packed ;
# load new data in config tree
foreach my $p (@packed) {
my ($id, @paths) = $p->@*;
next if $id == 0; # skip entries without info
my $datum = dclone($data[$id]);
# ditch old data when copyright data directory is found in source files
if ($paths[0] =~ /[*.]$/) {
if (@paths > 1) {
die "Internal error: can't have dir path with file path: @paths";
}
my $p = $paths[0];
$p =~ s/\.$/*/;
my $old_data = delete $preserved_path{$p};
my $using_old_data = 0;
if ($old_data) {
if ($datum->{Copyright} =~ /unknown|no-info-found/i) {
$self->_say( "keeping copyright dir data for $p");
$datum->{Copyright} = $old_data->{Copyright};
$using_old_data = 1;
}
if ($datum->{License}{short_name} =~ /unknown|no-info-found/i) {
$self->_say( "keeping license dir data for $p");
$datum->{License}{short_name} = $old_data->{License}{short_name};
$datum->{License}{full_license} = $old_data->{License}{full_license};
$using_old_data = 1;
}
$self->_say( "old dir data for $p overridden by new data") unless $using_old_data;
}
if ($paths[0] =~ /\.$/) {
if ($using_old_data) {
# fix path ending with '.' that contain merged info from old copyright file
$paths[0] = $p;
} else {
# skip writing data because it duplicates information
# found in directory above above (as shown the path ending
# with '/.')
# $self->_say( "skipping redundant path ".$paths[0] );
next;
}
}
};
my $path_str = $self->normalize_path(\@paths);
my $l = $datum->{License}{short_name};
my $norm_path_str = $self->normalize_path(\@paths);
# if full_license is not provided in datum, check global license(s)
if (not $datum->{License}{full_license}) {
my $ok = 0;
my @sub_licenses = split /\s+or\s+/,$l;
my $lic_count = 0;
my @empty_licenses = grep {
my $text = $self->grab_value(steps => qq!License:"$_" text!, check =>'no') ;
$ok++ if $text;
$lic_count += $lic_usage_count{$_} // 0 ;
not $text; # to get list of empty licenses
} @sub_licenses;
if ($ok ne @sub_licenses) {
my $filler = "Please fill license $l from header of @paths";
if ($lic_count > 1 ) {
$self->_say( "Adding dummy global license text for license $l for path @paths");
map { $self->load(qq!License:"$_" text="$filler"!) } @empty_licenses ;
}
else {
$self->_say( "Adding dummy license text for license $l for path @paths");
$datum->{License}{full_license} = $filler;
}
}
}
eval {
$files_obj->fetch_with_id($path_str)->load_data( data => $datum, check =>'yes' );
};
if ($@) {
die "Error: Data extracted from source file is corrupted:\n$@"
."This usually mean that cme or licensecheck (or both)"
."have a bug. You may work-around this issue by adding an override entry in "
."fill.copyright.blanks file. See "
."https://github.com/dod38fr/config-model/wiki/Updating-debian-copyright-file-with-cme "
."for instructions. Last but not least, please file a bug against libconfig-model-dpkg-perl.\n";
}
}
# delete global license without text
my $global_lic_obj = $self->fetch_element('License');
foreach my $l ($global_lic_obj->fetch_all_indexes) {
$global_lic_obj->delete($l)
unless $global_lic_obj->fetch_with_id($l)->fetch_element_value('text');
}
# put back preserved data
foreach my $old_path (sort keys %preserved_path) {
$self->_say( "Note: preserving entry '$old_path'");
$files_obj->fetch_with_id($old_path)->load_data( $preserved_path{$old_path} );
}
# put back debian data
foreach my $deb_path (sort keys %debian_paths) {
$files_obj->fetch_with_id($deb_path)->load_data( $debian_paths{$deb_path} );
}
$self->_apply_fix_scan_copyright_file($current_dir) ;
# normalized again after all the modifications
$self->load("Files:.sort");
$self->fetch_element("License")-> prune_unused_licenses;
$self->instance->clear_changes; # too many changes to show users
$self->notify_change(note => "updated copyright from source file"); # force a save
my @msgs = (
"Please follow the instructions given in ".__PACKAGE__." man page,",
"section \"Tweak results\" if some license and copyright entries are wrong.",
"Other information, like license text, can be added directly in debian/copyright file ",
"and will be merged correctly next time this command is run.",
"See also https://github.com/dod38fr/config-model/wiki/Updating-debian-copyright-file-with-cme"
);
return @msgs;
}
sub _apply_fix_scan_copyright_file ($self, $current_dir) {
# read a debian/fix.scanned.copyright file to patch scanned data
my $debian = $current_dir->child('debian'); # may be missing in test environment
if ($debian->is_dir) {
my @fixes = $current_dir->child('debian')->children(qr/fix\.scanned\.copyright$/);
$self->_say( "Note: loading @fixes fixes from copyright fix files") if @fixes;
foreach my $fix ( @fixes) {
my @l = grep { /[^\s]/ } grep { ! m!^(#|//)! } $fix->lines_utf8;
eval { $self->load( join(' ',@l) ); };
my $e = $@;
if ($e) {
my $msg = $e->full_message;
Config::Model::Exception::User->throw(
object => $self,
message => "Error while applying fix.scanned.copyright file:\n\t".$msg
);
}
}
}
}
sub _prune_old_dirs ($self, $h, $old_dirs, $path = [] ) {
# recurse in the data structure
foreach my $name (sort keys %$h) {
my $item = $h->{$name};
if (ref($item)) {
$self->_prune_old_dirs($item, $old_dirs, [ $path->@*, $name ]);
}
}
# delete current directory entry
my $dir_path = join('/', $path->@*,'.');
if ($old_dirs->{$dir_path}) {
$self->_say( "Removing old entry $dir_path" );
delete $old_dirs->{$dir_path};
}
}
sub fill_global_license ($self, $l, $text) {
#$self->_say( "Adding global license $l");
# handle the case where license is something like GPL-2 or GPL-3
my @names = $l =~ / or / ? split / or /, $l : ($l);
# try to fill text of a known license
foreach my $name (@names) {
my $license_object ;
eval {
$license_object = Software::LicenseUtils->new_from_short_name( {
short_name => $name,
holder => 'X. Ample'
}) ;
};
if ($license_object) {
$self->load(qq!License:$name!); # model will fill the text
}
else {
$self->load(qq!License:$name text:"$text"!);
}
}
}
1;
__END__
=encoding utf8
=head1 NAME
Config::Model::Dpkg::Copyright - Fill the File sections of debian/copyright file
=head1 SYNOPSIS
# this modules is used by cme when invoked with this command
$ cme update dpkg-copyright
=head1 DESCRIPTION
This commands helps with the tedious task of maintening
C<debian/copyright> file. When you package a new release of a
software, you can run C<cme update dpkg-copyright> to update the
content of the copyright file.
This command scans current package directory to extract copyright and
license information and store them in the Files sections of
debian/copyright file.
In debian package directory:
* run 'cme update dpkg-copyright' or 'cme update dpkg'
* check the result with your favorite VCS diff tool. (you do use
a VCS for your package files, do you ?)
Note: this command is experimental.
=head1 Tweak results
Results can be tweaked either by:
=over
=item *
Changing the list of files to scan or ignore. (By default, licensecheck will decide
which file to scan or not.)
=item *
Specifying information for individual files
=item *
Tweaking the copyright entries created by grouping and coaslescing
information.
=back
The first 2 ways are described in
L<Dpkg::Copyright::Scanner/"Selecting or ignoring files to scan">
and L<Dpkg::Copyright::Scanner/"Filling the blanks">.
The last way is described below:
=head2 Tweak copyright entries
Since the extraction of copyright information from source file is
based on comments, the result is sometimes lackluster. Your may
specify instruction to alter or set specific copyright entries in
C<debian/fix.scanned.copyright> file
(or C<< debian/<source-package>.fix.scanned.copyright >>).
Each line of this file will be handled
by L<Config::Model::Loader> to modify copyright information.
=head2 Example
If the extracted copyright contains:
Files: *
Copyright: 2014-2015, Adam Kennedy <adamk@cpan.org> "foobar
License: Artistic or GPL-1+
You may add this line in C<debian/fix.copyright> file:
! Files:'*' Copyright=~s/\s*".*//
This way, the copyright information will be updated from the file
content but the extra C<"foobar> will always be removed during
updates.
Comments are accepted in Perl and C++ style from the beginning of the line.
Lines breaks are ignored.
Here's another more complex example:
// added a global license, MIT license text is filled by Config::Model
! copyright License:MIT
# don't forget '!' to go back to tree root
! copyright Files:"pan/general/map-vector.h" Copyright="2001,Andrei Alexandrescu"
License short_name=MIT
# delete license text since short_name points to global MIT license
full_license~
# use a loop there vvvvvv to clean up that vvvvvvvvvvvvvvvvvvvvvvv in all copyrights
! copyright Files:~/.*/ Copyright=~s/all\s*rights\s*reserved//i
# defeat spammer by replacing all '@' in emails of 3rdparty files
# the operation :~/^3party/ loops over all Files entries that match ^3rdparty
# and modify the copyright entry with a Perl substitution
! Files:~/^3rdparty/ Copyright=~s/@/(at)/
=head1 Under the hood
This section explains how cme merges the information from the existing
C<debian/copyright> file (the "old" information) with the information
extracted by I<licensecheck> (the "new" information):
=over
=item *
The old and new information are compared in the form of file lists:
=over
=item *
New file entries are kept as is in the new list.
=item *
When a file entry is found in both old and new lists, the new © and
license short names are checked. If they are unknown, the information
from the old list is copied in the new list.
=item *
Old files entries not found in the new list are deleted.
=back
=item *
File entries are coalesced in the new list to reduce redundancies (this mechanism is explained in this L<blog|https://ddumont.wordpress.com/2015/04/05/improving-creation-of-debian-copyright-file>)
=item *
License entries are created, either attached to Files specification or as global licenses. License text is added for known license (actually known by L<Software::License>)
=item *
Directories (path ending with C</*>) from old list then checked:
=over
=item *
Directory is found in the new list: the old information is clobbered by new information.
=item *
Directory not found in new list but exists: the old information is copied in the new list.
=item *
Directory is not found: the old information is discarded
=back
=item *
Files entries are sorted and the new C<debian/copyright> is generated.
=back
=head1 update ( %args )
Updates data using the output
L<Dpkg::Copyright::Scanner/"scan_files ( %args )">.
Parameters in C<%args>:
=over
=item quiet
set to 1 to suppress progress messages. Should be used only in tests.
=back
Otherwise, C<%args> is passed to C<scan_files>
=head1 AUTHOR
Dominique Dumont <dod@debian.org>
=cut
|