[libconfig-model-dpkg-perl] 10/13: Copyright update: can replace old directory 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 7295ea5d9c0a54d1494b30f450c9ced43e539d70
Author: Dominique Dumont <dod at debian.org>
Date:   Wed May 20 18:42:34 2015 +0200

    Copyright update: can replace old directory entries
---
 lib/Config/Model/Dpkg/Copyright.pm |  4 ++--
 lib/Dpkg/Copyright/Scanner.pm      | 10 ++++++++--
 2 files changed, 10 insertions(+), 4 deletions(-)

diff --git a/lib/Config/Model/Dpkg/Copyright.pm b/lib/Config/Model/Dpkg/Copyright.pm
index d3cad02..86ca0d9 100644
--- a/lib/Config/Model/Dpkg/Copyright.pm
+++ b/lib/Config/Model/Dpkg/Copyright.pm
@@ -95,7 +95,7 @@ sub update ($self, %args) {
     # * %old_split_files contains paths no longer present. Useful to trace deleted files
     # implode files entries with same data index
 
-    __squash(\%new_split_files) ;
+    __squash(\%new_split_files, \%old_split_files) ;
 
     # pack files by copyright id
     my @packed = __pack_files(\%new_split_files);
@@ -168,7 +168,7 @@ sub update ($self, %args) {
 
     # warn about old files
     foreach my $old_path (sort keys %old_split_files) {
-        # put back data matching an existing dir
+        # put back data matching an existing dir (data may be redundant or obsolete though)
         if ($old_path eq '*' or ($old_path =~ m!(.*)/\*$! and $current_dir->is_dir($1))) {
             say "Note: preserving entry '$old_path'";
             $files_obj->fetch_with_id($old_path)->load_data( $old_split_files{$old_path} );
diff --git a/lib/Dpkg/Copyright/Scanner.pm b/lib/Dpkg/Copyright/Scanner.pm
index f1e1db5..b9e2a05 100644
--- a/lib/Dpkg/Copyright/Scanner.pm
+++ b/lib/Dpkg/Copyright/Scanner.pm
@@ -339,7 +339,7 @@ sub __coalesce_copyright_years($entries, $owners) {
 
 # $h is a tree of hash matching the directory structure. Each leaf is a
 # copyright id.
-sub __squash ($h) {
+sub __squash ($h, $old_dirs = {}, $path = [] ) {
     my %count ;
 
     # count the number of times each (c) info is used in this directory.
@@ -349,7 +349,7 @@ sub __squash ($h) {
         if (ref($item)) {
             # squash may return a plain id, or a hash with '*' => id ,
             # or a non squashable hash
-            $h->{$name} = __squash($item);
+            $h->{$name} = __squash($item, $old_dirs, [ $path->@*, $name ]);
         }
         my $id = (ref($item) and defined $item->{'*'}) ? $item->{'*'} : $item ;
 
@@ -390,6 +390,12 @@ sub __squash ($h) {
     # here's the '*' file representing the most used (c) info
     $h->{'*'} //= $max_id if defined $max_id;
 
+    # delete current directory entry
+    my $dir_path = join('/', $path->@*,'*');
+    if ($old_dirs->{$dir_path}) {
+        say "Removing old entry $dir_path";
+        delete $old_dirs->{$dir_path};
+    }
     return $h;
 }
 

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