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