| 1 | BEGIN { |
| 2 | chdir 't' if -d 't'; |
| 3 | require './test.pl'; |
| 4 | set_up_inc(qw(../lib .)); |
| 5 | skip_all_without_unicode_tables(); |
| 6 | } |
| 7 | |
| 8 | plan tests => 12; |
| 9 | |
| 10 | my $str = join "", map { chr utf8::unicode_to_native($_) } 0x20 .. 0x6F; |
| 11 | |
| 12 | is(($str =~ /(\p{IsMyUniClass}+)/)[0], '0123456789:;<=>?@ABCDEFGHIJKLMNO', |
| 13 | 'user-defined class compiled before defined'); |
| 14 | |
| 15 | sub IsMyUniClass { |
| 16 | my $return = ""; |
| 17 | for my $i (0x30 .. 0x4F) { |
| 18 | $return .= sprintf("%04X\n", utf8::unicode_to_native($i)); |
| 19 | } |
| 20 | return $return; |
| 21 | END |
| 22 | } |
| 23 | |
| 24 | sub Other::IsClass { |
| 25 | my $return = ""; |
| 26 | for my $i (0x40 .. 0x5F) { |
| 27 | $return .= sprintf("%04X\n", utf8::unicode_to_native($i)); |
| 28 | } |
| 29 | return $return; |
| 30 | } |
| 31 | |
| 32 | sub A::B::Intersection { |
| 33 | <<END; |
| 34 | +main::IsMyUniClass |
| 35 | &Other::IsClass |
| 36 | END |
| 37 | } |
| 38 | |
| 39 | sub test_regexp ($$) { |
| 40 | # test that given string consists of N-1 chars matching $qr1, and 1 |
| 41 | # char matching $qr2 |
| 42 | my ($str, $blk) = @_; |
| 43 | |
| 44 | # constructing these objects here makes the last test loop go much faster |
| 45 | my $qr1 = qr/(\p{$blk}+)/; |
| 46 | if ($str =~ $qr1) { |
| 47 | is($1, substr($str, 0, -1)); # all except last char |
| 48 | } |
| 49 | else { |
| 50 | fail('first N-1 chars did not match'); |
| 51 | } |
| 52 | |
| 53 | my $qr2 = qr/(\P{$blk}+)/; |
| 54 | if ($str =~ $qr2) { |
| 55 | is($1, substr($str, -1)); # only last char |
| 56 | } |
| 57 | else { |
| 58 | fail('last char did not match'); |
| 59 | } |
| 60 | } |
| 61 | |
| 62 | use strict; |
| 63 | |
| 64 | # make sure it finds built-in class |
| 65 | is(($str =~ /(\p{Letter}+)/)[0], 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'); |
| 66 | is(($str =~ /(\p{l}+)/)[0], 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'); |
| 67 | |
| 68 | # make sure it finds user-defined class |
| 69 | is(($str =~ /(\p{IsMyUniClass}+)/)[0], '0123456789:;<=>?@ABCDEFGHIJKLMNO'); |
| 70 | |
| 71 | # make sure it finds class in other package |
| 72 | is(($str =~ /(\p{Other::IsClass}+)/)[0], '@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_'); |
| 73 | |
| 74 | # make sure it finds class in other OTHER package |
| 75 | is(($str =~ /(\p{A::B::Intersection}+)/)[0], '@ABCDEFGHIJKLMNO'); |
| 76 | |
| 77 | # lib/unicore/lib/Bc/AL.pl. U+070E is unassigned, currently, but still has |
| 78 | # bidi class AL. The first one in the sequence that doesn't is 0711, which is |
| 79 | # BC=NSM. |
| 80 | $str = "\x{070D}\x{070E}\x{070F}\x{0710}\x{0711}\x{0712}"; |
| 81 | is(($str =~ /(\P{BidiClass: ArabicLetter}+)/)[0], "\x{0711}"); |
| 82 | is(($str =~ /(\P{BidiClass: AL}+)/)[0], "\x{0711}"); |
| 83 | is(($str =~ /(\P{BC :ArabicLetter}+)/)[0], "\x{0711}"); |
| 84 | is(($str =~ /(\P{bc=AL}+)/)[0], "\x{0711}"); |
| 85 | |
| 86 | # make sure InGreek works |
| 87 | $str = "[\x{038B}\x{038C}\x{038D}]"; |
| 88 | |
| 89 | is(($str =~ /(\p{InGreek}+)/)[0], "\x{038B}\x{038C}\x{038D}"); |
| 90 | |
| 91 | { # [perl #133860], compilation before data for it is available |
| 92 | package Foo; |
| 93 | |
| 94 | sub make { |
| 95 | my @lines; |
| 96 | while( my($c) = splice(@_,0,1) ) { |
| 97 | push @lines, sprintf("%04X", $c); |
| 98 | } |
| 99 | return join "\n", @lines; |
| 100 | } |
| 101 | |
| 102 | my @characters = ( ord("a") ); |
| 103 | sub IsProperty { make(@characters); }; |
| 104 | |
| 105 | main::like('a', qr/\p{IsProperty}/, "foo"); |
| 106 | } |
| 107 | |
| 108 | # The other tests that are based on looking at the generated files are now |
| 109 | # in t/re/uniprops.t |