This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perl5db: add tests for v command
[perl5.git] / t / uni / class.t
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