[libconfig-model-dpkg-perl] 05/12: Copyright update: improved generation of single vs global licenses

[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 930ee33c0753dff5c863c68358bc5db278c79a9f
Author: Dominique Dumont <dod at debian.org>
Date:   Sat Apr 4 11:22:49 2015 +0200

    Copyright update: improved generation of single vs global licenses
---
 lib/Config/Model/Dpkg/Copyright.pm | 49 ++++++++++++++++++++++++++++----------
 1 file changed, 37 insertions(+), 12 deletions(-)

diff --git a/lib/Config/Model/Dpkg/Copyright.pm b/lib/Config/Model/Dpkg/Copyright.pm
index 06f25e4..e40c755 100644
--- a/lib/Config/Model/Dpkg/Copyright.pm
+++ b/lib/Config/Model/Dpkg/Copyright.pm
@@ -89,7 +89,8 @@ sub update ($self, %args) {
 
     # 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
+    # * %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
     # implode files entries with same data index
@@ -103,30 +104,47 @@ sub update ($self, %args) {
     # deleted or altered (when individual files are removed, renamed) is too complex.
     $files_obj->clear;
 
+    # count license useage to dedice 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->@*;
-        my $datum = $data[$id];
+        my $datum = dclone($data[$id]);
         my $path_str = $self->normalize_path(\@paths);
         my $l = $datum->{License}{short_name};
 
         next unless $l ;
 
-        # FIXME: add boilerplate to trigger warning in model
-        my $text = "Please fill license $l from header of " . $paths[0];
-
         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 $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;
+            my @sub_licenses = split /\s+or\s+/,$l;
+            my $lic_count = 0;
+            my @empty_licenses = grep {
+                my $text = $self->grab_value(qq!License:"$_" text!) ;
+                $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 ) {
+                    say "Adding dummy global license text for license $l for path @paths";
+                    map { $self->load(qq!License:"$_" text="$filler"!) } @empty_licenses ;
+
+                }
+                else {
+                    say "Adding dummy license text for license $l for path @paths";
+                    $datum->{License}{full_license} = $filler;
+                }
             }
 
         }
@@ -134,6 +152,13 @@ sub update ($self, %args) {
         $files_obj->fetch_with_id($path_str)->load_data( $datum );
     }
 
+    # 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 debian data
     foreach my $deb_path (sort keys %debian_paths) {
         $files_obj->fetch_with_id($deb_path)->load_data( $debian_paths{$deb_path} );

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