[libconfig-model-dpkg-perl] 07/33: C::M::Dpkg::Copyright: improved update on existing file

[dod at debian.org]

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 86c7f13089effa6223243ba551ce96f1c2bb936d
Author: Dominique Dumont <dod at debian.org>
Date:   Tue Mar 24 20:54:12 2015 +0100

    C::M::Dpkg::Copyright: improved update on existing file
---
 lib/Config/Model/Dpkg/Copyright.pm | 60 ++++++++++++++++++++++++++++----------
 1 file changed, 45 insertions(+), 15 deletions(-)

diff --git a/lib/Config/Model/Dpkg/Copyright.pm b/lib/Config/Model/Dpkg/Copyright.pm
index 8d8b466..07d52a2 100644
--- a/lib/Config/Model/Dpkg/Copyright.pm
+++ b/lib/Config/Model/Dpkg/Copyright.pm
@@ -16,6 +16,20 @@ use Dpkg::Copyright::Scanner qw/scan_files/;
 use Software::LicenseUtils;
 use Scalar::Util qw/weaken/;
 
+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);
+}
+
 # $args{in} can contains the output of licensecheck (for tests)
 sub update ($self, %args) {
 
@@ -23,16 +37,21 @@ sub update ($self, %args) {
 
     my %old_files;
     my %old_split_files;
+
     # load existing path data to remove duplicates later
-    foreach my $f ($self->grab("Files")->fetch_all_indexes) {
-        my @paths = sort split /\s+/,$f;
-        $old_files{"@paths"} = [ \$f, $f ];
-        foreach my $path (@paths) {
+    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);
+        }
+        $old_files{$f} = [ \$f, $f ];
+        foreach my $path ($self->split_path($f)) {
             next if $path =~ /\*/;
             $old_split_files{$path} = \$f ;
         }
         # the weakened ref will vanish if all ref to $f are removed from %old_split_files
-        weaken($old_files{"@paths"}[0]);
+        weaken($old_files{$f}[0]);
     }
 
     my %license_short_name;
@@ -41,13 +60,13 @@ sub update ($self, %args) {
         #say "load '@$paths' with '$c' ('$l')";
 
         # remove paths from old stuff that are found in current list
-        delete $old_files{ join (' ', sort @$paths)} ;
+        my $norm_path_str = $self->normalize_path($paths);
+        delete $old_files{ $norm_path_str };
         map { delete $old_split_files{$_} } @$paths;
 
         next if $c eq 'no-info-found';
 
-        my $c_obj = $self->grab( qq!Files:"@$paths"!);
-        $c_obj->load(qq!Copyright="$c"!);
+        $self->load(qq!Files:"$norm_path_str" Copyright="$c"!);
 
         my $lsn = $license_short_name{$l} ||=[];
         push @$lsn, $paths;
@@ -64,22 +83,33 @@ sub update ($self, %args) {
             $self->fill_global_license($l, $text);
             foreach my $paths (@$pathset) {
                 #say "load '@$paths' with '$l' (global)";
-                $self->load( qq!Files:"@$paths" License short_name="$l"!);
+                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 $lic_obj = $self->grab( qq!Files:"@$paths" License!);
+                my $norm_path_str = $self->normalize_path($paths);
+                my $lic_obj = $self->grab(qq!Files:"$norm_path_str" License!);
 
                 # skip when file contains actual information and extracted
                 # license is unknown
-                my $current_name = $lic_obj->grab("short_name")->fetch( check => 'no') //'';
+                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;
 
-                #say "load '@$paths' with '$l' (single)";
-                $lic_obj->load( qq!full_license="$text" short_name="$l"!);
+                # skip if full_license is already provided in Files section
+                next if $current_name eq $l and $lic_obj->grab_value('full_license');
+                $lic_obj->load( qq!short_name="$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;
+                next if $ok eq $size;
+
+                $lic_obj->load( qq!full_license="$text"!);
             }
         }
 
@@ -100,7 +130,7 @@ sub update ($self, %args) {
             # %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+/,$old_sorted_entry) {
+            foreach my $path (split /[\s\n]+/,$old_sorted_entry) {
                 if (defined $old_split_files{$path}) {
                     push @new_paths, $path;
                 }
@@ -119,7 +149,7 @@ sub update ($self, %args) {
     # read a debian/fix.scanned.copyright file to patch scanned data
     my $current_dir = $args{from_dir} || path('.');
     my @fixes = $current_dir->child('debian')->children(qr/fix\.scanned\.copyright$/);
-    say "Found @fixes files for copyright fixes";
+    say "Found @fixes files for copyright fixes" if @fixes;
     foreach my $fix ( @fixes) {
         my @l = grep { /[^\s]/ } grep { ! m!^(#|//)!  } $fix->lines_utf8;
         chomp @l;

-- 
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libconfig-model-dpkg-perl.git