Commit | Line | Data |
0f1b7392 |
1 | BEGIN { |
2 | chdir 't' if -d 't'; |
3 | @INC = qw(../lib .); |
4 | require "test.pl"; |
5 | } |
6 | |
12ac2576 |
7 | plan tests => 4334; |
0f1b7392 |
8 | |
9 | sub MyUniClass { |
10 | <<END; |
11 | 0030 004F |
12 | END |
13 | } |
14 | |
15 | sub Other::Class { |
16 | <<END; |
17 | 0040 005F |
18 | END |
19 | } |
20 | |
21 | sub A::B::Intersection { |
22 | <<END; |
23 | +main::MyUniClass |
24 | &Other::Class |
25 | END |
26 | } |
27 | |
28 | |
29 | my $str = join "", map chr($_), 0x20 .. 0x6F; |
30 | |
31 | # make sure it finds built-in class |
32 | is(($str =~ /(\p{Letter}+)/)[0], 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'); |
12ac2576 |
33 | is(($str =~ /(\p{l}+)/)[0], 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'); |
0f1b7392 |
34 | |
35 | # make sure it finds user-defined class |
36 | is(($str =~ /(\p{MyUniClass}+)/)[0], '0123456789:;<=>?@ABCDEFGHIJKLMNO'); |
37 | |
38 | # make sure it finds class in other package |
39 | is(($str =~ /(\p{Other::Class}+)/)[0], '@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_'); |
40 | |
41 | # make sure it finds class in other OTHER package |
42 | is(($str =~ /(\p{A::B::Intersection}+)/)[0], '@ABCDEFGHIJKLMNO'); |
12ac2576 |
43 | |
44 | # all of these should look in lib/unicore/bc/AL.pl |
45 | $str = "\x{070D}\x{070E}\x{070F}\x{0710}\x{0711}"; |
46 | is(($str =~ /(\P{BidiClass: ArabicLetter}+)/)[0], "\x{070E}\x{070F}"); |
47 | is(($str =~ /(\P{BidiClass: AL}+)/)[0], "\x{070E}\x{070F}"); |
48 | is(($str =~ /(\P{BC :ArabicLetter}+)/)[0], "\x{070E}\x{070F}"); |
49 | is(($str =~ /(\P{bc=AL}+)/)[0], "\x{070E}\x{070F}"); |
50 | |
51 | # make sure InGreek works |
52 | $str = "[\x{038B}\x{038C}\x{038D}]"; |
53 | |
54 | is(($str =~ /(\p{InGreek}+)/)[0], "\x{038B}\x{038C}\x{038D}"); |
55 | is(($str =~ /(\p{Script:InGreek}+)/)[0], "\x{038B}\x{038C}\x{038D}"); |
56 | is(($str =~ /(\p{Script=InGreek}+)/)[0], "\x{038B}\x{038C}\x{038D}"); |
57 | is(($str =~ /(\p{sc:InGreek}+)/)[0], "\x{038B}\x{038C}\x{038D}"); |
58 | is(($str =~ /(\p{sc=InGreek}+)/)[0], "\x{038B}\x{038C}\x{038D}"); |
59 | |
60 | |
61 | use File::Spec; |
62 | my $updir = File::Spec->updir; |
63 | |
64 | |
65 | # the %utf8::... hashes are already in existence |
66 | # because utf8_pva.pl was run by utf8_heavy.pl |
67 | |
68 | # non-General Category and non-Script |
69 | while (my ($abbrev, $files) = each %utf8::PVA_abbr_map) { |
70 | my $prop_name = $utf8::PropertyAlias{$abbrev}; |
71 | next unless $prop_name; |
72 | next if $abbrev eq "gc_sc"; |
73 | |
74 | for (sort keys %$files) { |
75 | my $filename = File::Spec->catfile( |
76 | $updir => lib => unicore => lib => $abbrev => "$files->{$_}.pl" |
77 | ); |
78 | |
79 | next unless -e $filename; |
80 | my ($h1, $h2) = map hex, split /\t/, (do $filename); |
81 | my $str = join "", map chr, $h1 .. (($h2 || $h1) + 1); |
82 | |
83 | for my $p ($prop_name, $abbrev) { |
84 | for my $c ($files->{$_}, $_) { |
85 | is($str =~ /(\p{$p: $c}+)/ && $1, substr($str, 0, -1)); |
86 | is($str =~ /(\P{$p= $c}+)/ && $1, substr($str, -1)); |
87 | } |
88 | } |
89 | } |
90 | } |
91 | |
92 | # General Category and Script |
93 | for my $p ('gc', 'sc') { |
94 | while (my ($abbr) = each %{ $utf8::PropValueAlias{$p} }) { |
95 | my $filename = File::Spec->catfile( |
96 | $updir => lib => unicore => lib => gc_sc => "$utf8::PVA_abbr_map{gc_sc}{$abbr}.pl" |
97 | ); |
98 | |
99 | next unless -e $filename; |
100 | my ($h1, $h2) = map hex, split /\t/, (do $filename); |
101 | my $str = join "", map chr, $h1 .. (($h2 || $h1) + 1); |
102 | |
103 | for my $x ($p, { gc => 'General Category', sc => 'Script' }->{$p}) { |
104 | for my $y ($abbr, $utf8::PropValueAlias{$p}{$abbr}, $utf8::PVA_abbr_map{gc_sc}{$abbr}) { |
105 | is($str =~ /(\p{$x: $y}+)/ && $1, substr($str, 0, -1)); |
106 | is($str =~ /(\P{$x= $y}+)/ && $1, substr($str, -1)); |
107 | is($str =~ /(\p{$y}+)/ && $1, substr($str, 0, -1)); |
108 | is($str =~ /(\P{$y}+)/ && $1, substr($str, -1)); |
109 | } |
110 | } |
111 | } |
112 | } |
113 | |
114 | # test extra properties (ASCII_Hex_Digit, Bidi_Control, etc.) |
32d0b1dc |
115 | { |
116 | # Aargh. Nasty case insensitive filesystems mean that Cf.pl will cause a -e |
117 | # test for cf.pl to return true. So need to read the filenames explicitly |
118 | # to get a case sensitive test |
119 | my %files; |
12ac2576 |
120 | |
32d0b1dc |
121 | my $dirname = File::Spec->catdir($updir => lib => unicore => lib => gc_sc); |
122 | opendir D, $dirname or die $!; |
123 | @files{readdir D} = (); |
124 | closedir D; |
125 | |
126 | for (keys %utf8::PA_reverse) { |
127 | my $leafname = "$utf8::PA_reverse{$_}.pl"; |
128 | next unless exists $files{$leafname}; |
12ac2576 |
129 | |
32d0b1dc |
130 | my $filename = File::Spec->catfile($dirname, $leafname); |
131 | |
132 | my ($h1, $h2) = map hex, split /\t/, (do $filename); |
133 | my $str = join "", map chr, $h1 .. (($h2 || $h1) + 1); |
134 | |
135 | for my $x ('gc', 'General Category') { |
136 | print "# $filename $x $_, $utf8::PA_reverse{$_}\n"; |
137 | for my $y ($_, $utf8::PA_reverse{$_}) { |
138 | is($str =~ /(\p{$x: $y}+)/ && $1, substr($str, 0, -1)); |
139 | is($str =~ /(\P{$x= $y}+)/ && $1, substr($str, -1)); |
140 | is($str =~ /(\p{$y}+)/ && $1, substr($str, 0, -1)); |
141 | is($str =~ /(\P{$y}+)/ && $1, substr($str, -1)); |
142 | } |
12ac2576 |
143 | } |
144 | } |
145 | } |
146 | |
147 | # test the blocks (InFoobar) |
148 | for (grep $utf8::Canonical{$_} =~ /^In/, keys %utf8::Canonical) { |
149 | my $filename = File::Spec->catfile( |
150 | $updir => lib => unicore => lib => gc_sc => "$utf8::Canonical{$_}.pl" |
151 | ); |
152 | |
153 | next unless -e $filename; |
154 | my ($h1, $h2) = map hex, split /\t/, (do $filename); |
155 | my $str = join "", map chr, $h1 .. (($h2 || $h1) + 1); |
156 | |
157 | my $blk = $_; |
158 | |
159 | is($str =~ /(\p{$blk}+)/ && $1, substr($str, 0, -1)); |
160 | is($str =~ /(\P{$blk}+)/ && $1, substr($str, -1)); |
161 | |
162 | $blk =~ s/^In/Block:/; |
163 | |
164 | is($str =~ /(\p{$blk}+)/ && $1, substr($str, 0, -1)); |
165 | is($str =~ /(\P{$blk}+)/ && $1, substr($str, -1)); |
166 | } |