[ViewVC] Annotation of: cvs/App-Staticperl/mkbundle

#!/opt/bin/perl

#############################################################################
# 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;

my $PREFIX  = "bundle";
my $PACKAGE = "static";

my %pm;
my @libs;
my @static_ext;
my $extralibs;

@ARGV
   or die "$0: use 'staticperl help' (or read the sources of staticperl)\n";

$|=1;

our ($TRACER_W, $TRACER_R);

sub find_inc($) {
   for (@INC) {
      next if ref;
      return $_ if -e "$_/$_[0]";
   }

   undef
}

BEGIN {
   # create a loader process to detect @INC requests before we load any modules
   my ($W_TRACER, $R_TRACER); # used by tracer

   pipe $R_TRACER, $TRACER_W or die "pipe: $!";
   pipe $TRACER_R, $W_TRACER or die "pipe: $!";

   unless (fork) {
      close $TRACER_R;
      close $TRACER_W;

      unshift @INC, sub {
         my $dir = find_inc $_[1]
            or return;

         syswrite $W_TRACER, "-\n$dir\n$_[1]\n";

         open my $fh, "<:perlio", "$dir/$_[1]"
            or warn "ERROR: $dir/$_[1]: $!\n";

         $fh
      };

      while (<$R_TRACER>) {
         if (/use (.*)$/) {
            my $mod = $1;
            eval "require $mod";
            warn "ERROR: $@ (while loading '$mod')\n"
               if $@;
            syswrite $W_TRACER, "\n";
         } elsif (/eval (.*)$/) {
            my $eval = $1;
            eval $eval;
            warn "ERROR: $@ (in '$eval')\n"
               if $@;
         }
      }

      exit 0;
   }
}

# module loading is now safe
use Config;

sub trace_module {
   syswrite $TRACER_W, "use $_[0]\n";

   for (;;) {
      <$TRACER_R> =~ /^-$/ or last;
      my $dir  = <$TRACER_R>; chomp $dir;
      my $name = <$TRACER_R>; chomp $name;

      $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>;
               }

               # dynamic object
               warn "WARNING: found shared object - can't link statically ($_)\n"
                  if /\.\Q$Config{dlext}\E$/o;

               #TODO: extralibs?
            }
         }
      }
   }
}

sub trace_eval {
   syswrite $TRACER_W, "eval $_[0]\n";
}

sub trace_finish {
   close $TRACER_W;
   close $TRACER_R;
}

#############################################################################
# now we can use modules

use common::sense;
use Digest::MD5;

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";
      }
   } else {
      print $fh "  \"\"\n";
   }
}

# required for @INC loading, unfortunately
trace_module "PerlIO::scalar";

#trace_module "Term::ReadLine::readline"; # Term::ReadLine::Perl dependency
# URI is difficult
#trace_module "URI::http";
#trace_module "URI::_generic";

sub cmd_boot {
   $pm{"//boot"} = $_[0];
}

sub cmd_add {
   $_[0] =~ /^(.*)(?:\s*(\S+))$/
      or die "$_[0]: cannot parse";

   my $file = $1;
   my $as   = defined $2 ? $2 : "/$1";

   $pm{$as} = $file;
}

sub cmd_file {
   open my $fh, "<", $_[0]
      or die "$_[0]: $!\n";

   while (<$fh>) {
      chomp;
      my ($cmd, $args) = split / /, $_, 2;
      $cmd =~ s/^-+//;

      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";
      }
   }
}

use Getopt::Long;

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|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] },
   "static"    => sub { $STATIC = 1 },
   "<>"        => sub { cmd_file     $_[1] },
   or exit 1;

my $data;
my @index;
my @order = sort {
   length $a <=> length $b
      or $a cmp $b
} keys %pm;

# sorting by name - better compression, but needs more metadata
# sorting by length - faster lookup
# usually, the metadata overhead beats the loss through compression

for my $pm (@order) {
   my $path = $pm{$pm};

   128 > length $pm
      or die "$pm: path too long (only 128 octets supported)\n";

   my $src = ref $path
           ? $$path
           : do {
              open my $pm, "<:perlio", $path
                 or die "$path: $!";

              local $/;
              
              <$pm>
           };

   if ($pm =~ /^auto\/POSIX\/[^\/]+\.al$/) {
      if ($src =~ /^    unimpl \"/m) {
         warn "$pm: skipping (not implemented anyways).\n"
            if $VERBOSE >= 2;
         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;
         }

         $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::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;
            } else {
               $ws->{content} = ' ';
            }
         }
      }

      # 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::);
            }
         }

         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;
   } elsif ($STRIP =~ /pod/i && $pm ne "Opcode.pm") { # opcode parses it's own pod
      require Pod::Strip;

      my $stripper = Pod::Strip->new;

      my $out;
      $stripper->output_string (\$out);
      $stripper->parse_string_document ($src);
      $src = $out;
   }

   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;
#   }

   warn "adding $pm\n"
      if $VERBOSE >= 2;

   push @index, ((length $pm) << 25) | length $data;
   $data .= $pm . $src;
}

length $data < 2**25
   or die "bundle too large (only 32MB supported)\n";

my $varpfx = "bundle_" . substr +(Digest::MD5::md5_hex $data), 0, 16;

#############################################################################
# output

print "generating $PREFIX.h... ";

{
   open my $fh, ">", "$PREFIX.h"
      or die "$PREFIX.h: $!\n";

   print $fh <<EOF;
/* do not edit, automatically created by mkstaticbundle */
#include <EXTERN.h>
#include <perl.h>
#include <XSUB.h>

/* public API */
EXTERN_C PerlInterpreter *staticperl;
EXTERN_C void staticperl_init (void);
EXTERN_C void staticperl_cleanup (void);
EOF
}

print "\n";

#############################################################################
# output

print "generating $PREFIX.c... ";

open my $fh, ">", "$PREFIX.c"
   or die "$PREFIX.c: $!\n";

print $fh <<EOF;
/* do not edit, automatically created by mkstaticbundle */

#include <EXTERN.h>
#include <perl.h>
#include <XSUB.h>

#include "bundle.h"

/* public API */
PerlInterpreter *staticperl;

EOF

#############################################################################
# bundle data

my $count = @index;

print $fh <<EOF;
#include "bundle.h"

/* bundle data */

static const U32 $varpfx\_count = $count;
static const U32 $varpfx\_index [$count + 1] = {
EOF

my $col;
for (@index) {
   printf $fh "0x%08x,", $_;
   print $fh "\n" unless ++$col % 10;

}
printf $fh "0x%08x\n};\n", (length $data);

print $fh "static const char $varpfx\_data [] =\n";
dump_string $fh, $data;

print $fh ";\n\n";;

#############################################################################
# bootstrap

# boot file for staticperl
# this file will be eval'ed at initialisation time

my $bootstrap = '
BEGIN {
   package ' . $PACKAGE . ';

   PerlIO::scalar->bootstrap;

   @INC = sub {
      my $data = find "$_[1]"
         or return;

      $INC{$_[1]} = $_[1];

      open my $fh, "<", \$data;
      $fh
   };
}
';

$bootstrap .= "require '//boot';"
   if exists $pm{"//boot"};

$bootstrap =~ s/\s+/ /g;
$bootstrap =~ s/(\W) /$1/g;
$bootstrap =~ s/ (\W)/$1/g;

print $fh "const char bootstrap [] = ";
dump_string $fh, $bootstrap;
print $fh ";\n\n";

print $fh <<EOF;
/* search all bundles for the given file, using binary search */
XS(find)
{
  dXSARGS;

  if (items != 1)
    Perl_croak (aTHX_ "Usage: $PACKAGE\::find (\$path)");

  {
    STRLEN namelen;
    char *name = SvPV (ST (0), namelen);
    SV *res = 0;

    int l = 0, r = $varpfx\_count;

    while (l <= r)
      {
        int m = (l + r) >> 1;
        U32 idx = $varpfx\_index [m];
        int comp = namelen - (idx >> 25);

        if (!comp)
          {
            int ofs = idx & 0x1FFFFFFU;
            comp = memcmp (name, $varpfx\_data + ofs, namelen);

            if (!comp)
              {
                /* found */
                int ofs2 =  $varpfx\_index [m + 1] & 0x1FFFFFFU;

                ofs += namelen;
                res = newSVpvn ($varpfx\_data + ofs, ofs2 - ofs);
                goto found;
              }
          }

        if (comp < 0)
          r = m - 1;
        else
          l = m + 1;
      }

    XSRETURN (0);

  found:
    ST (0) = res;
    sv_2mortal (ST (0));
  }

  XSRETURN (1);
}

/* list all files in the bundle */
XS(list)
{
  dXSARGS;

  if (items != 0)
    Perl_croak (aTHX_ "Usage: $PACKAGE\::list");

  {
    int i;

    EXTEND (SP, $varpfx\_count);

    for (i = 0; i < $varpfx\_count; ++i)
      {
        U32 idx = $varpfx\_index [i];

        PUSHs (newSVpvn ($varpfx\_data + (idx & 0x1FFFFFFU), idx >> 25));
      }
  }

  XSRETURN ($varpfx\_count);
}

static char *args[] = {
  "staticperl",
  "-e",
  "0"
};

EOF

#############################################################################
# xs_init

print $fh <<EOF;
static void
xs_init (pTHX)
{
EOF

@static_ext = ("DynaLoader", sort @static_ext);

# prototypes
for (@static_ext) {
   s/\.pm$//;
   (my $cname = $_) =~ s/\//__/g;
   print $fh "  EXTERN_C void boot_$cname (pTHX_ CV* cv);\n";
}

print $fh <<EOF;
  char *file = __FILE__;
  dXSUB_SYS;

  newXSproto ("$PACKAGE\::find", find, file, "\$");
  newXSproto ("$PACKAGE\::list", list, file, "");
EOF

# calls
for (@static_ext) {
   s/\.pm$//;

   (my $cname = $_) =~ s/\//__/g;
   (my $pname = $_) =~ s/\//::/g;

   my $bootstrap = $pname eq "DynaLoader" ? "boot" : "bootstrap";

   print $fh "  newXS (\"$pname\::$bootstrap\", boot_$cname, file);\n";
}

print $fh <<EOF;
  Perl_av_create_and_unshift_one (&PL_preambleav, newSVpv (bootstrap, sizeof (bootstrap) - 1));
}
EOF

#############################################################################
# optional perl_init/perl_destroy

if ($PERL) {
   print $fh <<EOF;

int
main (int argc, char *argv [])
{
  extern char **environ;
  int exitstatus;

  PERL_SYS_INIT3 (&argc, &argv, &environ);
  staticperl = perl_alloc ();
  perl_construct (staticperl);

  PL_exit_flags |= PERL_EXIT_DESTRUCT_END;

  exitstatus = perl_parse (staticperl, xs_init, argc, argv, environ);
  if (!exitstatus)
    perl_run (staticperl);

  exitstatus = perl_destruct (staticperl);
  perl_free (staticperl);
  PERL_SYS_TERM ();

  return exitstatus;
}
EOF
} else {
   print $fh <<EOF;

EXTERN_C void
staticperl_init (void)
{
  extern char **environ;
  int argc = sizeof (args) / sizeof (args [0]);
  char **argv = args;

  PERL_SYS_INIT3 (&argc, &argv, &environ);
  staticperl = perl_alloc ();
  perl_construct (staticperl);
  PL_origalen = 1;
  PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
  perl_parse (staticperl, xs_init, argc, argv, environ);

  perl_run (staticperl);
}

EXTERN_C void
staticperl_cleanup (void)
{
  perl_destruct (staticperl);
  perl_free (staticperl);
  staticperl = 0;
  PERL_SYS_TERM ();
}
EOF
}

print -s "$PREFIX.c", " octets (", (length $data) , " data octets).\n\n";

#############################################################################
# libs, cflags

{
   print "generating $PREFIX.ccopts... ";

   my $str = "$Config{ccflags} $Config{optimize} $Config{cppflags} -I$Config{archlibexp}/CORE";
   $str =~ s/([\(\)])/\\$1/g;

   print "$str\n\n";

   open my $fh, ">$PREFIX.ccopts"
      or die "$PREFIX.ccopts: $!";
   print $fh $str;
}

{
   print "generating $PREFIX.ldopts... ";

   my $str = $STATIC ? "--static " : "";

   $str .= "$Config{ccdlflags} $Config{ldflags} @libs $Config{archlibexp}/CORE/$Config{libperl} $Config{perllibs}";

   my %seen;
   $str .= " $_" for grep !$seen{$_}++, ($extralibs =~ /(\S+)/g);

   $str =~ s/([\(\)])/\\$1/g;

   print "$str\n\n";

   open my $fh, ">$PREFIX.ldopts"
      or die "$PREFIX.ldopts: $!";
   print $fh $str;
}

if ($PERL) {
   system "$Config{cc} \$(cat bundle.ccopts\) -o perl bundle.c \$(cat bundle.ldopts\)";

   unlink "$PREFIX.$_"
      for qw(ccopts ldopts c h);
}

Revision:	1.2
Committed:	Mon Dec 6 20:53:43 2010 UTC (13 years, 6 months ago) by root
Branch:	MAIN
Changes since 1.1:	+2 -1 lines
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.1	#!/opt/bin/perl
2
3			#############################################################################
4			# cannot load modules till after the tracer BEGIN block
5
6			our $VERBOSE = 1;
7			our $STRIP = "pod"; # none, pod or ppi
8			our $PERL = 0;
9			our $VERIFY = 0;
10			our $STATIC = 0;
11
12			my $PREFIX = "bundle";
13			my $PACKAGE = "static";
14
15			my %pm;
16			my @libs;
17			my @static_ext;
18			my $extralibs;
19
20			@ARGV
21			or die "$0: use 'staticperl help' (or read the sources of staticperl)\n";
22
23			$\|=1;
24
25			our ($TRACER_W, $TRACER_R);
26
27			sub find_inc($) {
28			for (@INC) {
29			next if ref;
30			return $_ if -e "$_/$_[0]";
31			}
32
33			undef
34			}
35
36			BEGIN {
37			# create a loader process to detect @INC requests before we load any modules
38			my ($W_TRACER, $R_TRACER); # used by tracer
39
40			pipe $R_TRACER, $TRACER_W or die "pipe: $!";
41			pipe $TRACER_R, $W_TRACER or die "pipe: $!";
42
43			unless (fork) {
44			close $TRACER_R;
45			close $TRACER_W;
46
47			unshift @INC, sub {
48			my $dir = find_inc $_[1]
49			or return;
50
51			syswrite $W_TRACER, "-\n$dir\n$_[1]\n";
52
53			open my $fh, "<:perlio", "$dir/$_[1]"
54			or warn "ERROR: $dir/$_[1]: $!\n";
55
56			$fh
57			};
58
59			while (<$R_TRACER>) {
60			if (/use (.*)$/) {
61			my $mod = $1;
62			eval "require $mod";
63			warn "ERROR: $@ (while loading '$mod')\n"
64			if $@;
65			syswrite $W_TRACER, "\n";
66			} elsif (/eval (.*)$/) {
67			my $eval = $1;
68			eval $eval;
69			warn "ERROR: $@ (in '$eval')\n"
70			if $@;
71			}
72			}
73
74			exit 0;
75			}
76			}
77
78			# module loading is now safe
79			use Config;
80
81			sub trace_module {
82			syswrite $TRACER_W, "use $_[0]\n";
83
84			for (;;) {
85			<$TRACER_R> =~ /^-$/ or last;
86			my $dir = <$TRACER_R>; chomp $dir;
87			my $name = <$TRACER_R>; chomp $name;
88
89			$pm{$name} = "$dir/$name";
90
91			if ($name =~ /^(.*)\.pm$/) {
92			my $auto = "auto/$1";
93			my $autodir = "$dir/$auto";
94
95			if (-d $autodir) {
96			opendir my $dir, $autodir
97			or die "$autodir: $!\n";
98
99			for (readdir $dir) {
100			# AutoLoader
101			$pm{"$auto/$_"} = "$autodir/$_"
102			if /\.(?:al\|ix)$/;
103
104			# static ext
105			if (/\Q$Config{_a}\E$/o) {
106			push @libs, "$autodir/$_";
107			push @static_ext, $name;
108			}
109
110			# extralibs.ld
111			if ($_ eq "extralibs.ld") {
112			open my $fh, "<:perlio", "$autodir/$_"
113			or die "$autodir/$_";
114
115			local $/;
116			$extralibs .= " " . <$fh>;
117			}
118
119			# dynamic object
120			warn "WARNING: found shared object - can't link statically ($_)\n"
121			if /\.\Q$Config{dlext}\E$/o;
122
123			#TODO: extralibs?
124			}
125			}
126			}
127			}
128			}
129
130			sub trace_eval {
131			syswrite $TRACER_W, "eval $_[0]\n";
132			}
133
134			sub trace_finish {
135			close $TRACER_W;
136			close $TRACER_R;
137			}
138
139			#############################################################################
140			# now we can use modules
141
142			use common::sense;
143			use Digest::MD5;
144
145			sub dump_string {
146			my ($fh, $data) = @_;
147
148			if (length $data) {
149			for (
150			my $ofs = 0;
151			length (my $substr = substr $data, $ofs, 80);
152			$ofs += 80
153			) {
154			$substr =~ s/([^\x20-\x21\x23-\x5b\x5d-\x7e])/sprintf "\\%03o", ord $1/ge;
155			$substr =~ s/\?/\\?/g; # trigraphs...
156			print $fh " \"$substr\"\n";
157			}
158			} else {
159			print $fh " \"\"\n";
160			}
161			}
162
163			# required for @INC loading, unfortunately
164			trace_module "PerlIO::scalar";
165
166			#trace_module "Term::ReadLine::readline"; # Term::ReadLine::Perl dependency
167			# URI is difficult
168			#trace_module "URI::http";
169			#trace_module "URI::_generic";
170
171			sub cmd_boot {
172			$pm{"//boot"} = $_[0];
173			}
174
175			sub cmd_add {
176			$_[0] =~ /^(.)(?:\s(\S+))$/
177			or die "$_[0]: cannot parse";
178
179			my $file = $1;
180			my $as = defined $2 ? $2 : "/$1";
181
182			$pm{$as} = $file;
183			}
184
185			sub cmd_file {
186			open my $fh, "<", $_[0]
187			or die "$_[0]: $!\n";
188
189			while (<$fh>) {
190			chomp;
191			my ($cmd, $args) = split / /, $_, 2;
192	root	1.2	$cmd =~ s/^-+//;
193	root	1.1
194			if ($cmd eq "strip") {
195			$STRIP = $args;
196			} elsif ($cmd eq "eval") {
197			trace_eval $_;
198			} elsif ($cmd eq "use") {
199			trace_module $_
200			for split / /, $args;
201			} elsif ($cmd eq "boot") {
202			cmd_boot $args;
203			} elsif ($cmd eq "static") {
204			$STATIC = 1;
205			} elsif ($cmd eq "add") {
206			cmd_add $args;
207			} elsif (/^\s*#/) {
208			# comment
209			} elsif (/\S/) {
210			die "$_: unsupported directive\n";
211			}
212			}
213			}
214
215			use Getopt::Long;
216
217			Getopt::Long::Configure ("bundling", "no_auto_abbrev", "no_ignore_case");
218
219			GetOptions
220			"strip=s" => \$STRIP,
221			"verbose\|v" => sub { ++$VERBOSE },
222			"quiet\|q" => sub { --$VERBOSE },
223			"perl" => \$PERL,
224	root	1.2	"eval\|e=s" => sub { trace_eval $_[1] },
225	root	1.1	"use\|M=s" => sub { trace_module $_[1] },
226			"boot=s" => sub { cmd_boot $_[1] },
227			"add=s" => sub { cmd_add $_[1] },
228			"static" => sub { $STATIC = 1 },
229			"<>" => sub { cmd_file $_[1] },
230			or exit 1;
231
232			my $data;
233			my @index;
234			my @order = sort {
235			length $a <=> length $b
236			or $a cmp $b
237			} keys %pm;
238
239			# sorting by name - better compression, but needs more metadata
240			# sorting by length - faster lookup
241			# usually, the metadata overhead beats the loss through compression
242
243			for my $pm (@order) {
244			my $path = $pm{$pm};
245
246			128 > length $pm
247			or die "$pm: path too long (only 128 octets supported)\n";
248
249			my $src = ref $path
250			? $$path
251			: do {
252			open my $pm, "<:perlio", $path
253			or die "$path: $!";
254
255			local $/;
256
257			<$pm>
258			};
259
260			if ($pm =~ /^auto\/POSIX\/[^\/]+\.al$/) {
261			if ($src =~ /^ unimpl \"/m) {
262			warn "$pm: skipping (not implemented anyways).\n"
263			if $VERBOSE >= 2;
264			next;
265			}
266			}
267
268			if ($STRIP =~ /ppi/i) {
269			require PPI;
270
271			my $ppi = PPI::Document->new (\$src);
272			$ppi->prune ("PPI::Token::Comment");
273			$ppi->prune ("PPI::Token::Pod");
274
275			# prune END stuff
276			for (my $last = $ppi->last_element; $last; ) {
277			my $prev = $last->previous_token;
278
279			if ($last->isa (PPI::Token::Whitespace::)) {
280			$last->delete;
281			} elsif ($last->isa (PPI::Statement::End::)) {
282			$last->delete;
283			last;
284			} elsif ($last->isa (PPI::Token::Pod::)) {
285			$last->delete;
286			} else {
287			last;
288			}
289
290			$last = $prev;
291			}
292
293			# prune some but not all insignificant whitespace
294			for my $ws (@{ $ppi->find (PPI::Token::Whitespace::) }) {
295			my $prev = $ws->previous_token;
296			my $next = $ws->next_token;
297
298			if (!$prev \|\| !$next) {
299			$ws->delete;
300			} else {
301			if (
302			$next->isa (PPI::Token::Operator::) && $next->{content} =~ /^(?:,\|=\|!\|!=\|==\|=>)$/ # no ., because of digits. == float
303			or $prev->isa (PPI::Token::Operator::) && $prev->{content} =~ /^(?:,\|=\|\.\|!\|!=\|==\|=>)$/
304			or $prev->isa (PPI::Token::Structure::)
305			# decrease size, decrease compressability
306			#or ($prev->isa (PPI::Token::Word::)
307			# && (PPI::Token::Symbol:: eq ref $next
308			# \|\| $next->isa (PPI::Structure::Block::)
309			# \|\| $next->isa (PPI::Structure::List::)
310			# \|\| $next->isa (PPI::Structure::Condition::)))
311			) {
312			$ws->delete;
313			} elsif ($prev->isa (PPI::Token::Whitespace::)) {
314			$ws->{content} = ' ';
315			$prev->delete;
316			} else {
317			$ws->{content} = ' ';
318			}
319			}
320			}
321
322			# prune whitespace around blocks
323			if (0) {
324			# these usually decrease size, but decrease compressability more
325			for my $struct (PPI::Structure::Block::, PPI::Structure::Condition::) {
326			for my $node (@{ $ppi->find ($struct) }) {
327			my $n1 = $node->first_token;
328			my $n2 = $n1->previous_token;
329			$n1->delete if $n1->isa (PPI::Token::Whitespace::);
330			$n2->delete if $n2 && $n2->isa (PPI::Token::Whitespace::);
331			my $n1 = $node->last_token;
332			my $n2 = $n1->next_token;
333			$n1->delete if $n1->isa (PPI::Token::Whitespace::);
334			$n2->delete if $n2 && $n2->isa (PPI::Token::Whitespace::);
335			}
336			}
337
338			for my $node (@{ $ppi->find (PPI::Structure::List::) }) {
339			my $n1 = $node->first_token;
340			$n1->delete if $n1->isa (PPI::Token::Whitespace::);
341			my $n1 = $node->last_token;
342			$n1->delete if $n1->isa (PPI::Token::Whitespace::);
343			}
344			}
345
346			# reformat qw() lists which often have lots of whitespace
347			for my $node (@{ $ppi->find (PPI::Token::QuoteLike::Words::) }) {
348			if ($node->{content} =~ /^qw(.)(.*)(.)$/s) {
349			my ($a, $qw, $b) = ($1, $2, $3);
350			$qw =~ s/^\s+//;
351			$qw =~ s/\s+$//;
352			$qw =~ s/\s+/ /g;
353			$node->{content} = "qw$a$qw$b";
354			}
355			}
356
357			$src = $ppi->serialize;
358			} elsif ($STRIP =~ /pod/i && $pm ne "Opcode.pm") { # opcode parses it's own pod
359			require Pod::Strip;
360
361			my $stripper = Pod::Strip->new;
362
363			my $out;
364			$stripper->output_string (\$out);
365			$stripper->parse_string_document ($src);
366			$src = $out;
367			}
368
369			if ($VERIFY && $pm =~ /\.pm$/ && $pm ne "Opcode.pm") {
370			if (open my $fh, "-\|") {
371			<$fh>;
372			} else {
373			eval "#line 1 \"$pm\"\n$src" or warn "\n\n\n$pm\n\n$src\n$@\n\n\n";
374			exit 0;
375			}
376			}
377
378			# if ($pm eq "Opcode.pm") {
379			# open my $fh, ">x" or die; print $fh $src;#d#
380			# exit 1;
381			# }
382
383			warn "adding $pm\n"
384			if $VERBOSE >= 2;
385
386			push @index, ((length $pm) << 25) \| length $data;
387			$data .= $pm . $src;
388			}
389
390			length $data < 2**25
391			or die "bundle too large (only 32MB supported)\n";
392
393			my $varpfx = "bundle_" . substr +(Digest::MD5::md5_hex $data), 0, 16;
394
395			#############################################################################
396			# output
397
398			print "generating $PREFIX.h... ";
399
400			{
401			open my $fh, ">", "$PREFIX.h"
402			or die "$PREFIX.h: $!\n";
403
404			print $fh <<EOF;
405			/* do not edit, automatically created by mkstaticbundle */
406			#include <EXTERN.h>
407			#include <perl.h>
408			#include <XSUB.h>
409
410			/* public API */
411			EXTERN_C PerlInterpreter *staticperl;
412			EXTERN_C void staticperl_init (void);
413			EXTERN_C void staticperl_cleanup (void);
414			EOF
415			}
416
417			print "\n";
418
419			#############################################################################
420			# output
421
422			print "generating $PREFIX.c... ";
423
424			open my $fh, ">", "$PREFIX.c"
425			or die "$PREFIX.c: $!\n";
426
427			print $fh <<EOF;
428			/* do not edit, automatically created by mkstaticbundle */
429
430			#include <EXTERN.h>
431			#include <perl.h>
432			#include <XSUB.h>
433
434			#include "bundle.h"
435
436			/* public API */
437			PerlInterpreter *staticperl;
438
439			EOF
440
441			#############################################################################
442			# bundle data
443
444			my $count = @index;
445
446			print $fh <<EOF;
447			#include "bundle.h"
448
449			/* bundle data */
450
451			static const U32 $varpfx\_count = $count;
452			static const U32 $varpfx\_index [$count + 1] = {
453			EOF
454
455			my $col;
456			for (@index) {
457			printf $fh "0x%08x,", $_;
458			print $fh "\n" unless ++$col % 10;
459
460			}
461			printf $fh "0x%08x\n};\n", (length $data);
462
463			print $fh "static const char $varpfx\_data [] =\n";
464			dump_string $fh, $data;
465
466			print $fh ";\n\n";;
467
468			#############################################################################
469			# bootstrap
470
471			# boot file for staticperl
472			# this file will be eval'ed at initialisation time
473
474			my $bootstrap = '
475			BEGIN {
476			package ' . $PACKAGE . ';
477
478			PerlIO::scalar->bootstrap;
479
480			@INC = sub {
481			my $data = find "$_[1]"
482			or return;
483
484			$INC{$_[1]} = $_[1];
485
486			open my $fh, "<", \$data;
487			$fh
488			};
489			}
490			';
491
492			$bootstrap .= "require '//boot';"
493			if exists $pm{"//boot"};
494
495			$bootstrap =~ s/\s+/ /g;
496			$bootstrap =~ s/(\W) /$1/g;
497			$bootstrap =~ s/ (\W)/$1/g;
498
499			print $fh "const char bootstrap [] = ";
500			dump_string $fh, $bootstrap;
501			print $fh ";\n\n";
502
503			print $fh <<EOF;
504			/* search all bundles for the given file, using binary search */
505			XS(find)
506			{
507			dXSARGS;
508
509			if (items != 1)
510			Perl_croak (aTHX_ "Usage: $PACKAGE\::find (\$path)");
511
512			{
513			STRLEN namelen;
514			char *name = SvPV (ST (0), namelen);
515			SV *res = 0;
516
517			int l = 0, r = $varpfx\_count;
518
519			while (l <= r)
520			{
521			int m = (l + r) >> 1;
522			U32 idx = $varpfx\_index [m];
523			int comp = namelen - (idx >> 25);
524
525			if (!comp)
526			{
527			int ofs = idx & 0x1FFFFFFU;
528			comp = memcmp (name, $varpfx\_data + ofs, namelen);
529
530			if (!comp)
531			{
532			/* found */
533			int ofs2 = $varpfx\_index [m + 1] & 0x1FFFFFFU;
534
535			ofs += namelen;
536			res = newSVpvn ($varpfx\_data + ofs, ofs2 - ofs);
537			goto found;
538			}
539			}
540
541			if (comp < 0)
542			r = m - 1;
543			else
544			l = m + 1;
545			}
546
547			XSRETURN (0);
548
549			found:
550			ST (0) = res;
551			sv_2mortal (ST (0));
552			}
553
554			XSRETURN (1);
555			}
556
557			/* list all files in the bundle */
558			XS(list)
559			{
560			dXSARGS;
561
562			if (items != 0)
563			Perl_croak (aTHX_ "Usage: $PACKAGE\::list");
564
565			{
566			int i;
567
568			EXTEND (SP, $varpfx\_count);
569
570			for (i = 0; i < $varpfx\_count; ++i)
571			{
572			U32 idx = $varpfx\_index [i];
573
574			PUSHs (newSVpvn ($varpfx\_data + (idx & 0x1FFFFFFU), idx >> 25));
575			}
576			}
577
578			XSRETURN ($varpfx\_count);
579			}
580
581			static char *args[] = {
582			"staticperl",
583			"-e",
584			"0"
585			};
586
587			EOF
588
589			#############################################################################
590			# xs_init
591
592			print $fh <<EOF;
593			static void
594			xs_init (pTHX)
595			{
596			EOF
597
598			@static_ext = ("DynaLoader", sort @static_ext);
599
600			# prototypes
601			for (@static_ext) {
602			s/\.pm$//;
603			(my $cname = $_) =~ s/\//__/g;
604			print $fh " EXTERN_C void boot_$cname (pTHX_ CV* cv);\n";
605			}
606
607			print $fh <<EOF;
608			char *file = __FILE__;
609			dXSUB_SYS;
610
611			newXSproto ("$PACKAGE\::find", find, file, "\$");
612			newXSproto ("$PACKAGE\::list", list, file, "");
613			EOF
614
615			# calls
616			for (@static_ext) {
617			s/\.pm$//;
618
619			(my $cname = $_) =~ s/\//__/g;
620			(my $pname = $_) =~ s/\//::/g;
621
622			my $bootstrap = $pname eq "DynaLoader" ? "boot" : "bootstrap";
623
624			print $fh " newXS (\"$pname\::$bootstrap\", boot_$cname, file);\n";
625			}
626
627			print $fh <<EOF;
628			Perl_av_create_and_unshift_one (&PL_preambleav, newSVpv (bootstrap, sizeof (bootstrap) - 1));
629			}
630			EOF
631
632			#############################################################################
633			# optional perl_init/perl_destroy
634
635			if ($PERL) {
636			print $fh <<EOF;
637
638			int
639			main (int argc, char *argv [])
640			{
641			extern char **environ;
642			int exitstatus;
643
644			PERL_SYS_INIT3 (&argc, &argv, &environ);
645			staticperl = perl_alloc ();
646			perl_construct (staticperl);
647
648			PL_exit_flags \|= PERL_EXIT_DESTRUCT_END;
649
650			exitstatus = perl_parse (staticperl, xs_init, argc, argv, environ);
651			if (!exitstatus)
652			perl_run (staticperl);
653
654			exitstatus = perl_destruct (staticperl);
655			perl_free (staticperl);
656			PERL_SYS_TERM ();
657
658			return exitstatus;
659			}
660			EOF
661			} else {
662			print $fh <<EOF;
663
664			EXTERN_C void
665			staticperl_init (void)
666			{
667			extern char **environ;
668			int argc = sizeof (args) / sizeof (args [0]);
669			char **argv = args;
670
671			PERL_SYS_INIT3 (&argc, &argv, &environ);
672			staticperl = perl_alloc ();
673			perl_construct (staticperl);
674			PL_origalen = 1;
675			PL_exit_flags \|= PERL_EXIT_DESTRUCT_END;
676			perl_parse (staticperl, xs_init, argc, argv, environ);
677
678			perl_run (staticperl);
679			}
680
681			EXTERN_C void
682			staticperl_cleanup (void)
683			{
684			perl_destruct (staticperl);
685			perl_free (staticperl);
686			staticperl = 0;
687			PERL_SYS_TERM ();
688			}
689			EOF
690			}
691
692			print -s "$PREFIX.c", " octets (", (length $data) , " data octets).\n\n";
693
694			#############################################################################
695			# libs, cflags
696
697			{
698			print "generating $PREFIX.ccopts... ";
699
700			my $str = "$Config{ccflags} $Config{optimize} $Config{cppflags} -I$Config{archlibexp}/CORE";
701			$str =~ s/([\(\)])/\\$1/g;
702
703			print "$str\n\n";
704
705			open my $fh, ">$PREFIX.ccopts"
706			or die "$PREFIX.ccopts: $!";
707			print $fh $str;
708			}
709
710			{
711			print "generating $PREFIX.ldopts... ";
712
713			my $str = $STATIC ? "--static " : "";
714
715			$str .= "$Config{ccdlflags} $Config{ldflags} @libs $Config{archlibexp}/CORE/$Config{libperl} $Config{perllibs}";
716
717			my %seen;
718			$str .= " $_" for grep !$seen{$_}++, ($extralibs =~ /(\S+)/g);
719
720			$str =~ s/([\(\)])/\\$1/g;
721
722			print "$str\n\n";
723
724			open my $fh, ">$PREFIX.ldopts"
725			or die "$PREFIX.ldopts: $!";
726			print $fh $str;
727			}
728
729			if ($PERL) {
730			system "$Config{cc} \$(cat bundle.ccopts\) -o perl bundle.c \$(cat bundle.ldopts\)";
731
732			unlink "$PREFIX.$_"
733			for qw(ccopts ldopts c h);
734			}
735