X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FUnicode%2FUCD.pm;h=1496663c5495a73f0f119efc9ccf8799267e8a1d;hb=06c0cc96ebd866767a6d107ed78967600f7e0395;hp=0aaccd0c238652d2fdd07d867e603f3e485bb731;hpb=ac5ea53171baa7dab1a92df1eacf8d2fe19cbdbb;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/lib/Unicode/UCD.pm b/lib/Unicode/UCD.pm
index 0aaccd0..1496663 100644
--- a/lib/Unicode/UCD.pm
+++ b/lib/Unicode/UCD.pm
@@ -3,7 +3,9 @@ package Unicode::UCD;
 use strict;
 use warnings;
 
-our $VERSION = '0.2';
+our $VERSION = '0.23';
+
+use Storable qw(dclone);
 
 require Exporter;
 
@@ -14,7 +16,8 @@ our @EXPORT_OK = qw(charinfo
 		    charblocks charscripts
 		    charinrange
 		    compexcl
-		    casefold casespec);
+		    casefold casespec
+		    namedseq);
 
 use Carp;
 
@@ -31,7 +34,7 @@ Unicode::UCD - Unicode character database
     my $charblock  = charblock($codepoint);
 
     use Unicode::UCD 'charscript';
-    my $charscript = charblock($codepoint);
+    my $charscript = charscript($codepoint);
 
     use Unicode::UCD 'charblocks';
     my $charblocks = charblocks();
@@ -46,6 +49,9 @@ Unicode::UCD - Unicode character database
     use Unicode::UCD 'compexcl';
     my $compexcl = compexcl($codepoint);
 
+    use Unicode::UCD 'namedseq';
+    my $namedseq = namedseq($named_sequence_name);
+
     my $unicode_version = Unicode::UCD::UnicodeVersion();
 
 =head1 DESCRIPTION
@@ -62,6 +68,7 @@ my $VERSIONFH;
 my $COMPEXCLFH;
 my $CASEFOLDFH;
 my $CASESPECFH;
+my $NAMEDSEQFH;
 
 sub openunicode {
     my ($rfh, @path) = @_;
@@ -108,11 +115,11 @@ as defined 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, 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, aka TUS3) but instead in an auxiliary database
 (Chapter 14 of TUS3).  Similarly for the C<script> property.
@@ -123,12 +130,13 @@ you will need also the compexcl(), casefold(), and casespec() functions.
 
 =cut
 
+# NB: This function is duplicated in charnames.pm
 sub _getcode {
     my $arg = shift;
 
-    if ($arg =~ /^\d+$/) {
+    if ($arg =~ /^[1-9]\d*$/) {
 	return $arg;
-    } elsif ($arg =~ /^(?:U\+|0x)?([[:xdigit:]]+)$/) {
+    } elsif ($arg =~ /^(?:[Uu]\+|0[xX])?([[:xdigit:]]+)$/) {
 	return hex($1);
     }
 
@@ -204,11 +212,12 @@ sub charinfo {
         last;
       }
     }
-    openunicode(\$UNICODEFH, "Unicode.txt");
+    openunicode(\$UNICODEFH, "UnicodeData.txt");
     if (defined $UNICODEFH) {
 	use Search::Dict 1.02;
 	if (look($UNICODEFH, "$hexk;", { xfrm => sub { $_[0] =~ /^([^;]+);(.+)/; sprintf "%06X;$2", hex($1) } } ) >= 0) {
 	    my $line = <$UNICODEFH>;
+	    return unless defined $line;
 	    chomp $line;
 	    my %prop;
 	    @prop{qw(
@@ -280,13 +289,12 @@ 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 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.
+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 character block, C<undef> is returned.
 
 =cut
 
@@ -296,6 +304,7 @@ my %BLOCKS;
 sub _charblocks {
     unless (@BLOCKS) {
 	if (openunicode(\$BLOCKSFH, "Blocks.txt")) {
+	    local $_;
 	    while (<$BLOCKSFH>) {
 		if (/^([0-9A-F]+)\.\.([0-9A-F]+);\s+(.+)/) {
 		    my ($lo, $hi) = (hex($1), hex($2));
@@ -320,7 +329,7 @@ sub charblock {
 	_search(\@BLOCKS, 0, $#BLOCKS, $code);
     } else {
 	if (exists $BLOCKS{$arg}) {
-	    return $BLOCKS{$arg};
+	    return dclone $BLOCKS{$arg};
 	} else {
 	    return;
 	}
@@ -342,13 +351,12 @@ character belongs to, e.g.  C<Latin>, C<Greek>, C<Han>.
 
 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 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.
+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 character script, C<undef> is returned.
 
 =cut
 
@@ -358,6 +366,7 @@ my %SCRIPTS;
 sub _charscripts {
     unless (@SCRIPTS) {
 	if (openunicode(\$SCRIPTSFH, "Scripts.txt")) {
+	    local $_;
 	    while (<$SCRIPTSFH>) {
 		if (/^([0-9A-F]+)(?:\.\.([0-9A-F]+))?\s+;\s+(\w+)/) {
 		    my ($lo, $hi) = (hex($1), $2 ? hex($2) : hex($1));
@@ -385,7 +394,7 @@ sub charscript {
 	_search(\@SCRIPTS, 0, $#SCRIPTS, $code);
     } else {
 	if (exists $SCRIPTS{$arg}) {
-	    return $SCRIPTS{$arg};
+	    return dclone $SCRIPTS{$arg};
 	} else {
 	    return;
 	}
@@ -407,7 +416,7 @@ See also L</Blocks versus Scripts>.
 
 sub charblocks {
     _charblocks() unless %BLOCKS;
-    return \%BLOCKS;
+    return dclone \%BLOCKS;
 }
 
 =head2 charscripts
@@ -425,7 +434,7 @@ See also L</Blocks versus Scripts>.
 
 sub charscripts {
     _charscripts() unless %SCRIPTS;
-    return \%SCRIPTS;
+    return dclone \%SCRIPTS;
 }
 
 =head2 Blocks versus Scripts
@@ -433,13 +442,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
@@ -448,26 +457,21 @@ 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...}>.
-
-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>.
-
-There are a few cases where there is both a script and a block by the
-same name, in these cases the block version has C<Block> appended to
-its name: C<\p{InKatakana}> is the script, C<\p{InKatakanaBlock}> is
-the block.
+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).
 
 =head2 Code Point Arguments
 
-A <code point argument> is either a decimal or a hexadecimal scalar
-designating a Unicode character, or "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.
+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.  In other words, if you want a code
+point to be interpreted as a hexadecimal number, you must prefix it
+with either C<0x> or C<U+>, because a string like e.g. C<123> will
+be interpreted as a decimal code point.  Also 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
 
@@ -502,9 +506,10 @@ my %COMPEXCL;
 
 sub _compexcl {
     unless (%COMPEXCL) {
-	if (openunicode(\$COMPEXCLFH, "CompExcl.txt")) {
+	if (openunicode(\$COMPEXCLFH, "CompositionExclusions.txt")) {
+	    local $_;
 	    while (<$COMPEXCLFH>) {
-		if (/^([0-9A-F]+) \# /) {
+		if (/^([0-9A-F]+)\s+\#\s+/) {
 		    my $code = hex($1);
 		    $COMPEXCL{$code} = undef;
 		}
@@ -529,7 +534,7 @@ sub compexcl {
 
     use Unicode::UCD 'casefold';
 
-    my %casefold = casefold("09dc");
+    my $casefold = casefold("00DF");
 
 The casefold() returns the locale-independent case folding of the
 character specified by a B<code point argument>.
@@ -572,7 +577,8 @@ my %CASEFOLD;
 
 sub _casefold {
     unless (%CASEFOLD) {
-	if (openunicode(\$CASEFOLDFH, "CaseFold.txt")) {
+	if (openunicode(\$CASEFOLDFH, "CaseFolding.txt")) {
+	    local $_;
 	    while (<$CASEFOLDFH>) {
 		if (/^([0-9A-F]+); ([CFSI]); ([0-9A-F]+(?: [0-9A-F]+)*);/) {
 		    my $code = hex($1);
@@ -601,7 +607,7 @@ sub casefold {
 
     use Unicode::UCD 'casespec';
 
-    my %casespec = casespec("09dc");
+    my $casespec = casespec("FB00");
 
 The casespec() returns the potentially locale-dependent case mapping
 of the character specified by a B<code point argument>.  The mapping
@@ -624,7 +630,7 @@ 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
+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
@@ -652,7 +658,8 @@ my %CASESPEC;
 
 sub _casespec {
     unless (%CASESPEC) {
-	if (openunicode(\$CASESPECFH, "SpecCase.txt")) {
+	if (openunicode(\$CASESPECFH, "SpecialCasing.txt")) {
+	    local $_;
 	    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) =
@@ -668,9 +675,9 @@ sub _casespec {
 							   title
 							   upper
 							   condition)};
-			    my ($oldlocale) =
+			    if (defined $oldcondition) {
+				my ($oldlocale) =
 				($oldcondition =~ /^([a-z][a-z](?:_\S+)?)/);
-			    if (defined $oldlocale) {
 				delete $CASESPEC{$code};
 				$CASESPEC{$code}->{$oldlocale} =
 				{ code      => $hexcode,
@@ -678,8 +685,6 @@ sub _casespec {
 				  title     => $oldtitle,
 				  upper     => $oldupper,
 				  condition => $oldcondition };
-			    } else {
-				warn __PACKAGE__, ": SpecCase.txt:", $., ": No oldlocale for 0x$hexcode\n"
 			    }
 			}
 			my ($locale) =
@@ -713,7 +718,64 @@ sub casespec {
 
     _casespec() unless %CASESPEC;
 
-    return $CASESPEC{$code};
+    return ref $CASESPEC{$code} ? dclone $CASESPEC{$code} : $CASESPEC{$code};
+}
+
+=head2 namedseq()
+
+    use Unicode::UCD 'namedseq';
+
+    my $namedseq = namedseq("KATAKANA LETTER AINU P");
+    my @namedseq = namedseq("KATAKANA LETTER AINU P");
+    my %namedseq = namedseq();
+
+If used with a single argument in a scalar context, returns the string
+consisting of the code points of the named sequence, or C<undef> if no
+named sequence by that name exists.  If used with a single argument in
+a list context, returns list of the code points.  If used with no
+arguments in a list context, returns a hash with the names of the
+named sequences as the keys and the named sequences as strings as
+the values.  Otherwise, returns C<undef> or empty list depending
+on the context.
+
+(New from Unicode 4.1.0)
+
+=cut
+
+my %NAMEDSEQ;
+
+sub _namedseq {
+    unless (%NAMEDSEQ) {
+	if (openunicode(\$NAMEDSEQFH, "NamedSequences.txt")) {
+	    local $_;
+	    while (<$NAMEDSEQFH>) {
+		if (/^(.+)\s*;\s*([0-9A-F]+(?: [0-9A-F]+)*)$/) {
+		    my ($n, $s) = ($1, $2);
+		    my @s = map { chr(hex($_)) } split(' ', $s);
+		    $NAMEDSEQ{$n} = join("", @s);
+		}
+	    }
+	    close($NAMEDSEQFH);
+	}
+    }
+}
+
+sub namedseq {
+    _namedseq() unless %NAMEDSEQ;
+    my $wantarray = wantarray();
+    if (defined $wantarray) {
+	if ($wantarray) {
+	    if (@_ == 0) {
+		return %NAMEDSEQ;
+	    } elsif (@_ == 1) {
+		my $s = $NAMEDSEQ{ $_[0] };
+		return defined $s ? map { ord($_) } split('', $s) : ();
+	    }
+	} elsif (@_ == 1) {
+	    return $NAMEDSEQ{ $_[0] };
+	}
+    }
+    return;
 }
 
 =head2 Unicode::UCD::UnicodeVersion