Changeset 3462 in MondoRescue


Ignore:
Timestamp:
Sep 10, 2015, 10:46:19 AM (9 years ago)
Author:
Bruno Cornec
Message:
  • Fix mindi-get-perl-modules, non working on Debian 8 and probably other distribs by removing completely old code remaining, and avoiding mixing up with @INC. Simpler and now working on Debian 8 as well as Mageia 5
File:
1 edited

Legend:

Unmodified
Added
Removed

  • branches/3.2/mindi/mindi-get-perl-modules

    r3390 r3462  
    7474$pbdebug = 0 if (not defined $pbdebug);
    7575
    76 # Remove non exiting directories from @INC
    77 # and thus avoid perl warnings
    78 #
    79 pb_log(1,"Searching originally in ");
    80 pb_log(1,join " - ", @INC);
    81 pb_log(1,"\n");
    82 
    83 foreach my $d (@INC) {
    84     $d = mr_file_read_all_link($d) if (-l $d);
    85     push @includes,$d if (-d $d);
    86 }
    87 
    88 pb_log(1,"Searching finally in    ");
    89 pb_log(1,join " - ", @INC);
    90 pb_log(1,"\n");
    91 
    92 # deduplicate entry list
    9376if (not defined $ARGV[0]) {
    9477    pb_syntax();
    … …  
    9780pb_temp_init();
    9881
    99 my $tmpf = "$ENV{'PBTMP'}/mpgm.$$.pl";
     82# Adds missing modules not found automatically in certain cases
     83#
     84my $tmpf = "$ENV{'PBTMP'}/mgpm.$$.pl";
    10085
    10186open(TMPF,"> $tmpf") || die "Unable to create $tmpf: !$\n";
    … …  
    129114
    130115exit 0;
    131 
    132 sub mr_get_perl_modules {
    133 
    134 my $f = shift;
    135 my %newly_found;
    136 my $require;
    137 
    138 return($require) if (not defined $f);
    139 $require = mr_process_file($f);
    140 
    141 pb_log(1,"Requires on $f found:\n");
    142 pb_log(1,Dumper($require));
    143 pb_log(1,"---------------\n");
    144 
    145 my $cpt = keys %$require;
    146 
    147 # Exit recursion
    148 return($require) if ($cpt == 0);
    149 
    150 foreach my $m (keys %$require) {
    151     (my $mod = $m) =~ s|::|/|g;
    152     # Already found
    153     next if (exists $found{$mod});
    154     foreach my $d (@includes) {
    155         pb_log(1,"Looking at $m in $d\n");
    156         if (-f "$d/$mod.pm") {
    157             $files{"$d/$mod.pm"} = $mod;
    158             $found{$mod} = "$d/$mod.pm";
    159             $newly_found{"$d/$mod.pm"} = $mod;
    160             pb_log(1,"Found $mod in $d/$mod.pm\n");
    161             last;
    162         }
    163     }
    164     print STDERR "ERROR: Unable to find $mod. Your perl setup may be incorrect\n" if (not exists $found{$mod});
    165 }
    166                    
    167 pb_log(1,"Files found:\n");
    168 pb_log(1,Dumper(\%files));
    169 pb_log(2,Dumper(\%found));
    170 pb_log(1,"---------------\n");
    171 
    172 pb_log(1,"New Files found:\n");
    173 pb_log(1,Dumper(\%newly_found));
    174 pb_log(1,"---------------\n");
    175 
    176 my $foundrec;
    177 
    178 $cpt = keys %newly_found;
    179 if ($cpt != 0) {
    180     # Recurse on what we just found
    181     foreach my $f (keys %newly_found) {
    182         $foundrec = mr_get_perl_modules($f);
    183         foreach my $k (keys %$foundrec) {
    184             $files{$k} = $foundrec->{$k};
    185         }
    186     }
    187 
    188     # Cleanup
    189     foreach my $k (keys %newly_found) {
    190         delete $newly_found{$k};
    191     }
    192 }
    193 
    194 pb_log(1,"End of mr_get_perl_modules on $f we got:".Dumper(\%files)."\n");
    195 
    196 return(\%files);
    197 }
    198 
    199 # Adapted From /usr/lib/rpm/mageia/perl.req
    200 # by Ken Estes Mail.com kestes@staff.mail.com
    201 # used under the GPL
    202 
    203 sub mr_process_file {
    204  
    205 my $file = shift;
    206 my %line;
    207 my %list_req;
    208 my $current_line = undef;
    209 my $tag = undef;
    210 
    211 return(\%list_req) if (not defined $file);
    212 
    213 pb_log(2, "START Analyze $file\n");
    214 # In a recursive configuration we need a var as file handle
    215 open(my $fh, "$file") || return(\%list_req);
    216 while (my $line = <$fh>) {
    217 
    218     # skip the "= <<" block
    219 
    220     pb_log(2, "LINE: $line");
    221     if ( ( $line =~ m/^\s*\$(.*)\s*=\s*<<\s*["'](.*)['"]/i) ||
    222         ($line =~ m/^\s*\$(.*)\s*=\s*<<\s*(.*);/i) ) {
    223         $tag = $2;
    224         while (my $l = <$fh>) {
    225             pb_log(2, "LINE-tag: $l");
    226             ( $l =~ /^$tag/) && last;
    227         }
    228     }
    229 
    230     pb_log(2, "PHASE 2: $line");
    231     # skip the documentation
    232 
    233     # we should not need to have item in this if statement (it
    234     # properly belongs in the over/back section) but people do not
    235     # read the perldoc.
    236 
    237     if ( ($line =~ m/^=(head1|head2|pod|item)/) .. ($line =~ m/^=(cut)/) ) {
    238         pb_log(2, "PHASE 2bis:$line");
    239         next;
    240     }
    241     pb_log(2, "PHASE 3:\n");
    242 
    243     if ( ($line =~ m/^=(over)/) .. ($line =~ m/^=(back)/) ) {
    244         next;
    245     }
    246     pb_log(2, "PHASE 4:\n");
    247    
    248     # skip the data section
    249     if ($line =~ m/^__(DATA|END)__$/) {
    250         last;
    251     }
    252     pb_log(2, "PHASE 5:\n");
    253 
    254     # Each keyword can appear multiple times.  Don't
    255     #  bother with datastructures to store these strings,
    256     #  if we need to print it print it now.
    257 
    258     if ($line =~  m/^\s*\$RPM_Requires\s*=\s*["'](.*)['"]/i) {
    259         foreach my $l (split(/\s+/, $1)) {
    260             print "$l\n";
    261             }
    262     }
    263     pb_log(2, "PHASE 6:\n");
    264 
    265     if (
    266 
    267 # ouch could be in a eval, perhaps we do not want these since we catch
    268 # an exception they must not be required
    269 
    270 #   eval { require Term::ReadLine } or die $@;
    271 #   eval "require Term::Rendezvous;" or die $@;
    272 #   eval { require Carp } if defined $^S; # If error/warning during compilation,
    273 
    274 
    275     ($line =~ m/^(\s*)         # we hope the inclusion starts the line
    276         (require|use)\s+(?!\{)     # do not want 'do bracket' loops
    277         # quotes around name are always legal
    278         [\'\"]?([^\;\ \'\"\t]*)[\'\"]?[\t\;\ ]
    279         # the syntax for 'use' allows version requirements
    280         \s*([.0-9]*)
    281         /x)
    282     ) {
    283         pb_log(2, "REQUIRE FOUND ***\n");
    284         my ($whitespace, $statement, $module, $version) = ($1, $2, $3,$4);
    285         my $usebase;
    286 
    287         # we only consider require statements that are flush against
    288         # the left edge. any other require statements give too many
    289         # false positives, as they are usually inside of an if statement
    290         # as a fallback module or a rarely used option
    291 
    292         ($whitespace !~ /^\s*$/ && $statement eq "require") && next;
    293 
    294         pb_log(2, "REQUIRE AV *** $whitespace, $statement, $module, $version ***\n");
    295         # if there is some interpolation of variables just skip this
    296         # dependency, we do not want
    297         #        do "$ENV{LOGDIR}/$rcfile";
    298 
    299         ($module =~ m/\$/) && next;
    300 
    301         # skip if the phrase was "use of" -- shows up in gimp-perl, et al
    302         next if $module eq 'of';
    303 
    304         # if the module ends in a comma we probaly caught some
    305         # documentation of the form 'check stuff,\n do stuff, clean
    306         # stuff.' there are several of these in the perl distribution
    307 
    308         ($module  =~ m/[,>]$/) && next;
    309 
    310         # if the module name starts in a dot it is not a module name.
    311         # Is this necessary?  Please give me an example if you turn this
    312         # back on.
    313 
    314         #      ($module =~ m/^\./) && next;
    315 
    316         # if the module ends with .pm strip it to leave only basename.
    317         # starts with /, which means its an absolute path to a file
    318         if ($module =~ m(^/)) {
    319             print "$module\n";
    320             next;
    321         }
    322 
    323         # as seen in some perl scripts
    324         # use base qw(App::CLI Class::Accessor::Chained::Fast App::CLI::Command);
    325         if ($module eq 'base') {
    326             $list_req{$module} = $version;
    327             $line{$module} = $current_line;
    328             ($module = $line) =~ s/use\s*base\s*//;
    329             $module =~ s/qw\((.*)\)\s*;/$1/;
    330             $module =~ s/qw(.)(.*)\1\s*;/$2/;
    331             $module =~ s/\s*;$//;
    332             $module =~ s/#.*//;
    333             $usebase = 1;
    334         }
    335         # sometimes people do use POSIX qw(foo), or use POSIX(qw(foo)) etc
    336         # we can strip qw.*$, as well as (.*$:
    337         $module =~ s/qw.*$//;
    338         $module =~ s/\(.*$//;
    339 
    340         $module =~ s/\.pm$//;
    341 
    342         # some perl programmers write 'require URI/URL;' when
    343         # they mean 'require URI::URL;'
    344 
    345         $module =~ s/\//::/;
    346 
    347         # trim off trailing parenthesis if any.  Sometimes people pass
    348         # the module an empty list.
    349    
    350         $module =~ s/\(\s*\)$//;
    351 
    352         # if module is a number then both require and use interpret that
    353         # to mean that a particular version of perl is specified. Don't
    354         # add a dependency, though, since the rpm will already require
    355         # perl-base at the build version (via find-requires)
    356         next if $module =~ /^v?\d/;
    357 
    358         # ph files do not use the package name inside the file.
    359         # perlmodlib  documentation says:
    360         #       the .ph files made by h2ph will probably end up as
    361         #       extension modules made by h2xs.
    362         # so do not spend much effort on these.
    363 
    364         # there is no easy way to find out if a file named systeminfo.ph
    365         # will be included with the name sys/systeminfo.ph so only use the
    366         # basename of *.ph files
    367 
    368         ($module  =~ m/\.ph$/) && next;
    369 
    370         # if the module was loaded trough base, we need to split the list
    371         if ($usebase) {
    372             my $current_line = $line;
    373             foreach my $l (split(/\s+/, $module)) {
    374                 next unless $l;
    375                 $list_req{$l} = $version;
    376                 $line{$l} = $current_line;
    377             }
    378         } else {
    379             $list_req{$module}=$version;
    380             $line{$module}=$current_line;
    381         }
    382         pb_log(2, "REQUIRE FIN *** ".Dumper(\%list_req)." ***\n");
    383     }
    384 }
    385 
    386 close($fh) || die("$0: Could not close file: '$file' : $!\n");
    387 
    388 return(\%list_req);
    389 }
Note: See TracChangeset for help on using the changeset viewer.