--- cvsroot/App-Staticperl/mkbundle 2010/12/10 02:35:54 1.11 +++ cvsroot/App-Staticperl/mkbundle 2012/03/08 19:07:44 1.33 @@ -3,13 +3,17 @@ ############################################################################# # cannot load modules till after the tracer BEGIN block -our $VERBOSE = 1; -our $STRIP = "pod"; # none, pod or ppi -our $UNISTRIP = 1; # always on, try to strip unicore swash data -our $PERL = 0; +our $VERBOSE = 1; +our $STRIP = "pod"; # none, pod or ppi +our $UNISTRIP = 1; # always on, try to strip unicore swash data +our $PERL = 0; our $APP; -our $VERIFY = 0; -our $STATIC = 0; +our $VERIFY = 0; +our $STATIC = 0; +our $PACKLIST = 0; +our $IGNORE_ENV = 0; +our $ALLOW_DYNAMIC = 0; +our $HAVE_DYNAMIC; # maybe useful? our $OPTIMISE_SIZE = 0; # optimise for raw file size instead of for compression? @@ -37,7 +41,7 @@ our ($TRACER_W, $TRACER_R); -sub find_inc($) { +sub find_incdir($) { for (@INC) { next if ref; return $_ if -e "$_/$_[0]"; @@ -46,6 +50,15 @@ undef } +sub find_inc($) { + my $dir = find_incdir $_[0]; + + return "$dir/$_[0]" + if defined $dir; + + undef +} + BEGIN { # create a loader process to detect @INC requests before we load any modules my ($W_TRACER, $R_TRACER); # used by tracer @@ -57,8 +70,10 @@ close $TRACER_R; close $TRACER_W; + my $pkg = "pkg000000"; + unshift @INC, sub { - my $dir = find_inc $_[1] + my $dir = find_incdir $_[1] or return; syswrite $W_TRACER, "-\n$dir\n$_[1]\n"; @@ -72,16 +87,28 @@ while (<$R_TRACER>) { if (/use (.*)$/) { my $mod = $1; - eval "require $mod"; + my $eval; + + if ($mod =~ /^'.*'$/ or $mod =~ /^".*"$/) { + $eval = "require $mod"; + } elsif ($mod =~ y%/.%%) { + $eval = "require q\x00$mod\x00"; + } else { + my $pkg = ++$pkg; + $eval = "{ package $pkg; use $mod; }"; + } + + eval $eval; warn "ERROR: $@ (while loading '$mod')\n" if $@; - syswrite $W_TRACER, "\n"; } elsif (/eval (.*)$/) { my $eval = $1; eval $eval; warn "ERROR: $@ (in '$eval')\n" if $@; } + + syswrite $W_TRACER, "\n"; } exit 0; @@ -90,20 +117,33 @@ # module loading is now safe -sub trace_module { - syswrite $TRACER_W, "use $_[0]\n"; - +sub trace_parse { for (;;) { <$TRACER_R> =~ /^-$/ or last; my $dir = <$TRACER_R>; chomp $dir; my $name = <$TRACER_R>; chomp $name; $pm{$name} = "$dir/$name"; + + print "+ found potential dependency $name\n" + if $VERBOSE >= 3; } } +sub trace_module { + print "tracing module $_[0]\n" + if $VERBOSE >= 2; + + syswrite $TRACER_W, "use $_[0]\n"; + trace_parse; +} + sub trace_eval { + print "tracing eval $_[0]\n" + if $VERBOSE >= 2; + syswrite $TRACER_W, "eval $_[0]\n"; + trace_parse; } sub trace_finish { @@ -121,16 +161,22 @@ sub cache($$$) { my ($variant, $src, $filter) = @_; - if (length $CACHE and 2048 <= length $src) { + if (length $CACHE and 2048 <= length $src and defined $variant) { my $file = "$CACHE/" . Digest::MD5::md5_hex "$CACHEVER\x00$variant\x00$src"; if (open my $fh, "<:perlio", $file) { + print "using cache for $file\n" + if $VERBOSE >= 7; + local $/; return <$fh>; } $src = $filter->($src); + print "creating cache entry $file\n" + if $VERBOSE >= 8; + if (open my $fh, ">:perlio", "$file~") { if ((syswrite $fh, $src) == length $src) { close $fh; @@ -148,14 +194,28 @@ my ($fh, $data) = @_; if (length $data) { - for ( - my $ofs = 0; - length (my $substr = substr $data, $ofs, 80); - $ofs += 80 - ) { - $substr =~ s/([^\x20-\x21\x23-\x5b\x5d-\x7e])/sprintf "\\%03o", ord $1/ge; - $substr =~ s/\?/\\?/g; # trigraphs... - print $fh " \"$substr\"\n"; + if ($^O eq "MSWin32") { + # 16 bit system, strings can't be longer than 64k. seriously. + print $fh "{\n"; + for ( + my $ofs = 0; + length (my $substr = substr $data, $ofs, 20); + $ofs += 20 + ) { + $substr = join ",", map ord, split //, $substr; + print $fh " $substr,\n"; + } + print $fh " 0 }\n"; + } else { + for ( + my $ofs = 0; + length (my $substr = substr $data, $ofs, 80); + $ofs += 80 + ) { + $substr =~ s/([^\x20-\x21\x23-\x5b\x5d-\x7e])/sprintf "\\%03o", ord $1/ge; + $substr =~ s/\?/\\?/g; # trigraphs... + print $fh " \"$substr\"\n"; + } } } else { print $fh " \"\"\n"; @@ -202,8 +262,6 @@ if (-d "$path/.") { $scan->($path); } else { - next unless /\.(?:pm|pl)$/; - $path = substr $path, $skip; push @tree, $path unless exists $INCSKIP{$path}; @@ -234,15 +292,15 @@ ############################################################################# sub cmd_boot { - $pm{"//boot"} = $_[0]; + $pm{"!boot"} = $_[0]; } sub cmd_add { - $_[0] =~ /^(.*)(?:\s+(\S+))$/ + $_[0] =~ /^(.*?)(?:\s+(\S+))?$/ or die "$_[0]: cannot parse"; my $file = $1; - my $as = defined $2 ? $2 : "/$1"; + my $as = defined $2 ? $2 : $1; $pm{$as} = $file; $pmbin{$as} = 1 if $_[1]; @@ -266,77 +324,67 @@ my ($dir, $files) = @$_; $pm{$_} = "$dir/$_" - for grep /$pattern/, @$files; + for grep /$pattern/ && /\.(pl|pm)$/, @$files; } } +sub parse_argv; + sub cmd_file { open my $fh, "<", $_[0] or die "$_[0]: $!\n"; + local @ARGV; + while (<$fh>) { chomp; + next unless /\S/; + next if /^\s*#/; + + s/^\s*-*/--/; my ($cmd, $args) = split / /, $_, 2; - $cmd =~ s/^-+//; - if ($cmd eq "strip") { - $STRIP = $args; - } elsif ($cmd eq "perl") { - $PERL = 1; - } elsif ($cmd eq "app") { - $APP = $args; - } elsif ($cmd eq "eval") { - trace_eval $_; - } elsif ($cmd eq "use") { - trace_module $_ - for split / /, $args; - } elsif ($cmd eq "staticlib") { - cmd_staticlib $args; - } elsif ($cmd eq "boot") { - cmd_boot $args; - } elsif ($cmd eq "static") { - $STATIC = 1; - } elsif ($cmd eq "add") { - cmd_add $args, 0; - } elsif ($cmd eq "addbin") { - cmd_add $args, 1; - } elsif ($cmd eq "incglob") { - cmd_incglob $args; - } elsif ($cmd eq "include") { - cmd_include $args, 1; - } elsif ($cmd eq "exclude") { - cmd_include $args, 0; - } elsif (/^\s*#/) { - # comment - } elsif (/\S/) { - die "$_: unsupported directive\n"; - } + push @ARGV, $cmd; + push @ARGV, $args if defined $args; } + + parse_argv; } use Getopt::Long; +sub parse_argv { + GetOptions + "perl" => \$PERL, + "app=s" => \$APP, + + "verbose|v" => sub { ++$VERBOSE }, + "quiet|q" => sub { --$VERBOSE }, + + "strip=s" => \$STRIP, + "cache=s" => \$CACHE, # internal option + "eval|e=s" => sub { trace_eval $_[1] }, + "use|M=s" => sub { trace_module $_[1] }, + "boot=s" => sub { cmd_boot $_[1] }, + "add=s" => sub { cmd_add $_[1], 0 }, + "addbin=s" => sub { cmd_add $_[1], 1 }, + "incglob=s" => sub { cmd_incglob $_[1] }, + "include|i=s" => sub { cmd_include $_[1], 1 }, + "exclude|x=s" => sub { cmd_include $_[1], 0 }, + "usepacklists!" => \$PACKLIST, + + "static!" => \$STATIC, + "staticlib=s" => sub { cmd_staticlib $_[1] }, + "allow-dynamic!"=> \$ALLOW_DYNAMIC, + "ignore-env" => \$IGNORE_ENV, + + "<>" => sub { cmd_file $_[0] }, + or exit 1; +} + Getopt::Long::Configure ("bundling", "no_auto_abbrev", "no_ignore_case"); -GetOptions - "strip=s" => \$STRIP, - "cache=s" => \$CACHE, # internal option - "verbose|v" => sub { ++$VERBOSE }, - "quiet|q" => sub { --$VERBOSE }, - "perl" => \$PERL, - "app=s" => \$APP, - "eval|e=s" => sub { trace_eval $_[1] }, - "use|M=s" => sub { trace_module $_[1] }, - "boot=s" => sub { cmd_boot $_[1] }, - "add=s" => sub { cmd_add $_[1], 0 }, - "addbin=s" => sub { cmd_add $_[1], 1 }, - "incglob=s" => sub { cmd_incglob $_[1] }, - "include|i=s" => sub { cmd_include $_[1], 1 }, - "exclude|x=s" => sub { cmd_include $_[1], 0 }, - "static" => sub { $STATIC = 1 }, - "staticlib=s" => sub { cmd_staticlib $_[1] }, - "<>" => sub { cmd_file $_[0] }, - or exit 1; +parse_argv; die "cannot specify both --app and --perl\n" if $PERL and defined $APP; @@ -345,7 +393,7 @@ trace_module "PerlIO::scalar"; ############################################################################# -# include/exclude apply +# apply include/exclude { my %pmi; @@ -358,9 +406,15 @@ if ($inc) { # include @pmi{@match} = delete @pm{@match}; + + print "applying include $glob - protected ", (scalar @match), " files.\n" + if $VERBOSE >= 5; } else { # exclude delete @pm{@match}; + + print "applying exclude $glob - removed ", (scalar @match), " files.\n" + if $VERBOSE >= 5; } } @@ -369,13 +423,16 @@ } ############################################################################# -# scan for AutoLoader and static archives +# scan for AutoLoader, static archives and other dependencies sub scan_al { my ($auto, $autodir) = @_; my $ix = "$autodir/autosplit.ix"; + print "processing autoload index for '$auto'\n" + if $VERBOSE >= 6; + $pm{"$auto/autosplit.ix"} = $ix; open my $fh, "<:perlio", $ix @@ -390,14 +447,16 @@ defined $inc or die "$al: autoload file not found, but should be there.\n"; - $pm{$al} = "$inc/$al"; + $pm{$al} = $inc; + print "found autoload function '$al'\n" + if $VERBOSE >= 6; } elsif (/^\s*package\s+([^[:space:];]+)\s*;?\s*$/) { ($package = $1) =~ s/::/\//g; } elsif (/^\s*(?:#|1?\s*;?\s*$)/) { # nop } else { - warn "$ix: unparsable line, please report: $_"; + warn "WARNING: $ix: unparsable line, please report: $_"; } } } @@ -407,15 +466,16 @@ my $auto = "auto/$1"; my $autodir = find_inc $auto; - if (defined $autodir && -d "$autodir/$auto") { - $autodir = "$autodir/$auto"; - + if (defined $autodir && -d $autodir) { # AutoLoader scan_al $auto, $autodir if -f "$autodir/autosplit.ix"; # extralibs.ld if (open my $fh, "<:perlio", "$autodir/extralibs.ld") { + print "found extralibs for $pm\n" + if $VERBOSE >= 6; + local $/; $extralibs .= " " . <$fh>; } @@ -426,19 +486,65 @@ # static ext if (-f "$autodir/$base$Config{_a}") { + print "found static archive for $pm\n" + if $VERBOSE >= 3; + push @libs, "$autodir/$base$Config{_a}"; push @static_ext, $pm; } # dynamic object - die "ERROR: found shared object - can't link statically ($_)\n" - if -f "$autodir/$base.$Config{dlext}"; + if (-f "$autodir/$base.$Config{dlext}") { + if ($ALLOW_DYNAMIC) { + my $as = "!$auto/$base.$Config{dlext}"; + $pm{$as} = "$autodir/$base.$Config{dlext}"; + $pmbin{$as} = 1; + + $HAVE_DYNAMIC = 1; + + print "+ added dynamic object $as\n" + if $VERBOSE >= 3; + } else { + die "ERROR: found shared object '$autodir/$base.$Config{dlext}' but --allow-dynamic not given, aborting.\n" + } + } + + if ($PACKLIST && open my $fh, "<:perlio", "$autodir/.packlist") { + print "found .packlist for $pm\n" + if $VERBOSE >= 3; + + while (<$fh>) { + chomp; + s/ .*$//; # newer-style .packlists might contain key=value pairs + + # only include certain files (.al, .ix, .pm, .pl) + if (/\.(pm|pl|al|ix)$/) { + for my $inc (@INC) { + # in addition, we only add files that are below some @INC path + $inc =~ s/\/*$/\//; + + if ($inc eq substr $_, 0, length $inc) { + my $base = substr $_, length $inc; + $pm{$base} = $_; + + print "+ added .packlist dependency $base\n" + if $VERBOSE >= 3; + } + + last; + } + } + } + } } } } ############################################################################# +print "processing bundle files (try more -v power if you get bored waiting here)...\n" + if $VERBOSE >= 1; + my $data; my @index; my @order = sort { @@ -472,14 +578,17 @@ unless ($pmbin{$pm}) { # only do this unless the file is binary if ($pm =~ /^auto\/POSIX\/[^\/]+\.al$/) { if ($src =~ /^ unimpl \"/m) { - warn "$pm: skipping (not implemented anyways).\n" - if $VERBOSE >= 2; + print "$pm: skipping (raises runtime error only).\n" + if $VERBOSE >= 3; next; } } - $src = cache "$UNISTRIP,$OPTIMISE_SIZE,$STRIP", $src, sub { + $src = cache +($STRIP eq "ppi" ? "$UNISTRIP,$OPTIMISE_SIZE" : undef), $src, sub { if ($UNISTRIP && $pm =~ /^unicore\/.*\.pl$/) { + print "applying unicore stripping $pm\n" + if $VERBOSE >= 6; + # special stripping for unicore swashes and properties # much more could be done by going binary $src =~ s{ @@ -602,7 +711,7 @@ } else { warn "WARNING: $pm{$pm}: PPI failed to parse this file\n"; } - } elsif ($STRIP =~ /pod/i && $pm ne "Opcode.pm") { # opcode parses it's own pod + } elsif ($STRIP =~ /pod/i && $pm ne "Opcode.pm") { # opcode parses its own pod require Pod::Strip; my $stripper = Pod::Strip->new; @@ -632,7 +741,7 @@ # } } - print "adding $pm{$pm} (original size $size, stored size ", length $src, ")\n" + print "adding $pm (original size $size, stored size ", length $src, ")\n" if $VERBOSE >= 2; push @index, ((length $pm) << 25) | length $data; @@ -640,21 +749,22 @@ } length $data < 2**25 - or die "bundle too large (only 32MB supported)\n"; + or die "ERROR: bundle too large (only 32MB supported)\n"; -my $varpfx = "bundle_" . substr +(Digest::MD5::md5_hex $data), 0, 16; +my $varpfx = "bundle"; ############################################################################# # output -print "generating $PREFIX.h... "; +print "generating $PREFIX.h... " + if $VERBOSE >= 1; { open my $fh, ">", "$PREFIX.h" or die "$PREFIX.h: $!\n"; print $fh < #include @@ -663,24 +773,26 @@ /* public API */ EXTERN_C PerlInterpreter *staticperl; EXTERN_C void staticperl_xs_init (pTHX); -EXTERN_C void staticperl_init (void); +EXTERN_C void staticperl_init (XSINIT_t xs_init); /* argument can be 0 */ EXTERN_C void staticperl_cleanup (void); EOF } -print "\n"; +print "\n" + if $VERBOSE >= 1; ############################################################################# # output -print "generating $PREFIX.c... "; +print "generating $PREFIX.c... " + if $VERBOSE >= 1; open my $fh, ">", "$PREFIX.c" or die "$PREFIX.c: $!\n"; print $fh <bootstrap; + # the path prefix to use when putting files into %INC + our $inc_prefix; - @INC = sub { + # the @INC hook to use when we have PerlIO::scalar available + my $perlio_inc = sub { my $data = find "$_[1]" or return; - $INC{$_[1]} = $_[1]; + $INC{$_[1]} = "$inc_prefix$_[1]"; open my $fh, "<", \$data; $fh }; + +D if (defined &PerlIO::scalar::bootstrap) { + # PerlIO::scalar statically compiled in + PerlIO::scalar->bootstrap; + @INC = $perlio_inc; +D } else { +D # PerlIO::scalar not available, use slower method +D @INC = sub { +D # always check if PerlIO::scalar might now be available +D if (defined &PerlIO::scalar::bootstrap) { +D # switch to the faster perlio_inc hook +D @INC = map { $_ == $_[0] ? $perlio_inc : $_ } @INC; +D goto &$perlio_inc; +D } +D +D my $data = find "$_[1]" +D or return; +D +D $INC{$_[1]} = "$inc_prefix$_[1]"; +D +D sub { +D $data =~ /\G([^\n]*\n?)/g +D or return; +D +D $_ = $1; +D 1 +D } +D }; +D } } '; -$bootstrap .= "require '//boot';" - if exists $pm{"//boot"}; +$bootstrap .= "require '!boot';" + if exists $pm{"!boot"}; + +if ($HAVE_DYNAMIC) { + $bootstrap =~ s/^D/ /mg; +} else { + $bootstrap =~ s/^D.*$//mg; +} +$bootstrap =~ s/#.*$//mg; $bootstrap =~ s/\s+/ /g; $bootstrap =~ s/(\W) /$1/g; $bootstrap =~ s/ (\W)/$1/g; @@ -798,8 +949,7 @@ XSRETURN (0); found: - ST (0) = res; - sv_2mortal (ST (0)); + ST (0) = sv_2mortal (res); } XSRETURN (1); @@ -822,7 +972,7 @@ { U32 idx = $varpfx\_index [i]; - PUSHs (newSVpvn ($varpfx\_data + (idx & 0x1FFFFFFU), idx >> 25)); + PUSHs (sv_2mortal (newSVpvn ($varpfx\_data + (idx & 0x1FFFFFFU), idx >> 25))); } } @@ -840,7 +990,7 @@ { EOF -@static_ext = ("DynaLoader", sort @static_ext); +@static_ext = sort @static_ext; # prototypes for (@static_ext) { @@ -864,19 +1014,48 @@ (my $cname = $_) =~ s/\//__/g; (my $pname = $_) =~ s/\//::/g; - my $bootstrap = $pname eq "DynaLoader" ? "boot" : "bootstrap"; + my $bootstrap = $pname eq "DynaLoader" ? "boot_DynaLoader" : "bootstrap"; print $fh " newXS (\"$pname\::$bootstrap\", boot_$cname, file);\n"; } print $fh <= 1; ############################################################################# # libs, cflags -{ - print "generating $PREFIX.ccopts... "; +my $ccopts; - my $str = "$Config{ccflags} $Config{optimize} $Config{cppflags} -I$Config{archlibexp}/CORE"; - $str =~ s/([\(\)])/\\$1/g; +{ + print "generating $PREFIX.ccopts... " + if $VERBOSE >= 1; - print "$str\n\n"; + $ccopts = "$Config{ccflags} $Config{optimize} $Config{cppflags} -I$Config{archlibexp}/CORE"; + $ccopts =~ s/([\(\)])/\\$1/g; open my $fh, ">$PREFIX.ccopts" or die "$PREFIX.ccopts: $!"; - print $fh $str; + print $fh $ccopts; + + print "$ccopts\n\n" + if $VERBOSE >= 1; } +my $ldopts; + { print "generating $PREFIX.ldopts... "; - my $str = $STATIC ? "-static " : ""; + $ldopts = $STATIC ? "-static " : ""; - $str .= "$Config{ccdlflags} $Config{ldflags} @libs $Config{archlibexp}/CORE/$Config{libperl} $Config{perllibs}"; + $ldopts .= "$Config{ccdlflags} $Config{ldflags} @libs $Config{archlibexp}/CORE/$Config{libperl} $Config{perllibs}"; my %seen; - $str .= " $_" for grep !$seen{$_}++, ($extralibs =~ /(\S+)/g); + $ldopts .= " $_" for reverse grep !$seen{$_}++, reverse +($extralibs =~ /(\S+)/g); for (@staticlibs) { - $str =~ s/(^|\s) (-l\Q$_\E) ($|\s)/$1-Wl,-Bstatic $2 -Wl,-Bdynamic$3/gx; + $ldopts =~ s/(^|\s) (-l\Q$_\E) ($|\s)/$1-Wl,-Bstatic $2 -Wl,-Bdynamic$3/gx; } - $str =~ s/([\(\)])/\\$1/g; - - print "$str\n\n"; + $ldopts =~ s/([\(\)])/\\$1/g; open my $fh, ">$PREFIX.ldopts" or die "$PREFIX.ldopts: $!"; - print $fh $str; + print $fh $ldopts; + + print "$ldopts\n\n" + if $VERBOSE >= 1; } if ($PERL or defined $APP) { $APP = "perl" unless defined $APP; - print "generating $APP...\n"; + my $build = "$Config{cc} $ccopts -o \Q$APP\E$Config{_exe} bundle.c $ldopts"; + + print "build $APP...\n" + if $VERBOSE >= 1; + + print "$build\n" + if $VERBOSE >= 2; - system "$Config{cc} \$(cat bundle.ccopts\) -o \Q$APP\E bundle.c \$(cat bundle.ldopts\)"; + system $build; -# unlink "$PREFIX.$_" -# for qw(ccopts ldopts c h); + unlink "$PREFIX.$_" + for qw(ccopts ldopts c h); - print "\n"; + print "\n" + if $VERBOSE >= 1; }