From: SADAHIRO Tomoyuki Date: Sun, 4 Dec 2005 16:28:35 +0000 (+0900) Subject: Clarification and cleanup of the XS SWASHGET code X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=711a919c41ea4a93a45e4b6240ea6550abe85615;p=p5sagit%2Fp5-mst-13.2.git Clarification and cleanup of the XS SWASHGET code Subject: Re: XS-assisted SWASHGET (esp. for t/uni/class.t speedup) Message-Id: <20051204162508.D726.BQW10602@nifty.com> p4raw-id: //depot/perl@26255 --- diff --git a/lib/utf8_heavy.pl b/lib/utf8_heavy.pl index e5fd6e3..de4d01d 100644 --- a/lib/utf8_heavy.pl +++ b/lib/utf8_heavy.pl @@ -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; diff --git a/regexec.c b/regexec.c index ec13139..b0ba851 100644 --- 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; diff --git a/t/op/pat.t b/t/op/pat.t index 4ab37ad..dff0b65 100755 --- a/t/op/pat.t +++ b/t/op/pat.t @@ -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 --- 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 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; }