[libconfig-model-dpkg-perl] 04/27: copyright update: squashing is working

[dod]

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 66f7eee1ea36d1ce53e40cf828a2e3d18d4e40ff
Author: Dominique Dumont <d...@debian.org>
Date:   Wed Dec 10 21:03:37 2014 +0100

    copyright update: squashing is working
---
 lib/Config/Model/Dpkg/Copyright.pm | 58 ++++++++++++++++++++++++++++++++++++--
 1 file changed, 55 insertions(+), 3 deletions(-)

diff --git a/lib/Config/Model/Dpkg/Copyright.pm 
b/lib/Config/Model/Dpkg/Copyright.pm
index 7723b0f..0d77c01 100644
--- a/lib/Config/Model/Dpkg/Copyright.pm
+++ b/lib/Config/Model/Dpkg/Copyright.pm
@@ -43,9 +43,11 @@ sub update {
     $pipe->reader("licensecheck --copyright -m -r .");
 
     my %cop ;
+    my $files = {};
+    my $id = 0;
 
     while(my $line = $pipe->getline) {
-        chomp $line; 
+        chomp $line;
         my ($f,$l,$c) = split /\t/, $line; 
         if ($c =~ /^\*No/) {
             say "no info for $f, check manually this file";
@@ -67,8 +69,13 @@ 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} ||= [];
-        push $a->@* , $f;
+        my $a = $cop{$c}{$l} //= $id++;
+        # split file path and fill recursive hash, leaf is id
+        my @path = split m!/!,$f;
+        my $file = pop @path;
+        my $tmp = $files ;
+        map { $tmp = $tmp->{$_} ||= {};  } @path;
+        $tmp->{$file} = $a;
     }
 
     foreach my $c (keys %cop) {
@@ -84,6 +91,51 @@ sub update {
     return ''; # improve returned message ?
 }
 
+sub __squash ($h) {
+    my %count ;
+
+    foreach my $file (sort keys %$h) {
+        my $id = $h->{$file};
+        if (ref($id)) {
+            # squash may return a plain id, or a hash with '*' => id , or a 
non squashable hash
+            $h->{$file} = __squash($id);
+        }
+        if (ref($id) and defined $id->{'*'}) {
+            $id = $id->{'*'};
+        }
+        # do not count non squashable hashes
+        if (not ref ($id)) {
+            $count{$id}//=0;
+            $count{$id} ++;
+        }
+    }
+
+    my $max = 0;
+    my $max_id;
+    foreach my $id (sort keys %count) {
+        if ($count{$id} > $max) {
+            $max = $count{$id};
+            $max_id = $id ;
+        }
+    }
+
+    foreach my $file (sort keys %$h) {
+        my $id = $h->{$file};
+        if (ref($id) and defined $id->{'*'} and $id->{'*'} == $max_id) {
+            delete $id->{'*'};
+            delete $h->{$file} unless keys $h->{$file}->%*;
+        }
+        if (not ref ($id)) {
+            delete $h->{$file} if $id == $max_id;
+        }
+    }
+    $h->{'*'} = $max_id ;
+
+    return $h;
+}
+
+1;
+
 __END__
 
 =head1 SYNOPSIS

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

_______________________________________________
Pkg-perl-cvs-commits mailing list
Pkg-perl-cvs-commits@lists.alioth.debian.org
http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/pkg-perl-cvs-commits