File Coverage

web/cgi-bin/yatt.lib/YATT/Test.pm
Criterion Covered Total %
statement 198 208 95.1
branch 50 70 71.4
condition 17 29 58.6
subroutine 36 38 94.7
pod 0 13 0.0
total 301 358 84.0


line stmt bran cond sub pod time code
1             # -*- mode: perl; coding: utf-8 -*-
2             package YATT::Test;
3 10     10   39949 use strict;
  10         22  
  10         317  
4 10     10   223 use warnings qw(FATAL all NONFATAL misc);
  10         17  
  10         469  
5 10     10   49 use base qw(Test::More);
  10         17  
  10         8786  
6 10     10   163474 BEGIN {$INC{'YATT/Test.pm'} = __FILE__}
7              
8 10     10   78 use File::Basename;
  10         20  
  10         752  
9 10     10   53 use Cwd;
  10         20  
  10         608  
10              
11 10     10   9937 use Data::Dumper;
  10         97214  
  10         705  
12 10     10   74 use Carp;
  10         23  
  10         672  
13              
14 10     10   9185 use Time::HiRes qw(usleep);
  10         16390  
  10         64  
15              
16 10     10   6631 use YATT;
  10         25  
  10         333  
17 10         746 use YATT::Util qw(rootname catch checked_eval default defined_fmt
18             require_and
19 10     10   75 );
  10         20  
20 10     10   5526 use YATT::Util::Symbol;
  10         25  
  10         1065  
21 10     10   71 use YATT::Util::Finalizer;
  10         19  
  10         599  
22 10     10   6167 use YATT::Util::DirTreeBuilder qw(tmpbuilder);
  10         31  
  10         587  
23 10     10   6144 use YATT::Util::DictOrder;
  10         27  
  10         10308  
24              
25             #========================================
26              
27             our @EXPORT = qw(ok is isnt like is_deeply skip fail plan
28             require_ok isa_ok
29             basename
30              
31             wait_for_time
32              
33             is_rendered raises is_can run
34             capture rootname checked_eval default defined_fmt
35             tmpbuilder
36             dumper
37              
38             xhf_test
39             *TRANS
40             );
41             foreach my $name (@EXPORT) {
42             my $glob = globref(__PACKAGE__, $name);
43             unless (*{$glob}{CODE}) {
44             *$glob = \&{globref("Test::More", $name)};
45             }
46             }
47              
48             *eq_or_diff = do {
49             if (catch {require Test::Differences} \ my $error) {
50             \&Test::More::is;
51             } else {
52             \&Test::Differences::eq_or_diff;
53             }
54             };
55              
56             push @EXPORT, qw(eq_or_diff);
57              
58             our @EXPORT_OK = @EXPORT;
59              
60             #========================================
61              
62             sub run {
63 1     1 0 3 my ($testname, $sub) = @_;
64 1         2 my $res = eval { $sub->() };
  1         4  
65 1         1015 Test::More::is $@, '', "$testname doesn't raise error";
66 1         563 $res
67             }
68              
69             sub is_can ($$$) {
70 2     2 0 604 my ($desc, $cmp, $title) = @_;
71 2         6 my ($obj, $method, @args) = @$desc;
72 2         31 my $sub = $obj->can($method);
73 2         12 Test::More::ok defined $sub, "$title - can";
74 2 50       1254 if ($sub) {
75 2         743 Test::More::is scalar($sub->($obj, @args)), $cmp, $title;
76             } else {
77 0         0 Test::More::fail "skipped because method '$method' not found.";
78             }
79             }
80              
81             sub is_rendered ($$$) {
82 130     130 0 4897 my ($desc, $cmp, $title) = @_;
83 130         342 my ($trans, $path, @args) = @$desc;
84 130         204 my $error;
85 130 0   0   909 local $SIG{__DIE__} = sub {$error = @_ > 1 ? [@_] : shift};
  0         0  
86 130 0   0   676 local $SIG{__WARN__} = sub {$error = @_ > 1 ? [@_] : shift};
  0         0  
87 130         267 my ($sub, $pkg) = eval {
88 130         568 &YATT::break_translator;
89 130         578 $trans->get_handler_to(render => @$path)
90             };
91 130         893 Test::More::is $error, undef, "$title - compiled.";
92 130         85919 eval {
93 130 50       376 if ($sub) {
    0          
94             my $out = capture {
95 130     130   495 &YATT::break_handler;
96 130         5307 $sub->($pkg, @args);
97 130         1171 };
98 130 50       812 $out =~ s{\r}{}g if defined $out;
99 130         647 eq_or_diff($out, $cmp, $title);
100             } elsif ($error) {
101 0         0 Test::More::fail "skipped, because of previous compile error for [$title]: $error";
102             }
103             };
104 130 50       124891 if ($@) {
105 0         0 Test::More::fail "$title: runtime error: $@";
106             }
107             }
108              
109             sub raises ($$$) {
110 32     32 0 144 my ($desc, $cmp, $title) = @_;
111 32         100 my ($trans, $method, @args) = @$desc;
112 32     32   54 my $result = eval {capture {$trans->$method(@args)}};
  32         333  
  32         177  
113 32         468 Test::More::like $@, $cmp, $title;
114 32         24300 $result;
115             }
116              
117             #----------------------------------------
118              
119             sub dumper {
120             join "\n", map {
121 86     86 0 3615 Data::Dumper->new([$_])->Terse(1)->Indent(0)->Dump;
  140         3430  
122             } @_;
123             }
124              
125             #----------------------------------------
126 10     10   65 use base qw(YATT::Class::Configurable);
  10         19  
  10         1220  
127 10         157 use YATT::Types -base => __PACKAGE__
128             , [TestDesc => [qw(cf_FILE realfile
129             ntests
130             cf_TITLE num cf_TAG
131             cf_BREAK
132             cf_SKIP
133             cf_WIDGET
134             cf_RANDOM
135             cf_IN cf_PARAM cf_OUT cf_ERROR)]]
136             , [Config => [['^cf_translator' => 'YATT::Translator::Perl']
137             , '^cf_toplevel'
138             , '^TMPDIR', 'gen'
139             ]]
140             , [Toplevel => []]
141 10     10   5288 ;
  10         24  
142              
143 1 50   1   3 Config->define(target => sub { my $self = shift; $self->toplevel
  1         6  
144             || $self->translator });
145              
146             Config->define(new_translator => sub {
147             ;#
148 13     13   111 (my Config $global, my ($loader, @opts)) = @_;
149 13         83 require_and($global->translator => new => loader => $loader, @opts);
150             });
151              
152             Config->define(configure_DIR => sub {
153             ;#
154 1     1   3 (my Config $global, my ($dir)) = @_;
155 1         6 $global->{TMPDIR} = tmpbuilder($dir);
156             });
157              
158             sub ntests {
159 1     1 0 2 my $ntests = 0;
160 1         3 foreach my $section (@_) {
161 13         17 foreach my TestDesc $test (@{$section}[1 .. $#$section]) {
  13         27  
162 184         260 $ntests += $test->{ntests};
163             }
164             }
165 1         7 $ntests;
166             }
167              
168             sub xhf_test {
169 1     1 0 12 my Config $global = do {
170 1         34 shift->Config->new(DIR => shift);
171             };
172              
173 1 50 33     27 if (@_ == 1 and -d $_[0]) {
174 1         3 my $srcdir = shift;
175 1         305 @_ = dict_sort <$srcdir/*.xhf>;
176             }
177              
178 1 50       10 croak "Source is missing." unless @_;
179 1         8 my @sections = $global->xhf_load_sections(@_);
180              
181 1         5 Test::More::plan(tests => 1 + ntests(@sections));
182              
183 1         167 require_ok($global->target);
184              
185 1         395 $global->xhf_do_sections(@sections);
186             }
187              
188             sub xhf_load_sections {
189 1     1 0 2 my Config $global = shift;
190              
191 1         622 require YATT::XHF;
192              
193 1         3 my @sections;
194 1         4 foreach my $testfile (@_) {
195 13         71 my $parser = new YATT::XHF(filename => $testfile);
196 13         19 my TestDesc $prev;
197 13         27 my ($n, @test, %uniq) = (0);
198 13         34 while (my $rec = $parser->read_as_hash) {
199 184 50       382 if ($rec->{global}) {
200 0         0 $global->configure(%{$rec->{global}});
  0         0  
201 0         0 next;
202             }
203 184         1004 push @test, my TestDesc $test = $global->TestDesc->new(%$rec);
204 184         443 $test->{ntests} = $global->ntests_in_desc($test);
205             $test->{cf_FILE} ||= $prev && $prev->{cf_FILE}
206 184 100 66     1326 && $prev->{cf_FILE} =~ m{%d} ? $prev->{cf_FILE} : undef;
      100        
207              
208 184 100       410 if ($test->{cf_IN}) {
209 10     10   5562 use YATT::Util::redundant_sprintf;
  10         27  
  10         77  
210 159   100     708 $test->{realfile} = sprintf($test->{cf_FILE} ||= "doc/f%d.html", $n);
211 159   66     382 $test->{cf_WIDGET} ||= do {
212 159         252 my $widget = $test->{realfile};
213 159         451 $widget =~ s{^doc/}{};
214 159         531 $widget =~ s{\.\w+$}{};
215 159         268 $widget =~ s{/}{:}g;
216 159         502 $widget;
217             };
218             }
219              
220 184 100       440 if ($test->{cf_OUT}) {
221 130   33     335 $test->{cf_WIDGET} ||= $prev && $prev->{cf_WIDGET};
      66        
222 130 100 66     394 if (not $test->{cf_TITLE} and $prev) {
223 23         76 $test->{num} = default($prev->{num}) + 1;
224 23         58 $test->{cf_TITLE} = $prev->{cf_TITLE};
225             }
226             }
227 184         286 $prev = $test;
228             } continue {
229 184         819 $n++;
230             }
231              
232 13         214 push @sections, [$testfile => @test];
233             }
234              
235 1         6 @sections;
236             }
237              
238             sub xhf_is_runnable {
239 184     184 0 395 (my Config $global, my TestDesc $test) = @_;
240 184 100       1170 $test->{cf_OUT} || $test->{cf_ERROR};
241             }
242              
243             sub xhf_do_sections {
244 1     1 0 7 (my Config $global, my @sections) = @_;
245              
246 1         3 my $SECTION = 0;
247 1         2 foreach my $section (@sections) {
248 13         102 my ($testfile, @all) = @$section;
249 13         105 my $builder = $global->{TMPDIR}->as_sub;
250 13         94 my $DIR = $builder->([DIR => "doc"]);
251              
252 13         47 my @test;
253 13         34 foreach my TestDesc $test (@all) {
254 184 100       620 if ($test->{cf_IN}) {
255 159 50       1166 die "Conflicting FILE: $test->{realfile}!\n" if -e $test->{realfile};
256             $builder->($global->{TMPDIR}->path2desc
257 159         700 ($test->{realfile}, $test->{cf_IN}));
258             }
259 184 100       897 push @test, $test if $global->xhf_is_runnable($test);
260             }
261              
262 13         70 my @loader = (DIR => "$DIR/doc");
263 13         31 push @loader, LIB => do {
264 13 100       310 if (-d "$DIR/lib") {
265 1         5 my $libdir = "$DIR/lib";
266 1         41 chmod 0755, $libdir;
267 1         4 $libdir;
268             } else {
269 12         108 getcwd;
270             }
271             };
272              
273 13         26 my %config;
274 13 100       309 if (-r (my $fn = "$DIR/doc/.htyattroot")) {
275 2         48 %config = YATT::XHF->new(filename => $fn)->read_as('pairlist');
276             }
277              
278 13         105 &YATT::break_translator;
279             $global->{gen} = ($global->toplevel || $global)->new_translator
280             (\@loader
281             , app_prefix => "MyApp$SECTION"
282             , debug_translator => $ENV{DEBUG}
283 13   33     68 , no_lineinfo => YATT::Util::no_lineinfo()
284             , %config
285             );
286              
287 13         5799 foreach my TestDesc $test (@test) {
288 162 50       776 my @widget_path; @widget_path = split /:/, $test->{cf_WIDGET} if $test->{cf_WIDGET};
  162         1115  
289 162 50       258 my ($param); ($param) = map {ref $_ ? $_ : 'main'->checked_eval($_)}
  90         446  
290 162 100       687 $test->{cf_PARAM} if $test->{cf_PARAM};
291              
292             SKIP: {
293 162         288 $global->xhf_runtest_desc($test, $testfile, \@widget_path, $param);
  162         636  
294             }
295             }
296             } continue {
297 13         1546 $SECTION++;
298             }
299             }
300              
301             sub xhf_runtest_desc {
302 162     162 0 444 (my Config $global, my TestDesc $test
303             , my ($testfile, $widget_path, $param)) = @_;
304              
305 162 50       635 unless (defined $test->{cf_TITLE}) {
306 0         0 die "test title is not defined!" . dumper($test);
307             }
308             my $title = join("", '[', basename($testfile), '] ', $test->{cf_TITLE}
309 162         8242 , defined_fmt(' (%d)', $test->{num}, ''));
310              
311 162         879 my $toplevel = $global->toplevel;
312 162 100       589 if ($test->{cf_OUT}) {
    50          
313             Test::More::skip("($test->{cf_SKIP}) $title", 2)
314 130 100       505 if $test->{cf_SKIP};
315              
316 129 50 33     462 if ($toplevel
317             and my $sub = $toplevel->can("set_random_list")) {
318 0         0 $sub->($global, $test->{cf_RANDOM});
319             }
320              
321 129 100       411 &YATT::breakpoint if $test->{cf_BREAK};
322             is_rendered [$global->{gen}, $widget_path, $param]
323 129         650 , $test->{cf_OUT}, $title;
324             } elsif ($test->{cf_ERROR}) {
325             Test::More::skip("($test->{cf_SKIP}) $title", 1)
326 32 100       121 if $test->{cf_SKIP};
327 31 100       105 &YATT::breakpoint if $test->{cf_BREAK};
328 31         920 raises [$global->{gen}, call_handler => render => $widget_path, $param]
329             , qr{$test->{cf_ERROR}}s, $title;
330             }
331             }
332              
333             sub ntests_in_desc {
334 184     184 0 276 (my $this, my TestDesc $test) = @_;
335 184 100       399 if ($test->{cf_OUT}) {
    100          
336 130         289 2
337             } elsif ($test->{cf_ERROR}) {
338 32         69 1
339             } else {
340 22         50 0
341             }
342             }
343              
344             #
345             sub wait_for_time {
346 4     4 0 1015 my ($time) = @_;
347 4         19 my $now = Time::HiRes::time;
348 4         12 my $diff = $time - $now;
349 4 100       23 return if $diff <= 0;
350 2         1353935 usleep(int($diff * 1000 * 1000));
351 2         42 $diff;
352             }
353              
354             1;