--- cvsroot/App-Staticperl/mkbundle	2011/02/09 09:52:27	1.17
+++ cvsroot/App-Staticperl/mkbundle	2014/01/17 18:06:43	1.35
@@ -3,14 +3,17 @@
 #############################################################################
 # cannot load modules till after the tracer BEGIN block
 
-our $VERBOSE  = 1;
-our $STRIP    = "pod"; # none, pod or ppi
-our $UNISTRIP = 1; # always on, try to strip unicore swash data
-our $PERL     = 0;
+our $VERBOSE       = 1;
+our $STRIP         = "pod"; # none, pod or ppi
+our $UNISTRIP      = 1; # always on, try to strip unicore swash data
+our $PERL          = 0;
 our $APP;
-our $VERIFY   = 0;
-our $STATIC   = 0;
-our $PACKLIST = 0;
+our $VERIFY        = 0;
+our $STATIC        = 0;
+our $PACKLIST      = 0;
+our $IGNORE_ENV    = 0;
+our $ALLOW_DYNAMIC = 0;
+our $HAVE_DYNAMIC; # maybe useful?
 
 our $OPTIMISE_SIZE = 0; # optimise for raw file size instead of for compression?
 
@@ -75,7 +78,7 @@
 
          syswrite $W_TRACER, "-\n$dir\n$_[1]\n";
 
-         open my $fh, "<:perlio", "$dir/$_[1]"
+         open my $fh, "<:raw:perlio", "$dir/$_[1]"
             or warn "ERROR: $dir/$_[1]: $!\n";
 
          $fh
@@ -84,10 +87,17 @@
       while (<$R_TRACER>) {
          if (/use (.*)$/) {
             my $mod = $1;
-            my $pkg = ++$pkg;
-            my $eval = $mod = $mod =~ /[^A-Za-z0-9_:]/
-                       ? "require $mod"
-                       : "{ package $pkg; use $mod; }";
+            my $eval;
+
+            if ($mod =~ /^'.*'$/ or $mod =~ /^".*"$/) {
+               $eval = "require $mod";
+            } elsif ($mod =~ y%/.%%) {
+               $eval = "require q\x00$mod\x00";
+            } else {
+               my $pkg = ++$pkg;
+               $eval = "{ package $pkg; use $mod; }";
+            }
+
             eval $eval;
             warn "ERROR: $@ (while loading '$mod')\n"
                if $@;
@@ -154,7 +164,7 @@
    if (length $CACHE and 2048 <= length $src and defined $variant) {
       my $file = "$CACHE/" . Digest::MD5::md5_hex "$CACHEVER\x00$variant\x00$src";
 
-      if (open my $fh, "<:perlio", $file) {
+      if (open my $fh, "<:raw:perlio", $file) {
          print "using cache for $file\n"
             if $VERBOSE >= 7;
 
@@ -167,7 +177,7 @@
       print "creating cache entry $file\n"
          if $VERBOSE >= 8;
 
-      if (open my $fh, ">:perlio", "$file~") {
+      if (open my $fh, ">:raw:perlio", "$file~") {
          if ((syswrite $fh, $src) == length $src) {
             close $fh;
             rename "$file~", $file;
@@ -184,14 +194,28 @@
    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";
+      if ($^O eq "MSWin32") {
+         # 16 bit system, strings can't be longer than 64k. seriously.
+         print $fh "{\n";
+         for (
+            my $ofs = 0;
+            length (my $substr = substr $data, $ofs, 20);
+            $ofs += 20
+         )  {
+            $substr = join ",", map ord, split //, $substr;
+            print $fh "  $substr,\n";
+         }
+         print $fh "   0 }\n";
+      } else {
+         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";
@@ -268,15 +292,15 @@
 #############################################################################
 
 sub cmd_boot {
-   $pm{"//boot"} = $_[0];
+   $pm{"!boot"} = $_[0];
 }
 
 sub cmd_add {
-   $_[0] =~ /^(.*)(?:\s+(\S+))$/
+   $_[0] =~ /^(.*?)(?:\s+(\S+))?$/
       or die "$_[0]: cannot parse";
 
    my $file = $1;
-   my $as   = defined $2 ? $2 : "/$1";
+   my $as   = defined $2 ? $2 : $1;
 
    $pm{$as} = $file;
    $pmbin{$as} = 1 if $_[1];
@@ -331,12 +355,14 @@
 
 sub parse_argv {
    GetOptions
-      "strip=s"       => \$STRIP,
-      "cache=s"       => \$CACHE, # internal option
-      "verbose|v"     => sub { ++$VERBOSE },
-      "quiet|q"       => sub { --$VERBOSE },
       "perl"          => \$PERL,
       "app=s"         => \$APP,
+
+      "verbose|v"     => sub { ++$VERBOSE },
+      "quiet|q"       => sub { --$VERBOSE },
+
+      "strip=s"       => \$STRIP,
+      "cache=s"       => \$CACHE, # internal option
       "eval|e=s"      => sub { trace_eval    $_[1] },
       "use|M=s"       => sub { trace_module  $_[1] },
       "boot=s"        => sub { cmd_boot      $_[1] },
@@ -345,9 +371,13 @@
       "incglob=s"     => sub { cmd_incglob   $_[1] },
       "include|i=s"   => sub { cmd_include   $_[1], 1 },
       "exclude|x=s"   => sub { cmd_include   $_[1], 0 },
-      "static!"       => \$STATIC,
       "usepacklists!" => \$PACKLIST,
+
+      "static!"       => \$STATIC,
       "staticlib=s"   => sub { cmd_staticlib $_[1] },
+      "allow-dynamic!"=> \$ALLOW_DYNAMIC,
+      "ignore-env"    => \$IGNORE_ENV,
+
       "<>"            => sub { cmd_file      $_[0] },
       or exit 1;
 }
@@ -464,8 +494,20 @@
          }
 
          # dynamic object
-         die "ERROR: found shared object - can't link statically ($_)\n"
-            if -f "$autodir/$base.$Config{dlext}";
+         if (-f "$autodir/$base.$Config{dlext}") {
+            if ($ALLOW_DYNAMIC) {
+               my $as = "!$auto/$base.$Config{dlext}";
+               $pm{$as} = "$autodir/$base.$Config{dlext}";
+               $pmbin{$as} = 1;
+
+               $HAVE_DYNAMIC = 1;
+
+               print "+ added dynamic object $as\n"
+                  if $VERBOSE >= 3;
+            } else {
+               die "ERROR: found shared object '$autodir/$base.$Config{dlext}' but --allow-dynamic not given, aborting.\n"
+            }
+         }
 
          if ($PACKLIST && open my $fh, "<:perlio", "$autodir/.packlist") {
             print "found .packlist for $pm\n"
@@ -523,7 +565,7 @@
    my $src = ref $path
            ? $$path
            : do {
-              open my $pm, "<", $path
+              open my $pm, "<:raw:perlio", $path
                  or die "$path: $!";
 
               local $/;
@@ -709,7 +751,7 @@
 length $data < 2**25
    or die "ERROR: bundle too large (only 32MB supported)\n";
 
-my $varpfx = "bundle_" . substr +(Digest::MD5::md5_hex $data), 0, 16;
+my $varpfx = "bundle";
 
 #############################################################################
 # output
@@ -722,7 +764,7 @@
       or die "$PREFIX.h: $!\n";
 
    print $fh <<EOF;
-/* do not edit, automatically created by mkstaticbundle */
+/* do not edit, automatically created by staticperl */
 
 #include <EXTERN.h>
 #include <perl.h>
@@ -731,7 +773,7 @@
 /* public API */
 EXTERN_C PerlInterpreter *staticperl;
 EXTERN_C void staticperl_xs_init (pTHX);
-EXTERN_C void staticperl_init (void);
+EXTERN_C void staticperl_init (XSINIT_t xs_init); /* argument can be 0 */
 EXTERN_C void staticperl_cleanup (void);
 
 EOF
@@ -750,7 +792,7 @@
    or die "$PREFIX.c: $!\n";
 
 print $fh <<EOF;
-/* do not edit, automatically created by mkstaticbundle */
+/* do not edit, automatically created by staticperl */
 
 #include "bundle.h"
 
@@ -792,27 +834,66 @@
 # boot file for staticperl
 # this file will be eval'ed at initialisation time
 
+# lines marked with "^D" are only used when $HAVE_DYNAMIC
 my $bootstrap = '
 BEGIN {
    package ' . $PACKAGE . ';
 
-   PerlIO::scalar->bootstrap;
+   # the path prefix to use when putting files into %INC
+   our $inc_prefix;
 
-   @INC = sub {
+   # the @INC hook to use when we have PerlIO::scalar available
+   my $perlio_inc =  sub {
       my $data = find "$_[1]"
          or return;
 
-      $INC{$_[1]} = $_[1];
+      $INC{$_[1]} = "$inc_prefix$_[1]";
 
       open my $fh, "<", \$data;
       $fh
    };
+
+D  if (defined &PerlIO::scalar::bootstrap) {
+      # PerlIO::scalar statically compiled in
+      PerlIO::scalar->bootstrap;
+      @INC = $perlio_inc;
+D  } else {
+D     # PerlIO::scalar not available, use slower method
+D     @INC = sub {
+D        # always check if PerlIO::scalar might now be available
+D        if (defined &PerlIO::scalar::bootstrap) {
+D           # switch to the faster perlio_inc hook
+D           @INC = map { $_ == $_[0] ? $perlio_inc : $_ } @INC;
+D           goto &$perlio_inc;
+D        }
+D
+D        my $data = find "$_[1]"
+D           or return;
+D
+D        $INC{$_[1]} = "$inc_prefix$_[1]";
+D
+D        sub {
+D           $data =~ /\G([^\n]*\n?)/g
+D              or return;
+D
+D           $_ = $1;
+D           1
+D        }
+D     };
+D  }
 }
 ';
 
-$bootstrap .= "require '//boot';"
-   if exists $pm{"//boot"};
+$bootstrap .= "require '!boot';"
+   if exists $pm{"!boot"};
 
+if ($HAVE_DYNAMIC) {
+   $bootstrap =~ s/^D/ /mg;
+} else {
+   $bootstrap =~ s/^D.*$//mg;
+}
+
+$bootstrap =~ s/#.*$//mg;
 $bootstrap =~ s/\s+/ /g;
 $bootstrap =~ s/(\W) /$1/g;
 $bootstrap =~ s/ (\W)/$1/g;
@@ -868,8 +949,7 @@
     XSRETURN (0);
 
   found:
-    ST (0) = res;
-    sv_2mortal (ST (0));
+    ST (0) = sv_2mortal (res);
   }
 
   XSRETURN (1);
@@ -892,13 +972,17 @@
       {
         U32 idx = $varpfx\_index [i];
 
-        PUSHs (newSVpvn ($varpfx\_data + (idx & 0x1FFFFFFU), idx >> 25));
+        PUSHs (sv_2mortal (newSVpvn ($varpfx\_data + (idx & 0x1FFFFFFU), idx >> 25)));
       }
   }
 
   XSRETURN ($varpfx\_count);
 }
 
+#ifdef STATICPERL_BUNDLE_INCLUDE
+#include STATICPERL_BUNDLE_INCLUDE
+#endif
+
 EOF
 
 #############################################################################
@@ -910,7 +994,7 @@
 {
 EOF
 
-@static_ext = ("DynaLoader", sort @static_ext);
+@static_ext = sort @static_ext;
 
 # prototypes
 for (@static_ext) {
@@ -925,6 +1009,10 @@
 
   newXSproto ("$PACKAGE\::find", find, file, "\$");
   newXSproto ("$PACKAGE\::list", list, file, "");
+
+  #ifdef STATICPERL_BUNDLE_XS_INIT
+  STATICPERL_BUNDLE_XS_INIT;
+  #endif
 EOF
 
 # calls
@@ -934,19 +1022,48 @@
    (my $cname = $_) =~ s/\//__/g;
    (my $pname = $_) =~ s/\//::/g;
 
-   my $bootstrap = $pname eq "DynaLoader" ? "boot" : "bootstrap";
+   my $bootstrap = $pname eq "DynaLoader" ? "boot_DynaLoader" : "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));
+  #ifdef _WIN32
+    /* windows perls usually trail behind unix perls 8-10 years in exporting symbols */
+
+    if (!PL_preambleav)
+      PL_preambleav = newAV ();
+
+    av_unshift (PL_preambleav, 1);
+    av_store (PL_preambleav, 0, newSVpv (bootstrap, sizeof (bootstrap) - 1));
+  #else
+    Perl_av_create_and_unshift_one (&PL_preambleav, newSVpv (bootstrap, sizeof (bootstrap) - 1));
+  #endif
+
+  if (PL_oldname)
+    ((XSINIT_t)PL_oldname)(aTHX);
 }
 EOF
 
 #############################################################################
 # optional perl_init/perl_destroy
 
+if ($IGNORE_ENV) {
+   $IGNORE_ENV = <<EOF;
+  unsetenv ("PERL_UNICODE");
+  unsetenv ("PERL_HASH_SEED_DEBUG");
+  unsetenv ("PERL_DESTRUCT_LEVEL");
+  unsetenv ("PERL_SIGNALS");
+  unsetenv ("PERL_DEBUG_MSTATS");
+  unsetenv ("PERL5OPT");
+  unsetenv ("PERLIO_DEBUG");
+  unsetenv ("PERLIO");
+  unsetenv ("PERL_HASH_SEED");
+EOF
+} else {
+   $IGNORE_ENV = "";
+}
+
 if ($APP) {
    print $fh <<EOF;
 
@@ -965,6 +1082,7 @@
   for (i = 1; i < argc; ++i)
     args [i + 3] = argv [i];
 
+$IGNORE_ENV
   PERL_SYS_INIT3 (&argc, &argv, &environ);
   staticperl = perl_alloc ();
   perl_construct (staticperl);
@@ -992,6 +1110,7 @@
   extern char **environ;
   int exitstatus;
 
+$IGNORE_ENV
   PERL_SYS_INIT3 (&argc, &argv, &environ);
   staticperl = perl_alloc ();
   perl_construct (staticperl);
@@ -1013,7 +1132,7 @@
    print $fh <<EOF;
 
 EXTERN_C void
-staticperl_init (void)
+staticperl_init (XSINIT_t xs_init)
 {
   static char *args[] = {
     "staticperl",
@@ -1025,11 +1144,13 @@
   int argc = sizeof (args) / sizeof (args [0]);
   char **argv = args;
 
+$IGNORE_ENV
   PERL_SYS_INIT3 (&argc, &argv, &environ);
   staticperl = perl_alloc ();
   perl_construct (staticperl);
   PL_origalen = 1;
   PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
+  PL_oldname = (char *)xs_init;
   perl_parse (staticperl, staticperl_xs_init, argc, argv, environ);
 
   perl_run (staticperl);
@@ -1046,58 +1167,69 @@
 EOF
 }
 
+close $fh;
+
 print -s "$PREFIX.c", " octets (", (length $data) , " data octets).\n\n"
    if $VERBOSE >= 1;
 
 #############################################################################
 # libs, cflags
 
+my $ccopts;
+
 {
    print "generating $PREFIX.ccopts... "
       if $VERBOSE >= 1;
 
-   my $str = "$Config{ccflags} $Config{optimize} $Config{cppflags} -I$Config{archlibexp}/CORE";
-   $str =~ s/([\(\)])/\\$1/g;
+   $ccopts = "$Config{ccflags} $Config{optimize} $Config{cppflags} -I$Config{archlibexp}/CORE";
+   $ccopts =~ s/([\(\)])/\\$1/g;
 
    open my $fh, ">$PREFIX.ccopts"
       or die "$PREFIX.ccopts: $!";
-   print $fh $str;
+   print $fh $ccopts;
 
-   print "$str\n\n"
+   print "$ccopts\n\n"
       if $VERBOSE >= 1;
 }
 
+my $ldopts;
+
 {
    print "generating $PREFIX.ldopts... ";
 
-   my $str = $STATIC ? "-static " : "";
+   $ldopts = $STATIC ? "-static " : "";
 
-   $str .= "$Config{ccdlflags} $Config{ldflags} @libs $Config{archlibexp}/CORE/$Config{libperl} $Config{perllibs}";
+   $ldopts .= "$Config{ccdlflags} $Config{ldflags} @libs $Config{archlibexp}/CORE/$Config{libperl} $Config{perllibs}";
 
    my %seen;
-   $str .= " $_" for grep !$seen{$_}++, ($extralibs =~ /(\S+)/g);
+   $ldopts .= " $_" for reverse grep !$seen{$_}++, reverse +($extralibs =~ /(\S+)/g);
 
    for (@staticlibs) {
-      $str =~ s/(^|\s) (-l\Q$_\E) ($|\s)/$1-Wl,-Bstatic $2 -Wl,-Bdynamic$3/gx;
+      $ldopts =~ s/(^|\s) (-l\Q$_\E) ($|\s)/$1-Wl,-Bstatic $2 -Wl,-Bdynamic$3/gx;
    }
 
-   $str =~ s/([\(\)])/\\$1/g;
+   $ldopts =~ s/([\(\)])/\\$1/g;
 
    open my $fh, ">$PREFIX.ldopts"
       or die "$PREFIX.ldopts: $!";
-   print $fh $str;
+   print $fh $ldopts;
 
-   print "$str\n\n"
+   print "$ldopts\n\n"
       if $VERBOSE >= 1;
 }
 
 if ($PERL or defined $APP) {
    $APP = "perl" unless defined $APP;
 
-   print "building $APP...\n"
+   my $build = "$Config{cc} $ccopts -o \Q$APP\E$Config{_exe} bundle.c $ldopts";
+
+   print "build $APP...\n"
       if $VERBOSE >= 1;
 
-   system "$Config{cc} \$(cat bundle.ccopts\) -o \Q$APP\E bundle.c \$(cat bundle.ldopts\)";
+   print "$build\n"
+      if $VERBOSE >= 2;
+
+   system $build;
 
    unlink "$PREFIX.$_"
       for qw(ccopts ldopts c h);