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