local-lib5/lib/perl5/i486-linux-gnu-thread-multi/Template/Test.pm

   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   <abw@wardley.org>
  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 use strict;
  25 use warnings;
  26 use Template qw( :template );
  27 use Exporter;
  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     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     $ntests = shift;
  72     # add any pre-declared extra tests, or pre-stored test @results, to
  73     # the grand total of tests
  74     $ntests += $EXTRA + scalar @results;
  75     $ok_count = 1;
  76     print $ntests ? "1..$ntests\n" : "1..$ntests # skip $REASON\n";
  77     # flush cached results
  78     foreach my $pre_test (@results) {
  79         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     my ($ok, $msg) = @_;
  94
  95     # cache results if ntests() not yet called
  96     unless ($ok_count) {
  97         push(@results, [ $ok, $msg ]);
  98         return $ok;
  99     }
 100
 101     $msg = defined $msg ? " - $msg" : '';
 102     if ($ok) {
 103         print "ok ", $ok_count++, "$msg\n";
 104     }
 105     else {
 106         print STDERR "FAILED $ok_count: $msg\n" if defined $msg;
 107         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     my ($ok, $err) = @_;
 121     return ok(1) if $ok;
 122
 123     # failed
 124     my ($pkg, $file, $line) = caller();
 125     $err ||= "assert failed";
 126     $err .= " at $file line $line\n";
 127     ok(0);
 128     die $err;
 129 }
 130
 131 #------------------------------------------------------------------------
 132 # match( $result, $expect )
 133 #------------------------------------------------------------------------
 134
 135 sub match {
 136     my ($result, $expect, $msg) = @_;
 137     my $count = $ok_count ? $ok_count : scalar @results + 1;
 138
 139     # force stringification of $result to avoid 'no eq method' overload errors
 140     $result = "$result" if ref $result;
 141
 142     if ($result eq $expect) {
 143         return ok(1, $msg);
 144     }
 145     else {
 146         print STDERR "FAILED $count:\n  expect: [$expect]\n  result: [$result]\n";
 147         return ok(0, $msg);
 148     }
 149 }
 150
 151
 152 #------------------------------------------------------------------------
 153 # flush()
 154 #
 155 # Flush any tests results.
 156 #------------------------------------------------------------------------
 157
 158 sub flush {
 159     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     $REASON = join('', @_);
 174     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     my ($src, $tproc, $params) = @_;
 209     my ($input, @tests);
 210     my ($output, $expect, $match);
 211     my $count = 0;
 212     my $ttprocs;
 213
 214     # read input text
 215     eval {
 216         local $/ = undef;
 217         $input = ref $src ? <$src> : $src;
 218     };
 219     if ($@) {
 220         ntests(1); ok(0);
 221         warn "Cannot read input text from $src\n";
 222         return undef;
 223     }
 224
 225     # remove any comment lines
 226     $input =~ s/^#.*?\n//gm;
 227
 228     # remove anything before '-- start --' and/or after '-- stop --'
 229     $input = $' if $input =~ /\s*--\s*start\s*--\s*/;
 230     $input = $` if $input =~ /\s*--\s*stop\s*--\s*/;
 231
 232     @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     shift(@tests) if $tests[0] =~ /^\s*$/;
 237
 238     ntests(3 + scalar(@tests) * 2);
 239
 240     # first test is that Template loaded OK, which it did
 241     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     if (ref($tproc) eq 'HASH') {
 246         # create Template object using hash of config items
 247         $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         $ttprocs = { @$tproc };
 253         $tproc   = $tproc->[1];
 254     }
 255     elsif (! ref $tproc) {
 256         $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     ok($tproc, 'template processor is engaged');
 263
 264     # third test is that the input read ok, which it did
 265     ok(1, 'input read and split into ' . scalar @tests . ' tests');
 266
 267     # the remaining tests are defined in @tests...
 268     foreach $input (@tests) {
 269         $count++;
 270         my $name = '';
 271
 272         if ($input =~ s/^\s*-- name:? (.*?) --\s*\n//im) {
 273             $name = $1;
 274         }
 275         else {
 276             $name = "template text $count";
 277         }
 278
 279         # split input by a line like "-- expect --"
 280         ($input, $expect) =
 281             split(/^\s*--\s*expect\s*--\s*\n/im, $input);
 282         $expect = ''
 283             unless defined $expect;
 284
 285         $output = '';
 286
 287         # input text may be prefixed with "-- use name --" to indicate a
 288         # Template object in the $ttproc hash which we should use
 289         if ($input =~ s/^\s*--\s*use\s+(\S+)\s*--\s*\n//im) {
 290             my $ttname = $1;
 291             my $ttlookup;
 292             if ($ttlookup = $ttprocs->{ $ttname }) {
 293                 $tproc = $ttlookup;
 294             }
 295             else {
 296                 warn "no such template object to use: $ttname\n";
 297             }
 298         }
 299
 300         # process input text
 301         $tproc->process(\$input, $params, \$output) || do {
 302             warn "Template process failed: ", $tproc->error(), "\n";
 303             # report failure and automatically fail the expect match
 304             ok(0, "$name process FAILED: " . subtext($input));
 305             ok(0, '(obviously did not match expected)');
 306             next;
 307         };
 308
 309         # processed OK
 310         ok(1, "$name processed OK: " . subtext($input));
 311
 312         # another hack: if the '-- expect --' section starts with
 313         # '-- process --' then we process the expected output
 314         # before comparing it with the generated output.  This is
 315         # slightly twisted but it makes it possible to run tests
 316         # where the expected output isn't static.  See t/date.t for
 317         # an example.
 318
 319         if ($expect =~ s/^\s*--+\s*process\s*--+\s*\n//im) {
 320             my $out;
 321             $tproc->process(\$expect, $params, \$out) || do {
 322                 warn("Template process failed (expect): ",
 323                      $tproc->error(), "\n");
 324                 # report failure and automatically fail the expect match
 325                 ok(0, "failed to process expected output ["
 326                    . subtext($expect) . ']');
 327                 next;
 328             };
 329             $expect = $out;
 330         };
 331
 332         # strip any trailing blank lines from expected and real output
 333         foreach ($expect, $output) {
 334             s/[\n\r]*\Z//mg;
 335         }
 336
 337         $match = ($expect eq $output) ? 1 : 0;
 338         if (! $match || $DEBUG) {
 339             print "MATCH FAILED\n"
 340                 unless $match;
 341
 342             my ($copyi, $copye, $copyo) = ($input, $expect, $output);
 343             unless ($PRESERVE) {
 344                 foreach ($copyi, $copye, $copyo) {
 345                     s/\n/\\n/g;
 346                 }
 347             }
 348             printf(" input: [%s]\nexpect: [%s]\noutput: [%s]\n",
 349                    $copyi, $copye, $copyo);
 350         }
 351
 352         ok($match, $match ? "$name matched expected" : "$name did not match expected");
 353     };
 354 }
 355
 356 #------------------------------------------------------------------------
 357 # callsign()
 358 #
 359 # Returns a hash array mapping lower a..z to their phonetic alphabet
 360 # equivalent.
 361 #------------------------------------------------------------------------
 362
 363 sub callsign {
 364     my %callsign;
 365     @callsign{ 'a'..'z' } = qw(
 366         alpha bravo charlie delta echo foxtrot golf hotel india
 367         juliet kilo lima mike november oscar papa quebec romeo
 368         sierra tango umbrella victor whisky x-ray yankee zulu );
 369     return \%callsign;
 370 }
 371
 372
 373 #------------------------------------------------------------------------
 374 # banner($text)
 375 #
 376 # Prints a banner with the specified text if $DEBUG is set.
 377 #------------------------------------------------------------------------
 378
 379 sub banner {
 380     return unless $DEBUG;
 381     my $text = join('', @_);
 382     my $count = $ok_count ? $ok_count - 1 : scalar @results;
 383     print "-" x 72, "\n$text ($count tests completed)\n", "-" x 72, "\n";
 384 }
 385
 386
 387 sub subtext {
 388     my $text = shift;
 389     $text =~ s/\s*$//sg;
 390     $text = substr($text, 0, 32) . '...' if length $text > 32;
 391     $text =~ s/\n/\\n/g;
 392     return $text;
 393 }
 394
 395
 396 1;
 397
 398 __END__
 399
 400 =head1 NAME
 401
 402 Template::Test - Module for automating TT2 test scripts
 403
 404 =head1 SYNOPSIS
 405
 406     use Template::Test;
 407
 408     $Template::Test::DEBUG = 0;   # set this true to see each test running
 409     $Template::Test::EXTRA = 2;   # 2 extra tests follow test_expect()...
 410
 411     # ok() can be called any number of times before test_expect
 412     ok( $true_or_false )
 413
 414     # test_expect() splits $input into individual tests, processes each
 415     # and compares generated output against expected output
 416     test_expect($input, $template, \%replace );
 417
 418     # $input is text or filehandle (e.g. DATA section after __END__)
 419     test_expect( $text );
 420     test_expect( \*DATA );
 421
 422     # $template is a Template object or configuration hash
 423     my $template_cfg = { ... };
 424     test_expect( $input, $template_cfg );
 425     my $template_obj = Template->new($template_cfg);
 426     test_expect( $input, $template_obj );
 427
 428     # $replace is a hash reference of template variables
 429     my $replace = {
 430         a => 'alpha',
 431         b => 'bravo'
 432     };
 433     test_expect( $input, $template, $replace );
 434
 435     # ok() called after test_expect should be declared in $EXTRA (2)
 436     ok( $true_or_false )
 437     ok( $true_or_false )
 438
 439 =head1 DESCRIPTION
 440
 441 The C<Template::Test> module defines the L<test_expect()> and other related
 442 subroutines which can be used to automate test scripts for the
 443 Template Toolkit.  See the numerous tests in the F<t> sub-directory of
 444 the distribution for examples of use.
 445
 446 =head1 PACKAGE SUBROUTINES
 447
 448 =head2 text_expect()
 449
 450 The C<test_expect()> subroutine splits an input document into a number
 451 of separate tests, processes each one using the Template Toolkit and
 452 then compares the generated output against an expected output, also
 453 specified in the input document.  It generates the familiar
 454 C<ok>/C<not ok> output compatible with C<Test::Harness>.
 455
 456 The test input should be specified as a text string or a reference to
 457 a filehandle (e.g. C<GLOB> or C<IO::Handle>) from which it can be read.  In
 458 particular, this allows the test input to be placed after the C<__END__>
 459 marker and read via the C<DATA> filehandle.
 460
 461     use Template::Test;
 462
 463     test_expect(\*DATA);
 464
 465     __END__
 466     # this is the first test (this is a comment)
 467     -- test --
 468     blah blah blah [% foo %]
 469     -- expect --
 470     blah blah blah value_of_foo
 471
 472     # here's the second test (no surprise, so is this)
 473     -- test --
 474     more blah blah [% bar %]
 475     -- expect --
 476     more blah blah value_of_bar
 477
 478 Blank lines between test sections are generally ignored.  Any line starting
 479 with C<#> is treated as a comment and is ignored.
 480
 481 The second and third parameters to C<test_expect()> are optional.  The second
 482 may be either a reference to a Template object which should be used to
 483 process the template fragments, or a reference to a hash array containing
 484 configuration values which should be used to instantiate a new Template
 485 object.
 486
 487     # pass reference to config hash
 488     my $config = {
 489         INCLUDE_PATH => '/here/there:/every/where',
 490         POST_CHOMP   => 1,
 491     };
 492     test_expect(\*DATA, $config);
 493
 494     # or create Template object explicitly
 495     my $template = Template->new($config);
 496     test_expect(\*DATA, $template);
 497
 498 The third parameter may be used to reference a hash array of template
 499 variable which should be defined when processing the tests.  This is
 500 passed to the L<Template> L<process()|Template#process()> method.
 501
 502     my $replace = {
 503         a => 'alpha',
 504         b => 'bravo',
 505     };
 506
 507     test_expect(\*DATA, $config, $replace);
 508
 509 The second parameter may be left undefined to specify a default L<Template>
 510 configuration.
 511
 512     test_expect(\*DATA, undef, $replace);
 513
 514 For testing the output of different L<Template> configurations, a
 515 reference to a list of named L<Template> objects also may be passed as
 516 the second parameter.
 517
 518     my $tt1 = Template->new({ ... });
 519     my $tt2 = Template->new({ ... });
 520     my @tts = [ one => $tt1, two => $tt1 ];
 521
 522 The first object in the list is used by default.  Other objects may be
 523 switched in with a 'C<-- use $name -->' marker.  This should immediately
 524 follow a 'C<-- test -->' line.  That object will then be used for the rest
 525 of the test, or until a different object is selected.
 526
 527     -- test --
 528     -- use one --
 529     [% blah %]
 530     -- expect --
 531     blah, blah
 532
 533     -- test --
 534     still using one...
 535     -- expect --
 536     ...
 537
 538     -- test --
 539     -- use two --
 540     [% blah %]
 541     -- expect --
 542     blah, blah, more blah
 543
 544 The C<test_expect()> sub counts the number of tests, and then calls L<ntests()>
 545 to generate the familiar "C<1..$ntests\n>" test harness line.  Each
 546 test defined generates two test numbers.  The first indicates
 547 that the input was processed without error, and the second that the
 548 output matches that expected.
 549
 550 Additional test may be run before C<test_expect()> by calling L<ok()>. These
 551 test results are cached until L<ntests()> is called and the final number of
 552 tests can be calculated. Then, the "C<1..$ntests>" line is output, along with
 553 "C<ok $n>" / "C<not ok $n>" lines for each of the cached test result.
 554 Subsequent calls to L<ok()> then generate an output line immediately.
 555
 556     my $something = SomeObject->new();
 557     ok( $something );
 558
 559     my $other = AnotherThing->new();
 560     ok( $other );
 561
 562     test_expect(\*DATA);
 563
 564 If any tests are to follow after C<test_expect()> is called then these
 565 should be pre-declared by setting the C<$EXTRA> package variable.  This
 566 value (default: C<0>) is added to the grand total calculated by L<ntests()>.
 567 The results of the additional tests are also registered by calling L<ok()>.
 568
 569     $Template::Test::EXTRA = 2;
 570
 571     # can call ok() any number of times before test_expect()
 572     ok( $did_that_work );
 573     ok( $make_sure );
 574     ok( $dead_certain );
 575
 576     # <some> number of tests...
 577     test_expect(\*DATA, $config, $replace);
 578
 579     # here's those $EXTRA tests
 580     ok( defined $some_result && ref $some_result eq 'ARRAY' );
 581     ok( $some_result->[0] eq 'some expected value' );
 582
 583 If you don't want to call C<test_expect()> at all then you can call
 584 C<ntests($n)> to declare the number of tests and generate the test
 585 header line.  After that, simply call L<ok()> for each test passing
 586 a true or false values to indicate that the test passed or failed.
 587
 588     ntests(2);
 589     ok(1);
 590     ok(0);
 591
 592 If you're really lazy, you can just call L<ok()> and not bother declaring
 593 the number of tests at all.  All tests results will be cached until the
 594 end of the script and then printed in one go before the program exits.
 595
 596     ok( $x );
 597     ok( $y );
 598
 599 You can identify only a specific part of the input file for testing
 600 using the 'C<-- start -->' and 'C<-- stop -->' markers.  Anything before the
 601 first 'C<-- start -->' is ignored, along with anything after the next
 602 'C<-- stop -->' marker.
 603
 604     -- test --
 605     this is test 1 (not performed)
 606     -- expect --
 607     this is test 1 (not performed)
 608
 609     -- start --
 610
 611     -- test --
 612     this is test 2
 613     -- expect --
 614     this is test 2
 615
 616     -- stop --
 617
 618     ...
 619
 620 =head2 ntests()
 621
 622 Subroutine used to specify how many tests you're expecting to run.
 623
 624 =head2 ok($test)
 625
 626 Generates an "C<ok $n>" or "C<not ok $n>" message if C<$test> is true or false.
 627
 628 =head2 not_ok($test)
 629
 630 The logical inverse of L<ok()>. Prints an "C<ok $n>" message is C<$test> is
 631 I<false> and vice-versa.
 632
 633 =head2 callsign()
 634
 635 For historical reasons and general utility, the module also defines a
 636 C<callsign()> subroutine which returns a hash mapping the letters C<a>
 637 to C<z> to their phonetic alphabet equivalent (e.g. radio callsigns).
 638 This is used by many of the test scripts as a known source of variable values.
 639
 640     test_expect(\*DATA, $config, callsign());
 641
 642 =head2 banner()
 643
 644 This subroutine prints a simple banner including any text passed as parameters.
 645 The C<$DEBUG> variable must be set for it to generate any output.
 646
 647     banner('Testing something-or-other');
 648
 649 example output:
 650
 651     #------------------------------------------------------------
 652     # Testing something-or-other (27 tests completed)
 653     #------------------------------------------------------------
 654
 655 =head1 PACKAGE VARIABLES
 656
 657 =head2 $DEBUG
 658
 659 The $DEBUG package variable can be set to enable debugging mode.
 660
 661 =head2 $PRESERVE
 662
 663 The $PRESERVE package variable can be set to stop the test_expect()
 664 from converting newlines in the output and expected output into
 665 the literal strings '\n'.
 666
 667 =head1 HISTORY
 668
 669 This module started its butt-ugly life as the C<t/texpect.pl> script.  It
 670 was cleaned up to became the C<Template::Test> module some time around
 671 version 0.29.  It underwent further cosmetic surgery for version 2.00
 672 but still retains some remarkable rear-end resemblances.
 673
 674 Since then the C<Test::More> and related modules have appeared on CPAN
 675 making this module mostly, but not entirely, redundant.
 676
 677 =head1 BUGS / KNOWN "FEATURES"
 678
 679 Imports all methods by default.  This is generally a Bad Thing, but
 680 this module is only used in test scripts (i.e. at build time) so a) we
 681 don't really care and b) it saves typing.
 682
 683 The line splitter may be a bit dumb, especially if it sees lines like
 684 C<-- this --> that aren't supposed to be special markers.  So don't do that.
 685
 686 =head1 AUTHOR
 687
 688 Andy Wardley E<lt>abw@wardley.orgE<gt> L<http://wardley.org/>
 689
 690 =head1 COPYRIGHT
 691
 692 Copyright (C) 1996-2007 Andy Wardley.  All Rights Reserved.
 693
 694 This module is free software; you can redistribute it and/or
 695 modify it under the same terms as Perl itself.
 696
 697 =head1 SEE ALSO
 698
 699 L<Template>
 700
 701 =cut
 702
 703 # Local Variables:
 704 # mode: perl
 705 # perl-indent-level: 4
 706 # indent-tabs-mode: nil
 707 # End:
 708 #
 709 # vim: expandtab shiftwidth=4: