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