[libconfig-model-dpkg-perl] 01/01: added unused license check live
dod at debian.org
dod at debian.org
Fri Jul 29 16:24:15 UTC 2016
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 <dod at 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&rev=135
+Name: SOFTware
+Maintainer: John Doe <john.doe at 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
More information about the Pkg-perl-cvs-commits
mailing list