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.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}
… …
171sub cmd_boot { 199sub cmd_boot {
172 $pm{"//boot"} = $_[0]; 200 $pm{"//boot"} = $_[0];
173} 201}
174 202
175sub cmd_add { 203sub cmd_add {
176 $_[0] =~ /^(.*)(?:\s*(\S+))$/ 204 $_[0] =~ /^(.*)(?:\s+(\S+))$/
177 or die "$_[0]: cannot parse"; 205 or die "$_[0]: cannot parse";
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";
188 217
189 while (<$fh>) { 218 while (<$fh>) {
190 chomp; 219 chomp;
191 my ($cmd, $args) = split / /, $_, 2; 220 my ($cmd, $args) = split / /, $_, 2;
221 $cmd =~ s/^-+//;
192 222
193 if ($cmd eq "strip") { 223 if ($cmd eq "strip") {
194 $STRIP = $args; 224 $STRIP = $args;
195 } elsif ($cmd eq "eval") { 225 } elsif ($cmd eq "eval") {
196 trace_eval $_; 226 trace_eval $_;
… …
200 } elsif ($cmd eq "boot") { 230 } elsif ($cmd eq "boot") {
201 cmd_boot $args; 231 cmd_boot $args;
202 } elsif ($cmd eq "static") { 232 } elsif ($cmd eq "static") {
203 $STATIC = 1; 233 $STATIC = 1;
204 } elsif ($cmd eq "add") { 234 } elsif ($cmd eq "add") {
205 cmd_add $args; 235 cmd_add $args, 0;
236 } elsif ($cmd eq "addbin") {
237 cmd_add $args, 1;
206 } elsif (/^\s*#/) { 238 } elsif (/^\s*#/) {
207 # comment 239 # comment
208 } elsif (/\S/) { 240 } elsif (/\S/) {
209 die "$_: unsupported directive\n"; 241 die "$_: unsupported directive\n";
210 } 242 }
… …
218GetOptions 250GetOptions
219 "strip=s" => \$STRIP, 251 "strip=s" => \$STRIP,
220 "verbose|v" => sub { ++$VERBOSE }, 252 "verbose|v" => sub { ++$VERBOSE },
221 "quiet|q" => sub { --$VERBOSE }, 253 "quiet|q" => sub { --$VERBOSE },
222 "perl" => \$PERL, 254 "perl" => \$PERL,
223 "eval=s" => sub { trace_eval $_[1] }, 255 "eval|e=s" => sub { trace_eval $_[1] },
224 "use|M=s" => sub { trace_module $_[1] }, 256 "use|M=s" => sub { trace_module $_[1] },
225 "boot=s" => sub { cmd_boot $_[1] }, 257 "boot=s" => sub { cmd_boot $_[1] },
226 "add=s" => sub { cmd_add $_[1] }, 258 "add=s" => sub { cmd_add $_[1], 0 },
259 "addbin=s" => sub { cmd_add $_[1], 1 },
227 "static" => sub { $STATIC = 1 }, 260 "static" => sub { $STATIC = 1 },
228 "<>" => sub { cmd_file $_[1] }, 261 "<>" => sub { cmd_file $_[0] },
229 or exit 1; 262 or exit 1;
230 263
231my $data; 264my $data;
232my @index; 265my @index;
233my @order = sort { 266my @order = sort {
… …
246 or die "$pm: path too long (only 128 octets supported)\n"; 279 or die "$pm: path too long (only 128 octets supported)\n";
247 280
248 my $src = ref $path 281 my $src = ref $path
249 ? $$path 282 ? $$path
250 : do { 283 : do {
251 open my $pm, "<:perlio", $path 284 open my $pm, "<", $path
252 or die "$path: $!"; 285 or die "$path: $!";
253 286
254 local $/; 287 local $/;
255 288
256 <$pm> 289 <$pm>
257 }; 290 };
258 291
292 unless ($pmbin{$pm}) { # only do this unless the file is binary
293
259 if ($pm =~ /^auto\/POSIX\/[^\/]+\.al$/) { 294 if ($pm =~ /^auto\/POSIX\/[^\/]+\.al$/) {
260 if ($src =~ /^ unimpl \"/m) { 295 if ($src =~ /^ unimpl \"/m) {
261 warn "$pm: skipping (not implemented anyways).\n" 296 warn "$pm: skipping (not implemented anyways).\n"
262 if $VERBOSE >= 2; 297 if $VERBOSE >= 2;
263 next; 298 next;
264 }
265 }
266
267 if ($STRIP =~ /ppi/i) {
268 require PPI;
269
270 my $ppi = PPI::Document->new (\$src);
271 $ppi->prune ("PPI::Token::Comment");
272 $ppi->prune ("PPI::Token::Pod");
273
274 # prune END stuff
275 for (my $last = $ppi->last_element; $last; ) {
276 my $prev = $last->previous_token;
277
278 if ($last->isa (PPI::Token::Whitespace::)) {
279 $last->delete;
280 } elsif ($last->isa (PPI::Statement::End::)) {
281 $last->delete;
282 last;
283 } elsif ($last->isa (PPI::Token::Pod::)) {
284 $last->delete;
285 } else {
286 last;
287 } 299 }
300 }
288 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
289 $last = $prev; 324 $last = $prev;
290 } 325 }
291 326
292 # prune some but not all insignificant whitespace 327 # prune some but not all insignificant whitespace
293 for my $ws (@{ $ppi->find (PPI::Token::Whitespace::) }) { 328 for my $ws (@{ $ppi->find (PPI::Token::Whitespace::) }) {
294 my $prev = $ws->previous_token; 329 my $prev = $ws->previous_token;
295 my $next = $ws->next_token; 330 my $next = $ws->next_token;
296 331
297 if (!$prev || !$next) { 332 if (!$prev || !$next) {
298 $ws->delete;
299 } else {
300 if (
301 $next->isa (PPI::Token::Operator::) && $next->{content} =~ /^(?:,|=|!|!=|==|=>)$/ # no ., because of digits. == float
302 or $prev->isa (PPI::Token::Operator::) && $prev->{content} =~ /^(?:,|=|\.|!|!=|==|=>)$/
303 or $prev->isa (PPI::Token::Structure::)
304 # decrease size, decrease compressability
305 #or ($prev->isa (PPI::Token::Word::)
306 # && (PPI::Token::Symbol:: eq ref $next
307 # || $next->isa (PPI::Structure::Block::)
308 # || $next->isa (PPI::Structure::List::)
309 # || $next->isa (PPI::Structure::Condition::)))
310 ) {
311 $ws->delete; 333 $ws->delete;
312 } elsif ($prev->isa (PPI::Token::Whitespace::)) {
313 $ws->{content} = ' ';
314 $prev->delete;
315 } 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::)) {
316 $ws->{content} = ' '; 348 $ws->{content} = ' ';
349 $prev->delete;
350 } else {
351 $ws->{content} = ' ';
352 }
317 } 353 }
318 } 354 }
319 }
320 355
321 # prune whitespace around blocks 356 # prune whitespace around blocks
322 if (0) { 357 if (0) {
323 # these usually decrease size, but decrease compressability more 358 # these usually decrease size, but decrease compressability more
324 for my $struct (PPI::Structure::Block::, PPI::Structure::Condition::) { 359 for my $struct (PPI::Structure::Block::, PPI::Structure::Condition::) {
325 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::) }) {
326 my $n1 = $node->first_token; 373 my $n1 = $node->first_token;
327 my $n2 = $n1->previous_token;
328 $n1->delete if $n1->isa (PPI::Token::Whitespace::); 374 $n1->delete if $n1->isa (PPI::Token::Whitespace::);
329 $n2->delete if $n2 && $n2->isa (PPI::Token::Whitespace::);
330 my $n1 = $node->last_token; 375 my $n1 = $node->last_token;
331 my $n2 = $n1->next_token;
332 $n1->delete if $n1->isa (PPI::Token::Whitespace::); 376 $n1->delete if $n1->isa (PPI::Token::Whitespace::);
333 $n2->delete if $n2 && $n2->isa (PPI::Token::Whitespace::);
334 } 377 }
335 } 378 }
336 379
380 # reformat qw() lists which often have lots of whitespace
337 for my $node (@{ $ppi->find (PPI::Structure::List::) }) { 381 for my $node (@{ $ppi->find (PPI::Token::QuoteLike::Words::) }) {
338 my $n1 = $node->first_token; 382 if ($node->{content} =~ /^qw(.)(.*)(.)$/s) {
339 $n1->delete if $n1->isa (PPI::Token::Whitespace::); 383 my ($a, $qw, $b) = ($1, $2, $3);
340 my $n1 = $node->last_token; 384 $qw =~ s/^\s+//;
341 $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 }
342 } 389 }
343 }
344 390
345 # reformat qw() lists which often have lots of whitespace 391 $src = $ppi->serialize;
346 for my $node (@{ $ppi->find (PPI::Token::QuoteLike::Words::) }) { 392 } elsif ($STRIP =~ /pod/i && $pm ne "Opcode.pm") { # opcode parses it's own pod
347 if ($node->{content} =~ /^qw(.)(.*)(.)$/s) { 393 require Pod::Strip;
348 my ($a, $qw, $b) = ($1, $2, $3); 394
349 $qw =~ s/^\s+//; 395 my $stripper = Pod::Strip->new;
350 $qw =~ s/\s+$//; 396
351 $qw =~ s/\s+/ /g; 397 my $out;
352 $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;
353 } 410 }
354 } 411 }
355 412
356 $src = $ppi->serialize; 413# if ($pm eq "Opcode.pm") {
357 } 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#
358 require Pod::Strip; 415# exit 1;
359 416# }
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 } 417 }
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") {
378# open my $fh, ">x" or die; print $fh $src;#d#
379# exit 1;
380# }
381 418
382 warn "adding $pm\n" 419 warn "adding $pm\n"
383 if $VERBOSE >= 2; 420 if $VERBOSE >= 2;
384 421
385 push @index, ((length $pm) << 25) | length $data; 422 push @index, ((length $pm) << 25) | length $data;
… …
400 open my $fh, ">", "$PREFIX.h" 437 open my $fh, ">", "$PREFIX.h"
401 or die "$PREFIX.h: $!\n"; 438 or die "$PREFIX.h: $!\n";
402 439
403 print $fh <<EOF; 440 print $fh <<EOF;
404/* do not edit, automatically created by mkstaticbundle */ 441/* do not edit, automatically created by mkstaticbundle */
442
405#include <EXTERN.h> 443#include <EXTERN.h>
406#include <perl.h> 444#include <perl.h>
407#include <XSUB.h> 445#include <XSUB.h>
408 446
409/* public API */ 447/* public API */
410EXTERN_C PerlInterpreter *staticperl; 448EXTERN_C PerlInterpreter *staticperl;
449EXTERN_C void staticperl_xs_init (pTHX);
411EXTERN_C void staticperl_init (void); 450EXTERN_C void staticperl_init (void);
412EXTERN_C void staticperl_cleanup (void); 451EXTERN_C void staticperl_cleanup (void);
452
413EOF 453EOF
414} 454}
415 455
416print "\n"; 456print "\n";
417 457
… …
423open my $fh, ">", "$PREFIX.c" 463open my $fh, ">", "$PREFIX.c"
424 or die "$PREFIX.c: $!\n"; 464 or die "$PREFIX.c: $!\n";
425 465
426print $fh <<EOF; 466print $fh <<EOF;
427/* do not edit, automatically created by mkstaticbundle */ 467/* do not edit, automatically created by mkstaticbundle */
428
429#include <EXTERN.h>
430#include <perl.h>
431#include <XSUB.h>
432 468
433#include "bundle.h" 469#include "bundle.h"
434 470
435/* public API */ 471/* public API */
436PerlInterpreter *staticperl; 472PerlInterpreter *staticperl;
… …
587 623
588############################################################################# 624#############################################################################
589# xs_init 625# xs_init
590 626
591print $fh <<EOF; 627print $fh <<EOF;
592static void 628void
593xs_init (pTHX) 629staticperl_xs_init (pTHX)
594{ 630{
595EOF 631EOF
596 632
597@static_ext = ("DynaLoader", sort @static_ext); 633@static_ext = ("DynaLoader", sort @static_ext);
598 634
… …
644 staticperl = perl_alloc (); 680 staticperl = perl_alloc ();
645 perl_construct (staticperl); 681 perl_construct (staticperl);
646 682
647 PL_exit_flags |= PERL_EXIT_DESTRUCT_END; 683 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
648 684
649 exitstatus = perl_parse (staticperl, xs_init, argc, argv, environ); 685 exitstatus = perl_parse (staticperl, staticperl_xs_init, argc, argv, environ);
650 if (!exitstatus) 686 if (!exitstatus)
651 perl_run (staticperl); 687 perl_run (staticperl);
652 688
653 exitstatus = perl_destruct (staticperl); 689 exitstatus = perl_destruct (staticperl);
654 perl_free (staticperl); 690 perl_free (staticperl);
… …
670 PERL_SYS_INIT3 (&argc, &argv, &environ); 706 PERL_SYS_INIT3 (&argc, &argv, &environ);
671 staticperl = perl_alloc (); 707 staticperl = perl_alloc ();
672 perl_construct (staticperl); 708 perl_construct (staticperl);
673 PL_origalen = 1; 709 PL_origalen = 1;
674 PL_exit_flags |= PERL_EXIT_DESTRUCT_END; 710 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
675 perl_parse (staticperl, xs_init, argc, argv, environ); 711 perl_parse (staticperl, staticperl_xs_init, argc, argv, environ);
676 712
677 perl_run (staticperl); 713 perl_run (staticperl);
678} 714}
679 715
680EXTERN_C void 716EXTERN_C void

Diff Legend

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