[libconfig-model-dpkg-perl] 02/03: remove unused licenses during cme update..

[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 9bc5d07f6cacfc9e496a0b9ee29ba257066a162c
Author: Dominique Dumont <dod at debian.org>
Date:   Fri Jul 22 13:48:44 2016 +0200

    remove unused licenses during cme update..
    
    ... This fix is not perfect. I need to rework it to this prune step
    is available during 'cme fix'
---
 lib/Config/Model/Dpkg/Copyright.pm | 19 +++++++++++++++++++
 1 file changed, 19 insertions(+)

diff --git a/lib/Config/Model/Dpkg/Copyright.pm b/lib/Config/Model/Dpkg/Copyright.pm
index 4c52075..aeaad7e 100644
--- a/lib/Config/Model/Dpkg/Copyright.pm
+++ b/lib/Config/Model/Dpkg/Copyright.pm
@@ -287,6 +287,8 @@ sub update ($self, %args) {
     # normalized again after all the modifications
     $self->load("Files:.sort");
 
+    $self->prune_unused_global_licenses;
+
     $self->instance->clear_changes; # too many changes to show users
     $self->notify_change(note => "updated copyright from source file"); # force a save
 
@@ -301,6 +303,23 @@ sub update ($self, %args) {
     return @msgs;
 }
 
+sub prune_unused_global_licenses ($self) {
+    my %global_license = map { $_ => 1 } $self->fetch_element("License")->fetch_all_indexes;
+
+    foreach my $path ($self->fetch_element('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\s+/,$names;
+        map { delete $global_license{$_}; } @sub_licenses;
+    }
+
+    foreach my $obsolete_lic (sort keys %global_license) {
+        say "Deleting unused global license $obsolete_lic";
+        $self->load(qq!License:-"$obsolete_lic"!);
+    }
+}
+
 sub _apply_fix_scan_copyright_file ($self, $current_dir) {
     # read a debian/fix.scanned.copyright file to patch scanned data
     my $debian = $current_dir->child('debian'); # may be missing in test environment

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