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

Comparing cvsroot/App-Staticperl/mkbundle (file contents):
Revision 1.1 by root, Mon Dec 6 19:33:57 2010 UTC vs.
Revision 1.41 by root, Fri Aug 4 03:14:33 2023 UTC

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

Diff Legend

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

Comparing cvsroot/App-Staticperl/mkbundle (file contents): Revision 1.1 by root, Mon Dec 6 19:33:57 2010 UTC vs. Revision 1.41 by root, Fri Aug 4 03:14:33 2023 UTC

Diff Legend

Comparing cvsroot/App-Staticperl/mkbundle (file contents):
Revision 1.1 by root, Mon Dec 6 19:33:57 2010 UTC vs.
Revision 1.41 by root, Fri Aug 4 03:14:33 2023 UTC