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

Comparing App-Staticperl/mkbundle (file contents):
Revision 1.9 by root, Wed Dec 8 22:27:35 2010 UTC vs.
Revision 1.34 by root, Mon Mar 12 21:45:10 2012 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 $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;
13our $PACKLIST = 0;
14our $IGNORE_ENV = 0;
15our $ALLOW_DYNAMIC = 0;
16our $HAVE_DYNAMIC; # maybe useful?
17
18our $OPTIMISE_SIZE = 0; # optimise for raw file size instead of for compression?
19
20our $CACHE;
21our $CACHEVER = 1; # do not change unless you know what you are doing
12 22
13my $PREFIX = "bundle"; 23my $PREFIX = "bundle";
14my $PACKAGE = "static"; 24my $PACKAGE = "static";
15 25
16my %pm; 26my %pm;
17my %pmbin; 27my %pmbin;
18my @libs; 28my @libs;
19my @static_ext; 29my @static_ext;
20my $extralibs; 30my $extralibs;
31my @staticlibs;
32my @incext;
21 33
22@ARGV 34@ARGV
23 or die "$0: use 'staticperl help' (or read the sources of staticperl)\n"; 35 or die "$0: use 'staticperl help' (or read the sources of staticperl)\n";
24 36
37# remove "." from @INC - staticperl.sh does it for us, but be on the safe side
38BEGIN { @INC = grep !/^\.$/, @INC }
39
25$|=1; 40$|=1;
26 41
27our ($TRACER_W, $TRACER_R); 42our ($TRACER_W, $TRACER_R);
28 43
29sub find_inc($) { 44sub find_incdir($) {
30 for (@INC) { 45 for (@INC) {
31 next if ref; 46 next if ref;
32 return $_ if -e "$_/$_[0]"; 47 return $_ if -e "$_/$_[0]";
33 } 48 }
34 49
35 undef 50 undef
36} 51}
37 52
53sub find_inc($) {
54 my $dir = find_incdir $_[0];
55
56 return "$dir/$_[0]"
57 if defined $dir;
58
59 undef
60}
61
38BEGIN { 62BEGIN {
39 # create a loader process to detect @INC requests before we load any modules 63 # create a loader process to detect @INC requests before we load any modules
40 my ($W_TRACER, $R_TRACER); # used by tracer 64 my ($W_TRACER, $R_TRACER); # used by tracer
41 65
42 pipe $R_TRACER, $TRACER_W or die "pipe: $!"; 66 pipe $R_TRACER, $TRACER_W or die "pipe: $!";
… …
44 68
45 unless (fork) { 69 unless (fork) {
46 close $TRACER_R; 70 close $TRACER_R;
47 close $TRACER_W; 71 close $TRACER_W;
48 72
73 my $pkg = "pkg000000";
74
49 unshift @INC, sub { 75 unshift @INC, sub {
50 my $dir = find_inc $_[1] 76 my $dir = find_incdir $_[1]
51 or return; 77 or return;
52 78
53 syswrite $W_TRACER, "-\n$dir\n$_[1]\n"; 79 syswrite $W_TRACER, "-\n$dir\n$_[1]\n";
54 80
55 open my $fh, "<:perlio", "$dir/$_[1]" 81 open my $fh, "<:raw:perlio", "$dir/$_[1]"
56 or warn "ERROR: $dir/$_[1]: $!\n"; 82 or warn "ERROR: $dir/$_[1]: $!\n";
57 83
58 $fh 84 $fh
59 }; 85 };
60 86
61 while (<$R_TRACER>) { 87 while (<$R_TRACER>) {
62 if (/use (.*)$/) { 88 if (/use (.*)$/) {
63 my $mod = $1; 89 my $mod = $1;
90 my $eval;
91
92 if ($mod =~ /^'.*'$/ or $mod =~ /^".*"$/) {
64 eval "require $mod"; 93 $eval = "require $mod";
94 } elsif ($mod =~ y%/.%%) {
95 $eval = "require q\x00$mod\x00";
96 } else {
97 my $pkg = ++$pkg;
98 $eval = "{ package $pkg; use $mod; }";
99 }
100
101 eval $eval;
65 warn "ERROR: $@ (while loading '$mod')\n" 102 warn "ERROR: $@ (while loading '$mod')\n"
66 if $@; 103 if $@;
67 syswrite $W_TRACER, "\n";
68 } elsif (/eval (.*)$/) { 104 } elsif (/eval (.*)$/) {
69 my $eval = $1; 105 my $eval = $1;
70 eval $eval; 106 eval $eval;
71 warn "ERROR: $@ (in '$eval')\n" 107 warn "ERROR: $@ (in '$eval')\n"
72 if $@; 108 if $@;
73 } 109 }
110
111 syswrite $W_TRACER, "\n";
74 } 112 }
75 113
76 exit 0; 114 exit 0;
77 } 115 }
78} 116}
79 117
80# module loading is now safe 118# module loading is now safe
119
120sub trace_parse {
121 for (;;) {
122 <$TRACER_R> =~ /^-$/ or last;
123 my $dir = <$TRACER_R>; chomp $dir;
124 my $name = <$TRACER_R>; chomp $name;
125
126 $pm{$name} = "$dir/$name";
127
128 print "+ found potential dependency $name\n"
129 if $VERBOSE >= 3;
130 }
131}
132
133sub trace_module {
134 print "tracing module $_[0]\n"
135 if $VERBOSE >= 2;
136
137 syswrite $TRACER_W, "use $_[0]\n";
138 trace_parse;
139}
140
141sub trace_eval {
142 print "tracing eval $_[0]\n"
143 if $VERBOSE >= 2;
144
145 syswrite $TRACER_W, "eval $_[0]\n";
146 trace_parse;
147}
148
149sub trace_finish {
150 close $TRACER_W;
151 close $TRACER_R;
152}
153
154#############################################################################
155# now we can use modules
156
157use common::sense;
81use Config; 158use Config;
159use Digest::MD5;
160
161sub cache($$$) {
162 my ($variant, $src, $filter) = @_;
163
164 if (length $CACHE and 2048 <= length $src and defined $variant) {
165 my $file = "$CACHE/" . Digest::MD5::md5_hex "$CACHEVER\x00$variant\x00$src";
166
167 if (open my $fh, "<:raw:perlio", $file) {
168 print "using cache for $file\n"
169 if $VERBOSE >= 7;
170
171 local $/;
172 return <$fh>;
173 }
174
175 $src = $filter->($src);
176
177 print "creating cache entry $file\n"
178 if $VERBOSE >= 8;
179
180 if (open my $fh, ">:raw:perlio", "$file~") {
181 if ((syswrite $fh, $src) == length $src) {
182 close $fh;
183 rename "$file~", $file;
184 }
185 }
186
187 return $src;
188 }
189
190 $filter->($src)
191}
192
193sub dump_string {
194 my ($fh, $data) = @_;
195
196 if (length $data) {
197 if ($^O eq "MSWin32") {
198 # 16 bit system, strings can't be longer than 64k. seriously.
199 print $fh "{\n";
200 for (
201 my $ofs = 0;
202 length (my $substr = substr $data, $ofs, 20);
203 $ofs += 20
204 ) {
205 $substr = join ",", map ord, split //, $substr;
206 print $fh " $substr,\n";
207 }
208 print $fh " 0 }\n";
209 } else {
210 for (
211 my $ofs = 0;
212 length (my $substr = substr $data, $ofs, 80);
213 $ofs += 80
214 ) {
215 $substr =~ s/([^\x20-\x21\x23-\x5b\x5d-\x7e])/sprintf "\\%03o", ord $1/ge;
216 $substr =~ s/\?/\\?/g; # trigraphs...
217 print $fh " \"$substr\"\n";
218 }
219 }
220 } else {
221 print $fh " \"\"\n";
222 }
223}
224
225#############################################################################
226
227sub glob2re {
228 for (quotemeta $_[0]) {
229 s/\\\*/\x00/g;
230 s/\x00\x00/.*/g;
231 s/\x00/[^\/]*/g;
232 s/\\\?/[^\/]/g;
233
234 $_ = s/^\\\/// ? "^$_\$" : "(?:^|/)$_\$";
235
236 s/(?: \[\^\/\] | \. ) \*\$$//x;
237
238 return qr<$_>s
239 }
240}
241
242our %INCSKIP = (
243 "unicore/TestProp.pl" => undef, # 3.5MB of insanity, apparently just some testcase
244);
245
246sub get_dirtree {
247 my $root = shift;
248
249 my @tree;
250 my $skip;
251
252 my $scan; $scan = sub {
253 for (sort do {
254 opendir my $fh, $_[0]
255 or return;
256 readdir $fh
257 }) {
258 next if /^\./;
259
260 my $path = "$_[0]/$_";
261
262 if (-d "$path/.") {
263 $scan->($path);
264 } else {
265 $path = substr $path, $skip;
266 push @tree, $path
267 unless exists $INCSKIP{$path};
268 }
269 }
270 };
271
272 $root =~ s/\/$//;
273 $skip = 1 + length $root;
274 $scan->($root);
275
276 \@tree
277}
278
279my $inctrees;
280
281sub get_inctrees {
282 unless ($inctrees) {
283 my %inctree;
284 $inctree{$_} ||= [$_, get_dirtree $_] # entries in @INC are often duplicates
285 for @INC;
286 $inctrees = [values %inctree];
287 }
288
289 @$inctrees
290}
291
292#############################################################################
293
294sub cmd_boot {
295 $pm{"!boot"} = $_[0];
296}
297
298sub cmd_add {
299 $_[0] =~ /^(.*?)(?:\s+(\S+))?$/
300 or die "$_[0]: cannot parse";
301
302 my $file = $1;
303 my $as = defined $2 ? $2 : $1;
304
305 $pm{$as} = $file;
306 $pmbin{$as} = 1 if $_[1];
307}
308
309sub cmd_staticlib {
310 push @staticlibs, $_
311 for split /\s+/, $_[0];
312}
313
314sub cmd_include {
315 push @incext, [$_[1], glob2re $_[0]];
316}
317
318sub cmd_incglob {
319 my ($pattern) = @_;
320
321 $pattern = glob2re $pattern;
322
323 for (get_inctrees) {
324 my ($dir, $files) = @$_;
325
326 $pm{$_} = "$dir/$_"
327 for grep /$pattern/ && /\.(pl|pm)$/, @$files;
328 }
329}
330
331sub parse_argv;
332
333sub cmd_file {
334 open my $fh, "<", $_[0]
335 or die "$_[0]: $!\n";
336
337 local @ARGV;
338
339 while (<$fh>) {
340 chomp;
341 next unless /\S/;
342 next if /^\s*#/;
343
344 s/^\s*-*/--/;
345 my ($cmd, $args) = split / /, $_, 2;
346
347 push @ARGV, $cmd;
348 push @ARGV, $args if defined $args;
349 }
350
351 parse_argv;
352}
353
354use Getopt::Long;
355
356sub parse_argv {
357 GetOptions
358 "perl" => \$PERL,
359 "app=s" => \$APP,
360
361 "verbose|v" => sub { ++$VERBOSE },
362 "quiet|q" => sub { --$VERBOSE },
363
364 "strip=s" => \$STRIP,
365 "cache=s" => \$CACHE, # internal option
366 "eval|e=s" => sub { trace_eval $_[1] },
367 "use|M=s" => sub { trace_module $_[1] },
368 "boot=s" => sub { cmd_boot $_[1] },
369 "add=s" => sub { cmd_add $_[1], 0 },
370 "addbin=s" => sub { cmd_add $_[1], 1 },
371 "incglob=s" => sub { cmd_incglob $_[1] },
372 "include|i=s" => sub { cmd_include $_[1], 1 },
373 "exclude|x=s" => sub { cmd_include $_[1], 0 },
374 "usepacklists!" => \$PACKLIST,
375
376 "static!" => \$STATIC,
377 "staticlib=s" => sub { cmd_staticlib $_[1] },
378 "allow-dynamic!"=> \$ALLOW_DYNAMIC,
379 "ignore-env" => \$IGNORE_ENV,
380
381 "<>" => sub { cmd_file $_[0] },
382 or exit 1;
383}
384
385Getopt::Long::Configure ("bundling", "no_auto_abbrev", "no_ignore_case");
386
387parse_argv;
388
389die "cannot specify both --app and --perl\n"
390 if $PERL and defined $APP;
391
392# required for @INC loading, unfortunately
393trace_module "PerlIO::scalar";
394
395#############################################################################
396# apply include/exclude
397
398{
399 my %pmi;
400
401 for (@incext) {
402 my ($inc, $glob) = @$_;
403
404 my @match = grep /$glob/, keys %pm;
405
406 if ($inc) {
407 # include
408 @pmi{@match} = delete @pm{@match};
409
410 print "applying include $glob - protected ", (scalar @match), " files.\n"
411 if $VERBOSE >= 5;
412 } else {
413 # exclude
414 delete @pm{@match};
415
416 print "applying exclude $glob - removed ", (scalar @match), " files.\n"
417 if $VERBOSE >= 5;
418 }
419 }
420
421 my @pmi = keys %pmi;
422 @pm{@pmi} = delete @pmi{@pmi};
423}
424
425#############################################################################
426# scan for AutoLoader, static archives and other dependencies
82 427
83sub scan_al { 428sub scan_al {
84 my ($auto, $autodir, $ix) = @_; 429 my ($auto, $autodir) = @_;
85 430
86 $pm{"$auto/$ix"} = "$autodir/$ix"; 431 my $ix = "$autodir/autosplit.ix";
87 432
433 print "processing autoload index for '$auto'\n"
434 if $VERBOSE >= 6;
435
436 $pm{"$auto/autosplit.ix"} = $ix;
437
88 open my $fh, "<:perlio", "$autodir/$ix" 438 open my $fh, "<:perlio", $ix
89 or die "$autodir/$ix: $!"; 439 or die "$ix: $!";
90 440
91 my $package; 441 my $package;
92 442
93 while (<$fh>) { 443 while (<$fh>) {
94 if (/^\s*sub\s+ ([^[:space:];]+) \s* (?:\([^)]*\))? \s*;?\s*$/x) { 444 if (/^\s*sub\s+ ([^[:space:];]+) \s* (?:\([^)]*\))? \s*;?\s*$/x) {
95 my $al = "auto/$package/$1.al"; 445 my $al = "auto/$package/$1.al";
96 my $inc = find_inc $al; 446 my $inc = find_inc $al;
97 447
98 defined $inc or die "$al: autoload file not found, but should be there.\n"; 448 defined $inc or die "$al: autoload file not found, but should be there.\n";
99 449
100 $pm{$al} = "$inc/$al"; 450 $pm{$al} = $inc;
451 print "found autoload function '$al'\n"
452 if $VERBOSE >= 6;
101 453
102 } elsif (/^\s*package\s+([^[:space:];]+)\s*;?\s*$/) { 454 } elsif (/^\s*package\s+([^[:space:];]+)\s*;?\s*$/) {
103 ($package = $1) =~ s/::/\//g; 455 ($package = $1) =~ s/::/\//g;
104 } elsif (/^\s*(?:#|1?\s*;?\s*$)/) { 456 } elsif (/^\s*(?:#|1?\s*;?\s*$)/) {
105 # nop 457 # nop
106 } else { 458 } else {
107 warn "$autodir/$ix: unparsable line, please report: $_"; 459 warn "WARNING: $ix: unparsable line, please report: $_";
108 } 460 }
109 } 461 }
110} 462}
111 463
112sub trace_module { 464for my $pm (keys %pm) {
113 syswrite $TRACER_W, "use $_[0]\n";
114
115 for (;;) {
116 <$TRACER_R> =~ /^-$/ or last;
117 my $dir = <$TRACER_R>; chomp $dir;
118 my $name = <$TRACER_R>; chomp $name;
119
120 $pm{$name} = "$dir/$name";
121
122 if ($name =~ /^(.*)\.pm$/) { 465 if ($pm =~ /^(.*)\.pm$/) {
123 my $auto = "auto/$1"; 466 my $auto = "auto/$1";
124 my $autodir = "$dir/$auto"; 467 my $autodir = find_inc $auto;
125 468
126 if (-d $autodir) { 469 if (defined $autodir && -d $autodir) {
127 opendir my $dir, $autodir
128 or die "$autodir: $!\n";
129
130 for (readdir $dir) {
131 # AutoLoader 470 # AutoLoader
132 scan_al $auto, $autodir, $_ 471 scan_al $auto, $autodir
133 if /\.ix$/; 472 if -f "$autodir/autosplit.ix";
134 473
474 # extralibs.ld
475 if (open my $fh, "<:perlio", "$autodir/extralibs.ld") {
476 print "found extralibs for $pm\n"
477 if $VERBOSE >= 6;
478
479 local $/;
480 $extralibs .= " " . <$fh>;
481 }
482
483 $pm =~ /([^\/]+).pm$/ or die "$pm: unable to match last component";
484
485 my $base = $1;
486
135 # static ext 487 # static ext
136 if (/\Q$Config{_a}\E$/o) { 488 if (-f "$autodir/$base$Config{_a}") {
489 print "found static archive for $pm\n"
490 if $VERBOSE >= 3;
491
137 push @libs, "$autodir/$_"; 492 push @libs, "$autodir/$base$Config{_a}";
138 push @static_ext, $name; 493 push @static_ext, $pm;
494 }
495
496 # dynamic object
497 if (-f "$autodir/$base.$Config{dlext}") {
498 if ($ALLOW_DYNAMIC) {
499 my $as = "!$auto/$base.$Config{dlext}";
500 $pm{$as} = "$autodir/$base.$Config{dlext}";
501 $pmbin{$as} = 1;
502
503 $HAVE_DYNAMIC = 1;
504
505 print "+ added dynamic object $as\n"
506 if $VERBOSE >= 3;
507 } else {
508 die "ERROR: found shared object '$autodir/$base.$Config{dlext}' but --allow-dynamic not given, aborting.\n"
509 }
510 }
511
512 if ($PACKLIST && open my $fh, "<:perlio", "$autodir/.packlist") {
513 print "found .packlist for $pm\n"
514 if $VERBOSE >= 3;
515
516 while (<$fh>) {
517 chomp;
518 s/ .*$//; # newer-style .packlists might contain key=value pairs
519
520 # only include certain files (.al, .ix, .pm, .pl)
521 if (/\.(pm|pl|al|ix)$/) {
522 for my $inc (@INC) {
523 # in addition, we only add files that are below some @INC path
524 $inc =~ s/\/*$/\//;
525
526 if ($inc eq substr $_, 0, length $inc) {
527 my $base = substr $_, length $inc;
528 $pm{$base} = $_;
529
530 print "+ added .packlist dependency $base\n"
531 if $VERBOSE >= 3;
532 }
533
534 last;
535 }
139 } 536 }
140
141 # extralibs.ld
142 if ($_ eq "extralibs.ld") {
143 open my $fh, "<:perlio", "$autodir/$_"
144 or die "$autodir/$_";
145
146 local $/;
147 $extralibs .= " " . <$fh>;
148 }
149
150 # dynamic object
151 warn "WARNING: found shared object - can't link statically ($_)\n"
152 if /\.\Q$Config{dlext}\E$/o;
153 } 537 }
154 } 538 }
155 } 539 }
156 } 540 }
157} 541}
158 542
159sub trace_eval {
160 syswrite $TRACER_W, "eval $_[0]\n";
161}
162
163sub trace_finish {
164 close $TRACER_W;
165 close $TRACER_R;
166}
167
168############################################################################# 543#############################################################################
169# now we can use modules
170 544
171use common::sense; 545print "processing bundle files (try more -v power if you get bored waiting here)...\n"
172use Digest::MD5; 546 if $VERBOSE >= 1;
173
174sub dump_string {
175 my ($fh, $data) = @_;
176
177 if (length $data) {
178 for (
179 my $ofs = 0;
180 length (my $substr = substr $data, $ofs, 80);
181 $ofs += 80
182 ) {
183 $substr =~ s/([^\x20-\x21\x23-\x5b\x5d-\x7e])/sprintf "\\%03o", ord $1/ge;
184 $substr =~ s/\?/\\?/g; # trigraphs...
185 print $fh " \"$substr\"\n";
186 }
187 } else {
188 print $fh " \"\"\n";
189 }
190}
191
192# required for @INC loading, unfortunately
193trace_module "PerlIO::scalar";
194
195#trace_module "Term::ReadLine::readline"; # Term::ReadLine::Perl dependency
196# URI is difficult
197#trace_module "URI::http";
198#trace_module "URI::_generic";
199
200sub cmd_boot {
201 $pm{"//boot"} = $_[0];
202}
203
204sub cmd_add {
205 $_[0] =~ /^(.*)(?:\s+(\S+))$/
206 or die "$_[0]: cannot parse";
207
208 my $file = $1;
209 my $as = defined $2 ? $2 : "/$1";
210
211 $pm{$as} = $file;
212 $pmbin{$as} = 1 if $_[1];
213}
214
215sub cmd_file {
216 open my $fh, "<", $_[0]
217 or die "$_[0]: $!\n";
218
219 while (<$fh>) {
220 chomp;
221 my ($cmd, $args) = split / /, $_, 2;
222 $cmd =~ s/^-+//;
223
224 if ($cmd eq "strip") {
225 $STRIP = $args;
226 } elsif ($cmd eq "perl") {
227 $PERL = 1;
228 } elsif ($cmd eq "app") {
229 $APP = $args;
230 } elsif ($cmd eq "eval") {
231 trace_eval $_;
232 } elsif ($cmd eq "use") {
233 trace_module $_
234 for split / /, $args;
235 } elsif ($cmd eq "boot") {
236 cmd_boot $args;
237 } elsif ($cmd eq "static") {
238 $STATIC = 1;
239 } elsif ($cmd eq "add") {
240 cmd_add $args, 0;
241 } elsif ($cmd eq "addbin") {
242 cmd_add $args, 1;
243 } elsif (/^\s*#/) {
244 # comment
245 } elsif (/\S/) {
246 die "$_: unsupported directive\n";
247 }
248 }
249}
250
251use Getopt::Long;
252
253Getopt::Long::Configure ("bundling", "no_auto_abbrev", "no_ignore_case");
254
255GetOptions
256 "strip=s" => \$STRIP,
257 "verbose|v" => sub { ++$VERBOSE },
258 "quiet|q" => sub { --$VERBOSE },
259 "perl" => \$PERL,
260 "app=s" => \$APP,
261 "eval|e=s" => sub { trace_eval $_[1] },
262 "use|M=s" => sub { trace_module $_[1] },
263 "boot=s" => sub { cmd_boot $_[1] },
264 "add=s" => sub { cmd_add $_[1], 0 },
265 "addbin=s" => sub { cmd_add $_[1], 1 },
266 "static" => sub { $STATIC = 1 },
267 "<>" => sub { cmd_file $_[0] },
268 or exit 1;
269
270die "cannot specify both --app and --perl\n"
271 if $PERL and defined $APP;
272 547
273my $data; 548my $data;
274my @index; 549my @index;
275my @order = sort { 550my @order = sort {
276 length $a <=> length $b 551 length $a <=> length $b
… …
283 558
284for my $pm (@order) { 559for my $pm (@order) {
285 my $path = $pm{$pm}; 560 my $path = $pm{$pm};
286 561
287 128 > length $pm 562 128 > length $pm
288 or die "$pm: path too long (only 128 octets supported)\n"; 563 or die "ERROR: $pm: path too long (only 128 octets supported)\n";
289 564
290 my $src = ref $path 565 my $src = ref $path
291 ? $$path 566 ? $$path
292 : do { 567 : do {
293 open my $pm, "<", $path 568 open my $pm, "<:raw:perlio", $path
294 or die "$path: $!"; 569 or die "$path: $!";
295 570
296 local $/; 571 local $/;
297 572
298 <$pm> 573 <$pm>
299 }; 574 };
300 575
576 my $size = length $src;
577
301 unless ($pmbin{$pm}) { # only do this unless the file is binary 578 unless ($pmbin{$pm}) { # only do this unless the file is binary
302
303 if ($pm =~ /^auto\/POSIX\/[^\/]+\.al$/) { 579 if ($pm =~ /^auto\/POSIX\/[^\/]+\.al$/) {
304 if ($src =~ /^ unimpl \"/m) { 580 if ($src =~ /^ unimpl \"/m) {
305 warn "$pm: skipping (not implemented anyways).\n" 581 print "$pm: skipping (raises runtime error only).\n"
306 if $VERBOSE >= 2; 582 if $VERBOSE >= 3;
307 next; 583 next;
308 } 584 }
309 } 585 }
310 586
587 $src = cache +($STRIP eq "ppi" ? "$UNISTRIP,$OPTIMISE_SIZE" : undef), $src, sub {
588 if ($UNISTRIP && $pm =~ /^unicore\/.*\.pl$/) {
589 print "applying unicore stripping $pm\n"
590 if $VERBOSE >= 6;
591
592 # special stripping for unicore swashes and properties
593 # much more could be done by going binary
594 $src =~ s{
595 (^return\ <<'END';\n) (.*?\n) (END(?:\n|\Z))
596 }{
597 my ($pre, $data, $post) = ($1, $2, $3);
598
599 for ($data) {
600 s/^([0-9a-fA-F]+)\t([0-9a-fA-F]+)\t/sprintf "%X\t%X", hex $1, hex $2/gem
601 if $OPTIMISE_SIZE;
602
603# s{
604# ^([0-9a-fA-F]+)\t([0-9a-fA-F]*)\t
605# }{
606# # ww - smaller filesize, UU - compress better
607# pack "C0UU",
608# hex $1,
609# length $2 ? (hex $2) - (hex $1) : 0
610# }gemx;
611
612 s/#.*\n/\n/mg;
613 s/\s+\n/\n/mg;
614 }
615
616 "$pre$data$post"
617 }smex;
618 }
619
311 if ($STRIP =~ /ppi/i) { 620 if ($STRIP =~ /ppi/i) {
312 require PPI; 621 require PPI;
313 622
314 my $ppi = PPI::Document->new (\$src); 623 if (my $ppi = PPI::Document->new (\$src)) {
315 $ppi->prune ("PPI::Token::Comment"); 624 $ppi->prune ("PPI::Token::Comment");
316 $ppi->prune ("PPI::Token::Pod"); 625 $ppi->prune ("PPI::Token::Pod");
317 626
318 # prune END stuff 627 # prune END stuff
319 for (my $last = $ppi->last_element; $last; ) { 628 for (my $last = $ppi->last_element; $last; ) {
320 my $prev = $last->previous_token; 629 my $prev = $last->previous_token;
321 630
322 if ($last->isa (PPI::Token::Whitespace::)) { 631 if ($last->isa (PPI::Token::Whitespace::)) {
323 $last->delete; 632 $last->delete;
324 } elsif ($last->isa (PPI::Statement::End::)) { 633 } elsif ($last->isa (PPI::Statement::End::)) {
325 $last->delete; 634 $last->delete;
326 last; 635 last;
327 } elsif ($last->isa (PPI::Token::Pod::)) { 636 } elsif ($last->isa (PPI::Token::Pod::)) {
328 $last->delete; 637 $last->delete;
638 } else {
639 last;
640 }
641
642 $last = $prev;
643 }
644
645 # prune some but not all insignificant whitespace
646 for my $ws (@{ $ppi->find (PPI::Token::Whitespace::) }) {
647 my $prev = $ws->previous_token;
648 my $next = $ws->next_token;
649
650 if (!$prev || !$next) {
651 $ws->delete;
652 } else {
653 if (
654 $next->isa (PPI::Token::Operator::) && $next->{content} =~ /^(?:,|=|!|!=|==|=>)$/ # no ., because of digits. == float
655 or $prev->isa (PPI::Token::Operator::) && $prev->{content} =~ /^(?:,|=|\.|!|!=|==|=>)$/
656 or $prev->isa (PPI::Token::Structure::)
657 or ($OPTIMISE_SIZE &&
658 ($prev->isa (PPI::Token::Word::)
659 && (PPI::Token::Symbol:: eq ref $next
660 || $next->isa (PPI::Structure::Block::)
661 || $next->isa (PPI::Structure::List::)
662 || $next->isa (PPI::Structure::Condition::)))
663 )
664 ) {
665 $ws->delete;
666 } elsif ($prev->isa (PPI::Token::Whitespace::)) {
667 $ws->{content} = ' ';
668 $prev->delete;
669 } else {
670 $ws->{content} = ' ';
671 }
672 }
673 }
674
675 # prune whitespace around blocks
676 if ($OPTIMISE_SIZE) {
677 # these usually decrease size, but decrease compressability more
678 for my $struct (PPI::Structure::Block::, PPI::Structure::Condition::) {
679 for my $node (@{ $ppi->find ($struct) }) {
680 my $n1 = $node->first_token;
681 my $n2 = $n1->previous_token;
682 $n1->delete if $n1->isa (PPI::Token::Whitespace::);
683 $n2->delete if $n2 && $n2->isa (PPI::Token::Whitespace::);
684 my $n1 = $node->last_token;
685 my $n2 = $n1->next_token;
686 $n1->delete if $n1->isa (PPI::Token::Whitespace::);
687 $n2->delete if $n2 && $n2->isa (PPI::Token::Whitespace::);
688 }
689 }
690
691 for my $node (@{ $ppi->find (PPI::Structure::List::) }) {
692 my $n1 = $node->first_token;
693 $n1->delete if $n1->isa (PPI::Token::Whitespace::);
694 my $n1 = $node->last_token;
695 $n1->delete if $n1->isa (PPI::Token::Whitespace::);
696 }
697 }
698
699 # reformat qw() lists which often have lots of whitespace
700 for my $node (@{ $ppi->find (PPI::Token::QuoteLike::Words::) }) {
701 if ($node->{content} =~ /^qw(.)(.*)(.)$/s) {
702 my ($a, $qw, $b) = ($1, $2, $3);
703 $qw =~ s/^\s+//;
704 $qw =~ s/\s+$//;
705 $qw =~ s/\s+/ /g;
706 $node->{content} = "qw$a$qw$b";
707 }
708 }
709
710 $src = $ppi->serialize;
329 } else { 711 } else {
330 last; 712 warn "WARNING: $pm{$pm}: PPI failed to parse this file\n";
331 } 713 }
714 } elsif ($STRIP =~ /pod/i && $pm ne "Opcode.pm") { # opcode parses its own pod
715 require Pod::Strip;
332 716
333 $last = $prev; 717 my $stripper = Pod::Strip->new;
718
719 my $out;
720 $stripper->output_string (\$out);
721 $stripper->parse_string_document ($src)
722 or die;
723 $src = $out;
334 } 724 }
335 725
336 # prune some but not all insignificant whitespace 726 if ($VERIFY && $pm =~ /\.pm$/ && $pm ne "Opcode.pm") {
337 for my $ws (@{ $ppi->find (PPI::Token::Whitespace::) }) { 727 if (open my $fh, "-|") {
338 my $prev = $ws->previous_token;
339 my $next = $ws->next_token;
340
341 if (!$prev || !$next) {
342 $ws->delete; 728 <$fh>;
343 } else { 729 } else {
344 if ( 730 eval "#line 1 \"$pm\"\n$src" or warn "\n\n\n$pm\n\n$src\n$@\n\n\n";
345 $next->isa (PPI::Token::Operator::) && $next->{content} =~ /^(?:,|=|!|!=|==|=>)$/ # no ., because of digits. == float
346 or $prev->isa (PPI::Token::Operator::) && $prev->{content} =~ /^(?:,|=|\.|!|!=|==|=>)$/
347 or $prev->isa (PPI::Token::Structure::)
348 # decrease size, decrease compressability
349 #or ($prev->isa (PPI::Token::Word::)
350 # && (PPI::Token::Symbol:: eq ref $next
351 # || $next->isa (PPI::Structure::Block::)
352 # || $next->isa (PPI::Structure::List::)
353 # || $next->isa (PPI::Structure::Condition::)))
354 ) {
355 $ws->delete;
356 } elsif ($prev->isa (PPI::Token::Whitespace::)) {
357 $ws->{content} = ' ';
358 $prev->delete;
359 } else {
360 $ws->{content} = ' ';
361 } 731 exit 0;
362 } 732 }
363 } 733 }
364 734
365 # prune whitespace around blocks
366 if (0) {
367 # these usually decrease size, but decrease compressability more
368 for my $struct (PPI::Structure::Block::, PPI::Structure::Condition::) {
369 for my $node (@{ $ppi->find ($struct) }) {
370 my $n1 = $node->first_token;
371 my $n2 = $n1->previous_token;
372 $n1->delete if $n1->isa (PPI::Token::Whitespace::);
373 $n2->delete if $n2 && $n2->isa (PPI::Token::Whitespace::);
374 my $n1 = $node->last_token;
375 my $n2 = $n1->next_token;
376 $n1->delete if $n1->isa (PPI::Token::Whitespace::);
377 $n2->delete if $n2 && $n2->isa (PPI::Token::Whitespace::);
378 }
379 }
380
381 for my $node (@{ $ppi->find (PPI::Structure::List::) }) {
382 my $n1 = $node->first_token;
383 $n1->delete if $n1->isa (PPI::Token::Whitespace::);
384 my $n1 = $node->last_token;
385 $n1->delete if $n1->isa (PPI::Token::Whitespace::);
386 }
387 } 735 $src
388
389 # reformat qw() lists which often have lots of whitespace
390 for my $node (@{ $ppi->find (PPI::Token::QuoteLike::Words::) }) {
391 if ($node->{content} =~ /^qw(.)(.*)(.)$/s) {
392 my ($a, $qw, $b) = ($1, $2, $3);
393 $qw =~ s/^\s+//;
394 $qw =~ s/\s+$//;
395 $qw =~ s/\s+/ /g;
396 $node->{content} = "qw$a$qw$b";
397 }
398 }
399
400 $src = $ppi->serialize;
401 } elsif ($STRIP =~ /pod/i && $pm ne "Opcode.pm") { # opcode parses it's own pod
402 require Pod::Strip;
403
404 my $stripper = Pod::Strip->new;
405
406 my $out;
407 $stripper->output_string (\$out);
408 $stripper->parse_string_document ($src)
409 or die;
410 $src = $out;
411 } 736 };
412
413 if ($VERIFY && $pm =~ /\.pm$/ && $pm ne "Opcode.pm") {
414 if (open my $fh, "-|") {
415 <$fh>;
416 } else {
417 eval "#line 1 \"$pm\"\n$src" or warn "\n\n\n$pm\n\n$src\n$@\n\n\n";
418 exit 0;
419 }
420 }
421 737
422# if ($pm eq "Opcode.pm") { 738# if ($pm eq "Opcode.pm") {
423# open my $fh, ">x" or die; print $fh $src;#d# 739# open my $fh, ">x" or die; print $fh $src;#d#
424# exit 1; 740# exit 1;
425# } 741# }
426 } 742 }
427 743
428 warn "adding $pm\n" 744 print "adding $pm (original size $size, stored size ", length $src, ")\n"
429 if $VERBOSE >= 2; 745 if $VERBOSE >= 2;
430 746
431 push @index, ((length $pm) << 25) | length $data; 747 push @index, ((length $pm) << 25) | length $data;
432 $data .= $pm . $src; 748 $data .= $pm . $src;
433} 749}
434 750
435length $data < 2**25 751length $data < 2**25
436 or die "bundle too large (only 32MB supported)\n"; 752 or die "ERROR: bundle too large (only 32MB supported)\n";
437 753
438my $varpfx = "bundle_" . substr +(Digest::MD5::md5_hex $data), 0, 16; 754my $varpfx = "bundle";
439 755
440############################################################################# 756#############################################################################
441# output 757# output
442 758
443print "generating $PREFIX.h... "; 759print "generating $PREFIX.h... "
760 if $VERBOSE >= 1;
444 761
445{ 762{
446 open my $fh, ">", "$PREFIX.h" 763 open my $fh, ">", "$PREFIX.h"
447 or die "$PREFIX.h: $!\n"; 764 or die "$PREFIX.h: $!\n";
448 765
449 print $fh <<EOF; 766 print $fh <<EOF;
450/* do not edit, automatically created by mkstaticbundle */ 767/* do not edit, automatically created by staticperl */
451 768
452#include <EXTERN.h> 769#include <EXTERN.h>
453#include <perl.h> 770#include <perl.h>
454#include <XSUB.h> 771#include <XSUB.h>
455 772
456/* public API */ 773/* public API */
457EXTERN_C PerlInterpreter *staticperl; 774EXTERN_C PerlInterpreter *staticperl;
458EXTERN_C void staticperl_xs_init (pTHX); 775EXTERN_C void staticperl_xs_init (pTHX);
459EXTERN_C void staticperl_init (void); 776EXTERN_C void staticperl_init (XSINIT_t xs_init); /* argument can be 0 */
460EXTERN_C void staticperl_cleanup (void); 777EXTERN_C void staticperl_cleanup (void);
461 778
462EOF 779EOF
463} 780}
464 781
465print "\n"; 782print "\n"
783 if $VERBOSE >= 1;
466 784
467############################################################################# 785#############################################################################
468# output 786# output
469 787
470print "generating $PREFIX.c... "; 788print "generating $PREFIX.c... "
789 if $VERBOSE >= 1;
471 790
472open my $fh, ">", "$PREFIX.c" 791open my $fh, ">", "$PREFIX.c"
473 or die "$PREFIX.c: $!\n"; 792 or die "$PREFIX.c: $!\n";
474 793
475print $fh <<EOF; 794print $fh <<EOF;
476/* do not edit, automatically created by mkstaticbundle */ 795/* do not edit, automatically created by staticperl */
477 796
478#include "bundle.h" 797#include "bundle.h"
479 798
480/* public API */ 799/* public API */
481PerlInterpreter *staticperl; 800PerlInterpreter *staticperl;
… …
505printf $fh "0x%08x\n};\n", (length $data); 824printf $fh "0x%08x\n};\n", (length $data);
506 825
507print $fh "static const char $varpfx\_data [] =\n"; 826print $fh "static const char $varpfx\_data [] =\n";
508dump_string $fh, $data; 827dump_string $fh, $data;
509 828
510print $fh ";\n\n";; 829print $fh ";\n\n";
511 830
512############################################################################# 831#############################################################################
513# bootstrap 832# bootstrap
514 833
515# boot file for staticperl 834# boot file for staticperl
516# this file will be eval'ed at initialisation time 835# this file will be eval'ed at initialisation time
517 836
837# lines marked with "^D" are only used when $HAVE_DYNAMIC
518my $bootstrap = ' 838my $bootstrap = '
519BEGIN { 839BEGIN {
520 package ' . $PACKAGE . '; 840 package ' . $PACKAGE . ';
521 841
522 PerlIO::scalar->bootstrap; 842 # the path prefix to use when putting files into %INC
843 our $inc_prefix;
523 844
524 @INC = sub { 845 # the @INC hook to use when we have PerlIO::scalar available
846 my $perlio_inc = sub {
525 my $data = find "$_[1]" 847 my $data = find "$_[1]"
526 or return; 848 or return;
527 849
528 $INC{$_[1]} = $_[1]; 850 $INC{$_[1]} = "$inc_prefix$_[1]";
529 851
530 open my $fh, "<", \$data; 852 open my $fh, "<", \$data;
531 $fh 853 $fh
532 }; 854 };
855
856D if (defined &PerlIO::scalar::bootstrap) {
857 # PerlIO::scalar statically compiled in
858 PerlIO::scalar->bootstrap;
859 @INC = $perlio_inc;
860D } else {
861D # PerlIO::scalar not available, use slower method
862D @INC = sub {
863D # always check if PerlIO::scalar might now be available
864D if (defined &PerlIO::scalar::bootstrap) {
865D # switch to the faster perlio_inc hook
866D @INC = map { $_ == $_[0] ? $perlio_inc : $_ } @INC;
867D goto &$perlio_inc;
868D }
869D
870D my $data = find "$_[1]"
871D or return;
872D
873D $INC{$_[1]} = "$inc_prefix$_[1]";
874D
875D sub {
876D $data =~ /\G([^\n]*\n?)/g
877D or return;
878D
879D $_ = $1;
880D 1
881D }
882D };
883D }
533} 884}
534'; 885';
535 886
536$bootstrap .= "require '//boot';" 887$bootstrap .= "require '!boot';"
537 if exists $pm{"//boot"}; 888 if exists $pm{"!boot"};
538 889
890if ($HAVE_DYNAMIC) {
891 $bootstrap =~ s/^D/ /mg;
892} else {
893 $bootstrap =~ s/^D.*$//mg;
894}
895
896$bootstrap =~ s/#.*$//mg;
539$bootstrap =~ s/\s+/ /g; 897$bootstrap =~ s/\s+/ /g;
540$bootstrap =~ s/(\W) /$1/g; 898$bootstrap =~ s/(\W) /$1/g;
541$bootstrap =~ s/ (\W)/$1/g; 899$bootstrap =~ s/ (\W)/$1/g;
542 900
543print $fh "const char bootstrap [] = "; 901print $fh "const char bootstrap [] = ";
… …
589 } 947 }
590 948
591 XSRETURN (0); 949 XSRETURN (0);
592 950
593 found: 951 found:
594 ST (0) = res; 952 ST (0) = sv_2mortal (res);
595 sv_2mortal (ST (0));
596 } 953 }
597 954
598 XSRETURN (1); 955 XSRETURN (1);
599} 956}
600 957
… …
613 970
614 for (i = 0; i < $varpfx\_count; ++i) 971 for (i = 0; i < $varpfx\_count; ++i)
615 { 972 {
616 U32 idx = $varpfx\_index [i]; 973 U32 idx = $varpfx\_index [i];
617 974
618 PUSHs (newSVpvn ($varpfx\_data + (idx & 0x1FFFFFFU), idx >> 25)); 975 PUSHs (sv_2mortal (newSVpvn ($varpfx\_data + (idx & 0x1FFFFFFU), idx >> 25)));
619 } 976 }
620 } 977 }
621 978
622 XSRETURN ($varpfx\_count); 979 XSRETURN ($varpfx\_count);
623} 980}
… …
631void 988void
632staticperl_xs_init (pTHX) 989staticperl_xs_init (pTHX)
633{ 990{
634EOF 991EOF
635 992
636@static_ext = ("DynaLoader", sort @static_ext); 993@static_ext = sort @static_ext;
637 994
638# prototypes 995# prototypes
639for (@static_ext) { 996for (@static_ext) {
640 s/\.pm$//; 997 s/\.pm$//;
641 (my $cname = $_) =~ s/\//__/g; 998 (my $cname = $_) =~ s/\//__/g;
… …
655 s/\.pm$//; 1012 s/\.pm$//;
656 1013
657 (my $cname = $_) =~ s/\//__/g; 1014 (my $cname = $_) =~ s/\//__/g;
658 (my $pname = $_) =~ s/\//::/g; 1015 (my $pname = $_) =~ s/\//::/g;
659 1016
660 my $bootstrap = $pname eq "DynaLoader" ? "boot" : "bootstrap"; 1017 my $bootstrap = $pname eq "DynaLoader" ? "boot_DynaLoader" : "bootstrap";
661 1018
662 print $fh " newXS (\"$pname\::$bootstrap\", boot_$cname, file);\n"; 1019 print $fh " newXS (\"$pname\::$bootstrap\", boot_$cname, file);\n";
663} 1020}
664 1021
665print $fh <<EOF; 1022print $fh <<EOF;
1023 #ifdef _WIN32
1024 /* windows perls usually trail behind unix perls 8-10 years in exporting symbols */
1025
1026 if (!PL_preambleav)
1027 PL_preambleav = newAV ();
1028
1029 av_unshift (PL_preambleav, 1);
1030 av_store (PL_preambleav, 0, newSVpv (bootstrap, sizeof (bootstrap) - 1));
1031 #else
666 Perl_av_create_and_unshift_one (&PL_preambleav, newSVpv (bootstrap, sizeof (bootstrap) - 1)); 1032 Perl_av_create_and_unshift_one (&PL_preambleav, newSVpv (bootstrap, sizeof (bootstrap) - 1));
1033 #endif
1034
1035 if (PL_oldname)
1036 ((XSINIT_t)PL_oldname)(aTHX);
667} 1037}
668EOF 1038EOF
669 1039
670############################################################################# 1040#############################################################################
671# optional perl_init/perl_destroy 1041# optional perl_init/perl_destroy
672 1042
1043if ($IGNORE_ENV) {
1044 $IGNORE_ENV = <<EOF;
1045 unsetenv ("PERL_UNICODE");
1046 unsetenv ("PERL_HASH_SEED_DEBUG");
1047 unsetenv ("PERL_DESTRUCT_LEVEL");
1048 unsetenv ("PERL_SIGNALS");
1049 unsetenv ("PERL_DEBUG_MSTATS");
1050 unsetenv ("PERL5OPT");
1051 unsetenv ("PERLIO_DEBUG");
1052 unsetenv ("PERLIO");
1053 unsetenv ("PERL_HASH_SEED");
1054EOF
1055} else {
1056 $IGNORE_ENV = "";
1057}
1058
673if ($APP) { 1059if ($APP) {
1060 print $fh <<EOF;
1061
1062int
1063main (int argc, char *argv [])
1064{
1065 extern char **environ;
1066 int i, exitstatus;
1067 char **args = malloc ((argc + 3) * sizeof (const char *));
1068
1069 args [0] = argv [0];
1070 args [1] = "-e";
1071 args [2] = "0";
1072 args [3] = "--";
1073
1074 for (i = 1; i < argc; ++i)
1075 args [i + 3] = argv [i];
1076
1077$IGNORE_ENV
1078 PERL_SYS_INIT3 (&argc, &argv, &environ);
1079 staticperl = perl_alloc ();
1080 perl_construct (staticperl);
1081
1082 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
1083
1084 exitstatus = perl_parse (staticperl, staticperl_xs_init, argc + 3, args, environ);
1085 free (args);
1086 if (!exitstatus)
1087 perl_run (staticperl);
1088
1089 exitstatus = perl_destruct (staticperl);
1090 perl_free (staticperl);
1091 PERL_SYS_TERM ();
1092
1093 return exitstatus;
1094}
1095EOF
1096} elsif ($PERL) {
674 print $fh <<EOF; 1097 print $fh <<EOF;
675 1098
676int 1099int
677main (int argc, char *argv []) 1100main (int argc, char *argv [])
678{ 1101{
679 extern char **environ; 1102 extern char **environ;
680 int exitstatus; 1103 int exitstatus;
681 1104
1105$IGNORE_ENV
1106 PERL_SYS_INIT3 (&argc, &argv, &environ);
1107 staticperl = perl_alloc ();
1108 perl_construct (staticperl);
1109
1110 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
1111
1112 exitstatus = perl_parse (staticperl, staticperl_xs_init, argc, argv, environ);
1113 if (!exitstatus)
1114 perl_run (staticperl);
1115
1116 exitstatus = perl_destruct (staticperl);
1117 perl_free (staticperl);
1118 PERL_SYS_TERM ();
1119
1120 return exitstatus;
1121}
1122EOF
1123} else {
1124 print $fh <<EOF;
1125
1126EXTERN_C void
1127staticperl_init (XSINIT_t xs_init)
1128{
682 static char *args[] = { 1129 static char *args[] = {
683 "staticperl", 1130 "staticperl",
684 "-e", 1131 "-e",
685 "0" 1132 "0"
686 }; 1133 };
687 1134
688 PERL_SYS_INIT3 (&argc, &argv, &environ);
689 staticperl = perl_alloc ();
690 perl_construct (staticperl);
691
692 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
693
694 exitstatus = perl_parse (staticperl, staticperl_xs_init, sizeof (args) / sizeof (*args), args, environ);
695 if (!exitstatus)
696 perl_run (staticperl);
697
698 exitstatus = perl_destruct (staticperl);
699 perl_free (staticperl);
700 PERL_SYS_TERM ();
701
702 return exitstatus;
703}
704EOF
705} elsif ($PERL) {
706 print $fh <<EOF;
707
708int
709main (int argc, char *argv [])
710{
711 extern char **environ;
712 int exitstatus;
713
714 PERL_SYS_INIT3 (&argc, &argv, &environ);
715 staticperl = perl_alloc ();
716 perl_construct (staticperl);
717
718 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
719
720 exitstatus = perl_parse (staticperl, staticperl_xs_init, argc, argv, environ);
721 if (!exitstatus)
722 perl_run (staticperl);
723
724 exitstatus = perl_destruct (staticperl);
725 perl_free (staticperl);
726 PERL_SYS_TERM ();
727
728 return exitstatus;
729}
730EOF
731} else {
732 print $fh <<EOF;
733
734EXTERN_C void
735staticperl_init (void)
736{
737 extern char **environ; 1135 extern char **environ;
738 int argc = sizeof (args) / sizeof (args [0]); 1136 int argc = sizeof (args) / sizeof (args [0]);
739 char **argv = args; 1137 char **argv = args;
740 1138
741 static char *args[] = { 1139$IGNORE_ENV
742 "staticperl",
743 "-e",
744 "0"
745 };
746
747 PERL_SYS_INIT3 (&argc, &argv, &environ); 1140 PERL_SYS_INIT3 (&argc, &argv, &environ);
748 staticperl = perl_alloc (); 1141 staticperl = perl_alloc ();
749 perl_construct (staticperl); 1142 perl_construct (staticperl);
750 PL_origalen = 1; 1143 PL_origalen = 1;
751 PL_exit_flags |= PERL_EXIT_DESTRUCT_END; 1144 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
1145 PL_oldname = (char *)xs_init;
752 perl_parse (staticperl, staticperl_xs_init, argc, argv, environ); 1146 perl_parse (staticperl, staticperl_xs_init, argc, argv, environ);
753 1147
754 perl_run (staticperl); 1148 perl_run (staticperl);
755} 1149}
756 1150
… …
763 PERL_SYS_TERM (); 1157 PERL_SYS_TERM ();
764} 1158}
765EOF 1159EOF
766} 1160}
767 1161
1162close $fh;
1163
768print -s "$PREFIX.c", " octets (", (length $data) , " data octets).\n\n"; 1164print -s "$PREFIX.c", " octets (", (length $data) , " data octets).\n\n"
1165 if $VERBOSE >= 1;
769 1166
770############################################################################# 1167#############################################################################
771# libs, cflags 1168# libs, cflags
772 1169
1170my $ccopts;
1171
773{ 1172{
774 print "generating $PREFIX.ccopts... "; 1173 print "generating $PREFIX.ccopts... "
1174 if $VERBOSE >= 1;
775 1175
776 my $str = "$Config{ccflags} $Config{optimize} $Config{cppflags} -I$Config{archlibexp}/CORE"; 1176 $ccopts = "$Config{ccflags} $Config{optimize} $Config{cppflags} -I$Config{archlibexp}/CORE";
777 $str =~ s/([\(\)])/\\$1/g; 1177 $ccopts =~ s/([\(\)])/\\$1/g;
778
779 print "$str\n\n";
780 1178
781 open my $fh, ">$PREFIX.ccopts" 1179 open my $fh, ">$PREFIX.ccopts"
782 or die "$PREFIX.ccopts: $!"; 1180 or die "$PREFIX.ccopts: $!";
783 print $fh $str; 1181 print $fh $ccopts;
1182
1183 print "$ccopts\n\n"
1184 if $VERBOSE >= 1;
784} 1185}
1186
1187my $ldopts;
785 1188
786{ 1189{
787 print "generating $PREFIX.ldopts... "; 1190 print "generating $PREFIX.ldopts... ";
788 1191
789 my $str = $STATIC ? "--static " : ""; 1192 $ldopts = $STATIC ? "-static " : "";
790 1193
791 $str .= "$Config{ccdlflags} $Config{ldflags} @libs $Config{archlibexp}/CORE/$Config{libperl} $Config{perllibs}"; 1194 $ldopts .= "$Config{ccdlflags} $Config{ldflags} @libs $Config{archlibexp}/CORE/$Config{libperl} $Config{perllibs}";
792 1195
793 my %seen; 1196 my %seen;
794 $str .= " $_" for grep !$seen{$_}++, ($extralibs =~ /(\S+)/g); 1197 $ldopts .= " $_" for reverse grep !$seen{$_}++, reverse +($extralibs =~ /(\S+)/g);
795 1198
1199 for (@staticlibs) {
1200 $ldopts =~ s/(^|\s) (-l\Q$_\E) ($|\s)/$1-Wl,-Bstatic $2 -Wl,-Bdynamic$3/gx;
1201 }
1202
796 $str =~ s/([\(\)])/\\$1/g; 1203 $ldopts =~ s/([\(\)])/\\$1/g;
797
798 print "$str\n\n";
799 1204
800 open my $fh, ">$PREFIX.ldopts" 1205 open my $fh, ">$PREFIX.ldopts"
801 or die "$PREFIX.ldopts: $!"; 1206 or die "$PREFIX.ldopts: $!";
802 print $fh $str; 1207 print $fh $ldopts;
1208
1209 print "$ldopts\n\n"
1210 if $VERBOSE >= 1;
803} 1211}
804 1212
805if ($PERL or defined $APP) { 1213if ($PERL or defined $APP) {
806 $APP = "perl" unless defined $APP; 1214 $APP = "perl" unless defined $APP;
807 1215
1216 my $build = "$Config{cc} $ccopts -o \Q$APP\E$Config{_exe} bundle.c $ldopts";
1217
808 print "generating $APP...\n"; 1218 print "build $APP...\n"
1219 if $VERBOSE >= 1;
809 1220
810 system "$Config{cc} \$(cat bundle.ccopts\) -o \Q$APP\E bundle.c \$(cat bundle.ldopts\)"; 1221 print "$build\n"
1222 if $VERBOSE >= 2;
1223
1224 system $build;
811 1225
812 unlink "$PREFIX.$_" 1226 unlink "$PREFIX.$_"
813 for qw(ccopts ldopts c h); 1227 for qw(ccopts ldopts c h);
814}
815 1228
1229 print "\n"
1230 if $VERBOSE >= 1;
1231}
1232

Diff Legend

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