bin/perlcc

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