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

Comparing App-Staticperl/mkbundle (file contents):
Revision 1.4 by root, Mon Dec 6 21:10:41 2010 UTC vs.
Revision 1.8 by root, Wed Dec 8 09:13:55 2010 UTC

… …
11 11
12my $PREFIX = "bundle"; 12my $PREFIX = "bundle";
13my $PACKAGE = "static"; 13my $PACKAGE = "static";
14 14
15my %pm; 15my %pm;
16my %pmbin;
16my @libs; 17my @libs;
17my @static_ext; 18my @static_ext;
18my $extralibs; 19my $extralibs;
19 20
20@ARGV 21@ARGV
… …
76} 77}
77 78
78# module loading is now safe 79# module loading is now safe
79use Config; 80use Config;
80 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
81sub trace_module { 111sub trace_module {
82 syswrite $TRACER_W, "use $_[0]\n"; 112 syswrite $TRACER_W, "use $_[0]\n";
83 113
84 for (;;) { 114 for (;;) {
85 <$TRACER_R> =~ /^-$/ or last; 115 <$TRACER_R> =~ /^-$/ or last;
… …
96 opendir my $dir, $autodir 126 opendir my $dir, $autodir
97 or die "$autodir: $!\n"; 127 or die "$autodir: $!\n";
98 128
99 for (readdir $dir) { 129 for (readdir $dir) {
100 # AutoLoader 130 # AutoLoader
101 $pm{"$auto/$_"} = "$autodir/$_" 131 scan_al $auto, $autodir, $_
102 if /\.(?:al|ix)$/; 132 if /\.ix$/;
103 133
104 # static ext 134 # static ext
105 if (/\Q$Config{_a}\E$/o) { 135 if (/\Q$Config{_a}\E$/o) {
106 push @libs, "$autodir/$_"; 136 push @libs, "$autodir/$_";
107 push @static_ext, $name; 137 push @static_ext, $name;
… …
117 } 147 }
118 148
119 # dynamic object 149 # dynamic object
120 warn "WARNING: found shared object - can't link statically ($_)\n" 150 warn "WARNING: found shared object - can't link statically ($_)\n"
121 if /\.\Q$Config{dlext}\E$/o; 151 if /\.\Q$Config{dlext}\E$/o;
122
123 #TODO: extralibs?
124 } 152 }
125 } 153 }
126 } 154 }
127 } 155 }
128} 156}
… …
178 206
179 my $file = $1; 207 my $file = $1;
180 my $as = defined $2 ? $2 : "/$1"; 208 my $as = defined $2 ? $2 : "/$1";
181 209
182 $pm{$as} = $file; 210 $pm{$as} = $file;
211 $pmbin{$as} = 1 if $_[1];
183} 212}
184 213
185sub cmd_file { 214sub cmd_file {
186 open my $fh, "<", $_[0] 215 open my $fh, "<", $_[0]
187 or die "$_[0]: $!\n"; 216 or die "$_[0]: $!\n";
… …
201 } elsif ($cmd eq "boot") { 230 } elsif ($cmd eq "boot") {
202 cmd_boot $args; 231 cmd_boot $args;
203 } elsif ($cmd eq "static") { 232 } elsif ($cmd eq "static") {
204 $STATIC = 1; 233 $STATIC = 1;
205 } elsif ($cmd eq "add") { 234 } elsif ($cmd eq "add") {
206 cmd_add $args; 235 cmd_add $args, 0;
236 } elsif ($cmd eq "addbin") {
237 cmd_add $args, 1;
207 } elsif (/^\s*#/) { 238 } elsif (/^\s*#/) {
208 # comment 239 # comment
209 } elsif (/\S/) { 240 } elsif (/\S/) {
210 die "$_: unsupported directive\n"; 241 die "$_: unsupported directive\n";
211 } 242 }
… …
222 "quiet|q" => sub { --$VERBOSE }, 253 "quiet|q" => sub { --$VERBOSE },
223 "perl" => \$PERL, 254 "perl" => \$PERL,
224 "eval|e=s" => sub { trace_eval $_[1] }, 255 "eval|e=s" => sub { trace_eval $_[1] },
225 "use|M=s" => sub { trace_module $_[1] }, 256 "use|M=s" => sub { trace_module $_[1] },
226 "boot=s" => sub { cmd_boot $_[1] }, 257 "boot=s" => sub { cmd_boot $_[1] },
227 "add=s" => sub { cmd_add $_[1] }, 258 "add=s" => sub { cmd_add $_[1], 0 },
259 "addbin=s" => sub { cmd_add $_[1], 1 },
228 "static" => sub { $STATIC = 1 }, 260 "static" => sub { $STATIC = 1 },
229 "<>" => sub { cmd_file $_[0] }, 261 "<>" => sub { cmd_file $_[0] },
230 or exit 1; 262 or exit 1;
231 263
232my $data; 264my $data;
… …
247 or die "$pm: path too long (only 128 octets supported)\n"; 279 or die "$pm: path too long (only 128 octets supported)\n";
248 280
249 my $src = ref $path 281 my $src = ref $path
250 ? $$path 282 ? $$path
251 : do { 283 : do {
252 open my $pm, "<:perlio", $path 284 open my $pm, "<", $path
253 or die "$path: $!"; 285 or die "$path: $!";
254 286
255 local $/; 287 local $/;
256 288
257 <$pm> 289 <$pm>
258 }; 290 };
259 291
292 unless ($pmbin{$pm}) { # only do this unless the file is binary
293
260 if ($pm =~ /^auto\/POSIX\/[^\/]+\.al$/) { 294 if ($pm =~ /^auto\/POSIX\/[^\/]+\.al$/) {
261 if ($src =~ /^ unimpl \"/m) { 295 if ($src =~ /^ unimpl \"/m) {
262 warn "$pm: skipping (not implemented anyways).\n" 296 warn "$pm: skipping (not implemented anyways).\n"
263 if $VERBOSE >= 2; 297 if $VERBOSE >= 2;
264 next; 298 next;
265 }
266 }
267
268 if ($STRIP =~ /ppi/i) {
269 require PPI;
270
271 my $ppi = PPI::Document->new (\$src);
272 $ppi->prune ("PPI::Token::Comment");
273 $ppi->prune ("PPI::Token::Pod");
274
275 # prune END stuff
276 for (my $last = $ppi->last_element; $last; ) {
277 my $prev = $last->previous_token;
278
279 if ($last->isa (PPI::Token::Whitespace::)) {
280 $last->delete;
281 } elsif ($last->isa (PPI::Statement::End::)) {
282 $last->delete;
283 last;
284 } elsif ($last->isa (PPI::Token::Pod::)) {
285 $last->delete;
286 } else {
287 last;
288 } 299 }
300 }
289 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
290 $last = $prev; 324 $last = $prev;
291 } 325 }
292 326
293 # prune some but not all insignificant whitespace 327 # prune some but not all insignificant whitespace
294 for my $ws (@{ $ppi->find (PPI::Token::Whitespace::) }) { 328 for my $ws (@{ $ppi->find (PPI::Token::Whitespace::) }) {
295 my $prev = $ws->previous_token; 329 my $prev = $ws->previous_token;
296 my $next = $ws->next_token; 330 my $next = $ws->next_token;
297 331
298 if (!$prev || !$next) { 332 if (!$prev || !$next) {
299 $ws->delete;
300 } else {
301 if (
302 $next->isa (PPI::Token::Operator::) && $next->{content} =~ /^(?:,|=|!|!=|==|=>)$/ # no ., because of digits. == float
303 or $prev->isa (PPI::Token::Operator::) && $prev->{content} =~ /^(?:,|=|\.|!|!=|==|=>)$/
304 or $prev->isa (PPI::Token::Structure::)
305 # decrease size, decrease compressability
306 #or ($prev->isa (PPI::Token::Word::)
307 # && (PPI::Token::Symbol:: eq ref $next
308 # || $next->isa (PPI::Structure::Block::)
309 # || $next->isa (PPI::Structure::List::)
310 # || $next->isa (PPI::Structure::Condition::)))
311 ) {
312 $ws->delete; 333 $ws->delete;
313 } elsif ($prev->isa (PPI::Token::Whitespace::)) {
314 $ws->{content} = ' ';
315 $prev->delete;
316 } 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::)) {
317 $ws->{content} = ' '; 348 $ws->{content} = ' ';
349 $prev->delete;
350 } else {
351 $ws->{content} = ' ';
352 }
318 } 353 }
319 } 354 }
320 }
321 355
322 # prune whitespace around blocks 356 # prune whitespace around blocks
323 if (0) { 357 if (0) {
324 # these usually decrease size, but decrease compressability more 358 # these usually decrease size, but decrease compressability more
325 for my $struct (PPI::Structure::Block::, PPI::Structure::Condition::) { 359 for my $struct (PPI::Structure::Block::, PPI::Structure::Condition::) {
326 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::) }) {
327 my $n1 = $node->first_token; 373 my $n1 = $node->first_token;
328 my $n2 = $n1->previous_token;
329 $n1->delete if $n1->isa (PPI::Token::Whitespace::); 374 $n1->delete if $n1->isa (PPI::Token::Whitespace::);
330 $n2->delete if $n2 && $n2->isa (PPI::Token::Whitespace::);
331 my $n1 = $node->last_token; 375 my $n1 = $node->last_token;
332 my $n2 = $n1->next_token;
333 $n1->delete if $n1->isa (PPI::Token::Whitespace::); 376 $n1->delete if $n1->isa (PPI::Token::Whitespace::);
334 $n2->delete if $n2 && $n2->isa (PPI::Token::Whitespace::);
335 } 377 }
336 } 378 }
337 379
380 # reformat qw() lists which often have lots of whitespace
338 for my $node (@{ $ppi->find (PPI::Structure::List::) }) { 381 for my $node (@{ $ppi->find (PPI::Token::QuoteLike::Words::) }) {
339 my $n1 = $node->first_token; 382 if ($node->{content} =~ /^qw(.)(.*)(.)$/s) {
340 $n1->delete if $n1->isa (PPI::Token::Whitespace::); 383 my ($a, $qw, $b) = ($1, $2, $3);
341 my $n1 = $node->last_token; 384 $qw =~ s/^\s+//;
342 $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 }
343 } 389 }
344 }
345 390
346 # reformat qw() lists which often have lots of whitespace 391 $src = $ppi->serialize;
347 for my $node (@{ $ppi->find (PPI::Token::QuoteLike::Words::) }) { 392 } elsif ($STRIP =~ /pod/i && $pm ne "Opcode.pm") { # opcode parses it's own pod
348 if ($node->{content} =~ /^qw(.)(.*)(.)$/s) { 393 require Pod::Strip;
349 my ($a, $qw, $b) = ($1, $2, $3); 394
350 $qw =~ s/^\s+//; 395 my $stripper = Pod::Strip->new;
351 $qw =~ s/\s+$//; 396
352 $qw =~ s/\s+/ /g; 397 my $out;
353 $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;
354 } 410 }
355 } 411 }
356 412
357 $src = $ppi->serialize; 413# if ($pm eq "Opcode.pm") {
358 } 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#
359 require Pod::Strip; 415# exit 1;
360 416# }
361 my $stripper = Pod::Strip->new;
362
363 my $out;
364 $stripper->output_string (\$out);
365 $stripper->parse_string_document ($src);
366 $src = $out;
367 } 417 }
368
369 if ($VERIFY && $pm =~ /\.pm$/ && $pm ne "Opcode.pm") {
370 if (open my $fh, "-|") {
371 <$fh>;
372 } else {
373 eval "#line 1 \"$pm\"\n$src" or warn "\n\n\n$pm\n\n$src\n$@\n\n\n";
374 exit 0;
375 }
376 }
377
378# if ($pm eq "Opcode.pm") {
379# open my $fh, ">x" or die; print $fh $src;#d#
380# exit 1;
381# }
382 418
383 warn "adding $pm\n" 419 warn "adding $pm\n"
384 if $VERBOSE >= 2; 420 if $VERBOSE >= 2;
385 421
386 push @index, ((length $pm) << 25) | length $data; 422 push @index, ((length $pm) << 25) | length $data;
… …
401 open my $fh, ">", "$PREFIX.h" 437 open my $fh, ">", "$PREFIX.h"
402 or die "$PREFIX.h: $!\n"; 438 or die "$PREFIX.h: $!\n";
403 439
404 print $fh <<EOF; 440 print $fh <<EOF;
405/* do not edit, automatically created by mkstaticbundle */ 441/* do not edit, automatically created by mkstaticbundle */
442
406#include <EXTERN.h> 443#include <EXTERN.h>
407#include <perl.h> 444#include <perl.h>
408#include <XSUB.h> 445#include <XSUB.h>
409 446
410/* public API */ 447/* public API */
411EXTERN_C PerlInterpreter *staticperl; 448EXTERN_C PerlInterpreter *staticperl;
449EXTERN_C void staticperl_xs_init (pTHX);
412EXTERN_C void staticperl_init (void); 450EXTERN_C void staticperl_init (void);
413EXTERN_C void staticperl_cleanup (void); 451EXTERN_C void staticperl_cleanup (void);
452
414EOF 453EOF
415} 454}
416 455
417print "\n"; 456print "\n";
418 457
… …
424open my $fh, ">", "$PREFIX.c" 463open my $fh, ">", "$PREFIX.c"
425 or die "$PREFIX.c: $!\n"; 464 or die "$PREFIX.c: $!\n";
426 465
427print $fh <<EOF; 466print $fh <<EOF;
428/* do not edit, automatically created by mkstaticbundle */ 467/* do not edit, automatically created by mkstaticbundle */
429
430#include <EXTERN.h>
431#include <perl.h>
432#include <XSUB.h>
433 468
434#include "bundle.h" 469#include "bundle.h"
435 470
436/* public API */ 471/* public API */
437PerlInterpreter *staticperl; 472PerlInterpreter *staticperl;
… …
588 623
589############################################################################# 624#############################################################################
590# xs_init 625# xs_init
591 626
592print $fh <<EOF; 627print $fh <<EOF;
593static void 628void
594xs_init (pTHX) 629staticperl_xs_init (pTHX)
595{ 630{
596EOF 631EOF
597 632
598@static_ext = ("DynaLoader", sort @static_ext); 633@static_ext = ("DynaLoader", sort @static_ext);
599 634
… …
645 staticperl = perl_alloc (); 680 staticperl = perl_alloc ();
646 perl_construct (staticperl); 681 perl_construct (staticperl);
647 682
648 PL_exit_flags |= PERL_EXIT_DESTRUCT_END; 683 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
649 684
650 exitstatus = perl_parse (staticperl, xs_init, argc, argv, environ); 685 exitstatus = perl_parse (staticperl, staticperl_xs_init, argc, argv, environ);
651 if (!exitstatus) 686 if (!exitstatus)
652 perl_run (staticperl); 687 perl_run (staticperl);
653 688
654 exitstatus = perl_destruct (staticperl); 689 exitstatus = perl_destruct (staticperl);
655 perl_free (staticperl); 690 perl_free (staticperl);
… …
671 PERL_SYS_INIT3 (&argc, &argv, &environ); 706 PERL_SYS_INIT3 (&argc, &argv, &environ);
672 staticperl = perl_alloc (); 707 staticperl = perl_alloc ();
673 perl_construct (staticperl); 708 perl_construct (staticperl);
674 PL_origalen = 1; 709 PL_origalen = 1;
675 PL_exit_flags |= PERL_EXIT_DESTRUCT_END; 710 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
676 perl_parse (staticperl, xs_init, argc, argv, environ); 711 perl_parse (staticperl, staticperl_xs_init, argc, argv, environ);
677 712
678 perl_run (staticperl); 713 perl_run (staticperl);
679} 714}
680 715
681EXTERN_C void 716EXTERN_C void

Diff Legend

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