In perl.git, the branch smoke-me/re-tests has been updated <http://perl5.git.perl.org/perl.git/commitdiff/318342b449fb2f8263e017e0c08855bf6f420447?hp=379799981424d4455e218f63c1f702a594c7b2ca>
- Log ----------------------------------------------------------------- commit 318342b449fb2f8263e017e0c08855bf6f420447 Author: Nicholas Clark <[email protected]> Date: Fri Mar 4 22:32:24 2011 +0000 Refactor ReTest.pl to use test.pl for testing functions and TAP generation. Provide compatibility implementations of nok(), iseq() and isneq(), which will be remove once their callers are refactored. M t/re/ReTest.pl commit 4d2d493bd4a21191bb597c76b532c73c40c9b9eb Author: Nicholas Clark <[email protected]> Date: Fri Mar 4 21:55:46 2011 +0000 Slight tweaks to regexp tests so that they still produce sane TAP with test.pl Explicitly escape non-printable characters in test descriptions, instead of relying on some part of the TAP generation code to do so. Use diag() instead of passing 3 arguments to ok(). Add a mininal diag() implementation to ReTest.pl M t/re/ReTest.pl M t/re/pat.t M t/re/pat_advanced.t M t/re/pat_rt_report.t commit bf2189a6a02de08c4e9c3b257995b35c28d56227 Author: Nicholas Clark <[email protected]> Date: Fri Mar 4 22:02:23 2011 +0000 Use $::TODO, instead of $TODO, and relying on use vars '$TODO' in ReTest.pl M t/re/pat.t M t/re/pat_advanced.t M t/re/pat_rt_report.t commit 7b686c85893b67562abed7cd5e5112338f2507a3 Author: Nicholas Clark <[email protected]> Date: Fri Mar 4 20:47:28 2011 +0000 Remove the line number from the test description output by ReTest.pl This means that the TAP it generates is much closer to that generated by test.pl M t/re/ReTest.pl ----------------------------------------------------------------------- Summary of changes: t/re/ReTest.pl | 167 ++++---------------------------------------------- t/re/pat.t | 46 +++++++------- t/re/pat_advanced.t | 8 +- t/re/pat_rt_report.t | 28 ++++---- 4 files changed, 53 insertions(+), 196 deletions(-) diff --git a/t/re/ReTest.pl b/t/re/ReTest.pl index 00e4605..562bd88 100644 --- a/t/re/ReTest.pl +++ b/t/re/ReTest.pl @@ -8,9 +8,6 @@ use 5.010; use base qw/Exporter/; use Carp; use vars qw( - $EXPECTED_TESTS - $TODO - $running_as_thread $IS_ASCII $IS_EBCDIC $ordA @@ -26,162 +23,26 @@ our $IS_EBCDIC = $ordA == 193; use vars '%Config'; eval 'use Config'; # Defaults assumed if this fails -my $test = 0; -my $done_plan; -sub plan { - my (undef,$tests)= @_; - if (defined $tests) { - die "Number of tests already defined! ($EXPECTED_TESTS)" - if $EXPECTED_TESTS; - $EXPECTED_TESTS= $tests; - } - if ($EXPECTED_TESTS) { - print "1..$EXPECTED_TESTS\n" if !$done_plan++; - } else { - print "Number of tests not declared!"; - } -} - -sub pretty { - my ($mess) = @_; - return unless defined $mess; - $mess =~ s/\n/\\n/g; - $mess =~ s/\r/\\r/g; - $mess =~ s/\t/\\t/g; - $mess =~ s/([\00-\37\177])/sprintf '\%03o', ord $1/eg; - $mess =~ s/#/\\#/g; - $mess; -} - -sub safe_globals { - defined($_) and s/#/\\#/g for $TODO; -} - -sub _ok { - my ($ok, $mess, $error) = @_; - plan(); - safe_globals(); - $mess = defined $mess ? pretty ($mess) : 'Noname test'; - $mess .= " # TODO $TODO" if defined $TODO; - - my $line_nr = (caller(1)) [2]; - - printf "%sok %d - %s\n", - ($ok ? "" : "not "), - ++ $test, - "$mess\tLine $line_nr"; - - unless ($ok) { - print "# Failed test at line $line_nr\n" unless defined $TODO; - if ($error) { - no warnings 'utf8'; - chomp $error; - $error = join "\n#", map {pretty $_} split /\n\h*#/ => $error; - $error = "# $error" unless $error =~ /^\h*#/; - print $error, "\n"; - } - } - - return $ok; -} - -# Force scalar context on the pattern match -sub ok ($;$$) {_ok $_ [0], $_ [1], $_ [2]} -sub nok ($;$$) {_ok !$_ [0], "Failed: " . $_ [1], $_ [2]} - - -sub skip { - my $why = shift; - safe_globals(); - $why =~ s/\n.*//s; - my $ok; - if (defined $TODO) { - $why = "TODO & SKIP $why $TODO"; - $ok = "not ok"; - } else { - $why = "SKIP $why"; - $ok = "ok"; - } - - my $n = shift // 1; - my $line_nr = (caller(0)) [2]; - for (1 .. $n) { - ++ $test; - print "$ok $test # $why\tLine $line_nr\n"; - } - no warnings "exiting"; - last SKIP; +BEGIN { + require './test.pl'; } -sub iseq ($$;$) { - my ($got, $expected, $name) = @_; +*iseq = \&is; +*isneq = \&isnt; - my $pass; - if(!defined $got || !defined $expected) { - # undef only matches undef - $pass = !defined $got && !defined $expected; - } - else { - $pass = $got eq $expected; - } - - $_ = defined ($_) ? "'$_'" : "undef" for $got, $expected; - - my $error = "# expected: $expected\n" . - "# result: $got"; - - _ok $pass, $name, $error; -} - -sub isneq ($$;$) { - my ($got, $isnt, $name) = @_; - - my $pass; - if(!defined $got || !defined $isnt) { - # undef only matches undef - $pass = defined $got || defined $isnt; - } - else { - $pass = $got ne $isnt; - } - - $got = defined $got ? "'$got'" : "undef"; - my $error = "# results are equal ($got)"; - - _ok $pass, $name, $error; -} - -*is = \&iseq; -*isnt = \&isneq; - -sub like ($$$) { - my (undef, $expected, $name) = @_; - my ($pass, $error); - $pass = $_[0] =~ /$expected/; - unless ($pass) { - $error = "# got '$_[0]'\n# expected /$expected/"; - } - _ok($pass, $name, $error); -} - -sub unlike ($$$) { - my (undef, $expected, $name) = @_; - my ($pass, $error); - $pass = $_[0] !~ /$expected/; - unless ($pass) { - $error = "# got '$_[0]'\n# expected !~ /$expected/"; - } - _ok($pass, $name, $error); +sub nok ($;$$) { + my $bool = shift; + ok(!$bool, @_); } sub eval_ok ($;$) { my ($code, $name) = @_; local $@; if (ref $code) { - _ok eval {&$code} && !$@, $name; + ok eval {&$code} && !$@, $name; } else { - _ok eval ($code) && !$@, $name; + ok eval ($code) && !$@, $name; } } @@ -191,7 +52,7 @@ sub must_die { undef $@; ref $code ? &$code : eval $code; my $r = $@ && $@ =~ /$pattern/; - _ok $r, $name // "\$\@ =~ /$pattern/"; + like($@, $pattern, $name // "\$\@ =~ /$pattern/"); } sub must_warn { @@ -201,11 +62,7 @@ sub must_warn { local $SIG {__WARN__} = sub {$w .= join "" => @_}; use warnings 'all'; ref $code ? &$code : eval $code; - my $r = $w && $w =~ /$pattern/; - $w //= "UNDEF"; - _ok $r, $name // "Got warning /$pattern/", - "# expected: /$pattern/\n" . - "# result: $w"; + like($w, qr/$pattern/, "Got warning /$pattern/"); } sub may_not_warn { @@ -214,7 +71,7 @@ sub may_not_warn { local $SIG {__WARN__} = sub {$w .= join "" => @_}; use warnings 'all'; ref $code ? &$code : eval $code; - _ok !$w, $name, "Got warning '$w'"; + is($w, undef, $name) or diag("Got warning '$w'"); } 1; diff --git a/t/re/pat.t b/t/re/pat.t index 8c8baf1..1cd801e 100644 --- a/t/re/pat.t +++ b/t/re/pat.t @@ -33,26 +33,26 @@ run_tests() unless caller; sub run_tests { { - my $x = "abc\ndef\n"; + (my $x_pretty = $x) =~ s/\n/\\n/g; - ok $x =~ /^abc/, qq ["$x" =~ /^abc/]; - ok $x !~ /^def/, qq ["$x" !~ /^def/]; + ok $x =~ /^abc/, qq ["$x_pretty" =~ /^abc/]; + ok $x !~ /^def/, qq ["$x_pretty" !~ /^def/]; # used to be a test for $* - ok $x =~ /^def/m, qq ["$x" =~ /^def/m]; + ok $x =~ /^def/m, qq ["$x_pretty" =~ /^def/m]; - nok $x =~ /^xxx/, qq ["$x" =~ /^xxx/]; - nok $x !~ /^abc/, qq ["$x" !~ /^abc/]; + nok $x =~ /^xxx/, qq ["$x_pretty" =~ /^xxx/]; + nok $x !~ /^abc/, qq ["$x_pretty" !~ /^abc/]; - ok $x =~ /def/, qq ["$x" =~ /def/]; - nok $x !~ /def/, qq ["$x" !~ /def/]; + ok $x =~ /def/, qq ["$x_pretty" =~ /def/]; + nok $x !~ /def/, qq ["$x_pretty" !~ /def/]; - ok $x !~ /.def/, qq ["$x" !~ /.def/]; - nok $x =~ /.def/, qq ["$x" =~ /.def/]; + ok $x !~ /.def/, qq ["$x_pretty" !~ /.def/]; + nok $x =~ /.def/, qq ["$x_pretty" =~ /.def/]; - ok $x =~ /\ndef/, qq ["$x" =~ /\ndef/]; - nok $x !~ /\ndef/, qq ["$x" !~ /\ndef/]; + ok $x =~ /\ndef/, qq ["$x_pretty" =~ /\\ndef/]; + nok $x !~ /\ndef/, qq ["$x_pretty" !~ /\\ndef/]; } { @@ -84,7 +84,7 @@ sub run_tests { { # used to be a test for $* - ok "ab\ncd\n" =~ /^cd/m, qq ["ab\ncd\n" =~ /^cd/m]; + ok "ab\ncd\n" =~ /^cd/m, q ["ab\ncd\n" =~ /^cd/m]; } { @@ -444,7 +444,7 @@ sub run_tests { my $res = eval { "xx" =~ /(?$code)/o }; { no warnings 'uninitialized'; - my $message = "$message '$@', '$res', '$blah'"; + chomp $@; my $message = "$message '$@', '$res', '$blah'"; ok($@ && $@ =~ /not allowed at runtime/ && $blah == 12, $message); } @@ -704,7 +704,7 @@ sub run_tests { unlike($str, qr/^...\G/, $message); ok($str =~ /\G../ && $& eq 'cd', $message); - local $TODO = $running_as_thread; + local $::TODO = $::running_as_thread; ok($str =~ /.\G./ && $& eq 'bc', $message); } @@ -779,7 +779,7 @@ sub run_tests { my $foo = 'aabbccddeeffgg'; pos ($foo) = 1; { - local $TODO = $running_as_thread; + local $::TODO = $::running_as_thread; no warnings 'uninitialized'; ok($foo =~ /.\G(..)/g, $message); is($1, 'ab', $message); @@ -966,11 +966,11 @@ sub run_tests { sub new {bless []} my $message = "Ref stringification"; - ::ok(do { \my $v} =~ /^SCALAR/, "Scalar ref stringification", $message); - ::ok(do {\\my $v} =~ /^REF/, "Ref ref stringification", $message); - ::ok([] =~ /^ARRAY/, "Array ref stringification", $message); - ::ok({} =~ /^HASH/, "Hash ref stringification", $message); - ::ok('S' -> new =~ /^Object S/, "Object stringification", $message); + ::ok(do { \my $v} =~ /^SCALAR/, "Scalar ref stringification") or diag($message); + ::ok(do {\\my $v} =~ /^REF/, "Ref ref stringification") or diag($message); + ::ok([] =~ /^ARRAY/, "Array ref stringification") or diag($message); + ::ok({} =~ /^HASH/, "Hash ref stringification") or diag($message); + ::ok('S' -> new =~ /^Object S/, "Object stringification") or diag($message); } @@ -1071,7 +1071,7 @@ sub run_tests { my $message = '\p property after empty * match'; { - local $TODO = "Bug 77414"; + local $::TODO = "Bug 77414"; like("1", qr/\s*\pN/, $message); like("-", qr/\s*\p{Dash}/, $message); like(" ", qr/\w*\p{Blank}/, $message); @@ -1158,7 +1158,7 @@ sub run_tests { } { - local $TODO = "[perl #38133]"; + local $::TODO = "[perl #38133]"; "A" =~ /(((?:A))?)+/; my $first = $2; diff --git a/t/re/pat_advanced.t b/t/re/pat_advanced.t index df3e2bf..8eb872d 100644 --- a/t/re/pat_advanced.t +++ b/t/re/pat_advanced.t @@ -880,7 +880,7 @@ sub run_tests { # hasn't been crashing. Disable this test until it is fixed properly. # XXX also check what it returns rather than just doing ok(1,...) # split /(?{ split "" })/, "abc"; - local $TODO = "Recursive split is still broken"; + local $::TODO = "Recursive split is still broken"; ok 0, 'cache_re & "(?{": it dumps core in 5.6.1 & 5.8.0'; } @@ -1042,7 +1042,7 @@ sub run_tests { undef $w; eval q [ok "\0" !~ /[\N{EMPTY-STR}XY]/, - "Zerolength charname in charclass doesn't match \\0"]; + "Zerolength charname in charclass doesn't match \\\\0"]; ok $w && $w =~ /Ignoring zero length/, 'Ignoring zero length \N{} in character class warning'; @@ -1475,8 +1475,8 @@ sub run_tests { ok "\N{SMALL ROMAN NUMERAL ONE}" =~ /\p{Uppercase}/i, "i =~ Uppercase under /i"; ok "\N{SMALL ROMAN NUMERAL ONE}" !~ /\p{Titlecase}/, "i !~ Titlecase"; ok "\N{SMALL ROMAN NUMERAL ONE}" =~ /\p{Titlecase}/i, "i =~ Titlecase under /i"; - ok "\N{ROMAN NUMERAL ONE}" =~ /\p{Lowercase}/i, "I =~ Lowercase under - /i"; + ok "\N{ROMAN NUMERAL ONE}" =~ /\p{Lowercase}/i, "I =~ Lowercase under /i"; + ok "\N{SMALL ROMAN NUMERAL ONE}" =~ /\p{Lowercase}/, "i =~ Lowercase"; ok "\N{SMALL ROMAN NUMERAL ONE}" =~ /\p{IDStart}/, "i =~ ID_Start"; ok "\N{SMALL ROMAN NUMERAL ONE}" =~ /\p{IDContinue}/, "i =~ ID_Continue" diff --git a/t/re/pat_rt_report.t b/t/re/pat_rt_report.t index bf71634..33ab876 100644 --- a/t/re/pat_rt_report.t +++ b/t/re/pat_rt_report.t @@ -147,7 +147,7 @@ sub run_tests { # Amazingly vertical tabulator is the same in ASCII and EBCDIC. for ("\n", "\t", "\014", "\r") { - unlike($_, qr/[[:print:]]/, "'$_' not in [[:print:]]; Bug 20010619.003"); + unlike($_, qr/[[:print:]]/, sprintf "\\%03o not in [[:print:]]; Bug 20010619.003", ord $_); } for (" ") { like($_, qr/[[:print:]]/, "'$_' in [[:print:]]; Bug 20010619.003"); @@ -232,10 +232,10 @@ sub run_tests { $num =~ /\d/; for (0 .. 1) { my $match = m?? + 0; - ok $match != $_, $message, - sprintf "'match one' %s on %s iteration" => - $match ? 'succeeded' : 'failed', - $_ ? 'second' : 'first'; + ok($match != $_, $message) + or diag(sprintf "'match one' %s on %s iteration" => + $match ? 'succeeded' : 'failed', + $_ ? 'second' : 'first'); } $num =~ /(\d)/; my $result = join "" => $num =~ //g; @@ -251,9 +251,9 @@ sub run_tests { for my $len (32000, 32768, 33000) { my $s = $char . "f" x $len; my $r = $s =~ /$char([f]*)/gc; - ok $r, $message, "<$type x $len>"; - ok !$r || pos ($s) == $len + 1, $message, - "<$type x $len>; pos = @{[pos $s]}"; + ok($r, $message) or diag("<$type x $len>"); + ok(!$r || pos ($s) == $len + 1, $message) + or diag("<$type x $len>; pos = @{[pos $s]}"); } } } @@ -440,7 +440,7 @@ sub run_tests { # hasn't been crashing. Disable this test until it is fixed properly. # XXX also check what it returns rather than just doing ok(1,...) # split /(?{ split "" })/, "abc"; - local $TODO = "Recursive split is still broken"; + local $::TODO = "Recursive split is still broken"; ok 0, 'cache_re & "(?{": it dumps core in 5.6.1 & 5.8.0'; } @@ -602,7 +602,7 @@ sub run_tests { { - local $TODO = "See changes 26925-26928, which reverted change 26410"; + local $::TODO = "See changes 26925-26928, which reverted change 26410"; { package lv; our $var = "abc"; @@ -620,7 +620,7 @@ sub run_tests { iseq $f, "ab", "pos() retained between calls"; } else { - local $TODO; + local $::TODO; ok 0, "Code failed: $@"; } @@ -637,7 +637,7 @@ sub run_tests { iseq $g, "ab", "pos() retained between calls"; } else { - local $TODO; + local $::TODO; ok 0, "Code failed: $@"; } } @@ -905,7 +905,7 @@ sub run_tests { for my $l (10, 100, 1000) { $count = 0; ('a' x $l) =~ /(.*)(?{$count++})[bc]/; - local $TODO = "Should be L+1 not L*(L+3)/2 (L=$l)"; + local $::TODO = "Should be L+1 not L*(L+3)/2 (L=$l)"; is($count, $l + 1, $message); } } @@ -1161,7 +1161,7 @@ sub run_tests { } { - local $TODO = "[perl #38133]"; + local $::TODO = "[perl #38133]"; "A" =~ /(((?:A))?)+/; my $first = $2; -- Perl5 Master Repository
