From: Michael Tremer Date: Wed, 7 Dec 2022 17:55:16 +0000 (+0000) Subject: scripts: Update perl.{prov,req} from RPM X-Git-Tag: 0.9.28~38 X-Git-Url: http://git.ipfire.org/?a=commitdiff_plain;h=315a62ac3f76defc7adae598e127bee4d63e5be1;p=pakfire.git scripts: Update perl.{prov,req} from RPM Signed-off-by: Michael Tremer --- diff --git a/src/scripts/perl.prov b/src/scripts/perl.prov index 9886dd93f..ba34130c3 100644 --- a/src/scripts/perl.prov +++ b/src/scripts/perl.prov @@ -1,30 +1,16 @@ #!/usr/bin/perl -# RPM (and it's source code) is covered under two separate licenses. +# This is free software. You may redistribute copies of it under the terms of +# the GNU General Public License . +# There is NO WARRANTY, to the extent permitted by law. -# The entire code base may be distributed under the terms of the GNU -# General Public License (GPL), which appears immediately below. -# Alternatively, all of the source code in the lib subdirectory of the -# RPM source code distribution as well as any code derived from that -# code may instead be distributed under the GNU Library General Public -# License (LGPL), at the choice of the distributor. The complete text -# of the LGPL appears at the bottom of this file. +# This script was originally written by Ken Estes Mail.com +# kestes@staff.mail.com -# This alternative is allowed to enable applications to be linked -# against the RPM library (commonly called librpm) without forcing -# such applications to be distributed under the GPL. +# a simple script to print the proper name for Perl libraries. -# Any questions regarding the licensing of RPM should be addressed to -# Erik Troan . - -# a simple script to print the proper name for perl libraries. - -# To save development time I do not parse the perl grammmar but -# instead just lex it looking for what I want. I take special care to -# ignore comments and pod's. - -# it would be much better if perl could tell us the proper name of a -# given script. +# It does not parse the perl grammar but instead just lex it looking for +# what we want. It takes special care to ignore comments and pod's. # The filenames to scan are either passed on the command line or if # that is empty they are passed via stdin. @@ -40,10 +26,7 @@ # then these are treated as additional names which are provided by the # file and are printed as well. -# I plan to rewrite this in C so that perl is not required by RPM at -# build time. - -# by Ken Estes Mail.com kestes@staff.mail.com +my $perl_ns = "perl"; if ("@ARGV") { foreach (@ARGV) { @@ -62,14 +45,14 @@ if ("@ARGV") { foreach $module (sort keys %require) { if (length($require{$module}) == 0) { - print "perl($module)\n"; + print "$perl_ns($module)\n"; } else { - # I am not using rpm3.0 so I do not want spaces arround my + # I am not using rpm3.0 so I do not want spaces around my # operators. Also I will need to change the processing of the # $RPM_* variable when I upgrade. - print "perl($module) = $require{$module}\n"; + print "$perl_ns($module) = $require{$module}\n"; } } @@ -91,31 +74,47 @@ sub process_file { while () { + # skip the here-docs "<<" blocks + # assume that <<12 means bitwise operation + if (((m/^\s*(?:'[^']*?'|"[^"]*?"|[^"'#]*?)*?[^"'#<@]<<[\\]?(\w+)\s*/ && + ($1 !~ m/^\d+$/)) || + m/^\s*(?:'[^']*?'|"[^"]*?"|[^"'#]*?)*?[^"'#<@]<<\s*('[^']*?'|"[^"]*?"|`[^`]*?`)\s*/ + ) && + ! m/q[qxwr]?\s*[{([#|!\/][^})\]#|!\/]*?<<[^<]/ + ) { + $tag = $1; + $tag =~ s/['"`]//g; + while () { + chomp; + ( $_ eq $tag ) && last; + } + $_ = ; + } + + # skip q{} quoted sections - just hope we don't have curly brackets + # within the quote, nor an escaped hash mark that isn't a comment + # marker, such as occurs right here. Draw the line somewhere. + if ( m/^.*\Wq[qxwr]?\s*([{([#|!\/])[^})\]#|!\/]*$/ && ! m/^\s*(package)\s/ ) { + $tag = $1; + $tag =~ tr/{\(\[\#|!\//})]#|!\//; + $tag = quotemeta($tag); + while () { + ( $_ =~ m/$tag/ ) && last; + } + } + # skip the documentation # we should not need to have item in this if statement (it # properly belongs in the over/back section) but people do not # read the perldoc. - if (m/^=(head[1-4]|pod|for|item)/) { - $incomment = 1; - } - - if (m/^=(cut)/) { - $incomment = 0; - $inover = 0; - } - - if (m/^=(over)/) { - $inover = 1; - } - - if (m/^=(back)/) { - $inover = 0; + if (/^=(head[1-4]|pod|for|item)/) { + /^=cut/ && next while ; } - if ($incomment || $inover) { - next; + if (/^=over/) { + /^=back/ && next while ; } # skip the data section @@ -127,17 +126,18 @@ sub process_file { # package name so we report all namespaces except some common # false positives as if they were provided packages (really ugly). - if (m/^\s*package\s+([_:a-zA-Z0-9]+)\s*;/) { + if (m/^\s*package\s+([_:a-zA-Z0-9]+)\s*v?([0-9._]+)?\s*(;|{)/) { $package = $1; - undef $version; + $version = defined($2) ? $2 : undef; if ($package eq 'main') { undef $package; + undef $version; } else { # If $package already exists in the $require hash, it means # the package definition is broken up over multiple blocks. # In that case, don't stomp a previous $VERSION we might have # found. (See BZ#214496.) - $require{$package} = undef unless (exists $require{$package}); + $require{$package} = $version unless (exists $require{$package}); } } @@ -156,15 +156,16 @@ sub process_file { # or with the new "our" pragma you could (read will) see: # # our $VERSION = '1.00' - if ($package && m/^\s*(our\s+)?\$(\Q$package\E::)?VERSION\s*=\s+/) { + if ($package && m/^(?:\s*use\s+version\s*;)?\s*(?:[^#=]*=[^=~>]|)?\s*(?:our\s+)?\$(?:\Q$package\E::)?VERSION\s*=([^=~>]\s*[^;]*)/) { + my $version_str = $1; # first see if the version string contains the string - # '$Revision' this often causes bizzare strings and is the most + # '$Revision' this often causes bizarre strings and is the most # common method of non static numbering. - if (m/(\$Revision: (\d+[.0-9]+))/) { - $version = $2; - } elsif (m/['"]?(\d+[.0-9]+)['"]?/) { + if ($version_str =~ m/\$Revision: (\d+[.0-9]+)/) { + $version = $1; + } elsif ($version_str =~ m/\b['"]?v?(\d+(?:\.[.0-9]+)?)(_\d*|[a-zA-Z]*)?['"]?\b/) { # look for a static number hard coded in the script diff --git a/src/scripts/perl.req b/src/scripts/perl.req index c676c7373..7627645a9 100644 --- a/src/scripts/perl.req +++ b/src/scripts/perl.req @@ -1,30 +1,16 @@ #!/usr/bin/perl -# RPM (and its source code) is covered under two separate licenses. +# This is free software. You may redistribute copies of it under the terms of +# the GNU General Public License . +# There is NO WARRANTY, to the extent permitted by law. -# The entire code base may be distributed under the terms of the GNU -# General Public License (GPL), which appears immediately below. -# Alternatively, all of the source code in the lib subdirectory of the -# RPM source code distribution as well as any code derived from that -# code may instead be distributed under the GNU Library General Public -# License (LGPL), at the choice of the distributor. The complete text -# of the LGPL appears at the bottom of this file. +# This script was originally written by Ken Estes Mail.com +# kestes@staff.mail.com -# This alternatively is allowed to enable applications to be linked -# against the RPM library (commonly called librpm) without forcing -# such applications to be distributed under the GPL. +# a simple script used to generate dependencies of Perl modules and scripts. -# Any questions regarding the licensing of RPM should be addressed to -# Erik Troan . - -# a simple makedepend like script for perl. - -# To save development time I do not parse the perl grammar but -# instead just lex it looking for what I want. I take special care to -# ignore comments and pod's. - -# It would be much better if perl could tell us the dependencies of a -# given script. +# It does not parse the perl grammar but instead just lex it looking for +# what we want. It takes special care to ignore comments and pod's. # The filenames to scan are either passed on the command line or if # that is empty they are passed via stdin. @@ -34,52 +20,106 @@ # then these are treated as additional names which are required by the # file and are printed as well. -# I plan to rewrite this in C so that perl is not required by RPM at -# build time. - -# by Ken Estes Mail.com kestes@staff.mail.com +my $perl_ns = "perl"; $HAVE_VERSION = 0; eval { require version; $HAVE_VERSION = 1; }; - +use Fedora::VSP (); + +use File::Basename; +my $dir = dirname($0); +$HAVE_PROV = 0; +if ( -e "$dir/perl.prov" ) { + $HAVE_PROV = 1; + $prov_script = "$dir/perl.prov"; +} if ("@ARGV") { - foreach (@ARGV) { - process_file($_); + foreach my $file (@ARGV) { + process_file($file); + process_file_provides($file); + compute_global_requires(); } } else { # notice we are passed a list of filenames NOT as common in unix the # contents of the file. - foreach (<>) { - process_file($_); + foreach my $file (<>) { + process_file($file); + process_file_provides($file); + compute_global_requires(); } } foreach $perlver (sort keys %perlreq) { - print "perl >= $perlver\n"; + print "$perl_ns(:VERSION) >= $perlver\n"; } -foreach $module (sort keys %require) { - if (length($require{$module}) == 0) { - print "perl($module)\n"; + +foreach my $module (sort keys %global_require) { + if (length($global_require{$module}) == 0) { + print "$perl_ns($module)\n"; } else { # I am not using rpm3.0 so I do not want spaces around my # operators. Also I will need to change the processing of the # $RPM_* variable when I upgrade. - print "perl($module) >= $require{$module}\n"; + print "$perl_ns($module) >= $global_require{$module}\n"; } } exit 0; +sub compute_global_requires { + +# restrict require to all non provided by the file + foreach my $moduler (sort keys %require) { + if (exists $provide{$moduler} && length($require{$moduler}) == 0) { + $require = delete $require{$moduler}; + } + } +# store requires to global_requires + foreach my $module (sort keys %require) { + my $oldver = $global_require{$module}; + my $newver = $require{$module}; + if ($oldver) { + $global_require{$module} = $newver + if ($HAVE_VERSION && $newver && version->new($oldver) < $newver); + } else { + $global_require{$module} = $newver; + } + } +# remove all local requires and provides + undef %require; + undef %provide; +} + +sub add_perlreq { + my ($newver) = @_; + if (%perlreq) { + my ($oldver) = keys %perlreq; + if (eval "v$oldver" lt eval "v$newver") { + delete $perlreq{$oldver}; + $perlreq{$newver} = 1; + } + } else { + $perlreq{$newver} = 1; + } +} sub add_require { my ($module, $newver) = @_; + + # __EXAMPLE__ is not valid requirement + return if ($module =~ m/^__[A-Z]+__$/o); + + # To prevent that module does not end with '::' + # Example: use base Object::Event::; + $module =~ s/::$//; + my $oldver = $require{$module}; if ($oldver) { $require{$module} = $newver @@ -102,11 +142,17 @@ sub process_file { while () { - # skip the "= <<" block - - if (m/^\s*\$(?:.*)\s*=\s*<<\s*(["'`])(.+?)\1/ || - m/^\s*\$(.*)\s*=\s*<<(\w+)\s*;/) { - $tag = $2; + # skip the here-docs "<<" blocks + # assume that <<12 means bitwise operation + if (((m/^\s*(?:'[^']*?'|"[^"]*?"|[^"'#]*?)*?[^"'#<@]<<[\\]?(\w+)\s*/ && + ($1 !~ m/^\d+$/)) || + m/^\s*(?:'[^']*?'|"[^"]*?"|[^"'#]*?)*?[^"'#<@]<<\s*('[^']*?'|"[^"]*?"|`[^`]*?`)\s*/ + ) && + ! m/q[qxwr]?\s*[{([#|!\/][^})\]#|!\/]*?<<[^<]/ + ) { + $tag = $1; + $tag =~ s/['"`]//g; + if ($_ =~ m/^\s*use\s(constant)\s/) { add_require($1, undef) } while () { chomp; ( $_ eq $tag ) && last; @@ -117,11 +163,12 @@ sub process_file { # skip q{} quoted sections - just hope we don't have curly brackets # within the quote, nor an escaped hash mark that isn't a comment # marker, such as occurs right here. Draw the line somewhere. - if ( m/^.*\Wq[qxwr]?\s*([{([#|\/])[^})\]#|\/]*$/ && ! m/^\s*(require|use)\s/ ) { + if ( m/^.*\Wq[qxwr]?\s*([{([#|!\/])[^})\]#|!\/]*$/ && ! m/^\s*(require|use)\s/ ) { $tag = $1; - $tag =~ tr/{\(\[\#|\//})]#|\//; + $tag =~ tr/{\(\[\#|!\//})]#|!\//; + $tag = quotemeta($tag); while () { - ( $_ =~ m/\}/ ) && last; + ( $_ =~ m/$tag/ ) && last; } } @@ -156,6 +203,21 @@ sub process_file { } my $modver_re = qr/[.0-9]+/; + my $begin_re = qr#qw\s*[(\/'"!|{\[]\s*|qq?\s*[(\/'"!|{\[]\s*|['"]#; + my $end_re = qr#[)\/"'!|}\]]#; + + # Skip multiline print and assign statements + if ( m/\$\S+\s*=\s*(")([^"\\]|(\\.))*$/ || + m/\$\S+\s*=\s*(')([^'\\]|(\\.))*$/ || + m/print\s+(")([^"\\]|(\\.))*$/ || + m/print\s+(')([^'\\]|(\\.))*$/ ) { + + my $quote = $1; + while () { + m/^([^\\$quote]|(\\.))*$quote/ && last; + } + $_ = ; + } if ( @@ -168,15 +230,51 @@ sub process_file { (m/^(\s*) # we hope the inclusion starts the line + (?:BEGIN\s*\{\s*)? # but we accept an optional BEGIN { as used in Module::Loaded (require|use)\s+(?!\{) # do not want 'do {' loops # quotes around name are always legal - ['"]?([^; '"\t#]+)['"]?[\t; ] + (?:$begin_re?\s*([\w:\/\.]+?)\s*$end_re?| + ([\w:\.]+?))[^\w]*? + [\t; \n] # the syntax for 'use' allows version requirements + \s*($modver_re)?\s* + # catch parameter like '-norequire,' + (-[\w,]+)?\s* # the latter part is for "use base qw(Foo)" and friends special case - \s*($modver_re|(qw\s*[(\/'"]\s*|['"])[^)\/"'\$]*?\s*[)\/"'])? + (?:$begin_re\s* + ([^)\/"'\$!|}]*?) + \s*$end_re| + (?:qw<|qq?<)([^>]*?)>|([\w\:]+)|)\s*(.*) /x) ) { - my ($whitespace, $statement, $module, $version) = ($1, $2, $3, $4); + my ($whitespace, $statement, $module, $version, $params, $list, $rest) = ($1, $2, $3, $5, $6, $7 || $8 || $9, $10); + $version = undef if ($version eq ''); + + # Ignore line which contains direct method calls + # use base __PACKAGE__->subroutine(...); + $list = "" if ($list =~ /^[^;#]*?->/ || $rest =~ /^[^;#]*?->/); + + # + # Executed in case that multiline q{} quoted sections is used for + # list of modules + if (defined($list) && $list =~ /^q[qxwr]?$/) { + $list = ""; + if ($rest =~ m/^\s*([{([#|!\/])\s*([^})\]#|!\/]*)$/) { + $tag = $1; + $list = $2; + chomp($list); + $tag =~ tr/{\(\[\#|!\//})]#|!\//; + $tag = quotemeta($tag); + while () { + my $line = $_; + chomp($line); + if ($line =~ m/^\s*(.*?)$tag/) { + $list .= ' ' . $1 if ($1 ne ''); + last; + } else { $list .= ' ' . $line; } + } + } + } # we only consider require statements that are flushed against # the left edge. any other require statements give too many @@ -191,6 +289,9 @@ sub process_file { ($module =~ m/\$/) && next; + # ignore variables + ($module =~ m/^\s*[\$%@\*]/) && next; + # skip if the phrase was "use of" -- shows up in gimp-perl, et al. next if $module eq 'of'; @@ -218,31 +319,28 @@ sub process_file { $module =~ s/\(.*$//; # if the module ends with .pm, strip it to leave only basename. - $module =~ s/\.pm$//; + # .pm files are not accepted by 'use' + ($module =~ s/\.pm$// && $statement eq 'use' ) && next; # some perl programmers write 'require URI/URL;' when # they mean 'require URI::URL;' - $module =~ s/\//::/; + ($module =~ s/\//::/ && $statement eq 'use' ) && next; # trim off trailing parentheses if any. Sometimes people pass # the module an empty list. $module =~ s/\(\s*\)$//; - if ( $module =~ m/^v?([0-9._]+)$/ ) { - # if module is a number then both require and use interpret that - # to mean that a particular version of perl is specified + if ( $module =~ m/^(v?[0-9._]+)$/ ) { + # if module is a number then both require and use interpret that + # to mean that a particular version of perl is specified - my $ver = $1; - if ($ver =~ /5.00/) { - $perlreq{"0:$ver"} = 1; - next; - } - else { - $perlreq{"1:$ver"} = 1; - next; - } + my $rpm_ver = Fedora::VSP::vsp($1); + if (defined $rpm_ver) { + add_perlreq("$rpm_ver"); + next; + } }; @@ -261,26 +359,63 @@ sub process_file { ($module =~ m/\.ph$/) && next; - # use base qw(Foo) dependencies - if ($statement eq "use" && $module eq "base") { - add_require($module, undef); - if ($version =~ /^qw\s*[(\/'"]\s*([^)\/"']+?)\s*[)\/"']/) { - add_require($_, undef) for split(' ', $1); + # use base|parent qw(Foo) dependencies + # use aliased qw(Foo::Bar) dependencies + if ($statement eq "use" && ($module eq "base" || $module eq "aliased")) { + add_require($module, $version); + if (defined($list) && $list ne "") { + add_require($_, undef) for split(' ', $list); } - elsif ($version =~ /(["'])([^"']+)\1/) { - add_require($2, undef); + next; + } + # use parent -norequire, 'No::Version'; # $params == "-norequire," + # use parent qw/-norequire XML::XPath::Node/; # $list == "-norequire XML::XPath::Node" + if ($statement eq "use" && $module eq "parent") { + add_require($module, $version); + if (defined($list) && $list ne "" && $list !~ /-norequire/ && $params !~ /-norequire/) { + add_require($_, undef) for split(' ', $list); + } + next; + } + + # use Any::Moose dependencies + # Mouse or Mouse::Role will be added + if ($statement eq "use" && $module eq "Any::Moose") { + add_require($module, $version); + if (defined($list) && $list ne "") { + if (grep { !/^Role$/ } split(' ', $list)) { + add_require('Mouse::Role', undef); + } else { + add_require('Mouse', undef); + } + } else { + add_require('Mouse', undef); } next; } - $version = undef unless $version =~ /^$modver_re$/o; add_require($module, $version); - } + } # use|require regex - } + } # while () close(FILE) || die("$0: Could not close file: '$file' : $!\n"); return; } + +sub process_file_provides { + + my ($file) = @_; + chomp $file; + + return if (! $HAVE_PROV); + + $file =~ s/'/'"'"'/g; + my @result = readpipe( "$prov_script '$file'" ); + foreach my $prov (@result) { + $provide{$1} = undef if $prov =~ /perl\(([_:a-zA-Z0-9]+)\)/; + } + +}