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 => 11;
   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 # The other tests that are based on looking at the generated files are now
  92 # in t/re/uniprops.t