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

Comparing App-Staticperl/mkbundle (file contents):
Revision 1.10 by root, Thu Dec 9 09:51:32 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;
9our $APP; 10our $APP;
10our $VERIFY = 0; 11our $VERIFY = 0;
11our $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
12 18
13my $PREFIX = "bundle"; 19my $PREFIX = "bundle";
14my $PACKAGE = "static"; 20my $PACKAGE = "static";
15 21
16my %pm; 22my %pm;
… …
21my @staticlibs; 27my @staticlibs;
22my @incext; 28my @incext;
23 29
24@ARGV 30@ARGV
25 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 }
26 35
27$|=1; 36$|=1;
28 37
29our ($TRACER_W, $TRACER_R); 38our ($TRACER_W, $TRACER_R);
30 39
… …
78 exit 0; 87 exit 0;
79 } 88 }
80} 89}
81 90
82# module loading is now safe 91# module loading is now safe
83use Config;
84
85sub scan_al {
86 my ($auto, $autodir, $ix) = @_;
87
88 $pm{"$auto/$ix"} = "$autodir/$ix";
89
90 open my $fh, "<:perlio", "$autodir/$ix"
91 or die "$autodir/$ix: $!";
92
93 my $package;
94
95 while (<$fh>) {
96 if (/^\s*sub\s+ ([^[:space:];]+) \s* (?:\([^)]*\))? \s*;?\s*$/x) {
97 my $al = "auto/$package/$1.al";
98 my $inc = find_inc $al;
99
100 defined $inc or die "$al: autoload file not found, but should be there.\n";
101
102 $pm{$al} = "$inc/$al";
103
104 } elsif (/^\s*package\s+([^[:space:];]+)\s*;?\s*$/) {
105 ($package = $1) =~ s/::/\//g;
106 } elsif (/^\s*(?:#|1?\s*;?\s*$)/) {
107 # nop
108 } else {
109 warn "$autodir/$ix: unparsable line, please report: $_";
110 }
111 }
112}
113 92
114sub trace_module { 93sub trace_module {
115 syswrite $TRACER_W, "use $_[0]\n"; 94 syswrite $TRACER_W, "use $_[0]\n";
116 95
117 for (;;) { 96 for (;;) {
118 <$TRACER_R> =~ /^-$/ or last; 97 <$TRACER_R> =~ /^-$/ or last;
119 my $dir = <$TRACER_R>; chomp $dir; 98 my $dir = <$TRACER_R>; chomp $dir;
120 my $name = <$TRACER_R>; chomp $name; 99 my $name = <$TRACER_R>; chomp $name;
121 100
122 $pm{$name} = "$dir/$name"; 101 $pm{$name} = "$dir/$name";
123
124 if ($name =~ /^(.*)\.pm$/) {
125 my $auto = "auto/$1";
126 my $autodir = "$dir/$auto";
127
128 if (-d $autodir) {
129 opendir my $dir, $autodir
130 or die "$autodir: $!\n";
131
132 for (readdir $dir) {
133 # AutoLoader
134 scan_al $auto, $autodir, $_
135 if /\.ix$/;
136
137 # static ext
138 if (/\Q$Config{_a}\E$/o) {
139 push @libs, "$autodir/$_";
140 push @static_ext, $name;
141 }
142
143 # extralibs.ld
144 if ($_ eq "extralibs.ld") {
145 open my $fh, "<:perlio", "$autodir/$_"
146 or die "$autodir/$_";
147
148 local $/;
149 $extralibs .= " " . <$fh>;
150 }
151
152 # dynamic object
153 warn "WARNING: found shared object - can't link statically ($_)\n"
154 if /\.\Q$Config{dlext}\E$/o;
155 }
156 }
157 }
158 } 102 }
159} 103}
160 104
161sub trace_eval { 105sub trace_eval {
162 syswrite $TRACER_W, "eval $_[0]\n"; 106 syswrite $TRACER_W, "eval $_[0]\n";
… …
169 113
170############################################################################# 114#############################################################################
171# now we can use modules 115# now we can use modules
172 116
173use common::sense; 117use common::sense;
118use Config;
174use 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}
175 146
176sub dump_string { 147sub dump_string {
177 my ($fh, $data) = @_; 148 my ($fh, $data) = @_;
178 149
179 if (length $data) { 150 if (length $data) {
… …
189 } else { 160 } else {
190 print $fh " \"\"\n"; 161 print $fh " \"\"\n";
191 } 162 }
192} 163}
193 164
194# required for @INC loading, unfortunately 165#############################################################################
195trace_module "PerlIO::scalar";
196 166
197#trace_module "Term::ReadLine::readline"; # Term::ReadLine::Perl dependency 167sub glob2re {
198# URI is difficult 168 for (quotemeta $_[0]) {
199#trace_module "URI::http"; 169 s/\\\*/\x00/g;
200#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#############################################################################
201 235
202sub cmd_boot { 236sub cmd_boot {
203 $pm{"//boot"} = $_[0]; 237 $pm{"//boot"} = $_[0];
204} 238}
205 239
… …
215} 249}
216 250
217sub cmd_staticlib { 251sub cmd_staticlib {
218 push @staticlibs, $_ 252 push @staticlibs, $_
219 for split /\s+/, $_[0]; 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 }
220} 271}
221 272
222sub cmd_file { 273sub cmd_file {
223 open my $fh, "<", $_[0] 274 open my $fh, "<", $_[0]
224 or die "$_[0]: $!\n"; 275 or die "$_[0]: $!\n";
… …
247 $STATIC = 1; 298 $STATIC = 1;
248 } elsif ($cmd eq "add") { 299 } elsif ($cmd eq "add") {
249 cmd_add $args, 0; 300 cmd_add $args, 0;
250 } elsif ($cmd eq "addbin") { 301 } elsif ($cmd eq "addbin") {
251 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;
252 } elsif (/^\s*#/) { 309 } elsif (/^\s*#/) {
253 # comment 310 # comment
254 } elsif (/\S/) { 311 } elsif (/\S/) {
255 die "$_: unsupported directive\n"; 312 die "$_: unsupported directive\n";
256 } 313 }
… …
261 318
262Getopt::Long::Configure ("bundling", "no_auto_abbrev", "no_ignore_case"); 319Getopt::Long::Configure ("bundling", "no_auto_abbrev", "no_ignore_case");
263 320
264GetOptions 321GetOptions
265 "strip=s" => \$STRIP, 322 "strip=s" => \$STRIP,
323 "cache=s" => \$CACHE, # internal option
266 "verbose|v" => sub { ++$VERBOSE }, 324 "verbose|v" => sub { ++$VERBOSE },
267 "quiet|q" => sub { --$VERBOSE }, 325 "quiet|q" => sub { --$VERBOSE },
268 "perl" => \$PERL, 326 "perl" => \$PERL,
269 "app=s" => \$APP, 327 "app=s" => \$APP,
270 "eval|e=s" => sub { trace_eval $_[1] }, 328 "eval|e=s" => sub { trace_eval $_[1] },
271 "use|M=s" => sub { trace_module $_[1] }, 329 "use|M=s" => sub { trace_module $_[1] },
272 "boot=s" => sub { cmd_boot $_[1] }, 330 "boot=s" => sub { cmd_boot $_[1] },
273 "add=s" => sub { cmd_add $_[1], 0 }, 331 "add=s" => sub { cmd_add $_[1], 0 },
274 "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 },
275 "static" => sub { $STATIC = 1 }, 336 "static" => sub { $STATIC = 1 },
276 "staticlib=s" => sub { cmd_staticlib $_[1] }, 337 "staticlib=s" => sub { cmd_staticlib $_[1] },
277 "<>" => sub { cmd_file $_[0] }, 338 "<>" => sub { cmd_file $_[0] },
278 or exit 1; 339 or exit 1;
279 340
280die "cannot specify both --app and --perl\n" 341die "cannot specify both --app and --perl\n"
281 if $PERL and defined $APP; 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#############################################################################
282 441
283my $data; 442my $data;
284my @index; 443my @index;
285my @order = sort { 444my @order = sort {
286 length $a <=> length $b 445 length $a <=> length $b
… …
293 452
294for my $pm (@order) { 453for my $pm (@order) {
295 my $path = $pm{$pm}; 454 my $path = $pm{$pm};
296 455
297 128 > length $pm 456 128 > length $pm
298 or die "$pm: path too long (only 128 octets supported)\n"; 457 or die "ERROR: $pm: path too long (only 128 octets supported)\n";
299 458
300 my $src = ref $path 459 my $src = ref $path
301 ? $$path 460 ? $$path
302 : do { 461 : do {
303 open my $pm, "<", $path 462 open my $pm, "<", $path
… …
306 local $/; 465 local $/;
307 466
308 <$pm> 467 <$pm>
309 }; 468 };
310 469
470 my $size = length $src;
471
311 unless ($pmbin{$pm}) { # only do this unless the file is binary 472 unless ($pmbin{$pm}) { # only do this unless the file is binary
312
313 if ($pm =~ /^auto\/POSIX\/[^\/]+\.al$/) { 473 if ($pm =~ /^auto\/POSIX\/[^\/]+\.al$/) {
314 if ($src =~ /^ unimpl \"/m) { 474 if ($src =~ /^ unimpl \"/m) {
315 warn "$pm: skipping (not implemented anyways).\n" 475 warn "$pm: skipping (not implemented anyways).\n"
316 if $VERBOSE >= 2; 476 if $VERBOSE >= 2;
317 next; 477 next;
318 } 478 }
319 } 479 }
320 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
321 if ($STRIP =~ /ppi/i) { 511 if ($STRIP =~ /ppi/i) {
322 require PPI; 512 require PPI;
323 513
324 my $ppi = PPI::Document->new (\$src); 514 if (my $ppi = PPI::Document->new (\$src)) {
325 $ppi->prune ("PPI::Token::Comment"); 515 $ppi->prune ("PPI::Token::Comment");
326 $ppi->prune ("PPI::Token::Pod"); 516 $ppi->prune ("PPI::Token::Pod");
327 517
328 # prune END stuff 518 # prune END stuff
329 for (my $last = $ppi->last_element; $last; ) { 519 for (my $last = $ppi->last_element; $last; ) {
330 my $prev = $last->previous_token; 520 my $prev = $last->previous_token;
331 521
332 if ($last->isa (PPI::Token::Whitespace::)) { 522 if ($last->isa (PPI::Token::Whitespace::)) {
333 $last->delete; 523 $last->delete;
334 } elsif ($last->isa (PPI::Statement::End::)) { 524 } elsif ($last->isa (PPI::Statement::End::)) {
335 $last->delete; 525 $last->delete;
336 last; 526 last;
337 } elsif ($last->isa (PPI::Token::Pod::)) { 527 } elsif ($last->isa (PPI::Token::Pod::)) {
338 $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;
339 } else { 602 } else {
340 last; 603 warn "WARNING: $pm{$pm}: PPI failed to parse this file\n";
341 } 604 }
605 } elsif ($STRIP =~ /pod/i && $pm ne "Opcode.pm") { # opcode parses it's own pod
606 require Pod::Strip;
342 607
343 $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;
344 } 615 }
345 616
346 # prune some but not all insignificant whitespace 617 if ($VERIFY && $pm =~ /\.pm$/ && $pm ne "Opcode.pm") {
347 for my $ws (@{ $ppi->find (PPI::Token::Whitespace::) }) { 618 if (open my $fh, "-|") {
348 my $prev = $ws->previous_token;
349 my $next = $ws->next_token;
350
351 if (!$prev || !$next) {
352 $ws->delete; 619 <$fh>;
353 } else { 620 } else {
354 if ( 621 eval "#line 1 \"$pm\"\n$src" or warn "\n\n\n$pm\n\n$src\n$@\n\n\n";
355 $next->isa (PPI::Token::Operator::) && $next->{content} =~ /^(?:,|=|!|!=|==|=>)$/ # no ., because of digits. == float
356 or $prev->isa (PPI::Token::Operator::) && $prev->{content} =~ /^(?:,|=|\.|!|!=|==|=>)$/
357 or $prev->isa (PPI::Token::Structure::)
358 # decrease size, decrease compressability
359 #or ($prev->isa (PPI::Token::Word::)
360 # && (PPI::Token::Symbol:: eq ref $next
361 # || $next->isa (PPI::Structure::Block::)
362 # || $next->isa (PPI::Structure::List::)
363 # || $next->isa (PPI::Structure::Condition::)))
364 ) {
365 $ws->delete;
366 } elsif ($prev->isa (PPI::Token::Whitespace::)) {
367 $ws->{content} = ' ';
368 $prev->delete;
369 } else {
370 $ws->{content} = ' ';
371 } 622 exit 0;
372 } 623 }
373 } 624 }
374 625
375 # prune whitespace around blocks
376 if (0) {
377 # these usually decrease size, but decrease compressability more
378 for my $struct (PPI::Structure::Block::, PPI::Structure::Condition::) {
379 for my $node (@{ $ppi->find ($struct) }) {
380 my $n1 = $node->first_token;
381 my $n2 = $n1->previous_token;
382 $n1->delete if $n1->isa (PPI::Token::Whitespace::);
383 $n2->delete if $n2 && $n2->isa (PPI::Token::Whitespace::);
384 my $n1 = $node->last_token;
385 my $n2 = $n1->next_token;
386 $n1->delete if $n1->isa (PPI::Token::Whitespace::);
387 $n2->delete if $n2 && $n2->isa (PPI::Token::Whitespace::);
388 }
389 }
390
391 for my $node (@{ $ppi->find (PPI::Structure::List::) }) {
392 my $n1 = $node->first_token;
393 $n1->delete if $n1->isa (PPI::Token::Whitespace::);
394 my $n1 = $node->last_token;
395 $n1->delete if $n1->isa (PPI::Token::Whitespace::);
396 }
397 } 626 $src
398
399 # reformat qw() lists which often have lots of whitespace
400 for my $node (@{ $ppi->find (PPI::Token::QuoteLike::Words::) }) {
401 if ($node->{content} =~ /^qw(.)(.*)(.)$/s) {
402 my ($a, $qw, $b) = ($1, $2, $3);
403 $qw =~ s/^\s+//;
404 $qw =~ s/\s+$//;
405 $qw =~ s/\s+/ /g;
406 $node->{content} = "qw$a$qw$b";
407 }
408 }
409
410 $src = $ppi->serialize;
411 } elsif ($STRIP =~ /pod/i && $pm ne "Opcode.pm") { # opcode parses it's own pod
412 require Pod::Strip;
413
414 my $stripper = Pod::Strip->new;
415
416 my $out;
417 $stripper->output_string (\$out);
418 $stripper->parse_string_document ($src)
419 or die;
420 $src = $out;
421 } 627 };
422
423 if ($VERIFY && $pm =~ /\.pm$/ && $pm ne "Opcode.pm") {
424 if (open my $fh, "-|") {
425 <$fh>;
426 } else {
427 eval "#line 1 \"$pm\"\n$src" or warn "\n\n\n$pm\n\n$src\n$@\n\n\n";
428 exit 0;
429 }
430 }
431 628
432# if ($pm eq "Opcode.pm") { 629# if ($pm eq "Opcode.pm") {
433# open my $fh, ">x" or die; print $fh $src;#d# 630# open my $fh, ">x" or die; print $fh $src;#d#
434# exit 1; 631# exit 1;
435# } 632# }
436 } 633 }
437 634
438 warn "adding $pm\n" 635 print "adding $pm{$pm} (original size $size, stored size ", length $src, ")\n"
439 if $VERBOSE >= 2; 636 if $VERBOSE >= 2;
440 637
441 push @index, ((length $pm) << 25) | length $data; 638 push @index, ((length $pm) << 25) | length $data;
442 $data .= $pm . $src; 639 $data .= $pm . $src;
443} 640}
… …
821 1018
822 print "generating $APP...\n"; 1019 print "generating $APP...\n";
823 1020
824 system "$Config{cc} \$(cat bundle.ccopts\) -o \Q$APP\E bundle.c \$(cat bundle.ldopts\)"; 1021 system "$Config{cc} \$(cat bundle.ccopts\) -o \Q$APP\E bundle.c \$(cat bundle.ldopts\)";
825 1022
826 unlink "$PREFIX.$_" 1023# unlink "$PREFIX.$_"
827 for qw(ccopts ldopts c h); 1024# for qw(ccopts ldopts c h);
828}
829 1025
1026 print "\n";
1027}
1028

Diff Legend

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