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

#!/opt/bin/perl

#############################################################################
# cannot load modules till after the tracer BEGIN block

our $VERBOSE  = 1;
our $STRIP    = "pod"; # none, pod or ppi
our $PERL     = 0;
our $VERIFY   = 0;
our $STATIC   = 0;

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

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

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

$|=1;

our ($TRACER_W, $TRACER_R);

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

   undef
}

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

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

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

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

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

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

         $fh
      };

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

      exit 0;
   }
}

# module loading is now safe
use Config;

sub scan_al {
   my ($auto, $autodir, $ix) = @_;

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

   open my $fh, "<", "$autodir/$ix"
      or die "$autodir/$ix: $!";

   my $package;

   while (<$fh>) {
      if (/^\s*sub\s+([^[:space:];]+)\s*;?\s*$/) {
         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;
}

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

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

      if ($cmd eq "strip") {
         $STRIP = $args;
      } elsif ($cmd eq "eval") {
         trace_eval $_;
      } elsif ($cmd eq "use") {
         trace_module $_
            for split / /, $args;
      } elsif ($cmd eq "boot") {
         cmd_boot $args;
      } elsif ($cmd eq "static") {
         $STATIC = 1;
      } elsif ($cmd eq "add") {
         cmd_add $args;
      } elsif (/^\s*#/) {
         # comment
      } elsif (/\S/) {
         die "$_: unsupported directive\n";
      }
   }
}

use Getopt::Long;

Getopt::Long::Configure ("bundling", "no_auto_abbrev", "no_ignore_case");

GetOptions
   "strip=s"   => \$STRIP,
   "verbose|v" => sub { ++$VERBOSE },
   "quiet|q"   => sub { --$VERBOSE },
   "perl"      => \$PERL,
   "eval|e=s"  => sub { trace_eval   $_[1] },
   "use|M=s"   => sub { trace_module $_[1] },
   "boot=s"    => sub { cmd_boot     $_[1] },
   "add=s"     => sub { cmd_add      $_[1] },
   "static"    => sub { $STATIC = 1 },
   "<>"        => sub { cmd_file     $_[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>
           };

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