… | |
… | |
65 | |
65 | |
66 | unless (fork) { |
66 | unless (fork) { |
67 | close $TRACER_R; |
67 | close $TRACER_R; |
68 | close $TRACER_W; |
68 | close $TRACER_W; |
69 | |
69 | |
|
|
70 | my $pkg = "pkg000000"; |
|
|
71 | |
70 | unshift @INC, sub { |
72 | unshift @INC, sub { |
71 | my $dir = find_incdir $_[1] |
73 | my $dir = find_incdir $_[1] |
72 | or return; |
74 | or return; |
73 | |
75 | |
74 | syswrite $W_TRACER, "-\n$dir\n$_[1]\n"; |
76 | syswrite $W_TRACER, "-\n$dir\n$_[1]\n"; |
… | |
… | |
80 | }; |
82 | }; |
81 | |
83 | |
82 | while (<$R_TRACER>) { |
84 | while (<$R_TRACER>) { |
83 | if (/use (.*)$/) { |
85 | if (/use (.*)$/) { |
84 | my $mod = $1; |
86 | my $mod = $1; |
|
|
87 | my $pkg = ++$pkg; |
|
|
88 | my $eval = $mod = $mod =~ /[^A-Za-z0-9_:]/ |
85 | eval "require $mod"; |
89 | ? "require $mod" |
|
|
90 | : "{ package $pkg; use $mod; }"; |
|
|
91 | eval $eval; |
86 | warn "ERROR: $@ (while loading '$mod')\n" |
92 | warn "ERROR: $@ (while loading '$mod')\n" |
87 | if $@; |
93 | if $@; |
88 | } elsif (/eval (.*)$/) { |
94 | } elsif (/eval (.*)$/) { |
89 | my $eval = $1; |
95 | my $eval = $1; |
90 | eval $eval; |
96 | eval $eval; |
… | |
… | |
230 | my $path = "$_[0]/$_"; |
236 | my $path = "$_[0]/$_"; |
231 | |
237 | |
232 | if (-d "$path/.") { |
238 | if (-d "$path/.") { |
233 | $scan->($path); |
239 | $scan->($path); |
234 | } else { |
240 | } else { |
235 | next unless /\.(?:pm|pl)$/; |
|
|
236 | |
|
|
237 | $path = substr $path, $skip; |
241 | $path = substr $path, $skip; |
238 | push @tree, $path |
242 | push @tree, $path |
239 | unless exists $INCSKIP{$path}; |
243 | unless exists $INCSKIP{$path}; |
240 | } |
244 | } |
241 | } |
245 | } |
… | |
… | |
294 | |
298 | |
295 | for (get_inctrees) { |
299 | for (get_inctrees) { |
296 | my ($dir, $files) = @$_; |
300 | my ($dir, $files) = @$_; |
297 | |
301 | |
298 | $pm{$_} = "$dir/$_" |
302 | $pm{$_} = "$dir/$_" |
299 | for grep /$pattern/, @$files; |
303 | for grep /$pattern/ && /\.(pl|pm)$/, @$files; |
300 | } |
304 | } |
301 | } |
305 | } |
302 | |
306 | |
303 | sub parse_argv; |
307 | sub parse_argv; |
304 | |
308 | |
… | |
… | |
325 | |
329 | |
326 | use Getopt::Long; |
330 | use Getopt::Long; |
327 | |
331 | |
328 | sub parse_argv { |
332 | sub parse_argv { |
329 | GetOptions |
333 | GetOptions |
330 | "strip=s" => \$STRIP, |
334 | "strip=s" => \$STRIP, |
331 | "cache=s" => \$CACHE, # internal option |
335 | "cache=s" => \$CACHE, # internal option |
332 | "verbose|v" => sub { ++$VERBOSE }, |
336 | "verbose|v" => sub { ++$VERBOSE }, |
333 | "quiet|q" => sub { --$VERBOSE }, |
337 | "quiet|q" => sub { --$VERBOSE }, |
334 | "perl" => \$PERL, |
338 | "perl" => \$PERL, |
335 | "app=s" => \$APP, |
339 | "app=s" => \$APP, |
336 | "eval|e=s" => sub { trace_eval $_[1] }, |
340 | "eval|e=s" => sub { trace_eval $_[1] }, |
337 | "use|M=s" => sub { trace_module $_[1] }, |
341 | "use|M=s" => sub { trace_module $_[1] }, |
338 | "boot=s" => sub { cmd_boot $_[1] }, |
342 | "boot=s" => sub { cmd_boot $_[1] }, |
339 | "add=s" => sub { cmd_add $_[1], 0 }, |
343 | "add=s" => sub { cmd_add $_[1], 0 }, |
340 | "addbin=s" => sub { cmd_add $_[1], 1 }, |
344 | "addbin=s" => sub { cmd_add $_[1], 1 }, |
341 | "incglob=s" => sub { cmd_incglob $_[1] }, |
345 | "incglob=s" => sub { cmd_incglob $_[1] }, |
342 | "include|i=s" => sub { cmd_include $_[1], 1 }, |
346 | "include|i=s" => sub { cmd_include $_[1], 1 }, |
343 | "exclude|x=s" => sub { cmd_include $_[1], 0 }, |
347 | "exclude|x=s" => sub { cmd_include $_[1], 0 }, |
344 | "static!" => \$STATIC, |
348 | "static!" => \$STATIC, |
345 | "usepacklist!" => \$PACKLIST, |
349 | "usepacklists!" => \$PACKLIST, |
346 | "staticlib=s" => sub { cmd_staticlib $_[1] }, |
350 | "staticlib=s" => sub { cmd_staticlib $_[1] }, |
347 | "<>" => sub { cmd_file $_[0] }, |
351 | "<>" => sub { cmd_file $_[0] }, |
348 | or exit 1; |
352 | or exit 1; |
349 | } |
353 | } |
350 | |
354 | |
351 | Getopt::Long::Configure ("bundling", "no_auto_abbrev", "no_ignore_case"); |
355 | Getopt::Long::Configure ("bundling", "no_auto_abbrev", "no_ignore_case"); |
352 | |
356 | |
… | |
… | |
357 | |
361 | |
358 | # required for @INC loading, unfortunately |
362 | # required for @INC loading, unfortunately |
359 | trace_module "PerlIO::scalar"; |
363 | trace_module "PerlIO::scalar"; |
360 | |
364 | |
361 | ############################################################################# |
365 | ############################################################################# |
362 | # include/exclude apply |
366 | # apply include/exclude |
363 | |
367 | |
364 | { |
368 | { |
365 | my %pmi; |
369 | my %pmi; |
366 | |
370 | |
367 | for (@incext) { |
371 | for (@incext) { |
… | |
… | |
377 | if $VERBOSE >= 5; |
381 | if $VERBOSE >= 5; |
378 | } else { |
382 | } else { |
379 | # exclude |
383 | # exclude |
380 | delete @pm{@match}; |
384 | delete @pm{@match}; |
381 | |
385 | |
382 | print "applying exclude $glob - excluded ", (scalar @match), " files.\n" |
386 | print "applying exclude $glob - removed ", (scalar @match), " files.\n" |
383 | if $VERBOSE >= 5; |
387 | if $VERBOSE >= 5; |
384 | } |
388 | } |
385 | } |
389 | } |
386 | |
390 | |
387 | my @pmi = keys %pmi; |
391 | my @pmi = keys %pmi; |
388 | @pm{@pmi} = delete @pmi{@pmi}; |
392 | @pm{@pmi} = delete @pmi{@pmi}; |
389 | } |
393 | } |
390 | |
394 | |
391 | ############################################################################# |
395 | ############################################################################# |
392 | # scan for AutoLoader and static archives |
396 | # scan for AutoLoader, static archives and other dependencies |
393 | |
397 | |
394 | sub scan_al { |
398 | sub scan_al { |
395 | my ($auto, $autodir) = @_; |
399 | my ($auto, $autodir) = @_; |
396 | |
400 | |
397 | my $ix = "$autodir/autosplit.ix"; |
401 | my $ix = "$autodir/autosplit.ix"; |
… | |
… | |
467 | print "found .packlist for $pm\n" |
471 | print "found .packlist for $pm\n" |
468 | if $VERBOSE >= 3; |
472 | if $VERBOSE >= 3; |
469 | |
473 | |
470 | while (<$fh>) { |
474 | while (<$fh>) { |
471 | chomp; |
475 | chomp; |
|
|
476 | s/ .*$//; # newer-style .packlists might contain key=value pairs |
472 | |
477 | |
473 | # only include certain files (.al, .ix, .pm, .pl) |
478 | # only include certain files (.al, .ix, .pm, .pl) |
474 | if (/\.(pm|pl|al|ix)$/) { |
479 | if (/\.(pm|pl|al|ix)$/) { |
475 | for my $inc (@INC) { |
480 | for my $inc (@INC) { |
476 | # in addition, we only add files that are below some @INC path |
481 | # in addition, we only add files that are below some @INC path |
… | |
… | |
529 | my $size = length $src; |
534 | my $size = length $src; |
530 | |
535 | |
531 | unless ($pmbin{$pm}) { # only do this unless the file is binary |
536 | unless ($pmbin{$pm}) { # only do this unless the file is binary |
532 | if ($pm =~ /^auto\/POSIX\/[^\/]+\.al$/) { |
537 | if ($pm =~ /^auto\/POSIX\/[^\/]+\.al$/) { |
533 | if ($src =~ /^ unimpl \"/m) { |
538 | if ($src =~ /^ unimpl \"/m) { |
534 | print "$pm: skipping (only raises runtime error).\n" |
539 | print "$pm: skipping (raises runtime error only).\n" |
535 | if $VERBOSE >= 3; |
540 | if $VERBOSE >= 3; |
536 | next; |
541 | next; |
537 | } |
542 | } |
538 | } |
543 | } |
539 | |
544 | |
… | |
… | |
662 | |
667 | |
663 | $src = $ppi->serialize; |
668 | $src = $ppi->serialize; |
664 | } else { |
669 | } else { |
665 | warn "WARNING: $pm{$pm}: PPI failed to parse this file\n"; |
670 | warn "WARNING: $pm{$pm}: PPI failed to parse this file\n"; |
666 | } |
671 | } |
667 | } elsif ($STRIP =~ /pod/i && $pm ne "Opcode.pm") { # opcode parses it's own pod |
672 | } elsif ($STRIP =~ /pod/i && $pm ne "Opcode.pm") { # opcode parses its own pod |
668 | require Pod::Strip; |
673 | require Pod::Strip; |
669 | |
674 | |
670 | my $stripper = Pod::Strip->new; |
675 | my $stripper = Pod::Strip->new; |
671 | |
676 | |
672 | my $out; |
677 | my $out; |
… | |
… | |
947 | |
952 | |
948 | int |
953 | int |
949 | main (int argc, char *argv []) |
954 | main (int argc, char *argv []) |
950 | { |
955 | { |
951 | extern char **environ; |
956 | extern char **environ; |
|
|
957 | int i, exitstatus; |
|
|
958 | char **args = malloc ((argc + 3) * sizeof (const char *)); |
|
|
959 | |
|
|
960 | args [0] = argv [0]; |
|
|
961 | args [1] = "-e"; |
|
|
962 | args [2] = "0"; |
|
|
963 | args [3] = "--"; |
|
|
964 | |
|
|
965 | for (i = 1; i < argc; ++i) |
|
|
966 | args [i + 3] = argv [i]; |
|
|
967 | |
|
|
968 | PERL_SYS_INIT3 (&argc, &argv, &environ); |
|
|
969 | staticperl = perl_alloc (); |
|
|
970 | perl_construct (staticperl); |
|
|
971 | |
|
|
972 | PL_exit_flags |= PERL_EXIT_DESTRUCT_END; |
|
|
973 | |
|
|
974 | exitstatus = perl_parse (staticperl, staticperl_xs_init, argc + 3, args, environ); |
|
|
975 | free (args); |
|
|
976 | if (!exitstatus) |
|
|
977 | perl_run (staticperl); |
|
|
978 | |
|
|
979 | exitstatus = perl_destruct (staticperl); |
|
|
980 | perl_free (staticperl); |
|
|
981 | PERL_SYS_TERM (); |
|
|
982 | |
|
|
983 | return exitstatus; |
|
|
984 | } |
|
|
985 | EOF |
|
|
986 | } elsif ($PERL) { |
|
|
987 | print $fh <<EOF; |
|
|
988 | |
|
|
989 | int |
|
|
990 | main (int argc, char *argv []) |
|
|
991 | { |
|
|
992 | extern char **environ; |
952 | int exitstatus; |
993 | int exitstatus; |
953 | |
994 | |
|
|
995 | PERL_SYS_INIT3 (&argc, &argv, &environ); |
|
|
996 | staticperl = perl_alloc (); |
|
|
997 | perl_construct (staticperl); |
|
|
998 | |
|
|
999 | PL_exit_flags |= PERL_EXIT_DESTRUCT_END; |
|
|
1000 | |
|
|
1001 | exitstatus = perl_parse (staticperl, staticperl_xs_init, argc, argv, environ); |
|
|
1002 | if (!exitstatus) |
|
|
1003 | perl_run (staticperl); |
|
|
1004 | |
|
|
1005 | exitstatus = perl_destruct (staticperl); |
|
|
1006 | perl_free (staticperl); |
|
|
1007 | PERL_SYS_TERM (); |
|
|
1008 | |
|
|
1009 | return exitstatus; |
|
|
1010 | } |
|
|
1011 | EOF |
|
|
1012 | } else { |
|
|
1013 | print $fh <<EOF; |
|
|
1014 | |
|
|
1015 | EXTERN_C void |
|
|
1016 | staticperl_init (void) |
|
|
1017 | { |
954 | static char *args[] = { |
1018 | static char *args[] = { |
955 | "staticperl", |
1019 | "staticperl", |
956 | "-e", |
1020 | "-e", |
957 | "0" |
1021 | "0" |
958 | }; |
1022 | }; |
959 | |
1023 | |
960 | PERL_SYS_INIT3 (&argc, &argv, &environ); |
|
|
961 | staticperl = perl_alloc (); |
|
|
962 | perl_construct (staticperl); |
|
|
963 | |
|
|
964 | PL_exit_flags |= PERL_EXIT_DESTRUCT_END; |
|
|
965 | |
|
|
966 | exitstatus = perl_parse (staticperl, staticperl_xs_init, sizeof (args) / sizeof (*args), args, environ); |
|
|
967 | if (!exitstatus) |
|
|
968 | perl_run (staticperl); |
|
|
969 | |
|
|
970 | exitstatus = perl_destruct (staticperl); |
|
|
971 | perl_free (staticperl); |
|
|
972 | PERL_SYS_TERM (); |
|
|
973 | |
|
|
974 | return exitstatus; |
|
|
975 | } |
|
|
976 | EOF |
|
|
977 | } elsif ($PERL) { |
|
|
978 | print $fh <<EOF; |
|
|
979 | |
|
|
980 | int |
|
|
981 | main (int argc, char *argv []) |
|
|
982 | { |
|
|
983 | extern char **environ; |
|
|
984 | int exitstatus; |
|
|
985 | |
|
|
986 | PERL_SYS_INIT3 (&argc, &argv, &environ); |
|
|
987 | staticperl = perl_alloc (); |
|
|
988 | perl_construct (staticperl); |
|
|
989 | |
|
|
990 | PL_exit_flags |= PERL_EXIT_DESTRUCT_END; |
|
|
991 | |
|
|
992 | exitstatus = perl_parse (staticperl, staticperl_xs_init, argc, argv, environ); |
|
|
993 | if (!exitstatus) |
|
|
994 | perl_run (staticperl); |
|
|
995 | |
|
|
996 | exitstatus = perl_destruct (staticperl); |
|
|
997 | perl_free (staticperl); |
|
|
998 | PERL_SYS_TERM (); |
|
|
999 | |
|
|
1000 | return exitstatus; |
|
|
1001 | } |
|
|
1002 | EOF |
|
|
1003 | } else { |
|
|
1004 | print $fh <<EOF; |
|
|
1005 | |
|
|
1006 | EXTERN_C void |
|
|
1007 | staticperl_init (void) |
|
|
1008 | { |
|
|
1009 | extern char **environ; |
1024 | extern char **environ; |
1010 | int argc = sizeof (args) / sizeof (args [0]); |
1025 | int argc = sizeof (args) / sizeof (args [0]); |
1011 | char **argv = args; |
1026 | char **argv = args; |
1012 | |
|
|
1013 | static char *args[] = { |
|
|
1014 | "staticperl", |
|
|
1015 | "-e", |
|
|
1016 | "0" |
|
|
1017 | }; |
|
|
1018 | |
1027 | |
1019 | PERL_SYS_INIT3 (&argc, &argv, &environ); |
1028 | PERL_SYS_INIT3 (&argc, &argv, &environ); |
1020 | staticperl = perl_alloc (); |
1029 | staticperl = perl_alloc (); |
1021 | perl_construct (staticperl); |
1030 | perl_construct (staticperl); |
1022 | PL_origalen = 1; |
1031 | PL_origalen = 1; |