#!/usr/local/cpanel/3rdparty/perl/536/bin/perl
eval 'exec /usr/local/cpanel/3rdparty/perl/536/bin/perl -S $0 ${1+"$@"}'
if $running_under_some_shell;
--$running_under_some_shell;
# Version 2.0, Simon Cozens, Thu Mar 30 17:52:45 JST 2000
# Version 2.01, Tom Christiansen, Thu Mar 30 08:25:14 MST 2000
# Version 2.02, Simon Cozens, Sun Apr 16 01:53:36 JST 2000
# Version 2.03, Edward Peschko, Mon Feb 26 12:04:17 PST 2001
# Version 2.04, Enache Adrian, Fri, 18 Jul 2003 23:15:37 +0300
# Version 2.05, Reini Urban, 2009-12-01 00:00:13
# Version 2.06, Reini Urban, 2009-12-28 21:56:15
# Version 2.07, Reini Urban, 2010-06-30 22:32:20
# Version 2.08, Reini Urban, 2010-07-30 21:30:33
# Version 2.09, Reini Urban, 2010-10-11 13:54:52
# Version 2.10, Reini Urban, 2011-02-11 22:58:37
# Version 2.11, Reini Urban, 2011-04-11 20:16:00
# Version 2.12, Reini Urban, 2011-10-02 05:19:00
# Version 2.13, Reini Urban, 2012-01-10 13:03:00
# Version 2.14, Reini Urban, 2012-02-28 09:04:07
# Version 2.15, Reini Urban, 2013-02-01 10:41:54
# Version 2.16, Reini Urban, 2013-11-27 11:36:13
# Version 2.17, Reini Urban, Thu Feb 6 14:04:29 2014 -0600
# Version 2.18, Reini Urban, 2014-05-28
# Version 2.19, Reini Urban, 2014-07-09
# Version 2.20, Reini Urban, 2014-07-23
use strict;
use warnings;
use 5.006_000;
use FileHandle;
use Config;
use Fcntl qw(:DEFAULT :flock);
use File::Temp qw(tempfile);
use File::Basename qw(basename dirname);
# use Cwd;
use Pod::Usage;
use constant MINIMUM_VERBOSE_LEVEL => 1;
# Time::HiRes does not work with 5.6
# use Time::HiRes qw(gettimeofday tv_interval);
our $VERSION = 2.20;
$| = 1;
eval { require B::C::Flags; };
$SIG{INT} = sub { exit(); }
if exists $SIG{INT}; # exit gracefully and clean up after ourselves.
use subs qw{
cc_harness check_read check_write checkopts_byte choose_backend
compile_byte compile_cstyle compile_module generate_code
grab_stash parse_argv sanity_check vprint yclept spawnit
gettimeofday tv_interval vsystem
};
sub opt(*); # imal quoting
our ( $Options, $BinPerl, $Backend );
our ( $Input => $Output );
our ($logfh);
our ($cfile);
our (@begin_output); # output from BEGIN {}, for testsuite
our ($extra_libs);
# eval { main(); 1 } or die;
main();
sub main {
parse_argv();
check_write($Output);
choose_backend();
generate_code();
run_code();
_die("Not reached?");
}
#######################################################################
sub choose_backend {
# Choose the backend.
$Backend = 'C';
if ( opt('B') ) {
checkopts_byte();
$Backend = 'Bytecode';
}
if ( opt('S') && opt('c') ) {
# die "$0: Do you want me to compile this or not?\n";
delete $Options->{S};
}
$Backend = 'CC' if opt('O');
}
sub generate_code {
vprint 4, "Compiling $Input";
$BinPerl = yclept(); # Calling convention for perl.
if ( exists $Options->{m} ) {
compile_module();
}
else {
if ( $Backend eq 'Bytecode' ) {
compile_byte();
}
else {
compile_cstyle();
}
}
exit(0) if ( !opt('r') );
}
sub run_code {
if ( $Backend eq 'Bytecode' ) {
if ( $] < 5.007 ) {
$Output = "$BinPerl -MByteLoader $Output";
}
else {
$Output = "$BinPerl $Output";
}
}
if ($extra_libs) {
my $path = '';
my $PATHSEP = ':';
for ( split / /, $extra_libs ) {
s{/[^/]+$}{};
# XXX qx quote?
$path .= $PATHSEP . $_ if $_;
}
if ( $^O ne 'darwin' ) {
$ENV{LD_LIBRARY_PATH} .= $path;
vprint 0, "LD_LIBRARY_PATH=\$LD_LIBRARY_PATH$path";
}
}
vprint 0, "Running code $Output @ARGV";
system( join( " ", $Output, @ARGV ) );
exit(0);
}
# usage: vprint [level] msg args
sub vprint {
my $level;
if ( @_ == 1 ) {
$level = 1;
}
elsif ( $_[0] =~ /^-?\d$/ ) {
$level = shift;
}
else {
# well, they forgot to use a number; means >0
$level = 0;
}
my $msg = "@_";
$msg .= "\n" unless substr( $msg, -1 ) eq "\n";
if ( opt('v') > $level ) {
if ( opt('log') ) {
print $logfh "$0: $msg";
}
else {
print "$0: $msg";
}
}
}
sub vsystem {
if ( opt('dryrun') ) {
print "@_\n";
}
else {
system(@_);
}
}
sub parse_argv {
use Getopt::Long;
# disallows using long arguments
Getopt::Long::Configure("bundling");
Getopt::Long::Configure("no_ignore_case");
# no difference in exists and defined for %ENV; also, a "0"
# argument or a "" would not help cc, so skip
unshift @ARGV, split ' ', $ENV{PERLCC_OPTS} if $ENV{PERLCC_OPTS};
$Options = {};
# support single dash -Wb. GetOptions requires --Wb with bundling enabled.
if ( my ($wb) = grep /^-Wb=.+/, @ARGV ) {
$Options->{Wb} = $Options->{Wb} ? $Options->{Wb} . "," . substr( $wb, 4 ) : substr( $wb, 4 );
@ARGV = grep !/^-Wb=(.+)/, @ARGV;
}
# -O2 i.e. -Wb=-O1 (new since 2.13)
if ( my ($o1) = grep /^-O(\d)$/, @ARGV ) {
$Options->{Wb} = $Options->{Wb} ? $Options->{Wb} . ",$o1" : $o1;
@ARGV = grep !/^-O\d$/, @ARGV;
}
if ( my ($v) = grep /^-v\d?$/a, @ARGV ) {
$v =~ s{^-v}{};
$v = 1 unless length $v;
$Options->{v} = 0 + $v;
@ARGV = grep !/^-v\d?$/a, @ARGV;
}
if ( grep /^-stash$/, @ARGV ) {
$Options->{stash}++;
@ARGV = grep !/^-stash$/, @ARGV;
}
$Options->{spawn} = 1;
Getopt::Long::GetOptions(
$Options,
'L=s', # lib directory
'I=s', # include directories (FOR C, NOT FOR PERL)
'o=s', # Output executable
'v:i', # Verbosity level
'e=s', # One-liner
'm|sharedlib:s', # as Module [name] (new since 2.11, not yet tested)
'r', # run resulting executable
'B', # Byte compiler backend
'O', # Optimised C backend B::CC
#'O1-4' # alias for -Wb=-O1 (new since 2.13)
'dryrun|n', # only print commands, do not execute
'c', # Compile to C only, no linking
'check', # pass -c to B::C and exit
'g', # -g option for gcc
'help|h', # Help me
'S', # Keep generated C file
'T', # run the backend using perl -T
't', # run the backend using perl -t
'u=s@', # use packages (new since 2.13)
'U=s@', # skip packages (new since 2.13)
'static', # Link to static libperl (default, new since 2.11)
'shared', # Link to shared libperl (new since 2.07)
'sharedxs', # Link shared XSUBs (default, new since 2.07))
'stash', # Detect external packages via B::Stash
'log:s', # where to log compilation process information
'Wb=s', # pass (comma-seperated) options to backend
'f=s@', # pass compiler option(s) to backend (new since 2.14)
'Wc=s', # pass (comma-seperated) options to cc (new since 2.13)
'Wl=s', # pass (comma-seperated) options to ld (new since 2.13)
'spawn!', # --no-spawn (new since 2.12)
'time', # print benchmark timings (new since 2.08)
'version', # (new since 2.13)
'D|d', # short option do not allow extra args
'debug=s', # alias for --Wb=-Dfull and -S to enable all debug and preserve source code
);
$Options->{debug} = '' if $Options->{D}; # when short option is used
if ( defined $Options->{debug} ) {
$Options->{debug} =~ s{^=+}{};
$Options->{debug} = 'full' if !length $Options->{debug} && !$Options->{D};
$Options->{debug} =~ s{,}{.}g; # comma is already used
$Options->{Wb} = $Options->{Wb} ? $Options->{Wb} . ',' : '';
$Options->{Wb} .= '-D' . $Options->{debug};
$Options->{S} = 1;
}
if ( $Options->{'g'} || defined $ENV{BC_CFLAGS} && $ENV{BC_CFLAGS} =~ qr{^-?g$} ) {
vprint 3, q{Using gcc '-g' compilation option.};
$Options->{'g'} = 1;
}
$Options->{v} += 0;
if ( opt('t') && opt('T') ) {
warn "Can't specify both -T and -t, -t ignored";
$Options->{t} = 0;
}
helpme() if opt('help'); # And exit
if ( opt('version') ) {
die version();
}
# $Options->{Wb} .= ",-O1" if opt('O1');
# $Options->{Wb} .= ",-O2" if opt('O2');
# $Options->{Wb} .= ",-O3" if opt('O3');
# $Options->{Wb} .= ",-O4" if opt('O4');
if ( $Options->{time} or $Options->{spawn} ) {
eval { require Time::HiRes; }; # 5.6 has no Time::HiRes
if ($@) {
warn "--time ignored. No Time::HiRes\n" if $Options->{time};
$Options->{time} = 0;
}
else {
*gettimeofday = *Time::HiRes::gettimeofday;
Time::HiRes::gettimeofday();
Time::HiRes->import( 'gettimeofday', 'tv_interval', 'sleep' );
}
}
$logfh = new FileHandle( ">> " . opt('log') ) if ( opt('log') );
if ( opt('e') ) {
warn "$0: using -e 'code' as input file, ignoring @ARGV\n" if @ARGV;
# We don't use a temporary file here; why bother?
# XXX: this is not bullet proof -- spaces or quotes in name!
$Input = "-e '" . opt('e') . "'";
}
else {
$Input = shift @ARGV; # XXX: more files?
_usage_and_die("No input file specified\n") unless $Input;
# DWIM modules. This is bad but necessary.
$Options->{m} = '' if $Input =~ /\.pm\z/ and !opt('m');
vprint 1, "$0: using $Input as input file, ignoring @ARGV\n" if @ARGV;
check_read($Input);
check_perl($Input);
}
if ( opt('o') ) {
$Output = opt('o');
}
elsif ( opt('B') ) {
if ( opt('e') ) {
my $suffix = '.plc';
$suffix = '.pmc' if exists $Options->{m};
( undef, $Output ) = tempfile( "plcXXXXX", SUFFIX => $suffix );
}
else {
$Output = basename($Input) . "c";
}
}
else {
$Output = opt('e') ? 'a.out' : $Input;
$Output =~ s/\.(p[lm]|t)$//;
}
$Output = relativize($Output);
sanity_check();
}
sub opt(*) {
my $opt = shift;
return exists( $Options->{$opt} ) && ( $Options->{$opt} || 0 );
}
sub compile_module {
if ( $Backend eq 'Bytecode' ) {
compile_byte( '-m' . $Options->{m} );
}
else {
compile_cstyle( "-m" . $Options->{m} );
}
}
sub compile_byte {
vprint 3, "Writing B on $Output";
my $opts = $] < 5.007 ? "" : "-H,-s,";
if ( $] >= 5.007 and $Input =~ /^-e/ ) {
$opts = "-H,";
}
if ( @_ == 1 ) {
$opts .= $_[0] . ",";
}
my $addoptions = opt('Wb');
if ($addoptions) {
$opts .= '-v,' if opt('v') > 4;
$opts .= '-DM,-DG,-DA,-DComment,' if opt('v') > 5;
$opts .= "$addoptions,";
}
elsif ( opt('v') > 4 ) {
$opts .= '-v,';
$opts .= '-DM,-DG,-DA,-DComment,' if opt('v') > 5;
}
my $command = "$BinPerl -MO=Bytecode,$opts-o$Output $Input";
$Input =~ s/^-e.*$/-e/;
vprint 5, "Compiling...";
$command =~ s/\s\s+|\t/ /g;
vprint 0, "Calling $command";
my $t0 = [gettimeofday] if opt('time');
my ( $output_r, $error_r, $errcode ) = spawnit($command);
my $elapsed = tv_interval($t0) if opt('time');
vprint -1, "c time: $elapsed" if opt('time');
if ( @$error_r && $errcode != 0 ) {
_die("$Input did not compile $errcode:\n@$error_r\n");
}
else {
my @error = grep { !/^$Input syntax OK$/o } @$error_r;
@error = grep { !/^No package specified for compilation, assuming main::$/o } @error;
warn "$0: Unexpected compiler output\n@error" if @error and opt('v') < MINIMUM_VERBOSE_LEVEL();
warn "@error\n" if @error and opt('v') >= MINIMUM_VERBOSE_LEVEL();
}
unless ( opt('dryrun') ) {
chmod 0777 & ~umask, $Output or _die("can't chmod $Output: $!\n");
}
}
sub compile_cstyle {
adjust_options_for_B_dependency( $Input, $Options ); # these are global variables...
my $stash = opt('stash') ? grab_stash() : "";
$stash .= "," if $stash; #stash can be empty
$stash .= "-u$_," for @{ $Options->{u} };
$stash .= "-U$_," for @{ $Options->{U} };
my $taint = opt('T') ? ' -T' : opt('t') ? ' -t' : '';
# What are we going to call our output C file?
my $lose = 0;
my ($cfh);
my $addoptions = '';
if ( @_ == 1 ) {
$addoptions .= $_[0] . ",";
}
$addoptions .= opt('Wb');
$addoptions .= ',' if length $addoptions && substr( $addoptions, -1, 1 ) ne ',';
if ( opt('v') >= 1 && opt('v') <= 4 ) {
$addoptions .= '-v';
}
elsif ( opt('v') == 5 ) {
$addoptions .= '-Dsp,-v';
}
elsif ( opt('v') >= 6 ) {
$addoptions .= '-Dfull';
}
$addoptions .= ',' if length $addoptions && substr( $addoptions, -1, 1 ) ne ',';
if ( opt('f') ) {
$addoptions .= "-f$_," for @{ $Options->{f} };
}
if ( opt('check') ) {
$addoptions .= "-c,";
}
warn "Warning: staticxs on darwin is very experimental\n"
if $^O eq 'darwin';
if ( opt('check') ) {
$cfile = "";
}
elsif ( opt('o') ) {
$cfile = opt('o') . ".c";
}
elsif ( opt('S') || opt('c') ) { # We need to keep it
if ( opt('e') ) {
$cfile = $Output;
$cfile .= '.c';
}
else {
$cfile = basename($Input);
# File off extension if present
# hold on: plx is executable; also, careful of ordering!
$cfile =~ s/\.(?:p(?:lx|l|h)|m)\z//i;
$cfile .= ".c";
$cfile = $Output if opt('c') && $Output =~ /\.c\z/i;
}
check_write($cfile);
}
else { # Do not keep tempfiles (no -S nor -c nor -o)
$lose = 1;
( $cfh, $cfile ) = tempfile( "pccXXXXX", SUFFIX => ".c" );
close $cfh; # See comment just below
}
vprint 3, "Writing C on $cfile" unless opt('check');
foreach my $toclean ( $cfile, $cfile . ".lst" ) {
unlink($toclean) if -e $toclean;
}
my $max_line_len = '';
my $options = "$addoptions$max_line_len$stash";
$options .= "-o$cfile" unless opt('check');
$options = substr( $options, 0, -1 ) if substr( $options, -1, 1 ) eq ",";
# This has to do the write itself, so we can't keep a lock. Life
# sucks.
my $command = "$BinPerl$taint -MO=$Backend,$options $Input";
vprint 5, "Compiling...";
$command =~ s/\s\s+|\t/ /g;
vprint 0, "Calling $command";
my $t0 = [gettimeofday] if opt('time');
my ( $output_r, $error_r, $errcode ) = spawnit($command);
my $elapsed = tv_interval($t0) if opt('time');
my @output = @$output_r;
my @error = @$error_r;
if ( $errcode != 0 ) {
_die("$Input did not compile, which can't happen $errcode:\n@error\n");
}
else {
my $i = substr( $Input, 0, 2 ) eq '-e' ? '-e' : $Input;
@error = grep { !/^$i syntax OK$/o } @error;
if ( opt('check') ) {
print "@error" if @error;
}
else {
warn "$0: Unexpected compiler output\n@error" if @error and opt('v') < MINIMUM_VERBOSE_LEVEL;
warn "@error\n" if @error and opt('v') >= MINIMUM_VERBOSE_LEVEL;
}
}
_die(qq[Failed to generate .c file '$cfile'\n]) unless -e $cfile && -s $cfile;
vprint -1, "c time: $elapsed" if opt('time');
$extra_libs = '';
my %rpath;
if ( open( XS, "<", $cfile . ".lst" ) ) {
while (<XS>) {
my ( $s, $l ) = m/^([^\t]+)(.*)$/;
next if grep { $s eq $_ } @{ $Options->{U} };
$stash .= ",-u$s";
if ($l) {
$l = substr( $l, 1 );
if ( $^O eq 'darwin' and $l =~ /\.bundle$/ ) {
my $ofile = $l;
$ofile =~ s/\.bundle$/.o/;
$ofile =~ s{^.*/auto/}{};
$ofile =~ s{(.*)/[^/]+\.o}{$1.o};
$ofile =~ s{/}{_}g;
$ofile = 'pcc' . $ofile;
if ( -e $ofile ) {
vprint 3, "Using " . $ofile;
}
else {
vprint 3, "Creating " . $ofile;
# This fails sometimes
my $cmd = "otool -tv $l | \"$^X\" -pe " . q{'s{^/}{# .file /};s/^00[0-9a-f]+\s/\t/;s/^\(__(\w+)(,__.*?)?\) section/q(.).lc($1)/e'} . " | as -o \"$ofile\"";
vprint 3, $cmd;
vsystem($cmd);
}
$extra_libs .= " " . $l if -e $ofile;
}
else {
$extra_libs .= " " . $l;
$rpath{ dirname($l) }++;
}
}
}
close XS;
my ($rpath) = $Config{ccdlflags} =~ /^(.+rpath,)/;
($rpath) = $Config{ccdlflags} =~ m{^(.+-R,)/} unless $rpath;
if ( !$rpath and $Config{gccversion} ) {
$rpath = '-Wl,-rpath,';
}
$rpath =~ s/^-Wl,-E// if $rpath; # already done via ccdlflags
# $extra_libs .= " $rpath".join(" ".$rpath,keys %rpath) if $rpath and %rpath;
vprint 4, "staticxs: $stash $extra_libs";
}
exit if opt('check');
$t0 = [gettimeofday] if opt('time');
cc_harness( $cfile, $stash, $extra_libs ) unless opt('c');
$elapsed = tv_interval($t0) if opt('time');
vprint -1, "cc time: $elapsed" if opt('time');
if ( $lose and -s $Output ) {
vprint 3, "Unlinking $cfile";
unlink $cfile or _die("can't unlink $cfile: $!\n");
}
}
sub cc_harness {
my ( $cfile, $stash, $extra_libs ) = @_;
use ExtUtils::Embed ();
my $command = ExtUtils::Embed::ccopts . " -o $Output $cfile ";
$command =~ s/\s-pipe\s/ /; # Strip -pipe out of the compile flags so less memory is used building binaries
$command .= $B::C::Flags::extra_cflags if $B::C::Flags::extra_cflags;
$command .= " -I" . $_ for split /\s+/, opt('I');
$command .= " -L" . $_ for split /\s+/, opt('L');
$command .= " " . opt('Wc') if opt('Wc');
my $ccflags = $command;
my $useshrplib = $Config{useshrplib};
_die("--sharedxs with useshrplib=false\n") if !$useshrplib and opt('sharedxs');
my $ldopts;
if ($stash) {
my @mods = split /,?-?u/, $stash; # XXX -U stashes
$ldopts = ExtUtils::Embed::ldopts( "-std", \@mods );
}
else {
$ldopts = ExtUtils::Embed::ldopts("-std");
}
$ldopts .= " " . opt('Wl') if opt('Wl');
# gcc crashes with this duplicate -fstack-protector arg
my $ldflags = $Config{ldflags};
my $libperl = $Config{libperl};
my $libdir = $Config{prefix} . "/lib";
my $coredir = $ENV{PERL_SRC} || $Config{archlib} . "/CORE";
if ($extra_libs) {
# splice extra_libs after $Config{ldopts} before @archives
my $i_ldopts = index( $ldopts, $ldflags );
if ( $ldflags and $i_ldopts >= 0 ) {
my $l = $i_ldopts + length($ldflags);
$ldopts = substr( $ldopts, 0, $l ) . $extra_libs . " " . substr( $ldopts, $l );
}
else {
$ldopts = $extra_libs . " " . $ldopts;
}
}
if ( opt('shared') ) {
warn "--shared with useshrplib=false might not work\n" unless $useshrplib;
my @plibs = ( $libperl, "$coredir/$libperl", "$libdir/$libperl" );
if ( $libperl !~ /$Config{dlext}$/ ) {
$libperl = "libperl." . $Config{dlext};
@plibs = ( $libperl, "$coredir/$libperl", "$libdir/$libperl" );
push @plibs, glob "$coredir/*perl5*" . $Config{dlext};
push @plibs, glob "$coredir/*perl." . $Config{dlext};
push @plibs, glob $libdir . "/*perl5*." . $Config{dlext};
push @plibs, glob $libdir . "/*perl." . $Config{dlext};
push @plibs, glob $Config{bin} . "/perl*." . $Config{dlext};
}
for my $lib (@plibs) {
if ( -e $lib ) {
$ldopts =~ s|-lperl |$lib |;
$ldopts =~ s|\s+\S+libperl\w+\.a | $lib |;
$ldopts = "$coredir/DynaLoader.o $ldopts" if -e "$coredir/DynaLoader.o";
last;
}
}
}
elsif ( opt('static') ) {
for my $lib (
$libperl, "$coredir/$libperl", "$coredir/$libperl",
"$coredir/libperl.a", "$libdir/libperl.a"
) {
if ( -e $lib ) {
$ldopts =~ s|-lperl |$lib |;
$ldopts = "$coredir/DynaLoader.o $ldopts" if -e "$coredir/DynaLoader.o";
last;
}
}
}
else {
if ( $useshrplib and -e $libdir . "/" . $Config{libperl} ) {
# debian: only /usr/lib/libperl.so.5.10.1 and broken ExtUtils::Embed::ldopts
$ldopts =~ s|-lperl |$libdir/$Config{libperl} |;
}
if ( $useshrplib and -e $coredir . "/" . $Config{libperl} ) {
# help cygwin debugging, and workaround wrong debian linker prefs (/usr/lib before given -L)
$ldopts =~ s|-lperl |$coredir/$Config{libperl} |;
}
}
$ldopts .= " -lperl" unless $command =~ /perl/;
$command .= " " . $ldopts;
$command .= $B::C::Flags::extra_libs if $B::C::Flags::extra_libs;
$command = q{-g } . $command if $Options->{'g'};
my $gcc = get_gcc();
$command =~ s/\s\s+|\t/ /g;
vprint 3, "Calling $gcc $command";
vsystem("$gcc $command");
_die(qq[Failed to run gcc: $gcc $command\n]) unless $? == 0;
return;
}
{
my $GCC; # state variable
sub get_gcc {
if ( !defined $GCC ) {
$GCC = qx{which gcc};
chomp $GCC;
$GCC = '' unless -x $GCC;
}
return $GCC if length $GCC;
return $Config{cc};
}
}
# Where Perl is, and which include path to give it.
sub yclept {
my $command = $^X =~ m/\s/ ? qq{"$^X"} : $^X;
# DWIM the -I to be Perl, not C, include directories.
if ( opt('I') && $Backend eq "Bytecode" ) {
for ( split /\s+/, opt('I') ) {
if ( -d $_ ) {
push @INC, $_;
}
else {
warn "$0: Include directory $_ not found, skipping\n";
}
}
}
my %OINC;
$OINC{ $Config{$_} }++ for (qw(privlib archlib sitelib sitearch vendorlib vendorarch));
$OINC{'.'}++ unless ${^TAINT};
$OINC{$_}++ for split ':', $Config{otherlibdirs};
if ( my $incver = $Config{inc_version_list} ) {
my $incpre = dirname( $Config{sitelib} );
$OINC{$_}++ for map { File::Spec->catdir( $incpre, $_ ) } split( ' ', $incver );
$OINC{$incpre}++;
}
return $command;
}
# Use B::Stash to find additional modules and stuff.
{
my $_stash;
sub grab_stash {
warn "already called grab_stash once" if $_stash;
my $taint =
opt('T') ? ' -T'
: opt('t') ? ' -t'
: '';
my $command = "$BinPerl$taint -MB::Stash -c $Input";
# Filename here is perfectly sanitised.
$command =~ s/\s\s+|\t/ /g;
vprint 3, "Calling $command\n";
my ( $stash_r, $error_r, $errcode ) = spawnit($command);
my @stash = @$stash_r;
my @error = @$error_r;
if ( @error && $errcode != 0 ) {
_die("$Input did not compile $errcode:\n@error\n");
}
# band-aid for modules with noisy BEGIN {}
foreach my $i (@stash) {
$i =~ m/-[ux](?:[\w:]+|\<none\>)$/ and $stash[0] = $i and next;
push @begin_output, $i;
}
chomp $stash[0];
$stash[0] =~ s/,-[ux]\<none\>//;
$stash[0] =~ s/^.*?-([ux])/-$1/s;
vprint 2, "Stash: ", join " ", split /,?-[ux]/, $stash[0];
chomp $stash[0];
return $_stash = $stash[0];
}
}
{
# check if B is required or not: when B is not in the program dependencies then add -UB
sub adjust_options_for_B_dependency {
my ( $input, $opts ) = @_; # do not use the global variables directly
# preserve custom choice when passing B as -u ot -U
return if grep { $_ eq 'B' } @{ $opts->{u} }, @{ $opts->{U} };
local ( $?, $! ); # if not localized this is going to fail later....
my $perl_program;
if ( my $opt_e_value = opt('e') ) { # could also reparse input, but use the raw value
( undef, $perl_program ) = tempfile( "tmp-bc-check-B-XXXXXXXX", SUFFIX => '.pl', UNLINK => 1 );
open my $tmp, '>', $perl_program or die "Cannot open $perl_program: $!";
print {$tmp} "#!$^X\n\n";
print {$tmp} $opt_e_value;
print {$tmp} "\n";
close $tmp;
}
else { # -f $input
$perl_program = $input;
}
# do a first check to see if you can use our module
my $check = qx{$^X -c $perl_program 2>&1};
my $status = $?;
if ( $status != 0 ) {
vprint 2, "Program do not pass 'perl -c' check";
vprint 4, $check;
return;
}
# now check if B is used
$check = qx{$^X -MB::C::IsUsingModule=B -c $perl_program 2>&1};
$status = $?;
vprint 4, '-MB::C::IsUsingModule=B -c', $status;
# $? => 0 if B is used ; 1 if B is not used
if ( $status == 0 ) {
vprint 3, "B is used by the program";
#push @{ $opts->{u} }, 'B'; # not really needed
}
else {
vprint 3, "B is not used by the program: adding -UB to skip it";
push @{ $opts->{U} }, 'B';
}
}
return;
}
# Check the consistency of options if -B is selected.
# To wit, (-B|-O) ==> no -shared, no -S, no -c
sub checkopts_byte {
_die("Please choose one of either -B and -O.\n") if opt('O');
for my $o (qw[shared sharedxs static]) {
if ( exists( $Options->{$o} ) && $Options->{$o} ) {
warn "$0: --$o incompatible with -B\n";
delete $Options->{$o};
}
}
# TODO make -S produce an .asm also?
for my $o (qw[c S]) {
if ( exists( $Options->{$o} ) && $Options->{$o} ) {
warn "$0: Compiling to bytecode is a one-pass process. ", "-$o ignored\n";
delete $Options->{$o};
}
}
}
# Check the input and output files make sense, are read/writeable.
sub sanity_check {
if ( $Input eq $Output ) {
if ( $Input eq 'a.out' ) {
_die("Compiling a.out is probably not what you want to do.\n");
# You fully deserve what you get now. No you *don't*. typos happen.
}
else {
my $suffix = '';
( undef, $Output ) = tempfile( "plcXXXXX", SUFFIX => $suffix );
warn "$0: Will not write output on top of input file, ", "compiling to $Output instead\n";
}
}
}
sub check_read {
my $file = shift;
unless ( -r $file ) {
_die("Input file $file is a directory, not a file\n") if -d _;
unless ( -e _ ) {
_die("Input file $file was not found\n");
}
else {
_die("Cannot read input file $file: $!\n");
}
}
unless ( -f _ ) {
# XXX: die? don't try this on /dev/tty
warn "$0: WARNING: input $file is not a plain file\n";
}
}
sub check_write {
my $file = shift;
if ( -d $file ) {
_die("Cannot write on $file, is a directory\n");
}
if ( -e _ ) {
_die("Cannot write on $file: $!\n") unless -w _;
}
unless ( -w '.' ) {
_die("Cannot write in this directory: $!\n");
}
}
sub check_perl {
my $file = shift;
if ( !-T $file && !$ENV{SKIP_CHECK_PERL} ) {
warn "$0: Binary `$file' sure doesn't smell like perl source!\n";
print "Checking file type... ";
vsystem( "file", $file );
_die("Please try a perlier file!\n");
}
open( my $handle, "<", $file ) or _die("Can't open $file: $!\n");
local $_ = <$handle>;
if ( /^#!/ && !/perl/ ) {
_die( "$file is a ", /^#!\s*(\S+)/, " script, not perl\n" );
}
}
# File spawning and error collecting
sub spawnit {
my $command = shift;
my ( @error, @output, $errname, $errcode );
if ( opt('dryrun') ) {
print "$command\n";
}
elsif ( $Options->{spawn} ) {
( undef, $errname ) = tempfile("pccXXXXX");
{
my $pid = open( S_OUT, "$command 2>$errname |" )
or _die("Couldn't spawn the compiler.\n");
$errcode = $?;
my $kid;
do {
$kid = waitpid( $pid, 0 );
} while $kid > 0;
@output = <S_OUT>;
}
open( S_ERROR, $errname ) or _die("Couldn't read the error file.\n");
@error = <S_ERROR>;
close S_ERROR;
close S_OUT;
unlink $errname or _die("Can't unlink error file $errname\n");
}
else {
@output = split /\n/, `$command`;
}
return ( \@output, \@error, $errcode );
}
sub version {
require B::C::Flags;
no warnings 'once';
my $BC_VERSION = $B::C::Flags::VERSION . $B::C::REVISION;
return "perlcc $VERSION, B-C-${BC_VERSION} built for $Config{perlpath} $Config{archname}\n";
}
sub helpme {
print version(), "\n";
if ( opt('v') ) {
pod2usage( -verbose => opt('v') );
}
else {
pod2usage( -verbose => 0 );
}
}
sub relativize {
my ($args) = @_;
return ( "./" . basename($args) ) if ( $args =~ m"^[/\\]" );
return ("./$args");
}
sub _die {
my @args = ( "$0: ", @_ );
$logfh->print(@args) if opt('log');
print STDERR @args;
exit(); # should die eventually. However, needed so that a 'make compile'
# can compile all the way through to the end for standard dist.
}
sub _usage_and_die {
_die(<<EOU);
Usage:
$0 [-o executable] [-h][-r] [-O|-B|-c|-S] [-I /foo] [-L /foo] [--log log] [source[.pl] | -e code]
More options (see perldoc perlcc)
-v[1-4]
--stash --shared --static
--time
EOU
}
sub run {
my (@commands) = @_;
my $t0 = [gettimeofday] if opt('time');
if ( !opt('log') ) {
print interruptrun(@commands);
}
else {
$logfh->print( interruptrun(@commands) );
}
my $elapsed = tv_interval($t0) if opt('time');
vprint -1, "r time: $elapsed" if opt('time');
}
sub interruptrun {
my (@commands) = @_;
my $command = join( '', @commands );
local (*FD);
my $pid = open( FD, "$command |" );
my $text;
local ( $SIG{HUP}, $SIG{INT} ) if exists $SIG{HUP};
$SIG{HUP} = $SIG{INT} = sub { kill 9, $pid; exit }
if exists $SIG{HUP};
my $needalarm =
( $ENV{PERLCC_TIMEOUT} && exists $SIG{ALRM} && $command =~ m"(^|\s)perlcc\s" );
eval {
local ( $SIG{ALRM} ) =
sub { die "INFINITE LOOP"; }
if exists $SIG{ALRM};
alarm( $ENV{PERLCC_TIMEOUT} ) if $needalarm;
$text = join( '', <FD> );
alarm(0) if $needalarm;
};
if ($@) {
eval { kill 'HUP', $pid };
vprint 0, "SYSTEM TIMEOUT (infinite loop?)\n";
}
close(FD);
return ($text);
}
END {
if ( $cfile && !opt('S') && !opt('c') && -e $cfile ) {
vprint 4, "Unlinking $cfile";
unlink $cfile;
}
if ( defined $cfile && !opt('S') ) {
vprint 4, "Unlinking $cfile.lst";
unlink "$cfile.lst";
}
}
__END__
=head1 NAME
perlcc - generate executables from Perl programs
=head1 SYNOPSIS
perlcc hello.pl # Compiles into executable 'a.out'
perlcc -o hello hello.pl # Compiles into executable 'hello'
perlcc -O file.pl # Compiles using the optimised CC backend
perlcc -O3 file.pl # Compiles with C, using -O3 optimizations
perlcc -B file.pl # Compiles using the bytecode backend
perlcc -B -m file.pm # Compiles a module to file.pmc
perlcc -c file.pl # Creates a C file, 'file.c'
perlcc -S -o hello file.pl # Keep C file
perlcc -c out.c file.pl # Creates a C file, 'out.c' from 'file'
perlcc -r -o hello hello.pl # Compiles,links and runs with XS modules static/dynaloaded
perlcc -e 'print q//' # Compiles a one-liner into 'a.out'
perlcc -c -e 'print q//' # Creates a C file 'a.out.c'
perlcc -I /foo hello # extra headers for C
perlcc -L /foo hello # extra libraries for C
perlcc --Wb=-Dsp # extra perl compiler options
perlcc -fno-delete-pkg # extra perl compiler options
perlcc --Wc=-fno-openmp # extra C compiler options
perlcc --Wl=-s # extra C linker options
perlcc -uIO::Socket # force saving IO::Socket
perlcc -UB # "unuse" B, compile without any B symbols
perlcc -r hello # compiles 'hello' into 'a.out', runs 'a.out'
perlcc -r hello a b c # compiles 'hello' into 'a.out', runs 'a.out'
# with arguments 'a b c'
perlcc hello -log c.log # compiles 'hello' into 'a.out', log into 'c.log'
perlcc -h # help, only SYNOPSIS
perlcc -v2 -h # verbose help, also DESCRIPTION and OPTIONS (use v5 to enable verbose in B::C)
perlcc --version # prints internal perlcc and the B-C release version
=head1 DESCRIPTION
F<perlcc> creates standalone executables from Perl programs, using the
code generators provided by the L<B> module. At present, you may
either create executable Perl bytecode, using the C<-B> option, or
generate and compile C files using the standard and 'optimised' C
backends.
The code generated in this way is not guaranteed to work. The whole
codegen suite (C<perlcc> included) should be considered B<very>
experimental. Use for production purposes is strongly discouraged.
=head1 OPTIONS
=over 4
=item -LI<C library directories>
Adds the given directories to the library search path when C code is
passed to your C compiler.
=item -II<C include directories>
Adds the given directories to the include file search path when C code is
passed to your C compiler; when using the Perl bytecode option, adds the
given directories to Perl's include path.
=item -o I<output file name>
Specifies the file name for the final compiled executable.
Without given output file name we use the base of the input file,
or with C<-e> F<a.out> resp. F<a.exe> and a randomized intermediate
C filename.
If the input file is an absolute path on a non-windows system use
the basename.
=item -c I<C file name>
Create C file only; do not compile and link to a standalone binary.
=item -e I<perl code>
Compile a one-liner, much the same as C<perl -e '...'>
=item --check
Pass -c flag to the backend, prints all backend warnings to STDOUT
and exits before generating and compiling code. Similar to perl -c.
=item -S
"Keep source".
Do not delete generated C code after compilation.
=item -B
Use the Perl bytecode code generator.
=item --debug or -D
Shortcut for --Wb=-Dfull -S
to enable all debug levels and also preserve source code
=item -O
Use the 'optimised' C code generator B::CC. This is more experimental than
everything else put together, and the code created is not guaranteed to
compile in finite time and memory, or indeed, at all.
=item -OI<1-4>
Pass the numeric optimisation option to the compiler backend.
Shortcut for C<-Wb=-On>.
This does not enforce B::CC.
=item -v I<0-6>
Set verbosity of output from 0 to max. 6.
=item -r
Run the resulting compiled script after compiling it.
=item --log I<logfile>
Log the output of compiling to a file rather than to stdout.
=item -f<option> or --f=<option>
Pass the options to the compiler backend, such as
C<-fstash> or C<-fno-delete-pkg>.
=item --Wb=I<options>
Pass the options to the compiler backend, such as C<--Wb=-O2,-v>
=item --Wc=I<options>
Pass comma-seperated options to cc.
=item --Wl=I<options>
Pass comma-seperated options to ld.
=item -T or -t
run the backend using perl -T or -t
=item -u package
Add package(s) to compiler and force linking to it.
=item -U package
Skip package(s). Do not compile and link the package and its sole dependencies.
=item --stash
Detect external packages automatically via B::Stash
=item --static
Link to static libperl.a
=item --shared
Link to shared libperl
=item --sharedxs
Link shared XSUBs if the linker supports it. No DynaLoader needed.
This will still require the shared XSUB libraries to be installed
at the client, modification of @INC in the source is probably required.
(Not yet implemented)
=item -m|--sharedlib [Modulename]
Create a module, resp. a shared library.
Currently only enabled for Bytecode and CC. I<(not yet tested)>
=item --time
Benchmark the different phases B<c> I<(B::* compilation)>,
B<cc> I<(cc compile + link)>, and B<r> (runtime).
=item --no-spawn
Do not spawn subprocesses for compilation, because broken
shells might not be able to kill its children.
=back
=cut
# Local Variables:
# mode: cperl
# cperl-indent-level: 4
# fill-column: 100
# End:
# vim: expandtab shiftwidth=4: