t/re/pat_special_cc.t

   1 #!./perl
   2 #
   3 # This test file is used to bulk check that /\s/ and /[\s]/
   4 # test the same and that /\s/ and /\S/ are opposites, and that
   5 # /[\s]/ and /[\S]/ are also opposites, for \s/\S and \d/\D and
   6 # \w/\W.
   7
   8 BEGIN {
   9     chdir 't' if -d 't';
  10     require './test.pl';
  11     set_up_inc( '../lib', '.' );
  12 }
  13
  14 use strict;
  15 use warnings;
  16 use 5.010;
  17
  18 plan tests => 9;  # Update this when adding/deleting tests.
  19
  20 sub run_tests;
  21
  22 $| = 1;
  23
  24 run_tests() unless caller;
  25
  26 #
  27 # Tests start here.
  28 #
  29 sub run_tests {
  30     my $upper_bound= 10_000;
  31     for my $special (qw(\s \w \d)) {
  32         my $upper= uc($special);
  33         my @cc_plain_failed;
  34         my @cc_complement_failed;
  35         my @plain_complement_failed;
  36         for my $ord (0 .. $upper_bound) {
  37             my $ch= chr $ord;
  38             my $ord = sprintf "U+%04X", $ord;  # For display in Unicode terms
  39             my $plain= $ch=~/$special/ ? 1 : 0;
  40             my $plain_u= $ch=~/$upper/ ? 1 : 0;
  41             push @plain_complement_failed, "$ord-$plain-$plain_u" if $plain == $plain_u;
  42
  43             my $cc= $ch=~/[$special]/ ? 1 : 0;
  44             my $cc_u= $ch=~/[$upper]/ ? 1 : 0;
  45             push @cc_complement_failed, "$ord-$cc-$cc_u" if $cc == $cc_u;
  46
  47             push @cc_plain_failed, "$ord-$plain-$cc" if $plain != $cc;
  48         }
  49         is(join(" | ",@cc_plain_failed),"", "Check that /$special/ and /[$special]/ match same things (ord-plain-cc)");
  50         is(join(" | ",@plain_complement_failed),"", "Check that /$special/ and /$upper/ are complements (ord-plain-plain_u)");
  51         is(join(" | ",@cc_complement_failed),"", "Check that /[$special]/ and /[$upper]/ are complements (ord-cc-cc_u)");
  52     }
  53 } # End of sub run_tests
  54
  55 1;