1
package Config::Model::Dpkg::Copyright ;
9
use feature qw/postderef signatures/;
10
no warnings qw/experimental::postderef experimental::signatures/;
12
use base qw/Config::Model::Node/;
16
use Config::Model::DumpAsData;
17
use Dpkg::Copyright::Scanner qw/scan_files __squash __pack_files __create_tree_leaf_from_paths/;
18
use Software::LicenseUtils;
19
use Scalar::Util qw/weaken/;
20
use Storable qw/dclone/;
22
my $join_path = "\n "; # used to group Files
24
sub get_joined_path ($self, $paths) {
25
return join ($join_path, sort @$paths);
28
sub split_path ($self,$path) {
29
return sort ( ref $path ? @$path : split ( /[\s\n]+/ , $path ) );
31
sub normalize_path ($self,$path) {
32
my @paths = $self->split_path($path);
33
return $self->get_joined_path(\@paths);
36
my $dumper = Config::Model::DumpAsData->new;
38
# $args{in} can contains the output of licensecheck (for tests)
39
sub update ($self, %args) {
41
my $files_obj = $self->grab("Files");
43
# explode existing path data to track deleted paths
46
foreach my $paths_str ($files_obj->fetch_all_indexes) {
47
my $node = $files_obj->fetch_with_id($paths_str) ;
48
my $data = $dumper->dump_as_data( node => $node );
50
if ($paths_str =~ m!^debian/!) {
51
$debian_paths{$paths_str} = $data;
54
foreach my $path ($self->split_path($paths_str)) {
55
$old_split_files{$path} = $data ;
60
my ($files, $copyrights_by_id) = scan_files( %args );
62
# explode new data and merge with existing entries
66
foreach my $path ( keys $files->%* ) {
67
my ($c, $l) = $copyrights_by_id->[ $files->{$path} ]->@*;
69
my $new_data = dclone (delete $old_split_files{$path} || {} );
70
my $old_cop = $new_data->{Copyright};
71
my $old_lic = $new_data->{License}{short_name};
72
# say "load '$path' with '$c' ('$l') old '$old_cop' ('$old_lic')";
74
$new_data->{Copyright} = $c if ($c !~ /no-info-found|UNKNOWN/ or not $old_cop);
75
$new_data->{License}{short_name} = $l if ($l ne 'UNKNOWN');
77
# create an inventory of different file copyright and license data
78
my $dumper = Data::Dumper->new([$new_data])->Sortkeys(1)->Indent(0);
79
my $datum_dump = $dumper->Dump;
80
my $d_key = $data_keys{$datum_dump};
81
if (not defined $d_key) {
83
$d_key = $data_keys{$datum_dump} = $#data;
86
# explode path in subpaths and store id pointing to copyright data in there
87
__create_tree_leaf_from_paths(\%new_split_files, $path, $d_key);
91
# * @data contains a list of copyright/license data
92
# * %new_split_files contains a tree matching a directory tree where each leaf
93
# is an integer index referencing
94
# an entry in @data to get the correct copyright/license data
95
# * %old_split_files contains paths no longer present. Useful to trace deleted files
96
# implode files entries with same data index
98
__squash(\%new_split_files) ;
100
# pack files by copyright id
101
my @packed = __pack_files(\%new_split_files);
103
# delete existing data in config tree. A more subtle solution to track which entry is
104
# deleted or altered (when individual files are removed, renamed) is too complex.
107
# count license useage to dedice whether to add a global license
108
# or a single entry. Skip unknown or public-domain licenses
110
map { $lic_usage_count{$_}++ if $_ and not /unknown|public/i}
111
map {split /\s+or\s+/, $data[$_->[0]]->{License}{short_name} // ''; }
114
# load new data in config tree
115
foreach my $p (@packed) {
116
my ($id, @paths) = $p->@*;
117
my $datum = dclone($data[$id]);
118
my $path_str = $self->normalize_path(\@paths);
119
my $l = $datum->{License}{short_name};
123
my $norm_path_str = $self->normalize_path(\@paths);
125
# if full_license is not provided in datum, check global license(s)
126
if (not $datum->{License}{full_license}) {
128
my @sub_licenses = split /\s+or\s+/,$l;
130
my @empty_licenses = grep {
131
my $text = $self->grab_value(qq!License:"$_" text!) ;
133
$lic_count += $lic_usage_count{$_} // 0 ;
134
not $text; # to get list of empty licenses
137
if ($ok ne @sub_licenses) {
138
my $filler = "Please fill license $l from header of @paths";
139
if ($lic_count > 1 ) {
140
say "Adding dummy global license text for license $l for path @paths";
141
map { $self->load(qq!License:"$_" text="$filler"!) } @empty_licenses ;
145
say "Adding dummy license text for license $l for path @paths";
146
$datum->{License}{full_license} = $filler;
152
$files_obj->fetch_with_id($path_str)->load_data( $datum );
155
# delete global license without text
156
my $global_lic_obj = $self->fetch_element('License');
157
foreach my $l ($global_lic_obj->fetch_all_indexes) {
158
$global_lic_obj->delete($l)
159
unless $global_lic_obj->fetch_with_id($l)->fetch_element_value('text');
162
# put back debian data
163
foreach my $deb_path (sort keys %debian_paths) {
164
$files_obj->fetch_with_id($deb_path)->load_data( $debian_paths{$deb_path} );
167
my $current_dir = $args{from_dir} || path('.');
169
# warn about old files
170
foreach my $old_path (sort keys %old_split_files) {
171
# put back data matching an existing dir
172
if ($old_path eq '*' or ($old_path =~ m!(.*)/\*$! and $current_dir->is_dir($1))) {
173
say "Note: preserving entry '$old_path'";
174
$files_obj->fetch_with_id($old_path)->load_data( $old_split_files{$old_path} );
177
say "Note: '$old_path' was removed from new upstream source";
181
# read a debian/fix.scanned.copyright file to patch scanned data
182
my $debian = $current_dir->child('debian'); # may be missing in test environment
183
if ($debian->is_dir) {
184
$debian->children(qr/fix\.scanned\.copyright$/);
185
my @fixes = $current_dir->child('debian')->children(qr/fix\.scanned\.copyright$/);
186
say "Note: loading @fixes fixes from copyright fix files" if @fixes;
187
foreach my $fix ( @fixes) {
188
my @l = grep { /[^\s]/ } grep { ! m!^(#|//)! } $fix->lines_utf8;
189
$self->load( join('',@l) );
193
# normalized again after all the modifications
194
$self->load("Files:.sort");
196
return ''; # improve returned message ?
200
sub fill_global_license ($self, $l, $text) {
202
#say "Adding global license $l";
203
# handle the case where license is something like GPL-2 or GPL-3
204
my @names = $l =~ / or / ? split / or /, $l : ($l);
206
# try to fill text of a known license
207
foreach my $name (@names) {
210
$license_object = Software::LicenseUtils->new_from_short_name( {
215
if ($license_object) {
216
$self->load(qq!License:$name!); # model will fill the text
219
$self->load(qq!License:$name text:"$text"!);
231
Config::Model::Dpkg::Copyright - Fill the File sections of debian/copyright file
235
# this modules is used by cme when invoked with this command
236
$ cme update dpkg-copyright
240
This commands helps with the tedious task of maintening
241
C<debian/copyright> file. When you package a new release of a
242
software, you can run C<cme update dpkg-copyright> to update the
243
content of the copyright file.
245
This command scans current package directory to extract copyright and
246
license information and store them in the Files sections of
247
debian/copyright file.
249
In debian package directory:
251
* run 'cme update dpkg-copyright' or 'cme update dpkg'
252
* check the result with your favorite VCS diff tool. (you do use
253
a VCS for your package files, do you ?)
255
Note: this command is experimental.
259
Since the extraction of copyright information from source file is
260
based on comments, the result is sometimes lackluster. Your may
261
specify instruction to alter or set specific copyright entries in
262
C<debian/fix.scanned.copyright> file
263
(or C<< debian/<source-package>.fix.scanned.copyright >>).
264
Each line of this file will be handled
265
by L<Config::Model::Loader> to modify copyright information.
269
If the extracted copyright contains:
272
Copyright: 2014-2015, Adam Kennedy <adamk@cpan.org> "foobar
273
License: Artistic or GPL-1+
275
You may add this line in C<debian/fix.copyright> file:
277
! Files:'*' Copyright=~s/\s*".*//
279
This way, the copyright information will be updated from the file
280
content but the extra C<"foobar> will always be removed during
283
Comments are accepted in Perl and C++ style from the beginning of the line.
284
Lines breaks are ignored.
286
Here's another more complex example:
288
// added a global license, MIT license text is filled by Config::Model
289
! copyright License:MIT
291
# don't forget '!' to go back to tree root
292
! copyright Files:"pan/general/map-vector.h" Copyright="2001,Andrei Alexandrescu"
293
License short_name=MIT
294
# delete license text since short_name points to global MIT license
297
# use a loop there vvvvvv to clean up that vvvvvvvvvvvvvvvvvvvvvvv in all copyrights
298
! copyright Files:~/.*/ Copyright=~s/all\s*rights\s*reserved//i
303
Dominique Dumont <dod@debian.org>
added
removed
lib/Config/Model/Dpkg/Copyright.pm
