This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Integrate mainline
authorNick Ing-Simmons <nik@tiuk.ti.com>
Tue, 6 Nov 2001 08:26:40 +0000 (08:26 +0000)
committerNick Ing-Simmons <nik@tiuk.ti.com>
Tue, 6 Nov 2001 08:26:40 +0000 (08:26 +0000)
p4raw-id: //depot/perlio@12869

ext/DB_File/DB_File.pm
global.sym
hints/os390.sh
lib/encoding.pm
lib/encoding.t
proto.h
regcomp.c
regexec.c

index 432ae8a..a76927b 100644 (file)
@@ -595,7 +595,7 @@ DB_File - Perl5 access to Berkeley DB version 1.x
 
 B<DB_File> is a module which allows Perl programs to make use of the
 facilities provided by Berkeley DB version 1.x (if you have a newer
-version of DB, see L<Using DB_File with Berkeley DB version 2 or greater).
+version of DB, see L<Using DB_File with Berkeley DB version 2 or greater>).
 It is assumed that you have a copy of the Berkeley DB manual pages at
 hand when reading this documentation. The interface defined here
 mirrors the Berkeley DB interface closely.
index cf8ec98..693e3d6 100644 (file)
@@ -475,6 +475,7 @@ Perl_to_utf8_case
 Perl_to_utf8_lower
 Perl_to_utf8_upper
 Perl_to_utf8_title
+Perl_to_utf8_fold
 Perl_unlnk
 Perl_unlock_condpair
 Perl_unsharepvn
index 0273b32..bb41e67 100644 (file)
@@ -206,6 +206,6 @@ fi
 cat >config.arch<<'__CONFIG_ARCH__'
 # The '-W 0,float(ieee)' cannot be used during Configure as ldflags.
 
-ldflags="$ldflags -W 0,float\(ieee\)"
+ccflags="$ccflags -W 0,float(ieee)"
 
 __CONFIG_ARCH__
index 6f5970f..94ee323 100644 (file)
@@ -57,14 +57,33 @@ encoding pragma you can change this default.
 The pragma is a per script, not a per block lexical.  Only the last
 C<use encoding> matters, and it affects B<the whole script>.
 
+Notice that only literals (string or regular expression) having only
+legacy code points are affected: if you mix data like this
+
+       \xDF\x{100}
+
+the data is assumed to be in (Latin 1 and) Unicode, not in your native
+encoding.  In other words, this will match in "greek":
+
+       "\xDF" =~ /\x{3af}/
+
+but this will not
+
+       "\xDF\x{100}" =~ /\x{3af}\x{100}/
+
+since the C<\xDF> on the left will B<not> be upgraded to C<\x{3af}>
+because of the C<\x{100}> on the left.  You should not be mixing your
+legacy data and Unicode in the same string.
+
 If no encoding is specified, the environment variable L<PERL_ENCODING>
 is consulted.  If that fails, "latin1" (ISO 8859-1) is assumed.  If no
 encoding can be found, C<Unknown encoding '...'> error will be thrown.
 
 =head1 KNOWN PROBLEMS
 
-Literals in regular expressions are not affected by this pragma.
-They very probably should.
+For native multibyte encodings (either fixed or variable length)
+the current implementation of the regular expressions may introduce
+recoding errors for longer regular expression literals than 127 bytes.
 
 =head1 SEE ALSO
 
index 0363441..8b14c88 100644 (file)
@@ -1,4 +1,4 @@
-print "1..15\n";
+print "1..19\n";
 
 use encoding "latin1"; # ignored (overwritten by the next line)
 use encoding "greek";  # iso 8859-7 (no "latin" alias, surprise...)
@@ -68,3 +68,17 @@ print "ok 14\n";
 print "not " unless ord(substr($c, 2, 1)) == 0x3af;
 print "ok 15\n";
 
+# regex literals
+
+print "not " unless "\xDF"    =~ /\x{3AF}/;
+print "ok 16\n";
+
+print "not " unless "\x{3AF}" =~ /\xDF/;
+print "ok 17\n";
+
+print "not " unless "\xDF"    =~ /\xDF/;
+print "ok 18\n";
+
+print "not " unless "\x{3AF}" =~ /\x{3AF}/;
+print "ok 19\n";
+
diff --git a/proto.h b/proto.h
index e1bc067..27872ca 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -802,6 +802,7 @@ PERL_CALLCONV UV    Perl_to_utf8_case(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp, SV **sw
 PERL_CALLCONV UV       Perl_to_utf8_lower(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp);
 PERL_CALLCONV UV       Perl_to_utf8_upper(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp);
 PERL_CALLCONV UV       Perl_to_utf8_title(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp);
+PERL_CALLCONV UV       Perl_to_utf8_fold(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp);
 #if defined(UNLINK_ALL_VERSIONS)
 PERL_CALLCONV I32      Perl_unlnk(pTHX_ char* f);
 #endif
index 0a63f22..cd3857e 100644 (file)
--- a/regcomp.c
+++ b/regcomp.c
@@ -3155,6 +3155,21 @@ tryagain:
        break;
     }
 
+    if (PL_encoding && PL_regkind[(U8)OP(ret)] == EXACT && !RExC_utf8) {
+        STRLEN oldlen = STR_LEN(ret);
+        SV *sv        = sv_2mortal(newSVpvn(STRING(ret), oldlen));
+        char *s       = Perl_sv_recode_to_utf8(aTHX_ sv, PL_encoding);
+        STRLEN newlen = SvCUR(sv);
+        if (!SIZE_ONLY) {
+             DEBUG_r(PerlIO_printf(Perl_debug_log, "recode %*s to %*s\n",
+                                   oldlen, STRING(ret), newlen, s));
+             Copy(s, STRING(ret), newlen, char);
+             STR_LEN(ret) += newlen - oldlen;
+             RExC_emit += STR_SZ(newlen) - STR_SZ(oldlen);
+        } else
+             RExC_size += STR_SZ(newlen) - STR_SZ(oldlen);
+    }
+
     return(ret);
 }
 
@@ -4415,7 +4430,7 @@ Perl_regprop(pTHX_ SV *sv, regnode *o)
 
     if (k == EXACT) {
         SV *dsv = sv_2mortal(newSVpvn("", 0));
-       bool do_utf8 = PL_reg_match_utf8;
+       bool do_utf8 = DO_UTF8(sv);
        char *s    = do_utf8 ?
          pv_uni_display(dsv, (U8*)STRING(o), STR_LEN(o), 60, 0) :
          STRING(o);
index 67e9015..60d93f7 100644 (file)
--- a/regexec.c
+++ b/regexec.c
@@ -408,7 +408,8 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos,
        PL_reg_flags |= RF_utf8;
 
     if (prog->minlen > CHR_DIST((U8*)strend, (U8*)strpos)) {
-       DEBUG_r(PerlIO_printf(Perl_debug_log, "String too short...\n"));
+       DEBUG_r(PerlIO_printf(Perl_debug_log,
+                             "String too short... [re_intuit_start]\n"));
        goto fail;
     }
     strbeg = (sv && SvPOK(sv)) ? strend - SvCUR(sv) : strpos;
@@ -1474,11 +1475,10 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char *
     }
 
     minlen = prog->minlen;
-    if (do_utf8 && !(prog->reganch & ROPT_CANY_SEEN)) {
-        if (utf8_distance((U8*)strend, (U8*)startpos) < minlen) goto phooey;
-    }
-    else {
-        if (strend - startpos < minlen) goto phooey;
+    if (strend - startpos < minlen) {
+        DEBUG_r(PerlIO_printf(Perl_debug_log,
+                             "String too short [regexec_flags]...\n"));
+       goto phooey;
     }
 
     /* Check validity of program. */
@@ -1537,13 +1537,15 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char *
        d.scream_olds = &scream_olds;
        d.scream_pos = &scream_pos;
        s = re_intuit_start(prog, sv, s, strend, flags, &d);
-       if (!s)
+       if (!s) {
+           DEBUG_r(PerlIO_printf(Perl_debug_log, "Not present...\n"));
            goto phooey;        /* not present */
+       }
     }
 
     DEBUG_r({
-        char *s   = UTF ? sv_uni_display(dsv, sv, 60, 0) : startpos;
-        int   len = UTF ? strlen(s) : strend - startpos;
+        char *s   = do_utf8 ? sv_uni_display(dsv, sv, 60, 0) : startpos;
+        int   len = do_utf8 ? strlen(s) : strend - startpos;
         if (!PL_colorset)
             reginitcolors();
         PerlIO_printf(Perl_debug_log,
@@ -2070,13 +2072,13 @@ S_regmatch(pTHX_ regnode *prog)
                ? (5 + taill) - l : locinput - PL_bostr;
            int pref0_len;
 
-           while (UTF8_IS_CONTINUATION(*(U8*)(locinput - pref_len)))
+           while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput - pref_len)))
                pref_len++;
            pref0_len = pref_len  - (locinput - PL_reg_starttry);
            if (l + pref_len < (5 + taill) && l < PL_regeol - locinput)
                l = ( PL_regeol - locinput > (5 + taill) - pref_len
                      ? (5 + taill) - pref_len : PL_regeol - locinput);
-           while (UTF8_IS_CONTINUATION(*(U8*)(locinput + l)))
+           while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput + l)))
                l--;
            if (pref0_len < 0)
                pref0_len = 0;
@@ -2085,21 +2087,21 @@ S_regmatch(pTHX_ regnode *prog)
            regprop(prop, scan);
            {
              char *s0 =
-               UTF ?
+               do_utf8 ?
                pv_uni_display(dsv0, (U8*)(locinput - pref_len),
                               pref0_len, 60, 0) :
                locinput - pref_len;
-             int len0 = UTF ? strlen(s0) : pref0_len;
-             char *s1 = UTF ?
+             int len0 = do_utf8 ? strlen(s0) : pref0_len;
+             char *s1 = do_utf8 ?
                pv_uni_display(dsv1, (U8*)(locinput - pref_len + pref0_len),
                               pref_len - pref0_len, 60, 0) :
                locinput - pref_len + pref0_len;
-             int len1 = UTF ? strlen(s1) : pref_len - pref0_len;
-             char *s2 = UTF ?
+             int len1 = do_utf8 ? strlen(s1) : pref_len - pref0_len;
+             char *s2 = do_utf8 ?
                pv_uni_display(dsv2, (U8*)locinput,
                               PL_regeol - locinput, 60, 0) :
                locinput;
-             int len2 = UTF ? strlen(s2) : l;
+             int len2 = do_utf8 ? strlen(s2) : l;
              PerlIO_printf(Perl_debug_log,
                            "%4"IVdf" <%s%.*s%s%s%.*s%s%s%s%.*s%s>%*s|%3"IVdf":%*s%s\n",
                            (IV)(locinput - PL_bostr),
@@ -2205,14 +2207,26 @@ S_regmatch(pTHX_ regnode *prog)
                char *l = locinput;
                char *e = s + ln;
                STRLEN len;
+
                if (do_utf8)
                    while (s < e) {
+                       UV uv;
+
                        if (l >= PL_regeol)
                            sayNO;
-                       if (*((U8*)s) != utf8_to_uvchr((U8*)l, &len))
-                           sayNO;
-                       s++;
-                       l += len;
+                       uv = NATIVE_TO_UNI(*(U8*)s);
+                       if (UTF8_IS_START(uv)) {
+                            len = UTF8SKIP(s);
+                            if (memNE(s, l, len))
+                                 sayNO;
+                            l += len;
+                            s += len;
+                       } else {
+                            if (uv != utf8_to_uvchr((U8*)l, &len))
+                                 sayNO;
+                            l += len;
+                            s ++;
+                       }
                    }
                else
                    while (s < e) {
@@ -2221,7 +2235,7 @@ S_regmatch(pTHX_ regnode *prog)
                        if (*((U8*)l) != utf8_to_uvchr((U8*)s, &len))
                            sayNO;
                        s += len;
-                       l++;
+                       l ++;
                    }
                locinput = l;
                nextchr = UCHARAT(locinput);