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 e67ae2301bd4c792386f8e514326c3214d768be1 Author: Dominique Dumont <d...@debian.org> Date: Mon Dec 15 21:20:50 2014 +0100 Moved file scanner into its own module --- lib/Config/Model/Dpkg/Copyright.pm | 154 +-------------------- .../Copyright.pm => Dpkg/Copyright/Scanner.pm} | 33 ++--- 2 files changed, 18 insertions(+), 169 deletions(-) diff --git a/lib/Config/Model/Dpkg/Copyright.pm b/lib/Config/Model/Dpkg/Copyright.pm index 32cf7dd..b33edca 100644 --- a/lib/Config/Model/Dpkg/Copyright.pm +++ b/lib/Config/Model/Dpkg/Copyright.pm @@ -13,32 +13,14 @@ no warnings qw/experimental::postderef experimental::signatures/; use base qw/Config::Model::Node/; -say "Loaded"; +use Dpkg::Copyright::Scanner qw/scan_files/; -# license and copyright sanitisation pilfered from Jonas's licensecheck2deb -# hence this file is GPL-2+ not LGPL-2.1+ - -# Copyright 2014 Dominique Dumont <d...@debian.org> -# Copyright © 2005-2012 Jonas Smedegaard <d...@jones.dk> -# Description: Reformat licencecheck output to copyright file format -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License as -# published by the Free Software Foundation; either version 2, or (at -# your option) any later version. -# -# This program is distributed in the hope that it will be useful, but -# WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -# General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program. If not, see <http://www.gnu.org/licenses/>. +say "Loaded"; sub update { my ($self) = @_; - my @copyright_data = scan(); + my @copyright_data = scan_files(); foreach my $data (@copyright_data) { my ($paths, $c, $l) = $data->@*; @@ -54,136 +36,6 @@ sub update { return ''; # improve returned message ? } -sub scan { - my $pipe = IO::Pipe->new(); - $pipe->reader("licensecheck --copyright -m -r ."); - - 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"; - next; - } ; - $f =~ s!\./!!; - $l =~ s/([*?\\])/\\$1/g; - $l =~ s/\s*\(unversioned\/unknown version\)//; - $l =~ s/\s*\(with incorrect FSF address\)//; - $l =~ s/\s+\(v([^)]+) or later\)/-$1+/; - $l =~ s/\s+\(v([^)]+)\)/-$1/; - $l =~ s/^\s*(GENERATED FILE)/UNKNOWN/; - $l =~ s/\s+(GENERATED FILE)//; - $l =~ s/^\s*zlib\/libpng$/Zlib/; - $l =~ s/^\s*MIT\/X11 \(BSD like\)$/Expat/; - $l =~ s/^\s*BSD \((\d) clause\)$/BSD-$1-clause/; - $c =~ s/'//g; - $c =~ s/^©\s*//; - $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 = $copyrights{$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; - } - - 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 ] ; - } - } - - say "grouping"; - # regroup %files hash: all leaves have same id -> wild card - use XXX; - - 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('/',@path,$file); - } - else { - push @$pack, [ $id, join('/',@path,$file) ] ; - } - $old_id = $id; - } -} - -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__ diff --git a/lib/Config/Model/Dpkg/Copyright.pm b/lib/Dpkg/Copyright/Scanner.pm similarity index 90% copy from lib/Config/Model/Dpkg/Copyright.pm copy to lib/Dpkg/Copyright/Scanner.pm index 32cf7dd..8a23dea 100644 --- a/lib/Config/Model/Dpkg/Copyright.pm +++ b/lib/Dpkg/Copyright/Scanner.pm @@ -1,19 +1,23 @@ -# ABSTRACT: Fill the File sections of debian/copyright file +# ABSTRACT: Scan fiels to provide copyright data -package Config::Model::Dpkg::Copyright ; +package Dpkg::Copyright::Scanner ; use strict; use warnings; use 5.20.0; use IO::Pipe; +use Exporter::Lite; use feature qw/postderef signatures/; no warnings qw/experimental::postderef experimental::signatures/; -use base qw/Config::Model::Node/; +our @EXPORT = qw(scan_files get_copyright); + +my $whitespace_list_delimiter = $ENV{'whitespace_list_delimiter'} || "\n "; +my $rfc822_list_delimiter = $ENV{'rfc822_list_delimiter'} || "\n "; +my $merge_same_license = $ENV{'merge_same_license'} || ""; -say "Loaded"; # license and copyright sanitisation pilfered from Jonas's licensecheck2deb # hence this file is GPL-2+ not LGPL-2.1+ @@ -35,26 +39,19 @@ say "Loaded"; # You should have received a copy of the GNU General Public License # along with this program. If not, see <http://www.gnu.org/licenses/>. -sub update { - my ($self) = @_; - - my @copyright_data = scan(); +sub get_copyright { + my @copyright_data = scan_files(); 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" ! ); + say "Files: ", join($whitespace_list_delimiter, $paths->@* ); + say "Copyright: $c"; + say "License: $l"; + say ""; } - - # Fill also licence text if not present ? - - - return ''; # improve returned message ? } -sub scan { +sub scan_files { my $pipe = IO::Pipe->new(); $pipe->reader("licensecheck --copyright -m -r ."); -- 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