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         my @output = @$output_r;
 236         my @error = @$error_r;
 237
 238     if (@error && $? != 0) {
 239         die "$0: $Input did not compile, which can't happen:\n@error\n";
 240     }
 241
 242     # Write it and leave.
 243     print OUT @output               or die "can't write $Output: $!";
 244     close OUT                       or die "can't close $Output: $!";
 245
 246     # wait, how could it be anything but what you see next?
 247     chmod 0777 & ~umask, $Output    or die "can't chmod $Output: $!";
 248     exit 0;
 249 }
 250
 251 sub compile_cstyle {
 252     my $stash = grab_stash();
 253
 254     # What are we going to call our output C file?
 255     my ($cfile,$cfh);
 256     my $lose = 0;
 257     if (opt(S) || opt(c)) {
 258         # We need to keep it.
 259         if (opt(e)) {
 260             $cfile = "a.out.c";
 261         } else {
 262             $cfile = $Input;
 263             # File off extension if present
 264             # hold on: plx is executable; also, careful of ordering!
 265             $cfile =~ s/\.(?:p(?:lx|l|h)|m)\z//i;
 266             $cfile .= ".c";
 267             $cfile = $Output if opt(c) && $Output =~ /\.c\z/i;
 268         }
 269         check_write($cfile);
 270     } else {
 271         # Don't need to keep it, be safe with a tempfile.
 272         $lose = 1;
 273         ($cfh, $cfile) = tempfile("pccXXXXX", SUFFIX => ".c");
 274         close $cfh; # See comment just below
 275     }
 276     vprint 1, "Writing C on $cfile";
 277
 278     my $max_line_len = '';
 279     if ($^O eq 'MSWin32' && $Config{cc} =~ /^cl/i) {
 280         $max_line_len = '-l2000,';
 281     }
 282
 283     # This has to do the write itself, so we can't keep a lock. Life
 284     # sucks.
 285     my $command = "$BinPerl -MO=$Backend,$max_line_len$stash,-o$cfile $Input";
 286     vprint 1, "Compiling...";
 287     vprint 1, "Calling $command";
 288
 289         my ($output_r, $error_r) = spawnit($command);
 290         my @output = @$output_r;
 291         my @error = @$error_r;
 292
 293     if (@error && $? != 0) {
 294         die "$0: $Input did not compile, which can't happen:\n@error\n";
 295     }
 296
 297     cc_harness($cfile,$stash) unless opt(c);
 298
 299     if ($lose) {
 300         vprint 2, "unlinking $cfile";
 301         unlink $cfile or die "can't unlink $cfile: $!" if $lose;
 302     }
 303         exit(0);
 304 }
 305
 306 sub cc_harness {
 307         my ($cfile,$stash)=@_;
 308         use ExtUtils::Embed ();
 309         my $command = ExtUtils::Embed::ccopts." -o $Output $cfile ";
 310         $command .= join " -I", split /\s+/, opt(I);
 311         $command .= join " -L", split /\s+/, opt(L);
 312         my @mods = split /-?u /, $stash;
 313         $command .= ExtUtils::Embed::ldopts("-std", \@mods);
 314         vprint 3, "running cc $command";
 315         system("cc $command");
 316 }
 317
 318 # Where Perl is, and which include path to give it.
 319 sub yclept {
 320     my $command = "$^X ";
 321
 322     # DWIM the -I to be Perl, not C, include directories.
 323     if (opt(I) && $Backend eq "Bytecode") {
 324         for (split /\s+/, opt(I)) {
 325             if (-d $_) {
 326                 push @INC, $_;
 327             } else {
 328                 warn "$0: Include directory $_ not found, skipping\n";
 329             }
 330         }
 331     }
 332
 333     $command .= "-I$_ " for @INC;
 334     return $command;
 335 }
 336
 337 # Use B::Stash to find additional modules and stuff.
 338 {
 339     my $_stash;
 340     sub grab_stash {
 341
 342         warn "already called get_stash once" if $_stash;
 343
 344         my $command = "$BinPerl -MB::Stash -c $Input";
 345         # Filename here is perfectly sanitised.
 346         vprint 3, "Calling $command\n";
 347
 348                 my ($stash_r, $error_r) = spawnit($command);
 349                 my @stash = @$stash_r;
 350                 my @error = @$error_r;
 351
 352         if (@error && $? != 0) {
 353             die "$0: $Input did not compile:\n@error\n";
 354         }
 355
 356         $stash[0] =~ s/,-u\<none\>//;
 357         vprint 2, "Stash: ", join " ", split /,?-u/, $stash[0];
 358         chomp $stash[0];
 359         return $_stash = $stash[0];
 360     }
 361
 362 }
 363
 364 # Check the consistency of options if -B is selected.
 365 # To wit, (-B|-O) ==> no -shared, no -S, no -c
 366 sub checkopts_byte {
 367
 368     die "$0: Please choose one of either -B and -O.\n" if opt(O);
 369
 370     if (opt(shared)) {
 371         warn "$0: Will not create a shared library for bytecode\n";
 372         delete $Options->{shared};
 373     }
 374
 375     for my $o ( qw[c S] ) {
 376         if (opt($o)) {
 377             warn "$0: Compiling to bytecode is a one-pass process--",
 378                   "-$o ignored\n";
 379             delete $Options->{$o};
 380         }
 381     }
 382
 383 }
 384
 385 # Check the input and output files make sense, are read/writeable.
 386 sub sanity_check {
 387     if ($Input eq $Output) {
 388         if ($Input eq 'a.out') {
 389             warn "$0: Compiling a.out is probably not what you want to do.\n";
 390             # You fully deserve what you get now.
 391         } else {
 392             warn "$0: Will not write output on top of input file, ",
 393                 "compiling to a.out instead\n";
 394             $Output = "a.out";
 395         }
 396     }
 397 }
 398
 399 sub check_read {
 400     my $file = shift;
 401     unless (-r $file) {
 402         die "$0: Input file $file is a directory, not a file\n" if -d _;
 403         unless (-e _) {
 404             die "$0: Input file $file was not found\n";
 405         } else {
 406             die "$0: Cannot read input file $file: $!\n";
 407         }
 408     }
 409     unless (-f _) {
 410         # XXX: die?  don't try this on /dev/tty
 411         warn "$0: WARNING: input $file is not a plain file\n";
 412     }
 413 }
 414
 415 sub check_write {
 416     my $file = shift;
 417     if (-d $file) {
 418         die "$0: Cannot write on $file, is a directory\n";
 419     }
 420     if (-e _) {
 421         die "$0: Cannot write on $file: $!\n" unless -w _;
 422     }
 423     unless (-w cwd()) {
 424         die "$0: Cannot write in this directory: $!\n"
 425     }
 426 }
 427
 428 sub check_perl {
 429     my $file = shift;
 430     unless (-T $file) {
 431         warn "$0: Binary `$file' sure doesn't smell like perl source!\n";
 432         print "Checking file type... ";
 433         system("file", $file);
 434         die "Please try a perlier file!\n";
 435     }
 436
 437     open(my $handle, "<", $file)    or die "XXX: can't open $file: $!";
 438     local $_ = <$handle>;
 439     if (/^#!/ && !/perl/) {
 440         die "$0: $file is a ", /^#!\s*(\S+)/, " script, not perl\n";
 441     }
 442
 443 }
 444
 445 # File spawning and error collecting
 446 sub spawnit {
 447         my ($command) = shift;
 448         my (@error,@output);
 449         my $errname;
 450         (undef, $errname) = tempfile("pccXXXXX");
 451         {
 452         open (S_OUT, "$command 2>$errname |")
 453                 or die "$0: Couldn't spawn the compiler.\n";
 454         @output = <S_OUT>;
 455         }
 456         open (S_ERROR, $errname) or die "$0: Couldn't read the error file.\n";
 457         @error = <S_ERROR>;
 458         close S_ERROR;
 459         close S_OUT;
 460         unlink $errname or die "$0: Can't unlink error file $errname";
 461         return (\@output, \@error);
 462 }
 463
 464 sub helpme {
 465        print "perlcc compiler frontend, version $VERSION\n\n";
 466        { no warnings;
 467        exec "pod2usage $0";
 468        exec "perldoc $0";
 469        exec "pod2text $0";
 470        }
 471 }
 472
 473
 474 __END__
 475
 476 =head1 NAME
 477
 478 perlcc - generate executables from Perl programs
 479
 480 =head1 SYNOPSIS
 481
 482     $ perlcc hello              # Compiles into executable 'a.out'
 483     $ perlcc -o hello hello.pl  # Compiles into executable 'hello'
 484
 485     $ perlcc -O file            # Compiles using the optimised C backend
 486     $ perlcc -B file            # Compiles using the bytecode backend
 487
 488     $ perlcc -c file            # Creates a C file, 'file.c'
 489     $ perlcc -S -o hello file   # Creates a C file, 'file.c',
 490                                 # then compiles it to executable 'hello'
 491     $ perlcc -c out.c file      # Creates a C file, 'out.c' from 'file'
 492
 493     $ perlcc -e 'print q//'     # Compiles a one-liner into 'a.out'
 494     $ perlcc -c -e 'print q//'  # Creates a C file 'a.out.c'
 495
 496 =head1 DESCRIPTION
 497
 498 F<perlcc> creates standalone executables from Perl programs, using the
 499 code generators provided by the L<B> module. At present, you may
 500 either create executable Perl bytecode, using the C<-B> option, or
 501 generate and compile C files using the standard and 'optimised' C
 502 backends.
 503
 504 The code generated in this way is not guaranteed to work. The whole
 505 codegen suite (C<perlcc> included) should be considered B<very>
 506 experimental. Use for production purposes is strongly discouraged.
 507
 508 =head1 OPTIONS
 509
 510 =over 4
 511
 512 =item -LI<library directories>
 513
 514 Adds the given directories to the library search path when C code is
 515 passed to your C compiler.
 516
 517 =item -II<include directories>
 518
 519 Adds the given directories to the include file search path when C code is
 520 passed to your C compiler; when using the Perl bytecode option, adds the
 521 given directories to Perl's include path.
 522
 523 =item -o I<output file name>
 524
 525 Specifies the file name for the final compiled executable.
 526
 527 =item -c I<C file name>
 528
 529 Create C code only; do not compile to a standalone binary.
 530
 531 =item -e I<perl code>
 532
 533 Compile a one-liner, much the same as C<perl -e '...'>
 534
 535 =item -S
 536
 537 Do not delete generated C code after compilation.
 538
 539 =item -B
 540
 541 Use the Perl bytecode code generator.
 542
 543 =item -O
 544
 545 Use the 'optimised' C code generator. This is more experimental than
 546 everything else put together, and the code created is not guaranteed to
 547 compile in finite time and memory, or indeed, at all.
 548
 549 =item -v
 550
 551 Increase verbosity of output; can be repeated for more verbose output.
 552
 553 =back
 554
 555 =cut
 556
 557 !NO!SUBS!
 558
 559 close OUT or die "Can't close $file: $!";
 560 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
 561 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
 562 chdir $origdir;