1#!/usr/local/bin/perl 2 3use Config; 4use File::Basename qw(&basename &dirname); 5use File::Spec; 6use 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; 19chdir dirname($0); 20$file = basename($0, '.PL'); 21$file .= '.com' if $^O eq 'VMS'; 22 23open OUT,">$file" or die "Can't create $file: $!"; 24 25print "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 30print 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 39print 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 47use strict; 48use warnings; 49use 5.006_000; 50 51use FileHandle; 52use Config; 53use Fcntl qw(:DEFAULT :flock); 54use File::Temp qw(tempfile); 55use Cwd; 56our $VERSION = 2.04; 57$| = 1; 58 59$SIG{INT} = sub { exit(); }; # exit gracefully and clean up after ourselves. 60 61use 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}; 66sub opt(*); # imal quoting 67sub is_win32(); 68sub is_msvc(); 69 70our ($Options, $BinPerl, $Backend); 71our ($Input => $Output); 72our ($logfh); 73our ($cfile); 74our (@begin_output); # output from BEGIN {}, for testsuite 75 76# eval { main(); 1 } or die; 77 78main(); 79 80sub 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 91sub 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 106sub 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 124sub run_code { 125 vprint 0, "Running code"; 126 run("$Output @ARGV"); 127 exit(0); 128} 129 130# usage: vprint [level] msg args 131sub 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 150sub 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 219sub opt(*) { 220 my $opt = shift; 221 return exists($Options->{$opt}) && ($Options->{$opt} || 0); 222} 223 224sub compile_module { 225 die "$0: Compiling to shared libraries is currently disabled\n"; 226} 227 228sub 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 245sub 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 321sub 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 338sub 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. 352sub 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 408sub 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. 428sub 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 441sub 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 457sub 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 470sub 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 488sub 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 506sub 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 515sub relativize { 516 my ($args) = @_; 517 518 return() if ($args =~ m"^[/\\]"); 519 return("./$args"); 520} 521 522sub _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 529sub _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] 533EOU 534} 535 536sub run { 537 my (@commands) = @_; 538 539 print interruptrun(@commands) if (!opt('log')); 540 $logfh->print(interruptrun(@commands)) if (opt('log')); 541} 542 543sub 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 578sub is_win32() { $^O =~ m/^MSWin/ } 579sub is_msvc() { is_win32 && $Config{cc} =~ m/^cl/i } 580 581END { 582 unlink $cfile if ($cfile && !opt(S) && !opt(c)); 583} 584 585__END__ 586 587=head1 NAME 588 589perlcc - 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 619F<perlcc> creates standalone executables from Perl programs, using the 620code generators provided by the L<B> module. At present, you may 621either create executable Perl bytecode, using the C<-B> option, or 622generate and compile C files using the standard and 'optimised' C 623backends. 624 625The code generated in this way is not guaranteed to work. The whole 626codegen suite (C<perlcc> included) should be considered B<very> 627experimental. Use for production purposes is strongly discouraged. 628 629=head1 OPTIONS 630 631=over 4 632 633=item -LI<library directories> 634 635Adds the given directories to the library search path when C code is 636passed to your C compiler. 637 638=item -II<include directories> 639 640Adds the given directories to the include file search path when C code is 641passed to your C compiler; when using the Perl bytecode option, adds the 642given directories to Perl's include path. 643 644=item -o I<output file name> 645 646Specifies the file name for the final compiled executable. 647 648=item -c I<C file name> 649 650Create C code only; do not compile to a standalone binary. 651 652=item -e I<perl code> 653 654Compile a one-liner, much the same as C<perl -e '...'> 655 656=item -S 657 658Do not delete generated C code after compilation. 659 660=item -B 661 662Use the Perl bytecode code generator. 663 664=item -O 665 666Use the 'optimised' C code generator. This is more experimental than 667everything else put together, and the code created is not guaranteed to 668compile in finite time and memory, or indeed, at all. 669 670=item -v 671 672Increase verbosity of output; can be repeated for more verbose output. 673 674=item -r 675 676Run the resulting compiled script after compiling it. 677 678=item -log 679 680Log the output of compiling to a file rather than to stdout. 681 682=back 683 684=cut 685 686!NO!SUBS! 687 688close OUT or die "Can't close $file: $!"; 689chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; 690exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; 691chdir $origdir; 692