File Coverage

t/common.plt
Criterion Covered Total %
statement n/a
branch n/a
condition n/a
subroutine n/a
pod n/a
total n/a


line stmt bran cond sub pod time code
1             # -*- Mode: CPerl -*-
2             # File: t/common.plt
3             # Description: re-usable test subs; requires Test::More
4             BEGIN { $| = 1; }
5             use strict;
6              
7             # isok($label,@_) -- prints helpful label
8             sub isok {
9             my $label = shift;
10             if (@_==1) {
11             ok($_[0],$label);
12             } elsif (@_==2) {
13             is($_[0],$_[1], $label);
14             } else {
15             die("isok(): expected 1 or 2 non-label arguments, but got ", scalar(@_));
16             }
17             }
18              
19             # skipok($label,$skip_if_true,@_) -- prints helpful label
20             # skipok($label,$skip_if_true,\&CODE) -- prints helpful label
21             sub skipok {
22             my ($label,$skip_if_true) = splice(@_,0,2);
23             if ($skip_if_true) {
24             subtest $label => sub { plan skip_all => $skip_if_true; };
25             } else {
26             if (@_==1 && ref($_[0]) && ref($_[0]) eq 'CODE') {
27             isok($label, $_[0]->());
28             } else {
29             isok($label,@_);
30             }
31             }
32             }
33              
34             # skipordo($label,$skip_if_true,sub { ok ... },@args_for_sub)
35             sub skipordo {
36             my ($label,$skip_if_true) = splice(@_,0,2);
37             if ($skip_if_true) {
38             subtest $label => sub { plan skip_all => $skip_if_true; };
39             } else {
40             $_[0]->(@_[1..$#_]);
41             }
42             }
43              
44             # ulistok($label,\@got,\@expect)
45             # --> ok() for unsorted lists
46             sub ulistok {
47             my ($label,$l1,$l2) = @_;
48             is_deeply([sort @$l1],[sort @$l2],$label);
49             }
50              
51             # matchpdl($a,$b) : returns pdl identity check, including BAD
52             sub matchpdl {
53             my ($a,$b) = map {PDL->topdl($_)->setnantobad} @_[0,1];
54             return ($a==$b)->setbadtoval(0) | ($a->isbad & $b->isbad) | ($a->isfinite->not & $b->isfinite->not);
55             }
56             # matchpdl($a,$b,$eps) : returns pdl approximation check, including BAD
57             sub matchpdla {
58             my ($a,$b) = map {$_->setnantobad} @_[0,1];
59             my $eps = $_[2];
60             $eps = 1e-5 if (!defined($eps));
61             return $a->approx($b,$eps)->setbadtoval(0) | ($a->isbad & $b->isbad) | ($a->isfinite->not & $b->isfinite->not);
62             }
63              
64             # cmp_dims($got_pdl,$expect_pdl)
65             sub cmp_dims {
66             my ($p1,$p2) = @_;
67             return $p1->ndims==$p2->ndims && all(pdl(PDL::long(),[$p1->dims])==pdl(PDL::long(),[$p2->dims]));
68             }
69              
70             sub pdlstr {
71             my $a = shift;
72             my $str = defined($a) ? "$a" : '(undef)';
73             #$str =~ s/\n/ /g;
74             return $str;
75             }
76             sub labstr {
77             my ($label,$ok,$got,$want) = @_;
78             $label .= "\n : got=".pdlstr($got)."\n : wanted=".pdlstr($want) if (!$ok);
79             return $label;
80             }
81              
82             # pdlok($label, $got, $want)
83             sub pdlok {
84             my ($label,$got,$want) = @_;
85             $got = PDL->topdl($got) if (defined($got));
86             $want = PDL->topdl($want) if (defined($want));
87             my $ok = (defined($got) && defined($want)
88             && cmp_dims($got,$want)
89             && all(matchpdl($want,$got))
90             );
91             isok(labstr($label,$ok,$got,$want), $ok);
92             }
93              
94             # pdlok_nodims($label, $got, $want)
95             # + ignores dimensions
96             sub pdlok_nodims {
97             my ($label,$got,$want) = @_;
98             $got = PDL->topdl($got) if (defined($got));
99             $want = PDL->topdl($want) if (defined($want));
100             my $ok = (defined($got) && defined($want)
101             #&& cmp_dims($got,$want)
102             && all(matchpdl($want,$got)));
103             isok(labstr($label,$ok,$got,$want), $ok);
104             }
105              
106             # pdlapprox($label, $got, $want, $eps=1e-5)
107             sub pdlapprox {
108             my ($label,$got,$want,$eps) = @_;
109             $got = PDL->topdl($got) if (defined($got));
110             $want = PDL->topdl($want) if (defined($want));
111             $eps = 1e-5 if (!defined($eps));
112             my $ok = (defined($got) && defined($want)
113             && cmp_dims($got,$want)
114             && all(matchpdla($want,$got,$eps)));
115             isok(labstr($label,$ok,$got,$want), $ok);
116             }
117              
118              
119             print "loaded ", __FILE__, "\n";
120              
121             1;
122