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 83     83   208491 use strict;
  83         175  
  83         3448  
25 83     83   459 use warnings;
  83         1656  
  83         3085  
26 83     83   38530 use Template qw( :template );
  83         221  
  83         7008  
27 83     83   2138 use Exporter;
  83         168  
  83         267156  
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 83     83   981 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 83     83 1 254 $ntests = shift;
72             # add any pre-declared extra tests, or pre-stored test @results, to
73             # the grand total of tests
74 83         258 $ntests += $EXTRA + scalar @results;
75 83         207 $ok_count = 1;
76 83 100       41177 print $ntests ? "1..$ntests\n" : "1..$ntests # skip $REASON\n";
77             # flush cached results
78 83         687 foreach my $pre_test (@results) {
79 219         741 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 3040     3040 1 8854 my ($ok, $msg) = @_;
94              
95             # cache results if ntests() not yet called
96 3040 100       7660 unless ($ok_count) {
97 219         582 push(@results, [ $ok, $msg ]);
98 219         708 return $ok;
99             }
100              
101 2821 100       8886 $msg = defined $msg ? " - $msg" : '';
102 2821 100       6114 if ($ok) {
103 2820         656289 print "ok ", $ok_count++, "$msg\n";
104             }
105             else {
106 1 50       97 print STDERR "FAILED $ok_count: $msg\n" if defined $msg;
107 1         209 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 367 my ($result, $expect, $msg) = @_;
137 85 100       223 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       196 $result = "$result" if ref $result;
141              
142 85 50       206 if ($result eq $expect) {
143 85         170 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 83 50 66 83 0 58 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 2     2 0 1582 $REASON = join('', @_);
174 2         201 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 1135399 my ($src, $tproc, $params) = @_;
209 74         187 my ($input, @tests);
210 0         0 my ($output, $expect, $match);
211 74         175 my $count = 0;
212 74         154 my $ttprocs;
213              
214             # read input text
215 74         176 eval {
216 74         800 local $/ = undef;
217 74 50       2610 $input = ref $src ? <$src> : $src;
218             };
219 74 50       423 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         2546 $input =~ s/^#.*?\n//gm;
227              
228             # remove anything before '-- start --' and/or after '-- stop --'
229 74 50       1966 $input = $' if $input =~ /\s*--\s*start\s*--\s*/;
230 74 100       1516 $input = $` if $input =~ /\s*--\s*stop\s*--\s*/;
231              
232 74         4889 @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       733 shift(@tests) if $tests[0] =~ /^\s*$/;
237              
238 74         524 ntests(3 + scalar(@tests) * 2);
239              
240             # first test is that Template loaded OK, which it did
241 74         507 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       743 if (ref($tproc) eq 'HASH') {
    100          
    100          
246             # create Template object using hash of config items
247 30   50     739 $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         172 $ttprocs = { @$tproc };
253 24         86 $tproc = $tproc->[1];
254             }
255             elsif (! ref $tproc) {
256 17   50     387 $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         400 ok($tproc, 'template processor is engaged');
263              
264             # third test is that the input read ok, which it did
265 74         586 ok(1, 'input read and split into ' . scalar @tests . ' tests');
266              
267             # the remaining tests are defined in @tests...
268 74         310 foreach $input (@tests) {
269 1120         2640 $count++;
270 1120         2692 my $name = '';
271            
272 1120 100       10984 if ($input =~ s/^\s*-- name:? (.*?) --\s*\n//im) {
273 103         297 $name = $1;
274             }
275             else {
276 1017         2532 $name = "template text $count";
277             }
278              
279             # Configure a test as TODO
280 1120         1937 my $todo = '';
281 1120 50       7243 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 1120         9646 ($input, $expect) =
287             split(/^\s*--\s*expect\s*--\s*\n/im, $input);
288 1120 100       3665 $expect = ''
289             unless defined $expect;
290              
291 1120         1950 $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 1120 100       5007 if ($input =~ s/^\s*--\s*use\s+(\S+)\s*--\s*\n//im) {
296 68         283 my $ttname = $1;
297 68         114 my $ttlookup;
298 68 50       351 if ($ttlookup = $ttprocs->{ $ttname }) {
299 68         165 $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 1120 50       7074 $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 1120         6072 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 1120 100       6750 if ($expect =~ s/^\s*--+\s*process\s*--+\s*\n//im) {
326 34         65 my $out;
327 34 50       194 $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         96 $expect = $out;
336             };
337            
338             # strip any trailing blank lines from expected and real output
339 1120         2779 foreach ($expect, $output) {
340 2240         36365 s/[\n\r]*\Z//mg;
341             }
342            
343 1120 100       3854 $match = ($expect eq $output) ? 1 : 0;
344 1120 100 66     6162 if (! $match || $DEBUG) {
345 1 50       208 print "MATCH FAILED\n"
346             unless $match;
347            
348 1         5 my ($copyi, $copye, $copyo) = ($input, $expect, $output);
349 1 50       6 unless ($PRESERVE) {
350 1         5 foreach ($copyi, $copye, $copyo) {
351 3         19 s/\n/\\n/g;
352             }
353             }
354 1         281 printf(" input: [%s]\nexpect: [%s]\noutput: [%s]\n",
355             $copyi, $copye, $copyo);
356             }
357              
358 1120         2253 my $testprefix = $name;
359 1120 50       3007 if ( $todo ) {
360 0         0 $testprefix = "# TODO $todo - $name";
361             }
362              
363 1120 100       5174 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 334 my %callsign;
376 18         637 @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         148 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 31 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 1120     1120 0 2565 my $text = shift;
400 1120         22239 $text =~ s/\s*$//sg;
401 1120 100       5295 $text = substr($text, 0, 32) . '...' if length $text > 32;
402 1120         3592 $text =~ s/\n/\\n/g;
403 1120         5686 return $text;
404             }
405              
406              
407             1;
408              
409             __END__