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 36db48407045b0ce68bc39b0801927bbd81215bf
Author: Dominique Dumont <d...@debian.org>
Date: Thu Jan 12 13:07:16 2017 +0100
updated copyright parser...
for new data structure provided by DpkgSyntax
---
lib/Config/Model/Backend/Dpkg/Copyright.pm | 208 +++++++++++++++--------------
1 file changed, 105 insertions(+), 103 deletions(-)
diff --git a/lib/Config/Model/Backend/Dpkg/Copyright.pm
b/lib/Config/Model/Backend/Dpkg/Copyright.pm
index 9017678..7d60922 100644
--- a/lib/Config/Model/Backend/Dpkg/Copyright.pm
+++ b/lib/Config/Model/Backend/Dpkg/Copyright.pm
@@ -1,13 +1,21 @@
package Config::Model::Backend::Dpkg::Copyright ;
+use strict;
+use warnings;
+
use Mouse ;
extends 'Config::Model::Backend::Any';
with 'Config::Model::Backend::DpkgSyntax';
+with 'Config::Model::Backend::DpkgStoreRole';
+
+use 5.20.1;
+
+use feature qw/postderef signatures/;
+no warnings qw/experimental::postderef experimental::signatures/;
-use 5.10.1;
use Carp;
use Config::Model::Exception ;
use Config::Model::ObjTreeScanner ;
@@ -19,10 +27,9 @@ my $logger = get_logger("Backend::Dpkg::Copyright") ;
sub suffix { return '' ; }
my %store_dispatch = (
- list => \&_store_line_based_list,
- #string => \&_store_line,
- string => \&_store_text_no_synopsis,
- uniline => \&_store_line,
+ list => 'store_section_list_element',
+ string => 'append_text_no_synopsis',
+ uniline => 'store_section_leaf_element',
);
sub read {
@@ -45,9 +52,9 @@ sub read {
$logger->info("Parsing $args{file_path}");
# load dpkgctrl file
- my $c = $self -> parse_dpkg_file ($args{file_path}, $args{io_handle},
$check, ) ;
+ my $c = $self -> parse_dpkg_file ($args{file_path}, $args{io_handle},
$check ) ;
return 0 unless @$c ; # no sections in file
-
+
my $root = $args{object} ;
my $file;
my %license_paragraph ;
@@ -59,7 +66,7 @@ sub read {
my $header_line_nb = shift @$c ;
my $header_info = shift @$c ;
- my $section_nb = 1 ; # header was already done
+ my $section_nb = 1 ; # header was put aside, so start at 1
while (@$c) {
my ($section_line, $section_ref) = splice @$c, 0, 2;
$section_nb ++ ;
@@ -74,7 +81,7 @@ sub read {
# While this is correct grammatically, it tends to be PITA
if (my $file_section = delete $section{file}) {
warn("copyright line $section_line: section 'File' is converted in
'Files' section (mind the plural)\n");
- $file_section->[2] = 'changed file section into files section' ;
+ $file_section->[0][2] = 'changed file section into files section' ;
$section{files} //= $file_section ; # no clobber of good section
}
@@ -90,34 +97,43 @@ sub read {
warn("$str Adding 'Files: *' spec\n") ;
# the 3rd element is used to tell root node that read data was
# altered and needs to be written back
- $section{files} = [ '*', $section_line, 'created missing File:*
section' ] ;
+ $section{files} = [ ['*', $section_line, 'created missing File:*
section' ] ];
}
if (defined $section{licence}) {
warn("copyright line $section_line: Converting UK spelling for
license in US spelling\n");
$section{license} = delete $section{licence} ;# FIXME: use
notify_change
- $section{license}[2] = 'changed uk spelling for license (was
licence)'; # is altered
- }
+ $section{license}[0][2] = 'changed uk spelling for license (was
licence)'; # is altered
+ }
if (defined $section{files}) {
- my ($v,$l, $a) = @{$section{files}} ;
- if ($logger->is_debug) {
- my $a_str = $a ? "altered: '$a' ":'' ;
- $logger->debug("Found Files paragraph line $l, $a_str($v)");
+ # file_paragragh hash is used to contain file data indexed by file
names
+ # file names may be extracted from several lines in copyright file
+ my @file_keys;
+ foreach my $file_item( $section{files}->@* ) {
+ my ($v,$l, $a) = $file_item->@*;
+ if ($logger->is_debug) {
+ my $a_str = $a ? "altered: '$a' ":'' ;
+ $logger->debug("Found Files paragraph line $l,
$a_str($v)");
+ }
+ if ($v =~ /,/) {
+ $logger->warn("Found comma in Files line $l, cleaning up");
+ $v =~ s/,+/ /g;
+ }
+ $v =~ s/(?<=\w)[ \t]+/ /g; # cleanup spacing between words
+ $v =~ s/\s+$//;
+ push @file_keys, $v;
}
- if ($v =~ /,/) {
- $logger->warn("Found comma in Files line, cleaning up");
- $v =~ s/,+/ /g;
- }
- $v =~ s/(?<=\w)[ \t]+/ /g;
- $v =~ s/[ \t]+\n/\n/g;
- $v =~ s/^\s*|\s*$//g;
- $logger->debug("Files paragraph after cleanup $l: '$v'");
- $file_paragraph{$v} = $section_ref ;
- push @file_names, $v ;
+ # join with \n to keep original lines
+ my $file_key = join("\n", @file_keys);
+ $logger->debug("Files paragraph after cleanup: '$file_key'");
+ $file_paragraph{$file_key} = $section_ref ;
+ push @file_names, $file_key ;
}
elsif (defined $section{license}) {
- my ($v,$l, $a) = @{$section{license}} ;
+ # license_paragragh hash is used to contain license data indexed
by license names
+ # license name contains only one line
+ my ($v,$l, $a) = $section{license}[0]->@* ;
# need to extract license name from license text
my ($lic_name) = ($v =~ /^([^\n]+)/) ;
if (not defined $lic_name) {
@@ -144,7 +160,7 @@ sub read {
$logger->warn("copyright line $section_line: Dropping unknown
paragraph");
}
}
-
+
$logger->info("First pass to read pure license sections from $args{file}
control file");
foreach my $lic_name (@license_names) {
@@ -153,28 +169,26 @@ sub read {
my $section = $license_paragraph{$lic_name} ;
for (my $i=0; $i < @$section ; $i += 2 ) {
my $key = $section->[$i];
- my ($v,$l,$a) = @{$section->[$i+1]};
- $logger->info("reading key $key from $args{file} file line $l
altered $a for ".$object->name);
- $logger->debug("$key value: '$v'");
- my $elt_obj ;
-
+ my $v_ref = $section->[$i+1];
+ my ($v1,$l1,$a1) = $v_ref->[0]->@*;
+ $logger->info("reading key $key from $args{file} file line $l1
altered $a1 for ".$object->name);
+ $logger->debug("$key first line value: '$v1'");
+
if ($key =~ /licen[sc]e/i) {
- my @lic_text = split /\n/,$v ;
- my ($lic_name) = shift @lic_text ;
- $logger->debug("adding license text for '$lic_name':
'@lic_text'");
+ shift $v_ref->@* ; # remove first line that contains $lic_name
+ $logger->debug("adding license text for '$lic_name'");
# lic_obj may not be defined in -force mode
next unless defined $object ;
- $elt_obj = $object->fetch_element('text');
- $elt_obj->store(value => join("\n", @lic_text), check =>
$check) ;
+ my $elt_obj = $object->fetch_element('text');
+ $self-> store_section_leaf_element( $logger, $elt_obj, $check,
$v_ref );
}
else {
# store other sections thanks to 'accept' clause
- $elt_obj = $object->fetch_element($key);
- $elt_obj->store($v) ;
+ my $elt_obj = $object->fetch_element($key);
+ $self-> store_section_leaf_element( $logger, $elt_obj, $check,
$v_ref );
}
- $elt_obj->notify_change(note => $a, really => 1 ) if $a ;
}
}
@@ -184,24 +198,28 @@ sub read {
my @header = @$header_info ;
for (my $i=0; $i < @header ; $i += 2 ) {
my $key = $header[$i];
- my ($v,$l,$a) = @{$header[$i+1]};
+ my $v_ref = $header[$i+1] ;
- $logger->info("reading key $key from header line $l altered $a for
".$object->name);
- $logger->debug("$key value: '$v'");
+ # these represent information from the first line only
+ my ($v1,$l1,$a1) = $v_ref->[0]->@*;
+
+ $logger->info("reading key $key from header line $l1 ". ($a1 ?
"altered $a1 " :''). "for ".$object->name);
+ $logger->debug("$key first line value: '$v1'");
if ($key =~ /^licen[sc]e$/i) {
my $lic_node = $root->fetch_element('Global-License') ;
- _store_license_info ($lic_node, $key, $v, $a, $check);
+ $self->_store_license_info ($lic_node, $key, $check, $v_ref);
}
elsif ( $key eq 'Files' ) {
- die "Error: unexpected 'Files' field in header section of
copyright (line $l). Did you forget the header section?";
+ die "Error: unexpected 'Files' field in header section of
copyright (line $l1). Did you forget the header section?";
}
elsif (my $found = $object->find_element($key, case => 'any')) {
- _store_file_info('Header',$l,$object,$found,$key, $v, $check)
+ $self->_store_file_info('Header',$object,$found,$key, $check,
$v_ref)
}
else {
# try anyway to trigger an error message
- $object->fetch_element($key)->store($v) ;
+ my $unexpected_obj = $root->fetch_element($key);
+ $self->store_section_leaf_element ( $unexpected_obj, $check,
$v_ref);
}
}
@@ -213,24 +231,27 @@ sub read {
my $section = $file_paragraph{$file_name} ;
for (my $i=0; $i < @$section ; $i += 2 ) {
my $key = $section->[$i];
- my ($v,$l,$a) = @{$section->[$i+1]};
- #$v =~ s/^\s+//; # remove all leading spaces
+ my $v_ref = $section->[$i+1] ;
next if $key =~ /^files$/i; # already done just before this loop
- $logger->info("reading key $key from file paragraph '$file_name'
line $l for ".$object->name);
- $logger->debug("$key value: '$v'");
+ # these represent information from the first line only
+ my ($v1,$l1,$a1) = $v_ref->[0]->@*;
+
+ $logger->info("reading key $key from file paragraph '$file_name'
line $l1 for ".$object->name);
+ $logger->debug("$key first line value: '$v1'");
if ($key =~ /^licen[sc]e$/i) {
my $lic_node = $object->fetch_element('License') ;
- _store_license_info ($lic_node, $key, $v, $a, $check);
+ $self->_store_license_info ($lic_node, $key, $check, $v_ref);
}
elsif (my $found = $object->find_element($key, case => 'any')) {
- _store_file_info('File',$l,$object,$found,$key, $v, $check);
+ $self->_store_file_info('File',$object,$found,$key, $check,
$v_ref);
}
else {
# try anyway to trigger an error message
- $object->fetch_element($key)->store($v) ;
+ my $unexpected_obj = $root->fetch_element($key);
+ $self->store_section_leaf_element ( $unexpected_obj, $check,
$v_ref);
}
}
}
@@ -238,27 +259,15 @@ sub read {
return 1 ;
}
-sub _store_line_based_list {
- my ($object,$v,$check) = @_ ;
- my @v = grep {length($_) } split /\s*\n\s*/,$v ;
- $logger->debug("_store_line_based_list with check $check on
".$object->name." = ('".join("','",@v),"')")
- if $logger->is_debug;
- $object->push_x(values => \@v, check => $check);
-}
-
-sub _store_text_no_synopsis {
- my ($object,$v,$check) = @_ ;
- #$v =~ s/^\s*\n// ;
- chomp $v ;
+sub append_text_no_synopsis ($self, $logger_param, $object, $check, $v_ref) {
my $old = $object->fetch(check => 'no');
+ my @new_ref = $v_ref->@*;
if ($old) {
$logger->warn("double entry for ",$object->name,", appending value");
- $v = $old."\n".$v;
+ unshift @new_ref, [ $old, 0, ''];
}
- $logger->debug("_store_text_no_synopsis with check $check on
".$object->name." = '$v'")
- if $logger->is_debug;
- $object->store(value => $v, check => $check) ;
+ $self->store_section_leaf_element($logger_param,$object, $check,
\@new_ref);
}
sub _store_line {
@@ -269,51 +278,44 @@ sub _store_line {
$object->store(value => $v, check => $check) ;
}
-sub _store_file_info {
- my ($section, $l,$object, $target_name,$key, $v, $check) = @_;
-
+sub _store_file_info ($self,$section, $object, $target_name,$key, $check,
$v_ref) {
my $target = $object->fetch_element($target_name) ;
my $type = $target->get_type ;
my $dispatcher = $type eq 'leaf' ? $target->value_type : $type ;
my $f = $store_dispatch{$dispatcher}
- || die "Error in $section section (line $l): unexpected '$key'
field\n";
- $f->($target,$v,$check) ;
- $target->notify_change(note => $a, really => 1 ) if $a ;
+ || die "Error in $section section (line ".$v_ref->[0][1]."):
unexpected '$key' field\n";
+ $self->$f($logger, $target,$check,$v_ref) ;
}
-sub _store_license_info {
- my ( $lic_node, $key, $v, $a, $check ) = @_;
-
- if ( $key =~ /license/ ) {
- $logger->warn( "Found UK spelling for $key: $v. $key will be converted
to License" );
+sub _store_license_info ($self, $lic_node, $key, $check, $v_ref ) {
+ if ( $key =~ /licence/ ) {
+ $logger->warn( "Found UK spelling: $key will be converted to License"
);
$lic_node->notify_change(
- note => 'change uk spelling to us spelling',
+ note => 'change UK spelling to US spelling',
really => 1
);
}
- _store_file_license( $lic_node, $v, $check );
- $lic_node->notify_change( note => $a, really => 1 ) if $a;
+ $self->_store_file_license( $lic_node, $check, $v_ref );
}
-sub _store_file_license {
- my ($lic_object, $v, $check) = @_ ;
+sub _store_file_license ($self, $lic_object, $check, $v_ref) {
- chomp $v ;
- return unless $v =~ /\S/; # skip empty-ish value
- $logger->debug("_store_file_license check $check called on
".$lic_object->name." = $v");
- my ( $lic_line, $lic_text ) = split /\n/, $v, 2 ;
- $lic_line =~ s/\s+$//;
-
- $lic_line =~ s/\s*\|\s*/ or /g; # old way of expressing or condition
- $lic_line ||= 'other' ;
- $logger->debug("license abbrev: $lic_line");
- $logger->debug("license full_license: $lic_text") if $lic_text;
-
- $lic_object->fetch_element('full_license')
- ->store( value => $lic_text, check => $check )
- if $lic_text;
-
- $lic_object->fetch_element('short_name') ->store( value => $lic_line,
check => $check );
+ return unless grep { /\S/ } map {$_->[0]} $v_ref->@*; # skip empty-ish
value
+ my ( $lic_line_ref, @lic_text_ref ) = $v_ref->@*;
+ my $lic_line = $lic_line_ref->[0];
+ $logger->debug("_store_file_license check $check called on
".$lic_object->name);
+
+ $lic_line_ref->[0] =~ s/\s*\|\s*/ or /g; # old way of expressing or
condition
+ $lic_line_ref->[0] ||= 'other' ;
+ $logger->debug("license short_name: ".$lic_line_ref->[0]);
+
+ if (@lic_text_ref) {
+ my $full_obj = $lic_object->fetch_element('full_license');
+ $self->store_section_leaf_element ($logger, $full_obj, $check,
\@lic_text_ref);
+ }
+
+ my $short_name_obj = $lic_object->fetch_element('short_name');
+ $self->store_section_leaf_element ($logger, $short_name_obj, $check, [
$lic_line_ref ]);
}
sub write {
--
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
