source: MondoRescue/branches/3.2/mindi/mindi-get-perl-modules @ 3231

Last change on this file since 3231 was 3231, checked in by Bruno Cornec, 6 years ago
  • Try to put everything for mindi under /usr now with the way the latest distros work.
  • symlinks.tgz is gone as a consequence
  • FAILSAFE kernel is now gone in mindi
  • mindi now uses the new mr-read-all-link and mr-process-ldd perl scripts.
  • All this makes this version 3.0.0
  • Property svn:executable set to *
File size: 7.2 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
65sub mr_get_perl_modules {
66
67my %files;
68
69#print "Searching in ";
70#print join "\n", @INC;
71
72my $require = mr_process_file(@_);
73
74my @includes;
75
76# Remove non exiting directories from @INC
77# and thus avoid perl warnings
78#
79foreach my $d (@INC) {
80    $d = mr_file_read_all_link($d) if (-l $d);
81    push @includes,$d if (-d $d);
82}
83
84find(
85    sub {
86        if ((-f $File::Find::name) 
87            && (/\.pm$/) 
88            && (not defined $files{$File::Find::name})) {
89            foreach my $m (keys %$require,"warnings") {
90                (my $mod = $m) =~ s|::|/|g;
91                #print "Looking at $mod in $File::Find::name\n";
92                if (index($File::Find::name,"$mod.pm") ne -1) {
93                    $files{$File::Find::name} = $mod;
94                    #push @files, $File::Find::name;
95                    #print "Found $mod in $File::Find::name\n";
96                    last;
97                }
98            }
99        }
100    },
101    @includes);
102
103return(\%files);
104}
105
106# Adapted From /usr/lib/rpm/mandriva/perl.req
107# by Ken Estes Mail.com kestes@staff.mail.com
108# used under the GPL
109
110sub mr_process_file {
111 
112my %line;
113my %require;
114my $current_line;
115my $tag;
116
117foreach my $file (@_) {
118 
119    open(FILE, "<$file") || return(\%require);
120    while (<FILE>) {
121
122        # skip the "= <<" block
123
124        if ( ( m/^\s*\$(.*)\s*=\s*<<\s*["'](.*)['"]/i) ||
125            ( m/^\s*\$(.*)\s*=\s*<<\s*(.*);/i) ) {
126            $tag = $2;
127            while (<FILE>) {
128                ( $_ =~ /^$tag/) && last;
129            }
130        }
131
132        # skip the documentation
133   
134        # we should not need to have item in this if statement (it
135        # properly belongs in the over/back section) but people do not
136        # read the perldoc.
137   
138        if ( (m/^=(head1|head2|pod|item)/) .. (m/^=(cut)/) ) {
139            next;
140        }
141   
142        if ( (m/^=(over)/) .. (m/^=(back)/) ) {
143            next;
144        }
145       
146        # skip the data section
147        if (m/^__(DATA|END)__$/) {
148            last;
149        }
150   
151        # Each keyword can appear multiple times.  Don't
152        #  bother with datastructures to store these strings,
153        #  if we need to print it print it now.
154   
155        if ( m/^\s*\$RPM_Requires\s*=\s*["'](.*)['"]/i) {
156            foreach $_ (split(/\s+/, $1)) {
157                print "$_\n";
158                }
159        }
160
161        if ( 
162
163# ouch could be in a eval, perhaps we do not want these since we catch
164# an exception they must not be required
165
166#   eval { require Term::ReadLine } or die $@;
167#   eval "require Term::Rendezvous;" or die $@;
168#   eval { require Carp } if defined $^S; # If error/warning during compilation,
169
170
171        (m/^(\s*)         # we hope the inclusion starts the line
172            (require|use)\s+(?!\{)     # do not want 'do bracket' loops
173            # quotes around name are always legal
174            [\'\"]?([^\;\ \'\"\t]*)[\'\"]?[\t\;\ ]
175            # the syntax for 'use' allows version requirements
176            \s*([.0-9]*)
177            /x)
178        ) {
179            my ($whitespace, $statement, $module, $version) = ($1, $2, $3,$4);
180            my $usebase;
181
182            # we only consider require statements that are flush against
183            # the left edge. any other require statements give too many
184            # false positives, as they are usually inside of an if statement
185            # as a fallback module or a rarely used option
186
187            ($whitespace ne "" && $statement eq "require") && next;
188   
189            # if there is some interpolation of variables just skip this
190            # dependency, we do not want
191            #        do "$ENV{LOGDIR}/$rcfile";
192   
193            ($module =~ m/\$/) && next;
194   
195            # skip if the phrase was "use of" -- shows up in gimp-perl, et al
196            next if $module eq 'of';
197   
198            # if the module ends in a comma we probaly caught some
199            # documentation of the form 'check stuff,\n do stuff, clean
200            # stuff.' there are several of these in the perl distribution
201   
202            ($module  =~ m/[,>]$/) && next;
203   
204            # if the module name starts in a dot it is not a module name.
205            # Is this necessary?  Please give me an example if you turn this
206            # back on.
207   
208            #      ($module =~ m/^\./) && next;
209   
210            # if the module ends with .pm strip it to leave only basename.
211            # starts with /, which means its an absolute path to a file
212            if ($module =~ m(^/)) {
213                print "$module\n";
214                next;
215            }
216   
217            # as seen in some perl scripts
218            # use base qw(App::CLI Class::Accessor::Chained::Fast App::CLI::Command);
219            if ($module eq 'base') {
220                $require{$module} = $version;
221                $line{$module} = $current_line;
222                ($module = $_) =~ s/use\s*base\s*//;
223                $module =~ s/qw\((.*)\)\s*;/$1/;
224                $module =~ s/qw(.)(.*)\1\s*;/$2/;
225                $module =~ s/\s*;$//;
226                $module =~ s/#.*//;
227                $usebase = 1;
228            }
229            # sometimes people do use POSIX qw(foo), or use POSIX(qw(foo)) etc
230            # we can strip qw.*$, as well as (.*$:
231            $module =~ s/qw.*$//;
232            $module =~ s/\(.*$//;
233   
234            $module =~ s/\.pm$//;
235   
236            # some perl programmers write 'require URI/URL;' when
237            # they mean 'require URI::URL;'
238   
239            $module =~ s/\//::/;
240   
241            # trim off trailing parenthesis if any.  Sometimes people pass
242            # the module an empty list.
243       
244            $module =~ s/\(\s*\)$//;
245
246            # if module is a number then both require and use interpret that
247            # to mean that a particular version of perl is specified. Don't
248            # add a dependency, though, since the rpm will already require
249            # perl-base at the build version (via find-requires)
250            next if $module =~ /^v?\d/;
251
252            # ph files do not use the package name inside the file.
253            # perlmodlib  documentation says:
254            #       the .ph files made by h2ph will probably end up as
255            #       extension modules made by h2xs.
256            # so do not spend much effort on these.
257
258            # there is no easy way to find out if a file named systeminfo.ph
259            # will be included with the name sys/systeminfo.ph so only use the
260            # basename of *.ph files
261
262            ($module  =~ m/\.ph$/) && next;
263
264            # if the module was loaded trough base, we need to split the list
265            if ($usebase) {
266                my $current_line = $_;
267                foreach (split(/\s+/, $module)) {
268                    next unless $_;
269                    $require{$_} = $version;
270                    $line{$_} = $current_line;
271                }
272            } else {
273                $require{$module}=$version;
274                $line{$module}=$current_line;
275            }
276        }
277    }
278
279close(FILE) || die("$0: Could not close file: '$file' : $!\n");
280}
281
282return(\%require);
283}
Note: See TracBrowser for help on using the repository browser.