Changeset 3386 in MondoRescue for branches/3.2/mindi/mindi-get-perl-modules
- Timestamp:
- May 14, 2015, 7:03:47 AM (9 years ago)
- File:
-
- 1 edited
-
branches/3.2/mindi/mindi-get-perl-modules (modified) (5 diffs)
Legend:
- Unmodified
- Added
- Removed
-
branches/3.2/mindi/mindi-get-perl-modules
r3385 r3386 12 12 use Data::Dumper; 13 13 use File::Basename; 14 use ProjectBuilder::Base; 15 use Getopt::Long qw(:config auto_abbrev no_ignore_case); 14 16 15 17 =pod … … 56 58 =cut 57 59 60 # Globals 58 61 my %files; 59 62 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 63 my %opts; 87 64 my @includes; 65 my $req; 66 my %args; 67 68 GetOptions( 69 "verbose|v+" => \$opts{'v'}, 70 ); 71 72 pb_syntax_init("mindi-get-perl-modules Version PBVER-rPBREV\n"); 73 74 $pbdebug = $opts{'v'}; 75 $pbdebug = 0 if (not defined $pbdebug); 88 76 89 77 # Remove non exiting directories from @INC 90 78 # and thus avoid perl warnings 91 79 # 80 pb_log(1,"Searching originally in "); 81 pb_log(1,join " - ", @INC); 82 pb_log(1,"\n"); 83 92 84 foreach my $d (@INC) { 93 85 $d = mr_file_read_all_link($d) if (-l $d); 94 86 push @includes,$d if (-d $d); 95 87 } 88 89 pb_log(1,"Searching finally in "); 90 pb_log(1,join " - ", @INC); 91 pb_log(1,"\n"); 92 93 # deduplicate entry list 94 if (defined $ARGV[0]) { 95 %args = map { $_, 1 } @ARGV; 96 } else { 97 pb_syntax(); 98 } 99 100 pb_temp_init(); 101 102 my $tmpf = "$ENV{'PBTMP'}/mpgm.$$"; 103 104 open(TMPF,"> $tmpf") || die "Unable to create $tmpf: !$\n"; 105 print TMPF "# To include module corresponding to perl -w\n"; 106 print TMPF "use warnings;\n"; 107 print TMPF "# To include module used by Data:Dumper in a masked way for this script\n"; 108 print TMPF "use bytes;\n"; 109 close(TMPF); 110 111 foreach 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 } 119 unlink("$tmpf"); 120 121 foreach my $f (sort keys %files) { 122 print "$f\n"; 123 } 124 125 exit 0; 126 127 sub mr_get_perl_modules { 128 129 my $f = shift; 130 my %newly_found; 131 my $require; 132 133 return($require) if (not defined $f); 134 $require = mr_process_file($f); 135 136 pb_log(1,"Requires on $f found:\n"); 137 pb_log(1,Dumper($require)); 138 pb_log(1,"---------------\n"); 139 140 my $cpt = keys %$require; 141 142 # Exit recursion 143 return($require) if ($cpt == 0); 96 144 97 145 foreach my $m (keys %$require) { … … 100 148 next if (exists $found{$mod}); 101 149 foreach my $d (@includes) { 102 #print "Looking at $m in $d\n";150 pb_log(1,"Looking at $m in $d\n"); 103 151 if (-f "$d/$mod.pm") { 104 152 $files{"$d/$mod.pm"} = $mod; 105 153 $found{$mod} = "$d/$mod.pm"; 106 154 $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"); 108 156 last; 109 157 } 110 158 } 111 print "ERROR: Unable to find $mod. Your perl setup isincorrect\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}); 112 160 } 113 161 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 } 162 pb_log(1,"Files found:\n"); 163 pb_log(1,Dumper(\%files)); 164 pb_log(2,Dumper(\%found)); 165 pb_log(1,"---------------\n"); 166 167 pb_log(1,"New Files found:\n"); 168 pb_log(1,Dumper(\%newly_found)); 169 pb_log(1,"---------------\n"); 170 171 my $foundrec; 172 173 $cpt = keys %newly_found; 174 if ($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 189 pb_log(1,"End of mr_get_perl_modules on $f we got:".Dumper(\%files)."\n"); 136 190 137 191 return(\%files); … … 144 198 sub mr_process_file { 145 199 200 my $file = shift; 146 201 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; 202 my %list_req; 203 my $current_line = undef; 204 my $tag = undef; 205 206 return(\%list_req) if (not defined $file); 207 208 pb_log(2, "START Analyze $file\n"); 209 # In a recursive configuration we need a var as file handle 210 open(my $fh, "$file") || return(\%list_req); 211 while (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"; 163 256 } 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 ( 196 261 197 262 # ouch could be in a eval, perhaps we do not want these since we catch … … 203 268 204 269 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. 222 344 223 #print "*** $whitespace, $statement, $module, $version ***\n";224 # if there is some interpolation of variables just skip this 225 # dependency, we do not want226 # 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 some234 # documentation of the form 'check stuff,\n do stuff, clean235 # stuff.' there are several of these in the perl distribution236 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 file247 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; 250 372 } 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 381 close($fh) || die("$0: Could not close file: '$file' : $!\n"); 382 383 return(\%list_req); 384 }
Note:
See TracChangeset
for help on using the changeset viewer.
