lib/UnicodeCD.pm

   1 package UnicodeCD;
   2
   3 use strict;
   4 use warnings;
   5
   6 our $VERSION = '0.1';
   7
   8 require Exporter;
   9
  10 our @ISA = qw(Exporter);
  11 our @EXPORT_OK = qw(charinfo
  12                     charblock charscript
  13                     charblocks charscripts
  14                     charinrange
  15                     compexcl
  16                     casefold casespec);
  17
  18 use Carp;
  19
  20 =head1 NAME
  21
  22 UnicodeCD - Unicode character database
  23
  24 =head1 SYNOPSIS
  25
  26     use UnicodeCD 'charinfo';
  27     my $charinfo   = charinfo($codepoint);
  28
  29     use UnicodeCD 'charblock';
  30     my $charblock  = charblock($codepoint);
  31
  32     use UnicodeCD 'charscript';
  33     my $charscript = charblock($codepoint);
  34
  35     use UnicodeCD 'charblocks';
  36     my $charblocks = charblocks();
  37
  38     use UnicodeCD 'charscripts';
  39     my %charscripts = charscripts();
  40
  41     use UnicodeCD qw(charscript charinrange);
  42     my $range = charscript($script);
  43     print "looks like $script\n" if charinrange($range, $codepoint);
  44
  45     use UnicodeCD 'compexcl';
  46     my $compexcl = compexcl($codepoint);
  47
  48     my $unicode_version = UnicodeCD::UnicodeVersion();
  49
  50 =head1 DESCRIPTION
  51
  52 The UnicodeCD module offers a simple interface to the Unicode Character
  53 Database.
  54
  55 =cut
  56
  57 my $UNICODEFH;
  58 my $BLOCKSFH;
  59 my $SCRIPTSFH;
  60 my $VERSIONFH;
  61 my $COMPEXCLFH;
  62 my $CASEFOLDFH;
  63 my $CASESPECFH;
  64
  65 sub openunicode {
  66     my ($rfh, @path) = @_;
  67     my $f;
  68     unless (defined $$rfh) {
  69         for my $d (@INC) {
  70             use File::Spec;
  71             $f = File::Spec->catfile($d, "unicode", @path);
  72             last if open($$rfh, $f);
  73             undef $f;
  74         }
  75         croak __PACKAGE__, ": failed to find ",
  76               File::Spec->catfile(@path), " in @INC"
  77             unless defined $f;
  78     }
  79     return $f;
  80 }
  81
  82 =head2 charinfo
  83
  84     use UnicodeCD 'charinfo';
  85
  86     my $charinfo = charinfo(0x41);
  87
  88 charinfo() returns a reference to a hash that has the following fields
  89 as defined by the Unicode standard:
  90
  91     key
  92
  93     code             code point with at least four hexdigits
  94     name             name of the character IN UPPER CASE
  95     category         general category of the character
  96     combining        classes used in the Canonical Ordering Algorithm
  97     bidi             bidirectional category
  98     decomposition    character decomposition mapping
  99     decimal          if decimal digit this is the integer numeric value
 100     digit            if digit this is the numeric value
 101     numeric          if numeric is the integer or rational numeric value
 102     mirrored         if mirrored in bidirectional text
 103     unicode10        Unicode 1.0 name if existed and different
 104     comment          ISO 10646 comment field
 105     upper            uppercase equivalent mapping
 106     lower            lowercase equivalent mapping
 107     title            titlecase equivalent mapping
 108
 109     block            block the character belongs to (used in \p{In...})
 110     script           script the character belongs to
 111
 112 If no match is found, a reference to an empty hash is returned.
 113
 114 The C<block> property is the same as as returned by charinfo().  It is
 115 not defined in the Unicode Character Database proper (Chapter 4 of the
 116 Unicode 3.0 Standard) but instead in an auxiliary database (Chapter 14
 117 of TUS3).  Similarly for the C<script> property.
 118
 119 Note that you cannot do (de)composition and casing based solely on the
 120 above C<decomposition> and C<lower>, C<upper>, C<title>, properties,
 121 you will need also the compexcl(), casefold(), and casespec() functions.
 122
 123 =cut
 124
 125 sub _getcode {
 126     my $arg = shift;
 127
 128     if ($arg =~ /^\d+$/) {
 129         return $arg;
 130     } elsif ($arg =~ /^(?:U\+|0x)?([[:xdigit:]]+)$/) {
 131         return hex($1);
 132     }
 133
 134     return;
 135 }
 136
 137 sub han_charname {
 138     my $arg  = shift;
 139     my $code = _getcode($arg);
 140     croak __PACKAGE__, "::charinfo: unknown code '$arg'"
 141         unless defined $code;
 142     croak __PACKAGE__, "::han_charname: outside CJK Unified Ideographs '$arg'"
 143         unless 0x3400  <= $code && $code <= 0x4DB5
 144             || 0x4E00  <= $code && $code <= 0x9FA5
 145             || 0x20000 <= $code && $code <= 0x2A6D6;
 146     sprintf "CJK UNIFIED IDEOGRAPH-%04X", $code;
 147 }
 148
 149 my @JamoL = ( # Leading Consonant (HANGUL CHOSEONG)
 150     "G", "GG", "N", "D", "DD", "R", "M", "B", "BB",
 151     "S", "SS", "", "J", "JJ", "C", "K", "T", "P", "H",
 152   );
 153
 154 my @JamoV = ( # Medium Vowel (HANGUL JUNGSEONG)
 155     "A", "AE", "YA", "YAE", "EO", "E", "YEO", "YE", "O",
 156     "WA", "WAE", "OE", "YO", "U", "WEO", "WE", "WI",
 157     "YU", "EU", "YI", "I",
 158   );
 159
 160 my @JamoT = ( # Trailing Consonant (HANGUL JONGSEONG)
 161     "", "G", "GG", "GS", "N", "NJ", "NH", "D", "L", "LG", "LM",
 162     "LB", "LS", "LT", "LP", "LH", "M", "B", "BS",
 163     "S", "SS", "NG", "J", "C", "K", "T", "P", "H",
 164   );
 165
 166 my %HangulConst = (
 167    SBase  => 0xAC00,
 168    LBase  => 0x1100,
 169    VBase  => 0x1161,
 170    TBase  => 0x11A7,
 171    LCount => 19,     # scalar @JamoL
 172    VCount => 21,     # scalar @JamoV
 173    TCount => 28,     # scalar @JamoT
 174    NCount => 588,    # VCount * TCount
 175    SCount => 11172,  # LCount * NCount
 176    Final  => 0xD7A3, # SBase -1 + SCount
 177   );
 178
 179 sub hangul_charname {
 180     my $arg  = shift;
 181     my $code = _getcode($arg);
 182     croak __PACKAGE__, "::charinfo: unknown code '$arg'"
 183         unless defined $code;
 184     croak __PACKAGE__, "::hangul_charname: outside Hangul Syllables '$arg'"
 185         unless $HangulConst{SBase} <= $code && $code <= $HangulConst{Final};
 186     my $SIndex = $code - $HangulConst{SBase};
 187     my $LIndex = int( $SIndex / $HangulConst{NCount});
 188     my $VIndex = int(($SIndex % $HangulConst{NCount}) / $HangulConst{TCount});
 189     my $TIndex =      $SIndex % $HangulConst{TCount};
 190     return join('',
 191         "HANGUL SYLLABLE ",
 192         $JamoL[$LIndex],
 193         $JamoV[$VIndex],
 194         $JamoT[$TIndex],
 195       );
 196 }
 197
 198 sub hangul_decomp {
 199     my $arg  = shift;
 200     my $code = _getcode($arg);
 201     croak __PACKAGE__, "::charinfo: unknown code '$arg'"
 202         unless defined $code;
 203     croak __PACKAGE__, "::hangul_decomp: outside Hangul Syllables '$arg'"
 204         unless $HangulConst{SBase} <= $code && $code <= $HangulConst{Final};
 205     my $SIndex = $code - $HangulConst{SBase};
 206     my $LIndex = int( $SIndex / $HangulConst{NCount});
 207     my $VIndex = int(($SIndex % $HangulConst{NCount}) / $HangulConst{TCount});
 208     my $TIndex =      $SIndex % $HangulConst{TCount};
 209
 210     return join(" ",
 211         sprintf("%04X", $HangulConst{LBase} + $LIndex),
 212         sprintf("%04X", $HangulConst{VBase} + $VIndex),
 213       $TIndex ?
 214         sprintf("%04X", $HangulConst{TBase} + $TIndex) : (),
 215     );
 216 }
 217
 218 my @CharinfoRanges = (
 219 # block name
 220 # [ first, last, coderef to name, coderef to decompose ],
 221 # CJK Ideographs Extension A
 222   [ 0x3400,   0x4DB5,   \&han_charname,   undef  ],
 223 # CJK Ideographs
 224   [ 0x4E00,   0x9FA5,   \&han_charname,   undef  ],
 225 # Hangul Syllables
 226   [ 0xAC00,   0xD7A3,   \&hangul_charname, \&hangul_decomp  ],
 227 # Non-Private Use High Surrogates
 228   [ 0xD800,   0xDB7F,   undef,   undef  ],
 229 # Private Use High Surrogates
 230   [ 0xDB80,   0xDBFF,   undef,   undef  ],
 231 # Low Surrogates
 232   [ 0xDC00,   0xDFFF,   undef,   undef  ],
 233 # The Private Use Area
 234   [ 0xE000,   0xF8FF,   undef,   undef  ],
 235 # CJK Ideographs Extension B
 236   [ 0x20000,  0x2A6D6,  \&han_charname,   undef  ],
 237 # Plane 15 Private Use Area
 238   [ 0xF0000,  0xFFFFD,  undef,   undef  ],
 239 # Plane 16 Private Use Area
 240   [ 0x100000, 0x10FFFD, undef,   undef  ],
 241 );
 242
 243 sub charinfo {
 244     my $arg  = shift;
 245     my $code = _getcode($arg);
 246     croak __PACKAGE__, "::charinfo: unknown code '$arg'"
 247         unless defined $code;
 248     my $hexk = sprintf("%04X", $code);
 249     my($rcode,$rname,$rdec);
 250     foreach my $range (@CharinfoRanges){
 251       if($range->[0] <= $code && $code <= $range->[1]){
 252         $rcode = $hexk;
 253         $rname = $range->[2] ? $range->[2]->($code) : '';
 254         $rdec  = $range->[3] ? $range->[3]->($code) : '';
 255         $hexk  = sprintf("%04X",$range->[0]); # replace by the first
 256         last;
 257       }
 258     }
 259     openunicode(\$UNICODEFH, "Unicode.sort"); # sorted
 260     if (defined $UNICODEFH) {
 261         use Search::Dict;
 262         if (look($UNICODEFH, "$hexk;") >= 0) {
 263             my $line = <$UNICODEFH>;
 264             chomp $line;
 265             my %prop;
 266             @prop{qw(
 267                      code name category
 268                      combining bidi decomposition
 269                      decimal digit numeric
 270                      mirrored unicode10 comment
 271                      upper lower title
 272                     )} = split(/;/, $line, -1);
 273             if ($prop{code} eq $hexk) {
 274                 $prop{block}  = charblock($code);
 275                 $prop{script} = charscript($code);
 276                 if(defined $rname){
 277                     $prop{code} = $rcode;
 278                     $prop{name} = $rname;
 279                     $prop{decomposition} = $rdec;
 280                 }
 281                 return \%prop;
 282             }
 283         }
 284     }
 285     return;
 286 }
 287
 288 sub _search { # Binary search in a [[lo,hi,prop],[...],...] table.
 289     my ($table, $lo, $hi, $code) = @_;
 290
 291     return if $lo > $hi;
 292
 293     my $mid = int(($lo+$hi) / 2);
 294
 295     if ($table->[$mid]->[0] < $code) {
 296         if ($table->[$mid]->[1] >= $code) {
 297             return $table->[$mid]->[2];
 298         } else {
 299             _search($table, $mid + 1, $hi, $code);
 300         }
 301     } elsif ($table->[$mid]->[0] > $code) {
 302         _search($table, $lo, $mid - 1, $code);
 303     } else {
 304         return $table->[$mid]->[2];
 305     }
 306 }
 307
 308 sub charinrange {
 309     my ($range, $arg) = @_;
 310     my $code = _getcode($arg);
 311     croak __PACKAGE__, "::charinrange: unknown code '$arg'"
 312         unless defined $code;
 313     _search($range, 0, $#$range, $code);
 314 }
 315
 316 =head2 charblock
 317
 318     use UnicodeCD 'charblock';
 319
 320     my $charblock = charblock(0x41);
 321     my $charblock = charblock(1234);
 322     my $charblock = charblock("0x263a");
 323     my $charblock = charblock("U+263a");
 324
 325     my $ranges    = charblock('Armenian');
 326
 327 With a B<code point argument> charblock() returns the block the character
 328 belongs to, e.g.  C<Basic Latin>.  Note that not all the character
 329 positions within all blocks are defined.
 330
 331 If supplied with an argument that can't be a code point, charblock()
 332 tries to do the opposite and interpret the argument as a character
 333 block.  The return value is a I<range>: an anonymous list that
 334 contains anonymous lists, which in turn contain I<start-of-range>,
 335 I<end-of-range> code point pairs.  You can test whether a code point
 336 is in a range using the L</charinrange> function.  If the argument is
 337 not a known charater block, C<undef> is returned.
 338
 339 =cut
 340
 341 my @BLOCKS;
 342 my %BLOCKS;
 343
 344 sub _charblocks {
 345     unless (@BLOCKS) {
 346         if (openunicode(\$BLOCKSFH, "Blocks.txt")) {
 347             while (<$BLOCKSFH>) {
 348                 if (/^([0-9A-F]+)\.\.([0-9A-F]+);\s+(.+)/) {
 349                     my ($lo, $hi) = (hex($1), hex($2));
 350                     my $subrange = [ $lo, $hi, $3 ];
 351                     push @BLOCKS, $subrange;
 352                     push @{$BLOCKS{$3}}, $subrange;
 353                 }
 354             }
 355             close($BLOCKSFH);
 356         }
 357     }
 358 }
 359
 360 sub charblock {
 361     my $arg = shift;
 362
 363     _charblocks() unless @BLOCKS;
 364
 365     my $code = _getcode($arg);
 366
 367     if (defined $code) {
 368         _search(\@BLOCKS, 0, $#BLOCKS, $code);
 369     } else {
 370         if (exists $BLOCKS{$arg}) {
 371             return $BLOCKS{$arg};
 372         } else {
 373             return;
 374         }
 375     }
 376 }
 377
 378 =head2 charscript
 379
 380     use UnicodeCD 'charscript';
 381
 382     my $charscript = charscript(0x41);
 383     my $charscript = charscript(1234);
 384     my $charscript = charscript("U+263a");
 385
 386     my $ranges     = charscript('Thai');
 387
 388 With a B<code point argument> charscript() returns the script the
 389 character belongs to, e.g.  C<Latin>, C<Greek>, C<Han>.
 390
 391 If supplied with an argument that can't be a code point, charscript()
 392 tries to do the opposite and interpret the argument as a character
 393 script.  The return value is a I<range>: an anonymous list that
 394 contains anonymous lists, which in turn contain I<start-of-range>,
 395 I<end-of-range> code point pairs.  You can test whether a code point
 396 is in a range using the L</charinrange> function.  If the argument is
 397 not a known charater script, C<undef> is returned.
 398
 399 =cut
 400
 401 my @SCRIPTS;
 402 my %SCRIPTS;
 403
 404 sub _charscripts {
 405     unless (@SCRIPTS) {
 406         if (openunicode(\$SCRIPTSFH, "Scripts.txt")) {
 407             while (<$SCRIPTSFH>) {
 408                 if (/^([0-9A-F]+)(?:\.\.([0-9A-F]+))?\s+;\s+(\w+)/) {
 409                     my ($lo, $hi) = (hex($1), $2 ? hex($2) : hex($1));
 410                     my $script = lc($3);
 411                     $script =~ s/\b(\w)/uc($1)/ge;
 412                     my $subrange = [ $lo, $hi, $script ];
 413                     push @SCRIPTS, $subrange;
 414                     push @{$SCRIPTS{$script}}, $subrange;
 415                 }
 416             }
 417             close($SCRIPTSFH);
 418             @SCRIPTS = sort { $a->[0] <=> $b->[0] } @SCRIPTS;
 419         }
 420     }
 421 }
 422
 423 sub charscript {
 424     my $arg = shift;
 425
 426     _charscripts() unless @SCRIPTS;
 427
 428     my $code = _getcode($arg);
 429
 430     if (defined $code) {
 431         _search(\@SCRIPTS, 0, $#SCRIPTS, $code);
 432     } else {
 433         if (exists $SCRIPTS{$arg}) {
 434             return $SCRIPTS{$arg};
 435         } else {
 436             return;
 437         }
 438     }
 439 }
 440
 441 =head2 charblocks
 442
 443     use UnicodeCD 'charblocks';
 444
 445     my $charblocks = charblocks();
 446
 447 charblocks() returns a reference to a hash with the known block names
 448 as the keys, and the code point ranges (see L</charblock>) as the values.
 449
 450 =cut
 451
 452 sub charblocks {
 453     _charblocks() unless %BLOCKS;
 454     return \%BLOCKS;
 455 }
 456
 457 =head2 charscripts
 458
 459     use UnicodeCD 'charscripts';
 460
 461     my %charscripts = charscripts();
 462
 463 charscripts() returns a hash with the known script names as the keys,
 464 and the code point ranges (see L</charscript>) as the values.
 465
 466 =cut
 467
 468 sub charscripts {
 469     _charscripts() unless %SCRIPTS;
 470     return \%SCRIPTS;
 471 }
 472
 473 =head2 Blocks versus Scripts
 474
 475 The difference between a block and a script is that scripts are closer
 476 to the linguistic notion of a set of characters required to present
 477 languages, while block is more of an artifact of the Unicode character
 478 numbering and separation into blocks of 256 characters.
 479
 480 For example the Latin B<script> is spread over several B<blocks>, such
 481 as C<Basic Latin>, C<Latin 1 Supplement>, C<Latin Extended-A>, and
 482 C<Latin Extended-B>.  On the other hand, the Latin script does not
 483 contain all the characters of the C<Basic Latin> block (also known as
 484 the ASCII): it includes only the letters, not for example the digits
 485 or the punctuation.
 486
 487 For blocks see http://www.unicode.org/Public/UNIDATA/Blocks.txt
 488
 489 For scripts see UTR #24: http://www.unicode.org/unicode/reports/tr24/
 490
 491 =head2 Matching Scripts and Blocks
 492
 493 Both scripts and blocks can be matched using the regular expression
 494 construct C<\p{In...}> and its negation C<\P{In...}>.
 495
 496 The name of the script or the block comes after the C<In>, for example
 497 C<\p{InCyrillic}>, C<\P{InBasicLatin}>.  Spaces and dashes ('-') are
 498 removed from the names for the C<\p{In...}>, for example
 499 C<LatinExtendedA> instead of C<Latin Extended-A>.
 500
 501 There are a few cases where there exists both a script and a block by
 502 the same name, in these cases the block version has C<Block> appended:
 503 C<\p{InKatakana}> is the script, C<\p{InKatakanaBlock}> is the block.
 504
 505 =head2 Code Point Arguments
 506
 507 A <code point argument> is either a decimal or a hexadecimal scalar,
 508 or "U+" followed by hexadecimals.
 509
 510 =head2 charinrange
 511
 512 In addition to using the C<\p{In...}> and C<\P{In...}> constructs, you
 513 can also test whether a code point is in the I<range> as returned by
 514 L</charblock> and L</charscript> or as the values of the hash returned
 515 by L</charblocks> and L</charscripts> by using charinrange():
 516
 517     use UnicodeCD qw(charscript charinrange);
 518
 519     $range = charscript('Hiragana');
 520     print "looks like hiragana\n" if charinrange($range, $codepoint);
 521
 522 =cut
 523
 524 =head2 compexcl
 525
 526     use UnicodeCD 'compexcl';
 527
 528     my $compexcl = compexcl("09dc");
 529
 530 The compexcl() returns the composition exclusion (that is, if the
 531 character should not be produced during a precomposition) of the
 532 character specified by a B<code point argument>.
 533
 534 If there is a composition exclusion for the character, true is
 535 returned.  Otherwise, false is returned.
 536
 537 =cut
 538
 539 my %COMPEXCL;
 540
 541 sub _compexcl {
 542     unless (%COMPEXCL) {
 543         if (openunicode(\$COMPEXCLFH, "CompExcl.txt")) {
 544             while (<$COMPEXCLFH>) {
 545                 if (/^([0-9A-F]+) \# /) {
 546                     my $code = hex($1);
 547                     $COMPEXCL{$code} = undef;
 548                 }
 549             }
 550             close($COMPEXCLFH);
 551         }
 552     }
 553 }
 554
 555 sub compexcl {
 556     my $arg  = shift;
 557     my $code = _getcode($arg);
 558
 559     _compexcl() unless %COMPEXCL;
 560
 561     return exists $COMPEXCL{$code};
 562 }
 563
 564 =head2 casefold
 565
 566     use UnicodeCD 'casefold';
 567
 568     my %casefold = casefold("09dc");
 569
 570 The casefold() returns the locale-independent case folding of the
 571 character specified by a B<code point argument>.
 572
 573 If there is a case folding for that character, a reference to a hash
 574 with the following fields is returned:
 575
 576     key
 577
 578     code             code point with at least four hexdigits
 579     status           "C", "F", "S", or "I"
 580     mapping          one or more codes separated by spaces
 581
 582 The meaning of the I<status> is as follows:
 583
 584    C                 common case folding, common mappings shared
 585                      by both simple and full mappings
 586    F                 full case folding, mappings that cause strings
 587                      to grow in length. Multiple characters are separated
 588                      by spaces
 589    S                 simple case folding, mappings to single characters
 590                      where different from F
 591    I                 special case for dotted uppercase I and
 592                      dotless lowercase i
 593                      - If this mapping is included, the result is
 594                        case-insensitive, but dotless and dotted I's
 595                        are not distinguished
 596                      - If this mapping is excluded, the result is not
 597                        fully case-insensitive, but dotless and dotted
 598                        I's are distinguished
 599
 600 If there is no case folding for that character, C<undef> is returned.
 601
 602 For more information about case mappings see
 603 http://www.unicode.org/unicode/reports/tr21/
 604
 605 =cut
 606
 607 my %CASEFOLD;
 608
 609 sub _casefold {
 610     unless (%CASEFOLD) {
 611         if (openunicode(\$CASEFOLDFH, "CaseFold.txt")) {
 612             while (<$CASEFOLDFH>) {
 613                 if (/^([0-9A-F]+); ([CFSI]); ([0-9A-F]+(?: [0-9A-F]+)*);/) {
 614                     my $code = hex($1);
 615                     $CASEFOLD{$code} = { code    => $1,
 616                                          status  => $2,
 617                                          mapping => $3 };
 618                 }
 619             }
 620             close($CASEFOLDFH);
 621         }
 622     }
 623 }
 624
 625 sub casefold {
 626     my $arg  = shift;
 627     my $code = _getcode($arg);
 628
 629     _casefold() unless %CASEFOLD;
 630
 631     return $CASEFOLD{$code};
 632 }
 633
 634 =head2 casespec
 635
 636     use UnicodeCD 'casespec';
 637
 638     my %casespec = casespec("09dc");
 639
 640 The casespec() returns the potentially locale-dependent case mapping
 641 of the character specified by a B<code point argument>.  The mapping
 642 may change the length of the string (which the basic Unicode case
 643 mappings as returned by charinfo() never do).
 644
 645 If there is a case folding for that character, a reference to a hash
 646 with the following fields is returned:
 647
 648     key
 649
 650     code             code point with at least four hexdigits
 651     lower            lowercase
 652     title            titlecase
 653     upper            uppercase
 654     condition        condition list (may be undef)
 655
 656 The C<condition> is optional.  Where present, it consists of one or
 657 more I<locales> or I<contexts>, separated by spaces (other than as
 658 used to separate elements, spaces are to be ignored).  A condition
 659 list overrides the normal behavior if all of the listed conditions are
 660 true.  Case distinctions in the condition list are not significant.
 661 Conditions preceded by "NON_" represent the negation of the condition
 662
 663 A I<locale> is defined as a 2-letter ISO 3166 country code, possibly
 664 followed by a "_" and a 2-letter ISO language code (possibly followed
 665 by a "_" and a variant code).  You can find the lists of those codes,
 666 see L<Locale::Country> and L<Locale::Language>.
 667
 668 A I<context> is one of the following choices:
 669
 670     FINAL            The letter is not followed by a letter of
 671                      general category L (e.g. Ll, Lt, Lu, Lm, or Lo)
 672     MODERN           The mapping is only used for modern text
 673     AFTER_i          The last base character was "i" (U+0069)
 674
 675 For more information about case mappings see
 676 http://www.unicode.org/unicode/reports/tr21/
 677
 678 =cut
 679
 680 my %CASESPEC;
 681
 682 sub _casespec {
 683     unless (%CASESPEC) {
 684         if (openunicode(\$CASESPECFH, "SpecCase.txt")) {
 685             while (<$CASESPECFH>) {
 686                 if (/^([0-9A-F]+); ([0-9A-F]+(?: [0-9A-F]+)*)?; ([0-9A-F]+(?: [0-9A-F]+)*)?; ([0-9A-F]+(?: [0-9A-F]+)*)?; (\w+(?: \w+)*)?/) {
 687                     my $code = hex($1);
 688                     $CASESPEC{$code} = { code      => $1,
 689                                          lower     => $2,
 690                                          title     => $3,
 691                                          upper     => $4,
 692                                          condition => $5 };
 693                 }
 694             }
 695             close($CASESPECFH);
 696         }
 697     }
 698 }
 699
 700 sub casespec {
 701     my $arg  = shift;
 702     my $code = _getcode($arg);
 703
 704     _casespec() unless %CASESPEC;
 705
 706     return $CASESPEC{$code};
 707 }
 708
 709 =head2 UnicodeCD::UnicodeVersion
 710
 711 UnicodeCD::UnicodeVersion() returns the version of the Unicode Character
 712 Database, in other words, the version of the Unicode standard the
 713 database implements.
 714
 715 =cut
 716
 717 my $UNICODEVERSION;
 718
 719 sub UnicodeVersion {
 720     unless (defined $UNICODEVERSION) {
 721         openunicode(\$VERSIONFH, "version");
 722         chomp($UNICODEVERSION = <$VERSIONFH>);
 723         close($VERSIONFH);
 724         croak __PACKAGE__, "::VERSION: strange version '$UNICODEVERSION'"
 725             unless $UNICODEVERSION =~ /^\d+(?:\.\d+)+$/;
 726     }
 727     return $UNICODEVERSION;
 728 }
 729
 730 =head2 Implementation Note
 731
 732 The first use of charinfo() opens a read-only filehandle to the Unicode
 733 Character Database (the database is included in the Perl distribution).
 734 The filehandle is then kept open for further queries.
 735
 736 =head1 AUTHOR
 737
 738 Jarkko Hietaniemi
 739
 740 =cut
 741
 742 1;