B::Deparse tester

Message-ID: <20010509191750.A16940@penderel>

p4raw-id: //depot/perl@10059

diff --git a/ext/B/O.pm b/ext/B/O.pm
index 89352fb..455a061 100644 (file)
--- 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

diff --git a/t/TEST b/t/TEST
index 122bd96..a1080e2 100755 (executable)
--- a/t/TEST
+++ b/t/TEST
@@ -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;