view release on metacpan or  search on metacpan

script/perlcc.PL  view on Meta::CPAN

    if ($Backend eq 'Bytecode') {
        compile_byte("-m$name");
    } else {
        compile_cstyle("-m$name");
    }
}

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 (opt('v') > 4) {
        $opts .= '-v,';
        $opts .= '-DM,-DG,-DA,-DComment,' if opt('v') > 5;
    }
    #if ($Options->{cross}) {
    #    $opts .= '-cross='.$Options->{cross}.',';
    #}
    $opts .= "$addoptions," if $addoptions;
    my $command = "$BinPerl -MO=Bytecode,$opts-o$Output $Input";
    $Input =~ s/^-e.*$/-e/;
    vprint 5, "Compiling...";
    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')<5;
	warn "@error" if @error and opt('v')>4;
    }

    unless (opt('dryrun')) {
      chmod 0777 & ~umask, $Output    or _die("can't chmod $Output: $!\n");
    }
}

sub compile_cstyle {
    my $stash = opt('stash') ? grab_stash() : "";
    $stash .= "," if $stash; #stash can be empty
    $stash .= "-u$_," for @{$Options->{u}};
    $stash .= "-U$_," for @{$Options->{U}};

    #if ($ENV{PERL_CORE} and ($Config{ccflags} =~ /-m32/ or $Config{cc} =~ / -m32/)) {
    #    die "perlcc with -m32 cross compilation is not supported\n";
    #}

    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 = '';
    if (@_) {
        $addoptions = join(",",@_);
    }
    $addoptions .= opt('Wb') ? opt('Wb')."," : "";
    if( $addoptions ) {
        $addoptions .= ',-Dfull' if opt('v') >= 6;
        if (opt('v') == 5) {
            $addoptions .= opt('O') ? ',-DstFl,-v' : ',-DspF,-v';
        }
        $addoptions .= ',';
    } elsif (opt('v') > 4) {
        $addoptions = opt('O') ? '-DstFl,-v,' : '-DspF,-v,';
        $addoptions = '-Dfull,-v,' if opt('v') >= 6;
    }
    if (opt('f')) {
        $addoptions .= "-f$_," for @{$Options->{f}};
    }
    if (opt('check')) {
        $addoptions .= "-c,";
    }
    if (opt('cross')) {
        $addoptions .= '-cross='.$Options->{cross}.',';
    }
    $addoptions =~ s/,,/,/g;

    my $staticxs = opt('staticxs') ? "-staticxs," : '';
    warn "Warning: --staticxs on darwin is very experimental\n"
        if $staticxs and $^O eq 'darwin';
    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('check')) {
        $cfile = "";
        $staticxs = "";
    } elsif (opt('o')) {
        $cfile = opt('o').".c";
        if (is_winlike() and $Output =~ /\.exe.c$/) {
          $cfile =~ s/\.exe\.c$/.c/,
        }
    } elsif (opt('S') || opt('c')) { # We need to keep it
        if (opt('e')) {
            $cfile = $Output;
            if (is_winlike() and $Output =~ /\.exe$/) {
                $cfile =~ s/\.exe$//,
            }
            $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');

    my $max_line_len = '';
    if (is_msvc) {
        $max_line_len = '-l2000,';
    }

    my $options = "$addoptions$testsuite$max_line_len$staticxs$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...";
    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 (@error && $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')<5;
            warn "@error" if @error and opt('v')>4;
        }
    }
    vprint -1, "c time: $elapsed" if opt('time');
    $extra_libs = '';
    my %rpath;
    if ($staticxs and 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}) {

script/perlcc.PL  view on Meta::CPAN

	    $ldopts =~ s|-lperl |$coredir/$Config{libperl} |;
        }
    }
    unless ( $command =~ m{( -lc?perl|/CORE\/libperl)} ) {
        if ($Config{usecperl} and $libperl =~ /libcperl/) {
            $ldopts .= " -lcperl";
        } else {
            $ldopts .= " -lperl";
        }
        $ldopts .= " $Config{libs}" if $ENV{PERL_CORE}; # no -L found at all
    }
    $command .= " ".$ldopts;
    $command .= $B::C::Config::extra_libs if $B::C::Config::extra_libs;
    vprint 3, "Calling $Config{cc} $command";
    vsystem("$Config{cc} $command");
}

# 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") {
        my $incdir = opt('I');
        if ($incdir) {
            if (ref $incdir ne 'ARRAY') {
                $incdir = ($incdir);
            }
            for (@$incdir) {
                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}++;
    }
    for my $i (@INC) {
        my $inc = $i =~ m/\s/ ? qq{"$i"} : $i;
        $command .= " -I$inc" unless $OINC{$i}; # omit internal @INC dirs
    }

    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.
        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 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 staticxs] ) {
        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 = '';
            if (exists $Options->{m} or opt('shared')) {
                $suffix = ".".$Config{dlext};
            } elsif (is_winlike()) {
              $suffix = '.exe'