This commit was manufactured by cvs2git to create branch 'PERL_5_8_0'.

Cherrypick from master 2004-05-05 17:13:54 UTC radek <radek@pld-linux.org> '- fixed bug, which could cause providing "perl()"':
    perl.prov -> 1.10

diff --git a/perl.prov b/perl.prov
new file mode 100644 (file)
index 0000000..a494480
--- /dev/null
+++ b/perl.prov
@@ -0,0 +1,140 @@
+#!/usr/bin/perl
+use strict;
+
+# perl.prov - find information about perl modules for RPM
+# $Id$
+
+# It's questionable if we should provide perl(Foo::Bar) for modules
+# from outside @INC (possibly shipped with some applications).
+# I think we should not, and provide them only for the perl.req script,
+# while it scans files in that particular application.
+
+
+# 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;
+
+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
+sub print_result {
+       my $self = shift;
+       for (sort keys %{ $self->{provide} }) {
+               print "perl($_)"
+                 . (length $self->{provide}->{$_} ? " = $self->{provide}->{$_}" : '')
+                 . "\n";
+       }
+}
+
+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 (@{ $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} = '';
+                               return 1;
+                       }
+
+                       $package =~ s#/#::#g;
+                       last;
+               }
+       }
+
+       # 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)\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*;/ )
+                       && $1 ne 'main'
+                       && match_the_path( $file, $1 )
+                 )
+               {
+                       $package = $pack;
+               }
+
+               if ( !defined $version && /([\$*])(([\w\:\']*)\bVERSION)\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 = '';
+                       }
+               }
+       }
+
+       unless ( defined $package ) {
+               warn "$0: weird, cannot determine the package name for `$file'\n";
+               return 0;
+       }
+
+       $self->{provide}->{$package} = $version;
+
+       close FILE or die "$0: cannot close file `$file': $!";
+
+       1;
+}
+
+
+# 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