cpan/Locale-Codes/t/testfunc.pl

   1 #!/usr/bin/perl -w
   2 # Copyright (c) 1996-2012 Sullivan Beck. All rights reserved.
   3 # This program is free software; you can redistribute it and/or modify it
   4 # under the same terms as Perl itself.
   5
   6 # SB_TEST.PL
   7 ###############################################################################
   8 # HISTORY
   9 #
  10 # 1996-??-??  Wrote initial version for Date::Manip module
  11 #
  12 # 1996-2001   Numerous changes
  13 #
  14 # 2001-03-29  Rewrote to make it easier to drop in for any module.
  15 #
  16 # 2001-06-19  Modifications to make space delimited stuff work better.
  17 #
  18 # 2001-08-23  Added support for undef args.
  19 #
  20 # 2007-08-14  Better support for undef/blank args.
  21 #
  22 # 2008-01-02  Better handling of $runtests.
  23 #
  24 # 2008-01-24  Better handling of undef/blank args when arguements are
  25 #             entered as lists instead of strings.
  26 #
  27 # 2008-01-25  Created a global $testnum variable to store the test number
  28 #             in.
  29 #
  30 # 2008-11-05  Slightly better handling of blank/undef in returned values.
  31 #
  32 # 2009-09-01  Added "-l" value to $runtests.
  33 #
  34 # 2009-09-30  Much better support for references.
  35 #
  36 # 2010-02-05  Fixed bug in passing tests as lists
  37 #
  38 # 2010-04-05  Renamed to testfunc.pl to avoid being called in a core module
  39
  40 ###############################################################################
  41
  42 use Storable qw(dclone);
  43
  44 # Usage: test_Func($funcref,$tests,$runtests,@extra)=@_;
  45 #
  46 # This takes a series of tests, runs them, compares the output of the tests
  47 # with expected output, and reports any differences.  Each test consists of
  48 # several parts:
  49 #    a function passed in as a reference ($funcref)
  50 #    a series of arguments to be passed to the function
  51 #    the expected output from the function call
  52 #
  53 # Tests may be passed in in two methods: as a string, or as a reference.
  54 #
  55 # Using the string case, $tests is a newline delimited string.  Each test
  56 # takes one or more lines of the string.  Tests are separated from each
  57 # other by a blank line.
  58 #
  59 # Arguments and return value(s) may be written as a single line:
  60 #    ARG1 ARG2 ... ARGn ~ VAL1 VAL2 ... VALm
  61 # or as multiple lines:
  62 #    ARG1
  63 #    ARG2
  64 #    ...
  65 #    ARGn
  66 #    ~
  67 #    VAL1
  68 #    VAL2
  69 #    ...
  70 #    VALm
  71 #
  72 # If any of the arguments OR values have spaces in them, only the multiline
  73 # form may be used.
  74 #
  75 # If there is exactly one return value, the separating tilde is
  76 # optional:
  77 #    ARG1 ARG2 ... ARGn VAL1
  78 # or:
  79 #    ARG1
  80 #    ARG2
  81 #    ...
  82 #    ARGn
  83 #    VAL
  84 #
  85 # It is valid to have a function with no arguments or with no return
  86 # value (or both).  The "~" must be used:
  87 #
  88 #    ARG1 ARG2 ... ARGn ~
  89 #
  90 #    ~ VAL1 VAL2 ... VALm
  91 #
  92 #    ~
  93 #
  94 # Leading and trailing space is ignored in the multi-line format.
  95 #
  96 # If desired, any of the ARGs or VALs may be the word "_undef_" which
  97 # will be strictly interpreted as the perl undef value. The word "_blank_"
  98 # may also be used to designate a defined but empty string.
  99 #
 100 # They may also be (in the multiline format) of the form:
 101 #
 102 #   \ STRING           : a string reference
 103 #
 104 #   [] LIST            : a list reference (where LIST is a
 105 #                        comma separated list)
 106 #
 107 #   [SEP] LIST         : a list reference (where SEP is a
 108 #                        single character separator)
 109 #
 110 #   {} HASH            : a hash reference (where HASH is
 111 #                        a comma separated list)
 112 #
 113 #   {SEP} HASH         : a hash reference (where SEP is a
 114 #                        single character separator)
 115 #
 116 # Alternately, the tests can be passed in as a list reference:
 117 #    $tests = [
 118 #               [
 119 #                 [ @ARGS1 ],
 120 #                 [ @VALS1 ]
 121 #               ],
 122 #               [
 123 #                 [ @ARGS2 ],
 124 #                 [ @VALS2 ]
 125 #               ], ...
 126 #             ]
 127 #
 128 # @extra are extra arguments which are added to the function call.
 129 #
 130 # There are several ways to run the tests, depending on the value of
 131 # $runtests.
 132 #
 133 # If $runtests is 0, the tests are run in a non-interactive way suitable
 134 # for running as part of a "make test".
 135 #
 136 # If $runtests is a positive number, it runs runs all tests starting at
 137 # that value in a way suitable for running interactively.
 138 #
 139 # If $runtests is a negative number, it runs all tests starting at that
 140 # value, but providing feedback at each test.
 141 #
 142 # If $runtests is a string "=N" (where N is a number), it runs only
 143 # that test.
 144 #
 145 # If $runtests is the string "-l", it lists the tests and the expected
 146 # output without running any.
 147
 148 sub test_Func {
 149    my($funcref,$tests,$runtests,@extra)=@_;
 150    my(@tests);
 151
 152    $runtests     = 0  if (! $runtests);
 153    my($starttest,$feedback,$endtest,$runtest);
 154    if      ($runtests eq "0"  or  $runtests eq "-0") {
 155       $starttest = 1;
 156       $feedback  = 1;
 157       $endtest   = 0;
 158       $runtest   = 1;
 159    } elsif ($runtests =~ /^\d+$/){
 160       $starttest = $runtests;
 161       $feedback  = 0;
 162       $endtest   = 0;
 163       $runtest   = 1;
 164    } elsif ($runtests =~ /^-(\d+)$/) {
 165       $starttest = $1;
 166       $feedback  = 1;
 167       $endtest   = 0;
 168       $runtest   = 1;
 169    } elsif ($runtests =~ /^=(\d+)$/) {
 170       $starttest = $1;
 171       $feedback  = 1;
 172       $endtest   = $1;
 173       $runtest   = 1;
 174    } elsif ($runtests eq "-l") {
 175       $starttest = 1;
 176       $feedback  = 1;
 177       $endtest   = 0;
 178       $runtest   = 0;
 179    } else {
 180       die "ERROR: unknown argument(s): $runtests";
 181    }
 182
 183    my($tests_as_list) = 0;
 184    if (ref($tests) eq "ARRAY") {
 185       @tests   = @$tests;
 186       $tests_as_list = 1;
 187
 188    } else {
 189       # Separate tests.
 190
 191       my($comment)="#";
 192       my(@lines)=split(/\n/,$tests);
 193       my(@test);
 194       while (@lines) {
 195          my $line = shift(@lines);
 196          $line =~ s/^\s*//;
 197          $line =~ s/\s*$//;
 198          next  if ($line =~ /^$comment/);
 199
 200          if ($line ne "") {
 201             push(@test,$line);
 202             next;
 203          }
 204
 205          if (@test) {
 206             push(@tests,[ @test ]);
 207             @test=();
 208          }
 209       }
 210       if (@test) {
 211          push(@tests,[ @test ]);
 212       }
 213
 214       # Get arg/val lists for each test.
 215
 216       foreach my $test (@tests) {
 217          my(@tmp)=@$test;
 218          my(@arg,@val);
 219
 220          # single line test
 221          @tmp = split(/\s+/,$tmp[0])  if ($#tmp == 0);
 222
 223          my($sep)=-1;
 224          my($i);
 225          for ($i=0; $i<=$#tmp; $i++) {
 226             if ($tmp[$i] eq "~") {
 227                $sep=$i;
 228                last;
 229             }
 230          }
 231
 232          if ($sep<0) {
 233             @val=pop(@tmp);
 234             @arg=@tmp;
 235          } else {
 236             @arg=@tmp[0..($sep-1)];
 237             @val=@tmp[($sep+1)..$#tmp];
 238          }
 239          $test = [ [@arg],[@val] ];
 240       }
 241    }
 242
 243    my($ntest)=$#tests + 1;
 244    print "1..$ntest\n"  if ($feedback  &&  $runtest);
 245
 246    my(@t);
 247    if ($endtest) {
 248       @t = ($starttest..$endtest);
 249    } else {
 250       @t = ($starttest..$ntest);
 251    }
 252
 253    foreach my $t (@t) {
 254       $::testnum  = $t;
 255
 256       my (@arg);
 257       if ($tests_as_list) {
 258          @arg     = @{ $tests[$t-1][0] };
 259       } else {
 260          my $arg  = dclone($tests[$t-1][0]);
 261          @arg     = @$arg;
 262          print_to_vals(\@arg);
 263       }
 264
 265       my $argprt  = dclone(\@arg);
 266       my @argprt  = @$argprt;
 267       vals_to_print(\@argprt);
 268
 269       my $exp     = dclone($tests[$t-1][1]);
 270       my @exp     = @$exp;
 271       print_to_vals(\@exp);
 272       vals_to_print(\@exp);
 273
 274       # Run the test
 275
 276       my ($ans,@ans);
 277       if ($runtest) {
 278          @ans = &$funcref(@arg,@extra);
 279       }
 280       vals_to_print(\@ans);
 281
 282       # Compare the results
 283
 284       foreach my $arg (@arg) {
 285          $arg = "_undef_"  if (! defined $arg);
 286          $arg = "_blank_"  if ($arg eq "");
 287       }
 288       $arg = join("\n           ",@argprt,@extra);
 289       $ans = join("\n           ",@ans);
 290       $exp = join("\n           ",@exp);
 291
 292       if (! $runtest) {
 293          print "########################\n";
 294          print "Test     = $t\n";
 295          print "Args     = $arg\n";
 296          print "Expected = $exp\n";
 297       } elsif ($ans ne $exp) {
 298          print "not ok $t\n";
 299          warn "########################\n";
 300          warn "Args     = $arg\n";
 301          warn "Expected = $exp\n";
 302          warn "Got      = $ans\n";
 303          warn "########################\n";
 304       } else {
 305          print "ok $t\n"  if ($feedback);
 306       }
 307    }
 308 }
 309
 310 # The following is similar but it takes input from an input file and
 311 # sends output to an output file.
 312 #
 313 # $files is a reference to a list of tests.  If one of the tests is named
 314 # "foobar", the input is from "foobar.in", output is to "foobar.out", and
 315 # the expected output is in "foobar.exp".
 316 #
 317 # The function stored in $funcref is called as:
 318 #    &$funcref($in,$out,@extra)
 319 # where $in is the name of the input file, $out is the name of the output
 320 # file, and @extra are any additional arguments that are required.
 321 #
 322 # The function should return 0 on success, or an error message.
 323
 324 sub test_File {
 325    my($funcref,$files,$runtests,@extra)=@_;
 326    my(@files)=@$files;
 327
 328    $runtests=0  if (! $runtests);
 329
 330    my($ntest)=$#files + 1;
 331    print "1..$ntest\n"  if (! $runtests);
 332
 333    my(@t);
 334    if ($runtests > 0) {
 335       @t = ($runtests..$ntest);
 336    } elsif ($runtests < 0) {
 337       @t = (-$runtests);
 338    } else {
 339       @t = (1..$ntest);
 340    }
 341
 342    foreach my $t (@t) {
 343       $::testnum = $t;
 344       my $test = $files[$t-1];
 345       my $expf = "$test.exp";
 346       my $outf = "$test.out";
 347
 348       if (! -f $test  ||  ! -f $expf) {
 349          print "not ok $t\n";
 350          warn  "Test: $test: missing input/outpuf information\n";
 351          next;
 352       }
 353
 354       my $err  = &$funcref($test,$outf,@extra);
 355       if ($err) {
 356          print "not ok $t\n";
 357          warn  "Test: $test: $err\n";
 358          next;
 359       }
 360
 361       local *FH;
 362       open(FH,$expf)  ||  do {
 363          print "not ok $t\n";
 364          warn  "Test: $test: $!\n";
 365          next;
 366       };
 367       my @exp = <FH>;
 368       close(FH);
 369       my $exp = join("",@exp);
 370       open(FH,$outf)  ||  do {
 371          print "not ok $t\n";
 372          warn  "Test: $test: $!\n";
 373          next;
 374       };
 375       my @out = <FH>;
 376       close(FH);
 377       my $out = join("",@out);
 378
 379       if ($out ne $exp) {
 380          print "not ok $t\n";
 381          warn  "Test: $test: output differs from expected value\n";
 382          next;
 383       }
 384
 385       print "ok $t\n"  if (! $runtests);
 386    }
 387 }
 388
 389 # Converts a printable version of arguments to actual arguments
 390 sub print_to_vals {
 391    my($listref) = @_;
 392
 393    foreach my $arg (@$listref) {
 394       next  if (! defined($arg));
 395       if ($arg eq "_undef_") {
 396          $arg = undef;
 397
 398       } elsif ($arg eq "_blank_") {
 399          $arg = "";
 400
 401       } elsif ($arg =~ /^\\\s*(.*)/) {
 402          $str = $1;
 403          $arg = \$str;
 404
 405       } elsif ($arg =~ /^\[(.?)\]\s*(.*)/) {
 406          my($sep,$str) = ($1,$2);
 407          $sep = ","  if (! $sep);
 408          my @list = split(/\Q$sep\E/,$str);
 409          foreach my $e (@list) {
 410             $e = ""     if ($e eq "_blank_");
 411             $e = undef  if ($e eq "_undef_");
 412          }
 413          $arg = \@list;
 414
 415       } elsif ($arg =~ /^\{(.?)\}\s*(.*)/) {
 416          my($sep,$str) = ($1,$2);
 417          $sep = ","  if (! $sep);
 418          my %hash = split(/\Q$sep\E/,$str);
 419          foreach my $key (keys %hash) {
 420             my $val = $hash{$key};
 421             $hash{$key} = undef  if ($val eq "_undef_");
 422             $hash{$key} = ""     if ($val eq "_blank_");
 423          }
 424          $arg = \%hash;
 425       }
 426    }
 427 }
 428
 429 # Converts arguments to a printable version.
 430 sub vals_to_print {
 431    my($listref) = @_;
 432
 433    foreach my $arg (@$listref) {
 434       if (! defined $arg) {
 435          $arg = "_undef_";
 436
 437       } elsif (! ref($arg)) {
 438          $arg = "_blank_"  if ($arg eq "");
 439
 440       } else {
 441          my $ref = ref($arg);
 442          if      ($ref eq "SCALAR") {
 443             $arg = "\\ $$arg";
 444
 445          } elsif ($ref eq "ARRAY") {
 446             my @list = @$arg;
 447             foreach my $e (@list) {
 448                $e = "_undef_", next   if (! defined($e));
 449                $e = "_blank_"         if ($e eq "");
 450             }
 451             $arg = join(" ","[",join(", ",@list),"]");
 452
 453          } elsif ($ref eq "HASH") {
 454             %hash = %$arg;
 455             foreach my $key (keys %hash) {
 456                my $val = $hash{$key};
 457                $hash{$key} = "_undef_", next  if (! defined($val));
 458                $hash{$key} = "_blank_"        if ($val eq "_blank_");
 459             }
 460             $arg = join(" ","{",
 461                         join(", ",map { "$_ => $hash{$_}" }
 462                              (sort keys %hash)), "}");
 463             $arg =~ s/  +/ /g;
 464          }
 465       }
 466    }
 467 }
 468
 469 1;
 470 # Local Variables:
 471 # mode: cperl
 472 # indent-tabs-mode: nil
 473 # cperl-indent-level: 3
 474 # cperl-continued-statement-offset: 2
 475 # cperl-continued-brace-offset: 0
 476 # cperl-brace-offset: 0
 477 # cperl-brace-imaginary-offset: 0
 478 # cperl-label-offset: -2
 479 # End:
 480