[libconfig-model-dpkg-perl] 02/02: Copyright update: dont remove directory info during 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 d3f3864c95fea916c3e8005bc302cb6306089953
Author: Dominique Dumont <dod at debian.org>
Date:   Thu Jun 25 21:40:46 2015 +0200

    Copyright update: dont remove directory info during update...
---
 lib/Config/Model/Dpkg/Copyright.pm | 60 ++++++++++++++++++++++++++++----------
 1 file changed, 45 insertions(+), 15 deletions(-)

diff --git a/lib/Config/Model/Dpkg/Copyright.pm b/lib/Config/Model/Dpkg/Copyright.pm
index b663792..4f09ad9 100644
--- a/lib/Config/Model/Dpkg/Copyright.pm
+++ b/lib/Config/Model/Dpkg/Copyright.pm
@@ -93,9 +93,30 @@ sub update ($self, %args) {
     #   is an integer index referencing
     #   an entry in @data to get the correct  copyright/license data
     # * %old_split_files contains paths no longer present. Useful to trace deleted files
-    # implode files entries with same data index
 
+    my $current_dir = $args{from_dir} || path('.');
+
+    my %preserved_path;
+    # warn about old files (data may be redundant or obsolete though)
+    foreach my $old_path (sort keys %old_split_files) {
+        # put back data matching an existing dir
+        if ($old_path eq '*' or ($old_path =~ m!(.*)/\*$! and $current_dir->is_dir($1))) {
+            say "Note: preserving entry '$old_path'" ;
+            $preserved_path{$old_path} = delete $old_split_files{$old_path};
+        }
+        else {
+            say "Note: '$old_path' was removed from new upstream source";
+        }
+    }
+
+    $self->_prune_old_dirs(\%new_split_files, \%old_split_files) ;
+
+    YYY \%new_split_files;
+
+    # implode files entries with same data index
     __squash(\%new_split_files) ;
+    say "after __squash";
+    YYY \%new_split_files;
 
     # pack files by copyright id
     my @packed = __pack_files(\%new_split_files);
@@ -159,25 +180,16 @@ sub update ($self, %args) {
             unless $global_lic_obj->fetch_with_id($l)->fetch_element_value('text');
     }
 
+    # put back preserved data
+    foreach my $old_path (sort keys %preserved_path) {
+        $files_obj->fetch_with_id($old_path)->load_data( $preserved_path{$old_path} );
+    }
+
     # put back debian data
     foreach my $deb_path (sort keys %debian_paths) {
         $files_obj->fetch_with_id($deb_path)->load_data( $debian_paths{$deb_path} );
     }
 
-    my $current_dir = $args{from_dir} || path('.');
-
-    # warn about old files
-    foreach my $old_path (sort keys %old_split_files) {
-        # put back data matching an existing dir
-        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} );
-        }
-        else {
-            say "Note: '$old_path' was removed from new upstream source";
-        }
-    }
-
     # read a debian/fix.scanned.copyright file to patch scanned data
     my $debian = $current_dir->child('debian'); # may be missing in test environment
     if ($debian->is_dir) {
@@ -196,6 +208,24 @@ sub update ($self, %args) {
     return ''; # improve returned message ?
 }
 
+sub _prune_old_dirs ($self, $h, $old_dirs, $path = [] ) {
+
+    # recurse in the data structure
+    foreach my $name (sort keys %$h) {
+        my $item = $h->{$name};
+        if (ref($item)) {
+            $self->_prune_old_dirs($item, $old_dirs, [ $path->@*, $name ]);
+        }
+    }
+
+    # 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};
+    }
+}
+
 
 sub fill_global_license ($self, $l, $text) {
 

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