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