Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

178 lines (157 sloc) 5.133 kb
my module Test;
constant $?TRANSPARENT = 1;
class Builder {
has $!current-test;
has $!set-plan;
has $!todo-up-to;
has $!todo-reason;
method new() {
$*TEST-BUILDER;
}
method blame() {
my $frame = caller;
while $frame.hints('$?TRANSPARENT') {
$frame = $frame.caller;
}
$frame.file ~ " line " ~ $frame.line;
}
method !output($text) {
say $text;
}
method reset() {
$!current-test = 1;
}
method note($m) {
self!output("# " ~ $m);
0;
}
method ok($bool, $tag) {
my $not = $bool ?? "" !! "not ";
my $desc;
if $tag {
$desc = " - " ~ $tag.subst('#', '\#').split("\n").join("\n#");
} else {
$desc = '';
}
if $!todo-up-to >= $!current-test {
$desc ~= " # TODO $!todo-reason";
}
self!output($not ~ "ok " ~ $!current-test++ ~ $desc);
if !$bool { self.note(self.blame); }
}
method todo($reason, $count) {
$!todo-reason = $reason;
$!todo-up-to = $!current-test + $count - 1; # todo(1) should stop after cur
}
method skip($reason) {
self!output("ok {$!current-test++} # SKIP $reason");
}
method expected-tests($num) {
self!output("1.." ~ $num);
}
method plan($x) {
$!set-plan = 1;
if $x ~~ Cool {
self.expected-tests(+$x);
} else {
die "Invalid argument to plan";
}
}
method done {
if !($!set-plan) {
self!output("1.." ~ ($!current-test - 1));
}
}
}
INIT {
$GLOBAL::TEST-BUILDER = Builder.bless(*);
$GLOBAL::TEST-BUILDER.reset;
}
sub cmp_ok(\$a, $fn, \$b, $tag?) is export { ok($fn($a, $b), $tag); }
sub ok(\$bool, $tag?) is export { $*TEST-BUILDER.ok(?$bool, $tag) }
sub nok(\$bool, $tag?) is export { $*TEST-BUILDER.ok(!$bool, $tag) }
sub skip_rest($tag?) is export { } #OK
sub pass($tag?) is export { $*TEST-BUILDER.ok(1, $tag); True }
sub flunk($tag?) is export { $*TEST-BUILDER.ok(0, $tag) }
sub isa_ok(Mu $obj, Mu $type, $tag?) is export { $*TEST-BUILDER.ok($obj.^isa($type), $tag) }
sub is_deeply($a,$b,$c) is export { is $a.perl, $b.perl, $c }
sub is(\$got, \$expected, $tag?) is export {
# avoid comparing twice
my $equal = (~$got) eq (~$expected);
$*TEST-BUILDER.ok($equal, $tag);
if !$equal {
$*TEST-BUILDER.note(' Failed test');
$*TEST-BUILDER.note(' got: ' ~ ~$got);
$*TEST-BUILDER.note(' expected: ' ~ ~$expected);
}
}
sub isnt(Mu $got, Mu $expected, $tag?) is export { $*TEST-BUILDER.ok($got ne $expected, $tag) }
# Runs $code, trapping various failure modes and returning applicable.
sub no-control($code) {
my ($died, $warned);
{
CATCH { default { $died = True } }
CONTROL {
if .[0] == 11 {
$warned = True;
return; # NIECZA - causes &warn to return
}
when .[0] != 11 { $died = True } # exits block
}
$code.();
}
$died ?? "die" !! $warned ?? "warn" !! "";
}
sub lives_ok($code,$why?) is export {
$*TEST-BUILDER.ok(no-control($code) ne "die", $why);
}
sub dies_ok($code,$why?) is export {
$*TEST-BUILDER.ok(no-control($code) eq "die", $why);
}
sub succeeds_ok($code,$why?,:$ignore = ()) is export {
$*TEST-BUILDER.ok(?(no-control($code) eq any("", @$ignore)), $why);
}
sub fails_ok($code,$why?,:$expect = <die warn fail>) is export {
$*TEST-BUILDER.ok(?(no-control($code) eq any(@$expect)), $why);
}
sub eval_lives_ok($code,$why?) is export {
$*TEST-BUILDER.ok(no-control({ eval $code }) ne "die", $why);
}
sub eval_dies_ok($code,$why?) is export {
$*TEST-BUILDER.ok(no-control({ eval $code }) eq "die", $why);
}
sub eval_succeeds_ok($code,$why?,:$ignore = ()) is export {
$*TEST-BUILDER.ok(?(no-control({ eval $code }) eq any("", @$ignore)), $why);
}
sub eval_fails_ok($code,$why?,:$expect = <die warn fail>) is export {
$*TEST-BUILDER.ok(?(no-control({ eval $code }) eq any(@$expect)), $why);
}
sub diag($str) is export { $*TEST-BUILDER.note($str) }
sub is_approx(Mu $got, Mu $expected, $desc = '') is export {
my $test = ($got - $expected).abs <= 1/100000;
$*TEST-BUILDER.ok(?$test, $desc);
unless $test {
$*TEST-BUILDER.note("got: $got");
$*TEST-BUILDER.note("expected: $expected");
}
?$test;
}
sub todo($reason="", $count = 1) is export { $*TEST-BUILDER.todo($reason, $count) }
sub plan($num) is export { $*TEST-BUILDER.plan($num) }
sub done() is export { $*TEST-BUILDER.done }
sub skip($reason,$number) is export {
$*TEST-BUILDER.skip($reason) for ^$number;
}
# TODO standardize me
sub rxtest($rgx, $rgxname, @y, @n) is export {
for @y {
my $k = $_ ~~ Pair ?? $_.key !! $_;
my $v = $_ ~~ Pair ?? $_.value !! $_;
ok $k ~~ $rgx, "$rgxname ~~ $v";
}
for @n {
my $k = $_ ~~ Pair ?? $_.key !! $_;
my $v = $_ ~~ Pair ?? $_.value !! $_;
ok !($k ~~ $rgx), "$rgxname !~~ $v";
}
}
Jump to Line
Something went wrong with that request. Please try again.