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