[libconfig-model-dpkg-perl] 26/27: C::M::D::Copyright: update removes obsolete entries

[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 d8bde411320dc619cdcca03948ab0077c61794b0
Author: Dominique Dumont <dod at debian.org>
Date:   Mon Jan 5 20:56:26 2015 +0100

    C::M::D::Copyright: update removes obsolete entries
---
 lib/Config/Model/Dpkg/Copyright.pm | 55 +++++++++++++++++++++++++++++++++++++-
 1 file changed, 54 insertions(+), 1 deletion(-)

diff --git a/lib/Config/Model/Dpkg/Copyright.pm b/lib/Config/Model/Dpkg/Copyright.pm
index ed5bdce..d9a2bc1 100644
--- a/lib/Config/Model/Dpkg/Copyright.pm
+++ b/lib/Config/Model/Dpkg/Copyright.pm
@@ -16,14 +16,36 @@ use Path::Tiny;
 
 use Dpkg::Copyright::Scanner qw/scan_files/;
 use Software::LicenseUtils;
+use Scalar::Util qw/weaken/;
 
 sub update ($self) {
 
     my @copyright_data = scan_files();
 
+    my %old_files;
+    my %old_split_files;
+    # load existing path data to remove duplicates
+    foreach my $f ($self->grab("Files")->fetch_all_indexes) {
+        my @paths = sort split /\s+/,$f;
+        $old_files{"@paths"} = [ \$f, $f ];
+        foreach my $path (@paths) {
+            next if $path =~ /\*/;
+            $old_split_files{$path} = \$f ;
+        }
+        # the weakened ref will vanish if all ref to $f are removed from %old_split_files
+        weaken($old_files{"@paths"}[0]);
+    }
+
     foreach my $data (@copyright_data) {
         my ($paths, $c, $l) = $data->@*;
-        say "load ",$paths->[0]," $c $l";
+        #say "load '@$paths->[0]' with '$c' '$l'";
+
+        # remove paths from old stuff that are found in current list
+        delete $old_files{ join (' ', sort @$paths)} ;
+        map { delete $old_split_files{$_} } @$paths;
+
+        next if $c eq 'no-info-found';
+
         my $c_obj = $self->grab( qq!Files:"@$paths"!);
         $c_obj->load(qq!Copyright="$c"!);
         my $short_obj = $c_obj->grab( qq!License short_name!);
@@ -55,6 +77,37 @@ sub update ($self) {
 
     }
 
+    # now %old_files contains entries that were not touched by the
+    # found licenses.  either the files were removed, or the path
+    # distributions don't match
+    foreach my $old_sorted_entry (sort keys %old_files) {
+        my ($weak_old_ref, $old_entry) = $old_files{$old_sorted_entry}->@*;
+        next if $old_entry =~ /debian/; # leave debian dir alone
+        if (not defined $weak_old_ref) {
+            # all paths of $old_entry were found but arranged differently
+            say "deleting old entry: '$old_entry'";
+            $self->grab("Files")->delete($old_entry);
+        }
+        else {
+            # %old_split_files contains paths that were not found in the
+            # license process. i.e removed files.
+            my @new_paths;
+            foreach my $path (split /\s+/,$old_sorted_entry) {
+                if (defined $old_split_files{$path}) {
+                    push @new_paths, $path;
+                }
+                else {
+                    say "deleting $path from entry '$old_entry'";
+                }
+            }
+            my $new_path_entry = join(' ', at new_paths);
+            if ($new_path_entry ne $old_sorted_entry) {
+                say "renaming $old_entry in $new_path_entry";
+                $self->grab("Files")->move($old_entry, $new_path_entry);
+            }
+       }
+    }
+
     # read a debian/fix.copyright file to patch scanned data
     my $fix = path('debian')->child('fix-scanned-copyright');
     if ($fix->exists) {

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