This is an automated email from the git hooks/post-receive script.

dod pushed a commit to branch check-unused-licenses-live
in repository libconfig-model-dpkg-perl.

commit 4549fcc0fea11c5dadb893246c9a373e7f698d46
Author: Dominique Dumont <d...@debian.org>
Date:   Fri Jul 29 18:22:04 2016 +0200

    added unused license check live
    
    See TODOs
---
 lib/Config/Model/Dpkg/Copyright/License.pm         | 91 ++++++++++++++++++++++
 lib/Config/Model/models/Dpkg/Copyright.pl          |  1 +
 .../dpkg-copyright-examples/unused-license         | 33 ++++++++
 t/model_tests.d/dpkg-copyright-test-conf.pl        | 19 +++++
 4 files changed, 144 insertions(+)

diff --git a/lib/Config/Model/Dpkg/Copyright/License.pm 
b/lib/Config/Model/Dpkg/Copyright/License.pm
new file mode 100644
index 0000000..8259942
--- /dev/null
+++ b/lib/Config/Model/Dpkg/Copyright/License.pm
@@ -0,0 +1,91 @@
+package Config::Model::Dpkg::Copyright::License;
+
+use 5.20.0;
+
+use Mouse;
+extends qw/Config::Model::HashId/;
+
+use feature qw/postderef signatures/;
+no warnings qw/experimental::postderef experimental::signatures/;
+
+use Scalar::Util qw/weaken/;
+
+# checkUnused license is a idx check, not a content check
+
+sub BUILD ($self, @args) {
+    $self->SUPER::BUILD(@args);
+
+    weaken($self);
+    $self-> add_check_content( sub { $self->check_unused_licenses(@_);} )
+}
+
+sub check_idx {
+    my $self = shift;
+
+    my %args      = @_ > 1 ? @_ : ( index => $_[0] );
+    my $idx       = $args{index};
+    my $silent    = $args{silent} || 0;
+    my $check     = $args{check} || 'yes';
+    my $apply_fix = $args{fix} // $check eq 'fix' ? 1 : 0;
+
+    my $has_error =  $self->SUPER::check_idx(%args);
+
+    return $has_error if $self->instance->initial_load;
+    # not called after initial load if idx os not modified... is that a global 
check ?
+
+    my $unused_licenses = $self->_get_unused_licenses($idx);
+    if ($check eq 'yes' and $unused_licenses->{$idx}) {
+        if ($apply_fix) {
+            say "Deleting unused $idx license" unless $silent;
+            $self->delete($idx);
+        }
+        else {
+            $self->{warning_hash}{$idx} //= [];
+            my $warn = "License $idx is not used in Files: section";;
+            push $self->{warning_hash}{$idx}->@*, $warn;
+            warn "$warn\n" unless $silent;
+        }
+    }
+
+
+    return $has_error;
+}
+
+# TODO: move global check from Copyright to here ?
+
+sub _get_unused_licenses ($self, @licenses) {
+    my @to_check = scalar @licenses ? @licenses : $self->fetch_all_indexes;
+
+    my %unused = map { $_ => 1 } @to_check;
+    foreach my $path ($self->grab('- Files')->fetch_all_indexes) {
+        my $lic = $self->grab(qq!- Files:"$path" License!);
+
+        next if $lic->fetch_element_value("full_license"); # no need of a 
global License
+
+        my $names = $lic->fetch_element_value("short_name") ;
+        my @sub_licenses = split /[,\s]+(or|and)[,\s]+/,$names;
+        map { delete $unused{$_}; } @sub_licenses;
+    }
+
+    return \%unused;
+}
+
+sub check_unused_licenses ($self,$error, $warn, $fix = 0, $silent = 0) {
+
+    my @unused = sort keys $self->_get_unused_licenses()->%*;
+
+    return unless @unused;
+
+    if ($fix) {
+        say "Deleting unused license: @unused" unless $silent;
+        foreach my $lic (@unused) {
+            $self->delete("$lic");
+        }
+    }
+    else {
+        my $msg =  "Unused license: @unused";
+        push $warn->@*, $msg;
+    }
+}
+
+1;
diff --git a/lib/Config/Model/models/Dpkg/Copyright.pl 
b/lib/Config/Model/models/Dpkg/Copyright.pl
index 3a71c92..aca19b2 100644
--- a/lib/Config/Model/models/Dpkg/Copyright.pl
+++ b/lib/Config/Model/models/Dpkg/Copyright.pl
@@ -196,6 +196,7 @@ See L<files pattern 
documentation|https://www.debian.org/doc/packaging-manuals/c
           'config_class_name' => 'Dpkg::Copyright::LicenseSpec',
           'type' => 'node'
         },
+        'class' => 'Config::Model::Dpkg::Copyright::License',
         'index_type' => 'string',
         'type' => 'hash'
       },
diff --git a/t/model_tests.d/dpkg-copyright-examples/unused-license 
b/t/model_tests.d/dpkg-copyright-examples/unused-license
new file mode 100644
index 0000000..5ccfb8a
--- /dev/null
+++ b/t/model_tests.d/dpkg-copyright-examples/unused-license
@@ -0,0 +1,33 @@
+Format-specification: 
http://svn.debian.org/wsvn/dep/web/deps/dep5.mdwn?op=file&amp;rev=135
+Name: SOFTware
+Maintainer: John Doe <john....@example.com>
+Source: http://www.example.com/software/project
+License: GPL-2+
+
+Files: src/js/editline/*
+Copyright: 1993, John Doe
+           1993, Joe Average
+License: GPL-2+ or LGPL-2.1+
+
+Files: src/js/editline/foo
+Copyright: 1993, John Doe
+           1993, Joe Average
+License: blah
+ blah blah
+
+Files: src/js/editline/bar
+Copyright: 1993, John Doe
+           1993, Joe Average
+License: GPL-3
+
+License: MPL-1.1
+ [MPL-1.1 LICENSE TEXT]
+
+License: GPL-2+
+ [GPL-2 LICENSE TEXT]
+
+License: LGPL-2.1+
+ [LGPL-2.1 plus LICENSE TEXT]
+
+License: GPL-3
+ [GPL-3 LICENSE TEXT]
diff --git a/t/model_tests.d/dpkg-copyright-test-conf.pl 
b/t/model_tests.d/dpkg-copyright-test-conf.pl
index 0a672b9..f532d80 100644
--- a/t/model_tests.d/dpkg-copyright-test-conf.pl
+++ b/t/model_tests.d/dpkg-copyright-test-conf.pl
@@ -141,6 +141,7 @@ $skip = ( $@ or not -r '/etc/debian_version') ? 1 : 0 ;
     },
 
     { # t11 Debian bug #610231
+        # i.e. how to handle a file with missing info
         load_warnings => [  qr/insecure/, qr/Format does not match/ ],
         apply_fix => 1,
         dump_errors =>  [ 
@@ -323,6 +324,24 @@ in ‘/usr/share/common-licenses/GPL-1’.",
           'License:BSD-like text' => 'yada',
         }
     },
+    {
+        name => 'unused-license',
+        load_warnings => [ (qr/deprecated/) x 3 , qr/Unused global license/],
+        apply_fix => 1,
+
+        check_before_fix => {
+            'License:"MPL-1.1" text'     => "[MPL-1.1 LICENSE TEXT]",
+        },
+
+        has_not_key => [ 'License' => 'MPL-1.1' ],
+        check => {
+            'License:"GPL-2+" text'    => "[GPL-2 LICENSE TEXT]",
+            'License:"LGPL-2.1+" text' => "[LGPL-2.1 plus LICENSE TEXT]",
+            'Files:"src/js/editline/*" License short_name' =>
+              "GPL-2+ or LGPL-2.1+"
+        },
+
+    },
 );
 
 1;

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

_______________________________________________
Pkg-perl-cvs-commits mailing list
Pkg-perl-cvs-commits@lists.alioth.debian.org
http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/pkg-perl-cvs-commits

Reply via email to