]>
Commit | Line | Data |
---|---|---|
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 |