perl.prov

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