Changeset 3386 in MondoRescue


Ignore:
Timestamp:
May 14, 2015, 7:03:47 AM (10 years ago)
Author:
Bruno Cornec
Message:
  • Fix mindi-get-perl-modules by avoinding doing recursivity *and* multi file in the same function. We now have a single parameter for the recursive functions and loop around it to avoid variables management issues
Location:
branches/3.2/mindi
Files:
2 edited

Legend:

Unmodified
Added
Removed

  • branches/3.2/mindi/mindi

    r3384 r3386  
    26322632
    26332633    # Management of perl scripts delivered needed at restore time
    2634     mindi-get-perl-modules `cat $MINDI_CONF/perl-scripts` /usr/[s]*bin/mr-* > $MINDI_TMP/perl.lis
     2634    LogIt "INFO: Analyzing perl modules dependencies" $MINDI_TMP/$$.log
     2635    mindi-get-perl-modules `cat $MINDI_CONF/perl-scripts` /usr/[s]*bin/mr-* 2>> $MINDI_TMP/$$.log > $MINDI_TMP/perl.lis
    26352636    tar cf - `cat $MINDI_TMP/perl.lis` 2>> $MINDI_TMP/$$.log | tar xf - || LogIt "ERROR: Problem in perl scripts analysis" $MINDI_TMP/$$.log
    26362637

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

    r3385 r3386  
    1212use Data::Dumper;
    1313use File::Basename;
     14use ProjectBuilder::Base;
     15use Getopt::Long qw(:config auto_abbrev no_ignore_case);
    1416
    1517=pod
    … …  
    5658=cut
    5759
     60# Globals
    5861my %files;
    5962my %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 
     63my %opts;
    8764my @includes;
     65my $req;
     66my %args;
     67
     68GetOptions(
     69     "verbose|v+" => \$opts{'v'},
     70);
     71
     72pb_syntax_init("mindi-get-perl-modules Version PBVER-rPBREV\n");
     73
     74$pbdebug = $opts{'v'};
     75$pbdebug = 0 if (not defined $pbdebug);
    8876
    8977# Remove non exiting directories from @INC
    9078# and thus avoid perl warnings
    9179#
     80pb_log(1,"Searching originally in ");
     81pb_log(1,join " - ", @INC);
     82pb_log(1,"\n");
     83
    9284foreach my $d (@INC) {
    9385    $d = mr_file_read_all_link($d) if (-l $d);
    9486    push @includes,$d if (-d $d);
    9587}
     88
     89pb_log(1,"Searching finally in    ");
     90pb_log(1,join " - ", @INC);
     91pb_log(1,"\n");
     92
     93# deduplicate entry list
     94if (defined $ARGV[0]) {
     95    %args = map { $_, 1 } @ARGV;
     96} else {
     97    pb_syntax();
     98}
     99
     100pb_temp_init();
     101
     102my $tmpf = "$ENV{'PBTMP'}/mpgm.$$";
     103
     104open(TMPF,"> $tmpf") || die "Unable to create $tmpf: !$\n";
     105print TMPF "# To include module corresponding to perl -w\n";
     106print TMPF "use warnings;\n";
     107print TMPF "# To include module used by Data:Dumper in a masked way for this script\n";
     108print TMPF "use bytes;\n";
     109close(TMPF);
     110
     111foreach my $f (keys %args,"$tmpf") {
     112    pb_log(1,"Get perl modules on $f\n");
     113    $req = mr_get_perl_modules($f);
     114    foreach my $k (keys %$req) {
     115        $files{$k} = $req->{$k};
     116    }
     117    pb_log(1,"After mr_get_perl_modules on $f we got:".Dumper(\%files)."\n");
     118}
     119unlink("$tmpf");
     120
     121foreach my $f (sort keys %files) {
     122    print "$f\n";
     123}
     124
     125exit 0;
     126
     127sub mr_get_perl_modules {
     128
     129my $f = shift;
     130my %newly_found;
     131my $require;
     132
     133return($require) if (not defined $f);
     134$require = mr_process_file($f);
     135
     136pb_log(1,"Requires on $f found:\n");
     137pb_log(1,Dumper($require));
     138pb_log(1,"---------------\n");
     139
     140my $cpt = keys %$require;
     141
     142# Exit recursion
     143return($require) if ($cpt == 0);
    96144
    97145foreach my $m (keys %$require) {
    … …  
    100148    next if (exists $found{$mod});
    101149    foreach my $d (@includes) {
    102             #print "Looking at $m in $d\n";
     150        pb_log(1,"Looking at $m in $d\n");
    103151        if (-f "$d/$mod.pm") {
    104152            $files{"$d/$mod.pm"} = $mod;
    105153            $found{$mod} = "$d/$mod.pm";
    106154            $newly_found{"$d/$mod.pm"} = $mod;
    107             #print "Found $mod in $d/$mod.pm\n";
     155            pb_log(1,"Found $mod in $d/$mod.pm\n");
    108156            last;
    109157        }
    110158    }
    111     print "ERROR: Unable to find $mod. Your perl setup is incorrect\n" if (not exists $found{$mod});
     159    print STDERR "ERROR: Unable to find $mod. Your perl setup may be incorrect\n" if (not exists $found{$mod});
    112160}
    113161                   
    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 }
     162pb_log(1,"Files found:\n");
     163pb_log(1,Dumper(\%files));
     164pb_log(2,Dumper(\%found));
     165pb_log(1,"---------------\n");
     166
     167pb_log(1,"New Files found:\n");
     168pb_log(1,Dumper(\%newly_found));
     169pb_log(1,"---------------\n");
     170
     171my $foundrec;
     172
     173$cpt = keys %newly_found;
     174if ($cpt != 0) {
     175    # Recurse on what we just found
     176    foreach my $f (keys %newly_found) {
     177        $foundrec = mr_get_perl_modules($f);
     178        foreach my $k (keys %$foundrec) {
     179            $files{$k} = $foundrec->{$k};
     180        }
     181    }
     182
     183    # Cleanup
     184    foreach my $k (keys %newly_found) {
     185        delete $newly_found{$k};
     186    }
     187}
     188
     189pb_log(1,"End of mr_get_perl_modules on $f we got:".Dumper(\%files)."\n");
    136190
    137191return(\%files);
    … …  
    144198sub mr_process_file {
    145199 
     200my $file = shift;
    146201my %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;
     202my %list_req;
     203my $current_line = undef;
     204my $tag = undef;
     205
     206return(\%list_req) if (not defined $file);
     207
     208pb_log(2, "START Analyze $file\n");
     209# In a recursive configuration we need a var as file handle
     210open(my $fh, "$file") || return(\%list_req);
     211while (my $line = <$fh>) {
     212
     213    # skip the "= <<" block
     214
     215    pb_log(2, "LINE: $line");
     216    if ( ( $line =~ m/^\s*\$(.*)\s*=\s*<<\s*["'](.*)['"]/i) ||
     217        ($line =~ m/^\s*\$(.*)\s*=\s*<<\s*(.*);/i) ) {
     218        $tag = $2;
     219        while (my $l = <$fh>) {
     220            pb_log(2, "LINE-tag: $l");
     221            ( $l =~ /^$tag/) && last;
     222        }
     223    }
     224
     225    pb_log(2, "PHASE 2: $line");
     226    # skip the documentation
     227
     228    # we should not need to have item in this if statement (it
     229    # properly belongs in the over/back section) but people do not
     230    # read the perldoc.
     231
     232    if ( ($line =~ m/^=(head1|head2|pod|item)/) .. ($line =~ m/^=(cut)/) ) {
     233        pb_log(2, "PHASE 2bis:$line");
     234        next;
     235    }
     236    pb_log(2, "PHASE 3:\n");
     237
     238    if ( ($line =~ m/^=(over)/) .. ($line =~ m/^=(back)/) ) {
     239        next;
     240    }
     241    pb_log(2, "PHASE 4:\n");
     242   
     243    # skip the data section
     244    if ($line =~ m/^__(DATA|END)__$/) {
     245        last;
     246    }
     247    pb_log(2, "PHASE 5:\n");
     248
     249    # Each keyword can appear multiple times.  Don't
     250    #  bother with datastructures to store these strings,
     251    #  if we need to print it print it now.
     252
     253    if ($line =~  m/^\s*\$RPM_Requires\s*=\s*["'](.*)['"]/i) {
     254        foreach my $l (split(/\s+/, $1)) {
     255            print "$l\n";
    163256            }
    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 (
     257    }
     258    pb_log(2, "PHASE 6:\n");
     259
     260    if (
    196261
    197262# ouch could be in a eval, perhaps we do not want these since we catch
    … …  
    203268
    204269
    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;
     270    ($line =~ m/^(\s*)         # we hope the inclusion starts the line
     271        (require|use)\s+(?!\{)     # do not want 'do bracket' loops
     272        # quotes around name are always legal
     273        [\'\"]?([^\;\ \'\"\t]*)[\'\"]?[\t\;\ ]
     274        # the syntax for 'use' allows version requirements
     275        \s*([.0-9]*)
     276        /x)
     277    ) {
     278        pb_log(2, "REQUIRE FOUND ***\n");
     279        my ($whitespace, $statement, $module, $version) = ($1, $2, $3,$4);
     280        my $usebase;
     281
     282        # we only consider require statements that are flush against
     283        # the left edge. any other require statements give too many
     284        # false positives, as they are usually inside of an if statement
     285        # as a fallback module or a rarely used option
     286
     287        ($whitespace !~ /^\s*$/ && $statement eq "require") && next;
     288
     289        pb_log(2, "REQUIRE AV *** $whitespace, $statement, $module, $version ***\n");
     290        # if there is some interpolation of variables just skip this
     291        # dependency, we do not want
     292        #        do "$ENV{LOGDIR}/$rcfile";
     293
     294        ($module =~ m/\$/) && next;
     295
     296        # skip if the phrase was "use of" -- shows up in gimp-perl, et al
     297        next if $module eq 'of';
     298
     299        # if the module ends in a comma we probaly caught some
     300        # documentation of the form 'check stuff,\n do stuff, clean
     301        # stuff.' there are several of these in the perl distribution
     302
     303        ($module  =~ m/[,>]$/) && next;
     304
     305        # if the module name starts in a dot it is not a module name.
     306        # Is this necessary?  Please give me an example if you turn this
     307        # back on.
     308
     309        #      ($module =~ m/^\./) && next;
     310
     311        # if the module ends with .pm strip it to leave only basename.
     312        # starts with /, which means its an absolute path to a file
     313        if ($module =~ m(^/)) {
     314            print "$module\n";
     315            next;
     316        }
     317
     318        # as seen in some perl scripts
     319        # use base qw(App::CLI Class::Accessor::Chained::Fast App::CLI::Command);
     320        if ($module eq 'base') {
     321            $list_req{$module} = $version;
     322            $line{$module} = $current_line;
     323            ($module = $line) =~ s/use\s*base\s*//;
     324            $module =~ s/qw\((.*)\)\s*;/$1/;
     325            $module =~ s/qw(.)(.*)\1\s*;/$2/;
     326            $module =~ s/\s*;$//;
     327            $module =~ s/#.*//;
     328            $usebase = 1;
     329        }
     330        # sometimes people do use POSIX qw(foo), or use POSIX(qw(foo)) etc
     331        # we can strip qw.*$, as well as (.*$:
     332        $module =~ s/qw.*$//;
     333        $module =~ s/\(.*$//;
     334
     335        $module =~ s/\.pm$//;
     336
     337        # some perl programmers write 'require URI/URL;' when
     338        # they mean 'require URI::URL;'
     339
     340        $module =~ s/\//::/;
     341
     342        # trim off trailing parenthesis if any.  Sometimes people pass
     343        # the module an empty list.
    222344   
    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;
     345        $module =~ s/\(\s*\)$//;
     346
     347        # if module is a number then both require and use interpret that
     348        # to mean that a particular version of perl is specified. Don't
     349        # add a dependency, though, since the rpm will already require
     350        # perl-base at the build version (via find-requires)
     351        next if $module =~ /^v?\d/;
     352
     353        # ph files do not use the package name inside the file.
     354        # perlmodlib  documentation says:
     355        #       the .ph files made by h2ph will probably end up as
     356        #       extension modules made by h2xs.
     357        # so do not spend much effort on these.
     358
     359        # there is no easy way to find out if a file named systeminfo.ph
     360        # will be included with the name sys/systeminfo.ph so only use the
     361        # basename of *.ph files
     362
     363        ($module  =~ m/\.ph$/) && next;
     364
     365        # if the module was loaded trough base, we need to split the list
     366        if ($usebase) {
     367            my $current_line = $line;
     368            foreach my $l (split(/\s+/, $module)) {
     369                next unless $l;
     370                $list_req{$l} = $version;
     371                $line{$l} = $current_line;
    250372            }
    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 }
     373        } else {
     374            $list_req{$module}=$version;
     375            $line{$module}=$current_line;
     376        }
     377        pb_log(2, "REQUIRE FIN *** ".Dumper(\%list_req)." ***\n");
     378    }
     379}
     380
     381close($fh) || die("$0: Could not close file: '$file' : $!\n");
     382
     383return(\%list_req);
     384}
Note: See TracChangeset for help on using the changeset viewer.