This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Clarification and cleanup of the XS SWASHGET code
authorSADAHIRO Tomoyuki <BQW10602@nifty.com>
Sun, 4 Dec 2005 16:28:35 +0000 (01:28 +0900)
committerRafael Garcia-Suarez <rgarciasuarez@gmail.com>
Mon, 5 Dec 2005 15:15:53 +0000 (15:15 +0000)
Subject: Re: XS-assisted SWASHGET (esp. for t/uni/class.t speedup)
Message-Id: <20051204162508.D726.BQW10602@nifty.com>

p4raw-id: //depot/perl@26255

lib/utf8_heavy.pl
regexec.c
t/op/pat.t
utf8.c

index e5fd6e3..de4d01d 100644 (file)
@@ -25,10 +25,27 @@ sub SWASHNEW {
 
     ##
     ## Get the list of codepoints for the type.
-    ## Called from utf8.c
+    ## Called from swash_init (see utf8.c) or SWASHNEW itself.
+    ##
+    ## Callers of swash_init:
+    ##     op.c:pmtrans             -- for tr/// and y///
+    ##     regexec.c:regclass_swash -- for /[]/, \p, and \P
+    ##     utf8.c:is_utf8_common    -- for common Unicode properties
+    ##     utf8.c:to_utf8_case      -- for lc, uc, ucfirst, etc. and //i
     ##
     ## Given a $type, our goal is to fill $list with the set of codepoint
-    ## ranges.
+    ## ranges. If $type is false, $list passed is used.
+    ##
+    ## $minbits:
+    ##     For binary properties, $minbits must be 1.
+    ##     For character mappings (case and transliteration), $minbits must
+    ##     be a number except 1.
+    ##
+    ## $list (or that filled according to $type):
+    ##     Refer to perlunicode.pod, "User-Defined Character Properties."
+    ##     
+    ##     For binary properties, only characters with the property value
+    ##     of True should be listed. The 3rd column, if any, will be ignored.
     ##
     ## To make the parsing of $type clear, this code takes the a rather
     ## unorthodox approach of last'ing out of the block once we have the
@@ -43,7 +60,7 @@ sub SWASHNEW {
         $type =~ s/^\s+//;
         $type =~ s/\s+$//;
 
-        print "type = $type\n" if DEBUG;
+        print STDERR "type = $type\n" if DEBUG;
 
       GETFILE:
         {
@@ -117,7 +134,7 @@ sub SWASHNEW {
             ##
             my $canonical = lc $type;
             $canonical =~ s/(?<=[a-z\d])(?:\s+|[-_])(?=[a-z\d])//g;
-            print "canonical = $canonical\n" if DEBUG;
+            print STDERR "canonical = $canonical\n" if DEBUG;
 
             require "unicore/Canonical.pl";
             if (my $base = ($utf8::Canonical{$canonical} || $utf8::Canonical{ lc $utf8::PropertyAlias{$canonical} })) {
@@ -148,8 +165,7 @@ sub SWASHNEW {
            ## The user-level way to access ToDigit() and ToFold()
            ## is to use Unicode::UCD.
             ##
-            if ($type =~ /^To(Digit|Fold|Lower|Title|Upper)$/)
-            {
+            if ($type =~ /^To(Digit|Fold|Lower|Title|Upper)$/) {
                 $file = "unicore/To/$1.pl";
                 ## would like to test to see if $file actually exists....
                 last GETFILE;
@@ -164,7 +180,7 @@ sub SWASHNEW {
         }
 
        if (defined $file) {
-           print "found it (file='$file')\n" if DEBUG;
+           print STDERR "found it (file='$file')\n" if DEBUG;
 
            ##
            ## If we reach here, it was due to a 'last GETFILE' above
@@ -173,9 +189,8 @@ sub SWASHNEW {
            ## If we have, return the cached results. The cache key is the
            ## file to load.
            ##
-           if ($Cache{$file} and ref($Cache{$file}) eq $class)
-           {
-               print "Returning cached '$file' for \\p{$type}\n" if DEBUG;
+           if ($Cache{$file} and ref($Cache{$file}) eq $class) {
+               print STDERR "Returning cached '$file' for \\p{$type}\n" if DEBUG;
                return $Cache{$class, $file};
            }
 
@@ -186,7 +201,7 @@ sub SWASHNEW {
     }
 
     my $extras;
-    my $bits = 0;
+    my $bits = $minbits;
 
     my $ORIG = $list;
     if ($list) {
@@ -206,7 +221,7 @@ sub SWASHNEW {
        $list =~ s/\tXXXX$/\t$hextra/mg;
     }
 
-    if ($minbits < 32) {
+    if ($minbits != 1 && $minbits < 32) { # not binary property
        my $top = 0;
        while ($list =~ /^([0-9a-fA-F]+)(?:[\t]([0-9a-fA-F]+)?)(?:[ \t]([0-9a-fA-F]+))?/mg) {
            my $min = hex $1;
@@ -215,12 +230,11 @@ sub SWASHNEW {
            $val += $max - $min if defined $3;
            $top = $val if $val > $top;
        }
-       $bits =
+       my $topbits =
            $top > 0xffff ? 32 :
-           $top > 0xff ? 16 :
-           $top > 1 ? 8 : 1
+           $top > 0xff ? 16 : 8;
+       $bits = $topbits if $bits < $topbits;
     }
-    $bits = $minbits if $bits < $minbits;
 
     my @extras;
     for my $x ($extras) {
@@ -233,13 +247,13 @@ sub SWASHNEW {
                my ($c,$t) = split(/::/, $name, 2);     # bogus use of ::, really
                my $subobj;
                if ($c eq 'utf8') {
-                   $subobj = utf8->SWASHNEW($t, "", 0, 0, 0);
+                   $subobj = utf8->SWASHNEW($t, "", $minbits, 0);
                }
                elsif (exists &$name) {
-                   $subobj = utf8->SWASHNEW($name, "", 0, 0, 0);
+                   $subobj = utf8->SWASHNEW($name, "", $minbits, 0);
                }
                elsif ($c =~ /^([0-9a-fA-F]+)/) {
-                   $subobj = utf8->SWASHNEW("", $c, 0, 0, 0);
+                   $subobj = utf8->SWASHNEW("", $c, $minbits, 0);
                }
                return $subobj unless ref $subobj;
                push @extras, $name => $subobj;
index ec13139..b0ba851 100644 (file)
--- a/regexec.c
+++ b/regexec.c
@@ -4664,7 +4664,7 @@ Perl_regclass_swash(pTHX_ register const regnode* node, bool doinit, SV** listsv
            SV **const ary = AvARRAY(av);
            SV **a, **b;
        
-           /* See the end of regcomp.c:S_reglass() for
+           /* See the end of regcomp.c:S_regclass() for
             * documentation of these array elements. */
 
            si = *ary;
index 4ab37ad..dff0b65 100755 (executable)
@@ -6,7 +6,7 @@
 
 $| = 1;
 
-print "1..1191\n";
+print "1..1195\n";
 
 BEGIN {
     chdir 't' if -d 't';
@@ -2993,8 +2993,8 @@ sub IsSyriac1 {
 END
 }
 
-print "\x{0712}" =~ /\p{IsSyriac1}/ ? "ok $test\n" : "not ok $test\n"; $test++;
-print "\x{072F}" =~ /\P{IsSyriac1}/ ? "ok $test\n" : "not ok $test\n"; $test++;
+ok("\x{0712}" =~ /\p{IsSyriac1}/, '\x{0712}, \p{IsSyriac1}');
+ok("\x{072F}" =~ /\P{IsSyriac1}/, '\x{072F}, \P{IsSyriac1}');
 
 sub Syriac1 {
     return <<'END';
@@ -3003,8 +3003,8 @@ sub Syriac1 {
 END
 }
 
-print "\x{0712}" =~ /\p{Syriac1}/ ? "ok $test\n" : "not ok $test\n"; $test++;
-print "\x{072F}" =~ /\P{Syriac1}/ ? "ok $test\n" : "not ok $test\n"; $test++;
+ok("\x{0712}" =~ /\p{Syriac1}/, '\x{0712}, \p{Syriac1}');
+ok("\x{072F}" =~ /\P{Syriac1}/, '\x{072F}, \p{Syriac1}');
 
 print "# user-defined character properties may lack \\n at the end\n";
 sub InGreekSmall   { return "03B1\t03C9" }
@@ -3015,6 +3015,18 @@ ok("\x{03C2}" =~ /\p{InGreekSmall}/,   "Final sigma");
 ok("\x{03A0}" =~ /\p{InGreekCapital}/, "Capital PI");
 ok("\x{03A2}" =~ /\P{InGreekCapital}/, "Reserved");
 
+sub AsciiHexAndDash {
+    return <<'END';
++utf8::ASCII_Hex_Digit
++utf8::Dash
+END
+}
+
+ok("-" =~ /\p{Dash}/,            "'-' is Dash");
+ok("A" =~ /\p{ASCII_Hex_Digit}/, "'A' is ASCII_Hex_Digit");
+ok("-" =~ /\p{AsciiHexAndDash}/, "'-' is AsciiHexAndDash");
+ok("A" =~ /\p{AsciiHexAndDash}/, "'A' is AsciiHexAndDash");
+
 {
     print "# Change #18179\n";
     # previously failed with "panic: end_shift
@@ -3411,5 +3423,5 @@ ok(("foba  ba$s" =~ qr/(foo|BaSS|bar)/i)
        "# TODO assigning to original string should not corrupt match vars");
 }
 
-# last test 1191
+# last test 1195
 
diff --git a/utf8.c b/utf8.c
index 813a64f..8c9992f 100644 (file)
--- a/utf8.c
+++ b/utf8.c
@@ -1243,7 +1243,7 @@ S_is_utf8_common(pTHX_ const U8 *const p, SV **swash,
     if (!is_utf8_char(p))
        return FALSE;
     if (!*swash)
-       *swash = swash_init("utf8", swashname, &PL_sv_undef, 0, 0);
+       *swash = swash_init("utf8", swashname, &PL_sv_undef, 1, 0);
     return swash_fetch(*swash, p, TRUE) != 0;
 }
 
@@ -1545,8 +1545,12 @@ Perl_to_utf8_fold(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
                              &PL_utf8_tofold, "ToFold", "utf8::ToSpecFold");
 }
 
-/* a "swash" is a swatch hash */
-
+/* Note:
+ * A "swash" is a swatch hash.
+ * A "swatch" is a bit vector generated by utf8.c:S_swash_get().
+ * C<pkg> is a pointer to a package name for SWASHNEW, should be "utf8".
+ * For other parameters, see utf8::SWASHNEW in lib/utf8_heavy.pl.
+ */
 SV*
 Perl_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 minbits, I32 none)
 {
@@ -1744,7 +1748,7 @@ STATIC SV*
 S_swash_get(pTHX_ SV* swash, UV start, UV span)
 {
     SV *swatch;
-    U8 *l, *lend, *x, *xend, *s, *nl;
+    U8 *l, *lend, *x, *xend, *s;
     STRLEN lcur, xcur, scur;
 
     HV* const hv = (HV*)SvRV(swash);
@@ -1801,7 +1805,7 @@ S_swash_get(pTHX_ SV* swash, UV start, UV span)
        STRLEN numlen;
        I32 flags = PERL_SCAN_SILENT_ILLDIGIT | PERL_SCAN_DISALLOW_PREFIX;
 
-       nl = (U8*)memchr(l, '\n', lend - l);
+       U8* nl = (U8*)memchr(l, '\n', lend - l);
 
        numlen = lend - l;
        min = grok_hex((char *)l, &numlen, &flags, NULL);
@@ -1846,6 +1850,8 @@ S_swash_get(pTHX_ SV* swash, UV start, UV span)
                    }
                }
            }
+           else
+               val = 0; /* bits == 1, then val should be ignored */
        }
        else {
            max = min;
@@ -1855,6 +1861,8 @@ S_swash_get(pTHX_ SV* swash, UV start, UV span)
                    Perl_croak(aTHX_ "%s: illegal mapping '%s'", typestr, l);
                }
            }
+           else
+               val = 0; /* bits == 1, then val should be ignored */
        }
 
        if (nl)
@@ -1895,7 +1903,7 @@ S_swash_get(pTHX_ SV* swash, UV start, UV span)
                    ++val;
            }
        }
-       else {
+       else { /* bits == 1, then val should be ignored */
            if (min < start)
                min = start;
            for (key = min; key <= max; key++) {
@@ -1918,7 +1926,7 @@ S_swash_get(pTHX_ SV* swash, UV start, UV span)
        HV* otherhv;
        STRLEN otherbits;
        SV **otherbitssvp, *other;
-       U8 *s, *o;
+       U8 *s, *o, *nl;
        STRLEN slen, olen;
 
        U8 opc = *x++;
@@ -1993,8 +2001,7 @@ S_swash_get(pTHX_ SV* swash, UV start, UV span)
                break;
            }
        }
-       else { /* bits >= 8 */
-              /* XXX: but weirdly otherval is treated as boolean */
+       else {
            STRLEN otheroctets = otherbits >> 3;
            STRLEN offset = 0;
            U8* send = s + slen;
@@ -2015,8 +2022,8 @@ S_swash_get(pTHX_ SV* swash, UV start, UV span)
                    }
                }
 
-               if      (opc == '+' && otherval)
-                   otherval = 1;
+               if (opc == '+' && otherval)
+                   ; /* replace with otherval */
                else if (opc == '!' && !otherval)
                    otherval = 1;
                else if (opc == '-' && otherval)
@@ -2024,7 +2031,7 @@ S_swash_get(pTHX_ SV* swash, UV start, UV span)
                else if (opc == '&' && !otherval)
                    otherval = 0;
                else {
-                   s += octets; /* not modify orig swatch */
+                   s += octets; /* no replacement */
                    continue;
                }