[libconfig-model-dpkg-perl] 06/27: Moved file scanner into its own module

dod at debian.org dod at debian.org
Mon Jan 12 07:09:47 UTC 2015


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 <dod at 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 <dod at debian.org>
-# Copyright © 2005-2012 Jonas Smedegaard <dr at 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('/', at path,$file);
-        }
-        else {
-            push @$pack, [ $id, join('/', at 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



More information about the Pkg-perl-cvs-commits mailing list