diff options
| -rw-r--r-- | ext/B/O.pm | 15 | ||||
| -rwxr-xr-x | t/TEST | 55 |
2 files changed, 62 insertions, 8 deletions
diff --git a/ext/B/O.pm b/ext/B/O.pm index 89352fb6e7..455a061325 100644 --- a/ext/B/O.pm +++ b/ext/B/O.pm @@ -4,13 +4,16 @@ use Carp; sub import { my ($class, @options) = @_; - my $quiet = 0; - if ($options[0] eq '-q') { + my ($quiet, $veryquiet) = (0, 0); + if ($options[0] eq '-q' || $options[0] eq '-qq') { $quiet = 1; - shift @options; open (SAVEOUT, ">&STDOUT"); close STDOUT; open (STDOUT, ">", \$O::BEGIN_output); + if ($options[0] eq '-qq') { + $veryquiet = 1; + } + shift @options; } my $backend = shift (@options); eval q[ @@ -37,6 +40,8 @@ sub import { } &$compilesub(); + + close STDERR if $veryquiet; } ]; die $@ if $@; @@ -67,6 +72,10 @@ produce output themselves (C<Deparse>, C<Concise> etc), so that their output is not confused with that generated by the code being compiled. +The C<-qq> option behaves like C<-q>, except that it also closes +STDERR after deparsing has finished. This suppresses the "Syntax OK" +message normally produced by perl. + =head1 CONVENTIONS Most compiler backends use the following conventions: OPTIONS @@ -8,9 +8,13 @@ $| = 1; # Cheesy version of Getopt::Std. Maybe we should replace it with that. if ($#ARGV >= 0) { foreach my $idx (0..$#ARGV) { - next unless $ARGV[$idx] =~ /^-(\w+)$/; + next unless $ARGV[$idx] =~ /^-(\S+)$/; $verbose = 1 if $1 eq 'v'; $with_utf= 1 if $1 eq 'utf8'; + if ($1 =~ /^deparse(,.+)?$/) { + $deparse = 1; + $deparse_opts = $1; + } splice(@ARGV, $idx, 1); } } @@ -47,8 +51,12 @@ if ($#ARGV == -1) { # %infinite = ( 'comp/require.t', 1, 'op/bop.t', 1, 'lib/hostname.t', 1 ); -_testprogs('perl', @ARGV); -_testprogs('compile', @ARGV) if (-e "../testcompile"); +if ($deparse) { + _testprogs('deparse', @ARGV); +} else { + _testprogs('perl', @ARGV); + _testprogs('compile', @ARGV) if (-e "../testcompile"); +} sub _testprogs { $type = shift @_; @@ -61,6 +69,12 @@ TESTING COMPILER -------------------------------------------------------------------------------- EOT + print <<'EOT' if ($type eq 'deparse'); +-------------------------------------------------------------------------------- +TESTING DEPARSER +-------------------------------------------------------------------------------- +EOT + $ENV{PERLCC_TIMEOUT} = 120 if ($type eq 'compile' && !$ENV{PERLCC_TIMEOUT}); @@ -86,13 +100,23 @@ EOT if ($test =~ /^$/) { next; } + if ($type eq 'deparse') { + if ($test eq "comp/redef.t") { + # Redefinition happens at compile time + next; + } + elsif ($test eq "lib/switch.t") { + # B::Deparse doesn't support source filtering + next; + } + } $te = $test; chop($te); print "$te" . '.' x ($dotdotdot - length($te)); open(SCRIPT,"<$test") or die "Can't run $test.\n"; $_ = <SCRIPT>; - close(SCRIPT); + close(SCRIPT) unless ($type eq 'deparse'); if (/#!.*perl(.*)$/) { $switch = $1; if ($^O eq 'VMS') { @@ -104,10 +128,28 @@ EOT $switch = ''; } + my $file_opts = ""; + if ($type eq 'deparse') { + # Look for #line directives which change the filename + while (<SCRIPT>) { + $file_opts .= ",-f$3$4" + if /^#\s*line\s+(\d+)\s+((\w+)|"([^"]+)")/; + } + close(SCRIPT); + } my $utf = $with_utf ? '-I../lib -Mutf8' : ''; my $testswitch = '-I. -MTestInit'; # -T will strict . from @INC - if ($type eq 'perl') { + if ($type eq 'deparse') { + my $deparse = + "./perl $testswitch $switch -I../lib -MO=-qq,Deparse,". + "-l$deparse_opts$file_opts ". + "./$test > ./$test.dp ". + "&& ./perl $testswitch $switch -I../lib ./$test.dp |"; + open(RESULTS, $deparse) + or print "can't deparse '$deparse': $!.\n"; + } + elsif ($type eq 'perl') { my $run = "./perl $testswitch $switch $utf $test |"; open(RESULTS,$run) or print "can't run '$run': $!.\n"; } @@ -161,6 +203,9 @@ EOT } } close RESULTS; + if ($type eq 'deparse') { + unlink "./$test.dp"; + } if ($ENV{PERL_3LOG}) { my $tpp = $test; $tpp =~ s:/:_:g; |