- obsolete

[packages/rpm.git] / perl.prov

diff --git a/perl.prov b/perl.prov
index f36ca18c609eb05080ec3aa94a6946419cc44da6..a494480010caf026594bf8edb15fbf22dc243e03 100644 (file)
--- a/perl.prov
+++ b/perl.prov
@@ -1,5 +1,4 @@
 #!/usr/bin/perl
-use Safe;
 use strict;
 
 # perl.prov - find information about perl modules for RPM
@@ -10,45 +9,63 @@ use strict;
 # 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;
                        }
 
@@ -60,6 +77,7 @@ sub process_file {
        # it can be a *.pl oustide @INC
        return if /\.pl$/;
 
+       local *FILE;
        open FILE, $file or die "$0: cannot open file `$file': $!";
 
        while (<FILE>) {
@@ -75,8 +93,7 @@ sub process_file {
                # search for the package name
                if (
                        !defined $package
-                       && ( my ($pack) =
-                               m/^\s*(?:\{\s*)?package\s+([_:a-zA-Z0-9]+?):*\s*;/ )
+                       && ( my ($pack) = m/^\s*(?:\{\s*)?package\s+([_:a-zA-Z0-9]+?):*\s*;/ )
                        && $1 ne 'main'
                        && match_the_path( $file, $1 )
                  )
@@ -85,36 +102,39 @@ sub process_file {
                }
 
                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