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.1 by root, Mon Dec 6 19:33:57 2010 UTC vs.
Revision 1.20 by root, Thu Feb 10 09:30:56 2011 UTC

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

Diff Legend

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