#!/usr/bin/perl
-use Safe;
use strict;
# perl.prov - find information about perl modules for RPM
# I think we should not, and provide them only for the perl.req script,
# while it scans files in that particular application.
-# This shoud be provided as a library -- the same functionality is
-# needed by the perl.req script.
-my %provide;
-my @inc = sort { length $b cmp length $a } grep m#^/.+#, @INC;
-my $safe = new Safe;
+# check if we are called directly
+if ($0 =~ m#(?:^|/)perl.prov$#) {
+ my $prov = new RPM::PerlReq;
+ # process @ARGV or STDIN
+ foreach ( @ARGV ? @ARGV : <> ) {
+ chomp;
+ next if -l || !-f _; # skip non-files and symlinks
+ next if m#/usr/(?:share/doc|src)/#; # lot of false alarms; warning: we omit ^ here
+ next if !m#\.p[ml]$#; # we only care about *.pm and *.pl files
+ $prov->process_file($_);
+ }
+ $prov->print_result;
+}
+
+
+package RPM::PerlReq;
+use Safe;
-# process @ARGV or STDIN
-foreach ( @ARGV ? @ARGV : <> ) {
- chomp;
- next if !-f || -l; # skip non-files and symlinks
- next if m#^/usr/(?:doc|src)/#; # lot of false alarms
- next if !m#\.p[ml]$#; # we only care about *.pm and *.pl files
- process_file($_) if -f;
+sub new {
+ my $class = shift;
+ my $self = {
+ inc => [
+ sort { length $b cmp length $a } grep m#^/#,
+ map { y#/#/#s; s#/$##; $_ } @INC
+ ],
+ provide => {},
+ safe => Safe->new,
+ @_,
+ };
+ bless $self, $class;
}
# print out what we found
-for ( sort keys %provide ) {
- print "perl($_)" . ( length $provide{$_} ? " = $provide{$_}" : '' ) . "\n";
+sub print_result {
+ my $self = shift;
+ for (sort keys %{ $self->{provide} }) {
+ print "perl($_)"
+ . (length $self->{provide}->{$_} ? " = $self->{provide}->{$_}" : '')
+ . "\n";
+ }
}
-
-############################################################
-##### functions #####
-############################################################
-
sub process_file {
+ my $self = shift;
my $file = shift;
my ( $package, $version );
# if the file lives under @INC, we can
# obtain the package name from it's path
- for (@inc) {
- if ( $file =~ m#^\Q$_\E/?(.+)$# ) {
+ for (@{ $self->{inc} }) {
+ if ($file =~ m#\Q$_\E/(.+)$#) { # we can't use ^ here
$package = $1;
- if ( $package !~ s/\.pm$// ) { # it's a *.pl
- # $package =~ m#([^/]+)$#;
- # $provide{$1} = '';
+ if ($package !~ s/\.pm$//) { # it's a *.pl
+ # $package =~ m#([^/]+)$#;
+ # $provide{$1} = '';
return 1;
}
# it can be a *.pl oustide @INC
return if /\.pl$/;
+ local *FILE;
open FILE, $file or die "$0: cannot open file `$file': $!";
while (<FILE>) {
# skip the documentation
next
- if m/^=(?:head1|head2|pod|item|begin|for|over)/
- ... m/^=(?:cut|end)/;
+ if m/^=(?:head1|head2|pod|item|begin|for|over)\b/
+ ... ( m/^=(?:cut|end)\b/ || $. == 1 );
# skip the data section
last if m/^__(?:DATA|END)__$/;
# search for the package name
if (
- !defined $package
- && ( my ($pack) =
- m/^\s*(?:\{\s*)?package\s+([_:a-zA-Z0-9]+?):*\s*;/ )
+ (!defined $package || !defined $version)
+ && ( my ($pack, $ver) = m/^\s*(?:\{\s*)?package\s+([_:a-zA-Z0-9]+?)\s*(?:v?([0-9_.]+)\s*)?[;{]/)
&& $1 ne 'main'
&& match_the_path( $file, $1 )
)
{
$package = $pack;
+ $version = $ver;
+ }
+
+ if ( defined $package && $package == 'Getopt::Long' && /([\$*])(([\w\:\']*)\bVERSION_STRING)\b.*\=/ ) {
+ ( $version = $self->{safe}->reval($_) ) =~ s/^\s+|alpha|beta|\s+$//g;
+ if ( defined $version
+ && length $version
+ && $version =~ /[^\d\._abcdefgh]/ )
+ {
+ warn "$0: weird version number in $file: [$version]\n";
+ $version = '';
+ }
}
if ( !defined $version && /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/ ) {
- ( $version = $safe->reval($_) ) =~ s/^\s+|alpha|beta|\s+$//g;
+ ( $version = $self->{safe}->reval($_) ) =~ s/^\s+|alpha|beta|\s+$//g;
if ( defined $version
&& length $version
&& $version =~ /[^\d\._abcdefgh]/ )
{
- warn "perl.prov: weird version number in $file: [$version]\n";
+ warn "$0: weird version number in $file: [$version]\n";
$version = '';
}
}
}
unless ( defined $package ) {
- warn "$0: weird, I can't determine the package name for `$file'\n";
+ warn "$0: weird, cannot determine the package name for `$file'\n";
return 0;
}
- $provide{$package} = $version;
+ $self->{provide}->{$package} = $version;
- close FILE or die "perl.prov: cannot close file `$file': $!";
+ close FILE or die "$0: cannot close file `$file': $!";
1;
}
-# Returns true if the package name matches the patch,
-# so you can use() it. False otherwise.
+# Returns C<true> if the package name matches the path,
+# so you can use() it. C<false> otherwise.
sub match_the_path {
my ( $file, $pack ) = @_;
$pack =~ s#::#/#g;
$file =~ /\Q$pack\E(?:\.pm)?$/;
}
+
+1;
+
# vim: ts=4 sw=4 noet noai nosi cin