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.8 by root, Wed Dec 8 09:13:55 2010 UTC vs.
Revision 1.27 by root, Thu Feb 24 14:35:38 2011 UTC

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

Diff Legend

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