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