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.11 by root, Fri Dec 10 02:35:54 2010 UTC

… …
3############################################################################# 3#############################################################################
4# cannot load modules till after the tracer BEGIN block 4# cannot load modules till after the tracer BEGIN block
5 5
6our $VERBOSE = 1; 6our $VERBOSE = 1;
7our $STRIP = "pod"; # none, pod or ppi 7our $STRIP = "pod"; # none, pod or ppi
8our $UNISTRIP = 1; # always on, try to strip unicore swash data
8our $PERL = 0; 9our $PERL = 0;
10our $APP;
9our $VERIFY = 0; 11our $VERIFY = 0;
10our $STATIC = 0; 12our $STATIC = 0;
13
14our $OPTIMISE_SIZE = 0; # optimise for raw file size instead of for compression?
15
16our $CACHE;
17our $CACHEVER = 1; # do not change unless you know what you are doing
11 18
12my $PREFIX = "bundle"; 19my $PREFIX = "bundle";
13my $PACKAGE = "static"; 20my $PACKAGE = "static";
14 21
15my %pm; 22my %pm;
16my %pmbin; 23my %pmbin;
17my @libs; 24my @libs;
18my @static_ext; 25my @static_ext;
19my $extralibs; 26my $extralibs;
27my @staticlibs;
28my @incext;
20 29
21@ARGV 30@ARGV
22 or die "$0: use 'staticperl help' (or read the sources of staticperl)\n"; 31 or die "$0: use 'staticperl help' (or read the sources of staticperl)\n";
32
33# remove "." from @INC - staticperl.sh does it for us, but be on the safe side
34BEGIN { @INC = grep !/^\.$/, @INC }
23 35
24$|=1; 36$|=1;
25 37
26our ($TRACER_W, $TRACER_R); 38our ($TRACER_W, $TRACER_R);
27 39
… …
75 exit 0; 87 exit 0;
76 } 88 }
77} 89}
78 90
79# module loading is now safe 91# module loading is now safe
80use Config;
81
82sub scan_al {
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 92
111sub trace_module { 93sub trace_module {
112 syswrite $TRACER_W, "use $_[0]\n"; 94 syswrite $TRACER_W, "use $_[0]\n";
113 95
114 for (;;) { 96 for (;;) {
115 <$TRACER_R> =~ /^-$/ or last; 97 <$TRACER_R> =~ /^-$/ or last;
116 my $dir = <$TRACER_R>; chomp $dir; 98 my $dir = <$TRACER_R>; chomp $dir;
117 my $name = <$TRACER_R>; chomp $name; 99 my $name = <$TRACER_R>; chomp $name;
118 100
119 $pm{$name} = "$dir/$name"; 101 $pm{$name} = "$dir/$name";
120
121 if ($name =~ /^(.*)\.pm$/) {
122 my $auto = "auto/$1";
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 } 102 }
156} 103}
157 104
158sub trace_eval { 105sub trace_eval {
159 syswrite $TRACER_W, "eval $_[0]\n"; 106 syswrite $TRACER_W, "eval $_[0]\n";
… …
166 113
167############################################################################# 114#############################################################################
168# now we can use modules 115# now we can use modules
169 116
170use common::sense; 117use common::sense;
118use Config;
171use Digest::MD5; 119use Digest::MD5;
120
121sub cache($$$) {
122 my ($variant, $src, $filter) = @_;
123
124 if (length $CACHE and 2048 <= length $src) {
125 my $file = "$CACHE/" . Digest::MD5::md5_hex "$CACHEVER\x00$variant\x00$src";
126
127 if (open my $fh, "<:perlio", $file) {
128 local $/;
129 return <$fh>;
130 }
131
132 $src = $filter->($src);
133
134 if (open my $fh, ">:perlio", "$file~") {
135 if ((syswrite $fh, $src) == length $src) {
136 close $fh;
137 rename "$file~", $file;
138 }
139 }
140
141 return $src;
142 }
143
144 $filter->($src)
145}
172 146
173sub dump_string { 147sub dump_string {
174 my ($fh, $data) = @_; 148 my ($fh, $data) = @_;
175 149
176 if (length $data) { 150 if (length $data) {
… …
186 } else { 160 } else {
187 print $fh " \"\"\n"; 161 print $fh " \"\"\n";
188 } 162 }
189} 163}
190 164
191# required for @INC loading, unfortunately 165#############################################################################
192trace_module "PerlIO::scalar";
193 166
194#trace_module "Term::ReadLine::readline"; # Term::ReadLine::Perl dependency 167sub glob2re {
195# URI is difficult 168 for (quotemeta $_[0]) {
196#trace_module "URI::http"; 169 s/\\\*/\x00/g;
197#trace_module "URI::_generic"; 170 s/\x00\x00/.*/g;
171 s/\x00/[^\/]*/g;
172 s/\\\?/[^\/]/g;
173
174 $_ = s/^\\\/// ? "^$_\$" : "(?:^|/)$_\$";
175
176 s/(?: \[\^\/\] | \. ) \*\$$//x;
177
178 return qr<$_>s
179 }
180}
181
182our %INCSKIP = (
183 "unicore/TestProp.pl" => undef, # 3.5MB of insanity, apparently just some testcase
184);
185
186sub get_dirtree {
187 my $root = shift;
188
189 my @tree;
190 my $skip;
191
192 my $scan; $scan = sub {
193 for (sort do {
194 opendir my $fh, $_[0]
195 or return;
196 readdir $fh
197 }) {
198 next if /^\./;
199
200 my $path = "$_[0]/$_";
201
202 if (-d "$path/.") {
203 $scan->($path);
204 } else {
205 next unless /\.(?:pm|pl)$/;
206
207 $path = substr $path, $skip;
208 push @tree, $path
209 unless exists $INCSKIP{$path};
210 }
211 }
212 };
213
214 $root =~ s/\/$//;
215 $skip = 1 + length $root;
216 $scan->($root);
217
218 \@tree
219}
220
221my $inctrees;
222
223sub get_inctrees {
224 unless ($inctrees) {
225 my %inctree;
226 $inctree{$_} ||= [$_, get_dirtree $_] # entries in @INC are often duplicates
227 for @INC;
228 $inctrees = [values %inctree];
229 }
230
231 @$inctrees
232}
233
234#############################################################################
198 235
199sub cmd_boot { 236sub cmd_boot {
200 $pm{"//boot"} = $_[0]; 237 $pm{"//boot"} = $_[0];
201} 238}
202 239
… …
207 my $file = $1; 244 my $file = $1;
208 my $as = defined $2 ? $2 : "/$1"; 245 my $as = defined $2 ? $2 : "/$1";
209 246
210 $pm{$as} = $file; 247 $pm{$as} = $file;
211 $pmbin{$as} = 1 if $_[1]; 248 $pmbin{$as} = 1 if $_[1];
249}
250
251sub cmd_staticlib {
252 push @staticlibs, $_
253 for split /\s+/, $_[0];
254}
255
256sub cmd_include {
257 push @incext, [$_[1], glob2re $_[0]];
258}
259
260sub cmd_incglob {
261 my ($pattern) = @_;
262
263 $pattern = glob2re $pattern;
264
265 for (get_inctrees) {
266 my ($dir, $files) = @$_;
267
268 $pm{$_} = "$dir/$_"
269 for grep /$pattern/, @$files;
270 }
212} 271}
213 272
214sub cmd_file { 273sub cmd_file {
215 open my $fh, "<", $_[0] 274 open my $fh, "<", $_[0]
216 or die "$_[0]: $!\n"; 275 or die "$_[0]: $!\n";
… …
220 my ($cmd, $args) = split / /, $_, 2; 279 my ($cmd, $args) = split / /, $_, 2;
221 $cmd =~ s/^-+//; 280 $cmd =~ s/^-+//;
222 281
223 if ($cmd eq "strip") { 282 if ($cmd eq "strip") {
224 $STRIP = $args; 283 $STRIP = $args;
284 } elsif ($cmd eq "perl") {
285 $PERL = 1;
286 } elsif ($cmd eq "app") {
287 $APP = $args;
225 } elsif ($cmd eq "eval") { 288 } elsif ($cmd eq "eval") {
226 trace_eval $_; 289 trace_eval $_;
227 } elsif ($cmd eq "use") { 290 } elsif ($cmd eq "use") {
228 trace_module $_ 291 trace_module $_
229 for split / /, $args; 292 for split / /, $args;
293 } elsif ($cmd eq "staticlib") {
294 cmd_staticlib $args;
230 } elsif ($cmd eq "boot") { 295 } elsif ($cmd eq "boot") {
231 cmd_boot $args; 296 cmd_boot $args;
232 } elsif ($cmd eq "static") { 297 } elsif ($cmd eq "static") {
233 $STATIC = 1; 298 $STATIC = 1;
234 } elsif ($cmd eq "add") { 299 } elsif ($cmd eq "add") {
235 cmd_add $args, 0; 300 cmd_add $args, 0;
236 } elsif ($cmd eq "addbin") { 301 } elsif ($cmd eq "addbin") {
237 cmd_add $args, 1; 302 cmd_add $args, 1;
303 } elsif ($cmd eq "incglob") {
304 cmd_incglob $args;
305 } elsif ($cmd eq "include") {
306 cmd_include $args, 1;
307 } elsif ($cmd eq "exclude") {
308 cmd_include $args, 0;
238 } elsif (/^\s*#/) { 309 } elsif (/^\s*#/) {
239 # comment 310 # comment
240 } elsif (/\S/) { 311 } elsif (/\S/) {
241 die "$_: unsupported directive\n"; 312 die "$_: unsupported directive\n";
242 } 313 }
… …
246use Getopt::Long; 317use Getopt::Long;
247 318
248Getopt::Long::Configure ("bundling", "no_auto_abbrev", "no_ignore_case"); 319Getopt::Long::Configure ("bundling", "no_auto_abbrev", "no_ignore_case");
249 320
250GetOptions 321GetOptions
251 "strip=s" => \$STRIP, 322 "strip=s" => \$STRIP,
323 "cache=s" => \$CACHE, # internal option
252 "verbose|v" => sub { ++$VERBOSE }, 324 "verbose|v" => sub { ++$VERBOSE },
253 "quiet|q" => sub { --$VERBOSE }, 325 "quiet|q" => sub { --$VERBOSE },
254 "perl" => \$PERL, 326 "perl" => \$PERL,
327 "app=s" => \$APP,
255 "eval|e=s" => sub { trace_eval $_[1] }, 328 "eval|e=s" => sub { trace_eval $_[1] },
256 "use|M=s" => sub { trace_module $_[1] }, 329 "use|M=s" => sub { trace_module $_[1] },
257 "boot=s" => sub { cmd_boot $_[1] }, 330 "boot=s" => sub { cmd_boot $_[1] },
258 "add=s" => sub { cmd_add $_[1], 0 }, 331 "add=s" => sub { cmd_add $_[1], 0 },
259 "addbin=s" => sub { cmd_add $_[1], 1 }, 332 "addbin=s" => sub { cmd_add $_[1], 1 },
333 "incglob=s" => sub { cmd_incglob $_[1] },
334 "include|i=s" => sub { cmd_include $_[1], 1 },
335 "exclude|x=s" => sub { cmd_include $_[1], 0 },
260 "static" => sub { $STATIC = 1 }, 336 "static" => sub { $STATIC = 1 },
337 "staticlib=s" => sub { cmd_staticlib $_[1] },
261 "<>" => sub { cmd_file $_[0] }, 338 "<>" => sub { cmd_file $_[0] },
262 or exit 1; 339 or exit 1;
340
341die "cannot specify both --app and --perl\n"
342 if $PERL and defined $APP;
343
344# required for @INC loading, unfortunately
345trace_module "PerlIO::scalar";
346
347#############################################################################
348# include/exclude apply
349
350{
351 my %pmi;
352
353 for (@incext) {
354 my ($inc, $glob) = @$_;
355
356 my @match = grep /$glob/, keys %pm;
357
358 if ($inc) {
359 # include
360 @pmi{@match} = delete @pm{@match};
361 } else {
362 # exclude
363 delete @pm{@match};
364 }
365 }
366
367 my @pmi = keys %pmi;
368 @pm{@pmi} = delete @pmi{@pmi};
369}
370
371#############################################################################
372# scan for AutoLoader and static archives
373
374sub scan_al {
375 my ($auto, $autodir) = @_;
376
377 my $ix = "$autodir/autosplit.ix";
378
379 $pm{"$auto/autosplit.ix"} = $ix;
380
381 open my $fh, "<:perlio", $ix
382 or die "$ix: $!";
383
384 my $package;
385
386 while (<$fh>) {
387 if (/^\s*sub\s+ ([^[:space:];]+) \s* (?:\([^)]*\))? \s*;?\s*$/x) {
388 my $al = "auto/$package/$1.al";
389 my $inc = find_inc $al;
390
391 defined $inc or die "$al: autoload file not found, but should be there.\n";
392
393 $pm{$al} = "$inc/$al";
394
395 } elsif (/^\s*package\s+([^[:space:];]+)\s*;?\s*$/) {
396 ($package = $1) =~ s/::/\//g;
397 } elsif (/^\s*(?:#|1?\s*;?\s*$)/) {
398 # nop
399 } else {
400 warn "$ix: unparsable line, please report: $_";
401 }
402 }
403}
404
405for my $pm (keys %pm) {
406 if ($pm =~ /^(.*)\.pm$/) {
407 my $auto = "auto/$1";
408 my $autodir = find_inc $auto;
409
410 if (defined $autodir && -d "$autodir/$auto") {
411 $autodir = "$autodir/$auto";
412
413 # AutoLoader
414 scan_al $auto, $autodir
415 if -f "$autodir/autosplit.ix";
416
417 # extralibs.ld
418 if (open my $fh, "<:perlio", "$autodir/extralibs.ld") {
419 local $/;
420 $extralibs .= " " . <$fh>;
421 }
422
423 $pm =~ /([^\/]+).pm$/ or die "$pm: unable to match last component";
424
425 my $base = $1;
426
427 # static ext
428 if (-f "$autodir/$base$Config{_a}") {
429 push @libs, "$autodir/$base$Config{_a}";
430 push @static_ext, $pm;
431 }
432
433 # dynamic object
434 die "ERROR: found shared object - can't link statically ($_)\n"
435 if -f "$autodir/$base.$Config{dlext}";
436 }
437 }
438}
439
440#############################################################################
263 441
264my $data; 442my $data;
265my @index; 443my @index;
266my @order = sort { 444my @order = sort {
267 length $a <=> length $b 445 length $a <=> length $b
… …
274 452
275for my $pm (@order) { 453for my $pm (@order) {
276 my $path = $pm{$pm}; 454 my $path = $pm{$pm};
277 455
278 128 > length $pm 456 128 > length $pm
279 or die "$pm: path too long (only 128 octets supported)\n"; 457 or die "ERROR: $pm: path too long (only 128 octets supported)\n";
280 458
281 my $src = ref $path 459 my $src = ref $path
282 ? $$path 460 ? $$path
283 : do { 461 : do {
284 open my $pm, "<", $path 462 open my $pm, "<", $path
… …
287 local $/; 465 local $/;
288 466
289 <$pm> 467 <$pm>
290 }; 468 };
291 469
470 my $size = length $src;
471
292 unless ($pmbin{$pm}) { # only do this unless the file is binary 472 unless ($pmbin{$pm}) { # only do this unless the file is binary
293
294 if ($pm =~ /^auto\/POSIX\/[^\/]+\.al$/) { 473 if ($pm =~ /^auto\/POSIX\/[^\/]+\.al$/) {
295 if ($src =~ /^ unimpl \"/m) { 474 if ($src =~ /^ unimpl \"/m) {
296 warn "$pm: skipping (not implemented anyways).\n" 475 warn "$pm: skipping (not implemented anyways).\n"
297 if $VERBOSE >= 2; 476 if $VERBOSE >= 2;
298 next; 477 next;
299 } 478 }
300 } 479 }
301 480
481 $src = cache "$UNISTRIP,$OPTIMISE_SIZE,$STRIP", $src, sub {
482 if ($UNISTRIP && $pm =~ /^unicore\/.*\.pl$/) {
483 # special stripping for unicore swashes and properties
484 # much more could be done by going binary
485 $src =~ s{
486 (^return\ <<'END';\n) (.*?\n) (END(?:\n|\Z))
487 }{
488 my ($pre, $data, $post) = ($1, $2, $3);
489
490 for ($data) {
491 s/^([0-9a-fA-F]+)\t([0-9a-fA-F]+)\t/sprintf "%X\t%X", hex $1, hex $2/gem
492 if $OPTIMISE_SIZE;
493
494# s{
495# ^([0-9a-fA-F]+)\t([0-9a-fA-F]*)\t
496# }{
497# # ww - smaller filesize, UU - compress better
498# pack "C0UU",
499# hex $1,
500# length $2 ? (hex $2) - (hex $1) : 0
501# }gemx;
502
503 s/#.*\n/\n/mg;
504 s/\s+\n/\n/mg;
505 }
506
507 "$pre$data$post"
508 }smex;
509 }
510
302 if ($STRIP =~ /ppi/i) { 511 if ($STRIP =~ /ppi/i) {
303 require PPI; 512 require PPI;
304 513
305 my $ppi = PPI::Document->new (\$src); 514 if (my $ppi = PPI::Document->new (\$src)) {
306 $ppi->prune ("PPI::Token::Comment"); 515 $ppi->prune ("PPI::Token::Comment");
307 $ppi->prune ("PPI::Token::Pod"); 516 $ppi->prune ("PPI::Token::Pod");
308 517
309 # prune END stuff 518 # prune END stuff
310 for (my $last = $ppi->last_element; $last; ) { 519 for (my $last = $ppi->last_element; $last; ) {
311 my $prev = $last->previous_token; 520 my $prev = $last->previous_token;
312 521
313 if ($last->isa (PPI::Token::Whitespace::)) { 522 if ($last->isa (PPI::Token::Whitespace::)) {
314 $last->delete; 523 $last->delete;
315 } elsif ($last->isa (PPI::Statement::End::)) { 524 } elsif ($last->isa (PPI::Statement::End::)) {
316 $last->delete; 525 $last->delete;
317 last; 526 last;
318 } elsif ($last->isa (PPI::Token::Pod::)) { 527 } elsif ($last->isa (PPI::Token::Pod::)) {
319 $last->delete; 528 $last->delete;
529 } else {
530 last;
531 }
532
533 $last = $prev;
534 }
535
536 # prune some but not all insignificant whitespace
537 for my $ws (@{ $ppi->find (PPI::Token::Whitespace::) }) {
538 my $prev = $ws->previous_token;
539 my $next = $ws->next_token;
540
541 if (!$prev || !$next) {
542 $ws->delete;
543 } else {
544 if (
545 $next->isa (PPI::Token::Operator::) && $next->{content} =~ /^(?:,|=|!|!=|==|=>)$/ # no ., because of digits. == float
546 or $prev->isa (PPI::Token::Operator::) && $prev->{content} =~ /^(?:,|=|\.|!|!=|==|=>)$/
547 or $prev->isa (PPI::Token::Structure::)
548 or ($OPTIMISE_SIZE &&
549 ($prev->isa (PPI::Token::Word::)
550 && (PPI::Token::Symbol:: eq ref $next
551 || $next->isa (PPI::Structure::Block::)
552 || $next->isa (PPI::Structure::List::)
553 || $next->isa (PPI::Structure::Condition::)))
554 )
555 ) {
556 $ws->delete;
557 } elsif ($prev->isa (PPI::Token::Whitespace::)) {
558 $ws->{content} = ' ';
559 $prev->delete;
560 } else {
561 $ws->{content} = ' ';
562 }
563 }
564 }
565
566 # prune whitespace around blocks
567 if ($OPTIMISE_SIZE) {
568 # these usually decrease size, but decrease compressability more
569 for my $struct (PPI::Structure::Block::, PPI::Structure::Condition::) {
570 for my $node (@{ $ppi->find ($struct) }) {
571 my $n1 = $node->first_token;
572 my $n2 = $n1->previous_token;
573 $n1->delete if $n1->isa (PPI::Token::Whitespace::);
574 $n2->delete if $n2 && $n2->isa (PPI::Token::Whitespace::);
575 my $n1 = $node->last_token;
576 my $n2 = $n1->next_token;
577 $n1->delete if $n1->isa (PPI::Token::Whitespace::);
578 $n2->delete if $n2 && $n2->isa (PPI::Token::Whitespace::);
579 }
580 }
581
582 for my $node (@{ $ppi->find (PPI::Structure::List::) }) {
583 my $n1 = $node->first_token;
584 $n1->delete if $n1->isa (PPI::Token::Whitespace::);
585 my $n1 = $node->last_token;
586 $n1->delete if $n1->isa (PPI::Token::Whitespace::);
587 }
588 }
589
590 # reformat qw() lists which often have lots of whitespace
591 for my $node (@{ $ppi->find (PPI::Token::QuoteLike::Words::) }) {
592 if ($node->{content} =~ /^qw(.)(.*)(.)$/s) {
593 my ($a, $qw, $b) = ($1, $2, $3);
594 $qw =~ s/^\s+//;
595 $qw =~ s/\s+$//;
596 $qw =~ s/\s+/ /g;
597 $node->{content} = "qw$a$qw$b";
598 }
599 }
600
601 $src = $ppi->serialize;
320 } else { 602 } else {
321 last; 603 warn "WARNING: $pm{$pm}: PPI failed to parse this file\n";
322 } 604 }
605 } elsif ($STRIP =~ /pod/i && $pm ne "Opcode.pm") { # opcode parses it's own pod
606 require Pod::Strip;
323 607
324 $last = $prev; 608 my $stripper = Pod::Strip->new;
609
610 my $out;
611 $stripper->output_string (\$out);
612 $stripper->parse_string_document ($src)
613 or die;
614 $src = $out;
325 } 615 }
326 616
327 # prune some but not all insignificant whitespace 617 if ($VERIFY && $pm =~ /\.pm$/ && $pm ne "Opcode.pm") {
328 for my $ws (@{ $ppi->find (PPI::Token::Whitespace::) }) { 618 if (open my $fh, "-|") {
329 my $prev = $ws->previous_token;
330 my $next = $ws->next_token;
331
332 if (!$prev || !$next) {
333 $ws->delete; 619 <$fh>;
334 } else { 620 } else {
335 if ( 621 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 } 622 exit 0;
353 } 623 }
354 } 624 }
355 625
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 } 626 $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 } 627 };
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 628
413# if ($pm eq "Opcode.pm") { 629# if ($pm eq "Opcode.pm") {
414# open my $fh, ">x" or die; print $fh $src;#d# 630# open my $fh, ">x" or die; print $fh $src;#d#
415# exit 1; 631# exit 1;
416# } 632# }
417 } 633 }
418 634
419 warn "adding $pm\n" 635 print "adding $pm{$pm} (original size $size, stored size ", length $src, ")\n"
420 if $VERBOSE >= 2; 636 if $VERBOSE >= 2;
421 637
422 push @index, ((length $pm) << 25) | length $data; 638 push @index, ((length $pm) << 25) | length $data;
423 $data .= $pm . $src; 639 $data .= $pm . $src;
424} 640}
… …
611 } 827 }
612 828
613 XSRETURN ($varpfx\_count); 829 XSRETURN ($varpfx\_count);
614} 830}
615 831
616static char *args[] = {
617 "staticperl",
618 "-e",
619 "0"
620};
621
622EOF 832EOF
623 833
624############################################################################# 834#############################################################################
625# xs_init 835# xs_init
626 836
… …
665EOF 875EOF
666 876
667############################################################################# 877#############################################################################
668# optional perl_init/perl_destroy 878# optional perl_init/perl_destroy
669 879
880if ($APP) {
881 print $fh <<EOF;
882
883int
884main (int argc, char *argv [])
885{
886 extern char **environ;
887 int exitstatus;
888
889 static char *args[] = {
890 "staticperl",
891 "-e",
892 "0"
893 };
894
895 PERL_SYS_INIT3 (&argc, &argv, &environ);
896 staticperl = perl_alloc ();
897 perl_construct (staticperl);
898
899 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
900
901 exitstatus = perl_parse (staticperl, staticperl_xs_init, sizeof (args) / sizeof (*args), args, environ);
902 if (!exitstatus)
903 perl_run (staticperl);
904
905 exitstatus = perl_destruct (staticperl);
906 perl_free (staticperl);
907 PERL_SYS_TERM ();
908
909 return exitstatus;
910}
911EOF
670if ($PERL) { 912} elsif ($PERL) {
671 print $fh <<EOF; 913 print $fh <<EOF;
672 914
673int 915int
674main (int argc, char *argv []) 916main (int argc, char *argv [])
675{ 917{
… …
700staticperl_init (void) 942staticperl_init (void)
701{ 943{
702 extern char **environ; 944 extern char **environ;
703 int argc = sizeof (args) / sizeof (args [0]); 945 int argc = sizeof (args) / sizeof (args [0]);
704 char **argv = args; 946 char **argv = args;
947
948 static char *args[] = {
949 "staticperl",
950 "-e",
951 "0"
952 };
705 953
706 PERL_SYS_INIT3 (&argc, &argv, &environ); 954 PERL_SYS_INIT3 (&argc, &argv, &environ);
707 staticperl = perl_alloc (); 955 staticperl = perl_alloc ();
708 perl_construct (staticperl); 956 perl_construct (staticperl);
709 PL_origalen = 1; 957 PL_origalen = 1;
… …
743} 991}
744 992
745{ 993{
746 print "generating $PREFIX.ldopts... "; 994 print "generating $PREFIX.ldopts... ";
747 995
748 my $str = $STATIC ? "--static " : ""; 996 my $str = $STATIC ? "-static " : "";
749 997
750 $str .= "$Config{ccdlflags} $Config{ldflags} @libs $Config{archlibexp}/CORE/$Config{libperl} $Config{perllibs}"; 998 $str .= "$Config{ccdlflags} $Config{ldflags} @libs $Config{archlibexp}/CORE/$Config{libperl} $Config{perllibs}";
751 999
752 my %seen; 1000 my %seen;
753 $str .= " $_" for grep !$seen{$_}++, ($extralibs =~ /(\S+)/g); 1001 $str .= " $_" for grep !$seen{$_}++, ($extralibs =~ /(\S+)/g);
1002
1003 for (@staticlibs) {
1004 $str =~ s/(^|\s) (-l\Q$_\E) ($|\s)/$1-Wl,-Bstatic $2 -Wl,-Bdynamic$3/gx;
1005 }
754 1006
755 $str =~ s/([\(\)])/\\$1/g; 1007 $str =~ s/([\(\)])/\\$1/g;
756 1008
757 print "$str\n\n"; 1009 print "$str\n\n";
758 1010
759 open my $fh, ">$PREFIX.ldopts" 1011 open my $fh, ">$PREFIX.ldopts"
760 or die "$PREFIX.ldopts: $!"; 1012 or die "$PREFIX.ldopts: $!";
761 print $fh $str; 1013 print $fh $str;
762} 1014}
763 1015
764if ($PERL) { 1016if ($PERL or defined $APP) {
1017 $APP = "perl" unless defined $APP;
1018
1019 print "generating $APP...\n";
1020
765 system "$Config{cc} \$(cat bundle.ccopts\) -o perl bundle.c \$(cat bundle.ldopts\)"; 1021 system "$Config{cc} \$(cat bundle.ccopts\) -o \Q$APP\E bundle.c \$(cat bundle.ldopts\)";
766 1022
767 unlink "$PREFIX.$_" 1023# unlink "$PREFIX.$_"
768 for qw(ccopts ldopts c h); 1024# for qw(ccopts ldopts c h);
769}
770 1025
1026 print "\n";
1027}
1028

Diff Legend

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