t/re/regex_sets.t

   1 #!./perl
   2
   3 # This tests (?[...]).  XXX These are just basic tests, as full ones would be
   4 # best done with an infrastructure change to allow getting out the inversion
   5 # list of the constructed set and then comparing it character by character
   6 # with the expected result.
   7
   8 use strict;
   9 use warnings;
  10
  11 $| = 1;
  12
  13 BEGIN {
  14     chdir 't' if -d 't';
  15     @INC = ('../lib','.');
  16     require './test.pl';
  17 }
  18
  19 use utf8;
  20 no warnings 'experimental::regex_sets';
  21
  22 like("a", qr/(?[ [a]      # This is a comment
  23                     ])/, 'Can ignore a comment');
  24 like("a", qr/(?[ [a]      # [[:notaclass:]]
  25                     ])/, 'A comment isn\'t parsed');
  26 unlike("\x85", qr/(?[ \t\85 ])/, 'NEL is white space');
  27 unlike("\x85", qr/(?[ [\t\85] ])/, '... including within nested []');
  28 like("\x85", qr/(?[ \t + \\85 ])/, 'can escape NEL to match');
  29 like("\x85", qr/(?[ [\\85] ])/, '... including within nested []');
  30 like("\t", qr/(?[ \t + \\85 ])/, 'can do basic union');
  31 like("\cK", qr/(?[ \s ])/, '\s matches \cK');
  32 unlike("\cK", qr/(?[ \s - \cK ])/, 'can do basic subtraction');
  33 like(" ", qr/(?[ \s - \cK ])/, 'can do basic subtraction');
  34 like(":", qr/(?[ [:] ])/, '[:] is not a posix class');
  35 unlike("\t", qr/(?[ ! \t ])/, 'can do basic complement');
  36 like("\t", qr/(?[ ! [ ^ \t ] ])/, 'can do basic complement');
  37 unlike("\r", qr/(?[ \t ])/, '\r doesn\'t match \t ');
  38 like("\r", qr/(?[ ! \t ])/, 'can do basic complement');
  39 like("0", qr/(?[ [:word:] & [:digit:] ])/, 'can do basic intersection');
  40 unlike("A", qr/(?[ [:word:] & [:digit:] ])/, 'can do basic intersection');
  41 like("0", qr/(?[[:word:]&[:digit:]])/, 'spaces around internal [] aren\'t required');
  42
  43 like("a", qr/(?[ [a] | [b] ])/, '| means union');
  44 like("b", qr/(?[ [a] | [b] ])/, '| means union');
  45 unlike("c", qr/(?[ [a] | [b] ])/, '| means union');
  46
  47 like("a", qr/(?[ [ab] ^ [bc] ])/, 'basic symmetric difference works');
  48 unlike("b", qr/(?[ [ab] ^ [bc] ])/, 'basic symmetric difference works');
  49 like("c", qr/(?[ [ab] ^ [bc] ])/, 'basic symmetric difference works');
  50
  51 like("2", qr/(?[ ( ( \pN & ( [a] + [2] ) ) ) ])/, 'Nesting parens and grouping');
  52 unlike("a", qr/(?[ ( ( \pN & ( [a] + [2] ) ) ) ])/, 'Nesting parens and grouping');
  53
  54 unlike("\x{17f}", qr/(?[ [k] + \p{Blk=ASCII} ])/i, '/i doesn\'t affect \p{}');
  55 like("\N{KELVIN SIGN}", qr/(?[ [k] + \p{Blk=ASCII} ])/i, '/i does affect literals');
  56
  57 my $thai_or_lao = qr/(?[ \p{Thai} + \p{Lao} ])/;
  58 my $thai_or_lao_digit = qr/(?[ \p{Digit} & $thai_or_lao ])/;
  59 like("\N{THAI DIGIT ZERO}", $thai_or_lao_digit, 'embedded qr/(?[ ])/ works');
  60 unlike(chr(ord("\N{THAI DIGIT ZERO}") - 1), $thai_or_lao_digit, 'embedded qr/(?[ ])/ works');
  61 like("\N{THAI DIGIT NINE}", $thai_or_lao_digit, 'embedded qr/(?[ ])/ works');
  62 unlike(chr(ord("\N{THAI DIGIT NINE}") + 1), $thai_or_lao_digit, 'embedded qr/(?[ ])/ works');
  63 like("\N{LAO DIGIT ZERO}", $thai_or_lao_digit, 'embedded qr/(?[ ])/ works');
  64 unlike(chr(ord("\N{LAO DIGIT ZERO}") - 1), $thai_or_lao_digit, 'embedded qr/(?[ ])/ works');
  65 like("\N{LAO DIGIT NINE}", $thai_or_lao_digit, 'embedded qr/(?[ ])/ works');
  66 unlike(chr(ord("\N{LAO DIGIT NINE}") + 1), $thai_or_lao_digit, 'embedded qr/(?[ ])/ works');
  67
  68 my $ascii_word = qr/(?[ \w ])/a;
  69 my $ascii_digits_plus_all_of_arabic = qr/(?[ \p{Digit} & $ascii_word + \p{Arabic} ])/;
  70 like("9", $ascii_digits_plus_all_of_arabic, "/a, then interpolating and intersection works for ASCII in the set");
  71 unlike("A", $ascii_digits_plus_all_of_arabic, "/a, then interpolating and intersection works for ASCII not in the set");
  72 unlike("\N{BENGALI DIGIT ZERO}", $ascii_digits_plus_all_of_arabic, "/a, then interpolating and intersection works for non-ASCII not in either set");
  73 unlike("\N{BENGALI LETTER A}", $ascii_digits_plus_all_of_arabic, "/a, then interpolating and intersection works for non-ASCII in one set");
  74 like("\N{ARABIC LETTER HAMZA}", $ascii_digits_plus_all_of_arabic, "interpolation and intersection is left-associative");
  75 like("\N{EXTENDED ARABIC-INDIC DIGIT ZERO}", $ascii_digits_plus_all_of_arabic, "interpolation and intersection is left-associative");
  76
  77 my $kelvin = qr/(?[ \N{KELVIN SIGN} ])/;
  78 my $fold = qr/(?[ $kelvin ])/i;
  79 like("\N{KELVIN SIGN}", $kelvin, '"\N{KELVIN SIGN}" matches compiled qr/(?[ \N{KELVIN SIGN} ])/');
  80 unlike("K", $fold, "/i on outer (?[ ]) doesn't leak to interpolated one");
  81 unlike("k", $fold, "/i on outer (?[ ]) doesn't leak to interpolated one");
  82
  83 my $kelvin_fold = qr/(?[ \N{KELVIN SIGN} ])/i;
  84 my $still_fold = qr/(?[ $kelvin_fold ])/;
  85 like("K", $still_fold, "/i on interpolated (?[ ]) is retained in outer without /i");
  86 like("k", $still_fold, "/i on interpolated (?[ ]) is retained in outer without /i");
  87
  88 eval 'my $x = qr/(?[ [a] ])/; qr/(?[ $x ])/';
  89 is($@, "", 'qr/(?[ [a] ])/ can be interpolated');
  90
  91 done_testing();
  92
  93 1;