t/uni/class.t

   1 BEGIN {
   2     chdir 't' if -d 't';
   3     @INC = qw(../lib .);
   4     require "test.pl";
   5 }
   6
   7 plan tests => 4334;
   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');
  33 is(($str =~ /(\p{l}+)/)[0], 'ABCDEFGHIJKLMNOPQRSTUVWXYZ');
  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');
  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.)
 115 SKIP:
 116 {
 117   skip "Can't reliably derive class names from file names", 544 if $^O eq 'VMS';
 118
 119   # On case tolerant filesystems, Cf.pl will cause a -e test for cf.pl to
 120   # return true. Try to work around this by reading the filenames explicitly
 121   # to get a case sensitive test.  N.B.  This will fail if filename case is
 122   # not preserved because you might go looking for a class name of CF or cf
 123   # when you really want Cf.  Storing case sensitive data in filenames is
 124   # simply not portable.
 125
 126   my %files;
 127
 128   my $dirname = File::Spec->catdir($updir => lib => unicore => lib => gc_sc);
 129   opendir D, $dirname or die $!;
 130   @files{readdir D} = ();
 131   closedir D;
 132
 133   for (keys %utf8::PA_reverse) {
 134     my $leafname = "$utf8::PA_reverse{$_}.pl";
 135     next unless exists $files{$leafname};
 136
 137     my $filename = File::Spec->catfile($dirname, $leafname);
 138
 139     my ($h1, $h2) = map hex, split /\t/, (do $filename);
 140     my $str = join "", map chr, $h1 .. (($h2 || $h1) + 1);
 141
 142     for my $x ('gc', 'General Category') {
 143       print "# $filename $x $_, $utf8::PA_reverse{$_}\n";
 144       for my $y ($_, $utf8::PA_reverse{$_}) {
 145         is($str =~ /(\p{$x: $y}+)/ && $1, substr($str, 0, -1));
 146         is($str =~ /(\P{$x= $y}+)/ && $1, substr($str, -1));
 147         is($str =~ /(\p{$y}+)/ && $1, substr($str, 0, -1));
 148         is($str =~ /(\P{$y}+)/ && $1, substr($str, -1));
 149       }
 150     }
 151   }
 152 }
 153
 154 # test the blocks (InFoobar)
 155 for (grep $utf8::Canonical{$_} =~ /^In/, keys %utf8::Canonical) {
 156   my $filename = File::Spec->catfile(
 157     $updir => lib => unicore => lib => gc_sc => "$utf8::Canonical{$_}.pl"
 158   );
 159
 160   next unless -e $filename;
 161   my ($h1, $h2) = map hex, split /\t/, (do $filename);
 162   my $str = join "", map chr, $h1 .. (($h2 || $h1) + 1);
 163
 164   my $blk = $_;
 165
 166   is($str =~ /(\p{$blk}+)/ && $1, substr($str, 0, -1));
 167   is($str =~ /(\P{$blk}+)/ && $1, substr($str, -1));
 168
 169   $blk =~ s/^In/Block:/;
 170
 171   is($str =~ /(\p{$blk}+)/ && $1, substr($str, 0, -1));
 172   is($str =~ /(\P{$blk}+)/ && $1, substr($str, -1));
 173 }