X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FUnicode%2FUCD.pm;h=96dee9a8164c03ecfbc0b8f3b4c98b2e9f36ab80;hb=cd340a5d1de2dbc931e802b4aaed98e9e4d75f51;hp=ff819cde1a14084fca86903307fcdf29b21f9881;hpb=10a6ecd25e80ad20ebf67b311125411d51e78bc0;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/lib/Unicode/UCD.pm b/lib/Unicode/UCD.pm
index ff819cd..96dee9a 100644
--- a/lib/Unicode/UCD.pm
+++ b/lib/Unicode/UCD.pm
@@ -3,15 +3,18 @@ package Unicode::UCD;
 use strict;
 use warnings;
 
-our $VERSION = '0.1';
+our $VERSION = '0.2';
 
 require Exporter;
 
 our @ISA = qw(Exporter);
+
 our @EXPORT_OK = qw(charinfo
 		    charblock charscript
 		    charblocks charscripts
-		    charinrange);
+		    charinrange
+		    compexcl
+		    casefold casespec);
 
 use Carp;
 
@@ -22,7 +25,7 @@ Unicode::UCD - Unicode character database
 =head1 SYNOPSIS
 
     use Unicode::UCD 'charinfo';
-    my %charinfo   = charinfo($codepoint);
+    my $charinfo   = charinfo($codepoint);
 
     use Unicode::UCD 'charblock';
     my $charblock  = charblock($codepoint);
@@ -30,10 +33,25 @@ Unicode::UCD - Unicode character database
     use Unicode::UCD 'charscript';
     my $charscript = charblock($codepoint);
 
+    use Unicode::UCD 'charblocks';
+    my $charblocks = charblocks();
+
+    use Unicode::UCD 'charscripts';
+    my %charscripts = charscripts();
+
+    use Unicode::UCD qw(charscript charinrange);
+    my $range = charscript($script);
+    print "looks like $script\n" if charinrange($range, $codepoint);
+
+    use Unicode::UCD 'compexcl';
+    my $compexcl = compexcl($codepoint);
+
+    my $unicode_version = Unicode::UCD::UnicodeVersion();
+
 =head1 DESCRIPTION
 
-The Unicode module offers a simple interface to the Unicode Character
-Database.
+The Unicode::UCD module offers a simple interface to the Unicode
+Character Database.
 
 =cut
 
@@ -41,6 +59,9 @@ my $UNICODEFH;
 my $BLOCKSFH;
 my $SCRIPTSFH;
 my $VERSIONFH;
+my $COMPEXCLFH;
+my $CASEFOLDFH;
+my $CASESPECFH;
 
 sub openunicode {
     my ($rfh, @path) = @_;
@@ -48,7 +69,7 @@ sub openunicode {
     unless (defined $$rfh) {
 	for my $d (@INC) {
 	    use File::Spec;
-	    $f = File::Spec->catfile($d, "unicode", @path);
+	    $f = File::Spec->catfile($d, "unicore", @path);
 	    last if open($$rfh, $f);
 	    undef $f;
 	}
@@ -63,10 +84,10 @@ sub openunicode {
 
     use Unicode::UCD 'charinfo';
 
-    my %charinfo = charinfo(0x41);
+    my $charinfo = charinfo(0x41);
 
-charinfo() returns a hash that has the following fields as defined
-by the Unicode standard:
+charinfo() returns a reference to a hash that has the following fields
+as defined by the Unicode standard:
 
     key
 
@@ -87,20 +108,18 @@ by the Unicode standard:
     title            titlecase equivalent mapping
 
     block            block the character belongs to (used in \p{In...})
-    script           script the character belongs to 
+    script           script the character belongs to
 
-If no match is found, an empty hash is returned.
+If no match is found, a reference to an empty hash is returned.
 
-The C<block> property is the same as as returned by charinfo().  It is
+The C<block> property is the same as returned by charinfo().  It is
 not defined in the Unicode Character Database proper (Chapter 4 of the
-Unicode 3.0 Standard) but instead in an auxiliary database (Chapter 14
-of TUS3).  Similarly for the C<script> property.
+Unicode 3.0 Standard, aka TUS3) but instead in an auxiliary database
+(Chapter 14 of TUS3).  Similarly for the C<script> property.
 
 Note that you cannot do (de)composition and casing based solely on the
 above C<decomposition> and C<lower>, C<upper>, C<title>, properties,
-you will need also the I<Composition Exclusions>, I<Case Folding>, and
-I<SpecialCasing> tables, available as files F<CompExcl.txt>,
-F<CaseFold.txt>, and F<SpecCase.txt> in the Perl distribution.
+you will need also the compexcl(), casefold(), and casespec() functions.
 
 =cut
 
@@ -116,17 +135,79 @@ sub _getcode {
     return;
 }
 
+# Lingua::KO::Hangul::Util not part of the standard distribution
+# but it will be used if available.
+
+eval { require Lingua::KO::Hangul::Util };
+my $hasHangulUtil = ! $@;
+if ($hasHangulUtil) {
+    Lingua::KO::Hangul::Util->import();
+}
+
+sub hangul_decomp { # internal: called from charinfo
+    if ($hasHangulUtil) {
+	my @tmp = decomposeHangul(shift);
+	return sprintf("%04X %04X",      @tmp) if @tmp == 2;
+	return sprintf("%04X %04X %04X", @tmp) if @tmp == 3;
+    }
+    return;
+}
+
+sub hangul_charname { # internal: called from charinfo
+    return sprintf("HANGUL SYLLABLE-%04X", shift);
+}
+
+sub han_charname { # internal: called from charinfo
+    return sprintf("CJK UNIFIED IDEOGRAPH-%04X", shift);
+}
+
+my @CharinfoRanges = (
+# block name
+# [ first, last, coderef to name, coderef to decompose ],
+# CJK Ideographs Extension A
+  [ 0x3400,   0x4DB5,   \&han_charname,   undef  ],
+# CJK Ideographs
+  [ 0x4E00,   0x9FA5,   \&han_charname,   undef  ],
+# Hangul Syllables
+  [ 0xAC00,   0xD7A3,   $hasHangulUtil ? \&getHangulName : \&hangul_charname,  \&hangul_decomp ],
+# Non-Private Use High Surrogates
+  [ 0xD800,   0xDB7F,   undef,   undef  ],
+# Private Use High Surrogates
+  [ 0xDB80,   0xDBFF,   undef,   undef  ],
+# Low Surrogates
+  [ 0xDC00,   0xDFFF,   undef,   undef  ],
+# The Private Use Area
+  [ 0xE000,   0xF8FF,   undef,   undef  ],
+# CJK Ideographs Extension B
+  [ 0x20000,  0x2A6D6,  \&han_charname,   undef  ],
+# Plane 15 Private Use Area
+  [ 0xF0000,  0xFFFFD,  undef,   undef  ],
+# Plane 16 Private Use Area
+  [ 0x100000, 0x10FFFD, undef,   undef  ],
+);
+
 sub charinfo {
     my $arg  = shift;
     my $code = _getcode($arg);
     croak __PACKAGE__, "::charinfo: unknown code '$arg'"
 	unless defined $code;
-    my $hexk = sprintf("%04X", $code);
-
-    openunicode(\$UNICODEFH, "Unicode.txt");
+    my $hexk = sprintf("%06X", $code);
+    my($rcode,$rname,$rdec);
+    foreach my $range (@CharinfoRanges){
+      if ($range->[0] <= $code && $code <= $range->[1]) {
+        $rcode = $hexk;
+	$rcode =~ s/^0+//;
+	$rcode =  sprintf("%04X", hex($rcode));
+        $rname = $range->[2] ? $range->[2]->($code) : '';
+        $rdec  = $range->[3] ? $range->[3]->($code) : '';
+        $hexk  = sprintf("%06X", $range->[0]); # replace by the first
+        last;
+      }
+    }
+    openunicode(\$UNICODEFH, "UnicodeData.txt");
     if (defined $UNICODEFH) {
-	use Search::Dict;
-	if (look($UNICODEFH, "$hexk;") >= 0) {
+	use Search::Dict 1.02;
+	if (look($UNICODEFH, "$hexk;", { xfrm => sub { $_[0] =~ /^([^;]+);(.+)/; sprintf "%06X;$2", hex($1) } } ) >= 0) {
 	    my $line = <$UNICODEFH>;
 	    chomp $line;
 	    my %prop;
@@ -137,10 +218,17 @@ sub charinfo {
 		     mirrored unicode10 comment
 		     upper lower title
 		    )} = split(/;/, $line, -1);
+	    $hexk =~ s/^0+//;
+	    $hexk =  sprintf("%04X", hex($hexk));
 	    if ($prop{code} eq $hexk) {
 		$prop{block}  = charblock($code);
 		$prop{script} = charscript($code);
-		return %prop;
+		if(defined $rname){
+                    $prop{code} = $rcode;
+                    $prop{name} = $rname;
+                    $prop{decomposition} = $rdec;
+                }
+		return \%prop;
 	    }
 	}
     }
@@ -184,21 +272,20 @@ sub charinrange {
     my $charblock = charblock("0x263a");
     my $charblock = charblock("U+263a");
 
-    my $ranges    = charblock('Armenian');
+    my $range     = charblock('Armenian');
 
-With a B<code point argument> charblock() returns the block the character
+With a B<code point argument> charblock() returns the I<block> the character
 belongs to, e.g.  C<Basic Latin>.  Note that not all the character
-positions within all blocks are defined.  A <code point argument>
-is either a decimal or a hexadecimal scalar, or "U+" followed
-by hexadecimals.
-
-If supplied with an argument that can't be a code point, charblock()
-tries to do the opposite and interpret the argument as a character
-block.  The return value is a I<range>: an anonymous list that
-contains anonymous lists, which in turn contain I<start-of-range>,
-I<end-of-range> code point pairs.  You can test whether a code point
-is in a range using the L</charinrange> function.  If the argument is
-not a known charater block, C<undef> is returned.
+positions within all blocks are defined.
+
+See also L</Blocks versus Scripts>.
+
+If supplied with an argument that can't be a code point, charblock() tries
+to do the opposite and interpret the argument as a character block. The
+return value is a I<range>: an anonymous list of lists that contain
+I<start-of-range>, I<end-of-range> code point pairs. You can test whether a
+code point is in a range using the L</charinrange> function. If the
+argument is not a known charater block, C<undef> is returned.
 
 =cut
 
@@ -247,20 +334,19 @@ sub charblock {
     my $charscript = charscript(1234);
     my $charscript = charscript("U+263a");
 
-    my $ranges     = charscript('Thai');
+    my $range      = charscript('Thai');
 
-With a B<code point argument> charscript() returns the script the
-character belongs to, e.g.  C<Latin>, C<Greek>, C<Han>.  A <code point
-argument> is either a decimal or a hexadecimal scalar, or "U+"
-followed by hexadecimals.
+With a B<code point argument> charscript() returns the I<script> the
+character belongs to, e.g.  C<Latin>, C<Greek>, C<Han>.
 
-If supplied with an argument that can't be a code point, charscript()
-tries to do the opposite and interpret the argument as a character
-script.  The return value is a I<range>: an anonymous list that
-contains anonymous lists, which in turn contain I<start-of-range>,
-I<end-of-range> code point pairs.  You can test whether a code point
-is in a range using the L</charinrange> function.  If the argument is
-not a known charater script, C<undef> is returned.
+See also L</Blocks versus Scripts>.
+
+If supplied with an argument that can't be a code point, charscript() tries
+to do the opposite and interpret the argument as a character script. The
+return value is a I<range>: an anonymous list of lists that contain
+I<start-of-range>, I<end-of-range> code point pairs. You can test whether a
+code point is in a range using the L</charinrange> function. If the
+argument is not a known charater script, C<undef> is returned.
 
 =cut
 
@@ -308,16 +394,18 @@ sub charscript {
 
     use Unicode::UCD 'charblocks';
 
-    my %charblocks = charblocks();
+    my $charblocks = charblocks();
+
+charblocks() returns a reference to a hash with the known block names
+as the keys, and the code point ranges (see L</charblock>) as the values.
 
-charblocks() returns a hash with the known block names as the keys,
-and the code point ranges (see L</charblock>) as the values.
+See also L</Blocks versus Scripts>.
 
 =cut
 
 sub charblocks {
-    _charblocks() unless @BLOCKS;
-    return %BLOCKS;
+    _charblocks() unless %BLOCKS;
+    return \%BLOCKS;
 }
 
 =head2 charscripts
@@ -329,11 +417,13 @@ sub charblocks {
 charscripts() returns a hash with the known script names as the keys,
 and the code point ranges (see L</charscript>) as the values.
 
+See also L</Blocks versus Scripts>.
+
 =cut
 
 sub charscripts {
-    _charscripts() unless @SCRIPTS;
-    return %SCRIPTS;
+    _charscripts() unless %SCRIPTS;
+    return \%SCRIPTS;
 }
 
 =head2 Blocks versus Scripts
@@ -341,13 +431,13 @@ sub charscripts {
 The difference between a block and a script is that scripts are closer
 to the linguistic notion of a set of characters required to present
 languages, while block is more of an artifact of the Unicode character
-numbering and separation into blocks of 256 characters.
+numbering and separation into blocks of (mostly) 256 characters.
 
 For example the Latin B<script> is spread over several B<blocks>, such
 as C<Basic Latin>, C<Latin 1 Supplement>, C<Latin Extended-A>, and
 C<Latin Extended-B>.  On the other hand, the Latin script does not
 contain all the characters of the C<Basic Latin> block (also known as
-the ASCII): it includes only the letters, not for example the digits
+the ASCII): it includes only the letters, and not, for example, the digits
 or the punctuation.
 
 For blocks see http://www.unicode.org/Public/UNIDATA/Blocks.txt
@@ -356,37 +446,270 @@ For scripts see UTR #24: http://www.unicode.org/unicode/reports/tr24/
 
 =head2 Matching Scripts and Blocks
 
-Both scripts and blocks can be matched using the regular expression
-construct C<\p{In...}> and its negation C<\P{In...}>.
+Scripts are matched with the regular-expression construct
+C<\p{...}> (e.g. C<\p{Tibetan}> matches characters of the Tibetan script),
+while C<\p{In...}> is used for blocks (e.g. C<\p{InTibetan}> matches
+any of the 256 code points in the Tibetan block).
 
-The name of the script or the block comes after the C<In>, for example
-C<\p{InCyrillic}>, C<\P{InBasicLatin}>.  Spaces and dashes ('-') are
-removed from the names for the C<\p{In...}>, for example
-C<LatinExtendedA> instead of C<Latin Extended-A>.
+=head2 Code Point Arguments
 
-There are a few cases where there exists both a script and a block by
-the same name, in these cases the block version has C<Block> appended:
-C<\p{InKatakana}> is the script, C<\p{InKatakanaBlock}> is the block.
+A I<code point argument> is either a decimal or a hexadecimal scalar
+designating a Unicode character, or C<U+> followed by hexadecimals
+designating a Unicode character.  Note that Unicode is B<not> limited
+to 16 bits (the number of Unicode characters is open-ended, in theory
+unlimited): you may have more than 4 hexdigits.
 
 =head2 charinrange
 
 In addition to using the C<\p{In...}> and C<\P{In...}> constructs, you
 can also test whether a code point is in the I<range> as returned by
 L</charblock> and L</charscript> or as the values of the hash returned
-by L</charblocks> and </charscripts> by using charinrange():
+by L</charblocks> and L</charscripts> by using charinrange():
 
     use Unicode::UCD qw(charscript charinrange);
 
     $range = charscript('Hiragana');
-    print "looks like hiragana\n" if charinrange($range, $code);
+    print "looks like hiragana\n" if charinrange($range, $codepoint);
+
+=cut
+
+=head2 compexcl
+
+    use Unicode::UCD 'compexcl';
+
+    my $compexcl = compexcl("09dc");
+
+The compexcl() returns the composition exclusion (that is, if the
+character should not be produced during a precomposition) of the 
+character specified by a B<code point argument>.
+
+If there is a composition exclusion for the character, true is
+returned.  Otherwise, false is returned.
+
+=cut
+
+my %COMPEXCL;
+
+sub _compexcl {
+    unless (%COMPEXCL) {
+	if (openunicode(\$COMPEXCLFH, "CompositionExclusions.txt")) {
+	    while (<$COMPEXCLFH>) {
+		if (/^([0-9A-F]+)\s+\#\s+/) {
+		    my $code = hex($1);
+		    $COMPEXCL{$code} = undef;
+		}
+	    }
+	    close($COMPEXCLFH);
+	}
+    }
+}
+
+sub compexcl {
+    my $arg  = shift;
+    my $code = _getcode($arg);
+    croak __PACKAGE__, "::compexcl: unknown code '$arg'"
+	unless defined $code;
+
+    _compexcl() unless %COMPEXCL;
+
+    return exists $COMPEXCL{$code};
+}
+
+=head2 casefold
+
+    use Unicode::UCD 'casefold';
+
+    my %casefold = casefold("09dc");
+
+The casefold() returns the locale-independent case folding of the
+character specified by a B<code point argument>.
+
+If there is a case folding for that character, a reference to a hash
+with the following fields is returned:
+
+    key
+
+    code             code point with at least four hexdigits
+    status           "C", "F", "S", or "I"
+    mapping          one or more codes separated by spaces
+
+The meaning of the I<status> is as follows:
+
+   C                 common case folding, common mappings shared
+                     by both simple and full mappings
+   F                 full case folding, mappings that cause strings
+                     to grow in length. Multiple characters are separated
+                     by spaces
+   S                 simple case folding, mappings to single characters
+                     where different from F
+   I                 special case for dotted uppercase I and
+                     dotless lowercase i
+                     - If this mapping is included, the result is
+                       case-insensitive, but dotless and dotted I's
+                       are not distinguished
+                     - If this mapping is excluded, the result is not
+                       fully case-insensitive, but dotless and dotted
+                       I's are distinguished
+
+If there is no case folding for that character, C<undef> is returned.
+
+For more information about case mappings see
+http://www.unicode.org/unicode/reports/tr21/
 
 =cut
 
+my %CASEFOLD;
+
+sub _casefold {
+    unless (%CASEFOLD) {
+	if (openunicode(\$CASEFOLDFH, "CaseFolding.txt")) {
+	    while (<$CASEFOLDFH>) {
+		if (/^([0-9A-F]+); ([CFSI]); ([0-9A-F]+(?: [0-9A-F]+)*);/) {
+		    my $code = hex($1);
+		    $CASEFOLD{$code} = { code    => $1,
+					 status  => $2,
+					 mapping => $3 };
+		}
+	    }
+	    close($CASEFOLDFH);
+	}
+    }
+}
+
+sub casefold {
+    my $arg  = shift;
+    my $code = _getcode($arg);
+    croak __PACKAGE__, "::casefold: unknown code '$arg'"
+	unless defined $code;
+
+    _casefold() unless %CASEFOLD;
+
+    return $CASEFOLD{$code};
+}
+
+=head2 casespec
+
+    use Unicode::UCD 'casespec';
+
+    my %casespec = casespec("09dc");
+
+The casespec() returns the potentially locale-dependent case mapping
+of the character specified by a B<code point argument>.  The mapping
+may change the length of the string (which the basic Unicode case
+mappings as returned by charinfo() never do).
+
+If there is a case folding for that character, a reference to a hash
+with the following fields is returned:
+
+    key
+
+    code             code point with at least four hexdigits
+    lower            lowercase
+    title            titlecase
+    upper            uppercase
+    condition        condition list (may be undef)
+
+The C<condition> is optional.  Where present, it consists of one or
+more I<locales> or I<contexts>, separated by spaces (other than as
+used to separate elements, spaces are to be ignored).  A condition
+list overrides the normal behavior if all of the listed conditions are
+true.  Case distinctions in the condition list are not significant.
+Conditions preceded by "NON_" represent the negation of the condition
+
+Note that when there are multiple case folding definitions for a
+single code point because of different locales, the value returned by
+casespec() is a hash reference which has the locales as the keys and
+hash references as described above as the values.
+
+A I<locale> is defined as a 2-letter ISO 3166 country code, possibly
+followed by a "_" and a 2-letter ISO language code (possibly followed
+by a "_" and a variant code).  You can find the lists of those codes,
+see L<Locale::Country> and L<Locale::Language>.
+
+A I<context> is one of the following choices:
+
+    FINAL            The letter is not followed by a letter of
+                     general category L (e.g. Ll, Lt, Lu, Lm, or Lo)
+    MODERN           The mapping is only used for modern text
+    AFTER_i          The last base character was "i" (U+0069)
+
+For more information about case mappings see
+http://www.unicode.org/unicode/reports/tr21/
+
+=cut
+
+my %CASESPEC;
+
+sub _casespec {
+    unless (%CASESPEC) {
+	if (openunicode(\$CASESPECFH, "SpecialCasing.txt")) {
+	    while (<$CASESPECFH>) {
+		if (/^([0-9A-F]+); ([0-9A-F]+(?: [0-9A-F]+)*)?; ([0-9A-F]+(?: [0-9A-F]+)*)?; ([0-9A-F]+(?: [0-9A-F]+)*)?; (\w+(?: \w+)*)?/) {
+		    my ($hexcode, $lower, $title, $upper, $condition) =
+			($1, $2, $3, $4, $5);
+		    my $code = hex($hexcode);
+		    if (exists $CASESPEC{$code}) {
+			if (exists $CASESPEC{$code}->{code}) {
+			    my ($oldlower,
+				$oldtitle,
+				$oldupper,
+				$oldcondition) =
+				    @{$CASESPEC{$code}}{qw(lower
+							   title
+							   upper
+							   condition)};
+			    if (defined $oldcondition) {
+				my ($oldlocale) =
+				($oldcondition =~ /^([a-z][a-z](?:_\S+)?)/);
+				delete $CASESPEC{$code};
+				$CASESPEC{$code}->{$oldlocale} =
+				{ code      => $hexcode,
+				  lower     => $oldlower,
+				  title     => $oldtitle,
+				  upper     => $oldupper,
+				  condition => $oldcondition };
+			    }
+			}
+			my ($locale) =
+			    ($condition =~ /^([a-z][a-z](?:_\S+)?)/);
+			$CASESPEC{$code}->{$locale} =
+			{ code      => $hexcode,
+			  lower     => $lower,
+			  title     => $title,
+			  upper     => $upper,
+			  condition => $condition };
+		    } else {
+			$CASESPEC{$code} =
+			{ code      => $hexcode,
+			  lower     => $lower,
+			  title     => $title,
+			  upper     => $upper,
+			  condition => $condition };
+		    }
+		}
+	    }
+	    close($CASESPECFH);
+	}
+    }
+}
+
+sub casespec {
+    my $arg  = shift;
+    my $code = _getcode($arg);
+    croak __PACKAGE__, "::casespec: unknown code '$arg'"
+	unless defined $code;
+
+    _casespec() unless %CASESPEC;
+
+    return $CASESPEC{$code};
+}
+
 =head2 Unicode::UCD::UnicodeVersion
 
-Unicode::UCD::UnicodeVersion() returns the version of the Unicode Character
-Database, in other words, the version of the Unicode standard the
-database implements.
+Unicode::UCD::UnicodeVersion() returns the version of the Unicode
+Character Database, in other words, the version of the Unicode
+standard the database implements.  The version is a string
+of numbers delimited by dots (C<'.'>).
 
 =cut
 
@@ -407,7 +730,12 @@ sub UnicodeVersion {
 
 The first use of charinfo() opens a read-only filehandle to the Unicode
 Character Database (the database is included in the Perl distribution).
-The filehandle is then kept open for further queries.
+The filehandle is then kept open for further queries.  In other words,
+if you are wondering where one of your filehandles went, that's where.
+
+=head1 BUGS
+
+Does not yet support EBCDIC platforms.
 
 =head1 AUTHOR