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