[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;
my @staticlibs;
my @incext;

@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_staticlib {
   push @staticlibs, $_
      for split /\s+/, $_[0];
}

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 "staticlib") {
         cmd_staticlib $args;
      } elsif ($cmd eq "boot") {
         cmd_boot $args;
      } elsif ($cmd eq "static") {
         $STATIC = 1;
      } elsif ($cmd eq "add") {
         cmd_add $args, 0;
      } elsif ($cmd eq "addbin") {
         cmd_add $args, 1;
      } elsif (/^\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 },
   "staticlib=s" => sub { cmd_staticlib $_[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);

   for (@staticlibs) {
      $str =~ s/(^|\s) (-l\Q$_\E) ($|\s)/$1-Wl,-Bstatic $2 -Wl,-Bdynamic$3/gx;
   }

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