source: branches/3.2/mindi/mindi-get-perl-modules @ 3383

Last change on this file since 3383 was 3383, checked in by Bruno Cornec, 5 years ago
  • Fix mindi-get-perl-modules to get all modules in dependency as well (pb with Expoerter module missing during UEFI tests)
  • Property svn:executable set to *
File size: 7.7 KB
Line 
1#!/usr/bin/perl -w
2#
3# $Id$
4# Copyright B. Cornec 2005-2013
5# Provided under the GPL v2
6#
7# Get perl modules required by mindi and mondo and that should be on the restore media
8#
9use strict;
10
11use File::Find;
12use MondoRescue::File;
13
14
15=pod
16
17=head1 NAME
18
19mindi-get-perl-modules keeps track of the perl modules that should be on your restore media
20
21=head1 DESCRIPTION
22
23mindi-get-perl-modules keeps track of the perl modules that should be on your restore media by analyzing the references made to them in the scripts passed as parameters and returning all the modules needed to have them work correctly.
24
25=head1 SYNOPSIS
26
27mindi-get-perl-modules /path/to/perl-script ...
28
29=head1 ARGUMENTS
30
31=over 4
32
33=item B</path/to/perl-script>
34
35This is the path of the perl script to analyze and for which we want its perl modules in dependence to be included
36
37=back
38
39=head1 WEB SITES
40
41The main Web site of the project is available at L<http://www.mondorescue.org>. Bug reports should be filled using the trac instance of the project at L<http://trac.mondorescue.org/>.
42
43=head1 USER MAILING LIST
44
45For community exchanges around MondoRescue please use the list L<http://sourceforge.net/mailarchive/forum.php?forum_name=mondo-devel>
46
47=head1 AUTHORS
48
49The MondoRescue team lead by Bruno Cornec L<mailto:bruno@mondorescue.org>.
50
51=head1 COPYRIGHT
52
53MondoRescue is distributed under the GPL v2.0 license or later,
54described in the file C<COPYING> included with the distribution.
55
56=cut
57
58
59my $file = mr_get_perl_modules(@ARGV) if (defined $ARGV[0]);
60
61foreach my $f (sort keys %$file) {
62    print "$f\n";
63}
64
65exit 0;
66
67sub mr_get_perl_modules {
68
69my %files;
70
71#print "Searching in ";
72#print join "\n", @INC;
73
74my $require = mr_process_file(@_);
75
76my @includes;
77
78# Remove non exiting directories from @INC
79# and thus avoid perl warnings
80#
81foreach my $d (@INC) {
82    $d = mr_file_read_all_link($d) if (-l $d);
83    push @includes,$d if (-d $d);
84}
85
86find(
87    sub {
88        if ((-f $File::Find::name) 
89            && (/\.pm$/) 
90            && (not defined $files{$File::Find::name})) {
91            foreach my $m (keys %$require,"warnings") {
92                (my $mod = $m) =~ s|::|/|g;
93                #print "Looking at $mod in $File::Find::name\n";
94                if (index($File::Find::name,"$mod.pm") ne -1) {
95                    $files{$File::Find::name} = $mod;
96                    #push @files, $File::Find::name;
97                    #print "Found $mod in $File::Find::name\n";
98                    last;
99                }
100            }
101        }
102    },
103    @includes);
104
105# Recurse on what we just found
106my $found = mr_process_file(keys %files);
107find(
108    sub {
109        if ((-f $File::Find::name) 
110            && (/\.pm$/) 
111            && (not defined $files{$File::Find::name})) {
112            foreach my $m (keys %$found) {
113                (my $mod = $m) =~ s|::|/|g;
114                #print "Looking at $mod in $File::Find::name\n";
115                if (index($File::Find::name,"$mod.pm") ne -1) {
116                    $files{$File::Find::name} = $mod;
117                    #push @files, $File::Find::name;
118                    #print "Found $mod in $File::Find::name\n";
119                    last;
120                }
121            }
122        }
123    },
124    @includes);
125
126
127return(\%files);
128}
129
130# Adapted From /usr/lib/rpm/mageia/perl.req
131# by Ken Estes Mail.com kestes@staff.mail.com
132# used under the GPL
133
134sub mr_process_file {
135 
136my %line;
137my %require;
138my $current_line;
139my $tag;
140
141foreach my $file (@_) {
142 
143    open(FILE, "<$file") || return(\%require);
144    while (<FILE>) {
145
146        # skip the "= <<" block
147
148        if ( ( m/^\s*\$(.*)\s*=\s*<<\s*["'](.*)['"]/i) ||
149            ( m/^\s*\$(.*)\s*=\s*<<\s*(.*);/i) ) {
150            $tag = $2;
151            while (<FILE>) {
152                ( $_ =~ /^$tag/) && last;
153            }
154        }
155
156        # skip the documentation
157   
158        # we should not need to have item in this if statement (it
159        # properly belongs in the over/back section) but people do not
160        # read the perldoc.
161   
162        if ( (m/^=(head1|head2|pod|item)/) .. (m/^=(cut)/) ) {
163            next;
164        }
165   
166        if ( (m/^=(over)/) .. (m/^=(back)/) ) {
167            next;
168        }
169       
170        # skip the data section
171        if (m/^__(DATA|END)__$/) {
172            last;
173        }
174   
175        # Each keyword can appear multiple times.  Don't
176        #  bother with datastructures to store these strings,
177        #  if we need to print it print it now.
178   
179        if ( m/^\s*\$RPM_Requires\s*=\s*["'](.*)['"]/i) {
180            foreach $_ (split(/\s+/, $1)) {
181                print "$_\n";
182                }
183        }
184
185        if ( 
186
187# ouch could be in a eval, perhaps we do not want these since we catch
188# an exception they must not be required
189
190#   eval { require Term::ReadLine } or die $@;
191#   eval "require Term::Rendezvous;" or die $@;
192#   eval { require Carp } if defined $^S; # If error/warning during compilation,
193
194
195        (m/^(\s*)         # we hope the inclusion starts the line
196            (require|use)\s+(?!\{)     # do not want 'do bracket' loops
197            # quotes around name are always legal
198            [\'\"]?([^\;\ \'\"\t]*)[\'\"]?[\t\;\ ]
199            # the syntax for 'use' allows version requirements
200            \s*([.0-9]*)
201            /x)
202        ) {
203            my ($whitespace, $statement, $module, $version) = ($1, $2, $3,$4);
204            my $usebase;
205
206            # we only consider require statements that are flush against
207            # the left edge. any other require statements give too many
208            # false positives, as they are usually inside of an if statement
209            # as a fallback module or a rarely used option
210
211            ($whitespace ne "" && $statement eq "require") && next;
212   
213            # if there is some interpolation of variables just skip this
214            # dependency, we do not want
215            #        do "$ENV{LOGDIR}/$rcfile";
216   
217            ($module =~ m/\$/) && next;
218   
219            # skip if the phrase was "use of" -- shows up in gimp-perl, et al
220            next if $module eq 'of';
221   
222            # if the module ends in a comma we probaly caught some
223            # documentation of the form 'check stuff,\n do stuff, clean
224            # stuff.' there are several of these in the perl distribution
225   
226            ($module  =~ m/[,>]$/) && next;
227   
228            # if the module name starts in a dot it is not a module name.
229            # Is this necessary?  Please give me an example if you turn this
230            # back on.
231   
232            #      ($module =~ m/^\./) && next;
233   
234            # if the module ends with .pm strip it to leave only basename.
235            # starts with /, which means its an absolute path to a file
236            if ($module =~ m(^/)) {
237                print "$module\n";
238                next;
239            }
240   
241            # as seen in some perl scripts
242            # use base qw(App::CLI Class::Accessor::Chained::Fast App::CLI::Command);
243            if ($module eq 'base') {
244                $require{$module} = $version;
245                $line{$module} = $current_line;
246                ($module = $_) =~ s/use\s*base\s*//;
247                $module =~ s/qw\((.*)\)\s*;/$1/;
248                $module =~ s/qw(.)(.*)\1\s*;/$2/;
249                $module =~ s/\s*;$//;
250                $module =~ s/#.*//;
251                $usebase = 1;
252            }
253            # sometimes people do use POSIX qw(foo), or use POSIX(qw(foo)) etc
254            # we can strip qw.*$, as well as (.*$:
255            $module =~ s/qw.*$//;
256            $module =~ s/\(.*$//;
257   
258            $module =~ s/\.pm$//;
259   
260            # some perl programmers write 'require URI/URL;' when
261            # they mean 'require URI::URL;'
262   
263            $module =~ s/\//::/;
264   
265            # trim off trailing parenthesis if any.  Sometimes people pass
266            # the module an empty list.
267       
268            $module =~ s/\(\s*\)$//;
269
270            # if module is a number then both require and use interpret that
271            # to mean that a particular version of perl is specified. Don't
272            # add a dependency, though, since the rpm will already require
273            # perl-base at the build version (via find-requires)
274            next if $module =~ /^v?\d/;
275
276            # ph files do not use the package name inside the file.
277            # perlmodlib  documentation says:
278            #       the .ph files made by h2ph will probably end up as
279            #       extension modules made by h2xs.
280            # so do not spend much effort on these.
281
282            # there is no easy way to find out if a file named systeminfo.ph
283            # will be included with the name sys/systeminfo.ph so only use the
284            # basename of *.ph files
285
286            ($module  =~ m/\.ph$/) && next;
287
288            # if the module was loaded trough base, we need to split the list
289            if ($usebase) {
290                my $current_line = $_;
291                foreach (split(/\s+/, $module)) {
292                    next unless $_;
293                    $require{$_} = $version;
294                    $line{$_} = $current_line;
295                }
296            } else {
297                $require{$module}=$version;
298                $line{$module}=$current_line;
299            }
300        }
301    }
302
303close(FILE) || die("$0: Could not close file: '$file' : $!\n");
304}
305
306return(\%require);
307}
Note: See TracBrowser for help on using the repository browser.