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