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

Comparing App-Staticperl/mkbundle (file contents):
Revision 1.34 by root, Mon Mar 12 21:45:10 2012 UTC vs.
Revision 1.42 by root, Mon Aug 7 03:04:13 2023 UTC

… …
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;
14our $IGNORE_ENV = 0; 16our $IGNORE_ENV = 0;
15our $ALLOW_DYNAMIC = 0; 17our $ALLOW_DYNAMIC = 0;
16our $HAVE_DYNAMIC; # maybe useful? 18our $HAVE_DYNAMIC; # maybe useful?
19our $EXTRA_CFLAGS = "";
20our $EXTRA_LDFLAGS = "";
21our $EXTRA_LIBS = "";
17 22
18our $OPTIMISE_SIZE = 0; # optimise for raw file size instead of for compression? 23our $OPTIMISE_SIZE = 0; # optimise for raw file size instead of for compression?
19 24
20our $CACHE; 25our $CACHE;
21our $CACHEVER = 1; # do not change unless you know what you are doing 26our $CACHEVER = 2; # do not change unless you know what you are doing
22 27
23my $PREFIX = "bundle"; 28my $PREFIX = "bundle";
24my $PACKAGE = "static"; 29my $PACKAGE = "static";
25 30
26my %pm; 31my %pm;
… …
353 358
354use Getopt::Long; 359use Getopt::Long;
355 360
356sub parse_argv { 361sub parse_argv {
357 GetOptions 362 GetOptions
358 "perl" => \$PERL, 363 "perl" => \$PERL,
359 "app=s" => \$APP, 364 "app=s" => \$APP,
360 365
361 "verbose|v" => sub { ++$VERBOSE }, 366 "verbose|v" => sub { ++$VERBOSE },
362 "quiet|q" => sub { --$VERBOSE }, 367 "quiet|q" => sub { --$VERBOSE },
363 368
364 "strip=s" => \$STRIP, 369 "strip=s" => \$STRIP,
370 "keepnl" => \$KEEPNL,
371 "compress=s" => \$COMPRESS,
365 "cache=s" => \$CACHE, # internal option 372 "cache=s" => \$CACHE, # internal option
366 "eval|e=s" => sub { trace_eval $_[1] }, 373 "eval|e=s" => sub { trace_eval $_[1] },
367 "use|M=s" => sub { trace_module $_[1] }, 374 "use|M=s" => sub { trace_module $_[1] },
368 "boot=s" => sub { cmd_boot $_[1] }, 375 "boot=s" => sub { cmd_boot $_[1] },
369 "add=s" => sub { cmd_add $_[1], 0 }, 376 "add=s" => sub { cmd_add $_[1], 0 },
370 "addbin=s" => sub { cmd_add $_[1], 1 }, 377 "addbin=s" => sub { cmd_add $_[1], 1 },
371 "incglob=s" => sub { cmd_incglob $_[1] }, 378 "incglob=s" => sub { cmd_incglob $_[1] },
372 "include|i=s" => sub { cmd_include $_[1], 1 }, 379 "include|i=s" => sub { cmd_include $_[1], 1 },
373 "exclude|x=s" => sub { cmd_include $_[1], 0 }, 380 "exclude|x=s" => sub { cmd_include $_[1], 0 },
374 "usepacklists!" => \$PACKLIST, 381 "usepacklists!" => \$PACKLIST,
375 382
376 "static!" => \$STATIC, 383 "static!" => \$STATIC,
377 "staticlib=s" => sub { cmd_staticlib $_[1] }, 384 "staticlib=s" => sub { cmd_staticlib $_[1] },
378 "allow-dynamic!"=> \$ALLOW_DYNAMIC, 385 "allow-dynamic!" => \$ALLOW_DYNAMIC,
379 "ignore-env" => \$IGNORE_ENV, 386 "ignore-env" => \$IGNORE_ENV,
380 387
388 "extra-cflags=s" => \$EXTRA_CFLAGS,
389 "extra-ldflags=s" => \$EXTRA_LDFLAGS,
390 "extra-libs=s" => \$EXTRA_LIBS,
391
381 "<>" => sub { cmd_file $_[0] }, 392 "<>" => sub { cmd_file $_[0] },
382 or exit 1; 393 or exit 1;
383} 394}
384 395
385Getopt::Long::Configure ("bundling", "no_auto_abbrev", "no_ignore_case"); 396Getopt::Long::Configure ("bundling", "no_auto_abbrev", "no_ignore_case");
386 397
387parse_argv; 398parse_argv;
388 399
389die "cannot specify both --app and --perl\n" 400die "cannot specify both --app and --perl\n"
390 if $PERL and defined $APP; 401 if $PERL and defined $APP;
402
403die "--compress must be either none or lzf\n"
404 unless $COMPRESS =~ /^(?:none|lzf)\z/;
391 405
392# required for @INC loading, unfortunately 406# required for @INC loading, unfortunately
393trace_module "PerlIO::scalar"; 407trace_module "PerlIO::scalar";
394 408
395############################################################################# 409#############################################################################
… …
543############################################################################# 557#############################################################################
544 558
545print "processing bundle files (try more -v power if you get bored waiting here)...\n" 559print "processing bundle files (try more -v power if you get bored waiting here)...\n"
546 if $VERBOSE >= 1; 560 if $VERBOSE >= 1;
547 561
562my $compress = sub { shift };
563
564if ($COMPRESS eq "lzf") {
565 require Compress::LZF;
566 $compress = sub { Compress::LZF::compress_best (shift) };
567}
568
548my $data; 569my $data;
549my @index; 570my @index;
550my @order = sort { 571my @order = sort {
551 length $a <=> length $b 572 length $a <=> length $b
552 or $a cmp $b 573 or $a cmp $b
… …
582 if $VERBOSE >= 3; 603 if $VERBOSE >= 3;
583 next; 604 next;
584 } 605 }
585 } 606 }
586 607
587 $src = cache +($STRIP eq "ppi" ? "$UNISTRIP,$OPTIMISE_SIZE" : undef), $src, sub { 608 $src = cache "$STRIP,$UNISTRIP,$OPTIMISE_SIZE,$COMPRESS", $src, sub {
588 if ($UNISTRIP && $pm =~ /^unicore\/.*\.pl$/) { 609 if ($UNISTRIP && $pm =~ /^unicore\/.*\.pl$/) {
589 print "applying unicore stripping $pm\n" 610 print "applying unicore stripping $pm\n"
590 if $VERBOSE >= 6; 611 if $VERBOSE >= 6;
591 612
592 # special stripping for unicore swashes and properties 613 # special stripping for unicore swashes and properties
… …
618 } 639 }
619 640
620 if ($STRIP =~ /ppi/i) { 641 if ($STRIP =~ /ppi/i) {
621 require PPI; 642 require PPI;
622 643
644 # PPI (quite correctly) treeats pod in __DATA__ as data, not pod
645
623 if (my $ppi = PPI::Document->new (\$src)) { 646 if (my $ppi = PPI::Document->new (\$src)) {
624 $ppi->prune ("PPI::Token::Comment"); 647 $ppi->prune ("PPI::Token::Comment");
625 $ppi->prune ("PPI::Token::Pod"); 648
649 for my $pod (@{ $ppi->find (PPI::Token::Pod::) }) {
650 # should somehow convert to whitespace token
651 if ($KEEPNL) {
652 $pod->{content} =~ s/[^\n]//g;
653 } else {
654 $pod->{content} = '';
655 }
656 }
626 657
627 # prune END stuff 658 # prune END stuff
628 for (my $last = $ppi->last_element; $last; ) { 659 for (my $last = $ppi->last_element; $last; ) {
629 my $prev = $last->previous_token; 660 my $prev = $last->previous_token;
630 661
… …
648 my $next = $ws->next_token; 679 my $next = $ws->next_token;
649 680
650 if (!$prev || !$next) { 681 if (!$prev || !$next) {
651 $ws->delete; 682 $ws->delete;
652 } else { 683 } else {
684 if ($next->isa (PPI::Token::Whitespace::)) {
685 # push this whitespace data into the next node
686 $next->{content} = "$ws->{content}$next->{content}";
687 $ws->{content} = "";
688 } elsif (
653 if ( 689 (
654 $next->isa (PPI::Token::Operator::) && $next->{content} =~ /^(?:,|=|!|!=|==|=>)$/ # no ., because of digits. == float 690 $next->isa (PPI::Token::Operator::) && $next->{content} =~ /^(?:,|=|!|!=|==|=>)$/ # no ., because of digits. == float
655 or $prev->isa (PPI::Token::Operator::) && $prev->{content} =~ /^(?:,|=|\.|!|!=|==|=>)$/ 691 or $prev->isa (PPI::Token::Operator::) && $prev->{content} =~ /^(?:,|=|\.|!|!=|==|=>)$/
656 or $prev->isa (PPI::Token::Structure::) 692 or $prev->isa (PPI::Token::Structure::)
657 or ($OPTIMISE_SIZE && 693 or ($OPTIMISE_SIZE &&
658 ($prev->isa (PPI::Token::Word::) 694 ($prev->isa (PPI::Token::Word::)
659 && (PPI::Token::Symbol:: eq ref $next 695 && (PPI::Token::Symbol:: eq ref $next
660 || $next->isa (PPI::Structure::Block::) 696 || $next->isa (PPI::Structure::Block::)
661 || $next->isa (PPI::Structure::List::) 697 || $next->isa (PPI::Structure::List::)
662 || $next->isa (PPI::Structure::Condition::))) 698 || $next->isa (PPI::Structure::Condition::)))
699 )
663 ) 700 )
701 # perl has some idiotic warning about nonexisting operators (Reverse %s operator)
702 && !(
703 $prev->isa (PPI::Token::Operator::) && $prev->{content} eq "="
704 && $next->isa (PPI::Token::Operator::) && $next->{content} =~ /[+\-]/
705 )
664 ) { 706 ) {
707 if ($KEEPNL) {
708 $ws->{content} =~ s/[^\n]//g;
665 $ws->delete; 709 } else {
666 } elsif ($prev->isa (PPI::Token::Whitespace::)) {
667 $ws->{content} = ' '; 710 $ws->{content} = '';
668 $prev->delete; 711 }
669 } else { 712 } else {
713 if ($KEEPNL) {
714 $ws->{content} =~ s/[^\n]//g;
715 $ws->{content} ||= ' '; # keep at least one space
716 } else {
670 $ws->{content} = ' '; 717 $ws->{content} = ' ';
718 }
671 } 719 }
672 } 720 }
673 } 721 }
674 722
675 # prune whitespace around blocks 723 # prune whitespace around blocks
… …
730 eval "#line 1 \"$pm\"\n$src" or warn "\n\n\n$pm\n\n$src\n$@\n\n\n"; 778 eval "#line 1 \"$pm\"\n$src" or warn "\n\n\n$pm\n\n$src\n$@\n\n\n";
731 exit 0; 779 exit 0;
732 } 780 }
733 } 781 }
734 782
783 $src = $compress->($src);
784
735 $src 785 $src
736 }; 786 };
737 787
738# if ($pm eq "Opcode.pm") { 788# if ($pm eq "Opcode.pm") {
739# open my $fh, ">x" or die; print $fh $src;#d# 789# open my $fh, ">x" or die; print $fh $src;#d#
… …
798 848
799/* public API */ 849/* public API */
800PerlInterpreter *staticperl; 850PerlInterpreter *staticperl;
801 851
802EOF 852EOF
853
854#############################################################################
855# lzf decompressor
856
857if ($COMPRESS eq "lzf") {
858 print $fh <<'EOF';
859/* stripped down/perlified version of lzf_d.c from liblzf-3.7 */
860
861#if (__i386 || __amd64) && __GNUC__ >= 3
862# define lzf_movsb(dst, src, len) \
863 asm ("rep movsb" \
864 : "=D" (dst), "=S" (src), "=c" (len) \
865 : "0" (dst), "1" (src), "2" (len));
866#endif
867
868static unsigned int
869lzf_decompress (const void *const in_data, unsigned int in_len,
870 void *out_data, unsigned int out_len)
871{
872 U8 const *ip = (const U8 *)in_data;
873 U8 *op = (U8 *)out_data;
874 U8 const *const in_end = ip + in_len;
875 U8 *const out_end = op + out_len;
876
877 do
878 {
879 unsigned int ctrl = *ip++;
880
881 if (ctrl < (1 << 5)) /* literal run */
882 {
883 ctrl++;
884
885 if (op + ctrl > out_end)
886 return 0;
887
888#ifdef lzf_movsb
889 lzf_movsb (op, ip, ctrl);
890#else
891 while (ctrl--)
892 *op++ = *ip++;
893#endif
894 }
895 else /* back reference */
896 {
897 unsigned int len = ctrl >> 5;
898
899 U8 *ref = op - ((ctrl & 0x1f) << 8) - 1;
900
901 if (len == 7)
902 len += *ip++;
903
904 ref -= *ip++;
905
906 if (op + len + 2 > out_end)
907 return 0;
908
909 if (ref < (U8 *)out_data)
910 return 0;
911
912 len += 2;
913#ifdef lzf_movsb
914 lzf_movsb (op, ref, len);
915#else
916 do
917 *op++ = *ref++;
918 while (--len);
919#endif
920 }
921 }
922 while (ip < in_end);
923
924 return op - (U8 *)out_data;
925}
926
927static SV *
928static_to_sv (const char *ptr, STRLEN len)
929{
930 SV *res;
931 const U8 *p = (const U8 *)ptr;
932
933 if (len == 0) /* empty */
934 res = newSVpvn ("", 0);
935 else if (*p == 0) /* not compressed */
936 res = newSVpvn (p + 1, len - 1);
937 else /* lzf compressed, with UTF-8-encoded original size in front */
938 {
939 STRLEN ulenlen;
940 UV ulen = utf8n_to_uvchr (p, len, &ulenlen, 0);
941
942 p += ulenlen;
943 len -= ulenlen;
944
945 res = NEWSV (0, ulen);
946 sv_upgrade (res, SVt_PV);
947 SvPOK_only (res);
948 lzf_decompress (p, len, SvPVX (res), ulen);
949 SvCUR_set (res, ulen);
950 }
951
952 return res;
953}
954
955EOF
956} else {
957 print $fh <<EOF;
958
959#define static_to_sv(ptr,len) newSVpvn (ptr, len)
960
961EOF
962}
803 963
804############################################################################# 964#############################################################################
805# bundle data 965# bundle data
806 966
807my $count = @index; 967my $count = @index;
… …
933 { 1093 {
934 /* found */ 1094 /* found */
935 int ofs2 = $varpfx\_index [m + 1] & 0x1FFFFFFU; 1095 int ofs2 = $varpfx\_index [m + 1] & 0x1FFFFFFU;
936 1096
937 ofs += namelen; 1097 ofs += namelen;
938 res = newSVpvn ($varpfx\_data + ofs, ofs2 - ofs); 1098 res = static_to_sv ($varpfx\_data + ofs, ofs2 - ofs);
939 goto found; 1099 goto found;
940 } 1100 }
941 } 1101 }
942 1102
943 if (comp < 0) 1103 if (comp < 0)
… …
977 } 1137 }
978 1138
979 XSRETURN ($varpfx\_count); 1139 XSRETURN ($varpfx\_count);
980} 1140}
981 1141
1142#ifdef STATICPERL_BUNDLE_INCLUDE
1143#include STATICPERL_BUNDLE_INCLUDE
1144#endif
1145
982EOF 1146EOF
983 1147
984############################################################################# 1148#############################################################################
985# xs_init 1149# xs_init
986 1150
… …
1003 char *file = __FILE__; 1167 char *file = __FILE__;
1004 dXSUB_SYS; 1168 dXSUB_SYS;
1005 1169
1006 newXSproto ("$PACKAGE\::find", find, file, "\$"); 1170 newXSproto ("$PACKAGE\::find", find, file, "\$");
1007 newXSproto ("$PACKAGE\::list", list, file, ""); 1171 newXSproto ("$PACKAGE\::list", list, file, "");
1172
1173 #ifdef STATICPERL_BUNDLE_XS_INIT
1174 STATICPERL_BUNDLE_XS_INIT;
1175 #endif
1008EOF 1176EOF
1009 1177
1010# calls 1178# calls
1011for (@static_ext) { 1179for (@static_ext) {
1012 s/\.pm$//; 1180 s/\.pm$//;
… …
1018 1186
1019 print $fh " newXS (\"$pname\::$bootstrap\", boot_$cname, file);\n"; 1187 print $fh " newXS (\"$pname\::$bootstrap\", boot_$cname, file);\n";
1020} 1188}
1021 1189
1022print $fh <<EOF; 1190print $fh <<EOF;
1191 Safefree (PL_origfilename);
1192 PL_origfilename = savepv (PL_origargv [0]);
1193 sv_setpv (GvSV (gv_fetchpvs ("0", GV_ADD|GV_NOTQUAL, SVt_PV)), PL_origfilename);
1194
1023 #ifdef _WIN32 1195 #ifdef _WIN32
1024 /* windows perls usually trail behind unix perls 8-10 years in exporting symbols */ 1196 /* windows perls usually trail behind unix perls 8-10 years in exporting symbols */
1025 1197
1026 if (!PL_preambleav) 1198 if (!PL_preambleav)
1027 PL_preambleav = newAV (); 1199 PL_preambleav = newAV ();
… …
1080 perl_construct (staticperl); 1252 perl_construct (staticperl);
1081 1253
1082 PL_exit_flags |= PERL_EXIT_DESTRUCT_END; 1254 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
1083 1255
1084 exitstatus = perl_parse (staticperl, staticperl_xs_init, argc + 3, args, environ); 1256 exitstatus = perl_parse (staticperl, staticperl_xs_init, argc + 3, args, environ);
1085 free (args);
1086 if (!exitstatus) 1257 if (!exitstatus)
1087 perl_run (staticperl); 1258 perl_run (staticperl);
1088 1259
1089 exitstatus = perl_destruct (staticperl); 1260 exitstatus = perl_destruct (staticperl);
1090 perl_free (staticperl); 1261 perl_free (staticperl);
1091 PERL_SYS_TERM (); 1262 PERL_SYS_TERM ();
1263 /*free (args); no point doing it this late */
1092 1264
1093 return exitstatus; 1265 return exitstatus;
1094} 1266}
1095EOF 1267EOF
1096} elsif ($PERL) { 1268} elsif ($PERL) {
… …
1171 1343
1172{ 1344{
1173 print "generating $PREFIX.ccopts... " 1345 print "generating $PREFIX.ccopts... "
1174 if $VERBOSE >= 1; 1346 if $VERBOSE >= 1;
1175 1347
1176 $ccopts = "$Config{ccflags} $Config{optimize} $Config{cppflags} -I$Config{archlibexp}/CORE"; 1348 $ccopts = "$Config{ccflags} $Config{optimize} $Config{cppflags} -I$Config{archlibexp}/CORE $EXTRA_CFLAGS";
1177 $ccopts =~ s/([\(\)])/\\$1/g; 1349 $ccopts =~ s/([\(\)])/\\$1/g;
1178 1350
1179 open my $fh, ">$PREFIX.ccopts" 1351 open my $fh, ">$PREFIX.ccopts"
1180 or die "$PREFIX.ccopts: $!"; 1352 or die "$PREFIX.ccopts: $!";
1181 print $fh $ccopts; 1353 print $fh $ccopts;
… …
1189{ 1361{
1190 print "generating $PREFIX.ldopts... "; 1362 print "generating $PREFIX.ldopts... ";
1191 1363
1192 $ldopts = $STATIC ? "-static " : ""; 1364 $ldopts = $STATIC ? "-static " : "";
1193 1365
1194 $ldopts .= "$Config{ccdlflags} $Config{ldflags} @libs $Config{archlibexp}/CORE/$Config{libperl} $Config{perllibs}"; 1366 $ldopts .= "$Config{ccdlflags} $Config{ldflags} $EXTRA_LDFLAGS @libs $Config{archlibexp}/CORE/$Config{libperl} $Config{perllibs} $EXTRA_LIBS";
1195 1367
1196 my %seen; 1368 my %seen;
1197 $ldopts .= " $_" for reverse grep !$seen{$_}++, reverse +($extralibs =~ /(\S+)/g); 1369 $ldopts .= " $_" for reverse grep !$seen{$_}++, reverse +($extralibs =~ /(\S+)/g);
1198 1370
1199 for (@staticlibs) { 1371 for (@staticlibs) {

Diff Legend

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