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 61c85b545d6e01b6403860b7aface8bc46553909 Author: Dominique Dumont <d...@debian.org> Date: Tue Mar 10 20:35:45 2015 +0100 C::M::Dpkg::Copyright: update can now start from scratch --- lib/Config/Model/Dpkg/Copyright.pm | 83 ++++++++++++++++++++++++++------------ 1 file changed, 58 insertions(+), 25 deletions(-) diff --git a/lib/Config/Model/Dpkg/Copyright.pm b/lib/Config/Model/Dpkg/Copyright.pm index 5039e6e..af9bb73 100644 --- a/lib/Config/Model/Dpkg/Copyright.pm +++ b/lib/Config/Model/Dpkg/Copyright.pm @@ -22,7 +22,7 @@ sub update ($self) { my %old_files; my %old_split_files; - # load existing path data to remove duplicates + # load existing path data to remove duplicates later foreach my $f ($self->grab("Files")->fetch_all_indexes) { my @paths = sort split /\s+/,$f; $old_files{"@paths"} = [ \$f, $f ]; @@ -34,9 +34,10 @@ sub update ($self) { weaken($old_files{"@paths"}[0]); } + my %license_short_name; foreach my $data (@copyright_data) { my ($paths, $c, $l) = $data->@*; - #say "load '@$paths->[0]' with '$c' '$l'"; + say "load '@$paths' with '$c' ('$l')"; # remove paths from old stuff that are found in current list delete $old_files{ join (' ', sort @$paths)} ; @@ -46,31 +47,39 @@ sub update ($self) { my $c_obj = $self->grab( qq!Files:"@$paths"!); $c_obj->load(qq!Copyright="$c"!); - my $short_obj = $c_obj->grab( qq!License short_name!); - - # skip when file contains actual information and extracted - # license is unknown - next if $l eq 'UNKNOWN' and $short_obj->fetch(); - - # handle the case where license is something like GPL-2 or GPL-3 - foreach my $sub_l (split / or /, $l) { - my $license_object ; - eval { - $license_object = Software::LicenseUtils->new_from_short_name( { - short_name => $sub_l, - holder => 'X. Ample' - }) ; - }; - if ($license_object) { - $self->load(qq!License:$sub_l!); - } - } - $short_obj->store($l); + my $lsn = $license_short_name{$l} ||=[]; + push @$lsn, $paths; + } + + foreach my $l (sort keys %license_short_name) { + my $pathset = $license_short_name{$l}; - if ($short_obj->has_error) { - my $text="Please fill license $l from header of ".$paths->[0]; - $c_obj->load(qq!License full_license="$text" short_name="$l"!); + # 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)"; + $self->load( qq!Files:"@$paths" License short_name="$l"!); + } + } + else { + # single license, enter text directly below Files + foreach my $paths (@$pathset) { + my $lic_obj = $self->grab( qq!Files:"@$paths" License!); + + # skip when file contains actual information and extracted + # license is unknown + my $current_name = $lic_obj->grab("short_name")->fetch( check => 'no') //''; + say "Single license $l for path @$paths (current '$current_name')"; + next if $l eq 'UNKNOWN' and $current_name; + + say "load '@$paths' with '$l' (single)"; + $lic_obj->load( qq!full_license="$text" short_name="$l"!); + } } } @@ -118,6 +127,30 @@ sub update ($self) { return ''; # improve returned message ? } +sub fill_global_license ($self, $l, $text) { + + say "Adding global license $l"; + # handle the case where license is something like GPL-2 or GPL-3 + my @names = $l =~ / or / ? split / or /, $l : ($l); + + # try to fill text of a known license + foreach my $name (@names) { + my $license_object ; + eval { + $license_object = Software::LicenseUtils->new_from_short_name( { + short_name => $name, + holder => 'X. Ample' + }) ; + }; + if ($license_object) { + $self->load(qq!License:$name!); # model will fill the text + } + else { + $self->load(qq!License:$name text:"$text"!); + } + } +} + 1; __END__ -- 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