utils/perlcc.PL

   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     my $command = "$BinPerl -MO=Bytecode,-H,-o$Output $Input";
 229     $Input =~ s/^-e.*$/-e/;
 230
 231     my ($output_r, $error_r) = spawnit($command);
 232
 233     if (@$error_r && $? != 0) {
 234         _die("$0: $Input did not compile:\n@$error_r\n");
 235     } else {
 236         my @error = grep { !/^$Input syntax OK$/o } @$error_r;
 237         warn "$0: Unexpected compiler output:\n@error" if @error;
 238     }
 239
 240     chmod 0777 & ~umask, $Output    or _die("can't chmod $Output: $!");
 241     exit 0;
 242 }
 243
 244 sub compile_cstyle {
 245     my $stash = grab_stash();
 246     my $taint = opt(T) ? '-T' :
 247                 opt(t) ? '-t' : '';
 248
 249     # What are we going to call our output C file?
 250     my $lose = 0;
 251     my ($cfh);
 252     my $testsuite = '';
 253     my $addoptions = opt(Wb);
 254
 255     if( $addoptions ) {
 256         $addoptions .= ',' if $addoptions !~ m/,$/;
 257     }
 258
 259     if (opt(testsuite)) {
 260         my $bo = join '', @begin_output;
 261         $bo =~ s/\\/\\\\\\\\/gs;
 262         $bo =~ s/\n/\\n/gs;
 263         $bo =~ s/,/\\054/gs;
 264         # don't look at that: it hurts
 265         $testsuite = q{-fuse-script-name,-fsave-data,-fsave-sig-hash,}.
 266             qq[-e"print q{$bo}",] .
 267             q{-e"open(Test::Builder::TESTOUT\054 '>&STDOUT') or die $!",} .
 268             q{-e"open(Test::Builder::TESTERR\054 '>&STDERR') or die $!",};
 269     }
 270     if (opt(S) || opt(c)) {
 271         # We need to keep it.
 272         if (opt(e)) {
 273             $cfile = "a.out.c";
 274         } else {
 275             $cfile = $Input;
 276             # File off extension if present
 277             # hold on: plx is executable; also, careful of ordering!
 278             $cfile =~ s/\.(?:p(?:lx|l|h)|m)\z//i;
 279             $cfile .= ".c";
 280             $cfile = $Output if opt(c) && $Output =~ /\.c\z/i;
 281         }
 282         check_write($cfile);
 283     } else {
 284         # Don't need to keep it, be safe with a tempfile.
 285         $lose = 1;
 286         ($cfh, $cfile) = tempfile("pccXXXXX", SUFFIX => ".c");
 287         close $cfh; # See comment just below
 288     }
 289     vprint 1, "Writing C on $cfile";
 290
 291     my $max_line_len = '';
 292     if ($^O eq 'MSWin32' && $Config{cc} =~ /^cl/i) {
 293         $max_line_len = '-l2000,';
 294     }
 295
 296     # This has to do the write itself, so we can't keep a lock. Life
 297     # sucks.
 298     my $command = "$BinPerl $taint -MO=$Backend,$addoptions$testsuite$max_line_len$stash,-o$cfile $Input";
 299     vprint 1, "Compiling...";
 300     vprint 1, "Calling $command";
 301
 302         my ($output_r, $error_r) = spawnit($command);
 303         my @output = @$output_r;
 304         my @error = @$error_r;
 305
 306     if (@error && $? != 0) {
 307         _die("$0: $Input did not compile, which can't happen:\n@error\n");
 308     }
 309
 310     is_msvc ?
 311         cc_harness_msvc($cfile,$stash) :
 312         cc_harness($cfile,$stash) unless opt(c);
 313
 314     if ($lose) {
 315         vprint 2, "unlinking $cfile";
 316         unlink $cfile or _die("can't unlink $cfile: $!");
 317     }
 318 }
 319
 320 sub cc_harness_msvc {
 321     my ($cfile,$stash)=@_;
 322     use ExtUtils::Embed ();
 323     my $obj = "${Output}.obj";
 324     my $compile = ExtUtils::Embed::ccopts." -c -Fo$obj $cfile ";
 325     my $link = "-out:$Output $obj";
 326     $compile .= " -I".$_ for split /\s+/, opt(I);
 327     $link .= " -libpath:".$_ for split /\s+/, opt(L);
 328     my @mods = split /-?u /, $stash;
 329     $link .= " ".ExtUtils::Embed::ldopts("-std", \@mods);
 330     $link .= " perl57.lib kernel32.lib msvcrt.lib";
 331     vprint 3, "running $Config{cc} $compile";
 332     system("$Config{cc} $compile");
 333     vprint 3, "running $Config{ld} $link";
 334     system("$Config{ld} $link");
 335 }
 336
 337 sub cc_harness {
 338         my ($cfile,$stash)=@_;
 339         use ExtUtils::Embed ();
 340         my $command = ExtUtils::Embed::ccopts." -o $Output $cfile ";
 341         $command .= " -I".$_ for split /\s+/, opt(I);
 342         $command .= " -L".$_ for split /\s+/, opt(L);
 343         my @mods = split /-?u /, $stash;
 344         $command .= " ".ExtUtils::Embed::ldopts("-std", \@mods);
 345         $command .= " -lperl";
 346         vprint 3, "running $Config{cc} $command";
 347         system("$Config{cc} $command");
 348 }
 349
 350 # Where Perl is, and which include path to give it.
 351 sub yclept {
 352     my $command = "$^X ";
 353
 354     # DWIM the -I to be Perl, not C, include directories.
 355     if (opt(I) && $Backend eq "Bytecode") {
 356         for (split /\s+/, opt(I)) {
 357             if (-d $_) {
 358                 push @INC, $_;
 359             } else {
 360                 warn "$0: Include directory $_ not found, skipping\n";
 361             }
 362         }
 363     }
 364
 365     $command .= "-I$_ " for @INC;
 366     return $command;
 367 }
 368
 369 # Use B::Stash to find additional modules and stuff.
 370 {
 371     my $_stash;
 372     sub grab_stash {
 373
 374         warn "already called get_stash once" if $_stash;
 375
 376         my $taint = opt(T) ? '-T' :
 377                     opt(t) ? '-t' : '';
 378         my $command = "$BinPerl $taint -MB::Stash -c $Input";
 379         # Filename here is perfectly sanitised.
 380         vprint 3, "Calling $command\n";
 381
 382                 my ($stash_r, $error_r) = spawnit($command);
 383                 my @stash = @$stash_r;
 384                 my @error = @$error_r;
 385
 386         if (@error && $? != 0) {
 387             _die("$0: $Input did not compile:\n@error\n");
 388         }
 389
 390         # band-aid for modules with noisy BEGIN {}
 391         foreach my $i ( @stash ) {
 392             $i =~ m/-u(?:[\w:]+|\<none\>)$/ and $stash[0] = $i and next;
 393             push @begin_output, $i;
 394         }
 395         chomp $stash[0];
 396         $stash[0] =~ s/,-u\<none\>//;
 397         $stash[0] =~ s/^.*?-u/-u/s;
 398         vprint 2, "Stash: ", join " ", split /,?-u/, $stash[0];
 399         chomp $stash[0];
 400         return $_stash = $stash[0];
 401     }
 402
 403 }
 404
 405 # Check the consistency of options if -B is selected.
 406 # To wit, (-B|-O) ==> no -shared, no -S, no -c
 407 sub checkopts_byte {
 408
 409     _die("$0: Please choose one of either -B and -O.\n") if opt(O);
 410
 411     if (opt(shared)) {
 412         warn "$0: Will not create a shared library for bytecode\n";
 413         delete $Options->{shared};
 414     }
 415
 416     for my $o ( qw[c S] ) {
 417         if (opt($o)) {
 418             warn "$0: Compiling to bytecode is a one-pass process--",
 419                   "-$o ignored\n";
 420             delete $Options->{$o};
 421         }
 422     }
 423
 424 }
 425
 426 # Check the input and output files make sense, are read/writeable.
 427 sub sanity_check {
 428     if ($Input eq $Output) {
 429         if ($Input eq 'a.out') {
 430             _die("$0: Compiling a.out is probably not what you want to do.\n");
 431             # You fully deserve what you get now. No you *don't*. typos happen.
 432         } else {
 433             warn "$0: Will not write output on top of input file, ",
 434                 "compiling to a.out instead\n";
 435             $Output = "a.out";
 436         }
 437     }
 438 }
 439
 440 sub check_read {
 441     my $file = shift;
 442     unless (-r $file) {
 443         _die("$0: Input file $file is a directory, not a file\n") if -d _;
 444         unless (-e _) {
 445             _die("$0: Input file $file was not found\n");
 446         } else {
 447             _die("$0: Cannot read input file $file: $!\n");
 448         }
 449     }
 450     unless (-f _) {
 451         # XXX: die?  don't try this on /dev/tty
 452         warn "$0: WARNING: input $file is not a plain file\n";
 453     }
 454 }
 455
 456 sub check_write {
 457     my $file = shift;
 458     if (-d $file) {
 459         _die("$0: Cannot write on $file, is a directory\n");
 460     }
 461     if (-e _) {
 462         _die("$0: Cannot write on $file: $!\n") unless -w _;
 463     }
 464     unless (-w cwd()) {
 465         _die("$0: Cannot write in this directory: $!\n");
 466     }
 467 }
 468
 469 sub check_perl {
 470     my $file = shift;
 471     unless (-T $file) {
 472         warn "$0: Binary `$file' sure doesn't smell like perl source!\n";
 473         print "Checking file type... ";
 474         system("file", $file);
 475         _die("Please try a perlier file!\n");
 476     }
 477
 478     open(my $handle, "<", $file)    or _die("XXX: can't open $file: $!");
 479     local $_ = <$handle>;
 480     if (/^#!/ && !/perl/) {
 481         _die("$0: $file is a ", /^#!\s*(\S+)/, " script, not perl\n");
 482     }
 483
 484 }
 485
 486 # File spawning and error collecting
 487 sub spawnit {
 488         my ($command) = shift;
 489         my (@error,@output);
 490         my $errname;
 491         (undef, $errname) = tempfile("pccXXXXX");
 492         {
 493         open (S_OUT, "$command 2>$errname |")
 494                 or _die("$0: Couldn't spawn the compiler.\n");
 495         @output = <S_OUT>;
 496         }
 497         open (S_ERROR, $errname) or _die("$0: Couldn't read the error file.\n");
 498         @error = <S_ERROR>;
 499         close S_ERROR;
 500         close S_OUT;
 501         unlink $errname or _die("$0: Can't unlink error file $errname");
 502         return (\@output, \@error);
 503 }
 504
 505 sub helpme {
 506        print "perlcc compiler frontend, version $VERSION\n\n";
 507        { no warnings;
 508        exec "pod2usage $0";
 509        exec "perldoc $0";
 510        exec "pod2text $0";
 511        }
 512 }
 513
 514 sub relativize {
 515         my ($args) = @_;
 516
 517         return() if ($args =~ m"^[/\\]");
 518         return("./$args");
 519 }
 520
 521 sub _die {
 522     $logfh->print(@_) if opt('log');
 523     print STDERR @_;
 524     exit(); # should die eventually. However, needed so that a 'make compile'
 525             # can compile all the way through to the end for standard dist.
 526 }
 527
 528 sub _usage_and_die {
 529     _die(<<EOU);
 530 $0: Usage:
 531 $0 [-o executable] [-r] [-O|-B|-c|-S] [-log log] [source[.pl] | -e oneliner]
 532 EOU
 533 }
 534
 535 sub run {
 536     my (@commands) = @_;
 537
 538     print interruptrun(@commands) if (!opt('log'));
 539     $logfh->print(interruptrun(@commands)) if (opt('log'));
 540 }
 541
 542 sub interruptrun
 543 {
 544     my (@commands) = @_;
 545
 546     my $command = join('', @commands);
 547     local(*FD);
 548     my $pid = open(FD, "$command |");
 549     my $text;
 550
 551     local($SIG{HUP}) = sub { kill 9, $pid; exit };
 552     local($SIG{INT}) = sub { kill 9, $pid; exit };
 553
 554     my $needalarm =
 555           ($ENV{PERLCC_TIMEOUT} &&
 556           $Config{'osname'} ne 'MSWin32' &&
 557           $command =~ m"(^|\s)perlcc\s");
 558
 559     eval
 560     {
 561          local($SIG{ALRM}) = sub { die "INFINITE LOOP"; };
 562          alarm($ENV{PERLCC_TIMEOUT}) if ($needalarm);
 563          $text = join('', <FD>);
 564          alarm(0) if ($needalarm);
 565     };
 566
 567     if ($@)
 568     {
 569         eval { kill 'HUP', $pid };
 570         vprint 0, "SYSTEM TIMEOUT (infinite loop?)\n";
 571     }
 572
 573     close(FD);
 574     return($text);
 575 }
 576
 577 sub is_win32() { $^O =~ m/^MSWin/ }
 578 sub is_msvc() { is_win32 && $Config{cc} =~ m/^cl/i }
 579
 580 END {
 581     unlink $cfile if ($cfile && !opt(S) && !opt(c));
 582 }
 583
 584 __END__
 585
 586 =head1 NAME
 587
 588 perlcc - generate executables from Perl programs
 589
 590 =head1 SYNOPSIS
 591
 592     $ perlcc hello              # Compiles into executable 'a.out'
 593     $ perlcc -o hello hello.pl  # Compiles into executable 'hello'
 594
 595     $ perlcc -O file            # Compiles using the optimised C backend
 596     $ perlcc -B file            # Compiles using the bytecode backend
 597
 598     $ perlcc -c file            # Creates a C file, 'file.c'
 599     $ perlcc -S -o hello file   # Creates a C file, 'file.c',
 600                                 # then compiles it to executable 'hello'
 601     $ perlcc -c out.c file      # Creates a C file, 'out.c' from 'file'
 602
 603     $ perlcc -e 'print q//'     # Compiles a one-liner into 'a.out'
 604     $ perlcc -c -e 'print q//'  # Creates a C file 'a.out.c'
 605
 606     $ perlcc -I /foo hello      # extra headers (notice the space after -I)
 607     $ perlcc -L /foo hello      # extra libraries (notice the space after -L)
 608
 609     $ perlcc -r hello           # compiles 'hello' into 'a.out', runs 'a.out'.
 610     $ perlcc -r hello a b c     # compiles 'hello' into 'a.out', runs 'a.out'.
 611                                 # with arguments 'a b c'
 612
 613     $ perlcc hello -log c       # compiles 'hello' into 'a.out' logs compile
 614                                 # log into 'c'.
 615
 616 =head1 DESCRIPTION
 617
 618 F<perlcc> creates standalone executables from Perl programs, using the
 619 code generators provided by the L<B> module. At present, you may
 620 either create executable Perl bytecode, using the C<-B> option, or
 621 generate and compile C files using the standard and 'optimised' C
 622 backends.
 623
 624 The code generated in this way is not guaranteed to work. The whole
 625 codegen suite (C<perlcc> included) should be considered B<very>
 626 experimental. Use for production purposes is strongly discouraged.
 627
 628 =head1 OPTIONS
 629
 630 =over 4
 631
 632 =item -LI<library directories>
 633
 634 Adds the given directories to the library search path when C code is
 635 passed to your C compiler.
 636
 637 =item -II<include directories>
 638
 639 Adds the given directories to the include file search path when C code is
 640 passed to your C compiler; when using the Perl bytecode option, adds the
 641 given directories to Perl's include path.
 642
 643 =item -o I<output file name>
 644
 645 Specifies the file name for the final compiled executable.
 646
 647 =item -c I<C file name>
 648
 649 Create C code only; do not compile to a standalone binary.
 650
 651 =item -e I<perl code>
 652
 653 Compile a one-liner, much the same as C<perl -e '...'>
 654
 655 =item -S
 656
 657 Do not delete generated C code after compilation.
 658
 659 =item -B
 660
 661 Use the Perl bytecode code generator.
 662
 663 =item -O
 664
 665 Use the 'optimised' C code generator. This is more experimental than
 666 everything else put together, and the code created is not guaranteed to
 667 compile in finite time and memory, or indeed, at all.
 668
 669 =item -v
 670
 671 Increase verbosity of output; can be repeated for more verbose output.
 672
 673 =item -r
 674
 675 Run the resulting compiled script after compiling it.
 676
 677 =item -log
 678
 679 Log the output of compiling to a file rather than to stdout.
 680
 681 =back
 682
 683 =cut
 684
 685 !NO!SUBS!
 686
 687 close OUT or die "Can't close $file: $!";
 688 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
 689 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
 690 chdir $origdir;