| 1 | #!/usr/local/bin/perl |
| 2 | |
| 3 | use Config; |
| 4 | use File::Basename qw(&basename &dirname); |
| 5 | use File::Spec; |
| 6 | use Cwd; |
| 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. |
| 18 | $origdir = cwd; |
| 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; |
| 34 | --\$running_under_some_shell; |
| 35 | !GROK!THIS! |
| 36 | |
| 37 | # In the following, perl variables are not expanded during extraction. |
| 38 | |
| 39 | print OUT <<'!NO!SUBS!'; |
| 40 | |
| 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 |
| 44 | # Version 2.03, Edward Peschko, Mon Feb 26 12:04:17 PST 2001 |
| 45 | |
| 46 | use strict; |
| 47 | use warnings; |
| 48 | use 5.006_000; |
| 49 | |
| 50 | use FileHandle; |
| 51 | use Config; |
| 52 | use Fcntl qw(:DEFAULT :flock); |
| 53 | use File::Temp qw(tempfile); |
| 54 | use Cwd; |
| 55 | our $VERSION = 2.03; |
| 56 | $| = 1; |
| 57 | |
| 58 | $SIG{INT} = sub { exit(); }; # exit gracefully and clean up after ourselves. |
| 59 | |
| 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 |
| 66 | sub is_win32(); |
| 67 | sub is_msvc(); |
| 68 | |
| 69 | our ($Options, $BinPerl, $Backend); |
| 70 | our ($Input => $Output); |
| 71 | our ($logfh); |
| 72 | our ($cfile); |
| 73 | our (@begin_output); # output from BEGIN {}, for testsuite |
| 74 | |
| 75 | # eval { main(); 1 } or die; |
| 76 | |
| 77 | main(); |
| 78 | |
| 79 | sub main { |
| 80 | parse_argv(); |
| 81 | check_write($Output); |
| 82 | choose_backend(); |
| 83 | generate_code(); |
| 84 | run_code(); |
| 85 | _die("XXX: Not reached?"); |
| 86 | } |
| 87 | |
| 88 | ####################################################################### |
| 89 | |
| 90 | sub choose_backend { |
| 91 | # Choose the backend. |
| 92 | $Backend = 'C'; |
| 93 | if (opt(B)) { |
| 94 | checkopts_byte(); |
| 95 | $Backend = 'Bytecode'; |
| 96 | } |
| 97 | if (opt(S) && opt(c)) { |
| 98 | # die "$0: Do you want me to compile this or not?\n"; |
| 99 | delete $Options->{S}; |
| 100 | } |
| 101 | $Backend = 'CC' if opt(O); |
| 102 | } |
| 103 | |
| 104 | |
| 105 | sub generate_code { |
| 106 | |
| 107 | vprint 0, "Compiling $Input"; |
| 108 | |
| 109 | $BinPerl = yclept(); # Calling convention for perl. |
| 110 | |
| 111 | if (opt(shared)) { |
| 112 | compile_module(); |
| 113 | } else { |
| 114 | if ($Backend eq 'Bytecode') { |
| 115 | compile_byte(); |
| 116 | } else { |
| 117 | compile_cstyle(); |
| 118 | } |
| 119 | } |
| 120 | exit(0) if (!opt('r')); |
| 121 | } |
| 122 | |
| 123 | sub run_code { |
| 124 | vprint 0, "Running code"; |
| 125 | run("$Output @ARGV"); |
| 126 | exit(0); |
| 127 | } |
| 128 | |
| 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"; |
| 142 | if (opt(v) > $level) |
| 143 | { |
| 144 | print "$0: $msg" if !opt('log'); |
| 145 | print $logfh "$0: $msg" if opt('log'); |
| 146 | } |
| 147 | } |
| 148 | |
| 149 | sub parse_argv { |
| 150 | |
| 151 | use Getopt::Long; |
| 152 | |
| 153 | # disallows using long arguments |
| 154 | # Getopt::Long::Configure("bundling"); |
| 155 | |
| 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 |
| 167 | 'v:i', # Verbosity level |
| 168 | 'e:s', # One-liner |
| 169 | 'r', # run resulting executable |
| 170 | 'B', # Byte compiler backend |
| 171 | 'O', # Optimised C backend |
| 172 | 'c', # Compile only |
| 173 | 'h', # Help me |
| 174 | 'S', # Dump C files |
| 175 | 'r', # run the resulting executable |
| 176 | 'T', # run the backend using perl -T |
| 177 | 't', # run the backend using perl -t |
| 178 | 'static', # Dirty hack to enable -shared/-static |
| 179 | 'shared', # Create a shared library (--shared for compat.) |
| 180 | 'log:s', # where to log compilation process information |
| 181 | 'Wb:s', # pass (comma-sepearated) options to backend |
| 182 | 'testsuite', # try to be nice to testsuite |
| 183 | ); |
| 184 | |
| 185 | $Options->{v} += 0; |
| 186 | |
| 187 | if( opt(t) && opt(T) ) { |
| 188 | warn "Can't specify both -T and -t, -t ignored"; |
| 189 | $Options->{t} = 0; |
| 190 | } |
| 191 | |
| 192 | helpme() if opt(h); # And exit |
| 193 | |
| 194 | $Output = opt(o) || ( is_win32 ? 'a.exe' : 'a.out' ); |
| 195 | $Output = is_win32() ? $Output : relativize($Output); |
| 196 | $logfh = new FileHandle(">> " . opt('log')) if (opt('log')); |
| 197 | |
| 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! |
| 202 | $Input = is_win32() ? # Quotes eaten by shell |
| 203 | '-e "'.opt(e).'"' : |
| 204 | "-e '".opt(e)."'"; |
| 205 | } else { |
| 206 | $Input = shift @ARGV; # XXX: more files? |
| 207 | _usage_and_die("$0: No input file specified\n") unless $Input; |
| 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(); |
| 214 | } |
| 215 | |
| 216 | } |
| 217 | |
| 218 | sub opt(*) { |
| 219 | my $opt = shift; |
| 220 | return exists($Options->{$opt}) && ($Options->{$opt} || 0); |
| 221 | } |
| 222 | |
| 223 | sub compile_module { |
| 224 | die "$0: Compiling to shared libraries is currently disabled\n"; |
| 225 | } |
| 226 | |
| 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"; |
| 235 | |
| 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 }; |
| 239 | |
| 240 | # these dies are not "$0: .... \n" because they "can't happen" |
| 241 | |
| 242 | sysopen(OUT, $Output, $openflags) |
| 243 | or die "can't write to $Output: $!"; |
| 244 | |
| 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 }; |
| 248 | |
| 249 | truncate(OUT, 0) |
| 250 | or die "couldn't trunc $Output: $!"; |
| 251 | |
| 252 | print OUT <<EOF; |
| 253 | #!$^X |
| 254 | use ByteLoader $ByteLoader::VERSION; |
| 255 | EOF |
| 256 | |
| 257 | # Now the compile: |
| 258 | vprint 1, "Compiling..."; |
| 259 | vprint 3, "Calling $command"; |
| 260 | |
| 261 | my ($output_r, $error_r) = spawnit($command); |
| 262 | |
| 263 | if (@$error_r && $? != 0) { |
| 264 | _die("$0: $Input did not compile, which can't happen:\n@$error_r\n"); |
| 265 | } else { |
| 266 | my @error = grep { !/^$Input syntax OK$/o } @$error_r; |
| 267 | warn "$0: Unexpected compiler output:\n@error" if @error; |
| 268 | } |
| 269 | |
| 270 | # Write it and leave. |
| 271 | print OUT @$output_r or _die("can't write $Output: $!"); |
| 272 | close OUT or _die("can't close $Output: $!"); |
| 273 | |
| 274 | # wait, how could it be anything but what you see next? |
| 275 | chmod 0777 & ~umask, $Output or _die("can't chmod $Output: $!"); |
| 276 | exit 0; |
| 277 | } |
| 278 | |
| 279 | sub compile_cstyle { |
| 280 | my $stash = grab_stash(); |
| 281 | my $taint = opt(T) ? '-T' : |
| 282 | opt(t) ? '-t' : ''; |
| 283 | |
| 284 | # What are we going to call our output C file? |
| 285 | my $lose = 0; |
| 286 | my ($cfh); |
| 287 | my $testsuite = ''; |
| 288 | my $addoptions = opt(Wb); |
| 289 | |
| 290 | if( $addoptions ) { |
| 291 | $addoptions .= ',' if $addoptions !~ m/,$/; |
| 292 | } |
| 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 | } |
| 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 |
| 323 | } |
| 324 | vprint 1, "Writing C on $cfile"; |
| 325 | |
| 326 | my $max_line_len = ''; |
| 327 | if ($^O eq 'MSWin32' && $Config{cc} =~ /^cl/i) { |
| 328 | $max_line_len = '-l2000,'; |
| 329 | } |
| 330 | |
| 331 | # This has to do the write itself, so we can't keep a lock. Life |
| 332 | # sucks. |
| 333 | my $command = "$BinPerl $taint -MO=$Backend,$addoptions$testsuite$max_line_len$stash,-o$cfile $Input"; |
| 334 | vprint 1, "Compiling..."; |
| 335 | vprint 1, "Calling $command"; |
| 336 | |
| 337 | my ($output_r, $error_r) = spawnit($command); |
| 338 | my @output = @$output_r; |
| 339 | my @error = @$error_r; |
| 340 | |
| 341 | if (@error && $? != 0) { |
| 342 | _die("$0: $Input did not compile, which can't happen:\n@error\n"); |
| 343 | } |
| 344 | |
| 345 | is_msvc ? |
| 346 | cc_harness_msvc($cfile,$stash) : |
| 347 | cc_harness($cfile,$stash) unless opt(c); |
| 348 | |
| 349 | if ($lose) { |
| 350 | vprint 2, "unlinking $cfile"; |
| 351 | unlink $cfile or _die("can't unlink $cfile: $!"); |
| 352 | } |
| 353 | } |
| 354 | |
| 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); |
| 365 | $link .= " perl57.lib kernel32.lib msvcrt.lib"; |
| 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 | |
| 372 | sub cc_harness { |
| 373 | my ($cfile,$stash)=@_; |
| 374 | use ExtUtils::Embed (); |
| 375 | my $command = ExtUtils::Embed::ccopts." -o $Output $cfile "; |
| 376 | $command .= " -I".$_ for split /\s+/, opt(I); |
| 377 | $command .= " -L".$_ for split /\s+/, opt(L); |
| 378 | my @mods = split /-?u /, $stash; |
| 379 | $command .= " ".ExtUtils::Embed::ldopts("-std", \@mods); |
| 380 | $command .= " -lperl"; |
| 381 | vprint 3, "running $Config{cc} $command"; |
| 382 | system("$Config{cc} $command"); |
| 383 | } |
| 384 | |
| 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 | } |
| 397 | } |
| 398 | } |
| 399 | |
| 400 | $command .= "-I$_ " for @INC; |
| 401 | return $command; |
| 402 | } |
| 403 | |
| 404 | # Use B::Stash to find additional modules and stuff. |
| 405 | { |
| 406 | my $_stash; |
| 407 | sub grab_stash { |
| 408 | |
| 409 | warn "already called get_stash once" if $_stash; |
| 410 | |
| 411 | my $taint = opt(T) ? '-T' : |
| 412 | opt(t) ? '-t' : ''; |
| 413 | my $command = "$BinPerl $taint -MB::Stash -c $Input"; |
| 414 | # Filename here is perfectly sanitised. |
| 415 | vprint 3, "Calling $command\n"; |
| 416 | |
| 417 | my ($stash_r, $error_r) = spawnit($command); |
| 418 | my @stash = @$stash_r; |
| 419 | my @error = @$error_r; |
| 420 | |
| 421 | if (@error && $? != 0) { |
| 422 | _die("$0: $Input did not compile:\n@error\n"); |
| 423 | } |
| 424 | |
| 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]; |
| 431 | $stash[0] =~ s/,-u\<none\>//; |
| 432 | $stash[0] =~ s/^.*?-u/-u/s; |
| 433 | vprint 2, "Stash: ", join " ", split /,?-u/, $stash[0]; |
| 434 | chomp $stash[0]; |
| 435 | return $_stash = $stash[0]; |
| 436 | } |
| 437 | |
| 438 | } |
| 439 | |
| 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 { |
| 443 | |
| 444 | _die("$0: Please choose one of either -B and -O.\n") if opt(O); |
| 445 | |
| 446 | if (opt(shared)) { |
| 447 | warn "$0: Will not create a shared library for bytecode\n"; |
| 448 | delete $Options->{shared}; |
| 449 | } |
| 450 | |
| 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 | } |
| 457 | } |
| 458 | |
| 459 | } |
| 460 | |
| 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') { |
| 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. |
| 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 | } |
| 472 | } |
| 473 | } |
| 474 | |
| 475 | sub check_read { |
| 476 | my $file = shift; |
| 477 | unless (-r $file) { |
| 478 | _die("$0: Input file $file is a directory, not a file\n") if -d _; |
| 479 | unless (-e _) { |
| 480 | _die("$0: Input file $file was not found\n"); |
| 481 | } else { |
| 482 | _die("$0: Cannot read input file $file: $!\n"); |
| 483 | } |
| 484 | } |
| 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 | } |
| 489 | } |
| 490 | |
| 491 | sub check_write { |
| 492 | my $file = shift; |
| 493 | if (-d $file) { |
| 494 | _die("$0: Cannot write on $file, is a directory\n"); |
| 495 | } |
| 496 | if (-e _) { |
| 497 | _die("$0: Cannot write on $file: $!\n") unless -w _; |
| 498 | } |
| 499 | unless (-w cwd()) { |
| 500 | _die("$0: Cannot write in this directory: $!\n"); |
| 501 | } |
| 502 | } |
| 503 | |
| 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); |
| 510 | _die("Please try a perlier file!\n"); |
| 511 | } |
| 512 | |
| 513 | open(my $handle, "<", $file) or _die("XXX: can't open $file: $!"); |
| 514 | local $_ = <$handle>; |
| 515 | if (/^#!/ && !/perl/) { |
| 516 | _die("$0: $file is a ", /^#!\s*(\S+)/, " script, not perl\n"); |
| 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 |") |
| 529 | or _die("$0: Couldn't spawn the compiler.\n"); |
| 530 | @output = <S_OUT>; |
| 531 | } |
| 532 | open (S_ERROR, $errname) or _die("$0: Couldn't read the error file.\n"); |
| 533 | @error = <S_ERROR>; |
| 534 | close S_ERROR; |
| 535 | close S_OUT; |
| 536 | unlink $errname or _die("$0: Can't unlink error file $errname"); |
| 537 | return (\@output, \@error); |
| 538 | } |
| 539 | |
| 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 | } |
| 547 | } |
| 548 | |
| 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 | |
| 612 | sub is_win32() { $^O =~ m/^MSWin/ } |
| 613 | sub is_msvc() { is_win32 && $Config{cc} =~ m/^cl/i } |
| 614 | |
| 615 | END { |
| 616 | unlink $cfile if ($cfile && !opt(S) && !opt(c)); |
| 617 | } |
| 618 | |
| 619 | __END__ |
| 620 | |
| 621 | =head1 NAME |
| 622 | |
| 623 | perlcc - generate executables from Perl programs |
| 624 | |
| 625 | =head1 SYNOPSIS |
| 626 | |
| 627 | $ perlcc hello # Compiles into executable 'a.out' |
| 628 | $ perlcc -o hello hello.pl # Compiles into executable 'hello' |
| 629 | |
| 630 | $ perlcc -O file # Compiles using the optimised C backend |
| 631 | $ perlcc -B file # Compiles using the bytecode backend |
| 632 | |
| 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' |
| 637 | |
| 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' |
| 640 | |
| 641 | $ perlcc -I /foo hello # extra headers (notice the space after -I) |
| 642 | $ perlcc -L /foo hello # extra libraries (notice the space after -L) |
| 643 | |
| 644 | $ perlcc -r hello # compiles 'hello' into 'a.out', runs 'a.out'. |
| 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 | |
| 651 | =head1 DESCRIPTION |
| 652 | |
| 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. |
| 658 | |
| 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. |
| 662 | |
| 663 | =head1 OPTIONS |
| 664 | |
| 665 | =over 4 |
| 666 | |
| 667 | =item -LI<library directories> |
| 668 | |
| 669 | Adds the given directories to the library search path when C code is |
| 670 | passed to your C compiler. |
| 671 | |
| 672 | =item -II<include directories> |
| 673 | |
| 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. |
| 677 | |
| 678 | =item -o I<output file name> |
| 679 | |
| 680 | Specifies the file name for the final compiled executable. |
| 681 | |
| 682 | =item -c I<C file name> |
| 683 | |
| 684 | Create C code only; do not compile to a standalone binary. |
| 685 | |
| 686 | =item -e I<perl code> |
| 687 | |
| 688 | Compile a one-liner, much the same as C<perl -e '...'> |
| 689 | |
| 690 | =item -S |
| 691 | |
| 692 | Do not delete generated C code after compilation. |
| 693 | |
| 694 | =item -B |
| 695 | |
| 696 | Use the Perl bytecode code generator. |
| 697 | |
| 698 | =item -O |
| 699 | |
| 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. |
| 703 | |
| 704 | =item -v |
| 705 | |
| 706 | Increase verbosity of output; can be repeated for more verbose output. |
| 707 | |
| 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 | |
| 716 | =back |
| 717 | |
| 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 ':'; |
| 725 | chdir $origdir; |