perl.prov

   1 #!/usr/bin/perl
   2 use strict;
   3
   4 # perl.prov - find information about perl modules for RPM
   5 # $Id$
   6
   7 # It's questionable if we should provide perl(Foo::Bar) for modules
   8 # from outside @INC (possibly shipped with some applications).
   9 # I think we should not, and provide them only for the perl.req script,
  10 # while it scans files in that particular application.
  11
  12
  13 # check if we are called directly
  14 if ($0 =~ m#(?:^|/)perl.prov$#) {
  15         my $prov = new RPM::PerlReq;
  16         # process @ARGV or STDIN
  17         foreach ( @ARGV ? @ARGV : <> ) {
  18                 chomp;
  19                 next if -l || !-f _;                # skip non-files and symlinks
  20                 next if m#/usr/(?:share/doc|src)/#; # lot of false alarms; warning: we omit ^ here
  21                 next if !m#\.p[ml]$#;               # we only care about *.pm and *.pl files
  22                 $prov->process_file($_);
  23         }
  24         $prov->print_result;
  25 }
  26
  27
  28 package RPM::PerlReq;
  29 use Safe;
  30
  31 sub new {
  32         my $class = shift;
  33         my $self = {
  34                 inc => [ sort { length $b cmp length $a } grep m#^/#, @INC ],
  35                 provide => {},
  36                 safe => Safe->new,
  37                 @_,
  38         };
  39         bless $self, $class;
  40 }
  41
  42 # print out what we found
  43 sub print_result {
  44         my $self = shift;
  45         for (sort keys %{ $self->{provide} }) {
  46                 print "perl($_)"
  47                   . (length $self->{provide}->{$_} ? " = $self->{provide}->{$_}" : '')
  48                   . "\n";
  49         }
  50 }
  51
  52 sub process_file {
  53         my $self = shift;
  54         my $file = shift;
  55         my ( $package, $version );
  56
  57         # if the file lives under @INC, we can
  58         # obtain the package name from it's path
  59         for (@{ $self->{inc} }) {
  60                 if ($file =~ m#\Q$_\E/?(.+)$#) {    # we can't use ^ here
  61                         $package = $1;
  62
  63                         if ($package !~ s/\.pm$//) {    # it's a *.pl
  64                         #       $package =~ m#([^/]+)$#;
  65                         #       $provide{$1} = '';
  66                                 return 1;
  67                         }
  68
  69                         $package =~ s#/#::#g;
  70                         last;
  71                 }
  72         }
  73
  74         # it can be a *.pl oustide @INC
  75         return if /\.pl$/;
  76
  77         local *FILE;
  78         open FILE, $file or die "$0: cannot open file `$file': $!";
  79
  80         while (<FILE>) {
  81
  82                 # skip the documentation
  83                 next
  84                   if m/^=(?:head1|head2|pod|item|begin|for|over)\b/
  85                      ... ( m/^=(?:cut|end)\b/ || $. == 1 );
  86
  87                 # skip the data section
  88                 last if m/^__(?:DATA|END)__$/;
  89
  90                 # search for the package name
  91                 if (
  92                         !defined $package
  93                         && ( my ($pack) = m/^\s*(?:\{\s*)?package\s+([_:a-zA-Z0-9]+?):*\s*;/ )
  94                         && $1 ne 'main'
  95                         && match_the_path( $file, $1 )
  96                   )
  97                 {
  98                         $package = $pack;
  99                 }
 100
 101                 if ( !defined $version && /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/ ) {
 102                         ( $version = $self->{safe}->reval($_) ) =~ s/^\s+|alpha|beta|\s+$//g;
 103                         if ( defined $version
 104                                 && length $version
 105                                 && $version =~ /[^\d\._abcdefgh]/ )
 106                         {
 107                                 warn "$0: weird version number in $file: [$version]\n";
 108                                 $version = '';
 109                         }
 110                 }
 111         }
 112
 113         unless ( defined $package ) {
 114                 warn "$0: weird, cannot determine the package name for `$file'\n";
 115                 return 0;
 116         }
 117
 118         $self->{provide}->{$package} = $version;
 119
 120         close FILE or die "$0: cannot close file `$file': $!";
 121
 122         1;
 123 }
 124
 125
 126 # Returns C<true> if the package name matches the path,
 127 # so you can use() it.  C<false> otherwise.
 128 sub match_the_path {
 129         my ( $file, $pack ) = @_;
 130         $pack =~ s#::#/#g;
 131         $file =~ /\Q$pack\E(?:\.pm)?$/;
 132 }
 133
 134
 135 1;
 136
 137 # vim: ts=4 sw=4 noet noai nosi cin