1#!./perl
2#
3# Tests that have to do with checking whether characters have (or not have)
4# certain Unicode properties; belong (or not belong) to blocks, scripts, etc.
5#
6
7use strict;
8use warnings;
9use v5.16;
10use utf8;
11
12# To verify that messages containing the expansions work on UTF-8
13my $utf8_comment;
14
15my @warnings;
16local $SIG {__WARN__} = sub {push @warnings, "@_"};
17
18BEGIN {
19    chdir 't' if -d 't';
20    require './test.pl';
21    skip_all_if_miniperl("no dynamic loading on miniperl, no File::Spec (used by charnames)");
22}
23
24sub run_tests;
25
26sub get_str_name($) {
27    my $char = shift;
28
29    my ($str, $name);
30
31    if ($char =~ /^\\/) {
32        $str  = eval qq ["$char"];
33        $name =      qq ["$char"];
34    }
35    elsif ($char =~ /^0x([0-9A-Fa-f]+)$/) {
36        $str  =  chr hex $1;
37        $name = "chr ($char)";
38    }
39    else {
40        $str  =      $char;
41        $name = qq ["$char"];
42    }
43
44    return ($str, $name);
45}
46
47#
48# This is the data to test.
49#
50# This is a hash; keys are the property to test.
51# Values are arrays containing characters to test. The characters can
52# have the following formats:
53#   '\N{CHARACTER NAME}'  -  Use character with that name
54#   '\x{1234}'            -  Use character with that hex escape
55#   '0x1234'              -  Use chr() to get that character
56#   "a"                   -  Character to use
57#
58# If a character entry starts with ! the character does not belong to the class
59#
60# If the class is just single letter, we use both \pL and \p{L}
61#
62
63use charnames ':full';
64
65my @CLASSES = (
66    L                         => ["a", "A"],
67    Ll                        => ["b", "!B"],
68    Lu                        => ["!c", "C"],
69    IsLl                      => ["d", "!D"],
70    IsLu                      => ["!e", "E"],
71    LC                        => ["f", "!1"],
72   'L&'                       => ["g", "!2"],
73   'Lowercase Letter'         => ["h", "!H"],
74
75    Common                    => ["!i", "3"],
76    Inherited                 => ["!j", '\x{300}'],
77
78    InBasicLatin              => ['\N{LATIN CAPITAL LETTER A}'],
79    InLatin1Supplement        => ['\N{LATIN CAPITAL LETTER A WITH GRAVE}'],
80    InLatinExtendedA          => ['\N{LATIN CAPITAL LETTER A WITH MACRON}'],
81    InLatinExtendedB          => ['\N{LATIN SMALL LETTER B WITH STROKE}'],
82    InKatakana                => ['\N{KATAKANA LETTER SMALL A}'],
83    IsLatin                   => ["0x100", "0x212b"],
84    IsHebrew                  => ["0x5d0", "0xfb4f"],
85    IsGreek                   => ["0x37a", "0x386", "!0x387", "0x388",
86                                  "0x38a", "!0x38b", "0x38c"],
87    HangulSyllables           => ['\x{AC00}'],
88   'Script=Latin'             => ['\x{0100}'],
89   'Block=LatinExtendedA'     => ['\x{0100}'],
90   'Category=UppercaseLetter' => ['\x{0100}'],
91
92    #
93    # It's ok to repeat class names.
94    #
95    InLatin1Supplement        =>
96                            ['!\N{U+7f}',  '\N{U+80}',  '\N{U+ff}', '!\x{100}'],
97    InLatinExtendedA          =>
98                            ['!\N{U+7f}', '!\N{U+80}', '!\N{U+ff}',  '\x{100}'],
99
100    #
101    # Properties are case-insensitive, and may have whitespace,
102    # dashes and underscores.
103    #
104   'in-latin1_SUPPLEMENT'     => ['\N{U+80}',
105                                  '\N{LATIN SMALL LETTER Y WITH DIAERESIS}'],
106   '  ^  In Latin 1 Supplement  '
107                              => ['!\N{U+80}', '\N{COFFIN}'],
108   'latin-1   supplement'     => ['\N{U+80}', "0xDF"],
109
110);
111
112my @USER_DEFINED_PROPERTIES;
113my @USER_CASELESS_PROPERTIES;
114my @USER_ERROR_PROPERTIES;
115my @DEFERRED;
116my $overflow;
117BEGIN {
118    $utf8_comment = "#\N{U+30CD}";
119
120    use Config;
121    $overflow = $Config{uvsize} < 8 ? "80000000" : "80000000000000000";
122
123    # We defined these at compile time, so that the subroutines that they
124    # refer to aren't known, so that we can test properties not known until
125    # runtime
126
127    @USER_DEFINED_PROPERTIES = (
128        #
129        # User defined properties
130        #
131        InKana1                   => ['\x{3040}', '!\x{303F}'],
132        InKana2                   => ['\x{3040}', '!\x{303F}'],
133        InKana3                   => ['\x{3041}', '!\x{3040}'],
134        InNotKana                 => ['\x{3040}', '!\x{3041}'],
135        InConsonant               => ['d',        '!e'],
136        IsSyriac1                 => ['\x{0712}', '!\x{072F}'],
137        IsSyriac1KanaMark         => ['\x{309A}', '!\x{3090}'],
138        IsSyriac1KanaMark         => ['\x{0730}', '!\x{0712}'],
139        '# User-defined character properties may lack \n at the end',
140        InGreekSmall              => ['\N{GREEK SMALL LETTER PI}',
141                                        '\N{GREEK SMALL LETTER FINAL SIGMA}'],
142        InGreekCapital            => ['\N{GREEK CAPITAL LETTER PI}', '!\x{03A2}'],
143        Dash                      => ['-'],
144        ASCII_Hex_Digit           => ['!-', 'A'],
145        IsAsciiHexAndDash         => ['-', 'A'],
146    );
147
148    @USER_CASELESS_PROPERTIES = (
149        #
150        # User defined properties which differ depending on /i.  Second entry
151        # is false normally, true under /i
152        #
153        'IsMyUpper'                => ["M", "!m" ],
154        'pkg1::pkg2::IsMyLower'    => ["a", "!A" ],
155    );
156
157    @USER_ERROR_PROPERTIES = (
158        'IsOverflow'    => qr/Code point too large in (?#
159                             )"0\t$overflow$utf8_comment" in expansion of (?#
160                             )main::IsOverflow/,
161        'InRecursedA'   => qr/Infinite recursion in user-defined property (?#
162                             )"main::InRecursedA" in expansion of (?#
163                             )main::InRecursedC in expansion of (?#
164                             )main::InRecursedB in expansion of (?#
165                             )main::InRecursedA/,
166        'IsRangeReversed' => qr/Illegal range in "200 100$utf8_comment" in (?#
167                               )expansion of main::IsRangeReversed/,
168        'IsNonHex'        => qr/Can't find Unicode property definition (?#
169                               )"BEEF CAGED" in expansion of main::IsNonHex/,
170
171        # Could have \n, hence /s
172        'IsDeath'        => qr/Died.* in expansion of main::IsDeath/s,
173    );
174
175    # Now create a list of properties whose definitions won't be known at
176    # runtime.  The qr// below thus will have forward references to them, and
177    # when matched at runtime will not know what's in the property definition
178    my @DEFERRABLE_USER_DEFINED_PROPERTIES;
179    push @DEFERRABLE_USER_DEFINED_PROPERTIES, @USER_DEFINED_PROPERTIES;
180    push @DEFERRABLE_USER_DEFINED_PROPERTIES, @USER_CASELESS_PROPERTIES;
181    unshift @DEFERRABLE_USER_DEFINED_PROPERTIES, @USER_ERROR_PROPERTIES;
182    for (my $i = 0; $i < @DEFERRABLE_USER_DEFINED_PROPERTIES; $i+=2) {
183        my $property = $DEFERRABLE_USER_DEFINED_PROPERTIES[$i];
184        if ($property =~ / ^ \# /x) {
185            $i++;
186            redo;
187        }
188
189        # Only do this for the properties in the list that are user-defined
190        next if ($property !~ / ( ^ | :: ) I[ns] /x);
191
192        push @DEFERRED, qr/\p{$property}/,
193                        $DEFERRABLE_USER_DEFINED_PROPERTIES[$i+1];
194    }
195}
196
197# These override the official ones, so if found before defined, the official
198# ones prevail, so can't test deferred definition
199my @OVERRIDING_USER_DEFINED_PROPERTIES = (
200   InLatin1                  => ['\x{0100}', '!\x{00FF}'],
201);
202
203#
204# From the short properties we populate POSIX-like classes.
205#
206my %SHORT_PROPERTIES = (
207    'Ll'  => ['m', '\N{CYRILLIC SMALL LETTER A}'],
208    'Lu'  => ['M', '\N{GREEK CAPITAL LETTER ALPHA}'],
209    'Lo'  => ['\N{HIRAGANA LETTER SMALL A}'],
210    # is also in other alphabetic
211    'Mn'  => ['\N{HEBREW POINT RAFE}'],
212    'Nd'  => ["0", '\N{ARABIC-INDIC DIGIT ZERO}'],
213    'Pc'  => ["_"],
214    'Po'  => ["!"],
215    'Zs'  => [" "],
216    'Cc'  => ['\x{00}'],
217);
218
219#
220# Illegal properties
221#
222my @ILLEGAL_PROPERTIES =
223    qw[q qrst f foo isfoo infoo ISfoo INfoo Is::foo In::foo];
224
225my %d;
226
227while (my ($class, $chars) = each %SHORT_PROPERTIES) {
228    push @{$d {IsAlpha}} => map {$class =~ /^[LM]/   ? $_ : "!$_"} @$chars;
229    push @{$d {IsAlnum}} => map {$class =~ /^[LMN]./ ? $_ : "!$_"} @$chars;
230    push @{$d {IsASCII}} => map {length ($_) == 1 || $_ eq '\x{00}'
231                                                     ? $_ : "!$_"} @$chars;
232    push @{$d {IsCntrl}} => map {$class =~ /^C/      ? $_ : "!$_"} @$chars;
233    push @{$d {IsBlank}} => map {$class =~ /^Z[lps]/ ? $_ : "!$_"} @$chars;
234    push @{$d {IsDigit}} => map {$class =~ /^Nd$/    ? $_ : "!$_"} @$chars;
235    push @{$d {IsGraph}} => map {$class =~ /^([LMNPS]|Co)/
236                                                     ? $_ : "!$_"} @$chars;
237    push @{$d {IsPrint}} => map {$class =~ /^([LMNPS]|Co|Zs)/
238                                                     ? $_ : "!$_"} @$chars;
239    push @{$d {IsLower}} => map {$class =~ /^Ll$/    ? $_ : "!$_"} @$chars;
240    push @{$d {IsUpper}} => map {$class =~ /^L[ut]/  ? $_ : "!$_"} @$chars;
241    push @{$d {IsPunct}} => map {$class =~ /^P/      ? $_ : "!$_"} @$chars;
242    push @{$d {IsWord}}  => map {$class =~ /^[LMN]/ || $_ eq "_"
243                                                     ? $_ : "!$_"} @$chars;
244    push @{$d {IsSpace}} => map {$class =~ /^Z/ ||
245                                 length ($_) == 1 && utf8::native_to_unicode(ord ($_)) >= 0x09
246                                                  && utf8::native_to_unicode(ord ($_)) <= 0x0D
247                                                     ? $_ : "!$_"} @$chars;
248}
249
250push @CLASSES => "# Short properties"        => %SHORT_PROPERTIES,
251                 "# POSIX like properties"   => %d,
252                 "# User defined properties" => @USER_DEFINED_PROPERTIES,
253                 "# Overriding user defined properties" => @OVERRIDING_USER_DEFINED_PROPERTIES;
254
255
256#
257# Calculate the number of tests.
258#
259my $count = 0;
260for (my $i = 0; $i < @CLASSES; $i += 2) {
261    $i ++, redo if $CLASSES [$i] =~ /^\h*#\h*(.*)/;
262    $count += 2 * (length $CLASSES [$i] == 1 ? 4 : 2) * @{$CLASSES [$i + 1]};
263}
264$count += 4 * @ILLEGAL_PROPERTIES;
265$count += 4 * grep {length $_ == 1} @ILLEGAL_PROPERTIES;
266$count += 8 * @USER_CASELESS_PROPERTIES;
267$count += 1 * (@DEFERRED - @USER_ERROR_PROPERTIES) / 2;
268$count += 1 * @USER_ERROR_PROPERTIES;
269$count += 1;    # one bad apple
270$count += 1;    # No warnings generated
271
272plan(tests => $count);
273
274run_tests unless caller ();
275
276sub match {
277    my ($char, $match, $nomatch, $caseless) = @_;
278    $caseless = "" unless defined $caseless;
279    $caseless = 'i' if $caseless;
280
281    my ($str, $name) = get_str_name($char);
282
283    undef $@;
284    my $pat = "qr/$match/$caseless";
285    my $match_pat = eval $pat;
286    if (is($@, '', "$pat compiled correctly to a regexp: $@")) {
287        like($str, $match_pat, "$name correctly matched");
288    }
289
290    undef $@;
291    $pat = "qr/$nomatch/$caseless";
292    my $nomatch_pat = eval $pat;
293    if (is($@, '', "$pat compiled correctly to a regexp: $@")) {
294        unlike($str, $nomatch_pat, "$name correctly did not match");
295    }
296}
297
298sub run_tests {
299
300    for (my $i = 0; $i < @DEFERRED; $i+=2) {
301        if (ref $DEFERRED[$i+1] eq 'ARRAY') {
302            my ($str, $name) = get_str_name($DEFERRED[$i+1][0]);
303            like($str, $DEFERRED[$i],
304                "$name correctly matched $DEFERRED[$i] (defn. not known until runtime)");
305        }
306        else {  # Single entry rhs indicates a property that is an error
307            undef $@;
308
309            # Using block eval causes the pattern to not be recompiled, so it
310            # retains its deferred status until this is executed.
311            eval { 'A' =~ $DEFERRED[$i] };
312            like($@, $DEFERRED[$i+1],
313                                "$DEFERRED[$i] gave correct failure message (defn. not known until runtime)");
314        }
315    }
316
317    while (@CLASSES) {
318        my $class = shift @CLASSES;
319        if ($class =~ /^\h*#\h*(.*)/) {
320            print "# $1\n";
321            next;
322        }
323        last unless @CLASSES;
324        my $chars   = shift @CLASSES;
325        my @in      =                       grep {!/^!./} @$chars;
326        my @out     = map {s/^!(?=.)//; $_} grep { /^!./} @$chars;
327        my $in_pat  = eval qq ['\\p{$class}'];
328        my $out_pat = eval qq ['\\P{$class}'];
329
330        match $_, $in_pat,  $out_pat for @in;
331        match $_, $out_pat, $in_pat  for @out;
332
333        if (1 == length $class) {   # Repeat without braces if name length 1
334            my $in_pat  = eval qq ['\\p$class'];
335            my $out_pat = eval qq ['\\P$class'];
336
337            match $_, $in_pat,  $out_pat for @in;
338            match $_, $out_pat, $in_pat  for @out;
339        }
340    }
341
342
343    print "# Illegal properties\n";
344    foreach my $p (@ILLEGAL_PROPERTIES) {
345        my $pat;
346        if ($p =~ /::/) {
347            $pat = qr /^Illegal user-defined property name/;
348        }
349        else {
350            $pat = qr /^Can't find Unicode property definition/;
351        }
352
353        undef $@;
354        my $r = eval "'a' =~ /\\p{$p}/; 1";
355        is($r, undef, "Unknown Unicode property \\p{$p}");
356        like($@, $pat, "Unknown Unicode property \\p{$p}");
357        undef $@;
358        my $s = eval "'a' =~ /\\P{$p}/; 1";
359        is($s, undef, "Unknown Unicode property \\p{$p}");
360        like($@, $pat, "Unknown Unicode property \\p{$p}");
361        if (length $p == 1) {
362            undef $@;
363            my $r = eval "'a' =~ /\\p$p/; 1";
364            is($r, undef, "Unknown Unicode property \\p$p");
365            like($@, $pat, "Unknown Unicode property \\p$p");
366            undef $@;
367            my $s = eval "'a' =~ /\\P$p/; 1";
368            is($r, undef, "Unknown Unicode property \\P$p");
369            like($@, $pat, "Unknown Unicode property \\P$p");
370        }
371    }
372
373    print "# User-defined properties with /i differences\n";
374    while (my $class = shift @USER_CASELESS_PROPERTIES) {
375        my $chars_ref = shift @USER_CASELESS_PROPERTIES;
376        my @in      =                       grep {!/^!./} @$chars_ref;
377        my @out     = map {s/^!(?=.)//; $_} grep { /^!./} @$chars_ref;
378        my $in_pat  = eval qq ['\\p{$class}'];
379        my $out_pat = eval qq ['\\P{$class}'];
380
381        # Verify that adding /i does change the out set to match.
382        match $_, $in_pat,  $out_pat, 'i' for @out;
383
384        # Verify that adding /i doesn't change the in set.
385        match $_, $in_pat,  $out_pat, 'i' for @in;
386
387        # Verify works as regularly for not /i
388        match $_, $in_pat,  $out_pat for @in;
389        match $_, $out_pat, $in_pat  for @out;
390    }
391
392    print "# User-defined properties with errors in their definition\n";
393    while (my $error_property = shift @USER_ERROR_PROPERTIES) {
394        my $error_re = shift @USER_ERROR_PROPERTIES;
395
396        undef $@;
397        eval { 'A' =~ /\p{$error_property}/; };
398        like($@, $error_re, "$error_property gave correct failure message");
399    }
400}
401
402
403#
404# User defined properties
405#
406
407sub InKana1 {<<'--'}
4083040    309F            # A comment; next line has trailing spaces
40930A0    30FF
410--
411
412sub InKana2 {<<'--'}
413+utf8::InHiragana
414+utf8::InKatakana
415--
416
417sub InKana3 {<<'--'}
418# First line comment
419+utf8::InHiragana
420# Full line comment
421+utf8::InKatakana
422-utf8::IsCn
423--
424
425sub InNotKana {<<'--'}
426!utf8::InHiragana       # A comment; next line has trailing spaces
427-utf8::InKatakana
428+utf8::IsCn
429# Final line comment
430--
431
432sub InConsonant {
433
434    my $return = "+utf8::Lowercase\n&utf8::ASCII\n";
435    $return .= sprintf("-%X\n", ord "a");
436    $return .= sprintf("-%X\n", ord "e");
437    $return .= sprintf("-%X\n", ord "i");
438    $return .= sprintf("-%X\n", ord "o");
439    $return .= sprintf("-%X\n", ord "u");
440    return $return;
441}
442
443sub IsSyriac1 {<<'--'}
4440712    072C
4450730    074A
446--
447
448sub InRecursedA {
449    return "+main::InRecursedB\n";
450}
451
452sub InRecursedB {
453    return "+main::InRecursedC\n";
454}
455
456sub InRecursedC {
457    return "+main::InRecursedA\n";
458}
459
460sub InGreekSmall   {return "03B1\t03C9"}
461sub InGreekCapital {return "0391\t03A9\n-03A2"}
462
463sub IsAsciiHexAndDash {<<'--'}
464+utf8::ASCII_Hex_Digit
465+utf8::Dash
466--
467
468sub InLatin1 {
469    return "0100\t10FFFF";
470}
471
472sub IsMyUpper {
473    use feature 'state';
474
475    state $cased_count = 0;
476    state $caseless_count = 0;
477    my $ret= "+utf8::";
478
479    my $caseless = shift;
480    if($caseless) {
481        die "Called twice" if $caseless_count;
482        $caseless_count++;
483        $ret .= 'Alphabetic'
484    }
485    else {
486        die "Called twice" if $cased_count;
487        $cased_count++;
488        $ret .= 'Uppercase';
489    }
490
491    return $ret . "\n&utf8::ASCII";
492}
493
494sub pkg1::pkg2::IsMyLower {
495    my $caseless = shift;
496    return "+utf8::"
497        . (($caseless)
498            ? 'Alphabetic'
499            : 'Lowercase')
500        . "\n&utf8::ASCII";
501}
502
503sub IsRangeReversed {
504    return "200 100$utf8_comment";
505}
506
507sub IsNonHex {
508    return "BEEF CAGED$utf8_comment";
509}
510
511sub IsDeath {
512    die;
513}
514
515# Verify that can use user-defined properties inside another one
516sub IsSyriac1KanaMark {<<'--'}
517+main::IsSyriac1
518+main::InKana3
519&utf8::IsMark
520--
521
522# fake user-defined properties; these subs shouldn't be called, because
523# their names don't start with In or Is
524
525sub f       { die }
526sub foo     { die }
527sub isfoo   { die }
528sub infoo   { die }
529sub ISfoo   { die }
530sub INfoo   { die }
531sub Is::foo { die }
532sub In::foo { die }
533
534sub IsOverflow {
535    return "0\t$overflow$utf8_comment";
536}
537
538fresh_perl_like(<<'EOP', qr/Can't find Unicode property definition "F000\\tF010" in expansion of InOneBadApple/, {}, "Just one component bad");
539# Extra backslash converts tab to backslash-t
540sub InOneBadApple { return "0100\t0110\n10000\t10010\nF000\\tF010\n0400\t0410" }
541qr/\p{InOneBadApple}/;
542EOP
543
544if (! is(@warnings, 0, "No warnings were generated")) {
545    diag join "\n", @warnings, "\n";
546}
547
5481;
549__END__
550