[libconfig-model-dpkg-perl] 21/27: Copyright update: pack and loaf info correctly

[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 2af727fec378f997e2075c2da613a3b12a372bb4
Author: Dominique Dumont <dod at debian.org>
Date:   Tue Dec 30 20:48:09 2014 +0100

    Copyright update: pack and loaf info correctly
---
 lib/Config/Model/Dpkg/Copyright.pm | 50 +++++++++++++++++++++++++++++++-------
 1 file changed, 41 insertions(+), 9 deletions(-)

diff --git a/lib/Config/Model/Dpkg/Copyright.pm b/lib/Config/Model/Dpkg/Copyright.pm
index b33edca..da05b99 100644
--- a/lib/Config/Model/Dpkg/Copyright.pm
+++ b/lib/Config/Model/Dpkg/Copyright.pm
@@ -12,25 +12,57 @@ use feature qw/postderef signatures/;
 no warnings qw/experimental::postderef experimental::signatures/;
 
 use base qw/Config::Model::Node/;
+use Path::Tiny;
 
 use Dpkg::Copyright::Scanner qw/scan_files/;
+use Software::LicenseUtils;
 
-say "Loaded";
-
-sub update {
-    my ($self) = @_;
+sub update ($self) {
 
     my @copyright_data = scan_files();
 
     foreach my $data (@copyright_data) {
         my ($paths, $c, $l) = $data->@*;
-        # load in preset mode ???
-        # add option to clean Files entries so preset is always used ??
-        # perform a ma
-        $self->load( qq!Files:"@$paths" Copyright="$c" License short_name="$l" ! );
+        say "load ",$paths->[0]," $c $l";
+        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();
+
+        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);
+
+        # not good for GPL-2 or gpl-3 need to look into global license
+
+        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"!);
+        }
+
     }
 
-    # Fill also licence text if not present ?
+    # read a debian/fix.copyright file to patch scanned data
+    my $fix = path('debian')->child('fix-scanned-copyright');
+    if ($fix->exists) {
+        foreach my $l ( $fix->lines) {
+            $self->load( $l );
+        }
+    }
 
 
     return ''; # improve returned message ?

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