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.11 by root, Fri Dec 10 02:35:54 2010 UTC vs.
Revision 1.41 by root, Fri Aug 4 03:14:33 2023 UTC

1#!/opt/bin/perl 1#!/opt/bin/perl
2 2
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 $COMPRESS = "lzf";
8our $UNISTRIP = 1; # always on, try to strip unicore swash data 9our $UNISTRIP = 1; # always on, try to strip unicore swash data
9our $PERL = 0; 10our $PERL = 0;
10our $APP; 11our $APP;
11our $VERIFY = 0; 12our $VERIFY = 0;
12our $STATIC = 0; 13our $STATIC = 0;
14our $PACKLIST = 0;
15our $IGNORE_ENV = 0;
16our $ALLOW_DYNAMIC = 0;
17our $HAVE_DYNAMIC; # maybe useful?
18our $EXTRA_CFLAGS = "";
19our $EXTRA_LDFLAGS = "";
20our $EXTRA_LIBS = "";
13 21
14our $OPTIMISE_SIZE = 0; # optimise for raw file size instead of for compression? 22our $OPTIMISE_SIZE = 0; # optimise for raw file size instead of for compression?
15 23
16our $CACHE; 24our $CACHE;
17our $CACHEVER = 1; # do not change unless you know what you are doing 25our $CACHEVER = 2; # do not change unless you know what you are doing
18 26
19my $PREFIX = "bundle"; 27my $PREFIX = "bundle";
20my $PACKAGE = "static"; 28my $PACKAGE = "static";
21 29
22my %pm; 30my %pm;
… …
35 43
36$|=1; 44$|=1;
37 45
38our ($TRACER_W, $TRACER_R); 46our ($TRACER_W, $TRACER_R);
39 47
40sub find_inc($) { 48sub find_incdir($) {
41 for (@INC) { 49 for (@INC) {
42 next if ref; 50 next if ref;
43 return $_ if -e "$_/$_[0]"; 51 return $_ if -e "$_/$_[0]";
44 } 52 }
45 53
46 undef 54 undef
47} 55}
48 56
57sub find_inc($) {
58 my $dir = find_incdir $_[0];
59
60 return "$dir/$_[0]"
61 if defined $dir;
62
63 undef
64}
65
49BEGIN { 66BEGIN {
50 # create a loader process to detect @INC requests before we load any modules 67 # create a loader process to detect @INC requests before we load any modules
51 my ($W_TRACER, $R_TRACER); # used by tracer 68 my ($W_TRACER, $R_TRACER); # used by tracer
52 69
53 pipe $R_TRACER, $TRACER_W or die "pipe: $!"; 70 pipe $R_TRACER, $TRACER_W or die "pipe: $!";
… …
55 72
56 unless (fork) { 73 unless (fork) {
57 close $TRACER_R; 74 close $TRACER_R;
58 close $TRACER_W; 75 close $TRACER_W;
59 76
77 my $pkg = "pkg000000";
78
60 unshift @INC, sub { 79 unshift @INC, sub {
61 my $dir = find_inc $_[1] 80 my $dir = find_incdir $_[1]
62 or return; 81 or return;
63 82
64 syswrite $W_TRACER, "-\n$dir\n$_[1]\n"; 83 syswrite $W_TRACER, "-\n$dir\n$_[1]\n";
65 84
66 open my $fh, "<:perlio", "$dir/$_[1]" 85 open my $fh, "<:raw:perlio", "$dir/$_[1]"
67 or warn "ERROR: $dir/$_[1]: $!\n"; 86 or warn "ERROR: $dir/$_[1]: $!\n";
68 87
69 $fh 88 $fh
70 }; 89 };
71 90
72 while (<$R_TRACER>) { 91 while (<$R_TRACER>) {
73 if (/use (.*)$/) { 92 if (/use (.*)$/) {
74 my $mod = $1; 93 my $mod = $1;
94 my $eval;
95
96 if ($mod =~ /^'.*'$/ or $mod =~ /^".*"$/) {
75 eval "require $mod"; 97 $eval = "require $mod";
98 } elsif ($mod =~ y%/.%%) {
99 $eval = "require q\x00$mod\x00";
100 } else {
101 my $pkg = ++$pkg;
102 $eval = "{ package $pkg; use $mod; }";
103 }
104
105 eval $eval;
76 warn "ERROR: $@ (while loading '$mod')\n" 106 warn "ERROR: $@ (while loading '$mod')\n"
77 if $@; 107 if $@;
78 syswrite $W_TRACER, "\n";
79 } elsif (/eval (.*)$/) { 108 } elsif (/eval (.*)$/) {
80 my $eval = $1; 109 my $eval = $1;
81 eval $eval; 110 eval $eval;
82 warn "ERROR: $@ (in '$eval')\n" 111 warn "ERROR: $@ (in '$eval')\n"
83 if $@; 112 if $@;
84 } 113 }
114
115 syswrite $W_TRACER, "\n";
85 } 116 }
86 117
87 exit 0; 118 exit 0;
88 } 119 }
89} 120}
90 121
91# module loading is now safe 122# module loading is now safe
92 123
93sub trace_module { 124sub trace_parse {
94 syswrite $TRACER_W, "use $_[0]\n";
95
96 for (;;) { 125 for (;;) {
97 <$TRACER_R> =~ /^-$/ or last; 126 <$TRACER_R> =~ /^-$/ or last;
98 my $dir = <$TRACER_R>; chomp $dir; 127 my $dir = <$TRACER_R>; chomp $dir;
99 my $name = <$TRACER_R>; chomp $name; 128 my $name = <$TRACER_R>; chomp $name;
100 129
101 $pm{$name} = "$dir/$name"; 130 $pm{$name} = "$dir/$name";
131
132 print "+ found potential dependency $name\n"
133 if $VERBOSE >= 3;
102 } 134 }
103} 135}
104 136
137sub trace_module {
138 print "tracing module $_[0]\n"
139 if $VERBOSE >= 2;
140
141 syswrite $TRACER_W, "use $_[0]\n";
142 trace_parse;
143}
144
105sub trace_eval { 145sub trace_eval {
146 print "tracing eval $_[0]\n"
147 if $VERBOSE >= 2;
148
106 syswrite $TRACER_W, "eval $_[0]\n"; 149 syswrite $TRACER_W, "eval $_[0]\n";
150 trace_parse;
107} 151}
108 152
109sub trace_finish { 153sub trace_finish {
110 close $TRACER_W; 154 close $TRACER_W;
111 close $TRACER_R; 155 close $TRACER_R;
… …
119use Digest::MD5; 163use Digest::MD5;
120 164
121sub cache($$$) { 165sub cache($$$) {
122 my ($variant, $src, $filter) = @_; 166 my ($variant, $src, $filter) = @_;
123 167
124 if (length $CACHE and 2048 <= length $src) { 168 if (length $CACHE and 2048 <= length $src and defined $variant) {
125 my $file = "$CACHE/" . Digest::MD5::md5_hex "$CACHEVER\x00$variant\x00$src"; 169 my $file = "$CACHE/" . Digest::MD5::md5_hex "$CACHEVER\x00$variant\x00$src";
126 170
127 if (open my $fh, "<:perlio", $file) { 171 if (open my $fh, "<:raw:perlio", $file) {
172 print "using cache for $file\n"
173 if $VERBOSE >= 7;
174
128 local $/; 175 local $/;
129 return <$fh>; 176 return <$fh>;
130 } 177 }
131 178
132 $src = $filter->($src); 179 $src = $filter->($src);
133 180
181 print "creating cache entry $file\n"
182 if $VERBOSE >= 8;
183
134 if (open my $fh, ">:perlio", "$file~") { 184 if (open my $fh, ">:raw:perlio", "$file~") {
135 if ((syswrite $fh, $src) == length $src) { 185 if ((syswrite $fh, $src) == length $src) {
136 close $fh; 186 close $fh;
137 rename "$file~", $file; 187 rename "$file~", $file;
138 } 188 }
139 } 189 }
… …
146 196
147sub dump_string { 197sub dump_string {
148 my ($fh, $data) = @_; 198 my ($fh, $data) = @_;
149 199
150 if (length $data) { 200 if (length $data) {
201 if ($^O eq "MSWin32") {
202 # 16 bit system, strings can't be longer than 64k. seriously.
203 print $fh "{\n";
151 for ( 204 for (
152 my $ofs = 0; 205 my $ofs = 0;
206 length (my $substr = substr $data, $ofs, 20);
207 $ofs += 20
208 ) {
209 $substr = join ",", map ord, split //, $substr;
210 print $fh " $substr,\n";
211 }
212 print $fh " 0 }\n";
213 } else {
214 for (
215 my $ofs = 0;
153 length (my $substr = substr $data, $ofs, 80); 216 length (my $substr = substr $data, $ofs, 80);
154 $ofs += 80 217 $ofs += 80
155 ) { 218 ) {
156 $substr =~ s/([^\x20-\x21\x23-\x5b\x5d-\x7e])/sprintf "\\%03o", ord $1/ge; 219 $substr =~ s/([^\x20-\x21\x23-\x5b\x5d-\x7e])/sprintf "\\%03o", ord $1/ge;
157 $substr =~ s/\?/\\?/g; # trigraphs... 220 $substr =~ s/\?/\\?/g; # trigraphs...
158 print $fh " \"$substr\"\n"; 221 print $fh " \"$substr\"\n";
222 }
159 } 223 }
160 } else { 224 } else {
161 print $fh " \"\"\n"; 225 print $fh " \"\"\n";
162 } 226 }
163} 227}
… …
200 my $path = "$_[0]/$_"; 264 my $path = "$_[0]/$_";
201 265
202 if (-d "$path/.") { 266 if (-d "$path/.") {
203 $scan->($path); 267 $scan->($path);
204 } else { 268 } else {
205 next unless /\.(?:pm|pl)$/;
206
207 $path = substr $path, $skip; 269 $path = substr $path, $skip;
208 push @tree, $path 270 push @tree, $path
209 unless exists $INCSKIP{$path}; 271 unless exists $INCSKIP{$path};
210 } 272 }
211 } 273 }
… …
232} 294}
233 295
234############################################################################# 296#############################################################################
235 297
236sub cmd_boot { 298sub cmd_boot {
237 $pm{"//boot"} = $_[0]; 299 $pm{"!boot"} = $_[0];
238} 300}
239 301
240sub cmd_add { 302sub cmd_add {
241 $_[0] =~ /^(.*)(?:\s+(\S+))$/ 303 $_[0] =~ /^(.*?)(?:\s+(\S+))?$/
242 or die "$_[0]: cannot parse"; 304 or die "$_[0]: cannot parse";
243 305
244 my $file = $1; 306 my $file = $1;
245 my $as = defined $2 ? $2 : "/$1"; 307 my $as = defined $2 ? $2 : $1;
246 308
247 $pm{$as} = $file; 309 $pm{$as} = $file;
248 $pmbin{$as} = 1 if $_[1]; 310 $pmbin{$as} = 1 if $_[1];
249} 311}
250 312
… …
264 326
265 for (get_inctrees) { 327 for (get_inctrees) {
266 my ($dir, $files) = @$_; 328 my ($dir, $files) = @$_;
267 329
268 $pm{$_} = "$dir/$_" 330 $pm{$_} = "$dir/$_"
269 for grep /$pattern/, @$files; 331 for grep /$pattern/ && /\.(pl|pm)$/, @$files;
270 } 332 }
271} 333}
334
335sub parse_argv;
272 336
273sub cmd_file { 337sub cmd_file {
274 open my $fh, "<", $_[0] 338 open my $fh, "<", $_[0]
275 or die "$_[0]: $!\n"; 339 or die "$_[0]: $!\n";
276 340
341 local @ARGV;
342
277 while (<$fh>) { 343 while (<$fh>) {
278 chomp; 344 chomp;
345 next unless /\S/;
346 next if /^\s*#/;
347
348 s/^\s*-*/--/;
279 my ($cmd, $args) = split / /, $_, 2; 349 my ($cmd, $args) = split / /, $_, 2;
280 $cmd =~ s/^-+//;
281 350
282 if ($cmd eq "strip") { 351 push @ARGV, $cmd;
283 $STRIP = $args; 352 push @ARGV, $args if defined $args;
284 } elsif ($cmd eq "perl") {
285 $PERL = 1;
286 } elsif ($cmd eq "app") {
287 $APP = $args;
288 } elsif ($cmd eq "eval") {
289 trace_eval $_;
290 } elsif ($cmd eq "use") {
291 trace_module $_
292 for split / /, $args;
293 } elsif ($cmd eq "staticlib") {
294 cmd_staticlib $args;
295 } elsif ($cmd eq "boot") {
296 cmd_boot $args;
297 } elsif ($cmd eq "static") {
298 $STATIC = 1;
299 } elsif ($cmd eq "add") {
300 cmd_add $args, 0;
301 } elsif ($cmd eq "addbin") {
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;
309 } elsif (/^\s*#/) {
310 # comment
311 } elsif (/\S/) {
312 die "$_: unsupported directive\n";
313 }
314 } 353 }
354
355 parse_argv;
315} 356}
316 357
317use Getopt::Long; 358use Getopt::Long;
318 359
360sub parse_argv {
361 GetOptions
362 "perl" => \$PERL,
363 "app=s" => \$APP,
364
365 "verbose|v" => sub { ++$VERBOSE },
366 "quiet|q" => sub { --$VERBOSE },
367
368 "strip=s" => \$STRIP,
369 "compress=s" => \$COMPRESS,
370 "cache=s" => \$CACHE, # internal option
371 "eval|e=s" => sub { trace_eval $_[1] },
372 "use|M=s" => sub { trace_module $_[1] },
373 "boot=s" => sub { cmd_boot $_[1] },
374 "add=s" => sub { cmd_add $_[1], 0 },
375 "addbin=s" => sub { cmd_add $_[1], 1 },
376 "incglob=s" => sub { cmd_incglob $_[1] },
377 "include|i=s" => sub { cmd_include $_[1], 1 },
378 "exclude|x=s" => sub { cmd_include $_[1], 0 },
379 "usepacklists!" => \$PACKLIST,
380
381 "static!" => \$STATIC,
382 "staticlib=s" => sub { cmd_staticlib $_[1] },
383 "allow-dynamic!" => \$ALLOW_DYNAMIC,
384 "ignore-env" => \$IGNORE_ENV,
385
386 "extra-cflags=s" => \$EXTRA_CFLAGS,
387 "extra-ldflags=s" => \$EXTRA_LDFLAGS,
388 "extra-libs=s" => \$EXTRA_LIBS,
389
390 "<>" => sub { cmd_file $_[0] },
391 or exit 1;
392}
393
319Getopt::Long::Configure ("bundling", "no_auto_abbrev", "no_ignore_case"); 394Getopt::Long::Configure ("bundling", "no_auto_abbrev", "no_ignore_case");
320 395
321GetOptions 396parse_argv;
322 "strip=s" => \$STRIP,
323 "cache=s" => \$CACHE, # internal option
324 "verbose|v" => sub { ++$VERBOSE },
325 "quiet|q" => sub { --$VERBOSE },
326 "perl" => \$PERL,
327 "app=s" => \$APP,
328 "eval|e=s" => sub { trace_eval $_[1] },
329 "use|M=s" => sub { trace_module $_[1] },
330 "boot=s" => sub { cmd_boot $_[1] },
331 "add=s" => sub { cmd_add $_[1], 0 },
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 },
336 "static" => sub { $STATIC = 1 },
337 "staticlib=s" => sub { cmd_staticlib $_[1] },
338 "<>" => sub { cmd_file $_[0] },
339 or exit 1;
340 397
341die "cannot specify both --app and --perl\n" 398die "cannot specify both --app and --perl\n"
342 if $PERL and defined $APP; 399 if $PERL and defined $APP;
343 400
401die "--compress must be either none or lzf\n"
402 unless $COMPRESS =~ /^(?:none|lzf)\z/;
403
344# required for @INC loading, unfortunately 404# required for @INC loading, unfortunately
345trace_module "PerlIO::scalar"; 405trace_module "PerlIO::scalar";
346 406
347############################################################################# 407#############################################################################
348# include/exclude apply 408# apply include/exclude
349 409
350{ 410{
351 my %pmi; 411 my %pmi;
352 412
353 for (@incext) { 413 for (@incext) {
… …
356 my @match = grep /$glob/, keys %pm; 416 my @match = grep /$glob/, keys %pm;
357 417
358 if ($inc) { 418 if ($inc) {
359 # include 419 # include
360 @pmi{@match} = delete @pm{@match}; 420 @pmi{@match} = delete @pm{@match};
421
422 print "applying include $glob - protected ", (scalar @match), " files.\n"
423 if $VERBOSE >= 5;
361 } else { 424 } else {
362 # exclude 425 # exclude
363 delete @pm{@match}; 426 delete @pm{@match};
427
428 print "applying exclude $glob - removed ", (scalar @match), " files.\n"
429 if $VERBOSE >= 5;
364 } 430 }
365 } 431 }
366 432
367 my @pmi = keys %pmi; 433 my @pmi = keys %pmi;
368 @pm{@pmi} = delete @pmi{@pmi}; 434 @pm{@pmi} = delete @pmi{@pmi};
369} 435}
370 436
371############################################################################# 437#############################################################################
372# scan for AutoLoader and static archives 438# scan for AutoLoader, static archives and other dependencies
373 439
374sub scan_al { 440sub scan_al {
375 my ($auto, $autodir) = @_; 441 my ($auto, $autodir) = @_;
376 442
377 my $ix = "$autodir/autosplit.ix"; 443 my $ix = "$autodir/autosplit.ix";
444
445 print "processing autoload index for '$auto'\n"
446 if $VERBOSE >= 6;
378 447
379 $pm{"$auto/autosplit.ix"} = $ix; 448 $pm{"$auto/autosplit.ix"} = $ix;
380 449
381 open my $fh, "<:perlio", $ix 450 open my $fh, "<:perlio", $ix
382 or die "$ix: $!"; 451 or die "$ix: $!";
… …
388 my $al = "auto/$package/$1.al"; 457 my $al = "auto/$package/$1.al";
389 my $inc = find_inc $al; 458 my $inc = find_inc $al;
390 459
391 defined $inc or die "$al: autoload file not found, but should be there.\n"; 460 defined $inc or die "$al: autoload file not found, but should be there.\n";
392 461
393 $pm{$al} = "$inc/$al"; 462 $pm{$al} = $inc;
463 print "found autoload function '$al'\n"
464 if $VERBOSE >= 6;
394 465
395 } elsif (/^\s*package\s+([^[:space:];]+)\s*;?\s*$/) { 466 } elsif (/^\s*package\s+([^[:space:];]+)\s*;?\s*$/) {
396 ($package = $1) =~ s/::/\//g; 467 ($package = $1) =~ s/::/\//g;
397 } elsif (/^\s*(?:#|1?\s*;?\s*$)/) { 468 } elsif (/^\s*(?:#|1?\s*;?\s*$)/) {
398 # nop 469 # nop
399 } else { 470 } else {
400 warn "$ix: unparsable line, please report: $_"; 471 warn "WARNING: $ix: unparsable line, please report: $_";
401 } 472 }
402 } 473 }
403} 474}
404 475
405for my $pm (keys %pm) { 476for my $pm (keys %pm) {
406 if ($pm =~ /^(.*)\.pm$/) { 477 if ($pm =~ /^(.*)\.pm$/) {
407 my $auto = "auto/$1"; 478 my $auto = "auto/$1";
408 my $autodir = find_inc $auto; 479 my $autodir = find_inc $auto;
409 480
410 if (defined $autodir && -d "$autodir/$auto") { 481 if (defined $autodir && -d $autodir) {
411 $autodir = "$autodir/$auto";
412
413 # AutoLoader 482 # AutoLoader
414 scan_al $auto, $autodir 483 scan_al $auto, $autodir
415 if -f "$autodir/autosplit.ix"; 484 if -f "$autodir/autosplit.ix";
416 485
417 # extralibs.ld 486 # extralibs.ld
418 if (open my $fh, "<:perlio", "$autodir/extralibs.ld") { 487 if (open my $fh, "<:perlio", "$autodir/extralibs.ld") {
488 print "found extralibs for $pm\n"
489 if $VERBOSE >= 6;
490
419 local $/; 491 local $/;
420 $extralibs .= " " . <$fh>; 492 $extralibs .= " " . <$fh>;
421 } 493 }
422 494
423 $pm =~ /([^\/]+).pm$/ or die "$pm: unable to match last component"; 495 $pm =~ /([^\/]+).pm$/ or die "$pm: unable to match last component";
424 496
425 my $base = $1; 497 my $base = $1;
426 498
427 # static ext 499 # static ext
428 if (-f "$autodir/$base$Config{_a}") { 500 if (-f "$autodir/$base$Config{_a}") {
501 print "found static archive for $pm\n"
502 if $VERBOSE >= 3;
503
429 push @libs, "$autodir/$base$Config{_a}"; 504 push @libs, "$autodir/$base$Config{_a}";
430 push @static_ext, $pm; 505 push @static_ext, $pm;
431 } 506 }
432 507
433 # dynamic object 508 # dynamic object
434 die "ERROR: found shared object - can't link statically ($_)\n"
435 if -f "$autodir/$base.$Config{dlext}"; 509 if (-f "$autodir/$base.$Config{dlext}") {
510 if ($ALLOW_DYNAMIC) {
511 my $as = "!$auto/$base.$Config{dlext}";
512 $pm{$as} = "$autodir/$base.$Config{dlext}";
513 $pmbin{$as} = 1;
514
515 $HAVE_DYNAMIC = 1;
516
517 print "+ added dynamic object $as\n"
518 if $VERBOSE >= 3;
519 } else {
520 die "ERROR: found shared object '$autodir/$base.$Config{dlext}' but --allow-dynamic not given, aborting.\n"
521 }
522 }
523
524 if ($PACKLIST && open my $fh, "<:perlio", "$autodir/.packlist") {
525 print "found .packlist for $pm\n"
526 if $VERBOSE >= 3;
527
528 while (<$fh>) {
529 chomp;
530 s/ .*$//; # newer-style .packlists might contain key=value pairs
531
532 # only include certain files (.al, .ix, .pm, .pl)
533 if (/\.(pm|pl|al|ix)$/) {
534 for my $inc (@INC) {
535 # in addition, we only add files that are below some @INC path
536 $inc =~ s/\/*$/\//;
537
538 if ($inc eq substr $_, 0, length $inc) {
539 my $base = substr $_, length $inc;
540 $pm{$base} = $_;
541
542 print "+ added .packlist dependency $base\n"
543 if $VERBOSE >= 3;
544 }
545
546 last;
547 }
548 }
549 }
550 }
436 } 551 }
437 } 552 }
438} 553}
439 554
440############################################################################# 555#############################################################################
556
557print "processing bundle files (try more -v power if you get bored waiting here)...\n"
558 if $VERBOSE >= 1;
559
560my $compress = sub { shift };
561
562if ($COMPRESS eq "lzf") {
563 require Compress::LZF;
564 $compress = sub { Compress::LZF::compress_best (shift) };
565}
441 566
442my $data; 567my $data;
443my @index; 568my @index;
444my @order = sort { 569my @order = sort {
445 length $a <=> length $b 570 length $a <=> length $b
… …
457 or die "ERROR: $pm: path too long (only 128 octets supported)\n"; 582 or die "ERROR: $pm: path too long (only 128 octets supported)\n";
458 583
459 my $src = ref $path 584 my $src = ref $path
460 ? $$path 585 ? $$path
461 : do { 586 : do {
462 open my $pm, "<", $path 587 open my $pm, "<:raw:perlio", $path
463 or die "$path: $!"; 588 or die "$path: $!";
464 589
465 local $/; 590 local $/;
466 591
467 <$pm> 592 <$pm>
… …
470 my $size = length $src; 595 my $size = length $src;
471 596
472 unless ($pmbin{$pm}) { # only do this unless the file is binary 597 unless ($pmbin{$pm}) { # only do this unless the file is binary
473 if ($pm =~ /^auto\/POSIX\/[^\/]+\.al$/) { 598 if ($pm =~ /^auto\/POSIX\/[^\/]+\.al$/) {
474 if ($src =~ /^ unimpl \"/m) { 599 if ($src =~ /^ unimpl \"/m) {
475 warn "$pm: skipping (not implemented anyways).\n" 600 print "$pm: skipping (raises runtime error only).\n"
476 if $VERBOSE >= 2; 601 if $VERBOSE >= 3;
477 next; 602 next;
478 } 603 }
479 } 604 }
480 605
481 $src = cache "$UNISTRIP,$OPTIMISE_SIZE,$STRIP", $src, sub { 606 $src = cache "$STRIP,$UNISTRIP,$OPTIMISE_SIZE,$COMPRESS", $src, sub {
482 if ($UNISTRIP && $pm =~ /^unicore\/.*\.pl$/) { 607 if ($UNISTRIP && $pm =~ /^unicore\/.*\.pl$/) {
608 print "applying unicore stripping $pm\n"
609 if $VERBOSE >= 6;
610
483 # special stripping for unicore swashes and properties 611 # special stripping for unicore swashes and properties
484 # much more could be done by going binary 612 # much more could be done by going binary
485 $src =~ s{ 613 $src =~ s{
486 (^return\ <<'END';\n) (.*?\n) (END(?:\n|\Z)) 614 (^return\ <<'END';\n) (.*?\n) (END(?:\n|\Z))
487 }{ 615 }{
… …
539 my $next = $ws->next_token; 667 my $next = $ws->next_token;
540 668
541 if (!$prev || !$next) { 669 if (!$prev || !$next) {
542 $ws->delete; 670 $ws->delete;
543 } else { 671 } else {
672 if ($next->isa (PPI::Token::Whitespace::)) {
673 $ws->delete;
544 if ( 674 } elsif (
545 $next->isa (PPI::Token::Operator::) && $next->{content} =~ /^(?:,|=|!|!=|==|=>)$/ # no ., because of digits. == float 675 $next->isa (PPI::Token::Operator::) && $next->{content} =~ /^(?:,|=|!|!=|==|=>)$/ # no ., because of digits. == float
546 or $prev->isa (PPI::Token::Operator::) && $prev->{content} =~ /^(?:,|=|\.|!|!=|==|=>)$/ 676 or $prev->isa (PPI::Token::Operator::) && $prev->{content} =~ /^(?:,|=|\.|!|!=|==|=>)$/
547 or $prev->isa (PPI::Token::Structure::) 677 or $prev->isa (PPI::Token::Structure::)
548 or ($OPTIMISE_SIZE && 678 or ($OPTIMISE_SIZE &&
549 ($prev->isa (PPI::Token::Word::) 679 ($prev->isa (PPI::Token::Word::)
… …
551 || $next->isa (PPI::Structure::Block::) 681 || $next->isa (PPI::Structure::Block::)
552 || $next->isa (PPI::Structure::List::) 682 || $next->isa (PPI::Structure::List::)
553 || $next->isa (PPI::Structure::Condition::))) 683 || $next->isa (PPI::Structure::Condition::)))
554 ) 684 )
555 ) { 685 ) {
686 # perl has some idiotic warnigns about nonexisting operators
687 if ($prev->isa (PPI::Token::Operator::) && $prev->{content} eq "="
688 && $next->isa (PPI::Token::Operator::) && $next->{content} =~ /[+\-]/
689 ) {
690 # avoid "Reverse %s operator" diagnostic
691 } else {
556 $ws->delete; 692 $ws->delete;
557 } elsif ($prev->isa (PPI::Token::Whitespace::)) {
558 $ws->{content} = ' ';
559 $prev->delete; 693 }
560 } else { 694 } else {
561 $ws->{content} = ' '; 695 $ws->{content} = ' ';
562 } 696 }
563 } 697 }
564 } 698 }
… …
600 734
601 $src = $ppi->serialize; 735 $src = $ppi->serialize;
602 } else { 736 } else {
603 warn "WARNING: $pm{$pm}: PPI failed to parse this file\n"; 737 warn "WARNING: $pm{$pm}: PPI failed to parse this file\n";
604 } 738 }
605 } elsif ($STRIP =~ /pod/i && $pm ne "Opcode.pm") { # opcode parses it's own pod 739 } elsif ($STRIP =~ /pod/i && $pm ne "Opcode.pm") { # opcode parses its own pod
606 require Pod::Strip; 740 require Pod::Strip;
607 741
608 my $stripper = Pod::Strip->new; 742 my $stripper = Pod::Strip->new;
609 743
610 my $out; 744 my $out;
… …
621 eval "#line 1 \"$pm\"\n$src" or warn "\n\n\n$pm\n\n$src\n$@\n\n\n"; 755 eval "#line 1 \"$pm\"\n$src" or warn "\n\n\n$pm\n\n$src\n$@\n\n\n";
622 exit 0; 756 exit 0;
623 } 757 }
624 } 758 }
625 759
760 $src = $compress->($src);
761
626 $src 762 $src
627 }; 763 };
628 764
629# if ($pm eq "Opcode.pm") { 765# if ($pm eq "Opcode.pm") {
630# open my $fh, ">x" or die; print $fh $src;#d# 766# open my $fh, ">x" or die; print $fh $src;#d#
631# exit 1; 767# exit 1;
632# } 768# }
633 } 769 }
634 770
635 print "adding $pm{$pm} (original size $size, stored size ", length $src, ")\n" 771 print "adding $pm (original size $size, stored size ", length $src, ")\n"
636 if $VERBOSE >= 2; 772 if $VERBOSE >= 2;
637 773
638 push @index, ((length $pm) << 25) | length $data; 774 push @index, ((length $pm) << 25) | length $data;
639 $data .= $pm . $src; 775 $data .= $pm . $src;
640} 776}
641 777
642length $data < 2**25 778length $data < 2**25
643 or die "bundle too large (only 32MB supported)\n"; 779 or die "ERROR: bundle too large (only 32MB supported)\n";
644 780
645my $varpfx = "bundle_" . substr +(Digest::MD5::md5_hex $data), 0, 16; 781my $varpfx = "bundle";
646 782
647############################################################################# 783#############################################################################
648# output 784# output
649 785
650print "generating $PREFIX.h... "; 786print "generating $PREFIX.h... "
787 if $VERBOSE >= 1;
651 788
652{ 789{
653 open my $fh, ">", "$PREFIX.h" 790 open my $fh, ">", "$PREFIX.h"
654 or die "$PREFIX.h: $!\n"; 791 or die "$PREFIX.h: $!\n";
655 792
656 print $fh <<EOF; 793 print $fh <<EOF;
657/* do not edit, automatically created by mkstaticbundle */ 794/* do not edit, automatically created by staticperl */
658 795
659#include <EXTERN.h> 796#include <EXTERN.h>
660#include <perl.h> 797#include <perl.h>
661#include <XSUB.h> 798#include <XSUB.h>
662 799
663/* public API */ 800/* public API */
664EXTERN_C PerlInterpreter *staticperl; 801EXTERN_C PerlInterpreter *staticperl;
665EXTERN_C void staticperl_xs_init (pTHX); 802EXTERN_C void staticperl_xs_init (pTHX);
666EXTERN_C void staticperl_init (void); 803EXTERN_C void staticperl_init (XSINIT_t xs_init); /* argument can be 0 */
667EXTERN_C void staticperl_cleanup (void); 804EXTERN_C void staticperl_cleanup (void);
668 805
669EOF 806EOF
670} 807}
671 808
672print "\n"; 809print "\n"
810 if $VERBOSE >= 1;
673 811
674############################################################################# 812#############################################################################
675# output 813# output
676 814
677print "generating $PREFIX.c... "; 815print "generating $PREFIX.c... "
816 if $VERBOSE >= 1;
678 817
679open my $fh, ">", "$PREFIX.c" 818open my $fh, ">", "$PREFIX.c"
680 or die "$PREFIX.c: $!\n"; 819 or die "$PREFIX.c: $!\n";
681 820
682print $fh <<EOF; 821print $fh <<EOF;
683/* do not edit, automatically created by mkstaticbundle */ 822/* do not edit, automatically created by staticperl */
684 823
685#include "bundle.h" 824#include "bundle.h"
686 825
687/* public API */ 826/* public API */
688PerlInterpreter *staticperl; 827PerlInterpreter *staticperl;
689 828
690EOF 829EOF
830
831#############################################################################
832# lzf decompressor
833
834if ($COMPRESS eq "lzf") {
835 print $fh <<'EOF';
836/* stripped down/perlified version of lzf_d.c from liblzf-3.7 */
837
838#if (__i386 || __amd64) && __GNUC__ >= 3
839# define lzf_movsb(dst, src, len) \
840 asm ("rep movsb" \
841 : "=D" (dst), "=S" (src), "=c" (len) \
842 : "0" (dst), "1" (src), "2" (len));
843#endif
844
845static unsigned int
846lzf_decompress (const void *const in_data, unsigned int in_len,
847 void *out_data, unsigned int out_len)
848{
849 U8 const *ip = (const U8 *)in_data;
850 U8 *op = (U8 *)out_data;
851 U8 const *const in_end = ip + in_len;
852 U8 *const out_end = op + out_len;
853
854 do
855 {
856 unsigned int ctrl = *ip++;
857
858 if (ctrl < (1 << 5)) /* literal run */
859 {
860 ctrl++;
861
862 if (op + ctrl > out_end)
863 return 0;
864
865#ifdef lzf_movsb
866 lzf_movsb (op, ip, ctrl);
867#else
868 while (ctrl--)
869 *op++ = *ip++;
870#endif
871 }
872 else /* back reference */
873 {
874 unsigned int len = ctrl >> 5;
875
876 U8 *ref = op - ((ctrl & 0x1f) << 8) - 1;
877
878 if (len == 7)
879 len += *ip++;
880
881 ref -= *ip++;
882
883 if (op + len + 2 > out_end)
884 return 0;
885
886 if (ref < (U8 *)out_data)
887 return 0;
888
889 len += 2;
890#ifdef lzf_movsb
891 lzf_movsb (op, ref, len);
892#else
893 do
894 *op++ = *ref++;
895 while (--len);
896#endif
897 }
898 }
899 while (ip < in_end);
900
901 return op - (U8 *)out_data;
902}
903
904static SV *
905static_to_sv (const char *ptr, STRLEN len)
906{
907 SV *res;
908 const U8 *p = (const U8 *)ptr;
909
910 if (len == 0) /* empty */
911 res = newSVpvn ("", 0);
912 else if (*p == 0) /* not compressed */
913 res = newSVpvn (p + 1, len - 1);
914 else /* lzf compressed, with UTF-8-encoded original size in front */
915 {
916 STRLEN ulenlen;
917 UV ulen = utf8n_to_uvchr (p, len, &ulenlen, 0);
918
919 p += ulenlen;
920 len -= ulenlen;
921
922 res = NEWSV (0, ulen);
923 sv_upgrade (res, SVt_PV);
924 SvPOK_only (res);
925 lzf_decompress (p, len, SvPVX (res), ulen);
926 SvCUR_set (res, ulen);
927 }
928
929 return res;
930}
931
932EOF
933} else {
934 print $fh <<EOF;
935
936#define static_to_sv(ptr,len) newSVpvn (ptr, len)
937
938EOF
939}
691 940
692############################################################################# 941#############################################################################
693# bundle data 942# bundle data
694 943
695my $count = @index; 944my $count = @index;
… …
712printf $fh "0x%08x\n};\n", (length $data); 961printf $fh "0x%08x\n};\n", (length $data);
713 962
714print $fh "static const char $varpfx\_data [] =\n"; 963print $fh "static const char $varpfx\_data [] =\n";
715dump_string $fh, $data; 964dump_string $fh, $data;
716 965
717print $fh ";\n\n";; 966print $fh ";\n\n";
718 967
719############################################################################# 968#############################################################################
720# bootstrap 969# bootstrap
721 970
722# boot file for staticperl 971# boot file for staticperl
723# this file will be eval'ed at initialisation time 972# this file will be eval'ed at initialisation time
724 973
974# lines marked with "^D" are only used when $HAVE_DYNAMIC
725my $bootstrap = ' 975my $bootstrap = '
726BEGIN { 976BEGIN {
727 package ' . $PACKAGE . '; 977 package ' . $PACKAGE . ';
728 978
729 PerlIO::scalar->bootstrap; 979 # the path prefix to use when putting files into %INC
980 our $inc_prefix;
730 981
731 @INC = sub { 982 # the @INC hook to use when we have PerlIO::scalar available
983 my $perlio_inc = sub {
732 my $data = find "$_[1]" 984 my $data = find "$_[1]"
733 or return; 985 or return;
734 986
735 $INC{$_[1]} = $_[1]; 987 $INC{$_[1]} = "$inc_prefix$_[1]";
736 988
737 open my $fh, "<", \$data; 989 open my $fh, "<", \$data;
738 $fh 990 $fh
739 }; 991 };
992
993D if (defined &PerlIO::scalar::bootstrap) {
994 # PerlIO::scalar statically compiled in
995 PerlIO::scalar->bootstrap;
996 @INC = $perlio_inc;
997D } else {
998D # PerlIO::scalar not available, use slower method
999D @INC = sub {
1000D # always check if PerlIO::scalar might now be available
1001D if (defined &PerlIO::scalar::bootstrap) {
1002D # switch to the faster perlio_inc hook
1003D @INC = map { $_ == $_[0] ? $perlio_inc : $_ } @INC;
1004D goto &$perlio_inc;
1005D }
1006D
1007D my $data = find "$_[1]"
1008D or return;
1009D
1010D $INC{$_[1]} = "$inc_prefix$_[1]";
1011D
1012D sub {
1013D $data =~ /\G([^\n]*\n?)/g
1014D or return;
1015D
1016D $_ = $1;
1017D 1
1018D }
1019D };
1020D }
740} 1021}
741'; 1022';
742 1023
743$bootstrap .= "require '//boot';" 1024$bootstrap .= "require '!boot';"
744 if exists $pm{"//boot"}; 1025 if exists $pm{"!boot"};
745 1026
1027if ($HAVE_DYNAMIC) {
1028 $bootstrap =~ s/^D/ /mg;
1029} else {
1030 $bootstrap =~ s/^D.*$//mg;
1031}
1032
1033$bootstrap =~ s/#.*$//mg;
746$bootstrap =~ s/\s+/ /g; 1034$bootstrap =~ s/\s+/ /g;
747$bootstrap =~ s/(\W) /$1/g; 1035$bootstrap =~ s/(\W) /$1/g;
748$bootstrap =~ s/ (\W)/$1/g; 1036$bootstrap =~ s/ (\W)/$1/g;
749 1037
750print $fh "const char bootstrap [] = "; 1038print $fh "const char bootstrap [] = ";
… …
782 { 1070 {
783 /* found */ 1071 /* found */
784 int ofs2 = $varpfx\_index [m + 1] & 0x1FFFFFFU; 1072 int ofs2 = $varpfx\_index [m + 1] & 0x1FFFFFFU;
785 1073
786 ofs += namelen; 1074 ofs += namelen;
787 res = newSVpvn ($varpfx\_data + ofs, ofs2 - ofs); 1075 res = static_to_sv ($varpfx\_data + ofs, ofs2 - ofs);
788 goto found; 1076 goto found;
789 } 1077 }
790 } 1078 }
791 1079
792 if (comp < 0) 1080 if (comp < 0)
… …
796 } 1084 }
797 1085
798 XSRETURN (0); 1086 XSRETURN (0);
799 1087
800 found: 1088 found:
801 ST (0) = res; 1089 ST (0) = sv_2mortal (res);
802 sv_2mortal (ST (0));
803 } 1090 }
804 1091
805 XSRETURN (1); 1092 XSRETURN (1);
806} 1093}
807 1094
… …
820 1107
821 for (i = 0; i < $varpfx\_count; ++i) 1108 for (i = 0; i < $varpfx\_count; ++i)
822 { 1109 {
823 U32 idx = $varpfx\_index [i]; 1110 U32 idx = $varpfx\_index [i];
824 1111
825 PUSHs (newSVpvn ($varpfx\_data + (idx & 0x1FFFFFFU), idx >> 25)); 1112 PUSHs (sv_2mortal (newSVpvn ($varpfx\_data + (idx & 0x1FFFFFFU), idx >> 25)));
826 } 1113 }
827 } 1114 }
828 1115
829 XSRETURN ($varpfx\_count); 1116 XSRETURN ($varpfx\_count);
830} 1117}
1118
1119#ifdef STATICPERL_BUNDLE_INCLUDE
1120#include STATICPERL_BUNDLE_INCLUDE
1121#endif
831 1122
832EOF 1123EOF
833 1124
834############################################################################# 1125#############################################################################
835# xs_init 1126# xs_init
… …
838void 1129void
839staticperl_xs_init (pTHX) 1130staticperl_xs_init (pTHX)
840{ 1131{
841EOF 1132EOF
842 1133
843@static_ext = ("DynaLoader", sort @static_ext); 1134@static_ext = sort @static_ext;
844 1135
845# prototypes 1136# prototypes
846for (@static_ext) { 1137for (@static_ext) {
847 s/\.pm$//; 1138 s/\.pm$//;
848 (my $cname = $_) =~ s/\//__/g; 1139 (my $cname = $_) =~ s/\//__/g;
… …
853 char *file = __FILE__; 1144 char *file = __FILE__;
854 dXSUB_SYS; 1145 dXSUB_SYS;
855 1146
856 newXSproto ("$PACKAGE\::find", find, file, "\$"); 1147 newXSproto ("$PACKAGE\::find", find, file, "\$");
857 newXSproto ("$PACKAGE\::list", list, file, ""); 1148 newXSproto ("$PACKAGE\::list", list, file, "");
1149
1150 #ifdef STATICPERL_BUNDLE_XS_INIT
1151 STATICPERL_BUNDLE_XS_INIT;
1152 #endif
858EOF 1153EOF
859 1154
860# calls 1155# calls
861for (@static_ext) { 1156for (@static_ext) {
862 s/\.pm$//; 1157 s/\.pm$//;
863 1158
864 (my $cname = $_) =~ s/\//__/g; 1159 (my $cname = $_) =~ s/\//__/g;
865 (my $pname = $_) =~ s/\//::/g; 1160 (my $pname = $_) =~ s/\//::/g;
866 1161
867 my $bootstrap = $pname eq "DynaLoader" ? "boot" : "bootstrap"; 1162 my $bootstrap = $pname eq "DynaLoader" ? "boot_DynaLoader" : "bootstrap";
868 1163
869 print $fh " newXS (\"$pname\::$bootstrap\", boot_$cname, file);\n"; 1164 print $fh " newXS (\"$pname\::$bootstrap\", boot_$cname, file);\n";
870} 1165}
871 1166
872print $fh <<EOF; 1167print $fh <<EOF;
1168 Safefree (PL_origfilename);
1169 PL_origfilename = savepv (PL_origargv [0]);
1170 sv_setpv (GvSV (gv_fetchpvs ("0", GV_ADD|GV_NOTQUAL, SVt_PV)), PL_origfilename);
1171
1172 #ifdef _WIN32
1173 /* windows perls usually trail behind unix perls 8-10 years in exporting symbols */
1174
1175 if (!PL_preambleav)
1176 PL_preambleav = newAV ();
1177
1178 av_unshift (PL_preambleav, 1);
1179 av_store (PL_preambleav, 0, newSVpv (bootstrap, sizeof (bootstrap) - 1));
1180 #else
873 Perl_av_create_and_unshift_one (&PL_preambleav, newSVpv (bootstrap, sizeof (bootstrap) - 1)); 1181 Perl_av_create_and_unshift_one (&PL_preambleav, newSVpv (bootstrap, sizeof (bootstrap) - 1));
1182 #endif
1183
1184 if (PL_oldname)
1185 ((XSINIT_t)PL_oldname)(aTHX);
874} 1186}
875EOF 1187EOF
876 1188
877############################################################################# 1189#############################################################################
878# optional perl_init/perl_destroy 1190# optional perl_init/perl_destroy
879 1191
1192if ($IGNORE_ENV) {
1193 $IGNORE_ENV = <<EOF;
1194 unsetenv ("PERL_UNICODE");
1195 unsetenv ("PERL_HASH_SEED_DEBUG");
1196 unsetenv ("PERL_DESTRUCT_LEVEL");
1197 unsetenv ("PERL_SIGNALS");
1198 unsetenv ("PERL_DEBUG_MSTATS");
1199 unsetenv ("PERL5OPT");
1200 unsetenv ("PERLIO_DEBUG");
1201 unsetenv ("PERLIO");
1202 unsetenv ("PERL_HASH_SEED");
1203EOF
1204} else {
1205 $IGNORE_ENV = "";
1206}
1207
880if ($APP) { 1208if ($APP) {
1209 print $fh <<EOF;
1210
1211int
1212main (int argc, char *argv [])
1213{
1214 extern char **environ;
1215 int i, exitstatus;
1216 char **args = malloc ((argc + 3) * sizeof (const char *));
1217
1218 args [0] = argv [0];
1219 args [1] = "-e";
1220 args [2] = "0";
1221 args [3] = "--";
1222
1223 for (i = 1; i < argc; ++i)
1224 args [i + 3] = argv [i];
1225
1226$IGNORE_ENV
1227 PERL_SYS_INIT3 (&argc, &argv, &environ);
1228 staticperl = perl_alloc ();
1229 perl_construct (staticperl);
1230
1231 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
1232
1233 exitstatus = perl_parse (staticperl, staticperl_xs_init, argc + 3, args, environ);
1234 if (!exitstatus)
1235 perl_run (staticperl);
1236
1237 exitstatus = perl_destruct (staticperl);
1238 perl_free (staticperl);
1239 PERL_SYS_TERM ();
1240 /*free (args); no point doing it this late */
1241
1242 return exitstatus;
1243}
1244EOF
1245} elsif ($PERL) {
881 print $fh <<EOF; 1246 print $fh <<EOF;
882 1247
883int 1248int
884main (int argc, char *argv []) 1249main (int argc, char *argv [])
885{ 1250{
886 extern char **environ; 1251 extern char **environ;
887 int exitstatus; 1252 int exitstatus;
888 1253
1254$IGNORE_ENV
1255 PERL_SYS_INIT3 (&argc, &argv, &environ);
1256 staticperl = perl_alloc ();
1257 perl_construct (staticperl);
1258
1259 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
1260
1261 exitstatus = perl_parse (staticperl, staticperl_xs_init, argc, argv, environ);
1262 if (!exitstatus)
1263 perl_run (staticperl);
1264
1265 exitstatus = perl_destruct (staticperl);
1266 perl_free (staticperl);
1267 PERL_SYS_TERM ();
1268
1269 return exitstatus;
1270}
1271EOF
1272} else {
1273 print $fh <<EOF;
1274
1275EXTERN_C void
1276staticperl_init (XSINIT_t xs_init)
1277{
889 static char *args[] = { 1278 static char *args[] = {
890 "staticperl", 1279 "staticperl",
891 "-e", 1280 "-e",
892 "0" 1281 "0"
893 }; 1282 };
894 1283
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
912} elsif ($PERL) {
913 print $fh <<EOF;
914
915int
916main (int argc, char *argv [])
917{
918 extern char **environ;
919 int exitstatus;
920
921 PERL_SYS_INIT3 (&argc, &argv, &environ);
922 staticperl = perl_alloc ();
923 perl_construct (staticperl);
924
925 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
926
927 exitstatus = perl_parse (staticperl, staticperl_xs_init, argc, argv, environ);
928 if (!exitstatus)
929 perl_run (staticperl);
930
931 exitstatus = perl_destruct (staticperl);
932 perl_free (staticperl);
933 PERL_SYS_TERM ();
934
935 return exitstatus;
936}
937EOF
938} else {
939 print $fh <<EOF;
940
941EXTERN_C void
942staticperl_init (void)
943{
944 extern char **environ; 1284 extern char **environ;
945 int argc = sizeof (args) / sizeof (args [0]); 1285 int argc = sizeof (args) / sizeof (args [0]);
946 char **argv = args; 1286 char **argv = args;
947 1287
948 static char *args[] = { 1288$IGNORE_ENV
949 "staticperl",
950 "-e",
951 "0"
952 };
953
954 PERL_SYS_INIT3 (&argc, &argv, &environ); 1289 PERL_SYS_INIT3 (&argc, &argv, &environ);
955 staticperl = perl_alloc (); 1290 staticperl = perl_alloc ();
956 perl_construct (staticperl); 1291 perl_construct (staticperl);
957 PL_origalen = 1; 1292 PL_origalen = 1;
958 PL_exit_flags |= PERL_EXIT_DESTRUCT_END; 1293 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
1294 PL_oldname = (char *)xs_init;
959 perl_parse (staticperl, staticperl_xs_init, argc, argv, environ); 1295 perl_parse (staticperl, staticperl_xs_init, argc, argv, environ);
960 1296
961 perl_run (staticperl); 1297 perl_run (staticperl);
962} 1298}
963 1299
… …
970 PERL_SYS_TERM (); 1306 PERL_SYS_TERM ();
971} 1307}
972EOF 1308EOF
973} 1309}
974 1310
1311close $fh;
1312
975print -s "$PREFIX.c", " octets (", (length $data) , " data octets).\n\n"; 1313print -s "$PREFIX.c", " octets (", (length $data) , " data octets).\n\n"
1314 if $VERBOSE >= 1;
976 1315
977############################################################################# 1316#############################################################################
978# libs, cflags 1317# libs, cflags
979 1318
1319my $ccopts;
1320
980{ 1321{
981 print "generating $PREFIX.ccopts... "; 1322 print "generating $PREFIX.ccopts... "
1323 if $VERBOSE >= 1;
982 1324
983 my $str = "$Config{ccflags} $Config{optimize} $Config{cppflags} -I$Config{archlibexp}/CORE"; 1325 $ccopts = "$Config{ccflags} $Config{optimize} $Config{cppflags} -I$Config{archlibexp}/CORE $EXTRA_CFLAGS";
984 $str =~ s/([\(\)])/\\$1/g; 1326 $ccopts =~ s/([\(\)])/\\$1/g;
985
986 print "$str\n\n";
987 1327
988 open my $fh, ">$PREFIX.ccopts" 1328 open my $fh, ">$PREFIX.ccopts"
989 or die "$PREFIX.ccopts: $!"; 1329 or die "$PREFIX.ccopts: $!";
990 print $fh $str; 1330 print $fh $ccopts;
1331
1332 print "$ccopts\n\n"
1333 if $VERBOSE >= 1;
991} 1334}
1335
1336my $ldopts;
992 1337
993{ 1338{
994 print "generating $PREFIX.ldopts... "; 1339 print "generating $PREFIX.ldopts... ";
995 1340
996 my $str = $STATIC ? "-static " : ""; 1341 $ldopts = $STATIC ? "-static " : "";
997 1342
998 $str .= "$Config{ccdlflags} $Config{ldflags} @libs $Config{archlibexp}/CORE/$Config{libperl} $Config{perllibs}"; 1343 $ldopts .= "$Config{ccdlflags} $Config{ldflags} $EXTRA_LDFLAGS @libs $Config{archlibexp}/CORE/$Config{libperl} $Config{perllibs} $EXTRA_LIBS";
999 1344
1000 my %seen; 1345 my %seen;
1001 $str .= " $_" for grep !$seen{$_}++, ($extralibs =~ /(\S+)/g); 1346 $ldopts .= " $_" for reverse grep !$seen{$_}++, reverse +($extralibs =~ /(\S+)/g);
1002 1347
1003 for (@staticlibs) { 1348 for (@staticlibs) {
1004 $str =~ s/(^|\s) (-l\Q$_\E) ($|\s)/$1-Wl,-Bstatic $2 -Wl,-Bdynamic$3/gx; 1349 $ldopts =~ s/(^|\s) (-l\Q$_\E) ($|\s)/$1-Wl,-Bstatic $2 -Wl,-Bdynamic$3/gx;
1005 } 1350 }
1006 1351
1007 $str =~ s/([\(\)])/\\$1/g; 1352 $ldopts =~ s/([\(\)])/\\$1/g;
1008
1009 print "$str\n\n";
1010 1353
1011 open my $fh, ">$PREFIX.ldopts" 1354 open my $fh, ">$PREFIX.ldopts"
1012 or die "$PREFIX.ldopts: $!"; 1355 or die "$PREFIX.ldopts: $!";
1013 print $fh $str; 1356 print $fh $ldopts;
1357
1358 print "$ldopts\n\n"
1359 if $VERBOSE >= 1;
1014} 1360}
1015 1361
1016if ($PERL or defined $APP) { 1362if ($PERL or defined $APP) {
1017 $APP = "perl" unless defined $APP; 1363 $APP = "perl" unless defined $APP;
1018 1364
1365 my $build = "$Config{cc} $ccopts -o \Q$APP\E$Config{_exe} bundle.c $ldopts";
1366
1019 print "generating $APP...\n"; 1367 print "build $APP...\n"
1368 if $VERBOSE >= 1;
1020 1369
1021 system "$Config{cc} \$(cat bundle.ccopts\) -o \Q$APP\E bundle.c \$(cat bundle.ldopts\)"; 1370 print "$build\n"
1371 if $VERBOSE >= 2;
1022 1372
1373 system $build;
1374
1023# unlink "$PREFIX.$_" 1375 unlink "$PREFIX.$_"
1024# for qw(ccopts ldopts c h); 1376 for qw(ccopts ldopts c h);
1025 1377
1026 print "\n"; 1378 print "\n"
1379 if $VERBOSE >= 1;
1027} 1380}
1028 1381

Diff Legend

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