[libconfig-model-dpkg-perl] 19/33: Copyright update: mostly rewritten...
dod at debian.org
dod at debian.org
Mon Mar 30 17:41:42 UTC 2015
This is an automated email from the git hooks/post-receive script.
dod pushed a commit to branch master
in repository libconfig-model-dpkg-perl.
commit d6219e449876520f027db5d7c14d1c1b658a2a75
Author: Dominique Dumont <dod at debian.org>
Date: Fri Mar 27 20:33:41 2015 +0100
Copyright update: mostly rewritten...
---
lib/Config/Model/Dpkg/Copyright.pm | 175 ++++++++++++++++++-------------------
lib/Dpkg/Copyright/Scanner.pm | 16 ++--
t/model_tests.d/dpkg-test-conf.pl | 3 +-
3 files changed, 97 insertions(+), 97 deletions(-)
diff --git a/lib/Config/Model/Dpkg/Copyright.pm b/lib/Config/Model/Dpkg/Copyright.pm
index 10c28a0..41c3b4e 100644
--- a/lib/Config/Model/Dpkg/Copyright.pm
+++ b/lib/Config/Model/Dpkg/Copyright.pm
@@ -11,8 +11,10 @@ no warnings qw/experimental::postderef experimental::signatures/;
use base qw/Config::Model::Node/;
use Path::Tiny;
+use Data::Dumper;
-use Dpkg::Copyright::Scanner qw/scan_files/;
+use Config::Model::DumpAsData;
+use Dpkg::Copyright::Scanner qw/scan_files __squash __pack_files/;
use Software::LicenseUtils;
use Scalar::Util qw/weaken/;
@@ -30,124 +32,118 @@ sub normalize_path ($self,$path) {
return $self->get_joined_path(\@paths);
}
+my $dumper = Config::Model::DumpAsData->new;
+
# $args{in} can contains the output of licensecheck (for tests)
sub update ($self, %args) {
my @copyright_data = scan_files( %args );
- my %old_files;
+ my $files_obj = $self->grab("Files");
+
+ # explode existing path data to track deleted paths
my %old_split_files;
+ 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 );
- # load existing path data to remove duplicates later
- foreach my $raw_f ($self->grab("Files")->fetch_all_indexes) {
- my $f = $self->normalize_path($raw_f);
- if ($raw_f ne $f) {
- # normalise existing path
- $self->grab("Files")->move($raw_f,$f);
+ if ($paths_str =~ m!^debian/!) {
+ $debian_paths{$paths_str} = $data;
}
- $old_files{$f} = [ \$f, $f ];
- foreach my $path ($self->split_path($f)) {
- next if $path =~ /\*/;
- $old_split_files{$path} = \$f ;
+ else {
+ foreach my $path ($self->split_path($paths_str)) {
+ $old_split_files{$path} = $data ;
+ }
}
- # the weakened ref will vanish if all ref to $f are removed from %old_split_files
- weaken($old_files{$f}[0]);
}
- my %license_short_name;
+ # explode new data and merge with existing entries
+ my %new_split_files;
+ my @data;
+ my %data_keys;
foreach my $data (@copyright_data) {
my ($paths, $c, $l) = $data->@*;
#say "load '@$paths' with '$c' ('$l')";
- next if $c eq 'no-info-found';
+ foreach my $path (@$paths) {
+ my $new_data = delete $old_split_files{$path} || {} ;
+ # clobber old data
+ $new_data->{Copyright} = $c unless $c eq 'no-info-found';
+ $new_data->{License}{short_name} = $l unless $l eq 'UNKNOWN';
+
+ # create an inventory of different file copyright and license data
+ my $dumper = Data::Dumper->new([$new_data])->Sortkeys(1);
+ my $datum_dump = $dumper->Dump;
+ my $d_key;
+ if (not $d_key = $data_keys{$datum_dump}) {
+ push @data,$new_data;
+ $data_keys{$datum_dump} = $d_key = $#data;
+ }
- # remove paths from old stuff that are found in current list
- my $norm_path_str = $self->normalize_path($paths);
- delete $old_files{ $norm_path_str };
- map { delete $old_split_files{$_} } @$paths;
+ # explode path in subpaths
+ my @subpaths = split '/', $path;
+ my $h = \%new_split_files;
+ my $last = pop @subpaths;
+ map { $h = $h->{$_} ||= {} } @subpaths ;
+ $h->{$last} = $d_key;
+ }
+ }
- $self->load(qq!Files:"$norm_path_str" Copyright="$c"!);
+ # at this point:
+ # * @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 $lsn = $license_short_name{$l} ||=[];
- push @$lsn, $paths;
- }
+ # implode files entries with same data index
+ __squash(\%new_split_files) ;
- foreach my $l (sort keys %license_short_name) {
- my $pathset = $license_short_name{$l};
+ # pack files by copyright id
+ my @packed = __pack_files(\%new_split_files);
- # FIXME: add boilerplate to trigger warning in model
- my $text = "Please fill license $l from header of " . $pathset->[0][0];
-
- if ($l ne 'UNKNOWN' and @$pathset > 1) {
- # use a global license, *then* add short_name info in each Files section
- $self->fill_global_license($l, $text);
- foreach my $paths (@$pathset) {
- #say "load '@$paths' with '$l' (global)";
- my $norm_path_str = $self->normalize_path($paths);
- $self->load( qq!Files:"$norm_path_str" License short_name="$l"!);
- }
- }
- else {
- # single license, enter text directly below Files
- foreach my $paths (@$pathset) {
- my $norm_path_str = $self->normalize_path($paths);
- my $lic_obj = $self->grab(qq!Files:"$norm_path_str" License!);
+ # delete existing data in config tree
+ $files_obj->clear;
- # skip when file contains actual information and extracted
- # license is unknown
- my $current_name = $lic_obj->fetch_element("short_name")->fetch( check => 'no') //'';
- #say "Single license $l for path @$paths (current '$current_name')";
- next if $l eq 'UNKNOWN' and $current_name;
+ # load new data in config tree
+ foreach my $p (@packed) {
+ my ($id, @paths) = $p->@*;
+ my $datum = $data[$id];
+ my $path_str = $self->normalize_path(\@paths);
+ my $l = $datum->{License}{short_name};
- # skip if full_license is already provided in Files section
- next if $current_name eq $l and $lic_obj->grab_value('full_license');
+ next unless $l ;
- # skip if all licenses are provided in global license section
- my $ok = 0;
- my $global_lic = $lic_obj->grab('- - License');
- my $size = map { $ok++ if $global_lic->defined($_) ; } split /\s+or\s+/,$l;
+ # FIXME: add boilerplate to trigger warning in model
+ my $text = "Please fill license $l from header of " . $paths[0];
- if ($ok ne $size) {
- say "Adding dummy license text for license $l for path @$paths";
- $lic_obj->load( qq!full_license="$text"!);
- }
+ my $norm_path_str = $self->normalize_path(\@paths);
- $lic_obj->load( qq!short_name="$l"!);
+ # if full_license is not provided in datum, check global license(s)
+ if (not $datum->{License}{full_license}) {
+ my $ok = 0;
+ my $size = map {
+ $ok++ if $self->grab_value(qq!License:"$_" text!) ;
+ } split /\s+or\s+/,$l;
+ if ($ok ne $size) {
+ say "Adding dummy license text for license $l for path @paths";
+ $datum->{License}{full_license} = $text;
}
+
}
+ $files_obj->fetch_with_id($path_str)->load_data( $datum );
}
- # now %old_files contains entries that were not touched by the
- # found licenses. either the files were removed, or the path
- # distributions don't match
- foreach my $old_sorted_entry (sort keys %old_files) {
- my ($weak_old_ref, $old_entry) = $old_files{$old_sorted_entry}->@*;
- next if $old_entry =~ /debian/; # leave debian dir alone
- if (not defined $weak_old_ref) {
- # all paths of $old_entry were found but arranged differently
- say "deleting old entry: '$old_entry'";
- $self->grab("Files")->delete($old_entry);
- }
- else {
- # %old_split_files contains paths that were not found in the
- # license process. i.e removed files.
- my @new_paths;
- foreach my $path (split /[\s\n]+/,$old_sorted_entry) {
- if (defined $old_split_files{$path}) {
- push @new_paths, $path;
- }
- else {
- say "deleting $path from entry '$old_entry'";
- }
- }
- my $new_path_entry = $self->normalize_path(\@new_paths);
- if ($new_path_entry ne $old_sorted_entry) {
- say "renaming $old_entry in $new_path_entry";
- $self->grab("Files")->move($old_entry, $new_path_entry);
- }
- }
+ # 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} );
+ }
+
+ # warn about old files
+ foreach my $old_path (sort keys %old_split_files) {
+ say "Note: $old_path was removed from new upstream source";
}
# read a debian/fix.scanned.copyright file to patch scanned data
@@ -156,7 +152,7 @@ sub update ($self, %args) {
if ($debian->is_dir) {
$debian->children(qr/fix\.scanned\.copyright$/);
my @fixes = $current_dir->child('debian')->children(qr/fix\.scanned\.copyright$/);
- say "Found @fixes files for copyright fixes" if @fixes;
+ say "Note: Found @fixes files for copyright fixes" if @fixes;
foreach my $fix ( @fixes) {
my @l = grep { /[^\s]/ } grep { ! m!^(#|//)! } $fix->lines_utf8;
chomp @l;
@@ -171,6 +167,7 @@ sub update ($self, %args) {
return ''; # improve returned message ?
}
+
sub fill_global_license ($self, $l, $text) {
#say "Adding global license $l";
diff --git a/lib/Dpkg/Copyright/Scanner.pm b/lib/Dpkg/Copyright/Scanner.pm
index c31d109..df98c1c 100644
--- a/lib/Dpkg/Copyright/Scanner.pm
+++ b/lib/Dpkg/Copyright/Scanner.pm
@@ -311,13 +311,15 @@ sub __squash ($h) {
}
}
- # find the most used (c) info in this directory
+ # find the most used (c) info in this directory (or the existing '*' entry)
my $max = 0;
- my $max_id;
- foreach my $id (sort keys %count) {
- if ($count{$id} > $max) {
- $max = $count{$id};
- $max_id = $id ;
+ my $max_id = $h->{'*'};
+ if (not defined $max_id) {
+ foreach my $id (sort keys %count) {
+ if ($count{$id} > $max) {
+ $max = $count{$id};
+ $max_id = $id ;
+ }
}
}
@@ -337,7 +339,7 @@ sub __squash ($h) {
}
}
# here's the '*' file representing the most used (c) info
- $h->{'*'} = $max_id if defined $max_id;
+ $h->{'*'} //= $max_id if defined $max_id;
return $h;
}
diff --git a/t/model_tests.d/dpkg-test-conf.pl b/t/model_tests.d/dpkg-test-conf.pl
index 567cfc9..18740e5 100644
--- a/t/model_tests.d/dpkg-test-conf.pl
+++ b/t/model_tests.d/dpkg-test-conf.pl
@@ -83,7 +83,8 @@ my $del_home = sub {
'copyright Files:pan/general/sorted-vector.h Copyright'
=> '2002, Martin Holzherr (holzherr at infobrain.com).',
'copyright Files:pan/general/sorted-vector.h License short_name' => 'public-domain',
- qq'copyright Files:"uulib/fptools.c\n uulib/fptools.h" Copyright' => 'Unknown',
+ # entry "uulib/fptools.c\n uulib/fptools.h"is packed by update
+ qq'copyright Files:"uulib/*" Copyright' => 'Unknown',
},
wr_check => {
"copyright License:GPL-2 text" => {value => undef, mode => 'custom'},
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libconfig-model-dpkg-perl.git
More information about the Pkg-perl-cvs-commits
mailing list