lib/Unicode/UCD.pm

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