… | |
… | |
11 | |
11 | |
12 | my $PREFIX = "bundle"; |
12 | my $PREFIX = "bundle"; |
13 | my $PACKAGE = "static"; |
13 | my $PACKAGE = "static"; |
14 | |
14 | |
15 | my %pm; |
15 | my %pm; |
|
|
16 | my %pmbin; |
16 | my @libs; |
17 | my @libs; |
17 | my @static_ext; |
18 | my @static_ext; |
18 | my $extralibs; |
19 | my $extralibs; |
19 | |
20 | |
20 | @ARGV |
21 | @ARGV |
… | |
… | |
81 | sub scan_al { |
82 | sub scan_al { |
82 | my ($auto, $autodir, $ix) = @_; |
83 | my ($auto, $autodir, $ix) = @_; |
83 | |
84 | |
84 | $pm{"$auto/$ix"} = "$autodir/$ix"; |
85 | $pm{"$auto/$ix"} = "$autodir/$ix"; |
85 | |
86 | |
86 | open my $fh, "<", "$autodir/$ix" |
87 | open my $fh, "<:perlio", "$autodir/$ix" |
87 | or die "$autodir/$ix: $!"; |
88 | or die "$autodir/$ix: $!"; |
88 | |
89 | |
89 | my $package; |
90 | my $package; |
90 | |
91 | |
91 | while (<$fh>) { |
92 | while (<$fh>) { |
… | |
… | |
205 | |
206 | |
206 | my $file = $1; |
207 | my $file = $1; |
207 | my $as = defined $2 ? $2 : "/$1"; |
208 | my $as = defined $2 ? $2 : "/$1"; |
208 | |
209 | |
209 | $pm{$as} = $file; |
210 | $pm{$as} = $file; |
|
|
211 | $pmbin{$as} = 1 if $_[1]; |
210 | } |
212 | } |
211 | |
213 | |
212 | sub cmd_file { |
214 | sub cmd_file { |
213 | open my $fh, "<", $_[0] |
215 | open my $fh, "<", $_[0] |
214 | or die "$_[0]: $!\n"; |
216 | or die "$_[0]: $!\n"; |
… | |
… | |
228 | } elsif ($cmd eq "boot") { |
230 | } elsif ($cmd eq "boot") { |
229 | cmd_boot $args; |
231 | cmd_boot $args; |
230 | } elsif ($cmd eq "static") { |
232 | } elsif ($cmd eq "static") { |
231 | $STATIC = 1; |
233 | $STATIC = 1; |
232 | } elsif ($cmd eq "add") { |
234 | } elsif ($cmd eq "add") { |
233 | cmd_add $args; |
235 | cmd_add $args, 0; |
|
|
236 | } elsif ($cmd eq "addbin") { |
|
|
237 | cmd_add $args, 1; |
234 | } elsif (/^\s*#/) { |
238 | } elsif (/^\s*#/) { |
235 | # comment |
239 | # comment |
236 | } elsif (/\S/) { |
240 | } elsif (/\S/) { |
237 | die "$_: unsupported directive\n"; |
241 | die "$_: unsupported directive\n"; |
238 | } |
242 | } |
… | |
… | |
249 | "quiet|q" => sub { --$VERBOSE }, |
253 | "quiet|q" => sub { --$VERBOSE }, |
250 | "perl" => \$PERL, |
254 | "perl" => \$PERL, |
251 | "eval|e=s" => sub { trace_eval $_[1] }, |
255 | "eval|e=s" => sub { trace_eval $_[1] }, |
252 | "use|M=s" => sub { trace_module $_[1] }, |
256 | "use|M=s" => sub { trace_module $_[1] }, |
253 | "boot=s" => sub { cmd_boot $_[1] }, |
257 | "boot=s" => sub { cmd_boot $_[1] }, |
254 | "add=s" => sub { cmd_add $_[1] }, |
258 | "add=s" => sub { cmd_add $_[1], 0 }, |
|
|
259 | "addbin=s" => sub { cmd_add $_[1], 1 }, |
255 | "static" => sub { $STATIC = 1 }, |
260 | "static" => sub { $STATIC = 1 }, |
256 | "<>" => sub { cmd_file $_[0] }, |
261 | "<>" => sub { cmd_file $_[0] }, |
257 | or exit 1; |
262 | or exit 1; |
258 | |
263 | |
259 | my $data; |
264 | my $data; |
… | |
… | |
282 | local $/; |
287 | local $/; |
283 | |
288 | |
284 | <$pm> |
289 | <$pm> |
285 | }; |
290 | }; |
286 | |
291 | |
|
|
292 | unless ($pmbin{$pm}) { # only do this unless the file is binary |
|
|
293 | |
287 | if ($pm =~ /^auto\/POSIX\/[^\/]+\.al$/) { |
294 | if ($pm =~ /^auto\/POSIX\/[^\/]+\.al$/) { |
288 | if ($src =~ /^ unimpl \"/m) { |
295 | if ($src =~ /^ unimpl \"/m) { |
289 | warn "$pm: skipping (not implemented anyways).\n" |
296 | warn "$pm: skipping (not implemented anyways).\n" |
290 | if $VERBOSE >= 2; |
297 | if $VERBOSE >= 2; |
291 | next; |
298 | next; |
292 | } |
|
|
293 | } |
|
|
294 | |
|
|
295 | if ($STRIP =~ /ppi/i) { |
|
|
296 | require PPI; |
|
|
297 | |
|
|
298 | my $ppi = PPI::Document->new (\$src); |
|
|
299 | $ppi->prune ("PPI::Token::Comment"); |
|
|
300 | $ppi->prune ("PPI::Token::Pod"); |
|
|
301 | |
|
|
302 | # prune END stuff |
|
|
303 | for (my $last = $ppi->last_element; $last; ) { |
|
|
304 | my $prev = $last->previous_token; |
|
|
305 | |
|
|
306 | if ($last->isa (PPI::Token::Whitespace::)) { |
|
|
307 | $last->delete; |
|
|
308 | } elsif ($last->isa (PPI::Statement::End::)) { |
|
|
309 | $last->delete; |
|
|
310 | last; |
|
|
311 | } elsif ($last->isa (PPI::Token::Pod::)) { |
|
|
312 | $last->delete; |
|
|
313 | } else { |
|
|
314 | last; |
|
|
315 | } |
299 | } |
|
|
300 | } |
316 | |
301 | |
|
|
302 | if ($STRIP =~ /ppi/i) { |
|
|
303 | require PPI; |
|
|
304 | |
|
|
305 | my $ppi = PPI::Document->new (\$src); |
|
|
306 | $ppi->prune ("PPI::Token::Comment"); |
|
|
307 | $ppi->prune ("PPI::Token::Pod"); |
|
|
308 | |
|
|
309 | # prune END stuff |
|
|
310 | for (my $last = $ppi->last_element; $last; ) { |
|
|
311 | my $prev = $last->previous_token; |
|
|
312 | |
|
|
313 | if ($last->isa (PPI::Token::Whitespace::)) { |
|
|
314 | $last->delete; |
|
|
315 | } elsif ($last->isa (PPI::Statement::End::)) { |
|
|
316 | $last->delete; |
|
|
317 | last; |
|
|
318 | } elsif ($last->isa (PPI::Token::Pod::)) { |
|
|
319 | $last->delete; |
|
|
320 | } else { |
|
|
321 | last; |
|
|
322 | } |
|
|
323 | |
317 | $last = $prev; |
324 | $last = $prev; |
318 | } |
325 | } |
319 | |
326 | |
320 | # prune some but not all insignificant whitespace |
327 | # prune some but not all insignificant whitespace |
321 | for my $ws (@{ $ppi->find (PPI::Token::Whitespace::) }) { |
328 | for my $ws (@{ $ppi->find (PPI::Token::Whitespace::) }) { |
322 | my $prev = $ws->previous_token; |
329 | my $prev = $ws->previous_token; |
323 | my $next = $ws->next_token; |
330 | my $next = $ws->next_token; |
324 | |
331 | |
325 | if (!$prev || !$next) { |
332 | if (!$prev || !$next) { |
326 | $ws->delete; |
|
|
327 | } else { |
|
|
328 | if ( |
|
|
329 | $next->isa (PPI::Token::Operator::) && $next->{content} =~ /^(?:,|=|!|!=|==|=>)$/ # no ., because of digits. == float |
|
|
330 | or $prev->isa (PPI::Token::Operator::) && $prev->{content} =~ /^(?:,|=|\.|!|!=|==|=>)$/ |
|
|
331 | or $prev->isa (PPI::Token::Structure::) |
|
|
332 | # decrease size, decrease compressability |
|
|
333 | #or ($prev->isa (PPI::Token::Word::) |
|
|
334 | # && (PPI::Token::Symbol:: eq ref $next |
|
|
335 | # || $next->isa (PPI::Structure::Block::) |
|
|
336 | # || $next->isa (PPI::Structure::List::) |
|
|
337 | # || $next->isa (PPI::Structure::Condition::))) |
|
|
338 | ) { |
|
|
339 | $ws->delete; |
333 | $ws->delete; |
340 | } elsif ($prev->isa (PPI::Token::Whitespace::)) { |
|
|
341 | $ws->{content} = ' '; |
|
|
342 | $prev->delete; |
|
|
343 | } else { |
334 | } else { |
|
|
335 | if ( |
|
|
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::)) { |
344 | $ws->{content} = ' '; |
348 | $ws->{content} = ' '; |
|
|
349 | $prev->delete; |
|
|
350 | } else { |
|
|
351 | $ws->{content} = ' '; |
|
|
352 | } |
345 | } |
353 | } |
346 | } |
354 | } |
347 | } |
|
|
348 | |
355 | |
349 | # prune whitespace around blocks |
356 | # prune whitespace around blocks |
350 | if (0) { |
357 | if (0) { |
351 | # these usually decrease size, but decrease compressability more |
358 | # these usually decrease size, but decrease compressability more |
352 | for my $struct (PPI::Structure::Block::, PPI::Structure::Condition::) { |
359 | for my $struct (PPI::Structure::Block::, PPI::Structure::Condition::) { |
353 | for my $node (@{ $ppi->find ($struct) }) { |
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::) }) { |
354 | my $n1 = $node->first_token; |
373 | my $n1 = $node->first_token; |
355 | my $n2 = $n1->previous_token; |
|
|
356 | $n1->delete if $n1->isa (PPI::Token::Whitespace::); |
374 | $n1->delete if $n1->isa (PPI::Token::Whitespace::); |
357 | $n2->delete if $n2 && $n2->isa (PPI::Token::Whitespace::); |
|
|
358 | my $n1 = $node->last_token; |
375 | my $n1 = $node->last_token; |
359 | my $n2 = $n1->next_token; |
|
|
360 | $n1->delete if $n1->isa (PPI::Token::Whitespace::); |
376 | $n1->delete if $n1->isa (PPI::Token::Whitespace::); |
361 | $n2->delete if $n2 && $n2->isa (PPI::Token::Whitespace::); |
|
|
362 | } |
377 | } |
363 | } |
378 | } |
364 | |
379 | |
|
|
380 | # reformat qw() lists which often have lots of whitespace |
365 | for my $node (@{ $ppi->find (PPI::Structure::List::) }) { |
381 | for my $node (@{ $ppi->find (PPI::Token::QuoteLike::Words::) }) { |
366 | my $n1 = $node->first_token; |
382 | if ($node->{content} =~ /^qw(.)(.*)(.)$/s) { |
367 | $n1->delete if $n1->isa (PPI::Token::Whitespace::); |
383 | my ($a, $qw, $b) = ($1, $2, $3); |
368 | my $n1 = $node->last_token; |
384 | $qw =~ s/^\s+//; |
369 | $n1->delete if $n1->isa (PPI::Token::Whitespace::); |
385 | $qw =~ s/\s+$//; |
|
|
386 | $qw =~ s/\s+/ /g; |
|
|
387 | $node->{content} = "qw$a$qw$b"; |
|
|
388 | } |
370 | } |
389 | } |
371 | } |
|
|
372 | |
390 | |
373 | # reformat qw() lists which often have lots of whitespace |
391 | $src = $ppi->serialize; |
374 | for my $node (@{ $ppi->find (PPI::Token::QuoteLike::Words::) }) { |
392 | } elsif ($STRIP =~ /pod/i && $pm ne "Opcode.pm") { # opcode parses it's own pod |
375 | if ($node->{content} =~ /^qw(.)(.*)(.)$/s) { |
393 | require Pod::Strip; |
376 | my ($a, $qw, $b) = ($1, $2, $3); |
394 | |
377 | $qw =~ s/^\s+//; |
395 | my $stripper = Pod::Strip->new; |
378 | $qw =~ s/\s+$//; |
396 | |
379 | $qw =~ s/\s+/ /g; |
397 | my $out; |
380 | $node->{content} = "qw$a$qw$b"; |
398 | $stripper->output_string (\$out); |
|
|
399 | $stripper->parse_string_document ($src) |
|
|
400 | or die; |
|
|
401 | $src = $out; |
|
|
402 | } |
|
|
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; |
381 | } |
410 | } |
382 | } |
411 | } |
383 | |
412 | |
384 | $src = $ppi->serialize; |
413 | # if ($pm eq "Opcode.pm") { |
385 | } elsif ($STRIP =~ /pod/i && $pm ne "Opcode.pm") { # opcode parses it's own pod |
414 | # open my $fh, ">x" or die; print $fh $src;#d# |
386 | require Pod::Strip; |
415 | # exit 1; |
387 | |
416 | # } |
388 | my $stripper = Pod::Strip->new; |
|
|
389 | |
|
|
390 | my $out; |
|
|
391 | $stripper->output_string (\$out); |
|
|
392 | $stripper->parse_string_document ($src) |
|
|
393 | or die; |
|
|
394 | $src = $out; |
|
|
395 | } |
417 | } |
396 | |
|
|
397 | if ($VERIFY && $pm =~ /\.pm$/ && $pm ne "Opcode.pm") { |
|
|
398 | if (open my $fh, "-|") { |
|
|
399 | <$fh>; |
|
|
400 | } else { |
|
|
401 | eval "#line 1 \"$pm\"\n$src" or warn "\n\n\n$pm\n\n$src\n$@\n\n\n"; |
|
|
402 | exit 0; |
|
|
403 | } |
|
|
404 | } |
|
|
405 | |
|
|
406 | # if ($pm eq "Opcode.pm") { |
|
|
407 | # open my $fh, ">x" or die; print $fh $src;#d# |
|
|
408 | # exit 1; |
|
|
409 | # } |
|
|
410 | |
418 | |
411 | warn "adding $pm\n" |
419 | warn "adding $pm\n" |
412 | if $VERBOSE >= 2; |
420 | if $VERBOSE >= 2; |
413 | |
421 | |
414 | push @index, ((length $pm) << 25) | length $data; |
422 | push @index, ((length $pm) << 25) | length $data; |