ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/App-Staticperl/mkbundle
Revision: 1.47
Committed: Thu Aug 24 11:01:37 2023 UTC (7 months, 3 weeks ago) by root
Branch: MAIN
CVS Tags: HEAD
Changes since 1.46: +1 -1 lines
Log Message:
*** empty log message ***

File Contents

# Content
1 #!/opt/bin/perl
2
3 #############################################################################
4 # cannot load modules till after the tracer BEGIN block
5
6 our $VERBOSE = 1;
7 our $STRIP = "pod"; # none, pod or ppi
8 our $COMPRESS = "lzf";
9 our $KEEPNL = 0;
10 our $UNISTRIP = 1; # always on, try to strip unicore swash data
11 our $PERL = 0;
12 our $APP;
13 our $VERIFY = 0;
14 our $STATIC = 0;
15 our $PACKLIST = 0;
16 our $IGNORE_ENV = 0;
17 our $ALLOW_DYNAMIC = 0;
18 our $HAVE_DYNAMIC; # maybe useful?
19 our $EXTRA_CFLAGS = "";
20 our $EXTRA_LDFLAGS = "";
21 our $EXTRA_LIBS = "";
22
23 # TODO: at least with lzf, OPTIMIZE_SIZE sesm to be a win? (also, does not respect KEEPNL)
24 our $OPTIMISE_SIZE = 0; # optimise for raw file size instead of for compression?
25
26 our $CACHE;
27 our $CACHEVER = 2; # do not change unless you know what you are doing
28
29 my $PREFIX = "bundle";
30 my $PACKAGE = "static";
31
32 my %pm;
33 my %pmbin;
34 my @libs;
35 my @static_ext;
36 my $extralibs;
37 my @staticlibs;
38 my @incext;
39
40 @ARGV
41 or die "$0: use 'staticperl help' (or read the sources of staticperl)\n";
42
43 # remove "." from @INC - staticperl.sh does it for us, but be on the safe side
44 BEGIN { @INC = grep !/^\.$/, @INC }
45
46 $|=1;
47
48 our ($TRACER_W, $TRACER_R);
49
50 sub find_incdir($) {
51 for (@INC) {
52 next if ref;
53 return $_ if -e "$_/$_[0]";
54 }
55
56 undef
57 }
58
59 sub find_inc($) {
60 my $dir = find_incdir $_[0];
61
62 return "$dir/$_[0]"
63 if defined $dir;
64
65 undef
66 }
67
68 BEGIN {
69 # create a loader process to detect @INC requests before we load any modules
70 my ($W_TRACER, $R_TRACER); # used by tracer
71
72 pipe $R_TRACER, $TRACER_W or die "pipe: $!";
73 pipe $TRACER_R, $W_TRACER or die "pipe: $!";
74
75 unless (fork) {
76 close $TRACER_R;
77 close $TRACER_W;
78
79 my $pkg = "pkg000000";
80
81 unshift @INC, sub {
82 my $dir = find_incdir $_[1]
83 or return;
84
85 syswrite $W_TRACER, "-\n$dir\n$_[1]\n";
86
87 open my $fh, "<:raw:perlio", "$dir/$_[1]"
88 or warn "ERROR: $dir/$_[1]: $!\n";
89
90 $fh
91 };
92
93 while (<$R_TRACER>) {
94 if (/use (.*)$/) {
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 {
103 my $pkg = ++$pkg;
104 $eval = "{ package $pkg; use $mod; }";
105 }
106
107 eval $eval;
108 warn "ERROR: $@ (while loading '$mod')\n"
109 if $@;
110 } elsif (/eval (.*)$/) {
111 my $eval = $1;
112 eval $eval;
113 warn "ERROR: $@ (in '$eval')\n"
114 if $@;
115 }
116
117 syswrite $W_TRACER, "\n";
118 }
119
120 exit 0;
121 }
122 }
123
124 # module loading is now safe
125
126 sub trace_parse {
127 for (;;) {
128 <$TRACER_R> =~ /^-$/ or last;
129 my $dir = <$TRACER_R>; chomp $dir;
130 my $name = <$TRACER_R>; chomp $name;
131
132 $pm{$name} = "$dir/$name";
133
134 print "+ found potential dependency $name\n"
135 if $VERBOSE >= 3;
136 }
137 }
138
139 sub trace_module {
140 print "tracing module $_[0]\n"
141 if $VERBOSE >= 2;
142
143 syswrite $TRACER_W, "use $_[0]\n";
144 trace_parse;
145 }
146
147 sub trace_eval {
148 print "tracing eval $_[0]\n"
149 if $VERBOSE >= 2;
150
151 syswrite $TRACER_W, "eval $_[0]\n";
152 trace_parse;
153 }
154
155 sub trace_finish {
156 close $TRACER_W;
157 close $TRACER_R;
158 }
159
160 #############################################################################
161 # now we can use modules
162
163 use common::sense;
164 use Config;
165 use Digest::MD5;
166
167 sub cache($$$) {
168 my ($variant, $src, $filter) = @_;
169
170 if (length $CACHE and 2048 <= length $src and defined $variant) {
171 my $file = "$CACHE/" . Digest::MD5::md5_hex "$CACHEVER\x00$variant\x00$src";
172
173 if (open my $fh, "<:raw:perlio", $file) {
174 print "using cache for $file\n"
175 if $VERBOSE >= 7;
176
177 local $/;
178 return <$fh>;
179 }
180
181 $src = $filter->($src);
182
183 print "creating cache entry $file\n"
184 if $VERBOSE >= 8;
185
186 if (open my $fh, ">:raw:perlio", "$file~") {
187 if ((syswrite $fh, $src) == length $src) {
188 close $fh;
189 rename "$file~", $file;
190 }
191 }
192
193 return $src;
194 }
195
196 $filter->($src)
197 }
198
199 sub dump_string {
200 my ($fh, $data) = @_;
201
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";
206 for (
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;
218 length (my $substr = substr $data, $ofs, 80);
219 $ofs += 80
220 ) {
221 $substr =~ s/([^\x20-\x21\x23-\x5b\x5d-\x7e])/sprintf "\\%03o", ord $1/ge;
222 $substr =~ s/\?/\\?/g; # trigraphs...
223 print $fh " \"$substr\"\n";
224 }
225 }
226 } else {
227 print $fh " \"\"\n";
228 }
229 }
230
231 #############################################################################
232
233 sub glob2re {
234 for (quotemeta $_[0]) {
235 s/\\\*/\x00/g;
236 s/\x00\x00/.*/g;
237 s/\x00/[^\/]*/g;
238 s/\\\?/[^\/]/g;
239
240 $_ = s/^\\\/// ? "^$_\$" : "(?:^|/)$_\$";
241
242 s/(?: \[\^\/\] | \. ) \*\$$//x;
243
244 return qr<$_>s
245 }
246 }
247
248 our %INCSKIP = (
249 "unicore/TestProp.pl" => undef, # 3.5MB of insanity, apparently just some testcase
250 );
251
252 sub get_dirtree {
253 my $root = shift;
254
255 my @tree;
256 my $skip;
257
258 my $scan; $scan = sub {
259 for (sort do {
260 opendir my $fh, $_[0]
261 or return;
262 readdir $fh
263 }) {
264 next if /^\./;
265
266 my $path = "$_[0]/$_";
267
268 if (-d "$path/.") {
269 $scan->($path);
270 } else {
271 $path = substr $path, $skip;
272 push @tree, $path
273 unless exists $INCSKIP{$path};
274 }
275 }
276 };
277
278 $root =~ s/\/$//;
279 $skip = 1 + length $root;
280 $scan->($root);
281
282 \@tree
283 }
284
285 my $inctrees;
286
287 sub get_inctrees {
288 unless ($inctrees) {
289 my %inctree;
290 $inctree{$_} ||= [$_, get_dirtree $_] # entries in @INC are often duplicates
291 for @INC;
292 $inctrees = [values %inctree];
293 }
294
295 @$inctrees
296 }
297
298 #############################################################################
299
300 sub cmd_boot {
301 $pm{"!boot"} = $_[0];
302 }
303
304 sub cmd_add {
305 $_[0] =~ /^(.*?)(?:\s+(\S+))?$/
306 or die "$_[0]: cannot parse";
307
308 my $file = $1;
309 my $as = defined $2 ? $2 : $1;
310
311 $pm{$as} = $file;
312 $pmbin{$as} = 1 if $_[1];
313 }
314
315 sub cmd_staticlib {
316 push @staticlibs, $_
317 for split /\s+/, $_[0];
318 }
319
320 sub cmd_include {
321 push @incext, [$_[1], glob2re $_[0]];
322 }
323
324 sub cmd_incglob {
325 my ($pattern) = @_;
326
327 $pattern = glob2re $pattern;
328
329 for (get_inctrees) {
330 my ($dir, $files) = @$_;
331
332 $pm{$_} = "$dir/$_"
333 for grep /$pattern/ && /\.(pl|pm)$/, @$files;
334 }
335 }
336
337 sub parse_argv;
338
339 sub cmd_file {
340 open my $fh, "<", $_[0]
341 or die "$_[0]: $!\n";
342
343 local @ARGV;
344
345 while (<$fh>) {
346 chomp;
347 next unless /\S/;
348 next if /^\s*#/;
349
350 s/^\s*-*/--/;
351 my ($cmd, $args) = split / /, $_, 2;
352
353 push @ARGV, $cmd;
354 push @ARGV, $args if defined $args;
355 }
356
357 parse_argv;
358 }
359
360 use Getopt::Long;
361
362 sub parse_argv {
363 GetOptions
364 "perl" => \$PERL,
365 "app=s" => \$APP,
366
367 "verbose|v" => sub { ++$VERBOSE },
368 "quiet|q" => sub { --$VERBOSE },
369
370 "strip=s" => \$STRIP,
371 "keepnl" => \$KEEPNL,
372 "compress=s" => \$COMPRESS,
373 "cache=s" => \$CACHE, # internal option
374 "eval|e=s" => sub { trace_eval $_[1] },
375 "use|M=s" => sub { trace_module $_[1] },
376 "boot=s" => sub { cmd_boot $_[1] },
377 "add=s" => sub { cmd_add $_[1], 0 },
378 "addbin=s" => sub { cmd_add $_[1], 1 },
379 "incglob=s" => sub { cmd_incglob $_[1] },
380 "include|i=s" => sub { cmd_include $_[1], 1 },
381 "exclude|x=s" => sub { cmd_include $_[1], 0 },
382 "usepacklists!" => \$PACKLIST,
383
384 "static!" => \$STATIC,
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
393 "<>" => sub { cmd_file $_[0] },
394 or exit 1;
395 }
396
397 Getopt::Long::Configure ("bundling", "no_auto_abbrev", "no_ignore_case");
398
399 parse_argv;
400
401 die "cannot specify both --app and --perl\n"
402 if $PERL and defined $APP;
403
404 die "--compress must be either none or lzf\n"
405 unless $COMPRESS =~ /^(?:none|lzf)\z/;
406
407 # required for @INC loading, unfortunately
408 trace_module "PerlIO::scalar";
409
410 #############################################################################
411 # apply include/exclude
412
413 {
414 my %pmi;
415
416 for (@incext) {
417 my ($inc, $glob) = @$_;
418
419 my @match = grep /$glob/, keys %pm;
420
421 if ($inc) {
422 # include
423 @pmi{@match} = delete @pm{@match};
424
425 print "applying include $glob - protected ", (scalar @match), " files.\n"
426 if $VERBOSE >= 5;
427 } else {
428 # exclude
429 delete @pm{@match};
430
431 print "applying exclude $glob - removed ", (scalar @match), " files.\n"
432 if $VERBOSE >= 5;
433 }
434 }
435
436 my @pmi = keys %pmi;
437 @pm{@pmi} = delete @pmi{@pmi};
438 }
439
440 #############################################################################
441 # scan for AutoLoader, static archives and other dependencies
442
443 sub scan_al {
444 my ($auto, $autodir) = @_;
445
446 my $ix = "$autodir/autosplit.ix";
447
448 print "processing autoload index for '$auto'\n"
449 if $VERBOSE >= 6;
450
451 $pm{"$auto/autosplit.ix"} = $ix;
452
453 open my $fh, "<:perlio", $ix
454 or die "$ix: $!";
455
456 my $package;
457
458 while (<$fh>) {
459 if (/^\s*sub\s+ ([^[:space:];]+) \s* (?:\([^)]*\))? \s*;?\s*$/x) {
460 my $al = "auto/$package/$1.al";
461 my $inc = find_inc $al;
462
463 defined $inc or die "$al: autoload file not found, but should be there.\n";
464
465 $pm{$al} = $inc;
466 print "found autoload function '$al'\n"
467 if $VERBOSE >= 6;
468
469 } elsif (/^\s*package\s+([^[:space:];]+)\s*;?\s*$/) {
470 ($package = $1) =~ s/::/\//g;
471 } elsif (/^\s*(?:#|1?\s*;?\s*$)/) {
472 # nop
473 } else {
474 warn "WARNING: $ix: unparsable line, please report: $_";
475 }
476 }
477 }
478
479 for my $pm (keys %pm) {
480 if ($pm =~ /^(.*)\.pm$/) {
481 my $auto = "auto/$1";
482 my $autodir = find_inc $auto;
483
484 if (defined $autodir && -d $autodir) {
485 # AutoLoader
486 scan_al $auto, $autodir
487 if -f "$autodir/autosplit.ix";
488
489 # extralibs.ld
490 if (open my $fh, "<:perlio", "$autodir/extralibs.ld") {
491 print "found extralibs for $pm\n"
492 if $VERBOSE >= 6;
493
494 local $/;
495 $extralibs .= " " . <$fh>;
496 }
497
498 $pm =~ /([^\/]+).pm$/ or die "$pm: unable to match last component";
499
500 my $base = $1;
501
502 # static ext
503 if (-f "$autodir/$base$Config{_a}") {
504 print "found static archive for $pm\n"
505 if $VERBOSE >= 3;
506
507 push @libs, "$autodir/$base$Config{_a}";
508 push @static_ext, $pm;
509 }
510
511 # dynamic object
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 }
526
527 if ($PACKLIST && open my $fh, "<:perlio", "$autodir/.packlist") {
528 print "found .packlist for $pm\n"
529 if $VERBOSE >= 3;
530
531 while (<$fh>) {
532 chomp;
533 s/ .*$//; # newer-style .packlists might contain key=value pairs
534
535 # only include certain files (.al, .ix, .pm, .pl)
536 if (/\.(pm|pl|al|ix)$/) {
537 for my $inc (@INC) {
538 # in addition, we only add files that are below some @INC path
539 $inc =~ s/\/*$/\//;
540
541 if ($inc eq substr $_, 0, length $inc) {
542 my $base = substr $_, length $inc;
543 $pm{$base} = $_;
544
545 print "+ added .packlist dependency $base\n"
546 if $VERBOSE >= 3;
547 }
548
549 last;
550 }
551 }
552 }
553 }
554 }
555 }
556 }
557
558 #############################################################################
559
560 print "processing bundle files (try more -v power if you get bored waiting here)...\n"
561 if $VERBOSE >= 1;
562
563 my $compress = sub { shift };
564
565 if ($COMPRESS eq "lzf") {
566 require Compress::LZF;
567 $compress = sub { Compress::LZF::compress_best (shift) };
568 }
569
570 my $data;
571 my @index;
572 my @order = sort {
573 length $a <=> length $b
574 or $a cmp $b
575 } keys %pm;
576
577 # sorting by name - better compression, but needs more metadata
578 # sorting by length - faster lookup
579 # usually, the metadata overhead beats the loss through compression
580
581 for my $pm (@order) {
582 my $path = $pm{$pm};
583
584 128 > length $pm
585 or die "ERROR: $pm: path too long (only 128 octets supported)\n";
586
587 my $src = ref $path
588 ? $$path
589 : do {
590 open my $pm, "<:raw:perlio", $path
591 or die "$path: $!";
592
593 local $/;
594
595 <$pm>
596 };
597
598 my $size = length $src;
599
600 unless ($pmbin{$pm}) { # only do this unless the file is binary
601 if ($pm =~ /^auto\/POSIX\/[^\/]+\.al$/) {
602 if ($src =~ /^ unimpl \"/m) {
603 print "$pm: skipping (raises runtime error only).\n"
604 if $VERBOSE >= 3;
605 next;
606 }
607 }
608
609 $src = cache "$STRIP,$UNISTRIP,$KEEPNL,$OPTIMISE_SIZE,$COMPRESS", $src, sub {
610 if ($UNISTRIP && $pm =~ /^unicore\/.*\.pl$/) {
611 print "applying unicore stripping $pm\n"
612 if $VERBOSE >= 6;
613
614 # special stripping for unicore swashes and properties
615 # much more could be done by going binary
616 $src =~ s{
617 (^return\ <<'END';\n) (.*?\n) (END(?:\n|\Z))
618 }{
619 my ($pre, $data, $post) = ($1, $2, $3);
620
621 for ($data) {
622 s/^([0-9a-fA-F]+)\t([0-9a-fA-F]+)\t/sprintf "%X\t%X", hex $1, hex $2/gem
623 if $OPTIMISE_SIZE;
624
625 # s{
626 # ^([0-9a-fA-F]+)\t([0-9a-fA-F]*)\t
627 # }{
628 # # ww - smaller filesize, UU - compress better
629 # pack "C0UU",
630 # hex $1,
631 # length $2 ? (hex $2) - (hex $1) : 0
632 # }gemx;
633
634 s/#.*\n/\n/mg;
635 s/\s+\n/\n/mg;
636 }
637
638 "$pre$data$post"
639 }smex;
640 }
641
642 if ($STRIP =~ /ppi/i) {
643 require PPI;
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
648 if (my $ppi = PPI::Document->new (\$src)) {
649 for my $node (
650 @{ $ppi->find (PPI::Token::Comment::) },
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 }
660
661 # prune END stuff
662 for (my $last = $ppi->last_element; $last; ) {
663 my $prev = $last->previous_token;
664
665 if ($last->isa (PPI::Token::Whitespace::)) {
666 $last->delete;
667 } elsif ($last->isa (PPI::Statement::End::)) {
668 $last->delete;
669 last;
670 } elsif ($last->isa (PPI::Token::Pod::)) {
671 $last->delete;
672 } elsif ($last->isa (PPI::Token::Comment::)) {
673 $last->delete;
674 } else {
675 last;
676 }
677
678 $last = $prev;
679 }
680
681 # prune some but not all insignificant whitespace
682 for my $ws (@{ $ppi->find (PPI::Token::Whitespace::) }) {
683 my $prev = $ws->previous_token;
684 my $next = $ws->next_token;
685
686 if (!$prev || !$next) {
687 $ws->delete;
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 (
694 (
695 $next->isa (PPI::Token::Operator::) && $next->{content} =~ /^(?:,|=|!|!=|==|=>)$/ # no ., because of digits. == float
696 or $prev->isa (PPI::Token::Operator::) && $prev->{content} =~ /^(?:,|=|\.|!|!=|==|=>)$/
697 or $prev->isa (PPI::Token::Structure::)
698 or ($OPTIMISE_SIZE &&
699 ($prev->isa (PPI::Token::Word::)
700 && (PPI::Token::Symbol:: eq ref $next
701 || $next->isa (PPI::Structure::Block::)
702 || $next->isa (PPI::Structure::List::)
703 || $next->isa (PPI::Structure::Condition::)))
704 )
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 )
712 ) {
713 if ($KEEPNL) {
714 $ws->{content} =~ s/[^\n]//g;
715 } else {
716 $ws->{content} = '';
717 }
718 } else {
719 if ($KEEPNL) {
720 $ws->{content} =~ s/[^\n]//g;
721 $ws->{content} ||= ' '; # keep at least one space
722 } else {
723 $ws->{content} = ' ';
724 }
725 }
726 }
727 }
728
729 # prune whitespace around blocks
730 if ($OPTIMISE_SIZE) {
731 # these usually decrease size, but decrease compressability more
732 for my $struct (PPI::Structure::Block::, PPI::Structure::Condition::) {
733 for my $node (@{ $ppi->find ($struct) }) {
734 my $n1 = $node->first_token;
735 my $n2 = $n1->previous_token;
736 $n1->delete if $n1->isa (PPI::Token::Whitespace::);
737 $n2->delete if $n2 && $n2->isa (PPI::Token::Whitespace::);
738 my $n1 = $node->last_token;
739 my $n2 = $n1->next_token;
740 $n1->delete if $n1->isa (PPI::Token::Whitespace::);
741 $n2->delete if $n2 && $n2->isa (PPI::Token::Whitespace::);
742 }
743 }
744
745 for my $node (@{ $ppi->find (PPI::Structure::List::) }) {
746 my $n1 = $node->first_token;
747 $n1->delete if $n1->isa (PPI::Token::Whitespace::);
748 my $n1 = $node->last_token;
749 $n1->delete if $n1->isa (PPI::Token::Whitespace::);
750 }
751 }
752
753 # reformat qw() lists which often have lots of whitespace
754 for my $node (@{ $ppi->find (PPI::Token::QuoteLike::Words::) }) {
755 if ($node->{content} =~ /^qw(.)(.*)(.)$/s) {
756 my ($a, $qw, $b) = ($1, $2, $3);
757 $qw =~ s/^\s+//;
758 $qw =~ s/\s+$//;
759 $qw =~ s/\s+/ /g;
760 $node->{content} = "qw$a$qw$b";
761 }
762 }
763
764 $src = $ppi->serialize;
765 } else {
766 warn "WARNING: $pm{$pm}: PPI failed to parse this file\n";
767 }
768 } elsif ($STRIP =~ /pod/i && $pm ne "Opcode.pm") { # opcode parses its own pod
769 require Pod::Strip;
770
771 my $stripper = Pod::Strip->new;
772
773 my $out;
774 $stripper->output_string (\$out);
775 $stripper->parse_string_document ($src)
776 or die;
777 $src = $out;
778 }
779
780 if ($VERIFY && $pm =~ /\.pm$/ && $pm ne "Opcode.pm") {
781 if (open my $fh, "-|") {
782 <$fh>;
783 } else {
784 eval "#line 1 \"$pm\"\n$src" or warn "\n\n\n$pm\n\n$src\n$@\n\n\n";
785 exit 0;
786 }
787 }
788
789 $src
790 };
791
792 # if ($pm eq "Opcode.pm") {
793 # open my $fh, ">x" or die; print $fh $src;#d#
794 # exit 1;
795 # }
796 }
797
798 $src = $compress->($src); # maybe this should be cached, as well
799
800 print "adding $pm (original size $size, stored size ", length $src, ")\n"
801 if $VERBOSE >= 2;
802
803 push @index, ((length $pm) << 25) | length $data;
804 $data .= $pm . $src;
805 }
806
807 length $data < 2**25
808 or die "ERROR: bundle too large (only 32MB supported)\n";
809
810 my $varpfx = "bundle";
811
812 #############################################################################
813 # output
814
815 print "generating $PREFIX.h... "
816 if $VERBOSE >= 1;
817
818 {
819 open my $fh, ">", "$PREFIX.h"
820 or die "$PREFIX.h: $!\n";
821
822 print $fh <<EOF;
823 /* do not edit, automatically created by staticperl */
824
825 #include <EXTERN.h>
826 #include <perl.h>
827 #include <XSUB.h>
828
829 /* public API */
830 EXTERN_C PerlInterpreter *staticperl;
831 EXTERN_C void staticperl_xs_init (pTHX);
832 EXTERN_C void staticperl_init (XSINIT_t xs_init); /* argument can be 0 */
833 EXTERN_C void staticperl_cleanup (void);
834
835 EOF
836 }
837
838 print "\n"
839 if $VERBOSE >= 1;
840
841 #############################################################################
842 # output
843
844 print "generating $PREFIX.c... "
845 if $VERBOSE >= 1;
846
847 open my $fh, ">", "$PREFIX.c"
848 or die "$PREFIX.c: $!\n";
849
850 print $fh <<EOF;
851 /* do not edit, automatically created by staticperl */
852
853 #include "bundle.h"
854
855 /* public API */
856 PerlInterpreter *staticperl;
857
858 EOF
859
860 #############################################################################
861 # lzf decompressor
862
863 if ($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
874 static unsigned int
875 lzf_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
933 static SV *
934 static_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
961 EOF
962 } else {
963 print $fh <<EOF;
964
965 #define static_to_sv(ptr,len) newSVpvn (ptr, len)
966
967 EOF
968 }
969
970 #############################################################################
971 # bundle data
972
973 my $count = @index;
974
975 print $fh <<EOF;
976 #include "bundle.h"
977
978 /* bundle data */
979
980 static const U32 $varpfx\_count = $count;
981 static const U32 $varpfx\_index [$count + 1] = {
982 EOF
983
984 my $col;
985 for (@index) {
986 printf $fh "0x%08x,", $_;
987 print $fh "\n" unless ++$col % 10;
988
989 }
990 printf $fh "0x%08x\n};\n", (length $data);
991
992 print $fh "static const char $varpfx\_data [] =\n";
993 dump_string $fh, $data;
994
995 print $fh ";\n\n";
996
997 #############################################################################
998 # bootstrap
999
1000 # boot file for staticperl
1001 # this file will be eval'ed at initialisation time
1002
1003 # lines marked with "^D" are only used when $HAVE_DYNAMIC
1004 my $bootstrap = '
1005 BEGIN {
1006 package ' . $PACKAGE . ';
1007
1008 # the path prefix to use when putting files into %INC
1009 our $inc_prefix;
1010
1011 # the @INC hook to use when we have PerlIO::scalar available
1012 my $perlio_inc = sub {
1013 my $data = find "$_[1]"
1014 or return;
1015
1016 $INC{$_[1]} = "$inc_prefix$_[1]";
1017
1018 open my $fh, "<", \$data;
1019 $fh
1020 };
1021
1022 D if (defined &PerlIO::scalar::bootstrap) {
1023 # PerlIO::scalar statically compiled in
1024 PerlIO::scalar->bootstrap;
1025 @INC = $perlio_inc;
1026 D } else {
1027 D # PerlIO::scalar not available, use slower method
1028 D @INC = sub {
1029 D # always check if PerlIO::scalar might now be available
1030 D if (defined &PerlIO::scalar::bootstrap) {
1031 D # switch to the faster perlio_inc hook
1032 D @INC = map { $_ == $_[0] ? $perlio_inc : $_ } @INC;
1033 D goto &$perlio_inc;
1034 D }
1035 D
1036 D my $data = find "$_[1]"
1037 D or return;
1038 D
1039 D $INC{$_[1]} = "$inc_prefix$_[1]";
1040 D
1041 D sub {
1042 D $data =~ /\G([^\n]*\n?)/g
1043 D or return;
1044 D
1045 D $_ = $1;
1046 D 1
1047 D }
1048 D };
1049 D }
1050 }
1051 ';
1052
1053 $bootstrap .= "require '!boot';"
1054 if exists $pm{"!boot"};
1055
1056 if ($HAVE_DYNAMIC) {
1057 $bootstrap =~ s/^D/ /mg;
1058 } else {
1059 $bootstrap =~ s/^D.*$//mg;
1060 }
1061
1062 $bootstrap =~ s/#.*$//mg;
1063 $bootstrap =~ s/\s+/ /g;
1064 $bootstrap =~ s/(\W) /$1/g;
1065 $bootstrap =~ s/ (\W)/$1/g;
1066
1067 print $fh "const char bootstrap [] = ";
1068 dump_string $fh, $bootstrap;
1069 print $fh ";\n\n";
1070
1071 print $fh <<EOF;
1072 /* search all bundles for the given file, using binary search */
1073 XS(find)
1074 {
1075 dXSARGS;
1076
1077 if (items != 1)
1078 Perl_croak (aTHX_ "Usage: $PACKAGE\::find (\$path)");
1079
1080 {
1081 STRLEN namelen;
1082 char *name = SvPV (ST (0), namelen);
1083 SV *res = 0;
1084
1085 int l = 0, r = $varpfx\_count;
1086
1087 while (l <= r)
1088 {
1089 int m = (l + r) >> 1;
1090 U32 idx = $varpfx\_index [m];
1091 int comp = namelen - (idx >> 25);
1092
1093 if (!comp)
1094 {
1095 int ofs = idx & 0x1FFFFFFU;
1096 comp = memcmp (name, $varpfx\_data + ofs, namelen);
1097
1098 if (!comp)
1099 {
1100 /* found */
1101 int ofs2 = $varpfx\_index [m + 1] & 0x1FFFFFFU;
1102
1103 ofs += namelen;
1104 res = static_to_sv ($varpfx\_data + ofs, ofs2 - ofs);
1105 goto found;
1106 }
1107 }
1108
1109 if (comp < 0)
1110 r = m - 1;
1111 else
1112 l = m + 1;
1113 }
1114
1115 XSRETURN (0);
1116
1117 found:
1118 ST (0) = sv_2mortal (res);
1119 }
1120
1121 XSRETURN (1);
1122 }
1123
1124 /* list all files in the bundle */
1125 XS(list)
1126 {
1127 dXSARGS;
1128
1129 if (items != 0)
1130 Perl_croak (aTHX_ "Usage: $PACKAGE\::list");
1131
1132 {
1133 int i;
1134
1135 EXTEND (SP, $varpfx\_count);
1136
1137 for (i = 0; i < $varpfx\_count; ++i)
1138 {
1139 U32 idx = $varpfx\_index [i];
1140
1141 PUSHs (sv_2mortal (newSVpvn ($varpfx\_data + (idx & 0x1FFFFFFU), idx >> 25)));
1142 }
1143 }
1144
1145 XSRETURN ($varpfx\_count);
1146 }
1147
1148 #ifdef STATICPERL_BUNDLE_INCLUDE
1149 #include STATICPERL_BUNDLE_INCLUDE
1150 #endif
1151
1152 EOF
1153
1154 #############################################################################
1155 # xs_init
1156
1157 print $fh <<EOF;
1158 void
1159 staticperl_xs_init (pTHX)
1160 {
1161 EOF
1162
1163 @static_ext = sort @static_ext;
1164
1165 # prototypes
1166 for (@static_ext) {
1167 s/\.pm$//;
1168 (my $cname = $_) =~ s/\//__/g;
1169 print $fh " EXTERN_C void boot_$cname (pTHX_ CV* cv);\n";
1170 }
1171
1172 print $fh <<EOF;
1173 char *file = __FILE__;
1174 dXSUB_SYS;
1175
1176 newXSproto ("$PACKAGE\::find", find, file, "\$");
1177 newXSproto ("$PACKAGE\::list", list, file, "");
1178
1179 #ifdef STATICPERL_BUNDLE_XS_INIT
1180 STATICPERL_BUNDLE_XS_INIT;
1181 #endif
1182 EOF
1183
1184 # calls
1185 for (@static_ext) {
1186 s/\.pm$//;
1187
1188 (my $cname = $_) =~ s/\//__/g;
1189 (my $pname = $_) =~ s/\//::/g;
1190
1191 my $bootstrap = $pname eq "DynaLoader" ? "boot_DynaLoader" : "bootstrap";
1192
1193 print $fh " newXS (\"$pname\::$bootstrap\", boot_$cname, file);\n";
1194 }
1195
1196 print $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
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);
1215 }
1216 EOF
1217
1218 #############################################################################
1219 # optional perl_init/perl_destroy
1220
1221 if ($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");
1232 EOF
1233 } else {
1234 $IGNORE_ENV = "";
1235 }
1236
1237 if ($APP) {
1238 print $fh <<EOF;
1239
1240 int
1241 main (int argc, char *argv [])
1242 {
1243 extern char **environ;
1244 int i, exitstatus;
1245 char **args = malloc ((argc + 3) * sizeof (const char *));
1246
1247 args [0] = argv [0];
1248 args [1] = "-e";
1249 args [2] = "0";
1250 args [3] = "--";
1251
1252 for (i = 1; i < argc; ++i)
1253 args [i + 3] = argv [i];
1254
1255 $IGNORE_ENV
1256 PERL_SYS_INIT3 (&argc, &argv, &environ);
1257 staticperl = perl_alloc ();
1258 perl_construct (staticperl);
1259
1260 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
1261
1262 exitstatus = perl_parse (staticperl, staticperl_xs_init, argc + 3, args, environ);
1263 if (!exitstatus)
1264 perl_run (staticperl);
1265
1266 exitstatus = perl_destruct (staticperl);
1267 perl_free (staticperl);
1268 PERL_SYS_TERM ();
1269 /*free (args); no point doing it this late */
1270
1271 return exitstatus;
1272 }
1273 EOF
1274 } elsif ($PERL) {
1275 print $fh <<EOF;
1276
1277 int
1278 main (int argc, char *argv [])
1279 {
1280 extern char **environ;
1281 int exitstatus;
1282
1283 $IGNORE_ENV
1284 PERL_SYS_INIT3 (&argc, &argv, &environ);
1285 staticperl = perl_alloc ();
1286 perl_construct (staticperl);
1287
1288 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
1289
1290 exitstatus = perl_parse (staticperl, staticperl_xs_init, argc, argv, environ);
1291 if (!exitstatus)
1292 perl_run (staticperl);
1293
1294 exitstatus = perl_destruct (staticperl);
1295 perl_free (staticperl);
1296 PERL_SYS_TERM ();
1297
1298 return exitstatus;
1299 }
1300 EOF
1301 } else {
1302 print $fh <<EOF;
1303
1304 EXTERN_C void
1305 staticperl_init (XSINIT_t xs_init)
1306 {
1307 static char *args[] = {
1308 "staticperl",
1309 "-e",
1310 "0"
1311 };
1312
1313 extern char **environ;
1314 int argc = sizeof (args) / sizeof (args [0]);
1315 char **argv = args;
1316
1317 $IGNORE_ENV
1318 PERL_SYS_INIT3 (&argc, &argv, &environ);
1319 staticperl = perl_alloc ();
1320 perl_construct (staticperl);
1321 PL_origalen = 1;
1322 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
1323 PL_oldname = (char *)xs_init;
1324 perl_parse (staticperl, staticperl_xs_init, argc, argv, environ);
1325
1326 perl_run (staticperl);
1327 }
1328
1329 EXTERN_C void
1330 staticperl_cleanup (void)
1331 {
1332 perl_destruct (staticperl);
1333 perl_free (staticperl);
1334 staticperl = 0;
1335 PERL_SYS_TERM ();
1336 }
1337 EOF
1338 }
1339
1340 close $fh;
1341
1342 print -s "$PREFIX.c", " octets (", (length $data) , " data octets).\n\n"
1343 if $VERBOSE >= 1;
1344
1345 #############################################################################
1346 # libs, cflags
1347
1348 my $ccopts;
1349
1350 {
1351 print "generating $PREFIX.ccopts... "
1352 if $VERBOSE >= 1;
1353
1354 $ccopts = "$Config{ccflags} $Config{optimize} $Config{cppflags} -I$Config{archlibexp}/CORE $EXTRA_CFLAGS";
1355 $ccopts =~ s/([\(\)])/\\$1/g;
1356
1357 open my $fh, ">$PREFIX.ccopts"
1358 or die "$PREFIX.ccopts: $!";
1359 print $fh $ccopts;
1360
1361 print "$ccopts\n\n"
1362 if $VERBOSE >= 1;
1363 }
1364
1365 my $ldopts;
1366
1367 {
1368 print "generating $PREFIX.ldopts... ";
1369
1370 $ldopts = $STATIC ? "-static " : "";
1371
1372 $ldopts .= "$Config{ccdlflags} $Config{ldflags} $EXTRA_LDFLAGS @libs $Config{archlibexp}/CORE/$Config{libperl} $Config{perllibs} $EXTRA_LIBS";
1373
1374 my %seen;
1375 $ldopts .= " $_" for reverse grep !$seen{$_}++, reverse +($extralibs =~ /(\S+)/g);
1376
1377 for (@staticlibs) {
1378 $ldopts =~ s/(^|\s) (-l\Q$_\E) ($|\s)/$1-Wl,-Bstatic $2 -Wl,-Bdynamic$3/gx;
1379 }
1380
1381 $ldopts =~ s/([\(\)])/\\$1/g;
1382
1383 open my $fh, ">$PREFIX.ldopts"
1384 or die "$PREFIX.ldopts: $!";
1385 print $fh $ldopts;
1386
1387 print "$ldopts\n\n"
1388 if $VERBOSE >= 1;
1389 }
1390
1391 if ($PERL or defined $APP) {
1392 $APP = "perl" unless defined $APP;
1393
1394 my $build = "$Config{cc} $ccopts -o \Q$APP\E$Config{_exe} bundle.c $ldopts";
1395
1396 print "build $APP...\n"
1397 if $VERBOSE >= 1;
1398
1399 print "$build\n"
1400 if $VERBOSE >= 2;
1401
1402 system $build;
1403
1404 unlink "$PREFIX.$_"
1405 for qw(ccopts ldopts c h);
1406
1407 print "\n"
1408 if $VERBOSE >= 1;
1409 }
1410