This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
UCD.pm: Don't use NamedSequences.txt, saves disk
[perl5.git] / lib / Unicode / UCD.pm
1 package Unicode::UCD;
2
3 use strict;
4 use warnings;
5 use charnames ();
6
7 our $VERSION = '0.29';
8
9 use Storable qw(dclone);
10
11 require Exporter;
12
13 our @ISA = qw(Exporter);
14
15 our @EXPORT_OK = qw(charinfo
16                     charblock charscript
17                     charblocks charscripts
18                     charinrange
19                     general_categories bidi_types
20                     compexcl
21                     casefold casespec
22                     namedseq);
23
24 use Carp;
25
26 =head1 NAME
27
28 Unicode::UCD - Unicode character database
29
30 =head1 SYNOPSIS
31
32     use Unicode::UCD 'charinfo';
33     my $charinfo   = charinfo($codepoint);
34
35     use Unicode::UCD 'casefold';
36     my $casefold = casefold(0xFB00);
37
38     use Unicode::UCD 'casespec';
39     my $casespec = casespec(0xFB00);
40
41     use Unicode::UCD 'charblock';
42     my $charblock  = charblock($codepoint);
43
44     use Unicode::UCD 'charscript';
45     my $charscript = charscript($codepoint);
46
47     use Unicode::UCD 'charblocks';
48     my $charblocks = charblocks();
49
50     use Unicode::UCD 'charscripts';
51     my $charscripts = charscripts();
52
53     use Unicode::UCD qw(charscript charinrange);
54     my $range = charscript($script);
55     print "looks like $script\n" if charinrange($range, $codepoint);
56
57     use Unicode::UCD qw(general_categories bidi_types);
58     my $categories = general_categories();
59     my $types = bidi_types();
60
61     use Unicode::UCD 'compexcl';
62     my $compexcl = compexcl($codepoint);
63
64     use Unicode::UCD 'namedseq';
65     my $namedseq = namedseq($named_sequence_name);
66
67     my $unicode_version = Unicode::UCD::UnicodeVersion();
68
69 =head1 DESCRIPTION
70
71 The Unicode::UCD module offers a series of functions that
72 provide a simple interface to the Unicode
73 Character Database.
74
75 =head2 code point argument
76
77 Some of the functions are called with a I<code point argument>, which is either
78 a decimal or a hexadecimal scalar designating a Unicode code point, or C<U+>
79 followed by hexadecimals designating a Unicode code point.  In other words, if
80 you want a code point to be interpreted as a hexadecimal number, you must
81 prefix it with either C<0x> or C<U+>, because a string like e.g. C<123> will be
82 interpreted as a decimal code point.  Also note that Unicode is B<not> limited
83 to 16 bits (the number of Unicode code points is open-ended, in theory
84 unlimited): you may have more than 4 hexdigits.
85 =cut
86
87 my $UNICODEFH;
88 my $BLOCKSFH;
89 my $SCRIPTSFH;
90 my $VERSIONFH;
91 my $COMPEXCLFH;
92 my $CASEFOLDFH;
93 my $CASESPECFH;
94 my $NAMEDSEQFH;
95
96 sub openunicode {
97     my ($rfh, @path) = @_;
98     my $f;
99     unless (defined $$rfh) {
100         for my $d (@INC) {
101             use File::Spec;
102             $f = File::Spec->catfile($d, "unicore", @path);
103             last if open($$rfh, $f);
104             undef $f;
105         }
106         croak __PACKAGE__, ": failed to find ",
107               File::Spec->catfile(@path), " in @INC"
108             unless defined $f;
109     }
110     return $f;
111 }
112
113 =head2 B<charinfo()>
114
115     use Unicode::UCD 'charinfo';
116
117     my $charinfo = charinfo(0x41);
118
119 This returns information about the input L</code point argument>
120 as a reference to a hash of fields as defined by the Unicode
121 standard.  If the L</code point argument> is not assigned in the standard
122 (i.e., has the general category C<Cn> meaning C<Unassigned>)
123 or is a non-character (meaning it is guaranteed to never be assigned in
124 the standard),
125 B<undef> is returned.
126
127 Fields that aren't applicable to the particular code point argument exist in the
128 returned hash, and are empty. 
129
130 The keys in the hash with the meanings of their values are:
131
132 =over
133
134 =item B<code>
135
136 the input L</code point argument> expressed in hexadecimal, with leading zeros
137 added if necessary to make it contain at least four hexdigits
138
139 =item B<name>
140
141 name of I<code>, all IN UPPER CASE.
142 Some control-type code points do not have names.
143 This field will be empty for C<Surrogate> and C<Private Use> code points,
144 and for the others without a name,
145 it will contain a description enclosed in angle brackets, like
146 C<E<lt>controlE<gt>>.
147
148
149 =item B<category>
150
151 The short name of the general category of I<code>.
152 This will match one of the keys in the hash returned by L</general_categories()>.
153
154 =item B<combining>
155
156 the combining class number for I<code> used in the Canonical Ordering Algorithm.
157 For Unicode 5.1, this is described in Section 3.11 C<Canonical Ordering Behavior>
158 available at
159 L<http://www.unicode.org/versions/Unicode5.1.0/>
160
161 =item B<bidi>
162
163 bidirectional type of I<code>.
164 This will match one of the keys in the hash returned by L</bidi_types()>.
165
166 =item B<decomposition>
167
168 is empty if I<code> has no decomposition; or is one or more codes
169 (separated by spaces) that taken in order represent a decomposition for
170 I<code>.  Each has at least four hexdigits.
171 The codes may be preceded by a word enclosed in angle brackets then a space,
172 like C<E<lt>compatE<gt> >, giving the type of decomposition
173
174 =item B<decimal>
175
176 if I<code> is a decimal digit this is its integer numeric value
177
178 =item B<digit>
179
180 if I<code> represents a whole number, this is its integer numeric value
181
182 =item B<numeric>
183
184 if I<code> represents a whole or rational number, this is its numeric value.
185 Rational values are expressed as a string like C<1/4>.
186
187 =item B<mirrored>
188
189 C<Y> or C<N> designating if I<code> is mirrored in bidirectional text
190
191 =item B<unicode10>
192
193 name of I<code> in the Unicode 1.0 standard if one
194 existed for this code point and is different from the current name
195
196 =item B<comment>
197
198 ISO 10646 comment field.
199 It appears in parentheses in the ISO 10646 names list,
200 or contains an asterisk to indicate there is
201 a note for this code point in Annex P of that standard.
202
203 =item B<upper>
204
205 is empty if there is no single code point uppercase mapping for I<code>;
206 otherwise it is that mapping expressed as at least four hexdigits.
207 (L</casespec()> should be used in addition to B<charinfo()>
208 for case mappings when the calling program can cope with multiple code point
209 mappings.)
210
211 =item B<lower>
212
213 is empty if there is no single code point lowercase mapping for I<code>;
214 otherwise it is that mapping expressed as at least four hexdigits.
215 (L</casespec()> should be used in addition to B<charinfo()>
216 for case mappings when the calling program can cope with multiple code point
217 mappings.)
218
219 =item B<title>
220
221 is empty if there is no single code point titlecase mapping for I<code>;
222 otherwise it is that mapping expressed as at least four hexdigits.
223 (L</casespec()> should be used in addition to B<charinfo()>
224 for case mappings when the calling program can cope with multiple code point
225 mappings.)
226
227 =item B<block>
228
229 block I<code> belongs to (used in \p{In...}).
230 See L</Blocks versus Scripts>.
231
232
233 =item B<script>
234
235 script I<code> belongs to.
236 See L</Blocks versus Scripts>.
237
238 =back
239
240 Note that you cannot do (de)composition and casing based solely on the
241 I<decomposition>, I<combining>, I<lower>, I<upper>, and I<title> fields;
242 you will need also the L</compexcl()>, and L</casespec()> functions.
243
244 =cut
245
246 # NB: This function is nearly duplicated in charnames.pm
247 sub _getcode {
248     my $arg = shift;
249
250     if ($arg =~ /^[1-9]\d*$/) {
251         return $arg;
252     } elsif ($arg =~ /^(?:[Uu]\+|0[xX])?([[:xdigit:]]+)$/) {
253         return hex($1);
254     }
255
256     return;
257 }
258
259 # Lingua::KO::Hangul::Util not part of the standard distribution
260 # but it will be used if available.
261
262 eval { require Lingua::KO::Hangul::Util };
263 my $hasHangulUtil = ! $@;
264 if ($hasHangulUtil) {
265     Lingua::KO::Hangul::Util->import();
266 }
267
268 sub hangul_decomp { # internal: called from charinfo
269     if ($hasHangulUtil) {
270         my @tmp = decomposeHangul(shift);
271         return sprintf("%04X %04X",      @tmp) if @tmp == 2;
272         return sprintf("%04X %04X %04X", @tmp) if @tmp == 3;
273     }
274     return;
275 }
276
277 sub hangul_charname { # internal: called from charinfo
278     return sprintf("HANGUL SYLLABLE-%04X", shift);
279 }
280
281 sub han_charname { # internal: called from charinfo
282     return sprintf("CJK UNIFIED IDEOGRAPH-%04X", shift);
283 }
284
285 # Overwritten by data in file
286 my %first_last = (
287    'CJK Ideograph Extension A' => [ 0x3400,   0x4DB5   ],
288    'CJK Ideograph'             => [ 0x4E00,   0x9FA5   ],
289    'CJK Ideograph Extension B' => [ 0x20000,  0x2A6D6  ],
290 );
291
292 get_charinfo_ranges();
293
294 sub get_charinfo_ranges {
295    my @blocks = keys %first_last;
296    
297    my $fh;
298    openunicode( \$fh, 'UnicodeData.txt' );
299    if( defined $fh ){
300       while( my $line = <$fh> ){
301          next unless $line =~ /(?:First|Last)/;
302          if( grep{ $line =~ /[^;]+;<$_\s*,\s*(?:First|Last)>/ }@blocks ){
303             my ($number,$block,$type);
304             ($number,$block) = split /;/, $line;
305             $block =~ s/<|>//g;
306             ($block,$type) = split /, /, $block;
307             my $index = $type eq 'First' ? 0 : 1;
308             $first_last{ $block }->[$index] = hex $number;
309          }
310       }
311    }
312 }
313
314 my @CharinfoRanges = (
315 # block name
316 # [ first, last, coderef to name, coderef to decompose ],
317 # CJK Ideographs Extension A
318   [ @{ $first_last{'CJK Ideograph Extension A'} },        \&han_charname,   undef  ],
319 # CJK Ideographs
320   [ @{ $first_last{'CJK Ideograph'} },                    \&han_charname,   undef  ],
321 # Hangul Syllables
322   [ 0xAC00,   0xD7A3,   $hasHangulUtil ? \&getHangulName : \&hangul_charname,  \&hangul_decomp ],
323 # Non-Private Use High Surrogates
324   [ 0xD800,   0xDB7F,   undef,   undef  ],
325 # Private Use High Surrogates
326   [ 0xDB80,   0xDBFF,   undef,   undef  ],
327 # Low Surrogates
328   [ 0xDC00,   0xDFFF,   undef,   undef  ],
329 # The Private Use Area
330   [ 0xE000,   0xF8FF,   undef,   undef  ],
331 # CJK Ideographs Extension B
332   [ @{ $first_last{'CJK Ideograph Extension B'} },        \&han_charname,   undef  ],
333 # Plane 15 Private Use Area
334   [ 0xF0000,  0xFFFFD,  undef,   undef  ],
335 # Plane 16 Private Use Area
336   [ 0x100000, 0x10FFFD, undef,   undef  ],
337 );
338
339 sub charinfo {
340     my $arg  = shift;
341     my $code = _getcode($arg);
342     croak __PACKAGE__, "::charinfo: unknown code '$arg'"
343         unless defined $code;
344     my $hexk = sprintf("%06X", $code);
345     my($rcode,$rname,$rdec);
346     foreach my $range (@CharinfoRanges){
347       if ($range->[0] <= $code && $code <= $range->[1]) {
348         $rcode = $hexk;
349         $rcode =~ s/^0+//;
350         $rcode =  sprintf("%04X", hex($rcode));
351         $rname = $range->[2] ? $range->[2]->($code) : '';
352         $rdec  = $range->[3] ? $range->[3]->($code) : '';
353         $hexk  = sprintf("%06X", $range->[0]); # replace by the first
354         last;
355       }
356     }
357     openunicode(\$UNICODEFH, "UnicodeData.txt");
358     if (defined $UNICODEFH) {
359         use Search::Dict 1.02;
360         if (look($UNICODEFH, "$hexk;", { xfrm => sub { $_[0] =~ /^([^;]+);(.+)/; sprintf "%06X;$2", hex($1) } } ) >= 0) {
361             my $line = <$UNICODEFH>;
362             return unless defined $line;
363             chomp $line;
364             my %prop;
365             @prop{qw(
366                      code name category
367                      combining bidi decomposition
368                      decimal digit numeric
369                      mirrored unicode10 comment
370                      upper lower title
371                     )} = split(/;/, $line, -1);
372             $hexk =~ s/^0+//;
373             $hexk =  sprintf("%04X", hex($hexk));
374             if ($prop{code} eq $hexk) {
375                 $prop{block}  = charblock($code);
376                 $prop{script} = charscript($code);
377                 if(defined $rname){
378                     $prop{code} = $rcode;
379                     $prop{name} = $rname;
380                     $prop{decomposition} = $rdec;
381                 }
382                 return \%prop;
383             }
384         }
385     }
386     return;
387 }
388
389 sub _search { # Binary search in a [[lo,hi,prop],[...],...] table.
390     my ($table, $lo, $hi, $code) = @_;
391
392     return if $lo > $hi;
393
394     my $mid = int(($lo+$hi) / 2);
395
396     if ($table->[$mid]->[0] < $code) {
397         if ($table->[$mid]->[1] >= $code) {
398             return $table->[$mid]->[2];
399         } else {
400             _search($table, $mid + 1, $hi, $code);
401         }
402     } elsif ($table->[$mid]->[0] > $code) {
403         _search($table, $lo, $mid - 1, $code);
404     } else {
405         return $table->[$mid]->[2];
406     }
407 }
408
409 sub charinrange {
410     my ($range, $arg) = @_;
411     my $code = _getcode($arg);
412     croak __PACKAGE__, "::charinrange: unknown code '$arg'"
413         unless defined $code;
414     _search($range, 0, $#$range, $code);
415 }
416
417 =head2 B<charblock()>
418
419     use Unicode::UCD 'charblock';
420
421     my $charblock = charblock(0x41);
422     my $charblock = charblock(1234);
423     my $charblock = charblock(0x263a);
424     my $charblock = charblock("U+263a");
425
426     my $range     = charblock('Armenian');
427
428 With a L</code point argument> charblock() returns the I<block> the code point
429 belongs to, e.g.  C<Basic Latin>.
430 If the code point is unassigned, this returns the block it would belong to if
431 it were assigned (which it may in future versions of the Unicode Standard).
432
433 See also L</Blocks versus Scripts>.
434
435 If supplied with an argument that can't be a code point, charblock() tries
436 to do the opposite and interpret the argument as a code point block. The
437 return value is a I<range>: an anonymous list of lists that contain
438 I<start-of-range>, I<end-of-range> code point pairs. You can test whether
439 a code point is in a range using the L</charinrange()> function. If the
440 argument is not a known code point block, B<undef> is returned.
441
442 =cut
443
444 my @BLOCKS;
445 my %BLOCKS;
446
447 sub _charblocks {
448     unless (@BLOCKS) {
449         if (openunicode(\$BLOCKSFH, "Blocks.txt")) {
450             local $_;
451             while (<$BLOCKSFH>) {
452                 if (/^([0-9A-F]+)\.\.([0-9A-F]+);\s+(.+)/) {
453                     my ($lo, $hi) = (hex($1), hex($2));
454                     my $subrange = [ $lo, $hi, $3 ];
455                     push @BLOCKS, $subrange;
456                     push @{$BLOCKS{$3}}, $subrange;
457                 }
458             }
459             close($BLOCKSFH);
460         }
461     }
462 }
463
464 sub charblock {
465     my $arg = shift;
466
467     _charblocks() unless @BLOCKS;
468
469     my $code = _getcode($arg);
470
471     if (defined $code) {
472         _search(\@BLOCKS, 0, $#BLOCKS, $code);
473     } else {
474         if (exists $BLOCKS{$arg}) {
475             return dclone $BLOCKS{$arg};
476         } else {
477             return;
478         }
479     }
480 }
481
482 =head2 B<charscript()>
483
484     use Unicode::UCD 'charscript';
485
486     my $charscript = charscript(0x41);
487     my $charscript = charscript(1234);
488     my $charscript = charscript("U+263a");
489
490     my $range      = charscript('Thai');
491
492 With a L</code point argument> charscript() returns the I<script> the
493 code point belongs to, e.g.  C<Latin>, C<Greek>, C<Han>.
494 If the code point is unassigned, it returns B<undef>
495
496 If supplied with an argument that can't be a code point, charscript() tries
497 to do the opposite and interpret the argument as a code point script. The
498 return value is a I<range>: an anonymous list of lists that contain
499 I<start-of-range>, I<end-of-range> code point pairs. You can test whether a
500 code point is in a range using the L</charinrange()> function. If the
501 argument is not a known code point script, B<undef> is returned.
502
503 See also L</Blocks versus Scripts>.
504
505 =cut
506
507 my @SCRIPTS;
508 my %SCRIPTS;
509
510 sub _charscripts {
511     unless (@SCRIPTS) {
512         if (openunicode(\$SCRIPTSFH, "Scripts.txt")) {
513             local $_;
514             while (<$SCRIPTSFH>) {
515                 if (/^([0-9A-F]+)(?:\.\.([0-9A-F]+))?\s+;\s+(\w+)/) {
516                     my ($lo, $hi) = (hex($1), $2 ? hex($2) : hex($1));
517                     my $script = lc($3);
518                     $script =~ s/\b(\w)/uc($1)/ge;
519                     my $subrange = [ $lo, $hi, $script ];
520                     push @SCRIPTS, $subrange;
521                     push @{$SCRIPTS{$script}}, $subrange;
522                 }
523             }
524             close($SCRIPTSFH);
525             @SCRIPTS = sort { $a->[0] <=> $b->[0] } @SCRIPTS;
526         }
527     }
528 }
529
530 sub charscript {
531     my $arg = shift;
532
533     _charscripts() unless @SCRIPTS;
534
535     my $code = _getcode($arg);
536
537     if (defined $code) {
538         _search(\@SCRIPTS, 0, $#SCRIPTS, $code);
539     } else {
540         if (exists $SCRIPTS{$arg}) {
541             return dclone $SCRIPTS{$arg};
542         } else {
543             return;
544         }
545     }
546 }
547
548 =head2 B<charblocks()>
549
550     use Unicode::UCD 'charblocks';
551
552     my $charblocks = charblocks();
553
554 charblocks() returns a reference to a hash with the known block names
555 as the keys, and the code point ranges (see L</charblock()>) as the values.
556
557 See also L</Blocks versus Scripts>.
558
559 =cut
560
561 sub charblocks {
562     _charblocks() unless %BLOCKS;
563     return dclone \%BLOCKS;
564 }
565
566 =head2 B<charscripts()>
567
568     use Unicode::UCD 'charscripts';
569
570     my $charscripts = charscripts();
571
572 charscripts() returns a reference to a hash with the known script
573 names as the keys, and the code point ranges (see L</charscript()>) as
574 the values.
575
576 See also L</Blocks versus Scripts>.
577
578 =cut
579
580 sub charscripts {
581     _charscripts() unless %SCRIPTS;
582     return dclone \%SCRIPTS;
583 }
584
585 =head2 B<charinrange()>
586
587 In addition to using the C<\p{In...}> and C<\P{In...}> constructs, you
588 can also test whether a code point is in the I<range> as returned by
589 L</charblock()> and L</charscript()> or as the values of the hash returned
590 by L</charblocks()> and L</charscripts()> by using charinrange():
591
592     use Unicode::UCD qw(charscript charinrange);
593
594     $range = charscript('Hiragana');
595     print "looks like hiragana\n" if charinrange($range, $codepoint);
596
597 =cut
598
599 my %GENERAL_CATEGORIES =
600  (
601     'L'  =>         'Letter',
602     'LC' =>         'CasedLetter',
603     'Lu' =>         'UppercaseLetter',
604     'Ll' =>         'LowercaseLetter',
605     'Lt' =>         'TitlecaseLetter',
606     'Lm' =>         'ModifierLetter',
607     'Lo' =>         'OtherLetter',
608     'M'  =>         'Mark',
609     'Mn' =>         'NonspacingMark',
610     'Mc' =>         'SpacingMark',
611     'Me' =>         'EnclosingMark',
612     'N'  =>         'Number',
613     'Nd' =>         'DecimalNumber',
614     'Nl' =>         'LetterNumber',
615     'No' =>         'OtherNumber',
616     'P'  =>         'Punctuation',
617     'Pc' =>         'ConnectorPunctuation',
618     'Pd' =>         'DashPunctuation',
619     'Ps' =>         'OpenPunctuation',
620     'Pe' =>         'ClosePunctuation',
621     'Pi' =>         'InitialPunctuation',
622     'Pf' =>         'FinalPunctuation',
623     'Po' =>         'OtherPunctuation',
624     'S'  =>         'Symbol',
625     'Sm' =>         'MathSymbol',
626     'Sc' =>         'CurrencySymbol',
627     'Sk' =>         'ModifierSymbol',
628     'So' =>         'OtherSymbol',
629     'Z'  =>         'Separator',
630     'Zs' =>         'SpaceSeparator',
631     'Zl' =>         'LineSeparator',
632     'Zp' =>         'ParagraphSeparator',
633     'C'  =>         'Other',
634     'Cc' =>         'Control',
635     'Cf' =>         'Format',
636     'Cs' =>         'Surrogate',
637     'Co' =>         'PrivateUse',
638     'Cn' =>         'Unassigned',
639  );
640
641 sub general_categories {
642     return dclone \%GENERAL_CATEGORIES;
643 }
644
645 =head2 B<general_categories()>
646
647     use Unicode::UCD 'general_categories';
648
649     my $categories = general_categories();
650
651 This returns a reference to a hash which has short
652 general category names (such as C<Lu>, C<Nd>, C<Zs>, C<S>) as keys and long
653 names (such as C<UppercaseLetter>, C<DecimalNumber>, C<SpaceSeparator>,
654 C<Symbol>) as values.  The hash is reversible in case you need to go
655 from the long names to the short names.  The general category is the
656 one returned from
657 L</charinfo()> under the C<category> key.
658
659 =cut
660
661 my %BIDI_TYPES =
662  (
663    'L'   => 'Left-to-Right',
664    'LRE' => 'Left-to-Right Embedding',
665    'LRO' => 'Left-to-Right Override',
666    'R'   => 'Right-to-Left',
667    'AL'  => 'Right-to-Left Arabic',
668    'RLE' => 'Right-to-Left Embedding',
669    'RLO' => 'Right-to-Left Override',
670    'PDF' => 'Pop Directional Format',
671    'EN'  => 'European Number',
672    'ES'  => 'European Number Separator',
673    'ET'  => 'European Number Terminator',
674    'AN'  => 'Arabic Number',
675    'CS'  => 'Common Number Separator',
676    'NSM' => 'Non-Spacing Mark',
677    'BN'  => 'Boundary Neutral',
678    'B'   => 'Paragraph Separator',
679    'S'   => 'Segment Separator',
680    'WS'  => 'Whitespace',
681    'ON'  => 'Other Neutrals',
682  ); 
683
684 =head2 B<bidi_types()>
685
686     use Unicode::UCD 'bidi_types';
687
688     my $categories = bidi_types();
689
690 This returns a reference to a hash which has the short
691 bidi (bidirectional) type names (such as C<L>, C<R>) as keys and long
692 names (such as C<Left-to-Right>, C<Right-to-Left>) as values.  The
693 hash is reversible in case you need to go from the long names to the
694 short names.  The bidi type is the one returned from
695 L</charinfo()>
696 under the C<bidi> key.  For the exact meaning of the various bidi classes
697 the Unicode TR9 is recommended reading:
698 L<http://www.unicode.org/reports/tr9/>
699 (as of Unicode 5.0.0)
700
701 =cut
702
703 sub bidi_types {
704     return dclone \%BIDI_TYPES;
705 }
706
707 =head2 B<compexcl()>
708
709     use Unicode::UCD 'compexcl';
710
711     my $compexcl = compexcl(0x09dc);
712
713 This returns B<true> if the
714 L</code point argument> should not be produced by composition normalization,
715 B<AND> if that fact is not otherwise determinable from the Unicode data base.
716 It currently does not return B<true> if the code point has a decomposition
717 consisting of another single code point, nor if its decomposition starts
718 with a code point whose combining class is non-zero.  Code points that meet
719 either of these conditions should also not be produced by composition
720 normalization.
721
722 It returns B<false> otherwise.
723
724 =cut
725
726 my %COMPEXCL;
727
728 sub _compexcl {
729     unless (%COMPEXCL) {
730         if (openunicode(\$COMPEXCLFH, "CompositionExclusions.txt")) {
731             local $_;
732             while (<$COMPEXCLFH>) {
733                 if (/^([0-9A-F]+)\s+\#\s+/) {
734                     my $code = hex($1);
735                     $COMPEXCL{$code} = undef;
736                 }
737             }
738             close($COMPEXCLFH);
739         }
740     }
741 }
742
743 sub compexcl {
744     my $arg  = shift;
745     my $code = _getcode($arg);
746     croak __PACKAGE__, "::compexcl: unknown code '$arg'"
747         unless defined $code;
748
749     _compexcl() unless %COMPEXCL;
750
751     return exists $COMPEXCL{$code};
752 }
753
754 =head2 B<casefold()>
755
756     use Unicode::UCD 'casefold';
757
758     my $casefold = casefold(0xDF);
759     if (defined $casefold) {
760         my @full_fold_hex = split / /, $casefold->{'full'};
761         my $full_fold_string =
762                     join "", map {chr(hex($_))} @full_fold_hex;
763         my @turkic_fold_hex =
764                         split / /, ($casefold->{'turkic'} ne "")
765                                         ? $casefold->{'turkic'}
766                                         : $casefold->{'full'};
767         my $turkic_fold_string =
768                         join "", map {chr(hex($_))} @turkic_fold_hex;
769     }
770     if (defined $casefold && $casefold->{'simple'} ne "") {
771         my $simple_fold_hex = $casefold->{'simple'};
772         my $simple_fold_string = chr(hex($simple_fold_hex));
773     }
774
775 This returns the (almost) locale-independent case folding of the
776 character specified by the L</code point argument>.
777
778 If there is no case folding for that code point, B<undef> is returned.
779
780 If there is a case folding for that code point, a reference to a hash
781 with the following fields is returned:
782
783 =over
784
785 =item B<code>
786
787 the input L</code point argument> expressed in hexadecimal, with leading zeros
788 added if necessary to make it contain at least four hexdigits
789
790 =item B<full>
791
792 one or more codes (separated by spaces) that taken in order give the
793 code points for the case folding for I<code>.
794 Each has at least four hexdigits.
795
796 =item B<simple>
797
798 is empty, or is exactly one code with at least four hexdigits which can be used
799 as an alternative case folding when the calling program cannot cope with the
800 fold being a sequence of multiple code points.  If I<full> is just one code
801 point, then I<simple> equals I<full>.  If there is no single code point folding
802 defined for I<code>, then I<simple> is the empty string.  Otherwise, it is an
803 inferior, but still better-than-nothing alternative folding to I<full>.
804
805 =item B<mapping>
806
807 is the same as I<simple> if I<simple> is not empty, and it is the same as I<full>
808 otherwise.  It can be considered to be the simplest possible folding for
809 I<code>.  It is defined primarily for backwards compatibility.
810
811 =item B<status>
812
813 is C<C> (for C<common>) if the best possible fold is a single code point
814 (I<simple> equals I<full> equals I<mapping>).  It is C<S> if there are distinct
815 folds, I<simple> and I<full> (I<mapping> equals I<simple>).  And it is C<F> if
816 there only a I<full> fold (I<mapping> equals I<full>; I<simple> is empty).  Note
817 that this
818 describes the contents of I<mapping>.  It is defined primarily for backwards
819 compatibility.
820
821 On versions 3.1 and earlier of Unicode, I<status> can also be
822 C<I> which is the same as C<C> but is a special case for dotted uppercase I and
823 dotless lowercase i:
824
825 =over
826
827 =item B<*>
828
829 If you use this C<I> mapping, the result is case-insensitive,
830 but dotless and dotted I's are not distinguished
831
832 =item B<*>
833
834 If you exclude this C<I> mapping, the result is not fully case-insensitive, but
835 dotless and dotted I's are distinguished
836
837 =back
838
839 =item B<turkic>
840
841 contains any special folding for Turkic languages.  For versions of Unicode
842 starting with 3.2, this field is empty unless I<code> has a different folding
843 in Turkic languages, in which case it is one or more codes (separated by
844 spaces) that taken in order give the code points for the case folding for
845 I<code> in those languages.
846 Each code has at least four hexdigits.
847 Note that this folding does not maintain canonical equivalence without
848 additional processing.
849
850 For versions of Unicode 3.1 and earlier, this field is empty unless there is a
851 special folding for Turkic languages, in which case I<status> is C<I>, and
852 I<mapping>, I<full>, I<simple>, and I<turkic> are all equal.  
853
854 =back
855
856 Programs that want complete generality and the best folding results should use
857 the folding contained in the I<full> field.  But note that the fold for some
858 code points will be a sequence of multiple code points.
859
860 Programs that can't cope with the fold mapping being multiple code points can
861 use the folding contained in the I<simple> field, with the loss of some
862 generality.  In Unicode 5.1, about 7% of the defined foldings have no single
863 code point folding.
864
865 The I<mapping> and I<status> fields are provided for backwards compatibility for
866 existing programs.  They contain the same values as in previous versions of
867 this function.
868
869 Locale is not completely independent.  The I<turkic> field contains results to
870 use when the locale is a Turkic language.
871
872 For more information about case mappings see
873 L<http://www.unicode.org/unicode/reports/tr21>
874
875 =cut
876
877 my %CASEFOLD;
878
879 sub _casefold {
880     unless (%CASEFOLD) {
881         if (openunicode(\$CASEFOLDFH, "CaseFolding.txt")) {
882             local $_;
883             while (<$CASEFOLDFH>) {
884                 if (/^([0-9A-F]+); ([CFIST]); ([0-9A-F]+(?: [0-9A-F]+)*);/) {
885                     my $code = hex($1);
886                     $CASEFOLD{$code}{'code'} = $1;
887                     $CASEFOLD{$code}{'turkic'} = "" unless
888                                             defined $CASEFOLD{$code}{'turkic'};
889                     if ($2 eq 'C' || $2 eq 'I') {       # 'I' is only on 3.1 and
890                                                         # earlier Unicodes
891                                                         # Both entries there (I
892                                                         # only checked 3.1) are
893                                                         # the same as C, and
894                                                         # there are no other
895                                                         # entries for those
896                                                         # codepoints, so treat
897                                                         # as if C, but override
898                                                         # the turkic one for
899                                                         # 'I'.
900                         $CASEFOLD{$code}{'status'} = $2;
901                         $CASEFOLD{$code}{'full'} = $CASEFOLD{$code}{'simple'} =
902                         $CASEFOLD{$code}{'mapping'} = $3;
903                         $CASEFOLD{$code}{'turkic'} = $3 if $2 eq 'I';
904                     } elsif ($2 eq 'F') {
905                         $CASEFOLD{$code}{'full'} = $3;
906                         unless (defined $CASEFOLD{$code}{'simple'}) {
907                                 $CASEFOLD{$code}{'simple'} = "";
908                                 $CASEFOLD{$code}{'mapping'} = $3;
909                                 $CASEFOLD{$code}{'status'} = $2;
910                         }
911                     } elsif ($2 eq 'S') {
912
913
914                         # There can't be a simple without a full, and simple
915                         # overrides all but full
916
917                         $CASEFOLD{$code}{'simple'} = $3;
918                         $CASEFOLD{$code}{'mapping'} = $3;
919                         $CASEFOLD{$code}{'status'} = $2;
920                     } elsif ($2 eq 'T') {
921                         $CASEFOLD{$code}{'turkic'} = $3;
922                     } # else can't happen because only [CIFST] are possible
923                 }
924             }
925             close($CASEFOLDFH);
926         }
927     }
928 }
929
930 sub casefold {
931     my $arg  = shift;
932     my $code = _getcode($arg);
933     croak __PACKAGE__, "::casefold: unknown code '$arg'"
934         unless defined $code;
935
936     _casefold() unless %CASEFOLD;
937
938     return $CASEFOLD{$code};
939 }
940
941 =head2 B<casespec()>
942
943     use Unicode::UCD 'casespec';
944
945     my $casespec = casespec(0xFB00);
946
947 This returns the potentially locale-dependent case mappings of the L</code point
948 argument>.  The mappings may be longer than a single code point (which the basic
949 Unicode case mappings as returned by L</charinfo()> never are).
950
951 If there are no case mappings for the L</code point argument>, or if all three
952 possible mappings (I<lower>, I<title> and I<upper>) result in single code
953 points and are locale independent and unconditional, B<undef> is returned
954 (which means that the case mappings, if any, for the code point are those
955 returned by L</charinfo()>).
956
957 Otherwise, a reference to a hash giving the mappings (or a reference to a hash
958 of such hashes, explained below) is returned with the following keys and their
959 meanings:
960
961 The keys in the bottom layer hash with the meanings of their values are:
962
963 =over
964
965 =item B<code>
966
967 the input L</code point argument> expressed in hexadecimal, with leading zeros
968 added if necessary to make it contain at least four hexdigits
969
970 =item B<lower>
971
972 one or more codes (separated by spaces) that taken in order give the
973 code points for the lower case of I<code>.
974 Each has at least four hexdigits.
975
976 =item B<title>
977
978 one or more codes (separated by spaces) that taken in order give the
979 code points for the title case of I<code>.
980 Each has at least four hexdigits.
981
982 =item B<upper>
983
984 one or more codes (separated by spaces) that taken in order give the
985 code points for the upper case of I<code>.
986 Each has at least four hexdigits.
987
988 =item B<condition>
989
990 the conditions for the mappings to be valid.
991 If B<undef>, the mappings are always valid.
992 When defined, this field is a list of conditions,
993 all of which must be true for the mappings to be valid.
994 The list consists of one or more
995 I<locales> (see below)
996 and/or I<contexts> (explained in the next paragraph),
997 separated by spaces.
998 (Other than as used to separate elements, spaces are to be ignored.)
999 Case distinctions in the condition list are not significant.
1000 Conditions preceded by "NON_" represent the negation of the condition.
1001
1002 A I<context> is one of those defined in the Unicode standard.
1003 For Unicode 5.1, they are defined in Section 3.13 C<Default Case Operations>
1004 available at
1005 L<http://www.unicode.org/versions/Unicode5.1.0/>.
1006 These are for context-sensitive casing.
1007
1008 =back
1009
1010 The hash described above is returned for locale-independent casing, where
1011 at least one of the mappings has length longer than one.  If B<undef> is 
1012 returned, the code point may have mappings, but if so, all are length one,
1013 and are returned by L</charinfo()>.
1014 Note that when this function does return a value, it will be for the complete
1015 set of mappings for a code point, even those whose length is one.
1016
1017 If there are additional casing rules that apply only in certain locales,
1018 an additional key for each will be defined in the returned hash.  Each such key
1019 will be its locale name, defined as a 2-letter ISO 3166 country code, possibly
1020 followed by a "_" and a 2-letter ISO language code (possibly followed by a "_"
1021 and a variant code).  You can find the lists of all possible locales, see
1022 L<Locale::Country> and L<Locale::Language>.
1023 (In Unicode 5.1, the only locales returned by this function
1024 are C<lt>, C<tr>, and C<az>.)
1025
1026 Each locale key is a reference to a hash that has the form above, and gives
1027 the casing rules for that particular locale, which take precedence over the
1028 locale-independent ones when in that locale.
1029
1030 If the only casing for a code point is locale-dependent, then the returned
1031 hash will not have any of the base keys, like C<code>, C<upper>, etc., but
1032 will contain only locale keys.
1033
1034 For more information about case mappings see
1035 L<http://www.unicode.org/unicode/reports/tr21/>
1036
1037 =cut
1038
1039 my %CASESPEC;
1040
1041 sub _casespec {
1042     unless (%CASESPEC) {
1043         if (openunicode(\$CASESPECFH, "SpecialCasing.txt")) {
1044             local $_;
1045             while (<$CASESPECFH>) {
1046                 if (/^([0-9A-F]+); ([0-9A-F]+(?: [0-9A-F]+)*)?; ([0-9A-F]+(?: [0-9A-F]+)*)?; ([0-9A-F]+(?: [0-9A-F]+)*)?; (\w+(?: \w+)*)?/) {
1047                     my ($hexcode, $lower, $title, $upper, $condition) =
1048                         ($1, $2, $3, $4, $5);
1049                     my $code = hex($hexcode);
1050                     if (exists $CASESPEC{$code}) {
1051                         if (exists $CASESPEC{$code}->{code}) {
1052                             my ($oldlower,
1053                                 $oldtitle,
1054                                 $oldupper,
1055                                 $oldcondition) =
1056                                     @{$CASESPEC{$code}}{qw(lower
1057                                                            title
1058                                                            upper
1059                                                            condition)};
1060                             if (defined $oldcondition) {
1061                                 my ($oldlocale) =
1062                                 ($oldcondition =~ /^([a-z][a-z](?:_\S+)?)/);
1063                                 delete $CASESPEC{$code};
1064                                 $CASESPEC{$code}->{$oldlocale} =
1065                                 { code      => $hexcode,
1066                                   lower     => $oldlower,
1067                                   title     => $oldtitle,
1068                                   upper     => $oldupper,
1069                                   condition => $oldcondition };
1070                             }
1071                         }
1072                         my ($locale) =
1073                             ($condition =~ /^([a-z][a-z](?:_\S+)?)/);
1074                         $CASESPEC{$code}->{$locale} =
1075                         { code      => $hexcode,
1076                           lower     => $lower,
1077                           title     => $title,
1078                           upper     => $upper,
1079                           condition => $condition };
1080                     } else {
1081                         $CASESPEC{$code} =
1082                         { code      => $hexcode,
1083                           lower     => $lower,
1084                           title     => $title,
1085                           upper     => $upper,
1086                           condition => $condition };
1087                     }
1088                 }
1089             }
1090             close($CASESPECFH);
1091         }
1092     }
1093 }
1094
1095 sub casespec {
1096     my $arg  = shift;
1097     my $code = _getcode($arg);
1098     croak __PACKAGE__, "::casespec: unknown code '$arg'"
1099         unless defined $code;
1100
1101     _casespec() unless %CASESPEC;
1102
1103     return ref $CASESPEC{$code} ? dclone $CASESPEC{$code} : $CASESPEC{$code};
1104 }
1105
1106 =head2 B<namedseq()>
1107
1108     use Unicode::UCD 'namedseq';
1109
1110     my $namedseq = namedseq("KATAKANA LETTER AINU P");
1111     my @namedseq = namedseq("KATAKANA LETTER AINU P");
1112     my %namedseq = namedseq();
1113
1114 If used with a single argument in a scalar context, returns the string
1115 consisting of the code points of the named sequence, or B<undef> if no
1116 named sequence by that name exists.  If used with a single argument in
1117 a list context, it returns the list of the ordinals of the code points.  If used
1118 with no
1119 arguments in a list context, returns a hash with the names of the
1120 named sequences as the keys and the named sequences as strings as
1121 the values.  Otherwise, it returns B<undef> or an empty list depending
1122 on the context.
1123
1124 This function only operates on officially approved (not provisional) named
1125 sequences.
1126
1127 =cut
1128
1129 my %NAMEDSEQ;
1130
1131 sub _namedseq {
1132     unless (%NAMEDSEQ) {
1133         if (openunicode(\$NAMEDSEQFH, "Name.pl")) {
1134             local $_;
1135             while (<$NAMEDSEQFH>) {
1136                 if (/^ [0-9A-F]+ \  /x) {
1137                     chomp;
1138                     my ($sequence, $name) = split /\t/;
1139                     my @s = map { chr(hex($_)) } split(' ', $sequence);
1140                     $NAMEDSEQ{$name} = join("", @s);
1141                 }
1142             }
1143             close($NAMEDSEQFH);
1144         }
1145     }
1146 }
1147
1148 sub namedseq {
1149
1150     # Use charnames::string_vianame() which now returns this information,
1151     # unless the caller wants the hash returned, in which case we read it in,
1152     # and thereafter use it instead of calling charnames, as it is faster.
1153
1154     my $wantarray = wantarray();
1155     if (defined $wantarray) {
1156         if ($wantarray) {
1157             if (@_ == 0) {
1158                 _namedseq() unless %NAMEDSEQ;
1159                 return %NAMEDSEQ;
1160             } elsif (@_ == 1) {
1161                 my $s;
1162                 if (%NAMEDSEQ) {
1163                     $s = $NAMEDSEQ{ $_[0] };
1164                 }
1165                 else {
1166                     $s = charnames::string_vianame($_[0]);
1167                 }
1168                 return defined $s ? map { ord($_) } split('', $s) : ();
1169             }
1170         } elsif (@_ == 1) {
1171             return $NAMEDSEQ{ $_[0] } if %NAMEDSEQ;
1172             return charnames::string_vianame($_[0]);
1173         }
1174     }
1175     return;
1176 }
1177
1178 =head2 Unicode::UCD::UnicodeVersion
1179
1180 This returns the version of the Unicode Character Database, in other words, the
1181 version of the Unicode standard the database implements.  The version is a
1182 string of numbers delimited by dots (C<'.'>).
1183
1184 =cut
1185
1186 my $UNICODEVERSION;
1187
1188 sub UnicodeVersion {
1189     unless (defined $UNICODEVERSION) {
1190         openunicode(\$VERSIONFH, "version");
1191         chomp($UNICODEVERSION = <$VERSIONFH>);
1192         close($VERSIONFH);
1193         croak __PACKAGE__, "::VERSION: strange version '$UNICODEVERSION'"
1194             unless $UNICODEVERSION =~ /^\d+(?:\.\d+)+$/;
1195     }
1196     return $UNICODEVERSION;
1197 }
1198
1199 =head2 B<Blocks versus Scripts>
1200
1201 The difference between a block and a script is that scripts are closer
1202 to the linguistic notion of a set of code points required to present
1203 languages, while block is more of an artifact of the Unicode code point
1204 numbering and separation into blocks of (mostly) 256 code points.
1205
1206 For example the Latin B<script> is spread over several B<blocks>, such
1207 as C<Basic Latin>, C<Latin 1 Supplement>, C<Latin Extended-A>, and
1208 C<Latin Extended-B>.  On the other hand, the Latin script does not
1209 contain all the characters of the C<Basic Latin> block (also known as
1210 ASCII): it includes only the letters, and not, for example, the digits
1211 or the punctuation.
1212
1213 For blocks see L<http://www.unicode.org/Public/UNIDATA/Blocks.txt>
1214
1215 For scripts see UTR #24: L<http://www.unicode.org/unicode/reports/tr24/>
1216
1217 =head2 B<Matching Scripts and Blocks>
1218
1219 Scripts are matched with the regular-expression construct
1220 C<\p{...}> (e.g. C<\p{Tibetan}> matches characters of the Tibetan script),
1221 while C<\p{In...}> is used for blocks (e.g. C<\p{InTibetan}> matches
1222 any of the 256 code points in the Tibetan block).
1223
1224
1225 =head2 Implementation Note
1226
1227 The first use of charinfo() opens a read-only filehandle to the Unicode
1228 Character Database (the database is included in the Perl distribution).
1229 The filehandle is then kept open for further queries.  In other words,
1230 if you are wondering where one of your filehandles went, that's where.
1231
1232 =head1 BUGS
1233
1234 Does not yet support EBCDIC platforms.
1235
1236 L</compexcl()> should give a complete list of excluded code points.
1237
1238 =head1 AUTHOR
1239
1240 Jarkko Hietaniemi
1241
1242 =cut
1243
1244 1;