[libconfig-model-dpkg-perl] 01/01: C::M::Dpkg::Copyright: update can now start from scratch

[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 61c85b545d6e01b6403860b7aface8bc46553909
Author: Dominique Dumont <dod at debian.org>
Date:   Tue Mar 10 20:35:45 2015 +0100

    C::M::Dpkg::Copyright: update can now start from scratch
---
 lib/Config/Model/Dpkg/Copyright.pm | 83 ++++++++++++++++++++++++++------------
 1 file changed, 58 insertions(+), 25 deletions(-)

diff --git a/lib/Config/Model/Dpkg/Copyright.pm b/lib/Config/Model/Dpkg/Copyright.pm
index 5039e6e..af9bb73 100644
--- a/lib/Config/Model/Dpkg/Copyright.pm
+++ b/lib/Config/Model/Dpkg/Copyright.pm
@@ -22,7 +22,7 @@ sub update ($self) {
 
     my %old_files;
     my %old_split_files;
-    # load existing path data to remove duplicates
+    # 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 ];
@@ -34,9 +34,10 @@ sub update ($self) {
         weaken($old_files{"@paths"}[0]);
     }
 
+    my %license_short_name;
     foreach my $data (@copyright_data) {
         my ($paths, $c, $l) = $data->@*;
-        #say "load '@$paths->[0]' with '$c' '$l'";
+        say "load '@$paths' with '$c' ('$l')";
 
         # remove paths from old stuff that are found in current list
         delete $old_files{ join (' ', sort @$paths)} ;
@@ -46,31 +47,39 @@ sub update ($self) {
 
         my $c_obj = $self->grab( qq!Files:"@$paths"!);
         $c_obj->load(qq!Copyright="$c"!);
-        my $short_obj = $c_obj->grab( qq!License short_name!);
-
-        # skip when file contains actual information and extracted
-        # license is unknown
-        next if $l eq 'UNKNOWN' and $short_obj->fetch();
-
-        # handle the case where license is something like GPL-2 or GPL-3
-        foreach my $sub_l (split / or /, $l) {
-            my $license_object ;
-            eval {
-                $license_object = Software::LicenseUtils->new_from_short_name( {
-                    short_name => $sub_l,
-                    holder => 'X. Ample'
-                }) ;
-            };
-            if ($license_object) {
-                $self->load(qq!License:$sub_l!);
-            }
-        }
 
-        $short_obj->store($l);
+        my $lsn = $license_short_name{$l} ||=[];
+        push @$lsn, $paths;
+    }
+
+    foreach my $l (sort keys %license_short_name) {
+        my $pathset = $license_short_name{$l};
 
-        if ($short_obj->has_error) {
-            my $text="Please fill license $l from header of ".$paths->[0];
-            $c_obj->load(qq!License full_license="$text" short_name="$l"!);
+        # 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)";
+                $self->load( qq!Files:"@$paths" 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!);
+
+                # skip when file contains actual information and extracted
+                # license is unknown
+                my $current_name = $lic_obj->grab("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"!);
+            }
         }
 
     }
@@ -118,6 +127,30 @@ sub update ($self) {
     return ''; # improve returned message ?
 }
 
+sub fill_global_license ($self, $l, $text) {
+
+    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__

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