[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 $APP;
our $VERIFY   = 0;
our $STATIC   = 0;

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

my %pm;
my %pmbin;
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 scan_al {
   my ($auto, $autodir, $ix) = @_;

   $pm{"$auto/$ix"} = "$autodir/$ix";

   open my $fh, "<:perlio", "$autodir/$ix"
      or die "$autodir/$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/$al";

      } elsif (/^\s*package\s+([^[:space:];]+)\s*;?\s*$/) {
         ($package = $1) =~ s/::/\//g;
      } elsif (/^\s*(?:#|1?\s*;?\s*$)/) {
         # nop
      } else {
         warn "$autodir/$ix: unparsable line, please report: $_";
      }
   }
}

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
               scan_al $auto, $autodir, $_
                  if /\.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;
            }
         }
      }
   }
}

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;
   $pmbin{$as} = 1 if $_[1];
}

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

die "cannot specify both --app and --perl\n"
   if $PERL and defined $APP;

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, "<", $path
                 or die "$path: $!";

              local $/;
              
              <$pm>
           };

   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;
            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)
            or die;
         $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_xs_init (pTHX);
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 "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);
}

EOF

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

print $fh <<EOF;
void
staticperl_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 ($APP) {
   print $fh <<EOF;

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

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

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

  PL_exit_flags |= PERL_EXIT_DESTRUCT_END;

  exitstatus = perl_parse (staticperl, staticperl_xs_init, sizeof (args) / sizeof (*args), args, environ);
  if (!exitstatus)
    perl_run (staticperl);

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

  return exitstatus;
}
EOF
} elsif ($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, 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;

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

  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, 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 or defined $APP) {
   $APP = "perl" unless defined $APP;

   print "generating $APP...\n";

   system "$Config{cc} \$(cat bundle.ccopts\) -o \Q$APP\E bundle.c \$(cat bundle.ldopts\)";

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

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