Commit | Line | Data |
---|---|---|
52cebf5e EP |
1 | #!/usr/local/bin/perl |
2 | ||
3 | use Config; | |
4 | use File::Basename qw(&basename &dirname); | |
de0d1968 | 5 | use File::Spec; |
8a5546a1 | 6 | use Cwd; |
52cebf5e EP |
7 | |
8 | # List explicitly here the variables you want Configure to | |
9 | # generate. Metaconfig only looks for shell variables, so you | |
10 | # have to mention them as if they were shell variables, not | |
11 | # %Config entries. Thus you write | |
12 | # $startperl | |
13 | # to ensure Configure will look for $Config{startperl}. | |
14 | # Wanted: $archlibexp | |
15 | ||
16 | # This forces PL files to create target in same directory as PL file. | |
17 | # This is so that make depend always knows where to find PL derivatives. | |
8a5546a1 | 18 | $origdir = cwd; |
52cebf5e EP |
19 | chdir dirname($0); |
20 | $file = basename($0, '.PL'); | |
21 | $file .= '.com' if $^O eq 'VMS'; | |
22 | ||
23 | open OUT,">$file" or die "Can't create $file: $!"; | |
24 | ||
25 | print "Extracting $file (with variable substitutions)\n"; | |
26 | ||
27 | # In this section, perl variables will be expanded during extraction. | |
28 | # You can use $Config{...} to use Configure variables. | |
29 | ||
30 | print OUT <<"!GROK!THIS!"; | |
31 | $Config{startperl} | |
32 | eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' | |
33 | if \$running_under_some_shell; | |
ecde9bf0 | 34 | --\$running_under_some_shell; |
52cebf5e EP |
35 | !GROK!THIS! |
36 | ||
37 | # In the following, perl variables are not expanded during extraction. | |
38 | ||
39 | print OUT <<'!NO!SUBS!'; | |
40 | ||
ecde9bf0 SC |
41 | # Version 2.0, Simon Cozens, Thu Mar 30 17:52:45 JST 2000 |
42 | # Version 2.01, Tom Christiansen, Thu Mar 30 08:25:14 MST 2000 | |
43 | # Version 2.02, Simon Cozens, Sun Apr 16 01:53:36 JST 2000 | |
e4f0d88d | 44 | # Version 2.03, Edward Peschko, Mon Feb 26 12:04:17 PST 2001 |
ecde9bf0 | 45 | |
52cebf5e | 46 | use strict; |
ecde9bf0 | 47 | use warnings; |
33024943 | 48 | use 5.006_000; |
52cebf5e | 49 | |
e4f0d88d | 50 | use FileHandle; |
ecde9bf0 SC |
51 | use Config; |
52 | use Fcntl qw(:DEFAULT :flock); | |
53 | use File::Temp qw(tempfile); | |
54 | use Cwd; | |
e4f0d88d | 55 | our $VERSION = 2.03; |
ecde9bf0 | 56 | $| = 1; |
52cebf5e | 57 | |
e4f0d88d EP |
58 | $SIG{INT} = sub { exit(); }; # exit gracefully and clean up after ourselves. |
59 | ||
ecde9bf0 SC |
60 | use subs qw{ |
61 | cc_harness check_read check_write checkopts_byte choose_backend | |
62 | compile_byte compile_cstyle compile_module generate_code | |
63 | grab_stash parse_argv sanity_check vprint yclept spawnit | |
64 | }; | |
65 | sub opt(*); # imal quoting | |
b326da91 MB |
66 | sub is_win32(); |
67 | sub is_msvc(); | |
52cebf5e | 68 | |
ecde9bf0 SC |
69 | our ($Options, $BinPerl, $Backend); |
70 | our ($Input => $Output); | |
e4f0d88d EP |
71 | our ($logfh); |
72 | our ($cfile); | |
b326da91 | 73 | our (@begin_output); # output from BEGIN {}, for testsuite |
ef712cf7 | 74 | |
ecde9bf0 | 75 | # eval { main(); 1 } or die; |
52cebf5e EP |
76 | |
77 | main(); | |
78 | ||
e4f0d88d | 79 | sub main { |
ecde9bf0 SC |
80 | parse_argv(); |
81 | check_write($Output); | |
82 | choose_backend(); | |
83 | generate_code(); | |
e4f0d88d EP |
84 | run_code(); |
85 | _die("XXX: Not reached?"); | |
52cebf5e | 86 | } |
9636a016 | 87 | |
ecde9bf0 | 88 | ####################################################################### |
52cebf5e | 89 | |
ecde9bf0 SC |
90 | sub choose_backend { |
91 | # Choose the backend. | |
92 | $Backend = 'C'; | |
93 | if (opt(B)) { | |
94 | checkopts_byte(); | |
95 | $Backend = 'Bytecode'; | |
52cebf5e | 96 | } |
ecde9bf0 SC |
97 | if (opt(S) && opt(c)) { |
98 | # die "$0: Do you want me to compile this or not?\n"; | |
99 | delete $Options->{S}; | |
52cebf5e | 100 | } |
ecde9bf0 | 101 | $Backend = 'CC' if opt(O); |
52cebf5e EP |
102 | } |
103 | ||
52cebf5e | 104 | |
ecde9bf0 | 105 | sub generate_code { |
a07043ec | 106 | |
ecde9bf0 | 107 | vprint 0, "Compiling $Input"; |
9636a016 | 108 | |
ecde9bf0 | 109 | $BinPerl = yclept(); # Calling convention for perl. |
52cebf5e | 110 | |
ecde9bf0 SC |
111 | if (opt(shared)) { |
112 | compile_module(); | |
113 | } else { | |
114 | if ($Backend eq 'Bytecode') { | |
115 | compile_byte(); | |
116 | } else { | |
117 | compile_cstyle(); | |
118 | } | |
52cebf5e | 119 | } |
e4f0d88d EP |
120 | exit(0) if (!opt('r')); |
121 | } | |
52cebf5e | 122 | |
e4f0d88d EP |
123 | sub run_code { |
124 | vprint 0, "Running code"; | |
125 | run("$Output @ARGV"); | |
126 | exit(0); | |
52cebf5e EP |
127 | } |
128 | ||
ecde9bf0 SC |
129 | # usage: vprint [level] msg args |
130 | sub vprint { | |
131 | my $level; | |
132 | if (@_ == 1) { | |
133 | $level = 1; | |
134 | } elsif ($_[0] =~ /^\d$/) { | |
135 | $level = shift; | |
136 | } else { | |
137 | # well, they forgot to use a number; means >0 | |
138 | $level = 0; | |
139 | } | |
140 | my $msg = "@_"; | |
141 | $msg .= "\n" unless substr($msg, -1) eq "\n"; | |
e4f0d88d EP |
142 | if (opt(v) > $level) |
143 | { | |
144 | print "$0: $msg" if !opt('log'); | |
145 | print $logfh "$0: $msg" if opt('log'); | |
146 | } | |
147 | } | |
ecde9bf0 SC |
148 | |
149 | sub parse_argv { | |
150 | ||
151 | use Getopt::Long; | |
f5eac215 JH |
152 | |
153 | # disallows using long arguments | |
154 | # Getopt::Long::Configure("bundling"); | |
155 | ||
ecde9bf0 SC |
156 | Getopt::Long::Configure("no_ignore_case"); |
157 | ||
158 | # no difference in exists and defined for %ENV; also, a "0" | |
159 | # argument or a "" would not help cc, so skip | |
160 | unshift @ARGV, split ' ', $ENV{PERLCC_OPTS} if $ENV{PERLCC_OPTS}; | |
161 | ||
162 | $Options = {}; | |
163 | Getopt::Long::GetOptions( $Options, | |
164 | 'L:s', # lib directory | |
165 | 'I:s', # include directories (FOR C, NOT FOR PERL) | |
166 | 'o:s', # Output executable | |
b326da91 | 167 | 'v:i', # Verbosity level |
ecde9bf0 | 168 | 'e:s', # One-liner |
e4f0d88d | 169 | 'r', # run resulting executable |
ecde9bf0 SC |
170 | 'B', # Byte compiler backend |
171 | 'O', # Optimised C backend | |
172 | 'c', # Compile only | |
173 | 'h', # Help me | |
174 | 'S', # Dump C files | |
e4f0d88d | 175 | 'r', # run the resulting executable |
b326da91 MB |
176 | 'T', # run the backend using perl -T |
177 | 't', # run the backend using perl -t | |
e4f0d88d | 178 | 'static', # Dirty hack to enable -shared/-static |
ecde9bf0 | 179 | 'shared', # Create a shared library (--shared for compat.) |
b326da91 | 180 | 'log:s', # where to log compilation process information |
9d2bbe64 | 181 | 'Wb:s', # pass (comma-sepearated) options to backend |
b326da91 | 182 | 'testsuite', # try to be nice to testsuite |
ecde9bf0 | 183 | ); |
b326da91 | 184 | |
ecde9bf0 | 185 | $Options->{v} += 0; |
52cebf5e | 186 | |
b326da91 MB |
187 | if( opt(t) && opt(T) ) { |
188 | warn "Can't specify both -T and -t, -t ignored"; | |
189 | $Options->{t} = 0; | |
190 | } | |
191 | ||
ecde9bf0 | 192 | helpme() if opt(h); # And exit |
ef712cf7 | 193 | |
b326da91 MB |
194 | $Output = opt(o) || ( is_win32 ? 'a.exe' : 'a.out' ); |
195 | $Output = is_win32() ? $Output : relativize($Output); | |
e4f0d88d | 196 | $logfh = new FileHandle(">> " . opt('log')) if (opt('log')); |
ef712cf7 | 197 | |
ecde9bf0 SC |
198 | if (opt(e)) { |
199 | warn "$0: using -e 'code' as input file, ignoring @ARGV\n" if @ARGV; | |
200 | # We don't use a temporary file here; why bother? | |
201 | # XXX: this is not bullet proof -- spaces or quotes in name! | |
b326da91 MB |
202 | $Input = is_win32() ? # Quotes eaten by shell |
203 | '-e "'.opt(e).'"' : | |
204 | "-e '".opt(e)."'"; | |
ecde9bf0 SC |
205 | } else { |
206 | $Input = shift @ARGV; # XXX: more files? | |
e4f0d88d | 207 | _usage_and_die("$0: No input file specified\n") unless $Input; |
ecde9bf0 SC |
208 | # DWIM modules. This is bad but necessary. |
209 | $Options->{shared}++ if $Input =~ /\.pm\z/; | |
210 | warn "$0: using $Input as input file, ignoring @ARGV\n" if @ARGV; | |
211 | check_read($Input); | |
212 | check_perl($Input); | |
213 | sanity_check(); | |
52cebf5e EP |
214 | } |
215 | ||
ecde9bf0 | 216 | } |
5268c7a4 | 217 | |
ecde9bf0 SC |
218 | sub opt(*) { |
219 | my $opt = shift; | |
220 | return exists($Options->{$opt}) && ($Options->{$opt} || 0); | |
221 | } | |
52cebf5e | 222 | |
ecde9bf0 SC |
223 | sub compile_module { |
224 | die "$0: Compiling to shared libraries is currently disabled\n"; | |
52cebf5e EP |
225 | } |
226 | ||
ecde9bf0 SC |
227 | sub compile_byte { |
228 | require ByteLoader; | |
229 | my $stash = grab_stash(); | |
230 | my $command = "$BinPerl -MO=Bytecode,$stash $Input"; | |
231 | # The -a option means we'd have to close the file and lose the | |
232 | # lock, which would create the tiniest of races. Instead, append | |
233 | # the output ourselves. | |
234 | vprint 1, "Writing on $Output"; | |
52cebf5e | 235 | |
ecde9bf0 SC |
236 | my $openflags = O_WRONLY | O_CREAT; |
237 | $openflags |= O_BINARY if eval { O_BINARY; 1 }; | |
238 | $openflags |= O_EXLOCK if eval { O_EXLOCK; 1 }; | |
ef712cf7 | 239 | |
ecde9bf0 | 240 | # these dies are not "$0: .... \n" because they "can't happen" |
ef712cf7 | 241 | |
ecde9bf0 SC |
242 | sysopen(OUT, $Output, $openflags) |
243 | or die "can't write to $Output: $!"; | |
52cebf5e | 244 | |
ecde9bf0 SC |
245 | # this is blocking; hold on; why are we doing this?? |
246 | # flock OUT, LOCK_EX or die "can't lock $Output: $!" | |
247 | # unless eval { O_EXLOCK; 1 }; | |
52cebf5e | 248 | |
ecde9bf0 SC |
249 | truncate(OUT, 0) |
250 | or die "couldn't trunc $Output: $!"; | |
52cebf5e | 251 | |
ecde9bf0 SC |
252 | print OUT <<EOF; |
253 | #!$^X | |
254 | use ByteLoader $ByteLoader::VERSION; | |
52cebf5e EP |
255 | EOF |
256 | ||
ecde9bf0 SC |
257 | # Now the compile: |
258 | vprint 1, "Compiling..."; | |
259 | vprint 3, "Calling $command"; | |
52cebf5e | 260 | |
d873810b | 261 | my ($output_r, $error_r) = spawnit($command); |
52cebf5e | 262 | |
d873810b | 263 | if (@$error_r && $? != 0) { |
e4f0d88d | 264 | _die("$0: $Input did not compile, which can't happen:\n@$error_r\n"); |
d873810b NC |
265 | } else { |
266 | my @error = grep { !/^$Input syntax OK$/o } @$error_r; | |
267 | warn "$0: Unexpected compiler output:\n@error" if @error; | |
ef712cf7 | 268 | } |
b326da91 | 269 | |
ecde9bf0 | 270 | # Write it and leave. |
e4f0d88d EP |
271 | print OUT @$output_r or _die("can't write $Output: $!"); |
272 | close OUT or _die("can't close $Output: $!"); | |
52cebf5e | 273 | |
ecde9bf0 | 274 | # wait, how could it be anything but what you see next? |
e4f0d88d | 275 | chmod 0777 & ~umask, $Output or _die("can't chmod $Output: $!"); |
ecde9bf0 | 276 | exit 0; |
52cebf5e | 277 | } |
52cebf5e | 278 | |
ecde9bf0 SC |
279 | sub compile_cstyle { |
280 | my $stash = grab_stash(); | |
b326da91 MB |
281 | my $taint = opt(T) ? '-T' : |
282 | opt(t) ? '-t' : ''; | |
283 | ||
ecde9bf0 | 284 | # What are we going to call our output C file? |
ecde9bf0 | 285 | my $lose = 0; |
e4f0d88d | 286 | my ($cfh); |
b326da91 | 287 | my $testsuite = ''; |
9d2bbe64 MB |
288 | my $addoptions = opt(Wb); |
289 | ||
290 | if( $addoptions ) { | |
291 | $addoptions .= ',' if $addoptions !~ m/,$/; | |
292 | } | |
b326da91 MB |
293 | |
294 | if (opt(testsuite)) { | |
295 | my $bo = join '', @begin_output; | |
296 | $bo =~ s/\\/\\\\\\\\/gs; | |
297 | $bo =~ s/\n/\\n/gs; | |
298 | $bo =~ s/,/\\054/gs; | |
299 | # don't look at that: it hurts | |
300 | $testsuite = q{-fuse-script-name,-fsave-data,-fsave-sig-hash,}. | |
301 | qq[-e"print q{$bo}",] . | |
302 | q{-e"open(Test::Builder::TESTOUT\054 '>&STDOUT') or die $!",} . | |
303 | q{-e"open(Test::Builder::TESTERR\054 '>&STDERR') or die $!",}; | |
304 | } | |
ecde9bf0 SC |
305 | if (opt(S) || opt(c)) { |
306 | # We need to keep it. | |
307 | if (opt(e)) { | |
308 | $cfile = "a.out.c"; | |
309 | } else { | |
310 | $cfile = $Input; | |
311 | # File off extension if present | |
312 | # hold on: plx is executable; also, careful of ordering! | |
313 | $cfile =~ s/\.(?:p(?:lx|l|h)|m)\z//i; | |
314 | $cfile .= ".c"; | |
315 | $cfile = $Output if opt(c) && $Output =~ /\.c\z/i; | |
316 | } | |
317 | check_write($cfile); | |
318 | } else { | |
319 | # Don't need to keep it, be safe with a tempfile. | |
320 | $lose = 1; | |
321 | ($cfh, $cfile) = tempfile("pccXXXXX", SUFFIX => ".c"); | |
322 | close $cfh; # See comment just below | |
52cebf5e | 323 | } |
ecde9bf0 | 324 | vprint 1, "Writing C on $cfile"; |
52cebf5e | 325 | |
ecde9bf0 SC |
326 | my $max_line_len = ''; |
327 | if ($^O eq 'MSWin32' && $Config{cc} =~ /^cl/i) { | |
328 | $max_line_len = '-l2000,'; | |
329 | } | |
52cebf5e | 330 | |
ecde9bf0 SC |
331 | # This has to do the write itself, so we can't keep a lock. Life |
332 | # sucks. | |
9d2bbe64 | 333 | my $command = "$BinPerl $taint -MO=$Backend,$addoptions$testsuite$max_line_len$stash,-o$cfile $Input"; |
ecde9bf0 SC |
334 | vprint 1, "Compiling..."; |
335 | vprint 1, "Calling $command"; | |
52cebf5e | 336 | |
ecde9bf0 SC |
337 | my ($output_r, $error_r) = spawnit($command); |
338 | my @output = @$output_r; | |
339 | my @error = @$error_r; | |
52cebf5e | 340 | |
ecde9bf0 | 341 | if (@error && $? != 0) { |
e4f0d88d | 342 | _die("$0: $Input did not compile, which can't happen:\n@error\n"); |
ecde9bf0 | 343 | } |
52cebf5e | 344 | |
b326da91 MB |
345 | is_msvc ? |
346 | cc_harness_msvc($cfile,$stash) : | |
347 | cc_harness($cfile,$stash) unless opt(c); | |
52cebf5e | 348 | |
ecde9bf0 SC |
349 | if ($lose) { |
350 | vprint 2, "unlinking $cfile"; | |
e4f0d88d | 351 | unlink $cfile or _die("can't unlink $cfile: $!"); |
ecde9bf0 | 352 | } |
52cebf5e EP |
353 | } |
354 | ||
b326da91 MB |
355 | sub cc_harness_msvc { |
356 | my ($cfile,$stash)=@_; | |
357 | use ExtUtils::Embed (); | |
358 | my $obj = "${Output}.obj"; | |
359 | my $compile = ExtUtils::Embed::ccopts." -c -Fo$obj $cfile "; | |
360 | my $link = "-out:$Output $obj"; | |
361 | $compile .= " -I".$_ for split /\s+/, opt(I); | |
362 | $link .= " -libpath:".$_ for split /\s+/, opt(L); | |
363 | my @mods = split /-?u /, $stash; | |
364 | $link .= " ".ExtUtils::Embed::ldopts("-std", \@mods); | |
9d2bbe64 | 365 | $link .= " perl57.lib kernel32.lib msvcrt.lib"; |
b326da91 MB |
366 | vprint 3, "running $Config{cc} $compile"; |
367 | system("$Config{cc} $compile"); | |
368 | vprint 3, "running $Config{ld} $link"; | |
369 | system("$Config{ld} $link"); | |
370 | } | |
371 | ||
ecde9bf0 SC |
372 | sub cc_harness { |
373 | my ($cfile,$stash)=@_; | |
374 | use ExtUtils::Embed (); | |
375 | my $command = ExtUtils::Embed::ccopts." -o $Output $cfile "; | |
3af308c7 SC |
376 | $command .= " -I".$_ for split /\s+/, opt(I); |
377 | $command .= " -L".$_ for split /\s+/, opt(L); | |
ecde9bf0 | 378 | my @mods = split /-?u /, $stash; |
3af308c7 | 379 | $command .= " ".ExtUtils::Embed::ldopts("-std", \@mods); |
f5eac215 | 380 | $command .= " -lperl"; |
e4f0d88d EP |
381 | vprint 3, "running $Config{cc} $command"; |
382 | system("$Config{cc} $command"); | |
52cebf5e EP |
383 | } |
384 | ||
ecde9bf0 SC |
385 | # Where Perl is, and which include path to give it. |
386 | sub yclept { | |
387 | my $command = "$^X "; | |
388 | ||
389 | # DWIM the -I to be Perl, not C, include directories. | |
390 | if (opt(I) && $Backend eq "Bytecode") { | |
391 | for (split /\s+/, opt(I)) { | |
392 | if (-d $_) { | |
393 | push @INC, $_; | |
394 | } else { | |
395 | warn "$0: Include directory $_ not found, skipping\n"; | |
396 | } | |
52cebf5e EP |
397 | } |
398 | } | |
ecde9bf0 SC |
399 | |
400 | $command .= "-I$_ " for @INC; | |
401 | return $command; | |
52cebf5e EP |
402 | } |
403 | ||
ecde9bf0 | 404 | # Use B::Stash to find additional modules and stuff. |
52cebf5e | 405 | { |
ecde9bf0 SC |
406 | my $_stash; |
407 | sub grab_stash { | |
52cebf5e | 408 | |
ecde9bf0 | 409 | warn "already called get_stash once" if $_stash; |
52cebf5e | 410 | |
b326da91 MB |
411 | my $taint = opt(T) ? '-T' : |
412 | opt(t) ? '-t' : ''; | |
413 | my $command = "$BinPerl $taint -MB::Stash -c $Input"; | |
ecde9bf0 SC |
414 | # Filename here is perfectly sanitised. |
415 | vprint 3, "Calling $command\n"; | |
9636a016 | 416 | |
ecde9bf0 SC |
417 | my ($stash_r, $error_r) = spawnit($command); |
418 | my @stash = @$stash_r; | |
419 | my @error = @$error_r; | |
52cebf5e | 420 | |
ecde9bf0 | 421 | if (@error && $? != 0) { |
e4f0d88d | 422 | _die("$0: $Input did not compile:\n@error\n"); |
ecde9bf0 | 423 | } |
52cebf5e | 424 | |
b326da91 MB |
425 | # band-aid for modules with noisy BEGIN {} |
426 | foreach my $i ( @stash ) { | |
427 | $i =~ m/-u(?:[\w:]+|\<none\>)$/ and $stash[0] = $i and next; | |
428 | push @begin_output, $i; | |
429 | } | |
430 | chomp $stash[0]; | |
ecde9bf0 | 431 | $stash[0] =~ s/,-u\<none\>//; |
b326da91 | 432 | $stash[0] =~ s/^.*?-u/-u/s; |
ecde9bf0 SC |
433 | vprint 2, "Stash: ", join " ", split /,?-u/, $stash[0]; |
434 | chomp $stash[0]; | |
435 | return $_stash = $stash[0]; | |
52cebf5e EP |
436 | } |
437 | ||
ecde9bf0 | 438 | } |
52cebf5e | 439 | |
ecde9bf0 SC |
440 | # Check the consistency of options if -B is selected. |
441 | # To wit, (-B|-O) ==> no -shared, no -S, no -c | |
442 | sub checkopts_byte { | |
52cebf5e | 443 | |
e4f0d88d | 444 | _die("$0: Please choose one of either -B and -O.\n") if opt(O); |
52cebf5e | 445 | |
ecde9bf0 SC |
446 | if (opt(shared)) { |
447 | warn "$0: Will not create a shared library for bytecode\n"; | |
448 | delete $Options->{shared}; | |
449 | } | |
52cebf5e | 450 | |
ecde9bf0 SC |
451 | for my $o ( qw[c S] ) { |
452 | if (opt($o)) { | |
453 | warn "$0: Compiling to bytecode is a one-pass process--", | |
454 | "-$o ignored\n"; | |
455 | delete $Options->{$o}; | |
456 | } | |
52cebf5e EP |
457 | } |
458 | ||
52cebf5e EP |
459 | } |
460 | ||
ecde9bf0 SC |
461 | # Check the input and output files make sense, are read/writeable. |
462 | sub sanity_check { | |
463 | if ($Input eq $Output) { | |
464 | if ($Input eq 'a.out') { | |
e4f0d88d EP |
465 | _die("$0: Compiling a.out is probably not what you want to do.\n"); |
466 | # You fully deserve what you get now. No you *don't*. typos happen. | |
ecde9bf0 SC |
467 | } else { |
468 | warn "$0: Will not write output on top of input file, ", | |
469 | "compiling to a.out instead\n"; | |
470 | $Output = "a.out"; | |
471 | } | |
52cebf5e EP |
472 | } |
473 | } | |
474 | ||
ecde9bf0 SC |
475 | sub check_read { |
476 | my $file = shift; | |
477 | unless (-r $file) { | |
e4f0d88d | 478 | _die("$0: Input file $file is a directory, not a file\n") if -d _; |
ecde9bf0 | 479 | unless (-e _) { |
e4f0d88d | 480 | _die("$0: Input file $file was not found\n"); |
ecde9bf0 | 481 | } else { |
e4f0d88d | 482 | _die("$0: Cannot read input file $file: $!\n"); |
ecde9bf0 | 483 | } |
52cebf5e | 484 | } |
ecde9bf0 SC |
485 | unless (-f _) { |
486 | # XXX: die? don't try this on /dev/tty | |
487 | warn "$0: WARNING: input $file is not a plain file\n"; | |
488 | } | |
52cebf5e EP |
489 | } |
490 | ||
ecde9bf0 SC |
491 | sub check_write { |
492 | my $file = shift; | |
493 | if (-d $file) { | |
e4f0d88d | 494 | _die("$0: Cannot write on $file, is a directory\n"); |
ecde9bf0 SC |
495 | } |
496 | if (-e _) { | |
e4f0d88d | 497 | _die("$0: Cannot write on $file: $!\n") unless -w _; |
ecde9bf0 SC |
498 | } |
499 | unless (-w cwd()) { | |
e4f0d88d | 500 | _die("$0: Cannot write in this directory: $!\n"); |
ef712cf7 | 501 | } |
ef712cf7 EP |
502 | } |
503 | ||
ecde9bf0 SC |
504 | sub check_perl { |
505 | my $file = shift; | |
506 | unless (-T $file) { | |
507 | warn "$0: Binary `$file' sure doesn't smell like perl source!\n"; | |
508 | print "Checking file type... "; | |
509 | system("file", $file); | |
e4f0d88d | 510 | _die("Please try a perlier file!\n"); |
ecde9bf0 SC |
511 | } |
512 | ||
e4f0d88d | 513 | open(my $handle, "<", $file) or _die("XXX: can't open $file: $!"); |
ecde9bf0 SC |
514 | local $_ = <$handle>; |
515 | if (/^#!/ && !/perl/) { | |
e4f0d88d | 516 | _die("$0: $file is a ", /^#!\s*(\S+)/, " script, not perl\n"); |
ecde9bf0 SC |
517 | } |
518 | ||
519 | } | |
520 | ||
521 | # File spawning and error collecting | |
522 | sub spawnit { | |
523 | my ($command) = shift; | |
524 | my (@error,@output); | |
525 | my $errname; | |
526 | (undef, $errname) = tempfile("pccXXXXX"); | |
527 | { | |
528 | open (S_OUT, "$command 2>$errname |") | |
e4f0d88d | 529 | or _die("$0: Couldn't spawn the compiler.\n"); |
ecde9bf0 SC |
530 | @output = <S_OUT>; |
531 | } | |
e4f0d88d | 532 | open (S_ERROR, $errname) or _die("$0: Couldn't read the error file.\n"); |
ecde9bf0 SC |
533 | @error = <S_ERROR>; |
534 | close S_ERROR; | |
535 | close S_OUT; | |
e4f0d88d | 536 | unlink $errname or _die("$0: Can't unlink error file $errname"); |
ecde9bf0 SC |
537 | return (\@output, \@error); |
538 | } | |
52cebf5e | 539 | |
ecde9bf0 SC |
540 | sub helpme { |
541 | print "perlcc compiler frontend, version $VERSION\n\n"; | |
542 | { no warnings; | |
543 | exec "pod2usage $0"; | |
544 | exec "perldoc $0"; | |
545 | exec "pod2text $0"; | |
546 | } | |
52cebf5e EP |
547 | } |
548 | ||
e4f0d88d EP |
549 | sub relativize { |
550 | my ($args) = @_; | |
551 | ||
552 | return() if ($args =~ m"^[/\\]"); | |
553 | return("./$args"); | |
554 | } | |
555 | ||
556 | sub _die { | |
557 | $logfh->print(@_) if opt('log'); | |
558 | print STDERR @_; | |
559 | exit(); # should die eventually. However, needed so that a 'make compile' | |
560 | # can compile all the way through to the end for standard dist. | |
561 | } | |
562 | ||
563 | sub _usage_and_die { | |
564 | _die(<<EOU); | |
565 | $0: Usage: | |
566 | $0 [-o executable] [-r] [-O|-B|-c|-S] [-log log] [source[.pl] | -e oneliner] | |
567 | EOU | |
568 | } | |
569 | ||
570 | sub run { | |
571 | my (@commands) = @_; | |
572 | ||
573 | print interruptrun(@commands) if (!opt('log')); | |
574 | $logfh->print(interruptrun(@commands)) if (opt('log')); | |
575 | } | |
576 | ||
577 | sub interruptrun | |
578 | { | |
579 | my (@commands) = @_; | |
580 | ||
581 | my $command = join('', @commands); | |
582 | local(*FD); | |
583 | my $pid = open(FD, "$command |"); | |
584 | my $text; | |
585 | ||
586 | local($SIG{HUP}) = sub { kill 9, $pid; exit }; | |
587 | local($SIG{INT}) = sub { kill 9, $pid; exit }; | |
588 | ||
589 | my $needalarm = | |
590 | ($ENV{PERLCC_TIMEOUT} && | |
591 | $Config{'osname'} ne 'MSWin32' && | |
592 | $command =~ m"(^|\s)perlcc\s"); | |
593 | ||
594 | eval | |
595 | { | |
596 | local($SIG{ALRM}) = sub { die "INFINITE LOOP"; }; | |
597 | alarm($ENV{PERLCC_TIMEOUT}) if ($needalarm); | |
598 | $text = join('', <FD>); | |
599 | alarm(0) if ($needalarm); | |
600 | }; | |
601 | ||
602 | if ($@) | |
603 | { | |
604 | eval { kill 'HUP', $pid }; | |
605 | vprint 0, "SYSTEM TIMEOUT (infinite loop?)\n"; | |
606 | } | |
607 | ||
608 | close(FD); | |
609 | return($text); | |
610 | } | |
611 | ||
b326da91 MB |
612 | sub is_win32() { $^O =~ m/^MSWin/ } |
613 | sub is_msvc() { is_win32 && $Config{cc} =~ m/^cl/i } | |
614 | ||
e4f0d88d EP |
615 | END { |
616 | unlink $cfile if ($cfile && !opt(S) && !opt(c)); | |
617 | } | |
52cebf5e EP |
618 | |
619 | __END__ | |
620 | ||
621 | =head1 NAME | |
622 | ||
ecde9bf0 | 623 | perlcc - generate executables from Perl programs |
52cebf5e EP |
624 | |
625 | =head1 SYNOPSIS | |
626 | ||
ecde9bf0 SC |
627 | $ perlcc hello # Compiles into executable 'a.out' |
628 | $ perlcc -o hello hello.pl # Compiles into executable 'hello' | |
52cebf5e | 629 | |
ecde9bf0 SC |
630 | $ perlcc -O file # Compiles using the optimised C backend |
631 | $ perlcc -B file # Compiles using the bytecode backend | |
52cebf5e | 632 | |
ecde9bf0 SC |
633 | $ perlcc -c file # Creates a C file, 'file.c' |
634 | $ perlcc -S -o hello file # Creates a C file, 'file.c', | |
635 | # then compiles it to executable 'hello' | |
636 | $ perlcc -c out.c file # Creates a C file, 'out.c' from 'file' | |
52cebf5e | 637 | |
ecde9bf0 SC |
638 | $ perlcc -e 'print q//' # Compiles a one-liner into 'a.out' |
639 | $ perlcc -c -e 'print q//' # Creates a C file 'a.out.c' | |
e4f0d88d | 640 | |
f5eac215 JH |
641 | $ perlcc -I /foo hello # extra headers (notice the space after -I) |
642 | $ perlcc -L /foo hello # extra libraries (notice the space after -L) | |
e4f0d88d | 643 | |
f5eac215 | 644 | $ perlcc -r hello # compiles 'hello' into 'a.out', runs 'a.out'. |
e4f0d88d EP |
645 | $ perlcc -r hello a b c # compiles 'hello' into 'a.out', runs 'a.out'. |
646 | # with arguments 'a b c' | |
647 | ||
648 | $ perlcc hello -log c # compiles 'hello' into 'a.out' logs compile | |
649 | # log into 'c'. | |
650 | ||
52cebf5e EP |
651 | =head1 DESCRIPTION |
652 | ||
ecde9bf0 SC |
653 | F<perlcc> creates standalone executables from Perl programs, using the |
654 | code generators provided by the L<B> module. At present, you may | |
655 | either create executable Perl bytecode, using the C<-B> option, or | |
656 | generate and compile C files using the standard and 'optimised' C | |
657 | backends. | |
52cebf5e | 658 | |
ecde9bf0 SC |
659 | The code generated in this way is not guaranteed to work. The whole |
660 | codegen suite (C<perlcc> included) should be considered B<very> | |
661 | experimental. Use for production purposes is strongly discouraged. | |
52cebf5e | 662 | |
ecde9bf0 | 663 | =head1 OPTIONS |
52cebf5e EP |
664 | |
665 | =over 4 | |
666 | ||
ecde9bf0 | 667 | =item -LI<library directories> |
52cebf5e | 668 | |
ecde9bf0 SC |
669 | Adds the given directories to the library search path when C code is |
670 | passed to your C compiler. | |
52cebf5e | 671 | |
ecde9bf0 | 672 | =item -II<include directories> |
52cebf5e | 673 | |
ecde9bf0 SC |
674 | Adds the given directories to the include file search path when C code is |
675 | passed to your C compiler; when using the Perl bytecode option, adds the | |
676 | given directories to Perl's include path. | |
9636a016 | 677 | |
ecde9bf0 | 678 | =item -o I<output file name> |
9636a016 | 679 | |
ecde9bf0 | 680 | Specifies the file name for the final compiled executable. |
9636a016 | 681 | |
ecde9bf0 | 682 | =item -c I<C file name> |
9636a016 | 683 | |
ecde9bf0 | 684 | Create C code only; do not compile to a standalone binary. |
52cebf5e | 685 | |
ecde9bf0 | 686 | =item -e I<perl code> |
52cebf5e | 687 | |
ecde9bf0 | 688 | Compile a one-liner, much the same as C<perl -e '...'> |
52cebf5e | 689 | |
ecde9bf0 | 690 | =item -S |
52cebf5e | 691 | |
ecde9bf0 | 692 | Do not delete generated C code after compilation. |
52cebf5e | 693 | |
ecde9bf0 | 694 | =item -B |
52cebf5e | 695 | |
ecde9bf0 | 696 | Use the Perl bytecode code generator. |
52cebf5e | 697 | |
ecde9bf0 | 698 | =item -O |
52cebf5e | 699 | |
ecde9bf0 SC |
700 | Use the 'optimised' C code generator. This is more experimental than |
701 | everything else put together, and the code created is not guaranteed to | |
702 | compile in finite time and memory, or indeed, at all. | |
52cebf5e | 703 | |
ecde9bf0 | 704 | =item -v |
52cebf5e | 705 | |
ecde9bf0 | 706 | Increase verbosity of output; can be repeated for more verbose output. |
52cebf5e | 707 | |
e4f0d88d EP |
708 | =item -r |
709 | ||
710 | Run the resulting compiled script after compiling it. | |
711 | ||
712 | =item -log | |
713 | ||
714 | Log the output of compiling to a file rather than to stdout. | |
715 | ||
52cebf5e EP |
716 | =back |
717 | ||
52cebf5e EP |
718 | =cut |
719 | ||
720 | !NO!SUBS! | |
721 | ||
722 | close OUT or die "Can't close $file: $!"; | |
723 | chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; | |
724 | exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; | |
8a5546a1 | 725 | chdir $origdir; |