#!/usr/bin/perl
    eval 'exec /usr/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

use strict;
use warnings;
use 5.006_000;

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

$SIG{INT} = sub { exit(); }; # 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
};
sub opt(*); # imal quoting
sub is_win32();
sub is_msvc();

our ($Options, $BinPerl, $Backend);
our ($Input => $Output);
our ($logfh);
our ($cfile);
our (@begin_output); # output from BEGIN {}, for testsuite

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

main();

sub main {
    parse_argv();
    check_write($Output);
    choose_backend();
    generate_code();
    run_code();
    _die("XXX: 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 0, "Compiling $Input";

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

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

sub run_code {
    vprint 0, "Running code";
    run("$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)
    {
         print        "$0: $msg" if !opt('log');
	 print $logfh "$0: $msg" if  opt('log');
    }
}

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 = {};
    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
	'r',            # run resulting executable
        'B',            # Byte compiler backend
        'O',            # Optimised C backend
        'c',            # Compile only
        'h',            # Help me
        'S',            # Dump C files
	'r',            # run the resulting executable
        'T',            # run the backend using perl -T
        't',            # run the backend using perl -t
        'static',       # Dirty hack to enable -shared/-static
        'shared',       # Create a shared library (--shared for compat.)
	'log:s',        # where to log compilation process information
        'Wb:s',         # pass (comma-sepearated) options to backend
        'testsuite',    # try to be nice to testsuite
    );

    $Options->{v} += 0;

    if( opt(t) && opt(T) ) {
        warn "Can't specify both -T and -t, -t ignored";
        $Options->{t} = 0;
    }

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

    $Output = opt(o) || ( is_win32 ? 'a.exe' : 'a.out' );
    $Output = is_win32() ? $Output : relativize($Output);
    $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 = is_win32() ? # Quotes eaten by shell
            '-e "'.opt(e).'"' :
            "-e '".opt(e)."'";
    } else {
        $Input = shift @ARGV;  # XXX: more files?
        _usage_and_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 {
    my $command = "$BinPerl -MO=Bytecode,-H,-o$Output $Input";
    $Input =~ s/^-e.*$/-e/;

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

    if (@$error_r && $? != 0) {
	_die("$0: $Input did not compile:\n@$error_r\n");
    } else {
	my @error = grep { !/^$Input syntax OK$/o } @$error_r;
	warn "$0: Unexpected compiler output:\n@error" if @error;
    }

    chmod 0777 & ~umask, $Output    or _die("can't chmod $Output: $!");
    exit 0;
}

sub compile_cstyle {
    my $stash = grab_stash();
    my $taint = opt(T) ? '-T' :
                opt(t) ? '-t' : '';

    # What are we going to call our output C file?
    my $lose = 0;
    my ($cfh);
    my $testsuite = '';
    my $addoptions = opt(Wb);

    if( $addoptions ) {
        $addoptions .= ',' if $addoptions !~ m/,$/;
    }

    if (opt(testsuite)) {
        my $bo = join '', @begin_output;
        $bo =~ s/\\/\\\\\\\\/gs;
        $bo =~ s/\n/\\n/gs;
        $bo =~ s/,/\\054/gs;
        # don't look at that: it hurts
        $testsuite = q{-fuse-script-name,-fsave-data,-fsave-sig-hash,}.
            qq[-e"print q{$bo}",] .
            q{-e"open(Test::Builder::TESTOUT\054 '>&STDOUT') or die $!",} .
            q{-e"open(Test::Builder::TESTERR\054 '>&STDERR') or die $!",};
    }
    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 $taint -MO=$Backend,$addoptions$testsuite$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");
    }

    is_msvc ?
        cc_harness_msvc($cfile,$stash) :
        cc_harness($cfile,$stash) unless opt(c);

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

sub cc_harness_msvc {
    my ($cfile,$stash)=@_;
    use ExtUtils::Embed ();
    my $obj = "${Output}.obj";
    my $compile = ExtUtils::Embed::ccopts." -c -Fo$obj $cfile ";
    my $link = "-out:$Output $obj";
    $compile .= " -I".$_ for split /\s+/, opt(I);
    $link .= " -libpath:".$_ for split /\s+/, opt(L);
    my @mods = split /-?u /, $stash;
    $link .= " ".ExtUtils::Embed::ldopts("-std", \@mods);
    $link .= " perl5$Config{PERL_VERSION}.lib kernel32.lib msvcrt.lib";
    vprint 3, "running $Config{cc} $compile";
    system("$Config{cc} $compile");
    vprint 3, "running $Config{ld} $link";
    system("$Config{ld} $link");
}

sub cc_harness {
	my ($cfile,$stash)=@_;
	use ExtUtils::Embed ();
	my $command = ExtUtils::Embed::ccopts." -o $Output $cfile ";
	$command .= " -I".$_ for split /\s+/, opt(I);
	$command .= " -L".$_ for split /\s+/, opt(L);
	my @mods = split /-?u /, $stash;
	$command .= " ".ExtUtils::Embed::ldopts("-std", \@mods);
        $command .= " -lperl";
	vprint 3, "running $Config{cc} $command";
	system("$Config{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 $taint = opt(T) ? '-T' :
                    opt(t) ? '-t' : '';
        my $command = "$BinPerl $taint -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");
        }

        # band-aid for modules with noisy BEGIN {}
        foreach my $i ( @stash ) {
            $i =~ m/-u(?:[\w:]+|\<none\>)$/ and $stash[0] = $i and next;
            push @begin_output, $i;
        }
        chomp $stash[0];
        $stash[0] =~ s/,-u\<none\>//;
        $stash[0] =~ s/^.*?-u/-u/s;
        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') {
            _die("$0: 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.max_line_len = '-l2000,';
     output
produced by running C<perl -V> (note the uppercase V).

Whether you use C<perlbug> or send the email manually, please make
your Subject line informative.  "a bug" not informative.  Neither is
"perl crashes" nor "HELP!!!".  These don't help.
A compact description of what's wrong is fine.

=back

Having done your bit, please be prepared to wait, to be told the bug
is in your code, or even to get no reply at all.  The Perl maintainers
are busy folks, so if your problem is a small one or if it is difficult
to understand or already known, they may not respond with a personal reply.
If it is important to you that your bug be fixed, do monitor the
C<Changes> file in any development releases since the time you submitted
the bug, and encourage the maintainers with kind words (but never any
flames!).  Feel free to resend your bug report if the next released
version of perl comes out and your bug is still present.

=head1 OPTIONS

=over 8

=item B<-a>

Address to send the report to.  Defaults to B<perlbug@perl.org>.

=item B<-A>

Don't send a bug received acknowledgement to the reply address.
Generally it is only a sensible to use this option if you are a
perl maintainer actively watching perl porters for your message to
arrive.

=item B<-b>

Body of the report.  If not included on the command line, or
in a file with B<-f>, you will get a chance to edit the message.

=item B<-C>

Don't send copy to administrator.

=item B<-c>

Address to send copy of report to.  Defaults to the address of the
local perl administrator (recorded when perl was built).

=item B<-d>

Data mode (the default if you redirect or pipe output).  This prints out
your configuration data, without mailing anything.  You can use this
with B<-v> to get more complete data.

=item B<-e>

Editor to use.

=item B<-f>

File containing the body of the report.  Use this to quickly send a
prepared message.

=item B<-F>

File to output the results to instead of sending as an email. Useful
particularly when running perlbug on a machine with no direct internet
connection.

=item B<-h>

Prints a brief summary of the options.

=item B<-ok>

Report successful build on this system to perl porters. Forces B<-S>
and B<-C>. Forces and supplies values for B<-s> and B<-b>. Only
prompts for a return address if it cannot guess it (for use with
B<make>). Honors return address specified with B<-r>.  You can use this
with B<-v> to get more complete data.   Only makes a report if this
system is less than 60 days old.

=item B<-okay>

As B<-ok> except it will report on older systems.

=item B<-nok>

Report unsuccessful build on this system.  Forces B<-C>.  Forces and
supplies a value for B<-s>, then requires you to edit the report
and say what went wrong.  Alternatively, a prepared report may be
supplied using B<-f>.  Only prompts for a return address if it
cannot guess it (for use with B<make>). Honors return address
specified with B<-r>.  You can use this with B<-v> to get more
complete data.  Only makes a report if this system is less than 60
days old.

=item B<-nokay>

As B<-nok> except it will report on older systems.

=item B<-r>

Your return address.  The program will ask you to confirm its default
if you don't use this option.

=item B<-S>

Send without asking for confirmation.

=item B<-s>

Subject to include with the message.  You will be prompted if you don't
supply one on the command line.

=item B<-t>

Test mode.  The target address defaults to B<perlbug-test@perl.org>.

=item B<-v>

Include verbose configuration data in the report.

=back

=head1 AUTHORS

Kenneth Albanowski (E<lt>kjahds@kjahds.comE<gt>), subsequently I<doc>tored
by Gurusamy Sarathy (E<lt>gsar@activestate.comE<gt>), Tom Christiansen
(E<lt>tchrist@perl.comE<gt>), Nathan Torkington (E<lt>gnat@frii.comE<gt>),
Charles F. Randall (E<lt>cfr@pobox.comE<gt>), Mike Guy
(E<lt>mjtg@cam.a.ukE<gt>), Dominic Dunlop (E<lt>domo@computer.orgE<gt>),
Hugo van der Sanden (E<lt>hv@crypt.org<gt>),
Jarkko Hietaniemi (E<lt>jhi@iki.fiE<gt>), Chris Nandor
(E<lt>pudge@pobox.comE<gt>), Jon Orwant (E<lt>orwant@media.mit.eduE<gt>,
and Richard Foley (E<lt>richard@rfi.netE<gt>).

=head1 SEE ALSO

perl(1), perldebug(1), perldiag(1), perlport(1), perltrap(1),
diff(1), patch(1), dbx(1), gdb(1)

=head1 BUGS

None known (guess what must have been used to report them?)

=cut

                                                                                                       ./usr/bin/perlcc                                                                                    0000755 0000000 0000000 00000043041 10713460765 013743  0                                                                                                    ustar   root                            root                            0000000 0000000                                                                                                                                                                        #!/usr/bin/perl
    eval 'exec /usr/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

use strict;
use warnings;
use 5.006_000;

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

$SIG{INT} = sub { exit(); }; # 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
};
sub opt(*); # imal quoting
sub is_win32();
sub is_msvc();

our ($Options, $BinPerl, $Backend);
our ($Input => $Output);
our ($logfh);
our ($cfile);
our (@begin_output); # output from BEGIN {}, for testsuite

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

main();

sub main {
    parse_argv();
    check_write($Output);
    choose_backend();
    generate_code();
    run_code();
    _die("XXX: 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 com