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 => [
  35                         sort { length $b cmp length $a } grep m#^/#,
  36                         map { y#/#/#s; s#/$##; $_ } @INC
  37                 ],
  38                 provide => {},
  39                 safe    => Safe->new,
  40                 @_,
  41         };
  42         bless $self, $class;
  43 }
  44
  45 # print out what we found
  46 sub print_result {
  47         my $self = shift;
  48         for (sort keys %{ $self->{provide} }) {
  49                 print "perl($_)"
  50                   . (length $self->{provide}->{$_} ? " = $self->{provide}->{$_}" : '')
  51                   . "\n";
  52         }
  53 }
  54
  55 sub process_file {
  56         my $self = shift;
  57         my $file = shift;
  58         my ( $package, $version );
  59
  60         # if the file lives under @INC, we can
  61         # obtain the package name from it's path
  62         for (@{ $self->{inc} }) {
  63                 if ($file =~ m#\Q$_\E/(.+)$#) {    # we can't use ^ here
  64                         $package = $1;
  65
  66                         if ($package !~ s/\.pm$//) {    # it's a *.pl
  67                         #       $package =~ m#([^/]+)$#;
  68                         #       $provide{$1} = '';
  69                                 return 1;
  70                         }
  71
  72                         $package =~ s#/#::#g;
  73                         last;
  74                 }
  75         }
  76
  77         # it can be a *.pl oustide @INC
  78         return if /\.pl$/;
  79
  80         local *FILE;
  81         open FILE, $file or die "$0: cannot open file `$file': $!";
  82
  83         while (<FILE>) {
  84
  85                 # skip the documentation
  86                 next
  87                   if m/^=(?:head1|head2|pod|item|begin|for|over)\b/
  88                      ... ( m/^=(?:cut|end)\b/ || $. == 1 );
  89
  90                 # skip the data section
  91                 last if m/^__(?:DATA|END)__$/;
  92
  93                 # search for the package name
  94                 if (
  95                         !defined $package
  96                         && ( my ($pack) = m/^\s*(?:\{\s*)?package\s+([_:a-zA-Z0-9]+?):*\s*;/ )
  97                         && $1 ne 'main'
  98                         && match_the_path( $file, $1 )
  99                   )
 100                 {
 101                         $package = $pack;
 102                 }
 103
 104                 if ( !defined $version && /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/ ) {
 105                         ( $version = $self->{safe}->reval($_) ) =~ s/^\s+|alpha|beta|\s+$//g;
 106                         if ( defined $version
 107                                 && length $version
 108                                 && $version =~ /[^\d\._abcdefgh]/ )
 109                         {
 110                                 warn "$0: weird version number in $file: [$version]\n";
 111                                 $version = '';
 112                         }
 113                 }
 114         }
 115
 116         unless ( defined $package ) {
 117                 warn "$0: weird, cannot determine the package name for `$file'\n";
 118                 return 0;
 119         }
 120
 121         $self->{provide}->{$package} = $version;
 122
 123         close FILE or die "$0: cannot close file `$file': $!";
 124
 125         1;
 126 }
 127
 128
 129 # Returns C<true> if the package name matches the path,
 130 # so you can use() it.  C<false> otherwise.
 131 sub match_the_path {
 132         my ( $file, $pack ) = @_;
 133         $pack =~ s#::#/#g;
 134         $file =~ /\Q$pack\E(?:\.pm)?$/;
 135 }
 136
 137
 138 1;
 139
 140 # vim: ts=4 sw=4 noet noai nosi cin