[ViewVC] Diff of: cvs/App-Staticperl/mkbundle

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

Diff Legend

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

Comparing App-Staticperl/mkbundle (file contents): Revision 1.4 by root, Mon Dec 6 21:10:41 2010 UTC vs. Revision 1.47 by root, Thu Aug 24 11:01:37 2023 UTC

Diff Legend

Comparing App-Staticperl/mkbundle (file contents):
Revision 1.4 by root, Mon Dec 6 21:10:41 2010 UTC vs.
Revision 1.47 by root, Thu Aug 24 11:01:37 2023 UTC