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

Comparing App-Staticperl/mkbundle (file contents):
Revision 1.4 by root, Mon Dec 6 21:10:41 2010 UTC vs.
Revision 1.16 by root, Thu Jan 20 21:32:47 2011 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 $UNISTRIP = 1; # always on, try to strip unicore swash data
8our $PERL = 0; 9our $PERL = 0;
10our $APP;
9our $VERIFY = 0; 11our $VERIFY = 0;
10our $STATIC = 0; 12our $STATIC = 0;
13our $PACKLIST = 0;
14
15our $OPTIMISE_SIZE = 0; # optimise for raw file size instead of for compression?
16
17our $CACHE;
18our $CACHEVER = 1; # do not change unless you know what you are doing
11 19
12my $PREFIX = "bundle"; 20my $PREFIX = "bundle";
13my $PACKAGE = "static"; 21my $PACKAGE = "static";
14 22
15my %pm; 23my %pm;
24my %pmbin;
16my @libs; 25my @libs;
17my @static_ext; 26my @static_ext;
18my $extralibs; 27my $extralibs;
28my @staticlibs;
29my @incext;
19 30
20@ARGV 31@ARGV
21 or die "$0: use 'staticperl help' (or read the sources of staticperl)\n"; 32 or die "$0: use 'staticperl help' (or read the sources of staticperl)\n";
22 33
34# remove "." from @INC - staticperl.sh does it for us, but be on the safe side
35BEGIN { @INC = grep !/^\.$/, @INC }
36
23$|=1; 37$|=1;
24 38
25our ($TRACER_W, $TRACER_R); 39our ($TRACER_W, $TRACER_R);
26 40
27sub find_inc($) { 41sub find_incdir($) {
28 for (@INC) { 42 for (@INC) {
29 next if ref; 43 next if ref;
30 return $_ if -e "$_/$_[0]"; 44 return $_ if -e "$_/$_[0]";
31 } 45 }
32 46
33 undef 47 undef
34} 48}
35 49
50sub find_inc($) {
51 my $dir = find_incdir $_[0];
52
53 return "$dir/$_[0]"
54 if defined $dir;
55
56 undef
57}
58
36BEGIN { 59BEGIN {
37 # create a loader process to detect @INC requests before we load any modules 60 # create a loader process to detect @INC requests before we load any modules
38 my ($W_TRACER, $R_TRACER); # used by tracer 61 my ($W_TRACER, $R_TRACER); # used by tracer
39 62
40 pipe $R_TRACER, $TRACER_W or die "pipe: $!"; 63 pipe $R_TRACER, $TRACER_W or die "pipe: $!";
… …
42 65
43 unless (fork) { 66 unless (fork) {
44 close $TRACER_R; 67 close $TRACER_R;
45 close $TRACER_W; 68 close $TRACER_W;
46 69
70 my $pkg = "pkg000000";
71
47 unshift @INC, sub { 72 unshift @INC, sub {
48 my $dir = find_inc $_[1] 73 my $dir = find_incdir $_[1]
49 or return; 74 or return;
50 75
51 syswrite $W_TRACER, "-\n$dir\n$_[1]\n"; 76 syswrite $W_TRACER, "-\n$dir\n$_[1]\n";
52 77
53 open my $fh, "<:perlio", "$dir/$_[1]" 78 open my $fh, "<:perlio", "$dir/$_[1]"
… …
57 }; 82 };
58 83
59 while (<$R_TRACER>) { 84 while (<$R_TRACER>) {
60 if (/use (.*)$/) { 85 if (/use (.*)$/) {
61 my $mod = $1; 86 my $mod = $1;
62 eval "require $mod"; 87 my $pkg = ++$pkg;
88 eval "{ package $pkg; use $mod; }";
63 warn "ERROR: $@ (while loading '$mod')\n" 89 warn "ERROR: $@ (while loading '$mod')\n"
64 if $@; 90 if $@;
65 syswrite $W_TRACER, "\n";
66 } elsif (/eval (.*)$/) { 91 } elsif (/eval (.*)$/) {
67 my $eval = $1; 92 my $eval = $1;
68 eval $eval; 93 eval $eval;
69 warn "ERROR: $@ (in '$eval')\n" 94 warn "ERROR: $@ (in '$eval')\n"
70 if $@; 95 if $@;
71 } 96 }
97
98 syswrite $W_TRACER, "\n";
72 } 99 }
73 100
74 exit 0; 101 exit 0;
75 } 102 }
76} 103}
77 104
78# module loading is now safe 105# module loading is now safe
79use Config;
80 106
81sub trace_module { 107sub trace_parse {
82 syswrite $TRACER_W, "use $_[0]\n";
83
84 for (;;) { 108 for (;;) {
85 <$TRACER_R> =~ /^-$/ or last; 109 <$TRACER_R> =~ /^-$/ or last;
86 my $dir = <$TRACER_R>; chomp $dir; 110 my $dir = <$TRACER_R>; chomp $dir;
87 my $name = <$TRACER_R>; chomp $name; 111 my $name = <$TRACER_R>; chomp $name;
88 112
89 $pm{$name} = "$dir/$name"; 113 $pm{$name} = "$dir/$name";
90 114
91 if ($name =~ /^(.*)\.pm$/) { 115 print "+ found potential dependency $name\n"
92 my $auto = "auto/$1"; 116 if $VERBOSE >= 3;
93 my $autodir = "$dir/$auto";
94
95 if (-d $autodir) {
96 opendir my $dir, $autodir
97 or die "$autodir: $!\n";
98
99 for (readdir $dir) {
100 # AutoLoader
101 $pm{"$auto/$_"} = "$autodir/$_"
102 if /\.(?:al|ix)$/;
103
104 # static ext
105 if (/\Q$Config{_a}\E$/o) {
106 push @libs, "$autodir/$_";
107 push @static_ext, $name;
108 }
109
110 # extralibs.ld
111 if ($_ eq "extralibs.ld") {
112 open my $fh, "<:perlio", "$autodir/$_"
113 or die "$autodir/$_";
114
115 local $/;
116 $extralibs .= " " . <$fh>;
117 }
118
119 # dynamic object
120 warn "WARNING: found shared object - can't link statically ($_)\n"
121 if /\.\Q$Config{dlext}\E$/o;
122
123 #TODO: extralibs?
124 }
125 }
126 }
127 } 117 }
118}
119
120sub trace_module {
121 print "tracing module $_[0]\n"
122 if $VERBOSE >= 2;
123
124 syswrite $TRACER_W, "use $_[0]\n";
125 trace_parse;
128} 126}
129 127
130sub trace_eval { 128sub trace_eval {
129 print "tracing eval $_[0]\n"
130 if $VERBOSE >= 2;
131
131 syswrite $TRACER_W, "eval $_[0]\n"; 132 syswrite $TRACER_W, "eval $_[0]\n";
133 trace_parse;
132} 134}
133 135
134sub trace_finish { 136sub trace_finish {
135 close $TRACER_W; 137 close $TRACER_W;
136 close $TRACER_R; 138 close $TRACER_R;
… …
138 140
139############################################################################# 141#############################################################################
140# now we can use modules 142# now we can use modules
141 143
142use common::sense; 144use common::sense;
145use Config;
143use Digest::MD5; 146use Digest::MD5;
147
148sub cache($$$) {
149 my ($variant, $src, $filter) = @_;
150
151 if (length $CACHE and 2048 <= length $src and defined $variant) {
152 my $file = "$CACHE/" . Digest::MD5::md5_hex "$CACHEVER\x00$variant\x00$src";
153
154 if (open my $fh, "<:perlio", $file) {
155 print "using cache for $file\n"
156 if $VERBOSE >= 7;
157
158 local $/;
159 return <$fh>;
160 }
161
162 $src = $filter->($src);
163
164 print "creating cache entry $file\n"
165 if $VERBOSE >= 8;
166
167 if (open my $fh, ">:perlio", "$file~") {
168 if ((syswrite $fh, $src) == length $src) {
169 close $fh;
170 rename "$file~", $file;
171 }
172 }
173
174 return $src;
175 }
176
177 $filter->($src)
178}
144 179
145sub dump_string { 180sub dump_string {
146 my ($fh, $data) = @_; 181 my ($fh, $data) = @_;
147 182
148 if (length $data) { 183 if (length $data) {
… …
158 } else { 193 } else {
159 print $fh " \"\"\n"; 194 print $fh " \"\"\n";
160 } 195 }
161} 196}
162 197
163# required for @INC loading, unfortunately 198#############################################################################
164trace_module "PerlIO::scalar";
165 199
166#trace_module "Term::ReadLine::readline"; # Term::ReadLine::Perl dependency 200sub glob2re {
167# URI is difficult 201 for (quotemeta $_[0]) {
168#trace_module "URI::http"; 202 s/\\\*/\x00/g;
169#trace_module "URI::_generic"; 203 s/\x00\x00/.*/g;
204 s/\x00/[^\/]*/g;
205 s/\\\?/[^\/]/g;
206
207 $_ = s/^\\\/// ? "^$_\$" : "(?:^|/)$_\$";
208
209 s/(?: \[\^\/\] | \. ) \*\$$//x;
210
211 return qr<$_>s
212 }
213}
214
215our %INCSKIP = (
216 "unicore/TestProp.pl" => undef, # 3.5MB of insanity, apparently just some testcase
217);
218
219sub get_dirtree {
220 my $root = shift;
221
222 my @tree;
223 my $skip;
224
225 my $scan; $scan = sub {
226 for (sort do {
227 opendir my $fh, $_[0]
228 or return;
229 readdir $fh
230 }) {
231 next if /^\./;
232
233 my $path = "$_[0]/$_";
234
235 if (-d "$path/.") {
236 $scan->($path);
237 } else {
238 $path = substr $path, $skip;
239 push @tree, $path
240 unless exists $INCSKIP{$path};
241 }
242 }
243 };
244
245 $root =~ s/\/$//;
246 $skip = 1 + length $root;
247 $scan->($root);
248
249 \@tree
250}
251
252my $inctrees;
253
254sub get_inctrees {
255 unless ($inctrees) {
256 my %inctree;
257 $inctree{$_} ||= [$_, get_dirtree $_] # entries in @INC are often duplicates
258 for @INC;
259 $inctrees = [values %inctree];
260 }
261
262 @$inctrees
263}
264
265#############################################################################
170 266
171sub cmd_boot { 267sub cmd_boot {
172 $pm{"//boot"} = $_[0]; 268 $pm{"//boot"} = $_[0];
173} 269}
174 270
… …
178 274
179 my $file = $1; 275 my $file = $1;
180 my $as = defined $2 ? $2 : "/$1"; 276 my $as = defined $2 ? $2 : "/$1";
181 277
182 $pm{$as} = $file; 278 $pm{$as} = $file;
279 $pmbin{$as} = 1 if $_[1];
183} 280}
281
282sub cmd_staticlib {
283 push @staticlibs, $_
284 for split /\s+/, $_[0];
285}
286
287sub cmd_include {
288 push @incext, [$_[1], glob2re $_[0]];
289}
290
291sub cmd_incglob {
292 my ($pattern) = @_;
293
294 $pattern = glob2re $pattern;
295
296 for (get_inctrees) {
297 my ($dir, $files) = @$_;
298
299 $pm{$_} = "$dir/$_"
300 for grep /$pattern/ && /\.(pl|pm)$/, @$files;
301 }
302}
303
304sub parse_argv;
184 305
185sub cmd_file { 306sub cmd_file {
186 open my $fh, "<", $_[0] 307 open my $fh, "<", $_[0]
187 or die "$_[0]: $!\n"; 308 or die "$_[0]: $!\n";
188 309
310 local @ARGV;
311
189 while (<$fh>) { 312 while (<$fh>) {
190 chomp; 313 chomp;
314 next unless /\S/;
315 next if /^\s*#/;
316
317 s/^\s*-*/--/;
191 my ($cmd, $args) = split / /, $_, 2; 318 my ($cmd, $args) = split / /, $_, 2;
192 $cmd =~ s/^-+//;
193 319
194 if ($cmd eq "strip") { 320 push @ARGV, $cmd;
195 $STRIP = $args; 321 push @ARGV, $args if defined $args;
196 } elsif ($cmd eq "eval") { 322 }
197 trace_eval $_; 323
198 } elsif ($cmd eq "use") { 324 parse_argv;
199 trace_module $_ 325}
200 for split / /, $args; 326
201 } elsif ($cmd eq "boot") { 327use Getopt::Long;
202 cmd_boot $args; 328
203 } elsif ($cmd eq "static") { 329sub parse_argv {
204 $STATIC = 1; 330 GetOptions
205 } elsif ($cmd eq "add") { 331 "strip=s" => \$STRIP,
206 cmd_add $args; 332 "cache=s" => \$CACHE, # internal option
207 } elsif (/^\s*#/) { 333 "verbose|v" => sub { ++$VERBOSE },
208 # comment 334 "quiet|q" => sub { --$VERBOSE },
209 } elsif (/\S/) { 335 "perl" => \$PERL,
210 die "$_: unsupported directive\n"; 336 "app=s" => \$APP,
337 "eval|e=s" => sub { trace_eval $_[1] },
338 "use|M=s" => sub { trace_module $_[1] },
339 "boot=s" => sub { cmd_boot $_[1] },
340 "add=s" => sub { cmd_add $_[1], 0 },
341 "addbin=s" => sub { cmd_add $_[1], 1 },
342 "incglob=s" => sub { cmd_incglob $_[1] },
343 "include|i=s" => sub { cmd_include $_[1], 1 },
344 "exclude|x=s" => sub { cmd_include $_[1], 0 },
345 "static!" => \$STATIC,
346 "usepacklists!" => \$PACKLIST,
347 "staticlib=s" => sub { cmd_staticlib $_[1] },
348 "<>" => sub { cmd_file $_[0] },
349 or exit 1;
350}
351
352Getopt::Long::Configure ("bundling", "no_auto_abbrev", "no_ignore_case");
353
354parse_argv;
355
356die "cannot specify both --app and --perl\n"
357 if $PERL and defined $APP;
358
359# required for @INC loading, unfortunately
360trace_module "PerlIO::scalar";
361
362#############################################################################
363# apply include/exclude
364
365{
366 my %pmi;
367
368 for (@incext) {
369 my ($inc, $glob) = @$_;
370
371 my @match = grep /$glob/, keys %pm;
372
373 if ($inc) {
374 # include
375 @pmi{@match} = delete @pm{@match};
376
377 print "applying include $glob - protected ", (scalar @match), " files.\n"
378 if $VERBOSE >= 5;
379 } else {
380 # exclude
381 delete @pm{@match};
382
383 print "applying exclude $glob - removed ", (scalar @match), " files.\n"
384 if $VERBOSE >= 5;
211 } 385 }
212 } 386 }
213}
214 387
215use Getopt::Long; 388 my @pmi = keys %pmi;
389 @pm{@pmi} = delete @pmi{@pmi};
390}
216 391
217Getopt::Long::Configure ("bundling", "no_auto_abbrev", "no_ignore_case"); 392#############################################################################
393# scan for AutoLoader, static archives and other dependencies
218 394
219GetOptions 395sub scan_al {
220 "strip=s" => \$STRIP, 396 my ($auto, $autodir) = @_;
221 "verbose|v" => sub { ++$VERBOSE }, 397
222 "quiet|q" => sub { --$VERBOSE }, 398 my $ix = "$autodir/autosplit.ix";
223 "perl" => \$PERL, 399
224 "eval|e=s" => sub { trace_eval $_[1] }, 400 print "processing autoload index for '$auto'\n"
225 "use|M=s" => sub { trace_module $_[1] }, 401 if $VERBOSE >= 6;
226 "boot=s" => sub { cmd_boot $_[1] }, 402
227 "add=s" => sub { cmd_add $_[1] }, 403 $pm{"$auto/autosplit.ix"} = $ix;
228 "static" => sub { $STATIC = 1 }, 404
229 "<>" => sub { cmd_file $_[0] }, 405 open my $fh, "<:perlio", $ix
230 or exit 1; 406 or die "$ix: $!";
407
408 my $package;
409
410 while (<$fh>) {
411 if (/^\s*sub\s+ ([^[:space:];]+) \s* (?:\([^)]*\))? \s*;?\s*$/x) {
412 my $al = "auto/$package/$1.al";
413 my $inc = find_inc $al;
414
415 defined $inc or die "$al: autoload file not found, but should be there.\n";
416
417 $pm{$al} = $inc;
418 print "found autoload function '$al'\n"
419 if $VERBOSE >= 6;
420
421 } elsif (/^\s*package\s+([^[:space:];]+)\s*;?\s*$/) {
422 ($package = $1) =~ s/::/\//g;
423 } elsif (/^\s*(?:#|1?\s*;?\s*$)/) {
424 # nop
425 } else {
426 warn "WARNING: $ix: unparsable line, please report: $_";
427 }
428 }
429}
430
431for my $pm (keys %pm) {
432 if ($pm =~ /^(.*)\.pm$/) {
433 my $auto = "auto/$1";
434 my $autodir = find_inc $auto;
435
436 if (defined $autodir && -d $autodir) {
437 # AutoLoader
438 scan_al $auto, $autodir
439 if -f "$autodir/autosplit.ix";
440
441 # extralibs.ld
442 if (open my $fh, "<:perlio", "$autodir/extralibs.ld") {
443 print "found extralibs for $pm\n"
444 if $VERBOSE >= 6;
445
446 local $/;
447 $extralibs .= " " . <$fh>;
448 }
449
450 $pm =~ /([^\/]+).pm$/ or die "$pm: unable to match last component";
451
452 my $base = $1;
453
454 # static ext
455 if (-f "$autodir/$base$Config{_a}") {
456 print "found static archive for $pm\n"
457 if $VERBOSE >= 3;
458
459 push @libs, "$autodir/$base$Config{_a}";
460 push @static_ext, $pm;
461 }
462
463 # dynamic object
464 die "ERROR: found shared object - can't link statically ($_)\n"
465 if -f "$autodir/$base.$Config{dlext}";
466
467 if ($PACKLIST && open my $fh, "<:perlio", "$autodir/.packlist") {
468 print "found .packlist for $pm\n"
469 if $VERBOSE >= 3;
470
471 while (<$fh>) {
472 chomp;
473 s/ .*$//; # newer-style .packlists might contain key=value pairs
474
475 # only include certain files (.al, .ix, .pm, .pl)
476 if (/\.(pm|pl|al|ix)$/) {
477 for my $inc (@INC) {
478 # in addition, we only add files that are below some @INC path
479 $inc =~ s/\/*$/\//;
480
481 if ($inc eq substr $_, 0, length $inc) {
482 my $base = substr $_, length $inc;
483 $pm{$base} = $_;
484
485 print "+ added .packlist dependency $base\n"
486 if $VERBOSE >= 3;
487 }
488
489 last;
490 }
491 }
492 }
493 }
494 }
495 }
496}
497
498#############################################################################
499
500print "processing bundle files (try more -v power if you get bored waiting here)...\n"
501 if $VERBOSE >= 1;
231 502
232my $data; 503my $data;
233my @index; 504my @index;
234my @order = sort { 505my @order = sort {
235 length $a <=> length $b 506 length $a <=> length $b
… …
242 513
243for my $pm (@order) { 514for my $pm (@order) {
244 my $path = $pm{$pm}; 515 my $path = $pm{$pm};
245 516
246 128 > length $pm 517 128 > length $pm
247 or die "$pm: path too long (only 128 octets supported)\n"; 518 or die "ERROR: $pm: path too long (only 128 octets supported)\n";
248 519
249 my $src = ref $path 520 my $src = ref $path
250 ? $$path 521 ? $$path
251 : do { 522 : do {
252 open my $pm, "<:perlio", $path 523 open my $pm, "<", $path
253 or die "$path: $!"; 524 or die "$path: $!";
254 525
255 local $/; 526 local $/;
256 527
257 <$pm> 528 <$pm>
258 }; 529 };
259 530
531 my $size = length $src;
532
533 unless ($pmbin{$pm}) { # only do this unless the file is binary
260 if ($pm =~ /^auto\/POSIX\/[^\/]+\.al$/) { 534 if ($pm =~ /^auto\/POSIX\/[^\/]+\.al$/) {
261 if ($src =~ /^ unimpl \"/m) { 535 if ($src =~ /^ unimpl \"/m) {
262 warn "$pm: skipping (not implemented anyways).\n" 536 print "$pm: skipping (raises runtime error only).\n"
263 if $VERBOSE >= 2; 537 if $VERBOSE >= 3;
264 next; 538 next;
539 }
265 } 540 }
266 }
267 541
268 if ($STRIP =~ /ppi/i) { 542 $src = cache +($STRIP eq "ppi" ? "$UNISTRIP,$OPTIMISE_SIZE" : undef), $src, sub {
269 require PPI; 543 if ($UNISTRIP && $pm =~ /^unicore\/.*\.pl$/) {
544 print "applying unicore stripping $pm\n"
545 if $VERBOSE >= 6;
270 546
271 my $ppi = PPI::Document->new (\$src); 547 # special stripping for unicore swashes and properties
272 $ppi->prune ("PPI::Token::Comment"); 548 # much more could be done by going binary
273 $ppi->prune ("PPI::Token::Pod"); 549 $src =~ s{
550 (^return\ <<'END';\n) (.*?\n) (END(?:\n|\Z))
551 }{
552 my ($pre, $data, $post) = ($1, $2, $3);
274 553
275 # prune END stuff 554 for ($data) {
276 for (my $last = $ppi->last_element; $last; ) { 555 s/^([0-9a-fA-F]+)\t([0-9a-fA-F]+)\t/sprintf "%X\t%X", hex $1, hex $2/gem
277 my $prev = $last->previous_token; 556 if $OPTIMISE_SIZE;
278 557
279 if ($last->isa (PPI::Token::Whitespace::)) { 558# s{
280 $last->delete; 559# ^([0-9a-fA-F]+)\t([0-9a-fA-F]*)\t
281 } elsif ($last->isa (PPI::Statement::End::)) { 560# }{
282 $last->delete; 561# # ww - smaller filesize, UU - compress better
562# pack "C0UU",
563# hex $1,
564# length $2 ? (hex $2) - (hex $1) : 0
565# }gemx;
566
567 s/#.*\n/\n/mg;
568 s/\s+\n/\n/mg;
569 }
570
571 "$pre$data$post"
283 last; 572 }smex;
284 } elsif ($last->isa (PPI::Token::Pod::)) {
285 $last->delete;
286 } else {
287 last;
288 } 573 }
289 574
575 if ($STRIP =~ /ppi/i) {
576 require PPI;
577
578 if (my $ppi = PPI::Document->new (\$src)) {
579 $ppi->prune ("PPI::Token::Comment");
580 $ppi->prune ("PPI::Token::Pod");
581
582 # prune END stuff
583 for (my $last = $ppi->last_element; $last; ) {
584 my $prev = $last->previous_token;
585
586 if ($last->isa (PPI::Token::Whitespace::)) {
587 $last->delete;
588 } elsif ($last->isa (PPI::Statement::End::)) {
589 $last->delete;
590 last;
591 } elsif ($last->isa (PPI::Token::Pod::)) {
592 $last->delete;
593 } else {
594 last;
595 }
596
290 $last = $prev; 597 $last = $prev;
291 } 598 }
292 599
293 # prune some but not all insignificant whitespace 600 # prune some but not all insignificant whitespace
294 for my $ws (@{ $ppi->find (PPI::Token::Whitespace::) }) { 601 for my $ws (@{ $ppi->find (PPI::Token::Whitespace::) }) {
295 my $prev = $ws->previous_token; 602 my $prev = $ws->previous_token;
296 my $next = $ws->next_token; 603 my $next = $ws->next_token;
297 604
298 if (!$prev || !$next) { 605 if (!$prev || !$next) {
299 $ws->delete; 606 $ws->delete;
300 } else { 607 } else {
301 if ( 608 if (
302 $next->isa (PPI::Token::Operator::) && $next->{content} =~ /^(?:,|=|!|!=|==|=>)$/ # no ., because of digits. == float 609 $next->isa (PPI::Token::Operator::) && $next->{content} =~ /^(?:,|=|!|!=|==|=>)$/ # no ., because of digits. == float
303 or $prev->isa (PPI::Token::Operator::) && $prev->{content} =~ /^(?:,|=|\.|!|!=|==|=>)$/ 610 or $prev->isa (PPI::Token::Operator::) && $prev->{content} =~ /^(?:,|=|\.|!|!=|==|=>)$/
304 or $prev->isa (PPI::Token::Structure::) 611 or $prev->isa (PPI::Token::Structure::)
305 # decrease size, decrease compressability 612 or ($OPTIMISE_SIZE &&
306 #or ($prev->isa (PPI::Token::Word::) 613 ($prev->isa (PPI::Token::Word::)
307 # && (PPI::Token::Symbol:: eq ref $next 614 && (PPI::Token::Symbol:: eq ref $next
308 # || $next->isa (PPI::Structure::Block::) 615 || $next->isa (PPI::Structure::Block::)
309 # || $next->isa (PPI::Structure::List::) 616 || $next->isa (PPI::Structure::List::)
310 # || $next->isa (PPI::Structure::Condition::))) 617 || $next->isa (PPI::Structure::Condition::)))
618 )
311 ) { 619 ) {
312 $ws->delete; 620 $ws->delete;
313 } elsif ($prev->isa (PPI::Token::Whitespace::)) { 621 } elsif ($prev->isa (PPI::Token::Whitespace::)) {
314 $ws->{content} = ' '; 622 $ws->{content} = ' ';
315 $prev->delete; 623 $prev->delete;
624 } else {
625 $ws->{content} = ' ';
626 }
627 }
628 }
629
630 # prune whitespace around blocks
631 if ($OPTIMISE_SIZE) {
632 # these usually decrease size, but decrease compressability more
633 for my $struct (PPI::Structure::Block::, PPI::Structure::Condition::) {
634 for my $node (@{ $ppi->find ($struct) }) {
635 my $n1 = $node->first_token;
636 my $n2 = $n1->previous_token;
637 $n1->delete if $n1->isa (PPI::Token::Whitespace::);
638 $n2->delete if $n2 && $n2->isa (PPI::Token::Whitespace::);
639 my $n1 = $node->last_token;
640 my $n2 = $n1->next_token;
641 $n1->delete if $n1->isa (PPI::Token::Whitespace::);
642 $n2->delete if $n2 && $n2->isa (PPI::Token::Whitespace::);
643 }
644 }
645
646 for my $node (@{ $ppi->find (PPI::Structure::List::) }) {
647 my $n1 = $node->first_token;
648 $n1->delete if $n1->isa (PPI::Token::Whitespace::);
649 my $n1 = $node->last_token;
650 $n1->delete if $n1->isa (PPI::Token::Whitespace::);
651 }
652 }
653
654 # reformat qw() lists which often have lots of whitespace
655 for my $node (@{ $ppi->find (PPI::Token::QuoteLike::Words::) }) {
656 if ($node->{content} =~ /^qw(.)(.*)(.)$/s) {
657 my ($a, $qw, $b) = ($1, $2, $3);
658 $qw =~ s/^\s+//;
659 $qw =~ s/\s+$//;
660 $qw =~ s/\s+/ /g;
661 $node->{content} = "qw$a$qw$b";
662 }
663 }
664
665 $src = $ppi->serialize;
316 } else { 666 } else {
317 $ws->{content} = ' '; 667 warn "WARNING: $pm{$pm}: PPI failed to parse this file\n";
668 }
669 } elsif ($STRIP =~ /pod/i && $pm ne "Opcode.pm") { # opcode parses its own pod
670 require Pod::Strip;
671
672 my $stripper = Pod::Strip->new;
673
674 my $out;
675 $stripper->output_string (\$out);
676 $stripper->parse_string_document ($src)
677 or die;
678 $src = $out;
679 }
680
681 if ($VERIFY && $pm =~ /\.pm$/ && $pm ne "Opcode.pm") {
682 if (open my $fh, "-|") {
683 <$fh>;
684 } else {
685 eval "#line 1 \"$pm\"\n$src" or warn "\n\n\n$pm\n\n$src\n$@\n\n\n";
686 exit 0;
318 } 687 }
319 } 688 }
689
690 $src
320 } 691 };
321 692
322 # prune whitespace around blocks
323 if (0) {
324 # these usually decrease size, but decrease compressability more
325 for my $struct (PPI::Structure::Block::, PPI::Structure::Condition::) {
326 for my $node (@{ $ppi->find ($struct) }) {
327 my $n1 = $node->first_token;
328 my $n2 = $n1->previous_token;
329 $n1->delete if $n1->isa (PPI::Token::Whitespace::);
330 $n2->delete if $n2 && $n2->isa (PPI::Token::Whitespace::);
331 my $n1 = $node->last_token;
332 my $n2 = $n1->next_token;
333 $n1->delete if $n1->isa (PPI::Token::Whitespace::);
334 $n2->delete if $n2 && $n2->isa (PPI::Token::Whitespace::);
335 }
336 }
337
338 for my $node (@{ $ppi->find (PPI::Structure::List::) }) {
339 my $n1 = $node->first_token;
340 $n1->delete if $n1->isa (PPI::Token::Whitespace::);
341 my $n1 = $node->last_token;
342 $n1->delete if $n1->isa (PPI::Token::Whitespace::);
343 }
344 }
345
346 # reformat qw() lists which often have lots of whitespace
347 for my $node (@{ $ppi->find (PPI::Token::QuoteLike::Words::) }) {
348 if ($node->{content} =~ /^qw(.)(.*)(.)$/s) {
349 my ($a, $qw, $b) = ($1, $2, $3);
350 $qw =~ s/^\s+//;
351 $qw =~ s/\s+$//;
352 $qw =~ s/\s+/ /g;
353 $node->{content} = "qw$a$qw$b";
354 }
355 }
356
357 $src = $ppi->serialize;
358 } elsif ($STRIP =~ /pod/i && $pm ne "Opcode.pm") { # opcode parses it's own pod
359 require Pod::Strip;
360
361 my $stripper = Pod::Strip->new;
362
363 my $out;
364 $stripper->output_string (\$out);
365 $stripper->parse_string_document ($src);
366 $src = $out;
367 }
368
369 if ($VERIFY && $pm =~ /\.pm$/ && $pm ne "Opcode.pm") {
370 if (open my $fh, "-|") {
371 <$fh>;
372 } else {
373 eval "#line 1 \"$pm\"\n$src" or warn "\n\n\n$pm\n\n$src\n$@\n\n\n";
374 exit 0;
375 }
376 }
377
378# if ($pm eq "Opcode.pm") { 693# if ($pm eq "Opcode.pm") {
379# open my $fh, ">x" or die; print $fh $src;#d# 694# open my $fh, ">x" or die; print $fh $src;#d#
380# exit 1; 695# exit 1;
696# }
381# } 697 }
382 698
383 warn "adding $pm\n" 699 print "adding $pm (original size $size, stored size ", length $src, ")\n"
384 if $VERBOSE >= 2; 700 if $VERBOSE >= 2;
385 701
386 push @index, ((length $pm) << 25) | length $data; 702 push @index, ((length $pm) << 25) | length $data;
387 $data .= $pm . $src; 703 $data .= $pm . $src;
388} 704}
389 705
390length $data < 2**25 706length $data < 2**25
391 or die "bundle too large (only 32MB supported)\n"; 707 or die "ERROR: bundle too large (only 32MB supported)\n";
392 708
393my $varpfx = "bundle_" . substr +(Digest::MD5::md5_hex $data), 0, 16; 709my $varpfx = "bundle_" . substr +(Digest::MD5::md5_hex $data), 0, 16;
394 710
395############################################################################# 711#############################################################################
396# output 712# output
397 713
398print "generating $PREFIX.h... "; 714print "generating $PREFIX.h... "
715 if $VERBOSE >= 1;
399 716
400{ 717{
401 open my $fh, ">", "$PREFIX.h" 718 open my $fh, ">", "$PREFIX.h"
402 or die "$PREFIX.h: $!\n"; 719 or die "$PREFIX.h: $!\n";
403 720
404 print $fh <<EOF; 721 print $fh <<EOF;
405/* do not edit, automatically created by mkstaticbundle */ 722/* do not edit, automatically created by mkstaticbundle */
723
406#include <EXTERN.h> 724#include <EXTERN.h>
407#include <perl.h> 725#include <perl.h>
408#include <XSUB.h> 726#include <XSUB.h>
409 727
410/* public API */ 728/* public API */
411EXTERN_C PerlInterpreter *staticperl; 729EXTERN_C PerlInterpreter *staticperl;
730EXTERN_C void staticperl_xs_init (pTHX);
412EXTERN_C void staticperl_init (void); 731EXTERN_C void staticperl_init (void);
413EXTERN_C void staticperl_cleanup (void); 732EXTERN_C void staticperl_cleanup (void);
733
414EOF 734EOF
415} 735}
416 736
417print "\n"; 737print "\n"
738 if $VERBOSE >= 1;
418 739
419############################################################################# 740#############################################################################
420# output 741# output
421 742
422print "generating $PREFIX.c... "; 743print "generating $PREFIX.c... "
744 if $VERBOSE >= 1;
423 745
424open my $fh, ">", "$PREFIX.c" 746open my $fh, ">", "$PREFIX.c"
425 or die "$PREFIX.c: $!\n"; 747 or die "$PREFIX.c: $!\n";
426 748
427print $fh <<EOF; 749print $fh <<EOF;
428/* do not edit, automatically created by mkstaticbundle */ 750/* do not edit, automatically created by mkstaticbundle */
429
430#include <EXTERN.h>
431#include <perl.h>
432#include <XSUB.h>
433 751
434#include "bundle.h" 752#include "bundle.h"
435 753
436/* public API */ 754/* public API */
437PerlInterpreter *staticperl; 755PerlInterpreter *staticperl;
… …
461printf $fh "0x%08x\n};\n", (length $data); 779printf $fh "0x%08x\n};\n", (length $data);
462 780
463print $fh "static const char $varpfx\_data [] =\n"; 781print $fh "static const char $varpfx\_data [] =\n";
464dump_string $fh, $data; 782dump_string $fh, $data;
465 783
466print $fh ";\n\n";; 784print $fh ";\n\n";
467 785
468############################################################################# 786#############################################################################
469# bootstrap 787# bootstrap
470 788
471# boot file for staticperl 789# boot file for staticperl
… …
576 } 894 }
577 895
578 XSRETURN ($varpfx\_count); 896 XSRETURN ($varpfx\_count);
579} 897}
580 898
581static char *args[] = {
582 "staticperl",
583 "-e",
584 "0"
585};
586
587EOF 899EOF
588 900
589############################################################################# 901#############################################################################
590# xs_init 902# xs_init
591 903
592print $fh <<EOF; 904print $fh <<EOF;
593static void 905void
594xs_init (pTHX) 906staticperl_xs_init (pTHX)
595{ 907{
596EOF 908EOF
597 909
598@static_ext = ("DynaLoader", sort @static_ext); 910@static_ext = ("DynaLoader", sort @static_ext);
599 911
… …
630EOF 942EOF
631 943
632############################################################################# 944#############################################################################
633# optional perl_init/perl_destroy 945# optional perl_init/perl_destroy
634 946
635if ($PERL) { 947if ($APP) {
636 print $fh <<EOF; 948 print $fh <<EOF;
637 949
638int 950int
639main (int argc, char *argv []) 951main (int argc, char *argv [])
640{ 952{
641 extern char **environ; 953 extern char **environ;
642 int exitstatus; 954 int exitstatus;
643 955
956 static char *args[] = {
957 "staticperl",
958 "-e",
959 "0"
960 };
961
644 PERL_SYS_INIT3 (&argc, &argv, &environ); 962 PERL_SYS_INIT3 (&argc, &argv, &environ);
645 staticperl = perl_alloc (); 963 staticperl = perl_alloc ();
646 perl_construct (staticperl); 964 perl_construct (staticperl);
647 965
648 PL_exit_flags |= PERL_EXIT_DESTRUCT_END; 966 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
649 967
968 exitstatus = perl_parse (staticperl, staticperl_xs_init, sizeof (args) / sizeof (*args), args, environ);
969 if (!exitstatus)
970 perl_run (staticperl);
971
972 exitstatus = perl_destruct (staticperl);
973 perl_free (staticperl);
974 PERL_SYS_TERM ();
975
976 return exitstatus;
977}
978EOF
979} elsif ($PERL) {
980 print $fh <<EOF;
981
982int
983main (int argc, char *argv [])
984{
985 extern char **environ;
986 int exitstatus;
987
988 PERL_SYS_INIT3 (&argc, &argv, &environ);
989 staticperl = perl_alloc ();
990 perl_construct (staticperl);
991
992 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
993
650 exitstatus = perl_parse (staticperl, xs_init, argc, argv, environ); 994 exitstatus = perl_parse (staticperl, staticperl_xs_init, argc, argv, environ);
651 if (!exitstatus) 995 if (!exitstatus)
652 perl_run (staticperl); 996 perl_run (staticperl);
653 997
654 exitstatus = perl_destruct (staticperl); 998 exitstatus = perl_destruct (staticperl);
655 perl_free (staticperl); 999 perl_free (staticperl);
… …
666{ 1010{
667 extern char **environ; 1011 extern char **environ;
668 int argc = sizeof (args) / sizeof (args [0]); 1012 int argc = sizeof (args) / sizeof (args [0]);
669 char **argv = args; 1013 char **argv = args;
670 1014
1015 static char *args[] = {
1016 "staticperl",
1017 "-e",
1018 "0"
1019 };
1020
671 PERL_SYS_INIT3 (&argc, &argv, &environ); 1021 PERL_SYS_INIT3 (&argc, &argv, &environ);
672 staticperl = perl_alloc (); 1022 staticperl = perl_alloc ();
673 perl_construct (staticperl); 1023 perl_construct (staticperl);
674 PL_origalen = 1; 1024 PL_origalen = 1;
675 PL_exit_flags |= PERL_EXIT_DESTRUCT_END; 1025 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
676 perl_parse (staticperl, xs_init, argc, argv, environ); 1026 perl_parse (staticperl, staticperl_xs_init, argc, argv, environ);
677 1027
678 perl_run (staticperl); 1028 perl_run (staticperl);
679} 1029}
680 1030
681EXTERN_C void 1031EXTERN_C void
… …
687 PERL_SYS_TERM (); 1037 PERL_SYS_TERM ();
688} 1038}
689EOF 1039EOF
690} 1040}
691 1041
692print -s "$PREFIX.c", " octets (", (length $data) , " data octets).\n\n"; 1042print -s "$PREFIX.c", " octets (", (length $data) , " data octets).\n\n"
1043 if $VERBOSE >= 1;
693 1044
694############################################################################# 1045#############################################################################
695# libs, cflags 1046# libs, cflags
696 1047
697{ 1048{
698 print "generating $PREFIX.ccopts... "; 1049 print "generating $PREFIX.ccopts... "
1050 if $VERBOSE >= 1;
699 1051
700 my $str = "$Config{ccflags} $Config{optimize} $Config{cppflags} -I$Config{archlibexp}/CORE"; 1052 my $str = "$Config{ccflags} $Config{optimize} $Config{cppflags} -I$Config{archlibexp}/CORE";
701 $str =~ s/([\(\)])/\\$1/g; 1053 $str =~ s/([\(\)])/\\$1/g;
702
703 print "$str\n\n";
704 1054
705 open my $fh, ">$PREFIX.ccopts" 1055 open my $fh, ">$PREFIX.ccopts"
706 or die "$PREFIX.ccopts: $!"; 1056 or die "$PREFIX.ccopts: $!";
707 print $fh $str; 1057 print $fh $str;
1058
1059 print "$str\n\n"
1060 if $VERBOSE >= 1;
708} 1061}
709 1062
710{ 1063{
711 print "generating $PREFIX.ldopts... "; 1064 print "generating $PREFIX.ldopts... ";
712 1065
713 my $str = $STATIC ? "--static " : ""; 1066 my $str = $STATIC ? "-static " : "";
714 1067
715 $str .= "$Config{ccdlflags} $Config{ldflags} @libs $Config{archlibexp}/CORE/$Config{libperl} $Config{perllibs}"; 1068 $str .= "$Config{ccdlflags} $Config{ldflags} @libs $Config{archlibexp}/CORE/$Config{libperl} $Config{perllibs}";
716 1069
717 my %seen; 1070 my %seen;
718 $str .= " $_" for grep !$seen{$_}++, ($extralibs =~ /(\S+)/g); 1071 $str .= " $_" for grep !$seen{$_}++, ($extralibs =~ /(\S+)/g);
719 1072
1073 for (@staticlibs) {
1074 $str =~ s/(^|\s) (-l\Q$_\E) ($|\s)/$1-Wl,-Bstatic $2 -Wl,-Bdynamic$3/gx;
1075 }
1076
720 $str =~ s/([\(\)])/\\$1/g; 1077 $str =~ s/([\(\)])/\\$1/g;
721
722 print "$str\n\n";
723 1078
724 open my $fh, ">$PREFIX.ldopts" 1079 open my $fh, ">$PREFIX.ldopts"
725 or die "$PREFIX.ldopts: $!"; 1080 or die "$PREFIX.ldopts: $!";
726 print $fh $str; 1081 print $fh $str;
727}
728 1082
729if ($PERL) { 1083 print "$str\n\n"
1084 if $VERBOSE >= 1;
1085}
1086
1087if ($PERL or defined $APP) {
1088 $APP = "perl" unless defined $APP;
1089
1090 print "building $APP...\n"
1091 if $VERBOSE >= 1;
1092
730 system "$Config{cc} \$(cat bundle.ccopts\) -o perl bundle.c \$(cat bundle.ldopts\)"; 1093 system "$Config{cc} \$(cat bundle.ccopts\) -o \Q$APP\E bundle.c \$(cat bundle.ldopts\)";
731 1094
732 unlink "$PREFIX.$_" 1095 unlink "$PREFIX.$_"
733 for qw(ccopts ldopts c h); 1096 for qw(ccopts ldopts c h);
734}
735 1097
1098 print "\n"
1099 if $VERBOSE >= 1;
1100}
1101

Diff Legend

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