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 d6219e449876520f027db5d7c14d1c1b658a2a75
Author: Dominique Dumont <d...@debian.org>
Date:   Fri Mar 27 20:33:41 2015 +0100

    Copyright update: mostly rewritten...
---
 lib/Config/Model/Dpkg/Copyright.pm | 175 ++++++++++++++++++-------------------
 lib/Dpkg/Copyright/Scanner.pm      |  16 ++--
 t/model_tests.d/dpkg-test-conf.pl  |   3 +-
 3 files changed, 97 insertions(+), 97 deletions(-)

diff --git a/lib/Config/Model/Dpkg/Copyright.pm 
b/lib/Config/Model/Dpkg/Copyright.pm
index 10c28a0..41c3b4e 100644
--- a/lib/Config/Model/Dpkg/Copyright.pm
+++ b/lib/Config/Model/Dpkg/Copyright.pm
@@ -11,8 +11,10 @@ no warnings qw/experimental::postderef 
experimental::signatures/;
 
 use base qw/Config::Model::Node/;
 use Path::Tiny;
+use Data::Dumper;
 
-use Dpkg::Copyright::Scanner qw/scan_files/;
+use Config::Model::DumpAsData;
+use Dpkg::Copyright::Scanner qw/scan_files __squash __pack_files/;
 use Software::LicenseUtils;
 use Scalar::Util qw/weaken/;
 
@@ -30,124 +32,118 @@ sub normalize_path ($self,$path) {
     return $self->get_joined_path(\@paths);
 }
 
+my $dumper = Config::Model::DumpAsData->new;
+
 # $args{in} can contains the output of licensecheck (for tests)
 sub update ($self, %args) {
 
     my @copyright_data = scan_files( %args );
 
-    my %old_files;
+    my $files_obj = $self->grab("Files");
+
+    # explode existing path data to track deleted paths
     my %old_split_files;
+    my %debian_paths;
+    foreach my $paths_str ($files_obj->fetch_all_indexes) {
+        my $node = $files_obj->fetch_with_id($paths_str) ;
+        my $data = $dumper->dump_as_data( node => $node );
 
-    # load existing path data to remove duplicates later
-    foreach my $raw_f ($self->grab("Files")->fetch_all_indexes) {
-        my $f = $self->normalize_path($raw_f);
-        if ($raw_f ne $f) {
-            # normalise existing path
-            $self->grab("Files")->move($raw_f,$f);
+        if ($paths_str =~ m!^debian/!) {
+            $debian_paths{$paths_str} = $data;
         }
-        $old_files{$f} = [ \$f, $f ];
-        foreach my $path ($self->split_path($f)) {
-            next if $path =~ /\*/;
-            $old_split_files{$path} = \$f ;
+        else {
+            foreach my $path ($self->split_path($paths_str)) {
+                $old_split_files{$path} = $data ;
+            }
         }
-        # the weakened ref will vanish if all ref to $f are removed from 
%old_split_files
-        weaken($old_files{$f}[0]);
     }
 
-    my %license_short_name;
+    # explode new data and merge with existing entries
+    my %new_split_files;
+    my @data;
+    my %data_keys;
     foreach my $data (@copyright_data) {
         my ($paths, $c, $l) = $data->@*;
         #say "load '@$paths' with '$c' ('$l')";
 
-        next if $c eq 'no-info-found';
+        foreach my $path (@$paths) {
+            my $new_data = delete $old_split_files{$path} || {} ;
+            # clobber old data
+            $new_data->{Copyright} = $c unless $c eq 'no-info-found';
+            $new_data->{License}{short_name} = $l unless $l eq 'UNKNOWN';
+
+            # create an inventory of different file copyright and license data
+            my $dumper = Data::Dumper->new([$new_data])->Sortkeys(1);
+            my $datum_dump = $dumper->Dump;
+            my $d_key;
+            if (not $d_key = $data_keys{$datum_dump}) {
+                push @data,$new_data;
+                $data_keys{$datum_dump} = $d_key = $#data;
+            }
 
-        # remove paths from old stuff that are found in current list
-        my $norm_path_str = $self->normalize_path($paths);
-        delete $old_files{ $norm_path_str };
-        map { delete $old_split_files{$_} } @$paths;
+            # explode path in subpaths
+            my @subpaths = split '/', $path;
+            my $h = \%new_split_files;
+            my $last = pop @subpaths;
+            map { $h = $h->{$_} ||= {} } @subpaths ;
+            $h->{$last} = $d_key;
+        }
+    }
 
-        $self->load(qq!Files:"$norm_path_str" Copyright="$c"!);
+    # at this point:
+    # * @data contains a list of copyright/license data
+    # * %new_split_files contains a tree matching a directory tree where each 
leaf 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
 
-        my $lsn = $license_short_name{$l} ||=[];
-        push @$lsn, $paths;
-    }
+    # implode files entries with same data index
+    __squash(\%new_split_files) ;
 
-    foreach my $l (sort keys %license_short_name) {
-        my $pathset = $license_short_name{$l};
+    # pack files by copyright id
+    my @packed = __pack_files(\%new_split_files);
 
-        # FIXME: add boilerplate to trigger warning in model
-        my $text = "Please fill license $l from header of " . $pathset->[0][0];
-
-        if ($l ne 'UNKNOWN' and @$pathset > 1) {
-            # use a global license, *then* add short_name info in each Files 
section
-            $self->fill_global_license($l, $text);
-            foreach my $paths (@$pathset) {
-                #say "load '@$paths' with '$l' (global)";
-                my $norm_path_str = $self->normalize_path($paths);
-                $self->load( qq!Files:"$norm_path_str" License 
short_name="$l"!);
-            }
-        }
-        else {
-            # single license, enter text directly below Files
-            foreach my $paths (@$pathset) {
-                my $norm_path_str = $self->normalize_path($paths);
-                my $lic_obj = $self->grab(qq!Files:"$norm_path_str" License!);
+    # delete existing data in config tree
+    $files_obj->clear;
 
-                # skip when file contains actual information and extracted
-                # license is unknown
-                my $current_name = 
$lic_obj->fetch_element("short_name")->fetch( check => 'no') //'';
-                #say "Single license $l for path @$paths (current 
'$current_name')";
-                next if $l eq 'UNKNOWN' and $current_name;
+    # load new data in config tree
+    foreach my $p (@packed) {
+        my ($id, @paths) = $p->@*;
+        my $datum = $data[$id];
+        my $path_str = $self->normalize_path(\@paths);
+        my $l = $datum->{License}{short_name};
 
-                # skip if full_license is already provided in Files section
-                next if $current_name eq $l and 
$lic_obj->grab_value('full_license');
+        next unless $l ;
 
-                # skip if all licenses are provided in global license section
-                my $ok = 0;
-                my $global_lic = $lic_obj->grab('- - License');
-                my $size = map { $ok++ if $global_lic->defined($_) ; } split 
/\s+or\s+/,$l;
+        # FIXME: add boilerplate to trigger warning in model
+        my $text = "Please fill license $l from header of " . $paths[0];
 
-                if ($ok ne $size) {
-                    say "Adding dummy license text for license $l for path 
@$paths";
-                    $lic_obj->load( qq!full_license="$text"!);
-                }
+        my $norm_path_str = $self->normalize_path(\@paths);
 
-                $lic_obj->load( qq!short_name="$l"!);
+        # if full_license is not provided in datum, check global license(s)
+        if (not $datum->{License}{full_license}) {
+            my $ok = 0;
+            my $size = map {
+                $ok++ if $self->grab_value(qq!License:"$_" text!) ;
+            } split /\s+or\s+/,$l;
 
+            if ($ok ne $size) {
+                say "Adding dummy license text for license $l for path @paths";
+                $datum->{License}{full_license} = $text;
             }
+
         }
 
+        $files_obj->fetch_with_id($path_str)->load_data( $datum );
     }
 
-    # 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\n]+/,$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 = $self->normalize_path(\@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);
-            }
-       }
+    # 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} );
+    }
+
+    # warn about old files
+    foreach my $old_path (sort keys %old_split_files) {
+        say "Note: $old_path was removed from new upstream source";
     }
 
     # read a debian/fix.scanned.copyright file to patch scanned data
@@ -156,7 +152,7 @@ sub update ($self, %args) {
     if ($debian->is_dir) {
         $debian->children(qr/fix\.scanned\.copyright$/);
         my @fixes = 
$current_dir->child('debian')->children(qr/fix\.scanned\.copyright$/);
-        say "Found @fixes files for copyright fixes" if @fixes;
+        say "Note: Found @fixes files for copyright fixes" if @fixes;
         foreach my $fix ( @fixes) {
             my @l = grep { /[^\s]/ } grep { ! m!^(#|//)!  } $fix->lines_utf8;
             chomp @l;
@@ -171,6 +167,7 @@ sub update ($self, %args) {
     return ''; # improve returned message ?
 }
 
+
 sub fill_global_license ($self, $l, $text) {
 
     #say "Adding global license $l";
diff --git a/lib/Dpkg/Copyright/Scanner.pm b/lib/Dpkg/Copyright/Scanner.pm
index c31d109..df98c1c 100644
--- a/lib/Dpkg/Copyright/Scanner.pm
+++ b/lib/Dpkg/Copyright/Scanner.pm
@@ -311,13 +311,15 @@ sub __squash ($h) {
         }
     }
 
-    # find the most used (c) info in this directory
+    # find the most used (c) info in this directory (or the existing '*' entry)
     my $max = 0;
-    my $max_id;
-    foreach my $id (sort keys %count) {
-        if ($count{$id} > $max) {
-            $max = $count{$id};
-            $max_id = $id ;
+    my $max_id = $h->{'*'};
+    if (not defined $max_id) {
+        foreach my $id (sort keys %count) {
+            if ($count{$id} > $max) {
+                $max = $count{$id};
+                $max_id = $id ;
+            }
         }
     }
 
@@ -337,7 +339,7 @@ sub __squash ($h) {
         }
     }
     # here's the '*' file representing the most used (c) info
-    $h->{'*'} = $max_id if defined $max_id;
+    $h->{'*'} //= $max_id if defined $max_id;
 
     return $h;
 }
diff --git a/t/model_tests.d/dpkg-test-conf.pl 
b/t/model_tests.d/dpkg-test-conf.pl
index 567cfc9..18740e5 100644
--- a/t/model_tests.d/dpkg-test-conf.pl
+++ b/t/model_tests.d/dpkg-test-conf.pl
@@ -83,7 +83,8 @@ my $del_home = sub {
             'copyright Files:pan/general/sorted-vector.h Copyright'
             => '2002, Martin Holzherr (holzh...@infobrain.com).',
             'copyright Files:pan/general/sorted-vector.h License short_name' 
=> 'public-domain',
-            qq'copyright Files:"uulib/fptools.c\n uulib/fptools.h" Copyright' 
=> 'Unknown',
+            # entry "uulib/fptools.c\n uulib/fptools.h"is packed by update
+            qq'copyright Files:"uulib/*" Copyright' => 'Unknown',
         },
         wr_check => {
             "copyright License:GPL-2 text" => {value => undef, mode => 
'custom'},

-- 
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

Reply via email to