ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/App-Staticperl/mkbundle
(Generate patch)

Comparing App-Staticperl/mkbundle (file contents):
Revision 1.17 by root, Wed Feb 9 09:52:27 2011 UTC vs.
Revision 1.41 by root, Fri Aug 4 03:14:33 2023 UTC

1#!/opt/bin/perl 1#!/opt/bin/perl
2 2
3############################################################################# 3#############################################################################
4# cannot load modules till after the tracer BEGIN block 4# cannot load modules till after the tracer BEGIN block
5 5
6our $VERBOSE = 1; 6our $VERBOSE = 1;
7our $STRIP = "pod"; # none, pod or ppi 7our $STRIP = "pod"; # none, pod or ppi
8our $COMPRESS = "lzf";
8our $UNISTRIP = 1; # always on, try to strip unicore swash data 9our $UNISTRIP = 1; # always on, try to strip unicore swash data
9our $PERL = 0; 10our $PERL = 0;
10our $APP; 11our $APP;
11our $VERIFY = 0; 12our $VERIFY = 0;
12our $STATIC = 0; 13our $STATIC = 0;
13our $PACKLIST = 0; 14our $PACKLIST = 0;
15our $IGNORE_ENV = 0;
16our $ALLOW_DYNAMIC = 0;
17our $HAVE_DYNAMIC; # maybe useful?
18our $EXTRA_CFLAGS = "";
19our $EXTRA_LDFLAGS = "";
20our $EXTRA_LIBS = "";
14 21
15our $OPTIMISE_SIZE = 0; # optimise for raw file size instead of for compression? 22our $OPTIMISE_SIZE = 0; # optimise for raw file size instead of for compression?
16 23
17our $CACHE; 24our $CACHE;
18our $CACHEVER = 1; # do not change unless you know what you are doing 25our $CACHEVER = 2; # do not change unless you know what you are doing
19 26
20my $PREFIX = "bundle"; 27my $PREFIX = "bundle";
21my $PACKAGE = "static"; 28my $PACKAGE = "static";
22 29
23my %pm; 30my %pm;
… …
73 my $dir = find_incdir $_[1] 80 my $dir = find_incdir $_[1]
74 or return; 81 or return;
75 82
76 syswrite $W_TRACER, "-\n$dir\n$_[1]\n"; 83 syswrite $W_TRACER, "-\n$dir\n$_[1]\n";
77 84
78 open my $fh, "<:perlio", "$dir/$_[1]" 85 open my $fh, "<:raw:perlio", "$dir/$_[1]"
79 or warn "ERROR: $dir/$_[1]: $!\n"; 86 or warn "ERROR: $dir/$_[1]: $!\n";
80 87
81 $fh 88 $fh
82 }; 89 };
83 90
84 while (<$R_TRACER>) { 91 while (<$R_TRACER>) {
85 if (/use (.*)$/) { 92 if (/use (.*)$/) {
86 my $mod = $1; 93 my $mod = $1;
94 my $eval;
95
96 if ($mod =~ /^'.*'$/ or $mod =~ /^".*"$/) {
97 $eval = "require $mod";
98 } elsif ($mod =~ y%/.%%) {
99 $eval = "require q\x00$mod\x00";
100 } else {
87 my $pkg = ++$pkg; 101 my $pkg = ++$pkg;
88 my $eval = $mod = $mod =~ /[^A-Za-z0-9_:]/
89 ? "require $mod"
90 : "{ package $pkg; use $mod; }"; 102 $eval = "{ package $pkg; use $mod; }";
103 }
104
91 eval $eval; 105 eval $eval;
92 warn "ERROR: $@ (while loading '$mod')\n" 106 warn "ERROR: $@ (while loading '$mod')\n"
93 if $@; 107 if $@;
94 } elsif (/eval (.*)$/) { 108 } elsif (/eval (.*)$/) {
95 my $eval = $1; 109 my $eval = $1;
… …
152 my ($variant, $src, $filter) = @_; 166 my ($variant, $src, $filter) = @_;
153 167
154 if (length $CACHE and 2048 <= length $src and defined $variant) { 168 if (length $CACHE and 2048 <= length $src and defined $variant) {
155 my $file = "$CACHE/" . Digest::MD5::md5_hex "$CACHEVER\x00$variant\x00$src"; 169 my $file = "$CACHE/" . Digest::MD5::md5_hex "$CACHEVER\x00$variant\x00$src";
156 170
157 if (open my $fh, "<:perlio", $file) { 171 if (open my $fh, "<:raw:perlio", $file) {
158 print "using cache for $file\n" 172 print "using cache for $file\n"
159 if $VERBOSE >= 7; 173 if $VERBOSE >= 7;
160 174
161 local $/; 175 local $/;
162 return <$fh>; 176 return <$fh>;
… …
165 $src = $filter->($src); 179 $src = $filter->($src);
166 180
167 print "creating cache entry $file\n" 181 print "creating cache entry $file\n"
168 if $VERBOSE >= 8; 182 if $VERBOSE >= 8;
169 183
170 if (open my $fh, ">:perlio", "$file~") { 184 if (open my $fh, ">:raw:perlio", "$file~") {
171 if ((syswrite $fh, $src) == length $src) { 185 if ((syswrite $fh, $src) == length $src) {
172 close $fh; 186 close $fh;
173 rename "$file~", $file; 187 rename "$file~", $file;
174 } 188 }
175 } 189 }
… …
182 196
183sub dump_string { 197sub dump_string {
184 my ($fh, $data) = @_; 198 my ($fh, $data) = @_;
185 199
186 if (length $data) { 200 if (length $data) {
201 if ($^O eq "MSWin32") {
202 # 16 bit system, strings can't be longer than 64k. seriously.
203 print $fh "{\n";
187 for ( 204 for (
188 my $ofs = 0; 205 my $ofs = 0;
206 length (my $substr = substr $data, $ofs, 20);
207 $ofs += 20
208 ) {
209 $substr = join ",", map ord, split //, $substr;
210 print $fh " $substr,\n";
211 }
212 print $fh " 0 }\n";
213 } else {
214 for (
215 my $ofs = 0;
189 length (my $substr = substr $data, $ofs, 80); 216 length (my $substr = substr $data, $ofs, 80);
190 $ofs += 80 217 $ofs += 80
191 ) { 218 ) {
192 $substr =~ s/([^\x20-\x21\x23-\x5b\x5d-\x7e])/sprintf "\\%03o", ord $1/ge; 219 $substr =~ s/([^\x20-\x21\x23-\x5b\x5d-\x7e])/sprintf "\\%03o", ord $1/ge;
193 $substr =~ s/\?/\\?/g; # trigraphs... 220 $substr =~ s/\?/\\?/g; # trigraphs...
194 print $fh " \"$substr\"\n"; 221 print $fh " \"$substr\"\n";
222 }
195 } 223 }
196 } else { 224 } else {
197 print $fh " \"\"\n"; 225 print $fh " \"\"\n";
198 } 226 }
199} 227}
… …
266} 294}
267 295
268############################################################################# 296#############################################################################
269 297
270sub cmd_boot { 298sub cmd_boot {
271 $pm{"//boot"} = $_[0]; 299 $pm{"!boot"} = $_[0];
272} 300}
273 301
274sub cmd_add { 302sub cmd_add {
275 $_[0] =~ /^(.*)(?:\s+(\S+))$/ 303 $_[0] =~ /^(.*?)(?:\s+(\S+))?$/
276 or die "$_[0]: cannot parse"; 304 or die "$_[0]: cannot parse";
277 305
278 my $file = $1; 306 my $file = $1;
279 my $as = defined $2 ? $2 : "/$1"; 307 my $as = defined $2 ? $2 : $1;
280 308
281 $pm{$as} = $file; 309 $pm{$as} = $file;
282 $pmbin{$as} = 1 if $_[1]; 310 $pmbin{$as} = 1 if $_[1];
283} 311}
284 312
… …
329 357
330use Getopt::Long; 358use Getopt::Long;
331 359
332sub parse_argv { 360sub parse_argv {
333 GetOptions 361 GetOptions
362 "perl" => \$PERL,
363 "app=s" => \$APP,
364
365 "verbose|v" => sub { ++$VERBOSE },
366 "quiet|q" => sub { --$VERBOSE },
367
334 "strip=s" => \$STRIP, 368 "strip=s" => \$STRIP,
369 "compress=s" => \$COMPRESS,
335 "cache=s" => \$CACHE, # internal option 370 "cache=s" => \$CACHE, # internal option
336 "verbose|v" => sub { ++$VERBOSE },
337 "quiet|q" => sub { --$VERBOSE },
338 "perl" => \$PERL,
339 "app=s" => \$APP,
340 "eval|e=s" => sub { trace_eval $_[1] }, 371 "eval|e=s" => sub { trace_eval $_[1] },
341 "use|M=s" => sub { trace_module $_[1] }, 372 "use|M=s" => sub { trace_module $_[1] },
342 "boot=s" => sub { cmd_boot $_[1] }, 373 "boot=s" => sub { cmd_boot $_[1] },
343 "add=s" => sub { cmd_add $_[1], 0 }, 374 "add=s" => sub { cmd_add $_[1], 0 },
344 "addbin=s" => sub { cmd_add $_[1], 1 }, 375 "addbin=s" => sub { cmd_add $_[1], 1 },
345 "incglob=s" => sub { cmd_incglob $_[1] }, 376 "incglob=s" => sub { cmd_incglob $_[1] },
346 "include|i=s" => sub { cmd_include $_[1], 1 }, 377 "include|i=s" => sub { cmd_include $_[1], 1 },
347 "exclude|x=s" => sub { cmd_include $_[1], 0 }, 378 "exclude|x=s" => sub { cmd_include $_[1], 0 },
348 "static!" => \$STATIC,
349 "usepacklists!" => \$PACKLIST, 379 "usepacklists!" => \$PACKLIST,
380
381 "static!" => \$STATIC,
350 "staticlib=s" => sub { cmd_staticlib $_[1] }, 382 "staticlib=s" => sub { cmd_staticlib $_[1] },
383 "allow-dynamic!" => \$ALLOW_DYNAMIC,
384 "ignore-env" => \$IGNORE_ENV,
385
386 "extra-cflags=s" => \$EXTRA_CFLAGS,
387 "extra-ldflags=s" => \$EXTRA_LDFLAGS,
388 "extra-libs=s" => \$EXTRA_LIBS,
389
351 "<>" => sub { cmd_file $_[0] }, 390 "<>" => sub { cmd_file $_[0] },
352 or exit 1; 391 or exit 1;
353} 392}
354 393
355Getopt::Long::Configure ("bundling", "no_auto_abbrev", "no_ignore_case"); 394Getopt::Long::Configure ("bundling", "no_auto_abbrev", "no_ignore_case");
356 395
357parse_argv; 396parse_argv;
358 397
359die "cannot specify both --app and --perl\n" 398die "cannot specify both --app and --perl\n"
360 if $PERL and defined $APP; 399 if $PERL and defined $APP;
400
401die "--compress must be either none or lzf\n"
402 unless $COMPRESS =~ /^(?:none|lzf)\z/;
361 403
362# required for @INC loading, unfortunately 404# required for @INC loading, unfortunately
363trace_module "PerlIO::scalar"; 405trace_module "PerlIO::scalar";
364 406
365############################################################################# 407#############################################################################
… …
462 push @libs, "$autodir/$base$Config{_a}"; 504 push @libs, "$autodir/$base$Config{_a}";
463 push @static_ext, $pm; 505 push @static_ext, $pm;
464 } 506 }
465 507
466 # dynamic object 508 # dynamic object
467 die "ERROR: found shared object - can't link statically ($_)\n"
468 if -f "$autodir/$base.$Config{dlext}"; 509 if (-f "$autodir/$base.$Config{dlext}") {
510 if ($ALLOW_DYNAMIC) {
511 my $as = "!$auto/$base.$Config{dlext}";
512 $pm{$as} = "$autodir/$base.$Config{dlext}";
513 $pmbin{$as} = 1;
514
515 $HAVE_DYNAMIC = 1;
516
517 print "+ added dynamic object $as\n"
518 if $VERBOSE >= 3;
519 } else {
520 die "ERROR: found shared object '$autodir/$base.$Config{dlext}' but --allow-dynamic not given, aborting.\n"
521 }
522 }
469 523
470 if ($PACKLIST && open my $fh, "<:perlio", "$autodir/.packlist") { 524 if ($PACKLIST && open my $fh, "<:perlio", "$autodir/.packlist") {
471 print "found .packlist for $pm\n" 525 print "found .packlist for $pm\n"
472 if $VERBOSE >= 3; 526 if $VERBOSE >= 3;
473 527
… …
501############################################################################# 555#############################################################################
502 556
503print "processing bundle files (try more -v power if you get bored waiting here)...\n" 557print "processing bundle files (try more -v power if you get bored waiting here)...\n"
504 if $VERBOSE >= 1; 558 if $VERBOSE >= 1;
505 559
560my $compress = sub { shift };
561
562if ($COMPRESS eq "lzf") {
563 require Compress::LZF;
564 $compress = sub { Compress::LZF::compress_best (shift) };
565}
566
506my $data; 567my $data;
507my @index; 568my @index;
508my @order = sort { 569my @order = sort {
509 length $a <=> length $b 570 length $a <=> length $b
510 or $a cmp $b 571 or $a cmp $b
… …
521 or die "ERROR: $pm: path too long (only 128 octets supported)\n"; 582 or die "ERROR: $pm: path too long (only 128 octets supported)\n";
522 583
523 my $src = ref $path 584 my $src = ref $path
524 ? $$path 585 ? $$path
525 : do { 586 : do {
526 open my $pm, "<", $path 587 open my $pm, "<:raw:perlio", $path
527 or die "$path: $!"; 588 or die "$path: $!";
528 589
529 local $/; 590 local $/;
530 591
531 <$pm> 592 <$pm>
… …
540 if $VERBOSE >= 3; 601 if $VERBOSE >= 3;
541 next; 602 next;
542 } 603 }
543 } 604 }
544 605
545 $src = cache +($STRIP eq "ppi" ? "$UNISTRIP,$OPTIMISE_SIZE" : undef), $src, sub { 606 $src = cache "$STRIP,$UNISTRIP,$OPTIMISE_SIZE,$COMPRESS", $src, sub {
546 if ($UNISTRIP && $pm =~ /^unicore\/.*\.pl$/) { 607 if ($UNISTRIP && $pm =~ /^unicore\/.*\.pl$/) {
547 print "applying unicore stripping $pm\n" 608 print "applying unicore stripping $pm\n"
548 if $VERBOSE >= 6; 609 if $VERBOSE >= 6;
549 610
550 # special stripping for unicore swashes and properties 611 # special stripping for unicore swashes and properties
… …
606 my $next = $ws->next_token; 667 my $next = $ws->next_token;
607 668
608 if (!$prev || !$next) { 669 if (!$prev || !$next) {
609 $ws->delete; 670 $ws->delete;
610 } else { 671 } else {
672 if ($next->isa (PPI::Token::Whitespace::)) {
673 $ws->delete;
611 if ( 674 } elsif (
612 $next->isa (PPI::Token::Operator::) && $next->{content} =~ /^(?:,|=|!|!=|==|=>)$/ # no ., because of digits. == float 675 $next->isa (PPI::Token::Operator::) && $next->{content} =~ /^(?:,|=|!|!=|==|=>)$/ # no ., because of digits. == float
613 or $prev->isa (PPI::Token::Operator::) && $prev->{content} =~ /^(?:,|=|\.|!|!=|==|=>)$/ 676 or $prev->isa (PPI::Token::Operator::) && $prev->{content} =~ /^(?:,|=|\.|!|!=|==|=>)$/
614 or $prev->isa (PPI::Token::Structure::) 677 or $prev->isa (PPI::Token::Structure::)
615 or ($OPTIMISE_SIZE && 678 or ($OPTIMISE_SIZE &&
616 ($prev->isa (PPI::Token::Word::) 679 ($prev->isa (PPI::Token::Word::)
… …
618 || $next->isa (PPI::Structure::Block::) 681 || $next->isa (PPI::Structure::Block::)
619 || $next->isa (PPI::Structure::List::) 682 || $next->isa (PPI::Structure::List::)
620 || $next->isa (PPI::Structure::Condition::))) 683 || $next->isa (PPI::Structure::Condition::)))
621 ) 684 )
622 ) { 685 ) {
686 # perl has some idiotic warnigns about nonexisting operators
687 if ($prev->isa (PPI::Token::Operator::) && $prev->{content} eq "="
688 && $next->isa (PPI::Token::Operator::) && $next->{content} =~ /[+\-]/
689 ) {
690 # avoid "Reverse %s operator" diagnostic
691 } else {
623 $ws->delete; 692 $ws->delete;
624 } elsif ($prev->isa (PPI::Token::Whitespace::)) {
625 $ws->{content} = ' ';
626 $prev->delete; 693 }
627 } else { 694 } else {
628 $ws->{content} = ' '; 695 $ws->{content} = ' ';
629 } 696 }
630 } 697 }
631 } 698 }
… …
688 eval "#line 1 \"$pm\"\n$src" or warn "\n\n\n$pm\n\n$src\n$@\n\n\n"; 755 eval "#line 1 \"$pm\"\n$src" or warn "\n\n\n$pm\n\n$src\n$@\n\n\n";
689 exit 0; 756 exit 0;
690 } 757 }
691 } 758 }
692 759
760 $src = $compress->($src);
761
693 $src 762 $src
694 }; 763 };
695 764
696# if ($pm eq "Opcode.pm") { 765# if ($pm eq "Opcode.pm") {
697# open my $fh, ">x" or die; print $fh $src;#d# 766# open my $fh, ">x" or die; print $fh $src;#d#
… …
707} 776}
708 777
709length $data < 2**25 778length $data < 2**25
710 or die "ERROR: bundle too large (only 32MB supported)\n"; 779 or die "ERROR: bundle too large (only 32MB supported)\n";
711 780
712my $varpfx = "bundle_" . substr +(Digest::MD5::md5_hex $data), 0, 16; 781my $varpfx = "bundle";
713 782
714############################################################################# 783#############################################################################
715# output 784# output
716 785
717print "generating $PREFIX.h... " 786print "generating $PREFIX.h... "
… …
720{ 789{
721 open my $fh, ">", "$PREFIX.h" 790 open my $fh, ">", "$PREFIX.h"
722 or die "$PREFIX.h: $!\n"; 791 or die "$PREFIX.h: $!\n";
723 792
724 print $fh <<EOF; 793 print $fh <<EOF;
725/* do not edit, automatically created by mkstaticbundle */ 794/* do not edit, automatically created by staticperl */
726 795
727#include <EXTERN.h> 796#include <EXTERN.h>
728#include <perl.h> 797#include <perl.h>
729#include <XSUB.h> 798#include <XSUB.h>
730 799
731/* public API */ 800/* public API */
732EXTERN_C PerlInterpreter *staticperl; 801EXTERN_C PerlInterpreter *staticperl;
733EXTERN_C void staticperl_xs_init (pTHX); 802EXTERN_C void staticperl_xs_init (pTHX);
734EXTERN_C void staticperl_init (void); 803EXTERN_C void staticperl_init (XSINIT_t xs_init); /* argument can be 0 */
735EXTERN_C void staticperl_cleanup (void); 804EXTERN_C void staticperl_cleanup (void);
736 805
737EOF 806EOF
738} 807}
739 808
… …
748 817
749open my $fh, ">", "$PREFIX.c" 818open my $fh, ">", "$PREFIX.c"
750 or die "$PREFIX.c: $!\n"; 819 or die "$PREFIX.c: $!\n";
751 820
752print $fh <<EOF; 821print $fh <<EOF;
753/* do not edit, automatically created by mkstaticbundle */ 822/* do not edit, automatically created by staticperl */
754 823
755#include "bundle.h" 824#include "bundle.h"
756 825
757/* public API */ 826/* public API */
758PerlInterpreter *staticperl; 827PerlInterpreter *staticperl;
759 828
760EOF 829EOF
830
831#############################################################################
832# lzf decompressor
833
834if ($COMPRESS eq "lzf") {
835 print $fh <<'EOF';
836/* stripped down/perlified version of lzf_d.c from liblzf-3.7 */
837
838#if (__i386 || __amd64) && __GNUC__ >= 3
839# define lzf_movsb(dst, src, len) \
840 asm ("rep movsb" \
841 : "=D" (dst), "=S" (src), "=c" (len) \
842 : "0" (dst), "1" (src), "2" (len));
843#endif
844
845static unsigned int
846lzf_decompress (const void *const in_data, unsigned int in_len,
847 void *out_data, unsigned int out_len)
848{
849 U8 const *ip = (const U8 *)in_data;
850 U8 *op = (U8 *)out_data;
851 U8 const *const in_end = ip + in_len;
852 U8 *const out_end = op + out_len;
853
854 do
855 {
856 unsigned int ctrl = *ip++;
857
858 if (ctrl < (1 << 5)) /* literal run */
859 {
860 ctrl++;
861
862 if (op + ctrl > out_end)
863 return 0;
864
865#ifdef lzf_movsb
866 lzf_movsb (op, ip, ctrl);
867#else
868 while (ctrl--)
869 *op++ = *ip++;
870#endif
871 }
872 else /* back reference */
873 {
874 unsigned int len = ctrl >> 5;
875
876 U8 *ref = op - ((ctrl & 0x1f) << 8) - 1;
877
878 if (len == 7)
879 len += *ip++;
880
881 ref -= *ip++;
882
883 if (op + len + 2 > out_end)
884 return 0;
885
886 if (ref < (U8 *)out_data)
887 return 0;
888
889 len += 2;
890#ifdef lzf_movsb
891 lzf_movsb (op, ref, len);
892#else
893 do
894 *op++ = *ref++;
895 while (--len);
896#endif
897 }
898 }
899 while (ip < in_end);
900
901 return op - (U8 *)out_data;
902}
903
904static SV *
905static_to_sv (const char *ptr, STRLEN len)
906{
907 SV *res;
908 const U8 *p = (const U8 *)ptr;
909
910 if (len == 0) /* empty */
911 res = newSVpvn ("", 0);
912 else if (*p == 0) /* not compressed */
913 res = newSVpvn (p + 1, len - 1);
914 else /* lzf compressed, with UTF-8-encoded original size in front */
915 {
916 STRLEN ulenlen;
917 UV ulen = utf8n_to_uvchr (p, len, &ulenlen, 0);
918
919 p += ulenlen;
920 len -= ulenlen;
921
922 res = NEWSV (0, ulen);
923 sv_upgrade (res, SVt_PV);
924 SvPOK_only (res);
925 lzf_decompress (p, len, SvPVX (res), ulen);
926 SvCUR_set (res, ulen);
927 }
928
929 return res;
930}
931
932EOF
933} else {
934 print $fh <<EOF;
935
936#define static_to_sv(ptr,len) newSVpvn (ptr, len)
937
938EOF
939}
761 940
762############################################################################# 941#############################################################################
763# bundle data 942# bundle data
764 943
765my $count = @index; 944my $count = @index;
… …
790# bootstrap 969# bootstrap
791 970
792# boot file for staticperl 971# boot file for staticperl
793# this file will be eval'ed at initialisation time 972# this file will be eval'ed at initialisation time
794 973
974# lines marked with "^D" are only used when $HAVE_DYNAMIC
795my $bootstrap = ' 975my $bootstrap = '
796BEGIN { 976BEGIN {
797 package ' . $PACKAGE . '; 977 package ' . $PACKAGE . ';
798 978
799 PerlIO::scalar->bootstrap; 979 # the path prefix to use when putting files into %INC
980 our $inc_prefix;
800 981
801 @INC = sub { 982 # the @INC hook to use when we have PerlIO::scalar available
983 my $perlio_inc = sub {
802 my $data = find "$_[1]" 984 my $data = find "$_[1]"
803 or return; 985 or return;
804 986
805 $INC{$_[1]} = $_[1]; 987 $INC{$_[1]} = "$inc_prefix$_[1]";
806 988
807 open my $fh, "<", \$data; 989 open my $fh, "<", \$data;
808 $fh 990 $fh
809 }; 991 };
992
993D if (defined &PerlIO::scalar::bootstrap) {
994 # PerlIO::scalar statically compiled in
995 PerlIO::scalar->bootstrap;
996 @INC = $perlio_inc;
997D } else {
998D # PerlIO::scalar not available, use slower method
999D @INC = sub {
1000D # always check if PerlIO::scalar might now be available
1001D if (defined &PerlIO::scalar::bootstrap) {
1002D # switch to the faster perlio_inc hook
1003D @INC = map { $_ == $_[0] ? $perlio_inc : $_ } @INC;
1004D goto &$perlio_inc;
1005D }
1006D
1007D my $data = find "$_[1]"
1008D or return;
1009D
1010D $INC{$_[1]} = "$inc_prefix$_[1]";
1011D
1012D sub {
1013D $data =~ /\G([^\n]*\n?)/g
1014D or return;
1015D
1016D $_ = $1;
1017D 1
1018D }
1019D };
1020D }
810} 1021}
811'; 1022';
812 1023
813$bootstrap .= "require '//boot';" 1024$bootstrap .= "require '!boot';"
814 if exists $pm{"//boot"}; 1025 if exists $pm{"!boot"};
815 1026
1027if ($HAVE_DYNAMIC) {
1028 $bootstrap =~ s/^D/ /mg;
1029} else {
1030 $bootstrap =~ s/^D.*$//mg;
1031}
1032
1033$bootstrap =~ s/#.*$//mg;
816$bootstrap =~ s/\s+/ /g; 1034$bootstrap =~ s/\s+/ /g;
817$bootstrap =~ s/(\W) /$1/g; 1035$bootstrap =~ s/(\W) /$1/g;
818$bootstrap =~ s/ (\W)/$1/g; 1036$bootstrap =~ s/ (\W)/$1/g;
819 1037
820print $fh "const char bootstrap [] = "; 1038print $fh "const char bootstrap [] = ";
… …
852 { 1070 {
853 /* found */ 1071 /* found */
854 int ofs2 = $varpfx\_index [m + 1] & 0x1FFFFFFU; 1072 int ofs2 = $varpfx\_index [m + 1] & 0x1FFFFFFU;
855 1073
856 ofs += namelen; 1074 ofs += namelen;
857 res = newSVpvn ($varpfx\_data + ofs, ofs2 - ofs); 1075 res = static_to_sv ($varpfx\_data + ofs, ofs2 - ofs);
858 goto found; 1076 goto found;
859 } 1077 }
860 } 1078 }
861 1079
862 if (comp < 0) 1080 if (comp < 0)
… …
866 } 1084 }
867 1085
868 XSRETURN (0); 1086 XSRETURN (0);
869 1087
870 found: 1088 found:
871 ST (0) = res; 1089 ST (0) = sv_2mortal (res);
872 sv_2mortal (ST (0));
873 } 1090 }
874 1091
875 XSRETURN (1); 1092 XSRETURN (1);
876} 1093}
877 1094
… …
890 1107
891 for (i = 0; i < $varpfx\_count; ++i) 1108 for (i = 0; i < $varpfx\_count; ++i)
892 { 1109 {
893 U32 idx = $varpfx\_index [i]; 1110 U32 idx = $varpfx\_index [i];
894 1111
895 PUSHs (newSVpvn ($varpfx\_data + (idx & 0x1FFFFFFU), idx >> 25)); 1112 PUSHs (sv_2mortal (newSVpvn ($varpfx\_data + (idx & 0x1FFFFFFU), idx >> 25)));
896 } 1113 }
897 } 1114 }
898 1115
899 XSRETURN ($varpfx\_count); 1116 XSRETURN ($varpfx\_count);
900} 1117}
1118
1119#ifdef STATICPERL_BUNDLE_INCLUDE
1120#include STATICPERL_BUNDLE_INCLUDE
1121#endif
901 1122
902EOF 1123EOF
903 1124
904############################################################################# 1125#############################################################################
905# xs_init 1126# xs_init
… …
908void 1129void
909staticperl_xs_init (pTHX) 1130staticperl_xs_init (pTHX)
910{ 1131{
911EOF 1132EOF
912 1133
913@static_ext = ("DynaLoader", sort @static_ext); 1134@static_ext = sort @static_ext;
914 1135
915# prototypes 1136# prototypes
916for (@static_ext) { 1137for (@static_ext) {
917 s/\.pm$//; 1138 s/\.pm$//;
918 (my $cname = $_) =~ s/\//__/g; 1139 (my $cname = $_) =~ s/\//__/g;
… …
923 char *file = __FILE__; 1144 char *file = __FILE__;
924 dXSUB_SYS; 1145 dXSUB_SYS;
925 1146
926 newXSproto ("$PACKAGE\::find", find, file, "\$"); 1147 newXSproto ("$PACKAGE\::find", find, file, "\$");
927 newXSproto ("$PACKAGE\::list", list, file, ""); 1148 newXSproto ("$PACKAGE\::list", list, file, "");
1149
1150 #ifdef STATICPERL_BUNDLE_XS_INIT
1151 STATICPERL_BUNDLE_XS_INIT;
1152 #endif
928EOF 1153EOF
929 1154
930# calls 1155# calls
931for (@static_ext) { 1156for (@static_ext) {
932 s/\.pm$//; 1157 s/\.pm$//;
933 1158
934 (my $cname = $_) =~ s/\//__/g; 1159 (my $cname = $_) =~ s/\//__/g;
935 (my $pname = $_) =~ s/\//::/g; 1160 (my $pname = $_) =~ s/\//::/g;
936 1161
937 my $bootstrap = $pname eq "DynaLoader" ? "boot" : "bootstrap"; 1162 my $bootstrap = $pname eq "DynaLoader" ? "boot_DynaLoader" : "bootstrap";
938 1163
939 print $fh " newXS (\"$pname\::$bootstrap\", boot_$cname, file);\n"; 1164 print $fh " newXS (\"$pname\::$bootstrap\", boot_$cname, file);\n";
940} 1165}
941 1166
942print $fh <<EOF; 1167print $fh <<EOF;
1168 Safefree (PL_origfilename);
1169 PL_origfilename = savepv (PL_origargv [0]);
1170 sv_setpv (GvSV (gv_fetchpvs ("0", GV_ADD|GV_NOTQUAL, SVt_PV)), PL_origfilename);
1171
1172 #ifdef _WIN32
1173 /* windows perls usually trail behind unix perls 8-10 years in exporting symbols */
1174
1175 if (!PL_preambleav)
1176 PL_preambleav = newAV ();
1177
1178 av_unshift (PL_preambleav, 1);
1179 av_store (PL_preambleav, 0, newSVpv (bootstrap, sizeof (bootstrap) - 1));
1180 #else
943 Perl_av_create_and_unshift_one (&PL_preambleav, newSVpv (bootstrap, sizeof (bootstrap) - 1)); 1181 Perl_av_create_and_unshift_one (&PL_preambleav, newSVpv (bootstrap, sizeof (bootstrap) - 1));
1182 #endif
1183
1184 if (PL_oldname)
1185 ((XSINIT_t)PL_oldname)(aTHX);
944} 1186}
945EOF 1187EOF
946 1188
947############################################################################# 1189#############################################################################
948# optional perl_init/perl_destroy 1190# optional perl_init/perl_destroy
1191
1192if ($IGNORE_ENV) {
1193 $IGNORE_ENV = <<EOF;
1194 unsetenv ("PERL_UNICODE");
1195 unsetenv ("PERL_HASH_SEED_DEBUG");
1196 unsetenv ("PERL_DESTRUCT_LEVEL");
1197 unsetenv ("PERL_SIGNALS");
1198 unsetenv ("PERL_DEBUG_MSTATS");
1199 unsetenv ("PERL5OPT");
1200 unsetenv ("PERLIO_DEBUG");
1201 unsetenv ("PERLIO");
1202 unsetenv ("PERL_HASH_SEED");
1203EOF
1204} else {
1205 $IGNORE_ENV = "";
1206}
949 1207
950if ($APP) { 1208if ($APP) {
951 print $fh <<EOF; 1209 print $fh <<EOF;
952 1210
953int 1211int
… …
963 args [3] = "--"; 1221 args [3] = "--";
964 1222
965 for (i = 1; i < argc; ++i) 1223 for (i = 1; i < argc; ++i)
966 args [i + 3] = argv [i]; 1224 args [i + 3] = argv [i];
967 1225
1226$IGNORE_ENV
968 PERL_SYS_INIT3 (&argc, &argv, &environ); 1227 PERL_SYS_INIT3 (&argc, &argv, &environ);
969 staticperl = perl_alloc (); 1228 staticperl = perl_alloc ();
970 perl_construct (staticperl); 1229 perl_construct (staticperl);
971 1230
972 PL_exit_flags |= PERL_EXIT_DESTRUCT_END; 1231 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
973 1232
974 exitstatus = perl_parse (staticperl, staticperl_xs_init, argc + 3, args, environ); 1233 exitstatus = perl_parse (staticperl, staticperl_xs_init, argc + 3, args, environ);
975 free (args);
976 if (!exitstatus) 1234 if (!exitstatus)
977 perl_run (staticperl); 1235 perl_run (staticperl);
978 1236
979 exitstatus = perl_destruct (staticperl); 1237 exitstatus = perl_destruct (staticperl);
980 perl_free (staticperl); 1238 perl_free (staticperl);
981 PERL_SYS_TERM (); 1239 PERL_SYS_TERM ();
1240 /*free (args); no point doing it this late */
982 1241
983 return exitstatus; 1242 return exitstatus;
984} 1243}
985EOF 1244EOF
986} elsif ($PERL) { 1245} elsif ($PERL) {
… …
990main (int argc, char *argv []) 1249main (int argc, char *argv [])
991{ 1250{
992 extern char **environ; 1251 extern char **environ;
993 int exitstatus; 1252 int exitstatus;
994 1253
1254$IGNORE_ENV
995 PERL_SYS_INIT3 (&argc, &argv, &environ); 1255 PERL_SYS_INIT3 (&argc, &argv, &environ);
996 staticperl = perl_alloc (); 1256 staticperl = perl_alloc ();
997 perl_construct (staticperl); 1257 perl_construct (staticperl);
998 1258
999 PL_exit_flags |= PERL_EXIT_DESTRUCT_END; 1259 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
… …
1011EOF 1271EOF
1012} else { 1272} else {
1013 print $fh <<EOF; 1273 print $fh <<EOF;
1014 1274
1015EXTERN_C void 1275EXTERN_C void
1016staticperl_init (void) 1276staticperl_init (XSINIT_t xs_init)
1017{ 1277{
1018 static char *args[] = { 1278 static char *args[] = {
1019 "staticperl", 1279 "staticperl",
1020 "-e", 1280 "-e",
1021 "0" 1281 "0"
… …
1023 1283
1024 extern char **environ; 1284 extern char **environ;
1025 int argc = sizeof (args) / sizeof (args [0]); 1285 int argc = sizeof (args) / sizeof (args [0]);
1026 char **argv = args; 1286 char **argv = args;
1027 1287
1288$IGNORE_ENV
1028 PERL_SYS_INIT3 (&argc, &argv, &environ); 1289 PERL_SYS_INIT3 (&argc, &argv, &environ);
1029 staticperl = perl_alloc (); 1290 staticperl = perl_alloc ();
1030 perl_construct (staticperl); 1291 perl_construct (staticperl);
1031 PL_origalen = 1; 1292 PL_origalen = 1;
1032 PL_exit_flags |= PERL_EXIT_DESTRUCT_END; 1293 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
1294 PL_oldname = (char *)xs_init;
1033 perl_parse (staticperl, staticperl_xs_init, argc, argv, environ); 1295 perl_parse (staticperl, staticperl_xs_init, argc, argv, environ);
1034 1296
1035 perl_run (staticperl); 1297 perl_run (staticperl);
1036} 1298}
1037 1299
… …
1044 PERL_SYS_TERM (); 1306 PERL_SYS_TERM ();
1045} 1307}
1046EOF 1308EOF
1047} 1309}
1048 1310
1311close $fh;
1312
1049print -s "$PREFIX.c", " octets (", (length $data) , " data octets).\n\n" 1313print -s "$PREFIX.c", " octets (", (length $data) , " data octets).\n\n"
1050 if $VERBOSE >= 1; 1314 if $VERBOSE >= 1;
1051 1315
1052############################################################################# 1316#############################################################################
1053# libs, cflags 1317# libs, cflags
1318
1319my $ccopts;
1054 1320
1055{ 1321{
1056 print "generating $PREFIX.ccopts... " 1322 print "generating $PREFIX.ccopts... "
1057 if $VERBOSE >= 1; 1323 if $VERBOSE >= 1;
1058 1324
1059 my $str = "$Config{ccflags} $Config{optimize} $Config{cppflags} -I$Config{archlibexp}/CORE"; 1325 $ccopts = "$Config{ccflags} $Config{optimize} $Config{cppflags} -I$Config{archlibexp}/CORE $EXTRA_CFLAGS";
1060 $str =~ s/([\(\)])/\\$1/g; 1326 $ccopts =~ s/([\(\)])/\\$1/g;
1061 1327
1062 open my $fh, ">$PREFIX.ccopts" 1328 open my $fh, ">$PREFIX.ccopts"
1063 or die "$PREFIX.ccopts: $!"; 1329 or die "$PREFIX.ccopts: $!";
1064 print $fh $str; 1330 print $fh $ccopts;
1065 1331
1066 print "$str\n\n" 1332 print "$ccopts\n\n"
1067 if $VERBOSE >= 1; 1333 if $VERBOSE >= 1;
1068} 1334}
1335
1336my $ldopts;
1069 1337
1070{ 1338{
1071 print "generating $PREFIX.ldopts... "; 1339 print "generating $PREFIX.ldopts... ";
1072 1340
1073 my $str = $STATIC ? "-static " : ""; 1341 $ldopts = $STATIC ? "-static " : "";
1074 1342
1075 $str .= "$Config{ccdlflags} $Config{ldflags} @libs $Config{archlibexp}/CORE/$Config{libperl} $Config{perllibs}"; 1343 $ldopts .= "$Config{ccdlflags} $Config{ldflags} $EXTRA_LDFLAGS @libs $Config{archlibexp}/CORE/$Config{libperl} $Config{perllibs} $EXTRA_LIBS";
1076 1344
1077 my %seen; 1345 my %seen;
1078 $str .= " $_" for grep !$seen{$_}++, ($extralibs =~ /(\S+)/g); 1346 $ldopts .= " $_" for reverse grep !$seen{$_}++, reverse +($extralibs =~ /(\S+)/g);
1079 1347
1080 for (@staticlibs) { 1348 for (@staticlibs) {
1081 $str =~ s/(^|\s) (-l\Q$_\E) ($|\s)/$1-Wl,-Bstatic $2 -Wl,-Bdynamic$3/gx; 1349 $ldopts =~ s/(^|\s) (-l\Q$_\E) ($|\s)/$1-Wl,-Bstatic $2 -Wl,-Bdynamic$3/gx;
1082 } 1350 }
1083 1351
1084 $str =~ s/([\(\)])/\\$1/g; 1352 $ldopts =~ s/([\(\)])/\\$1/g;
1085 1353
1086 open my $fh, ">$PREFIX.ldopts" 1354 open my $fh, ">$PREFIX.ldopts"
1087 or die "$PREFIX.ldopts: $!"; 1355 or die "$PREFIX.ldopts: $!";
1088 print $fh $str; 1356 print $fh $ldopts;
1089 1357
1090 print "$str\n\n" 1358 print "$ldopts\n\n"
1091 if $VERBOSE >= 1; 1359 if $VERBOSE >= 1;
1092} 1360}
1093 1361
1094if ($PERL or defined $APP) { 1362if ($PERL or defined $APP) {
1095 $APP = "perl" unless defined $APP; 1363 $APP = "perl" unless defined $APP;
1096 1364
1365 my $build = "$Config{cc} $ccopts -o \Q$APP\E$Config{_exe} bundle.c $ldopts";
1366
1097 print "building $APP...\n" 1367 print "build $APP...\n"
1098 if $VERBOSE >= 1; 1368 if $VERBOSE >= 1;
1099 1369
1100 system "$Config{cc} \$(cat bundle.ccopts\) -o \Q$APP\E bundle.c \$(cat bundle.ldopts\)"; 1370 print "$build\n"
1371 if $VERBOSE >= 2;
1372
1373 system $build;
1101 1374
1102 unlink "$PREFIX.$_" 1375 unlink "$PREFIX.$_"
1103 for qw(ccopts ldopts c h); 1376 for qw(ccopts ldopts c h);
1104 1377
1105 print "\n" 1378 print "\n"

Diff Legend

– Removed lines
+ Added lines
< Changed lines
> Changed lines