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