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

Diff Legend

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