home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / t / op / regexp.t < prev    next >
Text File  |  1999-11-13  |  3KB  |  111 lines
  1. #!./perl
  2.  
  3. # XXX known to leak scalars
  4. $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3;
  5.  
  6. # The tests are in a separate file 't/op/re_tests'.
  7. # Each line in that file is a separate test.
  8. # There are five columns, separated by tabs.
  9. #
  10. # Column 1 contains the pattern, optionally enclosed in C<''>.
  11. # Modifiers can be put after the closing C<'>.
  12. #
  13. # Column 2 contains the string to be matched.
  14. #
  15. # Column 3 contains the expected result:
  16. #     y    expect a match
  17. #     n    expect no match
  18. #     c    expect an error
  19. #    B    test exposes a known bug in Perl, should be skipped
  20. #    b    test exposes a known bug in Perl, should be skipped if noamp
  21. #
  22. # Columns 4 and 5 are used only if column 3 contains C<y> or C<c>.
  23. #
  24. # Column 4 contains a string, usually C<$&>.
  25. #
  26. # Column 5 contains the expected result of double-quote
  27. # interpolating that string after the match, or start of error message.
  28. #
  29. # \n in the tests are interpolated, as are variables of the form ${\w+}.
  30. #
  31. # If you want to add a regular expression test that can't be expressed
  32. # in this format, don't add it here: put it in op/pat.t instead.
  33.  
  34. BEGIN {
  35.     chdir 't' if -d 't';
  36.     unshift @INC, '../lib' if -d '../lib';
  37. }
  38.  
  39. $iters = shift || 1;        # Poor man performance suite, 10000 is OK.
  40.  
  41. open(TESTS,'op/re_tests') || open(TESTS,'t/op/re_tests') ||
  42.     die "Can't open re_tests";
  43.  
  44. while (<TESTS>) { }
  45. $numtests = $.;
  46. seek(TESTS,0,0);
  47. $. = 0;
  48.  
  49. $bang = sprintf "\\%03o", ord "!"; # \41 would not be portable.
  50. $ffff  = chr(0xff) x 2;
  51. $nulnul = "\0" x 2;
  52.  
  53. $| = 1;
  54. print "1..$numtests\n# $iters iterations\n";
  55. TEST:
  56. while (<TESTS>) {
  57.     chomp;
  58.     s/\\n/\n/g;
  59.     ($pat, $subject, $result, $repl, $expect) = split(/\t/,$_);
  60.     $input = join(':',$pat,$subject,$result,$repl,$expect);
  61.     infty_subst(\$pat);
  62.     infty_subst(\$expect);
  63.     $pat = "'$pat'" unless $pat =~ /^[:']/;
  64.     $pat =~ s/(\$\{\w+\})/$1/eeg;
  65.     $pat =~ s/\\n/\n/g;
  66.     $subject =~ s/(\$\{\w+\})/$1/eeg;
  67.     $subject =~ s/\\n/\n/g;
  68.     $expect =~ s/(\$\{\w+\})/$1/eeg;
  69.     $expect =~ s/\\n/\n/g;
  70.     $expect = $repl = '-' if $skip_amp and $input =~ /\$[&\`\']/;
  71.     $skip = ($skip_amp ? ($result =~ s/B//i) : ($result =~ s/B//));
  72.     # Certain tests don't work with utf8 (the re_test should be in UTF8)
  73.     $skip = 1 if ($^H &= ~0x00000008) && $pat =~ /\[:\^(alnum|print|word):\]/;
  74.     $result =~ s/B//i unless $skip;
  75.     for $study ('', 'study \$subject') {
  76.      $c = $iters;
  77.      eval "$study; \$match = (\$subject =~ m$pat) while \$c--; \$got = \"$repl\";";
  78.     chomp( $err = $@ );
  79.     if ($result eq 'c') {
  80.         if ($err !~ m!^\Q$expect!) { print "not ok $. (compile) $input => `$err'\n"; next TEST }
  81.         last;  # no need to study a syntax error
  82.     }
  83.     elsif ( $skip ) {
  84.         print "ok $. # skipped\n"; next TEST;
  85.     }
  86.     elsif ($@) {
  87.         print "not ok $. $input => error `$err'\n"; next TEST;
  88.     }
  89.     elsif ($result eq 'n') {
  90.         if ($match) { print "not ok $. ($study) $input => false positive\n"; next TEST }
  91.     }
  92.     else {
  93.         if (!$match || $got ne $expect) {
  94.          print "not ok $. ($study) $input => `$got', match=$match\n";
  95.         next TEST;
  96.         }
  97.     }
  98.     }
  99.     print "ok $.\n";
  100. }
  101.  
  102. close(TESTS);
  103.  
  104. sub infty_subst                             # Special-case substitution
  105. {                                           #  of $reg_infty and friends
  106.     my $tp = shift;
  107.     $$tp =~ s/,\$reg_infty_m}/,$reg_infty_m}/o;
  108.     $$tp =~ s/,\$reg_infty_p}/,$reg_infty_p}/o;
  109.     $$tp =~ s/,\$reg_infty}/,$reg_infty}/o;
  110. }
  111.