File Coverage

lib/Template/Test.pm
Criterion Covered Total %
statement 102 129 79.0
branch 51 72 70.8
condition 6 12 50.0
subroutine 14 15 93.3
pod 4 10 40.0
total 177 238 74.3


line stmt bran cond sub pod time code
1             #============================================================= -*-Perl-*-
2             #
3             # Template::Test
4             #
5             # DESCRIPTION
6             # Module defining a test harness which processes template input and
7             # then compares the output against pre-define expected output.
8             # Generates test output compatible with Test::Harness. This was
9             # originally the t/texpect.pl script.
10             #
11             # AUTHOR
12             # Andy Wardley
13             #
14             # COPYRIGHT
15             # Copyright (C) 1996-2007 Andy Wardley. All Rights Reserved.
16             #
17             # This module is free software; you can redistribute it and/or
18             # modify it under the same terms as Perl itself.
19             #
20             #============================================================================
21              
22             package Template::Test;
23              
24 84     84   213114 use strict;
  84         169  
  84         3269  
25 84     84   441 use warnings;
  84         1502  
  84         2978  
26 84     84   44498 use Template qw( :template );
  84         2635  
  84         4218  
27 84     84   2032 use Exporter;
  84         179  
  84         231670  
28              
29             our $VERSION = 2.75;
30             our $DEBUG = 0;
31             our @ISA = qw( Exporter );
32             our @EXPORT = qw( ntests ok is match flush skip_all test_expect callsign banner );
33             our @EXPORT_OK = ( 'assert' );
34             our %EXPORT_TAGS = ( all => [ @EXPORT_OK, @EXPORT ] );
35             $| = 1;
36              
37             our $REASON = 'not applicable on this platform';
38             our $NO_FLUSH = 0;
39             our $EXTRA = 0; # any extra tests to come after test_expect()
40             our $PRESERVE = 0 # don't mangle newlines in output/expect
41             unless defined $PRESERVE;
42              
43             our ($loaded, %callsign);
44              
45             # always set binmode on Win32 machines so that any output generated
46             # is true to what we expect
47             $Template::BINMODE = ($^O eq 'MSWin32') ? 1 : 0;
48              
49             my @results = ();
50             my ($ntests, $ok_count);
51             *is = \&match;
52              
53             END {
54             # ensure flush() is called to print any cached results
55 84     84   829 flush();
56             }
57              
58              
59             #------------------------------------------------------------------------
60             # ntests($n)
61             #
62             # Declare how many (more) tests are expected to come. If ok() is called
63             # before ntests() then the results are cached instead of being printed
64             # to STDOUT. When ntests() is called, the total number of tests
65             # (including any cached) is known and the "1..$ntests" line can be
66             # printed along with the cached results. After that, calls to ok()
67             # generated printed output immediately.
68             #------------------------------------------------------------------------
69              
70             sub ntests {
71 84     84 1 279 $ntests = shift;
72             # add any pre-declared extra tests, or pre-stored test @results, to
73             # the grand total of tests
74 84         312 $ntests += $EXTRA + scalar @results;
75 84         188 $ok_count = 1;
76 84 100       36854 print $ntests ? "1..$ntests\n" : "1..$ntests # skip $REASON\n";
77             # flush cached results
78 84         411 foreach my $pre_test (@results) {
79 219         614 ok(@$pre_test);
80             }
81             }
82              
83              
84             #------------------------------------------------------------------------
85             # ok($truth, $msg)
86             #
87             # Tests the value passed for truth and generates an "ok $n" or "not ok $n"
88             # line accordingly. If ntests() hasn't been called then we cached
89             # results for later, instead.
90             #------------------------------------------------------------------------
91              
92             sub ok {
93 3024     3024 1 9251 my ($ok, $msg) = @_;
94              
95             # cache results if ntests() not yet called
96 3024 100       7050 unless ($ok_count) {
97 219         591 push(@results, [ $ok, $msg ]);
98 219         714 return $ok;
99             }
100              
101 2805 100       8881 $msg = defined $msg ? " - $msg" : '';
102 2805 100       6621 if ($ok) {
103 2804         689977 print "ok ", $ok_count++, "$msg\n";
104             }
105             else {
106 1 50       107 print STDERR "FAILED $ok_count: $msg\n" if defined $msg;
107 1         166 print "not ok ", $ok_count++, "$msg\n";
108             }
109             }
110              
111              
112              
113             #------------------------------------------------------------------------
114             # assert($truth, $error)
115             #
116             # Test value for truth, die if false.
117             #------------------------------------------------------------------------
118              
119             sub assert {
120 0     0 0 0 my ($ok, $err) = @_;
121 0 0       0 return ok(1) if $ok;
122              
123             # failed
124 0         0 my ($pkg, $file, $line) = caller();
125 0   0     0 $err ||= "assert failed";
126 0         0 $err .= " at $file line $line\n";
127 0         0 ok(0);
128 0         0 die $err;
129             }
130              
131             #------------------------------------------------------------------------
132             # match( $result, $expect )
133             #------------------------------------------------------------------------
134              
135             sub match {
136 85     85 0 363 my ($result, $expect, $msg) = @_;
137 85 100       219 my $count = $ok_count ? $ok_count : scalar @results + 1;
138              
139             # force stringification of $result to avoid 'no eq method' overload errors
140 85 50       195 $result = "$result" if ref $result;
141              
142 85 50       201 if ($result eq $expect) {
143 85         167 return ok(1, $msg);
144             }
145             else {
146 0         0 print STDERR "FAILED $count:\n expect: [$expect]\n result: [$result]\n";
147 0         0 return ok(0, $msg);
148             }
149             }
150              
151              
152             #------------------------------------------------------------------------
153             # flush()
154             #
155             # Flush any tests results.
156             #------------------------------------------------------------------------
157              
158             sub flush {
159 84 50 66 84 0 61 ntests(0)
160             unless $ok_count || $NO_FLUSH;
161             }
162              
163              
164             #------------------------------------------------------------------------
165             # skip_all($reason)
166             #
167             # Skip all tests, setting $REASON to contain any message passed. Calls
168             # exit(0) which triggers flush() which generates a "1..0 # $REASON"
169             # string to keep to test harness happy.
170             #------------------------------------------------------------------------
171              
172             sub skip_all {
173 3     3 0 1581 $REASON = join('', @_);
174 3         298 exit(0);
175             }
176              
177              
178             #------------------------------------------------------------------------
179             # test_expect($input, $template, \%replace)
180             #
181             # This is the main testing sub-routine. The $input parameter should be a
182             # text string or a filehandle reference (e.g. GLOB or IO::Handle) from
183             # which the input text can be read. The input should contain a number
184             # of tests which are split up and processed individually, comparing the
185             # generated output against the expected output. Tests should be defined
186             # as follows:
187             #
188             # -- test --
189             # test input
190             # -- expect --
191             # expected output
192             #
193             # -- test --
194             # etc...
195             #
196             # The number of tests is determined and ntests() is called to generate
197             # the "0..$n" line compatible with Test::Harness. Each test input is
198             # then processed by the Template object passed as the second parameter,
199             # $template. This may also be a hash reference containing configuration
200             # which are used to instantiate a Template object, or may be left
201             # undefined in which case a default Template object will be instantiated.
202             # The third parameter, also optional, may be a reference to a hash array
203             # defining template variables. This is passed to the template process()
204             # method.
205             #------------------------------------------------------------------------
206              
207             sub test_expect {
208 74     74 0 1040999 my ($src, $tproc, $params) = @_;
209 74         191 my ($input, @tests);
210 0         0 my ($output, $expect, $match);
211 74         174 my $count = 0;
212 74         148 my $ttprocs;
213              
214             # read input text
215 74         182 eval {
216 74         361 local $/ = undef;
217 74 50       2518 $input = ref $src ? <$src> : $src;
218             };
219 74 50       411 if ($@) {
220 0         0 ntests(1); ok(0);
  0         0  
221 0         0 warn "Cannot read input text from $src\n";
222 0         0 return undef;
223             }
224              
225             # remove any comment lines
226 74         2572 $input =~ s/^#.*?\n//gm;
227              
228             # remove anything before '-- start --' and/or after '-- stop --'
229 74 50       1971 $input = $' if $input =~ /\s*--\s*start\s*--\s*/;
230 74 100       1497 $input = $` if $input =~ /\s*--\s*stop\s*--\s*/;
231              
232 74         4587 @tests = split(/^\s*--\s*test\s*--\s*\n/im, $input);
233              
234             # if the first line of the file was '--test--' (optional) then the
235             # first test will be empty and can be discarded
236 74 100       603 shift(@tests) if $tests[0] =~ /^\s*$/;
237              
238 74         611 ntests(3 + scalar(@tests) * 2);
239              
240             # first test is that Template loaded OK, which it did
241 74         407 ok(1, 'running test_expect()');
242              
243             # optional second param may contain a Template reference or a HASH ref
244             # of constructor options, or may be undefined
245 74 100       772 if (ref($tproc) eq 'HASH') {
    100          
    100          
246             # create Template object using hash of config items
247 30   50     537 $tproc = Template->new($tproc)
248             || die Template->error(), "\n";
249             }
250             elsif (ref($tproc) eq 'ARRAY') {
251             # list of [ name => $tproc, name => $tproc ], use first $tproc
252 24         155 $ttprocs = { @$tproc };
253 24         76 $tproc = $tproc->[1];
254             }
255             elsif (! ref $tproc) {
256 17   50     287 $tproc = Template->new()
257             || die Template->error(), "\n";
258             }
259             # otherwise, we assume it's a Template reference
260              
261             # test: template processor created OK
262 74         436 ok($tproc, 'template processor is engaged');
263              
264             # third test is that the input read ok, which it did
265 74         643 ok(1, 'input read and split into ' . scalar @tests . ' tests');
266              
267             # the remaining tests are defined in @tests...
268 74         306 foreach $input (@tests) {
269 1112         2372 $count++;
270 1112         2116 my $name = '';
271            
272 1112 100       10151 if ($input =~ s/^\s*-- name:? (.*?) --\s*\n//im) {
273 103         485 $name = $1;
274             }
275             else {
276 1009         2779 $name = "template text $count";
277             }
278              
279             # Configure a test as TODO
280 1112         1984 my $todo = '';
281 1112 50       7139 if ($input =~ s/^\s*-- todo:? (.*?) --\s*\n//im) {
282 0 0       0 $todo = ( $1 eq '' ) ? 'No reason given' : $1;
283             }
284            
285             # split input by a line like "-- expect --"
286 1112         9277 ($input, $expect) =
287             split(/^\s*--\s*expect\s*--\s*\n/im, $input);
288 1112 100       3620 $expect = ''
289             unless defined $expect;
290              
291 1112         2207 $output = '';
292              
293             # input text may be prefixed with "-- use name --" to indicate a
294             # Template object in the $ttproc hash which we should use
295 1112 100       3961 if ($input =~ s/^\s*--\s*use\s+(\S+)\s*--\s*\n//im) {
296 68         209 my $ttname = $1;
297 68         108 my $ttlookup;
298 68 50       308 if ($ttlookup = $ttprocs->{ $ttname }) {
299 68         170 $tproc = $ttlookup;
300             }
301             else {
302 0         0 warn "no such template object to use: $ttname\n";
303             }
304             }
305              
306             # process input text
307 1112 50       5949 $tproc->process(\$input, $params, \$output) || do {
308 0         0 warn "Template process failed: ", $tproc->error(), "\n";
309             # report failure and automatically fail the expect match
310 0         0 ok(0, "$name process FAILED: " . subtext($input));
311 0         0 ok(0, '(obviously did not match expected)');
312 0         0 next;
313             };
314              
315             # processed OK
316 1112         5715 ok(1, "$name processed OK: " . subtext($input));
317              
318             # another hack: if the '-- expect --' section starts with
319             # '-- process --' then we process the expected output
320             # before comparing it with the generated output. This is
321             # slightly twisted but it makes it possible to run tests
322             # where the expected output isn't static. See t/date.t for
323             # an example.
324              
325 1112 100       17228 if ($expect =~ s/^\s*--+\s*process\s*--+\s*\n//im) {
326 34         64 my $out;
327 34 50       175 $tproc->process(\$expect, $params, \$out) || do {
328 0         0 warn("Template process failed (expect): ",
329             $tproc->error(), "\n");
330             # report failure and automatically fail the expect match
331 0         0 ok(0, "failed to process expected output ["
332             . subtext($expect) . ']');
333 0         0 next;
334             };
335 34         87 $expect = $out;
336             };
337            
338             # strip any trailing blank lines from expected and real output
339 1112         3029 foreach ($expect, $output) {
340 2224         26738 s/[\n\r]*\Z//mg;
341             }
342            
343 1112 100       3693 $match = ($expect eq $output) ? 1 : 0;
344 1112 100 66     6673 if (! $match || $DEBUG) {
345 1 50       225 print "MATCH FAILED\n"
346             unless $match;
347            
348 1         4 my ($copyi, $copye, $copyo) = ($input, $expect, $output);
349 1 50       5 unless ($PRESERVE) {
350 1         3 foreach ($copyi, $copye, $copyo) {
351 3         15 s/\n/\\n/g;
352             }
353             }
354 1         224 printf(" input: [%s]\nexpect: [%s]\noutput: [%s]\n",
355             $copyi, $copye, $copyo);
356             }
357              
358 1112         2463 my $testprefix = $name;
359 1112 50       2780 if ( $todo ) {
360 0         0 $testprefix = "# TODO $todo - $name";
361             }
362              
363 1112 100       6599 ok($match, $match ? "$testprefix matched expected" : "$testprefix did not match expected");
364             };
365             }
366              
367             #------------------------------------------------------------------------
368             # callsign()
369             #
370             # Returns a hash array mapping lower a..z to their phonetic alphabet
371             # equivalent.
372             #------------------------------------------------------------------------
373              
374             sub callsign {
375 18     18 1 311 my %callsign;
376 18         494 @callsign{ 'a'..'z' } = qw(
377             alpha bravo charlie delta echo foxtrot golf hotel india
378             juliet kilo lima mike november oscar papa quebec romeo
379             sierra tango umbrella victor whisky x-ray yankee zulu );
380 18         142 return \%callsign;
381             }
382              
383              
384             #------------------------------------------------------------------------
385             # banner($text)
386             #
387             # Prints a banner with the specified text if $DEBUG is set.
388             #------------------------------------------------------------------------
389              
390             sub banner {
391 5 50   5 1 27 return unless $DEBUG;
392 0         0 my $text = join('', @_);
393 0 0       0 my $count = $ok_count ? $ok_count - 1 : scalar @results;
394 0         0 print "-" x 72, "\n$text ($count tests completed)\n", "-" x 72, "\n";
395             }
396              
397              
398             sub subtext {
399 1112     1112 0 3818 my $text = shift;
400 1112         23295 $text =~ s/\s*$//sg;
401 1112 100       5432 $text = substr($text, 0, 32) . '...' if length $text > 32;
402 1112         4395 $text =~ s/\n/\\n/g;
403 1112         5738 return $text;
404             }
405              
406              
407             1;
408              
409             __END__