Merging pp_bit_or and pp_bit_xor shrinks the object code by about .7K.

[p5sagit/p5-mst-13.2.git] / t / test.pl

diff --git a/t/test.pl b/t/test.pl
index 9407129..95aa87f 100644 (file)
--- a/t/test.pl
+++ b/t/test.pl
@@ -5,6 +5,7 @@
 $Level = 1;
 my $test = 1;
 my $planned;
+my $noplan;
 
 $TODO = 0;
 $NO_ENDING = 0;
@@ -13,18 +14,27 @@ sub plan {
     my $n;
     if (@_ == 1) {
        $n = shift;
+       if ($n eq 'no_plan') {
+         undef $n;
+         $noplan = 1;
+       }
     } else {
        my %plan = @_;
        $n = $plan{tests}; 
     }
-    print STDOUT "1..$n\n";
+    print STDOUT "1..$n\n" unless $noplan;
     $planned = $n;
 }
 
 END {
     my $ran = $test - 1;
-    if (!$NO_ENDING && defined $planned && $planned != $ran) {
-        print STDERR "# Looks like you planned $planned tests but ran $ran.\n";
+    if (!$NO_ENDING) {
+       if (defined $planned && $planned != $ran) {
+           print STDERR
+               "# Looks like you planned $planned tests but ran $ran.\n";
+       } elsif ($noplan) {
+           print "1..$ran\n";
+       }
     }
 }
 
@@ -91,8 +101,8 @@ sub _q {
     my $x = shift;
     return 'undef' unless defined $x;
     my $q = $x;
-    $q =~ s/\\/\\\\/;
-    $q =~ s/'/\\'/;
+    $q =~ s/\\/\\\\/g;
+    $q =~ s/'/\\'/g;
     return "'$q'";
 }
 
@@ -248,6 +258,7 @@ sub like_yn ($$$@) {
        unshift(@mess, "#      got '$got'\n",
                "# expected /$expected/\n");
     }
+    local $Level = 2;
     _ok($pass, _where(), $name, @mess);
 }
 
@@ -281,10 +292,25 @@ sub skip {
     last SKIP;
 }
 
+sub todo_skip {
+    my $why = shift;
+    my $n   = @_ ? shift : 1;
+
+    for (1..$n) {
+        print STDOUT "not ok $test # TODO & SKIP: $why\n";
+        $test++;
+    }
+    local $^W = 0;
+    last TODO;
+}
+
 sub eq_array {
     my ($ra, $rb) = @_;
     return 0 unless $#$ra == $#$rb;
     for my $i (0..$#$ra) {
+       next     if !defined $ra->[$i] && !defined $rb->[$i]; 
+       return 0 if !defined $ra->[$i];
+       return 0 if !defined $rb->[$i];
        return 0 unless $ra->[$i] eq $rb->[$i];
     }
     return 1;
@@ -365,6 +391,10 @@ sub _quote_args {
 sub _create_runperl { # Create the string to qx in runperl().
     my %args = @_;
     my $runperl = $^X =~ m/\s/ ? qq{"$^X"} : $^X;
+    #- this allows, for example, to set PERL_RUNPERL_DEBUG=/usr/bin/valgrind
+    if ($ENV{PERL_RUNPERL_DEBUG}) {
+       $runperl = "$ENV{PERL_RUNPERL_DEBUG} $runperl";
+    }
     unless ($args{nolib}) {
        if ($is_macos) {
            $runperl .= ' -I::lib';
@@ -399,6 +429,12 @@ sub _create_runperl { # Create the string to qx in runperl().
         }
     } elsif (defined $args{progfile}) {
        $runperl .= qq( "$args{progfile}");
+    } else {
+       # You probaby didn't want to be sucking in from the upstream stdin
+       die "test.pl:runperl(): none of prog, progs, progfile, args, "
+           . " switches or stdin specified"
+           unless defined $args{args} or defined $args{switches}
+               or defined $args{stdin};
     }
     if (defined $args{stdin}) {
        # so we don't try to put literal newlines and crs onto the
@@ -442,6 +478,8 @@ sub _create_runperl { # Create the string to qx in runperl().
 }
 
 sub runperl {
+    die "test.pl:runperl() does not take a hashref"
+       if ref $_[0] and ref $_[0] eq 'HASH';
     my $runperl = &_create_runperl;
     my $result = `$runperl`;
     $result =~ s/\n\n/\n/ if $is_vms; # XXX pipes sometimes double these
@@ -542,7 +580,7 @@ sub _fresh_perl {
                   {if (-e _ and -f _)}
     }
 
-    print TEST $prog, "\n";
+    print TEST $prog;
     close TEST or die "Cannot close $tmpfile: $!";
 
     my $results = runperl(%$runperl_args);
@@ -612,4 +650,66 @@ sub fresh_perl_like {
                $runperl_args, $name);
 }
 
+sub can_ok ($@) {
+    my($proto, @methods) = @_;
+    my $class = ref $proto || $proto;
+
+    unless( @methods ) {
+        return _ok( 0, _where(), "$class->can(...)" );
+    }
+
+    my @nok = ();
+    foreach my $method (@methods) {
+        local($!, $@);  # don't interfere with caller's $@
+                        # eval sometimes resets $!
+        eval { $proto->can($method) } || push @nok, $method;
+    }
+
+    my $name;
+    $name = @methods == 1 ? "$class->can('$methods[0]')" 
+                          : "$class->can(...)";
+    
+    _ok( !@nok, _where(), $name );
+}
+
+sub isa_ok ($$;$) {
+    my($object, $class, $obj_name) = @_;
+
+    my $diag;
+    $obj_name = 'The object' unless defined $obj_name;
+    my $name = "$obj_name isa $class";
+    if( !defined $object ) {
+        $diag = "$obj_name isn't defined";
+    }
+    elsif( !ref $object ) {
+        $diag = "$obj_name isn't a reference";
+    }
+    else {
+        # We can't use UNIVERSAL::isa because we want to honor isa() overrides
+        local($@, $!);  # eval sometimes resets $!
+        my $rslt = eval { $object->isa($class) };
+        if( $@ ) {
+            if( $@ =~ /^Can't call method "isa" on unblessed reference/ ) {
+                if( !UNIVERSAL::isa($object, $class) ) {
+                    my $ref = ref $object;
+                    $diag = "$obj_name isn't a '$class' it's a '$ref'";
+                }
+            } else {
+                die <<WHOA;
+WHOA! I tried to call ->isa on your object and got some weird error.
+This should never happen.  Please contact the author immediately.
+Here's the error.
+$@
+WHOA
+            }
+        }
+        elsif( !$rslt ) {
+            my $ref = ref $object;
+            $diag = "$obj_name isn't a '$class' it's a '$ref'";
+        }
+    }
+
+    _ok( !$diag, _where(), $name );
+}
+
 1;