1N/A

1N/Ause Config;

1N/Ause File::Basename qw(&basename &dirname);

1N/Ause File::Spec;

1N/Ause Cwd;

1N/A

1N/A

1N/A$origdir = cwd;

1N/Achdir dirname($0);

1N/A$file = basename($0, '.PL');

1N/A$file .= '.com' if $^O eq 'VMS';

1N/A

1N/Aopen OUT,">$file" or die "Can't create $file: $!";

1N/A

1N/Aprint "Extracting $file (with variable substitutions)\n";

1N/A

1N/A

1N/Aprint OUT <<"!GROK!THIS!";

1N/A$Config{startperl}

1N/A eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'

1N/A if \$running_under_some_shell;

1N/A--\$running_under_some_shell;

1N/A!GROK!THIS!

1N/A

1N/A

1N/Aprint OUT <<'!NO!SUBS!';

1N/A

1N/A

1N/Ause strict;

1N/Ause warnings;

1N/Ause 5.006_000;

1N/A

1N/Ause FileHandle;

1N/Ause Config;

1N/Ause Fcntl qw(:DEFAULT :flock);

1N/Ause File::Temp qw(tempfile);

1N/Ause Cwd;

1N/Aour $VERSION = 2.04;

1N/A$| = 1;

1N/A

1N/A$SIG{INT} = sub { exit(); }; # exit gracefully and clean up after ourselves.

1N/A

1N/Ause subs qw{

1N/A cc_harness check_read check_write checkopts_byte choose_backend

1N/A compile_byte compile_cstyle compile_module generate_code

1N/A grab_stash parse_argv sanity_check vprint yclept spawnit

1N/A};

1N/Asub opt(*); # imal quoting

1N/Asub is_win32();

1N/Asub is_msvc();

1N/A

1N/Aour ($Options, $BinPerl, $Backend);

1N/Aour ($Input => $Output);

1N/Aour ($logfh);

1N/Aour ($cfile);

1N/Aour (@begin_output); # output from BEGIN {}, for testsuite

1N/A

1N/A

1N/Amain();

1N/A

1N/Asub main {

1N/A parse_argv();

1N/A check_write($Output);

1N/A choose_backend();

1N/A generate_code();

1N/A run_code();

1N/A _die("XXX: Not reached?");

1N/A}

1N/A

1N/A

1N/Asub choose_backend {

1N/A # Choose the backend.

1N/A $Backend = 'C';

1N/A if (opt(B)) {

1N/A checkopts_byte();

1N/A $Backend = 'Bytecode';

1N/A }

1N/A if (opt(S) && opt(c)) {

1N/A # die "$0: Do you want me to compile this or not?\n";

1N/A delete $Options->{S};

1N/A }

1N/A $Backend = 'CC' if opt(O);

1N/A}

1N/A

1N/A

1N/Asub generate_code {

1N/A

1N/A vprint 0, "Compiling $Input";

1N/A

1N/A $BinPerl = yclept(); # Calling convention for perl.

1N/A

1N/A if (opt(shared)) {

1N/A compile_module();

1N/A } else {

1N/A if ($Backend eq 'Bytecode') {

1N/A compile_byte();

1N/A } else {

1N/A compile_cstyle();

1N/A }

1N/A }

1N/A exit(0) if (!opt('r'));

1N/A}

1N/A

1N/Asub run_code {

1N/A vprint 0, "Running code";

1N/A run("$Output @ARGV");

1N/A exit(0);

1N/A}

1N/A

1N/Asub vprint {

1N/A my $level;

1N/A if (@_ == 1) {

1N/A $level = 1;

1N/A } elsif ($_[0] =~ /^\d$/) {

1N/A $level = shift;

1N/A } else {

1N/A # well, they forgot to use a number; means >0

1N/A $level = 0;

1N/A }

1N/A my $msg = "@_";

1N/A $msg .= "\n" unless substr($msg, -1) eq "\n";

1N/A if (opt(v) > $level)

1N/A {

1N/A print "$0: $msg" if !opt('log');

1N/A print $logfh "$0: $msg" if opt('log');

1N/A }

1N/A}

1N/A

1N/Asub parse_argv {

1N/A

1N/A use Getopt::Long;

1N/A

1N/A # disallows using long arguments

1N/A # Getopt::Long::Configure("bundling");

1N/A

1N/A Getopt::Long::Configure("no_ignore_case");

1N/A

1N/A # no difference in exists and defined for %ENV; also, a "0"

1N/A # argument or a "" would not help cc, so skip

1N/A unshift @ARGV, split ' ', $ENV{PERLCC_OPTS} if $ENV{PERLCC_OPTS};

1N/A

1N/A $Options = {};

1N/A Getopt::Long::GetOptions( $Options,

1N/A 'L:s', # lib directory

1N/A 'I:s', # include directories (FOR C, NOT FOR PERL)

1N/A 'o:s', # Output executable

1N/A 'v:i', # Verbosity level

1N/A 'e:s', # One-liner

1N/A 'r', # run resulting executable

1N/A 'B', # Byte compiler backend

1N/A 'O', # Optimised C backend

1N/A 'c', # Compile only

1N/A 'h', # Help me

1N/A 'S', # Dump C files

1N/A 'r', # run the resulting executable

1N/A 'T', # run the backend using perl -T

1N/A 't', # run the backend using perl -t

1N/A 'static', # Dirty hack to enable -shared/-static

1N/A 'shared', # Create a shared library (--shared for compat.)

1N/A 'log:s', # where to log compilation process information

1N/A 'Wb:s', # pass (comma-sepearated) options to backend

1N/A 'testsuite', # try to be nice to testsuite

1N/A );

1N/A

1N/A $Options->{v} += 0;

1N/A

1N/A if( opt(t) && opt(T) ) {

1N/A warn "Can't specify both -T and -t, -t ignored";

1N/A $Options->{t} = 0;

1N/A }

1N/A

1N/A helpme() if opt(h); # And exit

1N/A

1N/A $Output = opt(o) || ( is_win32 ? 'a.exe' : 'a.out' );

1N/A $Output = is_win32() ? $Output : relativize($Output);

1N/A $logfh = new FileHandle(">> " . opt('log')) if (opt('log'));

1N/A

1N/A if (opt(e)) {

1N/A warn "$0: using -e 'code' as input file, ignoring @ARGV\n" if @ARGV;

1N/A # We don't use a temporary file here; why bother?

1N/A # XXX: this is not bullet proof -- spaces or quotes in name!

1N/A $Input = is_win32() ? # Quotes eaten by shell

1N/A '-e "'.opt(e).'"' :

1N/A "-e '".opt(e)."'";

1N/A } else {

1N/A $Input = shift @ARGV; # XXX: more files?

1N/A _usage_and_die("$0: No input file specified\n") unless $Input;

1N/A # DWIM modules. This is bad but necessary.

1N/A $Options->{shared}++ if $Input =~ /\.pm\z/;

1N/A warn "$0: using $Input as input file, ignoring @ARGV\n" if @ARGV;

1N/A check_read($Input);

1N/A check_perl($Input);

1N/A sanity_check();

1N/A }

1N/A

1N/A}

1N/A

1N/Asub opt(*) {

1N/A my $opt = shift;

1N/A return exists($Options->{$opt}) && ($Options->{$opt} || 0);

1N/A}

1N/A

1N/Asub compile_module {

1N/A die "$0: Compiling to shared libraries is currently disabled\n";

1N/A}

1N/A

1N/Asub compile_byte {

1N/A my $command = "$BinPerl -MO=Bytecode,-H,-o$Output $Input";

1N/A $Input =~ s/^-e.*$/-e/;

1N/A

1N/A my ($output_r, $error_r) = spawnit($command);

1N/A

1N/A if (@$error_r && $? != 0) {

1N/A _die("$0: $Input did not compile:\n@$error_r\n");

1N/A } else {

1N/A my @error = grep { !/^$Input syntax OK$/o } @$error_r;

1N/A warn "$0: Unexpected compiler output:\n@error" if @error;

1N/A }

1N/A

1N/A chmod 0777 & ~umask, $Output or _die("can't chmod $Output: $!");

1N/A exit 0;

1N/A}

1N/A

1N/Asub compile_cstyle {

1N/A my $stash = grab_stash();

1N/A my $taint = opt(T) ? '-T' :

1N/A opt(t) ? '-t' : '';

1N/A

1N/A # What are we going to call our output C file?

1N/A my $lose = 0;

1N/A my ($cfh);

1N/A my $testsuite = '';

1N/A my $addoptions = opt(Wb);

1N/A

1N/A if( $addoptions ) {

1N/A $addoptions .= ',' if $addoptions !~ m/,$/;

1N/A }

1N/A

1N/A if (opt(testsuite)) {

1N/A my $bo = join '', @begin_output;

1N/A $bo =~ s/\\/\\\\\\\\/gs;

1N/A $bo =~ s/\n/\\n/gs;

1N/A $bo =~ s/,/\\054/gs;

1N/A # don't look at that: it hurts

1N/A $testsuite = q{-fuse-script-name,-fsave-data,-fsave-sig-hash,}.

1N/A qq[-e"print q{$bo}",] .

1N/A q{-e"open(Test::Builder::TESTOUT\054 '>&STDOUT') or die $!",} .

1N/A q{-e"open(Test::Builder::TESTERR\054 '>&STDERR') or die $!",};

1N/A }

1N/A if (opt(S) || opt(c)) {

1N/A # We need to keep it.

1N/A if (opt(e)) {

1N/A $cfile = "a.out.c";

1N/A } else {

1N/A $cfile = $Input;

1N/A # File off extension if present

1N/A # hold on: plx is executable; also, careful of ordering!

1N/A $cfile =~ s/\.(?:p(?:lx|l|h)|m)\z//i;

1N/A $cfile .= ".c";

1N/A $cfile = $Output if opt(c) && $Output =~ /\.c\z/i;

1N/A }

1N/A check_write($cfile);

1N/A } else {

1N/A # Don't need to keep it, be safe with a tempfile.

1N/A $lose = 1;

1N/A ($cfh, $cfile) = tempfile("pccXXXXX", SUFFIX => ".c");

1N/A close $cfh; # See comment just below

1N/A }

1N/A vprint 1, "Writing C on $cfile";

1N/A

1N/A my $max_line_len = '';

1N/A if ($^O eq 'MSWin32' && $Config{cc} =~ /^cl/i) {

1N/A $max_line_len = '-l2000,';

1N/A }

1N/A

1N/A # This has to do the write itself, so we can't keep a lock. Life

1N/A # sucks.

1N/A my $command = "$BinPerl $taint -MO=$Backend,$addoptions$testsuite$max_line_len$stash,-o$cfile $Input";

1N/A vprint 1, "Compiling...";

1N/A vprint 1, "Calling $command";

1N/A

1N/A my ($output_r, $error_r) = spawnit($command);

1N/A my @output = @$output_r;

1N/A my @error = @$error_r;

1N/A

1N/A if (@error && $? != 0) {

1N/A _die("$0: $Input did not compile, which can't happen:\n@error\n");

1N/A }

1N/A

1N/A is_msvc ?

1N/A cc_harness_msvc($cfile,$stash) :

1N/A cc_harness($cfile,$stash) unless opt(c);

1N/A

1N/A if ($lose) {

1N/A vprint 2, "unlinking $cfile";

1N/A unlink $cfile or _die("can't unlink $cfile: $!");

1N/A }

1N/A}

1N/A

1N/Asub cc_harness_msvc {

1N/A my ($cfile,$stash)=@_;

1N/A use ExtUtils::Embed ();

1N/A my $obj = "${Output}.obj";

1N/A my $compile = ExtUtils::Embed::ccopts." -c -Fo$obj $cfile ";

1N/A my $link = "-out:$Output $obj";

1N/A $compile .= " -I".$_ for split /\s+/, opt(I);

1N/A $link .= " -libpath:".$_ for split /\s+/, opt(L);

1N/A my @mods = split /-?u /, $stash;

1N/A $link .= " ".ExtUtils::Embed::ldopts("-std", \@mods);

1N/A $link .= " perl5$Config{PERL_VERSION}.lib kernel32.lib msvcrt.lib";

1N/A vprint 3, "running $Config{cc} $compile";

1N/A system("$Config{cc} $compile");

1N/A vprint 3, "running $Config{ld} $link";

1N/A system("$Config{ld} $link");

1N/A}

1N/A

1N/Asub cc_harness {

1N/A my ($cfile,$stash)=@_;

1N/A use ExtUtils::Embed ();

1N/A my $command = ExtUtils::Embed::ccopts." -o $Output $cfile ";

1N/A $command .= " -I".$_ for split /\s+/, opt(I);

1N/A $command .= " -L".$_ for split /\s+/, opt(L);

1N/A my @mods = split /-?u /, $stash;

1N/A $command .= " ".ExtUtils::Embed::ldopts("-std", \@mods);

1N/A $command .= " -lperl";

1N/A vprint 3, "running $Config{cc} $command";

1N/A system("$Config{cc} $command");

1N/A}

1N/A

1N/Asub yclept {

1N/A my $command = "$^X ";

1N/A

1N/A # DWIM the -I to be Perl, not C, include directories.

1N/A if (opt(I) && $Backend eq "Bytecode") {

1N/A for (split /\s+/, opt(I)) {

1N/A if (-d $_) {

1N/A push @INC, $_;

1N/A } else {

1N/A warn "$0: Include directory $_ not found, skipping\n";

1N/A }

1N/A }

1N/A }

1N/A

1N/A $command .= "-I$_ " for @INC;

1N/A return $command;

1N/A}

1N/A

1N/A{

1N/A my $_stash;

1N/A sub grab_stash {

1N/A

1N/A warn "already called get_stash once" if $_stash;

1N/A

1N/A my $taint = opt(T) ? '-T' :

1N/A opt(t) ? '-t' : '';

1N/A my $command = "$BinPerl $taint -MB::Stash -c $Input";

1N/A # Filename here is perfectly sanitised.

1N/A vprint 3, "Calling $command\n";

1N/A

1N/A my ($stash_r, $error_r) = spawnit($command);

1N/A my @stash = @$stash_r;

1N/A my @error = @$error_r;

1N/A

1N/A if (@error && $? != 0) {

1N/A _die("$0: $Input did not compile:\n@error\n");

1N/A }

1N/A

1N/A # band-aid for modules with noisy BEGIN {}

1N/A foreach my $i ( @stash ) {

1N/A $i =~ m/-u(?:[\w:]+|\<none\>)$/ and $stash[0] = $i and next;

1N/A push @begin_output, $i;

1N/A }

1N/A chomp $stash[0];

1N/A $stash[0] =~ s/,-u\<none\>//;

1N/A $stash[0] =~ s/^.*?-u/-u/s;

1N/A vprint 2, "Stash: ", join " ", split /,?-u/, $stash[0];

1N/A chomp $stash[0];

1N/A return $_stash = $stash[0];

1N/A }

1N/A

1N/A}

1N/A

1N/Asub checkopts_byte {

1N/A

1N/A _die("$0: Please choose one of either -B and -O.\n") if opt(O);

1N/A

1N/A if (opt(shared)) {

1N/A warn "$0: Will not create a shared library for bytecode\n";

1N/A delete $Options->{shared};

1N/A }

1N/A

1N/A for my $o ( qw[c S] ) {

1N/A if (opt($o)) {

1N/A warn "$0: Compiling to bytecode is a one-pass process--",

1N/A "-$o ignored\n";

1N/A delete $Options->{$o};

1N/A }

1N/A }

1N/A

1N/A}

1N/A

1N/Asub sanity_check {

1N/A if ($Input eq $Output) {

1N/A if ($Input eq 'a.out') {

1N/A _die("$0: Compiling a.out is probably not what you want to do.\n");

1N/A # You fully deserve what you get now. No you *don't*. typos happen.

1N/A } else {

1N/A warn "$0: Will not write output on top of input file, ",

1N/A "compiling to a.out instead\n";

1N/A $Output = "a.out";

1N/A }

1N/A }

1N/A}

1N/A

1N/Asub check_read {

1N/A my $file = shift;

1N/A unless (-r $file) {

1N/A _die("$0: Input file $file is a directory, not a file\n") if -d _;

1N/A unless (-e _) {

1N/A _die("$0: Input file $file was not found\n");

1N/A } else {

1N/A _die("$0: Cannot read input file $file: $!\n");

1N/A }

1N/A }

1N/A unless (-f _) {

1N/A # XXX: die? don't try this on /dev/tty

1N/A warn "$0: WARNING: input $file is not a plain file\n";

1N/A }

1N/A}

1N/A

1N/Asub check_write {

1N/A my $file = shift;

1N/A if (-d $file) {

1N/A _die("$0: Cannot write on $file, is a directory\n");

1N/A }

1N/A if (-e _) {

1N/A _die("$0: Cannot write on $file: $!\n") unless -w _;

1N/A }

1N/A unless (-w cwd()) {

1N/A _die("$0: Cannot write in this directory: $!\n");

1N/A }

1N/A}

1N/A

1N/Asub check_perl {

1N/A my $file = shift;

1N/A unless (-T $file) {

1N/A warn "$0: Binary `$file' sure doesn't smell like perl source!\n";

1N/A print "Checking file type... ";

1N/A system("file", $file);

1N/A _die("Please try a perlier file!\n");

1N/A }

1N/A

1N/A open(my $handle, "<", $file) or _die("XXX: can't open $file: $!");

1N/A local $_ = <$handle>;

1N/A if (/^#!/ && !/perl/) {

1N/A _die("$0: $file is a ", /^#!\s*(\S+)/, " script, not perl\n");

1N/A }

1N/A

1N/A}

1N/A

1N/Asub spawnit {

1N/A my ($command) = shift;

1N/A my (@error,@output);

1N/A my $errname;

1N/A (undef, $errname) = tempfile("pccXXXXX");

1N/A {

1N/A open (S_OUT, "$command 2>$errname |")

1N/A or _die("$0: Couldn't spawn the compiler.\n");

1N/A @output = <S_OUT>;

1N/A }

1N/A open (S_ERROR, $errname) or _die("$0: Couldn't read the error file.\n");

1N/A @error = <S_ERROR>;

1N/A close S_ERROR;

1N/A close S_OUT;

1N/A unlink $errname or _die("$0: Can't unlink error file $errname");

1N/A return (\@output, \@error);

1N/A}

1N/A

1N/Asub helpme {

1N/A print "perlcc compiler frontend, version $VERSION\n\n";

1N/A { no warnings;

1N/A exec "pod2usage $0";

1N/A exec "perldoc $0";

1N/A exec "pod2text $0";

1N/A }

1N/A}

1N/A

1N/Asub relativize {

1N/A my ($args) = @_;

1N/A

1N/A return() if ($args =~ m"^[/\\]");

1N/A return("./$args");

1N/A}

1N/A

1N/Asub _die {

1N/A $logfh->print(@_) if opt('log');

1N/A print STDERR @_;

1N/A exit(); # should die eventually. However, needed so that a 'make compile'

1N/A # can compile all the way through to the end for standard dist.

1N/A}

1N/A

1N/Asub _usage_and_die {

1N/A _die(<<EOU);

1N/A$0: Usage:

1N/A$0 [-o executable] [-r] [-O|-B|-c|-S] [-I /foo] [-L /foo] [-log log] [source[.pl] | -e oneliner]

1N/A}

1N/A

1N/Asub run {

1N/A my (@commands) = @_;

1N/A

1N/A print interruptrun(@commands) if (!opt('log'));

1N/A $logfh->print(interruptrun(@commands)) if (opt('log'));

1N/A}

1N/A

1N/Asub interruptrun

1N/A{

1N/A my (@commands) = @_;

1N/A

1N/A my $command = join('', @commands);

1N/A local(*FD);

1N/A my $pid = open(FD, "$command |");

1N/A my $text;

1N/A

1N/A local($SIG{HUP}) = sub { kill 9, $pid; exit };

1N/A local($SIG{INT}) = sub { kill 9, $pid; exit };

1N/A

1N/A my $needalarm =

1N/A ($ENV{PERLCC_TIMEOUT} &&

1N/A $Config{'osname'} ne 'MSWin32' &&

1N/A $command =~ m"(^|\s)perlcc\s");

1N/A

1N/A eval

1N/A {

1N/A local($SIG{ALRM}) = sub { die "INFINITE LOOP"; };

1N/A alarm($ENV{PERLCC_TIMEOUT}) if ($needalarm);

1N/A $text = join('', <FD>);

1N/A alarm(0) if ($needalarm);

1N/A };

1N/A

1N/A if ($@)

1N/A {

1N/A eval { kill 'HUP', $pid };

1N/A vprint 0, "SYSTEM TIMEOUT (infinite loop?)\n";

1N/A }

1N/A

1N/A close(FD);

1N/A return($text);

1N/A}

1N/A

1N/Asub is_win32() { $^O =~ m/^MSWin/ }

1N/Asub is_msvc() { is_win32 && $Config{cc} =~ m/^cl/i }

1N/A

1N/AEND {

1N/A unlink $cfile if ($cfile && !opt(S) && !opt(c));

1N/A}

1N/A

1N/A

1N/A

1N/A!NO!SUBS!

1N/A

1N/Aclose OUT or die "Can't close $file: $!";

1N/Achmod 0755, $file or die "Can't reset permissions for $file: $!\n";

1N/Aexec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';

1N/Achdir $origdir;