[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 %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 "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,
   "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;

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

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

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

  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) {
   system "$Config{cc} \$(cat bundle.ccopts\) -o perl bundle.c \$(cat bundle.ldopts\)";

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

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