From: Joshua Pritikin <joshua.pritikin@db.com>
Date: Sat, 4 Apr 1998 08:33:50 +0000 (-0500)
Subject: [PATCH 5.004_64] Test.pm update
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=8b3be1d1d662cdbae5ce4a277ed2aebfaf7de321;p=p5sagit%2Fp5-mst-13.2.git
[PATCH 5.004_64] Test.pm update
Date: Sat, 4 Apr 1998 08:33:50 -0500
Subject: [PATCH 5.004_64] modcount + comments
Date: Fri, 17 Apr 1998 16:07:35 -0400
p4raw-id: //depot/perl@943
---
diff --git a/lib/Test.pm b/lib/Test.pm
index b10d104..5f198c2 100644
--- a/lib/Test.pm
+++ b/lib/Test.pm
@@ -2,8 +2,9 @@ use strict;
package Test;
use Test::Harness 1.1601 ();
use Carp;
-use vars qw($VERSION @ISA @EXPORT $ntest %todo %history $TestLevel);
-$VERSION = '0.08';
+use vars (qw($VERSION @ISA @EXPORT $ntest $TestLevel), #public-ish
+ qw($ONFAIL %todo %history $planned @FAILDETAIL)); #private-ish
+$VERSION = '1.04';
require Exporter;
@ISA=('Exporter');
@EXPORT= qw(&plan &ok &skip $ntest);
@@ -19,12 +20,17 @@ $ENV{REGRESSION_TEST} = $0;
sub plan {
croak "Test::plan(%args): odd number of arguments" if @_ & 1;
+ croak "Test::plan(): should not be called more than once" if $planned;
my $max=0;
for (my $x=0; $x < @_; $x+=2) {
my ($k,$v) = @_[$x,$x+1];
if ($k =~ /^test(s)?$/) { $max = $v; }
elsif ($k eq 'todo' or
$k eq 'failok') { for (@$v) { $todo{$_}=1; }; }
+ elsif ($k eq 'onfail') {
+ ref $v eq 'CODE' or croak "Test::plan(onfail => $v): must be CODE";
+ $ONFAIL = $v;
+ }
else { carp "Test::plan(): skipping unrecognized directive '$k'" }
}
my @todo = sort { $a <=> $b } keys %todo;
@@ -33,6 +39,7 @@ sub plan {
} else {
print "1..$max\n";
}
+ ++$planned;
}
sub to_value {
@@ -40,79 +47,89 @@ sub to_value {
(ref $v or '') eq 'CODE' ? $v->() : $v;
}
-# prototypes are not used for maximum flexibility
-
-# STDERR is NOT used for diagnostic output that should be fixed before
-# the module is released.
+# STDERR is NOT used for diagnostic output which should have been
+# fixed before release. Is this appropriate?
-sub ok {
+sub ok ($;$$) {
+ croak "ok: plan before you test!" if !$planned;
my ($pkg,$file,$line) = caller($TestLevel);
my $repetition = ++$history{"$file:$line"};
my $context = ("$file at line $line".
- ($repetition > 1 ? " (\#$repetition)" : ''));
+ ($repetition > 1 ? " fail \#$repetition" : ''));
my $ok=0;
-
+ my $result = to_value(shift);
+ my ($expected,$diag);
if (@_ == 0) {
- print "not ok $ntest\n";
- print "# test $context: DOESN'T TEST ANYTHING!\n";
+ $ok = $result;
} else {
- my $result = to_value(shift);
- my ($expected,$diag);
- if (@_ == 0) {
- $ok = $result;
+ $expected = to_value(shift);
+ # until regex can be manipulated like objects...
+ my ($regex,$ignore);
+ if (($regex) = ($expected =~ m,^ / (.+) / $,sx) or
+ ($ignore, $regex) = ($expected =~ m,^ m([^\w\s]) (.+) \1 $,sx)) {
+ $ok = $result =~ /$regex/;
} else {
- $expected = to_value(shift);
$ok = $result eq $expected;
}
- if ($todo{$ntest}) {
- if ($ok) {
- print "ok $ntest # Wow!\n";
+ }
+ if ($todo{$ntest}) {
+ if ($ok) {
+ print "ok $ntest # Wow! ($context)\n";
+ } else {
+ $diag = to_value(shift) if @_;
+ if (!$diag) {
+ print "not ok $ntest # (failure expected in $context)\n";
} else {
- $diag = to_value(shift) if @_;
+ print "not ok $ntest # (failure expected: $diag)\n";
+ }
+ }
+ } else {
+ print "not " if !$ok;
+ print "ok $ntest\n";
+
+ if (!$ok) {
+ my $detail = { 'repetition' => $repetition, 'package' => $pkg,
+ 'result' => $result };
+ $$detail{expected} = $expected if defined $expected;
+ $diag = $$detail{diagnostic} = to_value(shift) if @_;
+ if (!defined $expected) {
if (!$diag) {
- print "not ok $ntest # (failure expected)\n";
+ print STDERR "# Failed test $ntest in $context\n";
} else {
- print "not ok $ntest # (failure expected: $diag)\n";
+ print STDERR "# Failed test $ntest in $context: $diag\n";
}
- }
- } else {
- print "not " if !$ok;
- print "ok $ntest\n";
-
- if (!$ok) {
- $diag = to_value(shift) if @_;
- if (!defined $expected) {
- if (!$diag) {
- print STDERR "# Failed $context\n";
- } else {
- print STDERR "# Failed $context: $diag\n";
- }
+ } else {
+ my $prefix = "Test $ntest";
+ print STDERR "# $prefix got: '$result' ($context)\n";
+ $prefix = ' ' x (length($prefix) - 5);
+ if (!$diag) {
+ print STDERR "# $prefix Expected: '$expected'\n";
} else {
- print STDERR "# Got: '$result' ($context)\n";
- if (!$diag) {
- print STDERR "# Expected: '$expected'\n";
- } else {
- print STDERR "# Expected: '$expected' ($diag)\n";
- }
+ print STDERR "# $prefix Expected: '$expected' ($diag)\n";
}
}
+ push @FAILDETAIL, $detail;
}
}
++ $ntest;
$ok;
}
-sub skip {
+sub skip ($$;$$) {
if (to_value(shift)) {
print "ok $ntest # skip\n";
++ $ntest;
1;
} else {
- local($TestLevel) += 1; #ignore this stack frame
- ok(@_);
+ local($TestLevel) = $TestLevel+1; #ignore this stack frame
+ &ok;
}
}
+END {
+ $ONFAIL->(\@FAILDETAIL) if @FAILDETAIL && $ONFAIL;
+}
+
1;
__END__
@@ -124,7 +141,7 @@ __END__
use strict;
use Test;
- BEGIN { plan tests => 12, todo => [3,4] }
+ BEGIN { plan tests => 13, todo => [3,4] }
ok(0); # failure
ok(1); # success
@@ -141,7 +158,8 @@ __END__
ok(0, int(rand(2)); # (just kidding! :-)
my @list = (0,0);
- ok(scalar(@list), 3, "\@list=".join(',',@list)); #extra diagnostics
+ ok @list, 3, "\@list=".join(',',@list); #extra diagnostics
+ ok 'segmentation fault', '/(?i)success/'; #regex match
skip($feature_is_missing, ...); #do platform specific test
@@ -175,10 +193,32 @@ test would be on the new feature list, not the TODO list).
Packages should NOT be released with successful TODO tests. As soon
as a TODO test starts working, it should be promoted to a normal test
-and the new feature should be documented in the release notes.
+and the newly minted feature should be documented in the release
+notes.
=back
+=head1 ONFAIL
+
+ BEGIN { plan test => 4, onfail => sub { warn "CALL 911!" } }
+
+The test failures can trigger extra diagnostics at the end of the test
+run. C<onfail> is passed an array ref of hash refs that describe each
+test failure. Each hash will contain at least the following fields:
+package, repetition, and result. (The file, line, and test number are
+not included because their correspondance to a particular test is
+fairly weak.) If the test had an expected value or a diagnostic
+string, these will also be included.
+
+This optional feature might be used simply to print out the version of
+your package and/or how to report problems. It might also be used to
+generate extremely sophisticated diagnostics for a particular test
+failure. It's not a panacea, however. Core dumps or other
+unrecoverable errors will prevent the C<onfail> hook from running.
+(It is run inside an END block.) Besides, C<onfail> is probably
+over-kill in the majority of cases. (Your test code should be simpler
+than the code it is testing, yes?)
+
=head1 SEE ALSO
L<Test::Harness> and various test coverage analysis tools.
diff --git a/op.c b/op.c
index 7459ae6..0b3fdce 100644
--- a/op.c
+++ b/op.c
@@ -1045,8 +1045,6 @@ modkids(OP *o, I32 type)
return o;
}
-static I32 modcount;
-
OP *
mod(OP *o, I32 type)
{
@@ -2421,6 +2419,7 @@ newASSIGNOP(I32 flags, OP *left, I32 optype, OP *right)
}
if (list_assignment(left)) {
+ dTHR;
modcount = 0;
eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
left = mod(left, OP_AASSIGN);
diff --git a/thrdvar.h b/thrdvar.h
index 812f1bf..7c40481 100644
--- a/thrdvar.h
+++ b/thrdvar.h
@@ -1,4 +1,10 @@
-/* Per-thread variables */
+/* Don't forget to re-run embed.pl to propagate changes! */
+
+/* Per-thread variables
+ The 'T' prefix is only needed for vars that need appropriate #defines
+generated when built with or without USE_THREADS. (It is also used
+to generate the appropriate the export list for win32.) */
+
/* Important ones in the first cache line (if alignment is done right) */
PERLVAR(Tstack_sp, SV **)
@@ -78,10 +84,14 @@ PERLVAR(Tstart_env, JMPENV) /* empty startup sigjmp() environment */
PERLVAR(Tav_fetch_sv, SV *)
PERLVAR(Thv_fetch_sv, SV *)
PERLVAR(Thv_fetch_ent_mh, HE)
+PERLVAR(Tmodcount, I32)
/* XXX Sort stuff, firstgv secongv and so on? */
/* XXX What about regexp stuff? */
+/* Note that the variables below are all explicitly referenced in the code
+as thr->whatever and therefore don't need the 'T' prefix. */
+
#ifdef USE_THREADS
PERLVAR(oursv, SV *)