This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Document tricks, work-arounds for user-defined casing
authorKarl Williamson <khw@khw-desktop.(none)>
Fri, 28 May 2010 04:24:40 +0000 (22:24 -0600)
committerRafael Garcia-Suarez <rgs@consttype.org>
Sun, 30 May 2010 17:55:29 +0000 (19:55 +0200)
And add a .t file to verify that it works.

MANIFEST
pod/perlunicode.pod
t/op/turkish.t [new file with mode: 0644]

index a676231..197d359 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -4506,6 +4506,7 @@ t/op/tie.t                        See if tie/untie functions work
 t/op/time_loop.t               Test that very large values don't hang gmtime and localtime.
 t/op/time.t                    See if time functions work
 t/op/tr.t                      See if tr works
+t/op/turkish.t                 See if we can implement Turkish casing
 t/op/undef.t                   See if undef works
 t/op/universal.t               See if UNIVERSAL class works
 t/op/unshift.t                 See if unshift works
index 1b4c249..bd193f8 100644 (file)
@@ -899,20 +899,83 @@ to be mapped to "A"; all other characters will remain unchanged.
 
 (For serious hackers only)  The above means you have to furnish a complete
 mapping; you can't just override a couple of characters and leave the rest
-unchanged.  You can find all the mappings in the directory
+unchanged.  You can find all the official mappings in the directory
 C<$Config{privlib}>F</unicore/To/>.  The mapping data is returned as the
 here-document.  The C<utf8::ToSpecI<Foo>> hashes in those files are special
 exception mappings derived from
-C<$Config{privlib}>F</unicore/SpecialCasing.txt>.  The "Digit" and
+C<$Config{privlib}>F</unicore/SpecialCasing.txt>.  (The "Digit" and
 "Fold" mappings that one can see in the directory are not directly
 user-accessible, one can use either the L<Unicode::UCD> module, or just match
-case-insensitively (that's when the "Fold" mapping is used).
+case-insensitively, which is what uses the "Fold" mapping.  Neither are user
+overridable.)
 
-The mappings will only take effect on scalars that have been marked as having
-Unicode characters, for example by using C<utf8::upgrade()>.
-Old byte-style strings are not affected.
+If you have many mappings to change, you can take the official mapping data,
+change by hand the affected code points, and place the whole thing into your
+subroutine.  But this will only be valid on Perls that use the same Unicode
+version.  Another option would be to have your subroutine read the official
+mapping file(s) and overwrite the affected code points.
 
-The mappings are in effect for the package they are defined in.
+If you have only a few mappings to change, starting in 5.14 you can use the
+following trick, here illustrated for Turkish.
+
+    use Config;
+
+    sub ToUpper {
+        my $official = do "$Config{privlib}/unicore/To/Upper.pl";
+        $utf8::ToSpecUpper{'i'} = 
+                           "\N{LATIN CAPITAL LETTER I WITH DOT ABOVE}";
+        return $official;
+    }
+
+This takes the official mappings and overrides just one, for "LATIN SMALL
+LETTER I".  The keys to the hash must be in UTF-8 (or on EBCDIC platforms,
+UTF-EBCDIC), as illustrated by the inverse function.
+
+    sub ToLower {
+        my $official = do $lower;
+        $utf8::ToSpecLower{"\xc4\xb0"} = "i";
+        return $official;
+    }
+
+This example is for an ASCII platform, and C<\xc4\xb0> is the UTF-8 string that 
+represents C<\N{LATIN CAPITAL LETTER I WITH DOT ABOVE}>, C<U+0130>.
+
+(The trick illustrated here does work in earlier releases, but only if all the
+characters you want to override have ordinal values of 256 or higher.)
+
+The mappings are in effect only for the package they are defined in, and only
+on scalars that have been marked as having Unicode characters, for example by
+using C<utf8::upgrade()>.  You can get around the latter restriction in the
+scope of a C<S<use subs>>:
+
+    use subs qw(uc ucfirst lc lcfirst);
+
+    sub uc($) {
+        my $string = shift;
+        utf8::upgrade($string);
+        return CORE::uc($string);
+    }
+
+    sub lc($) {
+        my $string = shift;
+        utf8::upgrade($string);
+
+        # Unless an I is before a dot_above, it turns into a dotless i.
+        $string =~ 
+              s/I (?! [^\p{ccc=0}\p{ccc=Above}]* \x{0307} )/\x{131}/gx;
+
+        # But when the I is followed by a dot_above, remove the
+        # dot_above so the end result will be i.
+        $string =~ s/I ([^\p{ccc=0}\p{ccc=Above}]* ) \x{0307}/i$1/gx;
+        return CORE::lc($string);
+    }
+
+These examples (also for Turkish) make sure the input is in UTF-8, and then
+call the corresponding official function, which will use the C<ToUpper()> and
+C<ToLower()> functions you have defined in the package.  The C<lc()> example
+shows how you can add context-dependent casing.  (For Turkish, there other
+required functions: C<ucfirst>, C<lcfirst>, and C<ToTitle>.  These are very
+similar to the ones given above.)
 
 =head2 Character Encodings for Input and Output
 
diff --git a/t/op/turkish.t b/t/op/turkish.t
new file mode 100644 (file)
index 0000000..08e2bac
--- /dev/null
@@ -0,0 +1,100 @@
+# Verifies that can implement Turkish casing as defined by Unicode 5.2.
+
+use Config;
+
+BEGIN {
+    chdir 't';
+    @INC = '../lib';
+    require './test.pl';
+}
+
+use subs qw(lc lcfirst uc ucfirst);
+
+sub uc($) {
+    my $string = shift;
+    utf8::upgrade($string);
+    return CORE::uc($string);
+}
+
+sub ucfirst($) {
+    my $string = shift;
+    utf8::upgrade($string);
+    return CORE::ucfirst($string);
+}
+
+sub lc($) {
+    my $string = shift;
+    utf8::upgrade($string);
+
+    # Unless an I is before a dot_above, it turns into a dotless i.
+    $string =~ s/I (?! [^\p{ccc=0}\p{ccc=Above}]* \x{0307} )/\x{131}/gx;
+
+    # But when the I is followed by a dot_above, remove the dot_above so
+    # the end result will be i.
+    $string =~ s/I ([^\p{ccc=0}\p{ccc=Above}]* ) \x{0307}/i$1/gx;
+    return CORE::lc($string);
+}
+
+sub lcfirst($) {
+    my $string = shift;
+    utf8::upgrade($string);
+
+    # Unless an I is before a dot_above, it turns into a dotless i.
+    $string =~ s/^I (?! [^\p{ccc=0}\p{ccc=Above}]* \x{0307} )/\x{131}/x;
+
+    # But when the I is followed by a dot_above, remove the dot_above so
+    # the end result will be i.
+    $string =~ s/^I ([^\p{ccc=0}\p{ccc=Above}]* ) \x{0307}/i$1/x;
+    return CORE::lcfirst($string);
+}
+
+plan tests => 22;
+
+my $map_directory = "../lib/unicore/To";
+my $upper = "$map_directory/Upper.pl";
+my $lower = "$map_directory/Lower.pl";
+my $title = "$map_directory/Title.pl";
+
+sub ToUpper {
+    my $official = do $upper;
+    $utf8::ToSpecUpper{'i'} = "\x{0130}";
+    return $official;
+}
+
+sub ToTitle {
+    my $official = do $title;
+    $utf8::ToSpecTitle{'i'} = "\x{0130}";
+    return $official;
+}
+
+sub ToLower {
+    my $official = do $lower;
+    $utf8::ToSpecLower{"\xc4\xb0"} = "i";
+    return $official;
+}
+
+is(uc("\x{DF}\x{DF}"), "SSSS", "Verify that uc of non-overridden multi-char works");
+is(uc("aa"), "AA", "Verify that uc of non-overridden ASCII works");
+is(uc("\x{101}\x{101}"), "\x{100}\x{100}", "Verify that uc of non-overridden utf8 works");
+is(uc("ii"), "\x{130}\x{130}", "Verify uc('i') eq \\x{130}");
+
+is(ucfirst("\x{DF}\x{DF}"), "Ss\x{DF}", "Verify that ucfirst of non-overridden multi-char works");
+is(ucfirst("\x{101}\x{101}"), "\x{100}\x{101}", "Verify that ucfirst of non-overridden utf8 works");
+is(ucfirst("aa"), "Aa", "Verify that ucfirst of non-overridden ASCII works");
+is(ucfirst("ii"), "\x{130}i", "Verify ucfirst('ii') eq \"\\x{130}i\"");
+
+is(lc("AA"), "aa", "Verify that lc of non-overridden ASCII works");
+is(lc("\x{C0}\x{C0}"), "\x{E0}\x{E0}", "Verify that lc of non-overridden latin1 works");
+is(lc("\x{0178}\x{0178}"), "\x{FF}\x{FF}", "Verify that lc of non-overridden utf8 works");
+is(lc("II"), "\x{131}\x{131}", "Verify that lc('I') eq \\x{131}");
+is(lc("IG\x{0307}IG\x{0307}"), "\x{131}g\x{0307}\x{131}g\x{0307}", "Verify that lc(\"I...\\x{0307}\") eq \"\\x{131}...\\x{0307}\"");
+is(lc("I\x{0307}I\x{0307}"), "ii", "Verify that lc(\"I\\x{0307}\") removes the \\x{0307}, leaving 'i'");
+is(lc("\x{130}\x{130}"), "ii", "Verify that lc(\"\\x{130}\") eq 'i'");
+
+is(lcfirst("AA"), "aA", "Verify that lcfirst of non-overridden ASCII works");
+is(lcfirst("\x{C0}\x{C0}"), "\x{E0}\x{C0}", "Verify that lcfirst of non-overridden latin1 works");
+is(lcfirst("\x{0178}\x{0178}"), "\x{FF}\x{0178}", "Verify that lcfirst of non-overridden utf8 works");
+is(lcfirst("I"), "\x{131}", "Verify that lcfirst('II') eq \"\\x{131}I\"");
+is(lcfirst("IG\x{0307}"), "\x{131}G\x{0307}", "Verify that lcfirst(\"I...\\x{0307}\") eq \"\\x{131}...\\x{0307}\"");
+is(lcfirst("I\x{0307}I\x{0307}"), "iI\x{0307}", "Verify that lcfirst(\"I\\x{0307}I\\x{0307}\") removes the first \\x{0307}, leaving 'iI\\x{0307}'");
+is(lcfirst("\x{130}\x{130}"), "i\x{130}", "Verify that lcfirst(\"\\x{130}\\x{130}\") eq \"i\\x{130}\"");