SYN SYN

[p5sagit/p5-mst-13.2.git] / utils / perlcc.PL

#!/usr/local/bin/perl
 
use Config;
use File::Basename qw(&basename &dirname);
use File::Spec;
use Cwd;
 
# List explicitly here the variables you want Configure to
# generate.  Metaconfig only looks for shell variables, so you
# have to mention them as if they were shell variables, not
# %Config entries.  Thus you write
#  $startperl
# to ensure Configure will look for $Config{startperl}.
# Wanted:  $archlibexp
 
# This forces PL files to create target in same directory as PL file.
# This is so that make depend always knows where to find PL derivatives.
$origdir = cwd;
chdir dirname($0);
$file = basename($0, '.PL');
$file .= '.com' if $^O eq 'VMS';
 
open OUT,">$file" or die "Can't create $file: $!";
 
print "Extracting $file (with variable substitutions)\n";
 
# In this section, perl variables will be expanded during extraction.
# You can use $Config{...} to use Configure variables.
 
print OUT <<"!GROK!THIS!";
$Config{startperl}
    eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
    if \$running_under_some_shell;
--\$running_under_some_shell;
!GROK!THIS!
 
# In the following, perl variables are not expanded during extraction.
 
print OUT <<'!NO!SUBS!';

# 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

use strict;
use warnings;
use v5.6.0;

use Config;
use Fcntl qw(:DEFAULT :flock);
use File::Temp qw(tempfile);
use Cwd;
our $VERSION = 2.02;
$| = 1;

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
};
sub opt(*); # imal quoting

our ($Options, $BinPerl, $Backend);
our ($Input => $Output);

# eval { main(); 1 } or die;

main();

sub main { 
    parse_argv();
    check_write($Output);
    choose_backend();
    generate_code();
    die "XXX: Not reached?";
    exit(0);
}

#######################################################################

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 0, "Compiling $Input";

    $BinPerl  = yclept();  # Calling convention for perl.

    if (opt(shared)) {
        compile_module();
    } else {
        if ($Backend eq 'Bytecode') {
            compile_byte();
        } else {
            compile_cstyle();
        }
    }

}

# 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";
    print "$0: $msg" if opt(v) > $level;
} 

sub parse_argv {

    use Getopt::Long; 
    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 = {};
    Getopt::Long::GetOptions( $Options,
        'L:s',          # lib directory
        'I:s',          # include directories (FOR C, NOT FOR PERL)
        'o:s',          # Output executable
        'v+',           # Verbosity level
        'e:s',          # One-liner
        'B',            # Byte compiler backend
        'O',            # Optimised C backend
        'c',            # Compile only
        'h',            # Help me
        'S',            # Dump C files
        's:s',          # Dirty hack to enable -shared/-static
        'shared',       # Create a shared library (--shared for compat.)
    );
        
    # This is an attempt to make perlcc's arg. handling look like cc.
    if ( opt('s') ) {  # must quote: looks like s)foo)bar)!
        if (opt('s') eq 'hared') {
            $Options->{shared}++; 
        } elsif (opt('s') eq 'tatic') {
            $Options->{static}++; 
        } else {
            warn "$0: Unknown option -s", opt('s');
        }
    }

    $Options->{v} += 0;

    helpme() if opt(h); # And exit

    $Output = opt(o) || 'a.out';

    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)."'"; # Quotes eaten by shell
    } else {
        $Input = shift @ARGV;  # XXX: more files?
        die "$0: No input file specified\n" unless $Input;
        # DWIM modules. This is bad but necessary.
        $Options->{shared}++ if $Input =~ /\.pm\z/;
        warn "$0: using $Input as input file, ignoring @ARGV\n" if @ARGV;
        check_read($Input);
        check_perl($Input);
        sanity_check();
    }

}

sub opt(*) {
    my $opt = shift;
    return exists($Options->{$opt}) && ($Options->{$opt} || 0);
} 

sub compile_module { 
    die "$0: Compiling to shared libraries is currently disabled\n";
}

sub compile_byte {
    require ByteLoader;
    my $stash = grab_stash();
    my $command = "$BinPerl -MO=Bytecode,$stash $Input";
    # The -a option means we'd have to close the file and lose the
    # lock, which would create the tiniest of races. Instead, append
    # the output ourselves. 
    vprint 1, "Writing on $Output";

    my $openflags = O_WRONLY | O_CREAT;
    $openflags |= O_BINARY if eval { O_BINARY; 1 };
    $openflags |= O_EXLOCK if eval { O_EXLOCK; 1 };

    # these dies are not "$0: .... \n" because they "can't happen"

    sysopen(OUT, $Output, $openflags)
        or die "can't write to $Output: $!";

    # this is blocking; hold on; why are we doing this??
    # flock OUT, LOCK_EX or die "can't lock $Output: $!"
    #    unless eval { O_EXLOCK; 1 };

    truncate(OUT, 0)
        or die "couldn't trunc $Output: $!";

    print OUT <<EOF;
#!$^X
use ByteLoader $ByteLoader::VERSION;
EOF

    # Now the compile:
    vprint 1, "Compiling...";
    vprint 3, "Calling $command";

    my ($output_r, $error_r) = spawnit($command);

    if (@$error_r && $? != 0) {
	die "$0: $Input did not compile, which can't happen:\n@$error_r\n";
    } else {
	my @error = grep { !/^$Input syntax OK$/o } @$error_r;
	warn "$0: Unexpected compiler output:\n@error" if @error;
    }
	
    # Write it and leave.
    print OUT @$output_r               or die "can't write $Output: $!";
    close OUT                          or die "can't close $Output: $!";

    # wait, how could it be anything but what you see next?
    chmod 0777 & ~umask, $Output    or die "can't chmod $Output: $!";
    exit 0;
}

sub compile_cstyle {
    my $stash = grab_stash();
    
    # What are we going to call our output C file?
    my ($cfile,$cfh);
    my $lose = 0;
    if (opt(S) || opt(c)) {
        # We need to keep it.
        if (opt(e)) {
            $cfile = "a.out.c";
        } else {
            $cfile = $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 {
        # Don't need to keep it, be safe with a tempfile.
        $lose = 1;
        ($cfh, $cfile) = tempfile("pccXXXXX", SUFFIX => ".c"); 
        close $cfh; # See comment just below
    }
    vprint 1, "Writing C on $cfile";

    my $max_line_len = '';
    if ($^O eq 'MSWin32' && $Config{cc} =~ /^cl/i) {
        $max_line_len = '-l2000,';
    }

    # This has to do the write itself, so we can't keep a lock. Life
    # sucks.
    my $command = "$BinPerl -MO=$Backend,$max_line_len$stash,-o$cfile $Input";
    vprint 1, "Compiling...";
    vprint 1, "Calling $command";

	my ($output_r, $error_r) = spawnit($command);
	my @output = @$output_r;
	my @error = @$error_r;

    if (@error && $? != 0) {
        die "$0: $Input did not compile, which can't happen:\n@error\n";
    }

    cc_harness($cfile,$stash) unless opt(c);

    if ($lose) {
        vprint 2, "unlinking $cfile";
        unlink $cfile or die "can't unlink $cfile: $!" if $lose;
    }
	exit(0);
}

sub cc_harness {
	my ($cfile,$stash)=@_;
	use ExtUtils::Embed ();
	my $command = ExtUtils::Embed::ccopts." -o $Output $cfile ";
	$command .= join " -I", split /\s+/, opt(I);
	$command .= join " -L", split /\s+/, opt(L);
	my @mods = split /-?u /, $stash;
	$command .= ExtUtils::Embed::ldopts("-std", \@mods);
	vprint 3, "running cc $command";
	system("cc $command");
}

# Where Perl is, and which include path to give it.
sub yclept {
    my $command = "$^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";
            }
        }
    }
            
    $command .= "-I$_ " for @INC;
    return $command;
}

# Use B::Stash to find additional modules and stuff.
{
    my $_stash;
    sub grab_stash {

        warn "already called get_stash once" if $_stash;

        my $command = "$BinPerl -MB::Stash -c $Input";
        # Filename here is perfectly sanitised.
        vprint 3, "Calling $command\n";

		my ($stash_r, $error_r) = spawnit($command);
		my @stash = @$stash_r;
		my @error = @$error_r;

    	if (@error && $? != 0) {
            die "$0: $Input did not compile:\n@error\n";
        }

        $stash[0] =~ s/,-u\<none\>//;
        vprint 2, "Stash: ", join " ", split /,?-u/, $stash[0];
        chomp $stash[0];
        return $_stash = $stash[0];
    }

}

# Check the consistency of options if -B is selected.
# To wit, (-B|-O) ==> no -shared, no -S, no -c
sub checkopts_byte {

    die "$0: Please choose one of either -B and -O.\n" if opt(O);

    if (opt(shared)) {
        warn "$0: Will not create a shared library for bytecode\n";
        delete $Options->{shared};
    }

    for my $o ( qw[c S] ) { 
        if (opt($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') {
            warn "$0: Compiling a.out is probably not what you want to do.\n";
            # You fully deserve what you get now.
        } else {
            warn "$0: Will not write output on top of input file, ",
                "compiling to a.out instead\n";
            $Output = "a.out";
        }
    }
}

sub check_read { 
    my $file = shift;
    unless (-r $file) {
        die "$0: Input file $file is a directory, not a file\n" if -d _;
        unless (-e _) {
            die "$0: Input file $file was not found\n";
        } else {
            die "$0: 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 "$0: Cannot write on $file, is a directory\n";
    }
    if (-e _) {
        die "$0: Cannot write on $file: $!\n" unless -w _;
    } 
    unless (-w cwd()) { 
        die "$0: Cannot write in this directory: $!\n" 
    }
}

sub check_perl {
    my $file = shift;
    unless (-T $file) {
        warn "$0: Binary `$file' sure doesn't smell like perl source!\n";
        print "Checking file type... ";
        system("file", $file);  
        die "Please try a perlier file!\n";
    } 

    open(my $handle, "<", $file)    or die "XXX: can't open $file: $!";
    local $_ = <$handle>;
    if (/^#!/ && !/perl/) {
        die "$0: $file is a ", /^#!\s*(\S+)/, " script, not perl\n";
    } 

} 

# File spawning and error collecting
sub spawnit {
	my ($command) = shift;
	my (@error,@output);
	my $errname;
	(undef, $errname) = tempfile("pccXXXXX");
	{ 
	open (S_OUT, "$command 2>$errname |")
		or die "$0: Couldn't spawn the compiler.\n";
	@output = <S_OUT>;
	}
	open (S_ERROR, $errname) or die "$0: Couldn't read the error file.\n";
	@error = <S_ERROR>;
	close S_ERROR;
	close S_OUT;
	unlink $errname or die "$0: Can't unlink error file $errname";
	return (\@output, \@error);
}

sub helpme {
       print "perlcc compiler frontend, version $VERSION\n\n";
       { no warnings;
       exec "pod2usage $0";
       exec "perldoc $0";
       exec "pod2text $0";
       }
}


__END__

=head1 NAME

perlcc - generate executables from Perl programs

=head1 SYNOPSIS

    $ perlcc hello              # Compiles into executable 'a.out'
    $ perlcc -o hello hello.pl  # Compiles into executable 'hello'

    $ perlcc -O file            # Compiles using the optimised C backend
    $ perlcc -B file            # Compiles using the bytecode backend

    $ perlcc -c file            # Creates a C file, 'file.c'
    $ perlcc -S -o hello file   # Creates a C file, 'file.c',
                                # then compiles it to executable 'hello'
    $ perlcc -c out.c file      # Creates a C file, 'out.c' from 'file'

    $ perlcc -e 'print q//'     # Compiles a one-liner into 'a.out'
    $ perlcc -c -e 'print q//'  # Creates a C file 'a.out.c'
    
=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<library directories>

Adds the given directories to the library search path when C code is
passed to your C compiler.

=item -II<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.

=item -c I<C file name>

Create C code only; do not compile to a standalone binary.

=item -e I<perl code>

Compile a one-liner, much the same as C<perl -e '...'>

=item -S

Do not delete generated C code after compilation.

=item -B

Use the Perl bytecode code generator.

=item -O

Use the 'optimised' C code generator. 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 -v

Increase verbosity of output; can be repeated for more verbose output.

=back

=cut

!NO!SUBS!

close OUT or die "Can't close $file: $!";
chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
chdir $origdir;