--- cvsroot/App-Staticperl/mkbundle 2010/12/06 19:33:57 1.1 +++ cvsroot/App-Staticperl/mkbundle 2023/08/04 03:14:33 1.41 @@ -3,28 +3,49 @@ ############################################################################# # cannot load modules till after the tracer BEGIN block -our $VERBOSE = 1; -our $STRIP = "pod"; # none, pod or ppi -our $PERL = 0; -our $VERIFY = 0; -our $STATIC = 0; +our $VERBOSE = 1; +our $STRIP = "pod"; # none, pod or ppi +our $COMPRESS = "lzf"; +our $UNISTRIP = 1; # always on, try to strip unicore swash data +our $PERL = 0; +our $APP; +our $VERIFY = 0; +our $STATIC = 0; +our $PACKLIST = 0; +our $IGNORE_ENV = 0; +our $ALLOW_DYNAMIC = 0; +our $HAVE_DYNAMIC; # maybe useful? +our $EXTRA_CFLAGS = ""; +our $EXTRA_LDFLAGS = ""; +our $EXTRA_LIBS = ""; + +our $OPTIMISE_SIZE = 0; # optimise for raw file size instead of for compression? + +our $CACHE; +our $CACHEVER = 2; # do not change unless you know what you are doing my $PREFIX = "bundle"; my $PACKAGE = "static"; my %pm; +my %pmbin; my @libs; my @static_ext; my $extralibs; +my @staticlibs; +my @incext; @ARGV or die "$0: use 'staticperl help' (or read the sources of staticperl)\n"; +# remove "." from @INC - staticperl.sh does it for us, but be on the safe side +BEGIN { @INC = grep !/^\.$/, @INC } + $|=1; our ($TRACER_W, $TRACER_R); -sub find_inc($) { +sub find_incdir($) { for (@INC) { next if ref; return $_ if -e "$_/$_[0]"; @@ -33,6 +54,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 @@ -44,13 +74,15 @@ 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"; - open my $fh, "<:perlio", "$dir/$_[1]" + open my $fh, "<:raw:perlio", "$dir/$_[1]" or warn "ERROR: $dir/$_[1]: $!\n"; $fh @@ -59,16 +91,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; @@ -76,11 +120,8 @@ } # module loading is now safe -use Config; - -sub trace_module { - syswrite $TRACER_W, "use $_[0]\n"; +sub trace_parse { for (;;) { <$TRACER_R> =~ /^-$/ or last; my $dir = <$TRACER_R>; chomp $dir; @@ -88,47 +129,25 @@ $pm{$name} = "$dir/$name"; - if ($name =~ /^(.*)\.pm$/) { - my $auto = "auto/$1"; - my $autodir = "$dir/$auto"; - - if (-d $autodir) { - opendir my $dir, $autodir - or die "$autodir: $!\n"; - - for (readdir $dir) { - # AutoLoader - $pm{"$auto/$_"} = "$autodir/$_" - if /\.(?:al|ix)$/; - - # static ext - if (/\Q$Config{_a}\E$/o) { - push @libs, "$autodir/$_"; - push @static_ext, $name; - } - - # extralibs.ld - if ($_ eq "extralibs.ld") { - open my $fh, "<:perlio", "$autodir/$_" - or die "$autodir/$_"; - - local $/; - $extralibs .= " " . <$fh>; - } + print "+ found potential dependency $name\n" + if $VERBOSE >= 3; + } +} - # dynamic object - warn "WARNING: found shared object - can't link statically ($_)\n" - if /\.\Q$Config{dlext}\E$/o; +sub trace_module { + print "tracing module $_[0]\n" + if $VERBOSE >= 2; - #TODO: extralibs? - } - } - } - } + 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 { @@ -140,93 +159,410 @@ # now we can use modules use common::sense; +use Config; use Digest::MD5; +sub cache($$$) { + my ($variant, $src, $filter) = @_; + + 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, "<:raw: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, ">:raw:perlio", "$file~") { + if ((syswrite $fh, $src) == length $src) { + close $fh; + rename "$file~", $file; + } + } + + return $src; + } + + $filter->($src) +} + sub dump_string { 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"; } } -# required for @INC loading, unfortunately -trace_module "PerlIO::scalar"; +############################################################################# + +sub glob2re { + for (quotemeta $_[0]) { + s/\\\*/\x00/g; + s/\x00\x00/.*/g; + s/\x00/[^\/]*/g; + s/\\\?/[^\/]/g; + + $_ = s/^\\\/// ? "^$_\$" : "(?:^|/)$_\$"; -#trace_module "Term::ReadLine::readline"; # Term::ReadLine::Perl dependency -# URI is difficult -#trace_module "URI::http"; -#trace_module "URI::_generic"; + s/(?: \[\^\/\] | \. ) \*\$$//x; + + return qr<$_>s + } +} + +our %INCSKIP = ( + "unicore/TestProp.pl" => undef, # 3.5MB of insanity, apparently just some testcase +); + +sub get_dirtree { + my $root = shift; + + my @tree; + my $skip; + + my $scan; $scan = sub { + for (sort do { + opendir my $fh, $_[0] + or return; + readdir $fh + }) { + next if /^\./; + + my $path = "$_[0]/$_"; + + if (-d "$path/.") { + $scan->($path); + } else { + $path = substr $path, $skip; + push @tree, $path + unless exists $INCSKIP{$path}; + } + } + }; + + $root =~ s/\/$//; + $skip = 1 + length $root; + $scan->($root); + + \@tree +} + +my $inctrees; + +sub get_inctrees { + unless ($inctrees) { + my %inctree; + $inctree{$_} ||= [$_, get_dirtree $_] # entries in @INC are often duplicates + for @INC; + $inctrees = [values %inctree]; + } + + @$inctrees +} + +############################################################################# 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]; +} + +sub cmd_staticlib { + push @staticlibs, $_ + for split /\s+/, $_[0]; +} + +sub cmd_include { + push @incext, [$_[1], glob2re $_[0]]; } +sub cmd_incglob { + my ($pattern) = @_; + + $pattern = glob2re $pattern; + + for (get_inctrees) { + my ($dir, $files) = @$_; + + $pm{$_} = "$dir/$_" + 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; - if ($cmd eq "strip") { - $STRIP = $args; - } elsif ($cmd eq "eval") { - trace_eval $_; - } elsif ($cmd eq "use") { - trace_module $_ - for split / /, $args; - } elsif ($cmd eq "boot") { - cmd_boot $args; - } elsif ($cmd eq "static") { - $STATIC = 1; - } elsif ($cmd eq "add") { - cmd_add $args; - } 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, + "compress=s" => \$COMPRESS, + "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, + + "extra-cflags=s" => \$EXTRA_CFLAGS, + "extra-ldflags=s" => \$EXTRA_LDFLAGS, + "extra-libs=s" => \$EXTRA_LIBS, + + "<>" => sub { cmd_file $_[0] }, + or exit 1; +} + Getopt::Long::Configure ("bundling", "no_auto_abbrev", "no_ignore_case"); -GetOptions - "strip=s" => \$STRIP, - "verbose|v" => sub { ++$VERBOSE }, - "quiet|q" => sub { --$VERBOSE }, - "perl" => \$PERL, - "eval=s" => sub { trace_eval $_[1] }, - "use|M=s" => sub { trace_module $_[1] }, - "boot=s" => sub { cmd_boot $_[1] }, - "add=s" => sub { cmd_add $_[1] }, - "static" => sub { $STATIC = 1 }, - "<>" => sub { cmd_file $_[1] }, - or exit 1; +parse_argv; + +die "cannot specify both --app and --perl\n" + if $PERL and defined $APP; + +die "--compress must be either none or lzf\n" + unless $COMPRESS =~ /^(?:none|lzf)\z/; + +# required for @INC loading, unfortunately +trace_module "PerlIO::scalar"; + +############################################################################# +# apply include/exclude + +{ + my %pmi; + + for (@incext) { + my ($inc, $glob) = @$_; + + my @match = grep /$glob/, keys %pm; + + 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; + } + } + + my @pmi = keys %pmi; + @pm{@pmi} = delete @pmi{@pmi}; +} + +############################################################################# +# 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 + or die "$ix: $!"; + + my $package; + + while (<$fh>) { + if (/^\s*sub\s+ ([^[:space:];]+) \s* (?:\([^)]*\))? \s*;?\s*$/x) { + my $al = "auto/$package/$1.al"; + my $inc = find_inc $al; + + defined $inc or die "$al: autoload file not found, but should be there.\n"; + + $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 "WARNING: $ix: unparsable line, please report: $_"; + } + } +} + +for my $pm (keys %pm) { + if ($pm =~ /^(.*)\.pm$/) { + my $auto = "auto/$1"; + my $autodir = find_inc $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>; + } + + $pm =~ /([^\/]+).pm$/ or die "$pm: unable to match last component"; + + my $base = $1; + + # 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 + 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 $compress = sub { shift }; + +if ($COMPRESS eq "lzf") { + require Compress::LZF; + $compress = sub { Compress::LZF::compress_best (shift) }; +} my $data; my @index; @@ -243,12 +579,12 @@ my $path = $pm{$pm}; 128 > length $pm - or die "$pm: path too long (only 128 octets supported)\n"; + or die "ERROR: $pm: path too long (only 128 octets supported)\n"; my $src = ref $path ? $$path : do { - open my $pm, "<:perlio", $path + open my $pm, "<:raw:perlio", $path or die "$path: $!"; local $/; @@ -256,130 +592,183 @@ <$pm> }; - if ($pm =~ /^auto\/POSIX\/[^\/]+\.al$/) { - if ($src =~ /^ unimpl \"/m) { - warn "$pm: skipping (not implemented anyways).\n" - if $VERBOSE >= 2; - next; + my $size = length $src; + + unless ($pmbin{$pm}) { # only do this unless the file is binary + if ($pm =~ /^auto\/POSIX\/[^\/]+\.al$/) { + if ($src =~ /^ unimpl \"/m) { + print "$pm: skipping (raises runtime error only).\n" + if $VERBOSE >= 3; + next; + } } - } - if ($STRIP =~ /ppi/i) { - require PPI; - - my $ppi = PPI::Document->new (\$src); - $ppi->prune ("PPI::Token::Comment"); - $ppi->prune ("PPI::Token::Pod"); - - # prune END stuff - for (my $last = $ppi->last_element; $last; ) { - my $prev = $last->previous_token; - - if ($last->isa (PPI::Token::Whitespace::)) { - $last->delete; - } elsif ($last->isa (PPI::Statement::End::)) { - $last->delete; - last; - } elsif ($last->isa (PPI::Token::Pod::)) { - $last->delete; - } else { - last; + $src = cache "$STRIP,$UNISTRIP,$OPTIMISE_SIZE,$COMPRESS", $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{ + (^return\ <<'END';\n) (.*?\n) (END(?:\n|\Z)) + }{ + my ($pre, $data, $post) = ($1, $2, $3); + + for ($data) { + s/^([0-9a-fA-F]+)\t([0-9a-fA-F]+)\t/sprintf "%X\t%X", hex $1, hex $2/gem + if $OPTIMISE_SIZE; + +# s{ +# ^([0-9a-fA-F]+)\t([0-9a-fA-F]*)\t +# }{ +# # ww - smaller filesize, UU - compress better +# pack "C0UU", +# hex $1, +# length $2 ? (hex $2) - (hex $1) : 0 +# }gemx; + + s/#.*\n/\n/mg; + s/\s+\n/\n/mg; + } + + "$pre$data$post" + }smex; } - $last = $prev; - } + if ($STRIP =~ /ppi/i) { + require PPI; - # prune some but not all insignificant whitespace - for my $ws (@{ $ppi->find (PPI::Token::Whitespace::) }) { - my $prev = $ws->previous_token; - my $next = $ws->next_token; + if (my $ppi = PPI::Document->new (\$src)) { + $ppi->prune ("PPI::Token::Comment"); + $ppi->prune ("PPI::Token::Pod"); + + # prune END stuff + for (my $last = $ppi->last_element; $last; ) { + my $prev = $last->previous_token; + + if ($last->isa (PPI::Token::Whitespace::)) { + $last->delete; + } elsif ($last->isa (PPI::Statement::End::)) { + $last->delete; + last; + } elsif ($last->isa (PPI::Token::Pod::)) { + $last->delete; + } else { + last; + } - if (!$prev || !$next) { - $ws->delete; - } else { - if ( - $next->isa (PPI::Token::Operator::) && $next->{content} =~ /^(?:,|=|!|!=|==|=>)$/ # no ., because of digits. == float - or $prev->isa (PPI::Token::Operator::) && $prev->{content} =~ /^(?:,|=|\.|!|!=|==|=>)$/ - or $prev->isa (PPI::Token::Structure::) - # decrease size, decrease compressability - #or ($prev->isa (PPI::Token::Word::) - # && (PPI::Token::Symbol:: eq ref $next - # || $next->isa (PPI::Structure::Block::) - # || $next->isa (PPI::Structure::List::) - # || $next->isa (PPI::Structure::Condition::))) - ) { - $ws->delete; - } elsif ($prev->isa (PPI::Token::Whitespace::)) { - $ws->{content} = ' '; - $prev->delete; + $last = $prev; + } + + # prune some but not all insignificant whitespace + for my $ws (@{ $ppi->find (PPI::Token::Whitespace::) }) { + my $prev = $ws->previous_token; + my $next = $ws->next_token; + + if (!$prev || !$next) { + $ws->delete; + } else { + if ($next->isa (PPI::Token::Whitespace::)) { + $ws->delete; + } elsif ( + $next->isa (PPI::Token::Operator::) && $next->{content} =~ /^(?:,|=|!|!=|==|=>)$/ # no ., because of digits. == float + or $prev->isa (PPI::Token::Operator::) && $prev->{content} =~ /^(?:,|=|\.|!|!=|==|=>)$/ + or $prev->isa (PPI::Token::Structure::) + or ($OPTIMISE_SIZE && + ($prev->isa (PPI::Token::Word::) + && (PPI::Token::Symbol:: eq ref $next + || $next->isa (PPI::Structure::Block::) + || $next->isa (PPI::Structure::List::) + || $next->isa (PPI::Structure::Condition::))) + ) + ) { + # perl has some idiotic warnigns about nonexisting operators + if ($prev->isa (PPI::Token::Operator::) && $prev->{content} eq "=" + && $next->isa (PPI::Token::Operator::) && $next->{content} =~ /[+\-]/ + ) { + # avoid "Reverse %s operator" diagnostic + } else { + $ws->delete; + } + } else { + $ws->{content} = ' '; + } + } + } + + # prune whitespace around blocks + if ($OPTIMISE_SIZE) { + # these usually decrease size, but decrease compressability more + for my $struct (PPI::Structure::Block::, PPI::Structure::Condition::) { + for my $node (@{ $ppi->find ($struct) }) { + my $n1 = $node->first_token; + my $n2 = $n1->previous_token; + $n1->delete if $n1->isa (PPI::Token::Whitespace::); + $n2->delete if $n2 && $n2->isa (PPI::Token::Whitespace::); + my $n1 = $node->last_token; + my $n2 = $n1->next_token; + $n1->delete if $n1->isa (PPI::Token::Whitespace::); + $n2->delete if $n2 && $n2->isa (PPI::Token::Whitespace::); + } + } + + for my $node (@{ $ppi->find (PPI::Structure::List::) }) { + my $n1 = $node->first_token; + $n1->delete if $n1->isa (PPI::Token::Whitespace::); + my $n1 = $node->last_token; + $n1->delete if $n1->isa (PPI::Token::Whitespace::); + } + } + + # reformat qw() lists which often have lots of whitespace + for my $node (@{ $ppi->find (PPI::Token::QuoteLike::Words::) }) { + if ($node->{content} =~ /^qw(.)(.*)(.)$/s) { + my ($a, $qw, $b) = ($1, $2, $3); + $qw =~ s/^\s+//; + $qw =~ s/\s+$//; + $qw =~ s/\s+/ /g; + $node->{content} = "qw$a$qw$b"; + } + } + + $src = $ppi->serialize; } else { - $ws->{content} = ' '; + warn "WARNING: $pm{$pm}: PPI failed to parse this file\n"; } - } - } + } elsif ($STRIP =~ /pod/i && $pm ne "Opcode.pm") { # opcode parses its own pod + require Pod::Strip; - # prune whitespace around blocks - if (0) { - # these usually decrease size, but decrease compressability more - for my $struct (PPI::Structure::Block::, PPI::Structure::Condition::) { - for my $node (@{ $ppi->find ($struct) }) { - my $n1 = $node->first_token; - my $n2 = $n1->previous_token; - $n1->delete if $n1->isa (PPI::Token::Whitespace::); - $n2->delete if $n2 && $n2->isa (PPI::Token::Whitespace::); - my $n1 = $node->last_token; - my $n2 = $n1->next_token; - $n1->delete if $n1->isa (PPI::Token::Whitespace::); - $n2->delete if $n2 && $n2->isa (PPI::Token::Whitespace::); - } - } + my $stripper = Pod::Strip->new; - for my $node (@{ $ppi->find (PPI::Structure::List::) }) { - my $n1 = $node->first_token; - $n1->delete if $n1->isa (PPI::Token::Whitespace::); - my $n1 = $node->last_token; - $n1->delete if $n1->isa (PPI::Token::Whitespace::); + my $out; + $stripper->output_string (\$out); + $stripper->parse_string_document ($src) + or die; + $src = $out; } - } - # reformat qw() lists which often have lots of whitespace - for my $node (@{ $ppi->find (PPI::Token::QuoteLike::Words::) }) { - if ($node->{content} =~ /^qw(.)(.*)(.)$/s) { - my ($a, $qw, $b) = ($1, $2, $3); - $qw =~ s/^\s+//; - $qw =~ s/\s+$//; - $qw =~ s/\s+/ /g; - $node->{content} = "qw$a$qw$b"; + if ($VERIFY && $pm =~ /\.pm$/ && $pm ne "Opcode.pm") { + if (open my $fh, "-|") { + <$fh>; + } else { + eval "#line 1 \"$pm\"\n$src" or warn "\n\n\n$pm\n\n$src\n$@\n\n\n"; + exit 0; + } } - } - - $src = $ppi->serialize; - } elsif ($STRIP =~ /pod/i && $pm ne "Opcode.pm") { # opcode parses it's own pod - require Pod::Strip; - my $stripper = Pod::Strip->new; + $src = $compress->($src); - my $out; - $stripper->output_string (\$out); - $stripper->parse_string_document ($src); - $src = $out; - } + $src + }; - if ($VERIFY && $pm =~ /\.pm$/ && $pm ne "Opcode.pm") { - if (open my $fh, "-|") { - <$fh>; - } else { - eval "#line 1 \"$pm\"\n$src" or warn "\n\n\n$pm\n\n$src\n$@\n\n\n"; - exit 0; - } +# if ($pm eq "Opcode.pm") { +# open my $fh, ">x" or die; print $fh $src;#d# +# exit 1; +# } } -# if ($pm eq "Opcode.pm") { -# open my $fh, ">x" or die; print $fh $src;#d# -# exit 1; -# } - - warn "adding $pm\n" + print "adding $pm (original size $size, stored size ", length $src, ")\n" if $VERBOSE >= 2; push @index, ((length $pm) << 25) | length $data; @@ -387,48 +776,50 @@ } 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 #include /* public API */ EXTERN_C PerlInterpreter *staticperl; -EXTERN_C void staticperl_init (void); +EXTERN_C void staticperl_xs_init (pTHX); +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 < -#include -#include +/* do not edit, automatically created by staticperl */ #include "bundle.h" @@ -438,6 +829,116 @@ EOF ############################################################################# +# lzf decompressor + +if ($COMPRESS eq "lzf") { + print $fh <<'EOF'; +/* stripped down/perlified version of lzf_d.c from liblzf-3.7 */ + +#if (__i386 || __amd64) && __GNUC__ >= 3 +# define lzf_movsb(dst, src, len) \ + asm ("rep movsb" \ + : "=D" (dst), "=S" (src), "=c" (len) \ + : "0" (dst), "1" (src), "2" (len)); +#endif + +static unsigned int +lzf_decompress (const void *const in_data, unsigned int in_len, + void *out_data, unsigned int out_len) +{ + U8 const *ip = (const U8 *)in_data; + U8 *op = (U8 *)out_data; + U8 const *const in_end = ip + in_len; + U8 *const out_end = op + out_len; + + do + { + unsigned int ctrl = *ip++; + + if (ctrl < (1 << 5)) /* literal run */ + { + ctrl++; + + if (op + ctrl > out_end) + return 0; + +#ifdef lzf_movsb + lzf_movsb (op, ip, ctrl); +#else + while (ctrl--) + *op++ = *ip++; +#endif + } + else /* back reference */ + { + unsigned int len = ctrl >> 5; + + U8 *ref = op - ((ctrl & 0x1f) << 8) - 1; + + if (len == 7) + len += *ip++; + + ref -= *ip++; + + if (op + len + 2 > out_end) + return 0; + + if (ref < (U8 *)out_data) + return 0; + + len += 2; +#ifdef lzf_movsb + lzf_movsb (op, ref, len); +#else + do + *op++ = *ref++; + while (--len); +#endif + } + } + while (ip < in_end); + + return op - (U8 *)out_data; +} + +static SV * +static_to_sv (const char *ptr, STRLEN len) +{ + SV *res; + const U8 *p = (const U8 *)ptr; + + if (len == 0) /* empty */ + res = newSVpvn ("", 0); + else if (*p == 0) /* not compressed */ + res = newSVpvn (p + 1, len - 1); + else /* lzf compressed, with UTF-8-encoded original size in front */ + { + STRLEN ulenlen; + UV ulen = utf8n_to_uvchr (p, len, &ulenlen, 0); + + p += ulenlen; + len -= ulenlen; + + res = NEWSV (0, ulen); + sv_upgrade (res, SVt_PV); + SvPOK_only (res); + lzf_decompress (p, len, SvPVX (res), ulen); + SvCUR_set (res, ulen); + } + + return res; +} + +EOF +} else { + 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; @@ -532,7 +1072,7 @@ int ofs2 = $varpfx\_index [m + 1] & 0x1FFFFFFU; ofs += namelen; - res = newSVpvn ($varpfx\_data + ofs, ofs2 - ofs); + res = static_to_sv ($varpfx\_data + ofs, ofs2 - ofs); goto found; } } @@ -546,8 +1086,7 @@ XSRETURN (0); found: - ST (0) = res; - sv_2mortal (ST (0)); + ST (0) = sv_2mortal (res); } XSRETURN (1); @@ -570,18 +1109,16 @@ { U32 idx = $varpfx\_index [i]; - PUSHs (newSVpvn ($varpfx\_data + (idx & 0x1FFFFFFU), idx >> 25)); + PUSHs (sv_2mortal (newSVpvn ($varpfx\_data + (idx & 0x1FFFFFFU), idx >> 25))); } } XSRETURN ($varpfx\_count); } -static char *args[] = { - "staticperl", - "-e", - "0" -}; +#ifdef STATICPERL_BUNDLE_INCLUDE +#include STATICPERL_BUNDLE_INCLUDE +#endif EOF @@ -589,12 +1126,12 @@ # xs_init 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 $EXTRA_CFLAGS"; + $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} $EXTRA_LDFLAGS @libs $Config{archlibexp}/CORE/$Config{libperl} $Config{perllibs} $EXTRA_LIBS"; my %seen; - $str .= " $_" for grep !$seen{$_}++, ($extralibs =~ /(\S+)/g); + $ldopts .= " $_" for reverse grep !$seen{$_}++, reverse +($extralibs =~ /(\S+)/g); - $str =~ s/([\(\)])/\\$1/g; + for (@staticlibs) { + $ldopts =~ s/(^|\s) (-l\Q$_\E) ($|\s)/$1-Wl,-Bstatic $2 -Wl,-Bdynamic$3/gx; + } - 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) { - system "$Config{cc} \$(cat bundle.ccopts\) -o perl bundle.c \$(cat bundle.ldopts\)"; +if ($PERL or defined $APP) { + $APP = "perl" unless defined $APP; + + 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 $build; unlink "$PREFIX.$_" for qw(ccopts ldopts c h); + + print "\n" + if $VERBOSE >= 1; }