X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=utils%2Fperlcc.PL;h=361069edf25e4513ae1c54f2d300052634e6c2b8;hb=8bbf3450a1ff0a3996dade29a4194cc0939d871f;hp=0c4b726d35df61c57672eac407585607e2f24324;hpb=d873810b3537a2d7375918c521de90017ed077b7;p=p5sagit%2Fp5-mst-13.2.git diff --git a/utils/perlcc.PL b/utils/perlcc.PL index 0c4b726..361069e 100644 --- a/utils/perlcc.PL +++ b/utils/perlcc.PL @@ -41,39 +41,49 @@ 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 +# 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 v5.6.0; +use 5.006_000; +use FileHandle; use Config; use Fcntl qw(:DEFAULT :flock); use File::Temp qw(tempfile); use Cwd; -our $VERSION = 2.02; +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 { +sub main { parse_argv(); check_write($Output); choose_backend(); generate_code(); - die "XXX: Not reached?"; - exit(0); + run_code(); + _die("XXX: Not reached?"); } ####################################################################### @@ -108,7 +118,13 @@ sub generate_code { compile_cstyle(); } } + exit(0) if (!opt('r')); +} +sub run_code { + vprint 0, "Running code"; + run("$Output @ARGV"); + exit(0); } # usage: vprint [level] msg args @@ -124,13 +140,20 @@ sub vprint { } my $msg = "@_"; $msg .= "\n" unless substr($msg, -1) eq "\n"; - print "$0: $msg" if opt(v) > $level; -} + if (opt(v) > $level) + { + print "$0: $msg" if !opt('log'); + print $logfh "$0: $msg" if opt('log'); + } +} sub parse_argv { use Getopt::Long; - Getopt::Long::Configure("bundling"); + + # 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" @@ -142,42 +165,47 @@ sub parse_argv { 'L:s', # lib directory 'I:s', # include directories (FOR C, NOT FOR PERL) 'o:s', # Output executable - 'v+', # Verbosity level + '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 - 's:s', # Dirty hack to enable -shared/-static + '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 ); - - # 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; + 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) || 'a.out'; + $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 = "-e '".opt(e)."'"; # Quotes eaten by shell + $Input = is_win32() ? # Quotes eaten by shell + '-e "'.opt(e).'"' : + "-e '".opt(e)."'"; } else { $Input = shift @ARGV; # XXX: more files? - die "$0: No input file specified\n" unless $Input; + _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; @@ -198,63 +226,48 @@ sub compile_module { } 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 <&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)) { @@ -283,7 +296,7 @@ sub compile_cstyle { # 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"; + my $command = "$BinPerl $taint -MO=$Backend,$addoptions$testsuite$max_line_len$stash,-o$cfile $Input"; vprint 1, "Compiling..."; vprint 1, "Calling $command"; @@ -292,28 +305,47 @@ sub compile_cstyle { my @error = @$error_r; if (@error && $? != 0) { - die "$0: $Input did not compile, which can't happen:\n@error\n"; + _die("$0: $Input did not compile, which can't happen:\n@error\n"); } - cc_harness($cfile,$stash) unless opt(c); + 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: $!" if $lose; + unlink $cfile or _die("can't unlink $cfile: $!"); } - exit(0); +} + +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 .= join " -I", split /\s+/, opt(I); - $command .= join " -L", split /\s+/, opt(L); + $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); - vprint 3, "running cc $command"; - system("cc $command"); + $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. @@ -342,7 +374,9 @@ sub yclept { warn "already called get_stash once" if $_stash; - my $command = "$BinPerl -MB::Stash -c $Input"; + 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"; @@ -351,10 +385,17 @@ sub yclept { my @error = @$error_r; if (@error && $? != 0) { - die "$0: $Input did not compile:\n@error\n"; + _die("$0: $Input did not compile:\n@error\n"); } + # band-aid for modules with noisy BEGIN {} + foreach my $i ( @stash ) { + $i =~ m/-u(?:[\w:]+|\)$/ and $stash[0] = $i and next; + push @begin_output, $i; + } + chomp $stash[0]; $stash[0] =~ s/,-u\//; + $stash[0] =~ s/^.*?-u/-u/s; vprint 2, "Stash: ", join " ", split /,?-u/, $stash[0]; chomp $stash[0]; return $_stash = $stash[0]; @@ -366,7 +407,7 @@ sub yclept { # 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); + _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"; @@ -387,8 +428,8 @@ sub checkopts_byte { 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. + _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. } else { warn "$0: Will not write output on top of input file, ", "compiling to a.out instead\n"; @@ -400,11 +441,11 @@ sub sanity_check { sub check_read { my $file = shift; unless (-r $file) { - die "$0: Input file $file is a directory, not a file\n" if -d _; + _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"; + _die("$0: Input file $file was not found\n"); } else { - die "$0: Cannot read input file $file: $!\n"; + _die("$0: Cannot read input file $file: $!\n"); } } unless (-f _) { @@ -416,13 +457,13 @@ sub check_read { sub check_write { my $file = shift; if (-d $file) { - die "$0: Cannot write on $file, is a directory\n"; + _die("$0: Cannot write on $file, is a directory\n"); } if (-e _) { - die "$0: Cannot write on $file: $!\n" unless -w _; + _die("$0: Cannot write on $file: $!\n") unless -w _; } unless (-w cwd()) { - die "$0: Cannot write in this directory: $!\n" + _die("$0: Cannot write in this directory: $!\n"); } } @@ -432,13 +473,13 @@ sub check_perl { 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"; + _die("Please try a perlier file!\n"); } - open(my $handle, "<", $file) or die "XXX: can't open $file: $!"; + 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"; + _die("$0: $file is a ", /^#!\s*(\S+)/, " script, not perl\n"); } } @@ -451,14 +492,14 @@ sub spawnit { (undef, $errname) = tempfile("pccXXXXX"); { open (S_OUT, "$command 2>$errname |") - or die "$0: Couldn't spawn the compiler.\n"; + or _die("$0: Couldn't spawn the compiler.\n"); @output = ; } - open (S_ERROR, $errname) or die "$0: Couldn't read the error file.\n"; + open (S_ERROR, $errname) or _die("$0: Couldn't read the error file.\n"); @error = ; close S_ERROR; close S_OUT; - unlink $errname or die "$0: Can't unlink error file $errname"; + unlink $errname or _die("$0: Can't unlink error file $errname"); return (\@output, \@error); } @@ -471,6 +512,75 @@ sub helpme { } } +sub relativize { + my ($args) = @_; + + return() if ($args =~ m"^[/\\]"); + return("./$args"); +} + +sub _die { + $logfh->print(@_) if opt('log'); + print STDERR @_; + 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(<print(interruptrun(@commands)) if (opt('log')); +} + +sub interruptrun +{ + my (@commands) = @_; + + my $command = join('', @commands); + local(*FD); + my $pid = open(FD, "$command |"); + my $text; + + local($SIG{HUP}) = sub { kill 9, $pid; exit }; + local($SIG{INT}) = sub { kill 9, $pid; exit }; + + my $needalarm = + ($ENV{PERLCC_TIMEOUT} && + $Config{'osname'} ne 'MSWin32' && + $command =~ m"(^|\s)perlcc\s"); + + eval + { + local($SIG{ALRM}) = sub { die "INFINITE LOOP"; }; + alarm($ENV{PERLCC_TIMEOUT}) if ($needalarm); + $text = join('', ); + alarm(0) if ($needalarm); + }; + + if ($@) + { + eval { kill 'HUP', $pid }; + vprint 0, "SYSTEM TIMEOUT (infinite loop?)\n"; + } + + close(FD); + return($text); +} + +sub is_win32() { $^O =~ m/^MSWin/ } +sub is_msvc() { is_win32 && $Config{cc} =~ m/^cl/i } + +END { + unlink $cfile if ($cfile && !opt(S) && !opt(c)); +} __END__ @@ -493,7 +603,17 @@ perlcc - generate executables from Perl programs $ 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 (notice the space after -I) + $ perlcc -L /foo hello # extra libraries (notice the space after -L) + + $ 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 # compiles 'hello' into 'a.out' logs compile + # log into 'c'. + =head1 DESCRIPTION F creates standalone executables from Perl programs, using the @@ -551,6 +671,14 @@ compile in finite time and memory, or indeed, at all. Increase verbosity of output; can be repeated for more verbose output. +=item -r + +Run the resulting compiled script after compiling it. + +=item -log + +Log the output of compiling to a file rather than to stdout. + =back =cut