[libconfig-model-dpkg-perl] 05/27: squash and pack copyright both work

[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 608c3464a2ad3cc50c7e1202e69e5020cc5845c2
Author: Dominique Dumont <dod at debian.org>
Date:   Mon Dec 15 20:54:33 2014 +0100

    squash and pack copyright both work
---
 lib/Config/Model/Dpkg/Copyright.pm | 70 ++++++++++++++++++++++++++++++++------
 1 file changed, 60 insertions(+), 10 deletions(-)

diff --git a/lib/Config/Model/Dpkg/Copyright.pm b/lib/Config/Model/Dpkg/Copyright.pm
index 0d77c01..32cf7dd 100644
--- a/lib/Config/Model/Dpkg/Copyright.pm
+++ b/lib/Config/Model/Dpkg/Copyright.pm
@@ -13,7 +13,7 @@ no warnings qw/experimental::postderef experimental::signatures/;
 
 use base qw/Config::Model::Node/;
 
-
+say "Loaded";
 
 # license and copyright sanitisation pilfered from Jonas's licensecheck2deb
 # hence this file is GPL-2+ not LGPL-2.1+
@@ -38,16 +38,33 @@ use base qw/Config::Model::Node/;
 sub update {
     my ($self) = @_;
 
+    my @copyright_data = scan();
+
+    foreach my $data (@copyright_data) {
+        my ($paths, $c, $l) = $data->@*;
+        # load in preset mode ???
+        # add option to clean Files entries so preset is always used ??
+        # perform a ma
+        $self->load( qq!Files:"@$paths" Copyright="$c" License short_name="$l" ! );
+    }
 
+    # Fill also licence text if not present ?
+
+
+    return ''; # improve returned message ?
+}
+
+sub scan {
     my $pipe = IO::Pipe->new();
     $pipe->reader("licensecheck --copyright -m -r .");
 
-    my %cop ;
+    my %copyrights ;
     my $files = {};
     my $id = 0;
 
     while(my $line = $pipe->getline) {
         chomp $line;
+        say "found: $line";
         my ($f,$l,$c) = split /\t/, $line; 
         if ($c =~ /^\*No/) {
             say "no info for $f, check manually this file";
@@ -69,7 +86,7 @@ sub update {
         $c =~ s/(?<=\b\d{4})\s*-\s*\d{4}(?=\s*-\s*(\d{4})\b)//g;
         $c =~ s/\b(\d{4}),?\s+([\S^\d])/$1, $2/g;
 
-        my $a = $cop{$c}{$l} //= $id++;
+        my $a = $copyrights{$c}{$l} //= $id++;
         # split file path and fill recursive hash, leaf is id
         my @path = split m!/!,$f;
         my $file = pop @path;
@@ -78,17 +95,50 @@ sub update {
         $tmp->{$file} = $a;
     }
 
-    foreach my $c (keys %cop) {
-        foreach my $l (keys $cop{$c}->%* ) {
-            my $f = $cop{$c}{$l};
-            $self->load( qq(! Files:"@$f" Copyright="$c" License short_name="$l" ) );
+    my @copyrights_by_id ;
+    foreach my $c (keys %copyrights) {
+        foreach my $l (keys $copyrights{$c}->%* ) {
+            my $id = $copyrights{$c}{$l};
+            $copyrights_by_id[$id] = [ $c, $l ] ;
         }
     }
 
-    # Fill also licence text if not present ?
+    say "grouping";
+    # regroup %files hash: all leaves have same id -> wild card
+    use XXX;
 
-    $self->load( " ! Files:.sort " );
-    return ''; # improve returned message ?
+    my $squashed = WWW  __squash(WWW $files);
+
+    # pack files by copyright id
+    my @packed;
+    __pack($files,\@packed);
+
+    my @copyright_data;
+
+    foreach my $p (@packed) {
+        my ($id, @paths) = $p->@*;
+        my ($c,$l) = $copyrights_by_id[$id]->@*;
+        push @copyright_data, [ \@paths, $c, $l ];
+    }
+
+    return @copyright_data;
+}
+
+sub __pack ($h, $pack, @path) {
+    my $old_id ;
+    foreach my $file (sort keys %$h) {
+        my $id = $h->{$file};
+        if (ref($id)) {
+            __pack($id, $pack, @path, $file) ;
+        }
+        elsif (defined $old_id and $old_id == $id ) {
+            push $pack->[$#$pack]->@*, join('/', at path,$file);
+        }
+        else {
+            push @$pack, [ $id, join('/', at path,$file) ] ;
+        }
+        $old_id = $id;
+    }
 }
 
 sub __squash ($h) {

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