]>
Commit | Line | Data |
---|---|---|
fc228fe8 | 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 | |
4cd275d8 | 25 | next if !m#\.(?:p[ml]|cgi$#; # we only care about *.pm and *.pl files and CGI scripts |
fc228fe8 | 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 | } | |
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/?(.+)$# ) { | |
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 | |
aac3bac8 | 69 | if m/^=(?:head1|head2|pod|item|begin|for|over)\b/ |
70 | ... ( m/^=(?:cut|end)\b/ || $. == 1 ); | |
fc228fe8 | 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) = | |
79 | m/^\s*(?:\{\s*)?package\s+([_:a-zA-Z0-9]+?):*\s*;/ ) | |
80 | && $1 ne 'main' | |
81 | && match_the_path( $file, $1 ) | |
82 | ) | |
83 | { | |
84 | $package = $pack; | |
85 | } | |
86 | ||
87 | if ( !defined $version && /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/ ) { | |
88 | ( $version = $safe->reval($_) ) =~ s/^\s+|alpha|beta|\s+$//g; | |
89 | if ( defined $version | |
90 | && length $version | |
91 | && $version =~ /[^\d\._abcdefgh]/ ) | |
92 | { | |
93 | warn "perl.prov: weird version number in $file: [$version]\n"; | |
94 | $version = ''; | |
95 | } | |
96 | } | |
97 | } | |
98 | ||
99 | unless ( defined $package ) { | |
100 | warn "$0: weird, I can't determine the package name for `$file'\n"; | |
101 | return 0; | |
102 | } | |
103 | ||
104 | $provide{$package} = $version; | |
105 | ||
106 | close FILE or die "perl.prov: cannot close file `$file': $!"; | |
107 | ||
108 | 1; | |
109 | } | |
110 | ||
111 | ||
112 | # Returns true if the package name matches the patch, | |
113 | # so you can use() it. False otherwise. | |
114 | sub match_the_path { | |
115 | my ( $file, $pack ) = @_; | |
116 | $pack =~ s#::#/#g; | |
117 | $file =~ /\Q$pack\E(?:\.pm)?$/; | |
118 | } | |
119 | ||
120 | # vim: ts=4 sw=4 noet noai nosi cin |