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

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

Diff Legend

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