1#!/usr/local/bin/perl
2
3# RPM (and its source code) is covered under two separate licenses.
4
5# The entire code base may be distributed under the terms of the GNU
6# General Public License (GPL), which appears immediately below.
7# Alternatively, all of the source code in the lib subdirectory of the
8# RPM source code distribution as well as any code derived from that
9# code may instead be distributed under the GNU Library General Public
10# License (LGPL), at the choice of the distributor. The complete text
11# of the LGPL appears at the bottom of this file.
12
13# This alternatively is allowed to enable applications to be linked
14# against the RPM library (commonly called librpm) without forcing
15# such applications to be distributed under the GPL.
16
17# Any questions regarding the licensing of RPM should be addressed to
18# Erik Troan <ewt@redhat.com>.
19
20# a simple makedepend like script for perl.
21
22# To save development time I do not parse the perl grammar but
23# instead just lex it looking for what I want.  I take special care to
24# ignore comments and pod's.
25
26# It would be much better if perl could tell us the dependencies of a
27# given script.
28
29# The filenames to scan are either passed on the command line or if
30# that is empty they are passed via stdin.
31
32# If there are strings in the file which match the pattern
33#     m/^\s*\$RPM_Requires\s*=\s*["'](.*)['"]/i
34# then these are treated as additional names which are required by the
35# file and are printed as well.
36
37# I plan to rewrite this in C so that perl is not required by RPM at
38# build time.
39
40# by Ken Estes Mail.com kestes@staff.mail.com
41
42$HAVE_VERSION = 0;
43eval { require version; $HAVE_VERSION = 1; };
44
45
46if ("@ARGV") {
47  foreach (@ARGV) {
48    process_file($_);
49  }
50} else {
51
52  # notice we are passed a list of filenames NOT as common in unix the
53  # contents of the file.
54
55  foreach (<>) {
56    process_file($_);
57  }
58}
59
60
61foreach $perlver (sort keys %perlreq) {
62  print "perl >= $perlver\n";
63}
64foreach $module (sort keys %require) {
65  if (length($require{$module}) == 0) {
66    print "perl($module)\n";
67  } else {
68
69    # I am not using rpm3.0 so I do not want spaces around my
70    # operators. Also I will need to change the processing of the
71    # $RPM_* variable when I upgrade.
72
73    print "perl($module) >= $require{$module}\n";
74  }
75}
76
77exit 0;
78
79
80
81sub add_require {
82  my ($module, $newver) = @_;
83  my $oldver = $require{$module};
84  if ($oldver) {
85    $require{$module} = $newver
86      if ($HAVE_VERSION && $newver && version->new($oldver) < $newver);
87  }
88  else {
89    $require{$module} = $newver;
90  }
91}
92
93sub process_file {
94
95  my ($file) = @_;
96  chomp $file;
97
98  if (!open(FILE, $file)) {
99    warn("$0: Warning: Could not open file '$file' for reading: $!\n");
100    return;
101  }
102
103  while (<FILE>) {
104
105    # skip the "= <<" block
106
107    if (m/^\s*(?:my\s*)?\$(?:.*)\s*=\s*<<\s*(["'`])(.+?)\1/ ||
108        m/^\s*(?:my\s*)?\$(.*)\s*=\s*<<(\w+)\s*;/) {
109      $tag = $2;
110      while (<FILE>) {
111        chomp;
112        ( $_ eq $tag ) && last;
113      }
114      $_ = <FILE>;
115    }
116
117    # skip q{} quoted sections - just hope we don't have curly brackets
118    # within the quote, nor an escaped hash mark that isn't a comment
119    # marker, such as occurs right here. Draw the line somewhere.
120    if ( m/^.*\Wq[qxwr]?\s*([{([#|\/])[^})\]#|\/]*$/ && ! m/^\s*(require|use)\s/ ) {
121      $tag = $1;
122      $tag =~ tr/{\(\[\#|\//})]#|\//;
123      $tag = quotemeta($tag);
124      while (<FILE>) {
125        ( $_ =~ m/$tag/ ) && last;
126      }
127    }
128
129    # skip the documentation
130
131    # we should not need to have item in this if statement (it
132    # properly belongs in the over/back section) but people do not
133    # read the perldoc.
134
135    if (/^=(head[1-4]|pod|for|item)/) {
136      /^=cut/ && next while <FILE>;
137    }
138
139    if (/^=over/) {
140      /^=back/ && next while <FILE>;
141    }
142
143    # skip the data section
144    if (m/^__(DATA|END)__$/) {
145      last;
146    }
147
148    # Each keyword can appear multiple times.  Don't
149    #  bother with datastructures to store these strings,
150    #  if we need to print it print it now.
151    #
152        # Again allow for "our".
153    if (m/^\s*(our\s+)?\$RPM_Requires\s*=\s*["'](.*)['"]/i) {
154      foreach $_ (split(/\s+/, $2)) {
155        print "$_\n";
156      }
157    }
158
159    my $modver_re = qr/[.0-9]+/;
160
161    #
162    # The (require|use) match further down in this subroutine will match lines
163    # within a multi-line print or return statements.  So, let's skip over such
164    # statements whose content should not be loading modules anyway. -BEF-
165    #
166    if (m/print(?:\s+|\s+\S+\s+)\<\<\s*(["'`])(.+?)\1/ ||
167        m/print(\s+|\s+\S+\s+)\<\<(\w+)/ ||
168	m/return(\s+)\<\<(\w+)/ ) {
169
170        my $tag = $2;
171        while (<FILE>) {
172            chomp;
173            ( $_ eq $tag ) && last;
174        }
175        $_ = <FILE>;
176    }
177
178    # Skip multiline print and assign statements
179    if ( m/\$\S+\s*=\s*(")([^"\\]|(\\.))*$/ ||
180         m/\$\S+\s*=\s*(')([^'\\]|(\\.))*$/ ||
181         m/print\s+(")([^"\\]|(\\.))*$/ ||
182         m/print\s+(')([^'\\]|(\\.))*$/ ) {
183
184        my $quote = $1;
185        while (<FILE>) {
186          m/^([^\\$quote]|(\\.))*$quote/ && last;
187        }
188        $_ = <FILE>;
189    }
190
191    if (
192
193# ouch could be in a eval, perhaps we do not want these since we catch
194# an exception they must not be required
195
196#   eval { require Term::ReadLine } or die $@;
197#   eval "require Term::Rendezvous;" or die $@;
198#   eval { require Carp } if defined $^S; # If error/warning during compilation,
199
200
201        (m/^(\s*)         # we hope the inclusion starts the line
202         (require|use)\s+(?!\{)     # do not want 'do {' loops
203         # quotes around name are always legal
204         ['"]?([\w:\.\/]+?)['"]?[\t; ]
205         # the syntax for 'use' allows version requirements
206         # the latter part is for "use base qw(Foo)" and friends special case
207         \s*($modver_re|(qw\s*[(\/'"]\s*|['"])[^)\/"'\$]*?\s*[)\/"'])?
208         /x)
209       ) {
210      my ($whitespace, $statement, $module, $version) = ($1, $2, $3, $4);
211
212      # we only consider require statements that are flushed against
213      # the left edge. any other require statements give too many
214      # false positives, as they are usually inside of an if statement
215      # as a fallback module or a rarely used option
216
217      ($whitespace ne "" && $statement eq "require") && next;
218
219      # if there is some interpolation of variables just skip this
220      # dependency, we do not want
221      #        do "$ENV{LOGDIR}/$rcfile";
222
223      ($module =~ m/\$/) && next;
224
225      # skip if the phrase was "use of" -- shows up in gimp-perl, et al.
226      next if $module eq 'of';
227
228      # if the module ends in a comma we probably caught some
229      # documentation of the form 'check stuff,\n do stuff, clean
230      # stuff.' there are several of these in the perl distribution
231
232      ($module  =~ m/[,>]$/) && next;
233
234      # if the module name starts in a dot it is not a module name.
235      # Is this necessary?  Please give me an example if you turn this
236      # back on.
237
238      #      ($module =~ m/^\./) && next;
239
240      # if the module starts with /, it is an absolute path to a file
241      if ($module =~ m(^/)) {
242        print "$module\n";
243        next;
244      }
245
246      # sometimes people do use POSIX qw(foo), or use POSIX(qw(foo)) etc.
247      # we can strip qw.*$, as well as (.*$:
248      $module =~ s/qw.*$//;
249      $module =~ s/\(.*$//;
250
251      # if the module ends with .pm, strip it to leave only basename.
252      $module =~ s/\.pm$//;
253
254      # some perl programmers write 'require URI/URL;' when
255      # they mean 'require URI::URL;'
256
257      $module =~ s/\//::/;
258
259      # trim off trailing parentheses if any.  Sometimes people pass
260      # the module an empty list.
261
262      $module =~ s/\(\s*\)$//;
263
264      if ( $module =~ m/^v?([0-9._]+)$/ ) {
265      # if module is a number then both require and use interpret that
266      # to mean that a particular version of perl is specified
267
268      my $ver = $1;
269      if ($ver =~ /5.00/) {
270        $perlreq{"0:$ver"} = 1;
271        next;
272      }
273      else {
274        $perlreq{"1:$ver"} = 1;
275        next;
276      }
277
278      };
279
280      # ph files do not use the package name inside the file.
281      # perlmodlib documentation says:
282
283      #       the .ph files made by h2ph will probably end up as
284      #       extension modules made by h2xs.
285
286      # so do not expend much effort on these.
287
288
289      # there is no easy way to find out if a file named systeminfo.ph
290      # will be included with the name sys/systeminfo.ph so only use the
291      # basename of *.ph files
292
293      ($module =~ m/\.ph$/) && next;
294
295      # use base|parent qw(Foo) dependencies
296      if ($statement eq "use" && ($module eq "base" || $module eq "parent")) {
297        add_require($module, undef);
298        if ($version =~ /^qw\s*[(\/'"]\s*([^)\/"']+?)\s*[)\/"']/) {
299          add_require($_, undef) for split(' ', $1);
300        }
301        elsif ($version =~ /(["'])([^"']+)\1/) {
302          add_require($2, undef);
303        }
304        next;
305      }
306      $version = undef unless $version =~ /^$modver_re$/o;
307
308      add_require($module, $version);
309    }
310
311  }
312
313  close(FILE) ||
314    die("$0: Could not close file: '$file' : $!\n");
315
316  return;
317}
318