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

Diff Legend

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