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