[SCM] Debian native package for Config::Model::Dpkg branch, master, updated. debian/2.036-17-gdc3acc3
Dominique Dumont
dod at debian.org
Mon May 20 14:21:14 UTC 2013
The following commit has been merged in the master branch:
commit 55ea532f5ee517a4f36f9e8c064581081666deec
Author: Dominique Dumont <dod at debian.org>
Date: Sun May 19 16:09:00 2013 +0200
Dependency: rewrote grammar to give better error message and skip complex treament
Complex treatment will be handled later outside of the grammar
diff --git a/lib/Config/Model/Dpkg/Dependency.pm b/lib/Config/Model/Dpkg/Dependency.pm
index ab918fa..15b66ea 100644
--- a/lib/Config/Model/Dpkg/Dependency.pm
+++ b/lib/Config/Model/Dpkg/Dependency.pm
@@ -48,42 +48,80 @@ extends qw/Config::Model::Value/ ;
# the dependency value through the value ref ($arg[2])
my $grammar = << 'EOG' ;
-# called with $self,$pending_check,$apply_fix, \@fixed_dep
-check_depend: depend alt_depend(s?) eofile {
- @{$arg[3]} = ($item{depend}, @{$item[2]}) ;
- $arg[0]->check_depend_chain( @arg[1..3] ) ;
- $return = 1;
+{
+ my @dep_errors ;
+ my $add_error = sub {
+ my ($err, $txt) = @_ ;
+ push @dep_errors, "$err: '$txt'" ;
+ return ; # to ensure production error
+ } ;
+}
+
+# comment this out when modifying the grammar
+<nocheck>
+
+dependency: { @dep_errors = (); } <reject>
+
+dependency: depend(s /\|/) eofile {
+ $return = [ 1 , @{$item[1]} ] ;
+ }
+ | {
+ push( @dep_errors, "Cannot parse: '$text'" ) unless @dep_errors ;
+ $return = [ 0, @dep_errors ];
}
depend: pkg_dep | variable
-alt_depend: '|' depend
+alt_depend: '|' depend
# For the allowed stuff after ${foo}, see #702792
variable: /\${[\w:\-]+}[\w\.\-~+]*/
-pkg_dep: pkg_name dep_version arch_restriction(?) {
- # pass dep_version by ref so they can be modified
- my @dep_info = ( $item{pkg_name}, @{ $item{dep_version} } ) ;
- $arg[0]->check_or_fix_dep( @arg[1..2], \@dep_info) ;
- $return = \@dep_info ;
+pkg_dep: pkg_name dep_version(?) arch_restriction(?) {
+ my $dv = $item[2] ;
+ my $ar = $item[3] ;
+ my @ret = ( $item{pkg_name} ) ;
+ if (@$dv and @$ar) { push @ret, @$dv, @$ar ;}
+ elsif (@$dv) { push @ret, @{$dv->[0]} ;}
+ elsif (@$ar) { push @ret, undef, undef, @{$ar->[0]} ;}
+ $return = \@ret ; ;
}
- | pkg_name arch_restriction(?) {
- my @dep_info = ( $item{pkg_name} ) ;
- $arg[0]->check_or_fix_pkg_name(@arg[1..2], \@dep_info) ; # async
- $arg[0]->check_or_fix_essential_package($arg[2], \@dep_info) ;
- $return = \@dep_info ;
- }
-
-arch_restriction: '[' arch(s) ']'
+
+arch_restriction: '[' osarch(s /,/) ']' { $return = $item[2] ;}
+
dep_version: '(' oper version ')' { $return = [ $item{oper}, $item{version} ] ;}
-pkg_name: /[a-z0-9][a-z0-9\+\-\.]+/
+
+pkg_name: /[a-z0-9][a-z0-9\+\-\.]+(?=\s|\Z|\(|\[)/
+ | /\S+/ { $add_error->("bad package name", $item[1]) ;}
+
oper: '<<' | '<=' | '=' | '>=' | '>>'
-version: variable | /[\w\.\-~:+]+/
-eofile: /^\Z/
-arch: not(?) /[\w-]+/
+ | /\S+/ { $add_error->("bad dependency version operator", $item[1]) ;}
+
+version: variable | /[\w\.\-~:+]+(?=\s|\)|\Z)/
+ | /\S+/ { $add_error->("bad dependency version", $item[1]) ;}
+
+# valid arch are listed by dpkg-architecture -L
+osarch: not(?) os(?) arch
+ {
+ $return = ($item[1][0] || '') . ($item[2][0] || '') . $item[3] ;
+ }
+
not: '!'
+os: /(any|uclibc-linux|linux|kfreebsd|knetbsd|kopensolaris|hurd|darwin|freebsd|netbsd|openbsd|solaris|uclinux)
+ -/x
+ | /\w+/ '-' { $add_error->("bad os in architecture specification", $item[1]) ;}
+
+arch: / (any | alpha |amd64 |arm |arm64 |armeb |armel |armhf |avr32
+ |hppa |i386 |ia64 |lpia |m32r |m68k |mips |mipsel |powerpc
+ |powerpcspe |ppc64 |s390 |s390x |sh3 |sh3eb |sh4 |sh4eb |sparc |sparc64 |x32 )
+ (?=\s*\])
+ /x
+ | /\w+/ { $add_error->("bad arch in architecture specification", $item[1]) ;}
+
+
+eofile: /^\Z/
+
EOG
my $parser ;
diff --git a/t/dependency-grammar.t b/t/dependency-grammar.t
new file mode 100644
index 0000000..315ebcd
--- /dev/null
+++ b/t/dependency-grammar.t
@@ -0,0 +1,101 @@
+# -*- cperl -*-
+
+use ExtUtils::testlib;
+use Test::More ;
+use Test::Differences;
+use Config::Model::Dpkg::Dependency ;
+use Log::Log4perl qw(:easy) ;
+use 5.10.0;
+
+use warnings;
+
+use strict;
+
+my $arg = shift || '';
+my ($log,$show,$one) = (0) x 3 ;
+
+use Log::Log4perl qw(:easy) ;
+my $home = $ENV{HOME} || "";
+my $log4perl_user_conf_file = "$home/.log4config-model";
+
+if ($log and -e $log4perl_user_conf_file ) {
+ Log::Log4perl::init($log4perl_user_conf_file);
+}
+else {
+ Log::Log4perl->easy_init($ERROR);
+}
+
+{
+ no warnings qw/once/;
+ $::RD_HINT = 1 if $arg =~ /rdt?h/;
+ $::RD_TRACE = 1 if $arg =~ /rdh?t/;
+}
+
+my $parser = Config::Model::Dpkg::Dependency::dep_parser ;
+
+use XXX -with => 'Data::Dumper';
+
+exit main( @ARGV );
+
+sub main {
+ my @args = @_;
+
+ test_good();
+ test_errors();
+
+ done_testing;
+ return 0;
+}
+
+
+sub test_good {
+ # dep, data struct
+ my @tests = (
+ [ 'foo' , ['foo'] ],
+ [ 'foo | bar ' , ['foo' ], ['bar'] ],
+ [ 'foo | bar | baz ' , ['foo' ], ['bar'], ['baz'] ],
+
+ [ 'foo ( >= 1.24 )| bar ' , ['foo','>=','1.24' ], ['bar'] ],
+ [ 'foo ( >= 1.24 )| bar ( << 1.3a3)' , ['foo','>=','1.24' ], [qw/bar << 1.3a3/] ],
+ [ 'foo(>=1.24)|bar(<<1.3a3) ' , ['foo','>=','1.24' ], [qw/bar << 1.3a3/] ],
+
+ [ 'foo ( >= 1.24 )| bar [ linux-any]' , ['foo','>=','1.24' ], ['bar', undef, undef, 'linux-any'] ],
+
+
+ [ ('${foo}') x 2 ],
+ [ ('${foo}.1-2~') x 2 ],
+ ) ;
+
+ foreach my $td ( @tests ) {
+ my ($dep, at exp) = @$td ;
+ unshift @exp, 1; # match what's returned when there's no errors
+ my $ret = $parser->dependency($dep) ;
+ eq_or_diff ($ret, \@exp,"parsed $dep");
+ }
+}
+
+sub test_errors {
+ my @tests = (
+ [ 'foo@' , q!bad package name: '%%'! ],
+ [ 'foo ( >= 3.24' , q!Cannot parse: '%%'! ],
+ [ 'foo ( >= 3.!4 )' , q(bad dependency version: '3.!4') ],
+ [ 'bar( >= 1.1) | foo ( >= 3.!4 )' , q(bad dependency version: '3.!4') ],
+ [ 'bar( >= 1.!1) | foo ( >= 3.14 )' , q{bad dependency version: '1.!1)'} ],
+ [ 'foo ( <> 3.24 )' , q!bad dependency version operator: '<>'! ],
+
+ [ 'foo ( >= 1.24 )| bar [ binux-any]' , q!bad os in architecture specification: 'binux'!,
+ q!bad arch in architecture specification: 'binux'! ],
+ [ 'foo ( >= 1.24 )| bar [ linux-nany]' , q!bad arch in architecture specification: 'nany'! ],
+
+ ) ;
+
+ foreach my $td ( @tests ) {
+ my ($dep, at errs) = @$td ;
+ my $ret = $parser->dependency($dep) ;
+ map { s/%%/$dep/;} @errs ;
+ unshift @errs, 0; # match what's returned when there's an error
+ is_deeply($ret,\@errs,"test error message for $dep") ;
+ }
+}
+
+
--
Debian native package for Config::Model::Dpkg
More information about the Pkg-perl-cvs-commits
mailing list