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

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

Diff Legend

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