This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Integrate changes #7355[-doio.c],7691,7744,7753[perlio],
authorJarkko Hietaniemi <jhi@iki.fi>
Sat, 27 Jan 2001 18:06:51 +0000 (18:06 +0000)
committerJarkko Hietaniemi <jhi@iki.fi>
Sat, 27 Jan 2001 18:06:51 +0000 (18:06 +0000)
7783,7790[perlio],7869,7871,7872,7911,7916,7932,
7935[-perlio.c],7936,7959,7965 from mainline.

Change the "big byte" error message to "Wide character".
(7355, the croak-if-wide-chars-in-print part ignored)

Use UINT64_C().

Introduce Perl_utf8_length().

diff -se shows these as different (7753, forgotten check-ins)

Subject: [PATCH] doop.c - UTF8 tr///

If we use (aTHX_ ...) then put Perl_ on the front.

Make utf8_length() and utf8_distance() to be less forgiving
about bad UTF-8.

Test line numbers are different with utf8.

No need to scan till infinity, 13 is enough. (7872,7911)

Subject: [PATCH] Tokeniser debugging

Subject: Re: question about retlen in utf8.c:Perl_utf8_to_uv()

Subject: [PATCH perl@7930] toke.c perlio.c -Wformat nits (only toke.c)

Be more careful in Perl_sv_utf8_downgrade().

Use DO_UTF8().

Raw zero bytes in text files confuse at least GNU patch 2.1.

p4raw-link: @7355 on //depot/perl: 4b3603a49f6eac34b6cdb154bf3bd8a8f5240085

p4raw-id: //depot/maint-5.6/perl@8568
p4raw-integrated: from //depot/perlio@7790 'ignore' scope.h (@7789..)
p4raw-integrated: from //depot/perlio@7753 'edit in' pod/perlapi.pod
(@7492..) 'merge in' global.sym (@7486..)
p4raw-integrated: from //depot/perl@8553 'copy in' pod/perlrun.pod
(@7652..)
p4raw-integrated: from //depot/perl@7965 'merge in' t/pragma/utf8.t
(@7485..)
p4raw-integrated: from //depot/perl@7959 'merge in' op.c (@7914..)
p4raw-integrated: from //depot/perl@7936 'edit in' sv.c (@7927..)
p4raw-integrated: from //depot/perl@7935 'edit in' toke.c (@7916..)
p4raw-integrated: from //depot/perl@7932 'edit in' pod/perlapi.pod
(@7756..) utf8.c (@7911..)
p4raw-integrated: from //depot/perl@7916 'merge in' perl.c (@7758..)
perl.h (@7855..)
p4raw-integrated: from //depot/perl@7872 'merge in' handy.h (@7793..)
p4raw-integrated: from //depot/perl@7871 'merge in' t/op/re_tests
(@7815..)
p4raw-integrated: from //depot/perl@7869 'edit in' embed.pl proto.h
(@7858..) 'ignore' embed.h objXSUB.h (@7858..)
p4raw-integrated: from //depot/perl@7783 'merge in' doop.c (@7677..)
p4raw-integrated: from //depot/perl@7744 'merge in' perlapi.c (@7547..)
p4raw-integrated: from //depot/perl@7691 'copy in' utf8.h (@7677..)
p4raw-integrated: from //depot/perl@7355 'merge in' pod/perldiag.pod
(@7213..)

20 files changed:
doop.c
embed.h
embed.pl
global.sym
handy.h
objXSUB.h
op.c
perl.c
perl.h
perlapi.c
pod/perlapi.pod
pod/perldiag.pod
pod/perlrun.pod
proto.h
sv.c
t/op/re_tests
t/pragma/utf8.t
toke.c
utf8.c
utf8.h

diff --git a/doop.c b/doop.c
index e10b21d..edd20a3 100644 (file)
--- a/doop.c
+++ b/doop.c
@@ -142,6 +142,7 @@ S_do_trans_complex(pTHX_ SV *sv)/* SPC - NOT OK */
     U8 *s;
     U8 *send;
     U8 *d;
+    U8 *dstart;
     I32 hasutf = SvUTF8(sv);
     I32 matches = 0;
     STRLEN len;
@@ -155,7 +156,9 @@ S_do_trans_complex(pTHX_ SV *sv)/* SPC - NOT OK */
     s = (U8*)SvPV(sv, len);
     send = s + len;
 
-    d = s;
+    Newz(0, d, len*2+1, U8);
+    dstart = d;
+
     if (PL_op->op_private & OPpTRANS_SQUASH) {
        U8* p = send;
 
@@ -166,9 +169,7 @@ S_do_trans_complex(pTHX_ SV *sv)/* SPC - NOT OK */
                if ((ch = tbl[*s]) >= 0) {
                    *d = ch;
                    matches++;
-                   if (p == d - 1 && *p == *d)
-                       matches--;
-                   else
+           if (p != d - 1 || *p != *d)
                        p = d++;
                }
                else if (ch == -1)      /* -1 is unmapped character */
@@ -179,26 +180,41 @@ S_do_trans_complex(pTHX_ SV *sv)/* SPC - NOT OK */
     }
     else {
        while (s < send) {
+           UV comp;
             if (hasutf && *s & 0x80)
-                s += UTF8SKIP(s);
-            else {
-               if ((ch = tbl[*s]) >= 0) {
-                   *d = ch;
-                   matches++;
-                   d++;
-               }
-               else if (ch == -1)      /* -1 is unmapped character */
-                   *d++ = *s;          /* -2 is delete character */
-               s++;
-            }
+                comp = utf8_to_uv_simple(s, NULL);
+           else
+                comp = *s;
+           
+           ch = tbl[comp];
+           
+           if (ch == -1) { /* -1 is unmapped character */
+                ch = comp;
+               matches--;
+           }
+
+           if (ch >= 0) {
+               if (hasutf)
+                 d = uv_to_utf8(d, ch);
+               else 
+                 *d++ = ch;
+           }
+           matches++;
+
+           s += hasutf && *s & 0x80 ? UNISKIP(*s) : 1;
+            
        }
     }
-    matches += send - d;               /* account for disappeared chars */
+
     *d = '\0';
-    SvCUR_set(sv, d - (U8*)SvPVX(sv));
-    SvSETMAGIC(sv);
 
+    sv_setpvn(sv, (const char*)dstart, d - dstart);
+    Safefree(dstart);
+    if (hasutf)
+        SvUTF8_on(sv);
+    SvSETMAGIC(sv);
     return matches;
+
 }
 
 STATIC I32
diff --git a/embed.h b/embed.h
index d174407..8e0ab17 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define utilize                        Perl_utilize
 #define utf16_to_utf8          Perl_utf16_to_utf8
 #define utf16_to_utf8_reversed Perl_utf16_to_utf8_reversed
+#define utf8_length            Perl_utf8_length
 #define utf8_distance          Perl_utf8_distance
 #define utf8_hop               Perl_utf8_hop
 #define utf8_to_bytes          Perl_utf8_to_bytes
 #define utilize(a,b,c,d,e)     Perl_utilize(aTHX_ a,b,c,d,e)
 #define utf16_to_utf8(a,b,c,d) Perl_utf16_to_utf8(aTHX_ a,b,c,d)
 #define utf16_to_utf8_reversed(a,b,c,d)        Perl_utf16_to_utf8_reversed(aTHX_ a,b,c,d)
+#define utf8_length(a,b)       Perl_utf8_length(aTHX_ a,b)
 #define utf8_distance(a,b)     Perl_utf8_distance(aTHX_ a,b)
 #define utf8_hop(a,b)          Perl_utf8_hop(aTHX_ a,b)
 #define utf8_to_bytes(a,b)     Perl_utf8_to_bytes(aTHX_ a,b)
 #define utf16_to_utf8          Perl_utf16_to_utf8
 #define Perl_utf16_to_utf8_reversed    CPerlObj::Perl_utf16_to_utf8_reversed
 #define utf16_to_utf8_reversed Perl_utf16_to_utf8_reversed
+#define Perl_utf8_length       CPerlObj::Perl_utf8_length
+#define utf8_length            Perl_utf8_length
 #define Perl_utf8_distance     CPerlObj::Perl_utf8_distance
 #define utf8_distance          Perl_utf8_distance
 #define Perl_utf8_hop          CPerlObj::Perl_utf8_hop
index 3e7debe..8c0ce34 100755 (executable)
--- a/embed.pl
+++ b/embed.pl
@@ -2070,7 +2070,8 @@ p |void   |unshare_hek    |HEK* hek
 p      |void   |utilize        |int aver|I32 floor|OP* version|OP* id|OP* arg
 Ap     |U8*    |utf16_to_utf8  |U8* p|U8 *d|I32 bytelen|I32 *newlen
 Ap     |U8*    |utf16_to_utf8_reversed|U8* p|U8 *d|I32 bytelen|I32 *newlen
-Ap     |I32    |utf8_distance  |U8 *a|U8 *b
+Ap     |STRLEN |utf8_length    |U8* s|U8 *e
+Ap     |IV     |utf8_distance  |U8 *a|U8 *b
 Ap     |U8*    |utf8_hop       |U8 *s|I32 off
 ApM    |U8*    |utf8_to_bytes  |U8 *s|STRLEN *len
 ApM    |U8*    |bytes_to_utf8  |U8 *s|STRLEN *len
index 22d3b64..169cfa5 100644 (file)
@@ -461,6 +461,7 @@ Perl_unlock_condpair
 Perl_unsharepvn
 Perl_utf16_to_utf8
 Perl_utf16_to_utf8_reversed
+Perl_utf8_length
 Perl_utf8_distance
 Perl_utf8_hop
 Perl_utf8_to_bytes
diff --git a/handy.h b/handy.h
index b3912a4..aa6c408 100644 (file)
--- a/handy.h
+++ b/handy.h
@@ -463,23 +463,21 @@ Converts the specified character to lowercase.
 #define isPSXSPC_utf8(c)       (isSPACE_utf8(c) ||(c) == '\f')
 #define isBLANK_utf8(c)                isBLANK(c) /* could be wrong */
 
-#define STRLEN_MAX     ((STRLEN)-1)
-
-#define isALNUM_LC_utf8(p)     isALNUM_LC_uni(utf8_to_uv(p, STRLEN_MAX, 0, 0))
-#define isIDFIRST_LC_utf8(p)   isIDFIRST_LC_uni(utf8_to_uv(p, STRLEN_MAX, 0, 0))
-#define isALPHA_LC_utf8(p)     isALPHA_LC_uni(utf8_to_uv(p, STRLEN_MAX, 0, 0))
-#define isSPACE_LC_utf8(p)     isSPACE_LC_uni(utf8_to_uv(p, STRLEN_MAX, 0, 0))
-#define isDIGIT_LC_utf8(p)     isDIGIT_LC_uni(utf8_to_uv(p, STRLEN_MAX, 0, 0))
-#define isUPPER_LC_utf8(p)     isUPPER_LC_uni(utf8_to_uv(p, STRLEN_MAX, 0, 0))
-#define isLOWER_LC_utf8(p)     isLOWER_LC_uni(utf8_to_uv(p, STRLEN_MAX, 0, 0))
-#define isALNUMC_LC_utf8(p)    isALNUMC_LC_uni(utf8_to_uv(p, STRLEN_MAX, 0, 0))
-#define isCNTRL_LC_utf8(p)     isCNTRL_LC_uni(utf8_to_uv(p, STRLEN_MAX, 0, 0))
-#define isGRAPH_LC_utf8(p)     isGRAPH_LC_uni(utf8_to_uv(p, STRLEN_MAX, 0, 0))
-#define isPRINT_LC_utf8(p)     isPRINT_LC_uni(utf8_to_uv(p, STRLEN_MAX, 0, 0))
-#define isPUNCT_LC_utf8(p)     isPUNCT_LC_uni(utf8_to_uv(p, STRLEN_MAX, 0, 0))
-#define toUPPER_LC_utf8(p)     toUPPER_LC_uni(utf8_to_uv(p, STRLEN_MAX, 0, 0))
-#define toTITLE_LC_utf8(p)     toTITLE_LC_uni(utf8_to_uv(p, STRLEN_MAX, 0, 0))
-#define toLOWER_LC_utf8(p)     toLOWER_LC_uni(utf8_to_uv(p, STRLEN_MAX, 0, 0))
+#define isALNUM_LC_utf8(p)     isALNUM_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0))
+#define isIDFIRST_LC_utf8(p)   isIDFIRST_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0))
+#define isALPHA_LC_utf8(p)     isALPHA_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0))
+#define isSPACE_LC_utf8(p)     isSPACE_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0))
+#define isDIGIT_LC_utf8(p)     isDIGIT_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0))
+#define isUPPER_LC_utf8(p)     isUPPER_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0))
+#define isLOWER_LC_utf8(p)     isLOWER_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0))
+#define isALNUMC_LC_utf8(p)    isALNUMC_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0))
+#define isCNTRL_LC_utf8(p)     isCNTRL_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0))
+#define isGRAPH_LC_utf8(p)     isGRAPH_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0))
+#define isPRINT_LC_utf8(p)     isPRINT_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0))
+#define isPUNCT_LC_utf8(p)     isPUNCT_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0))
+#define toUPPER_LC_utf8(p)     toUPPER_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0))
+#define toTITLE_LC_utf8(p)     toTITLE_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0))
+#define toLOWER_LC_utf8(p)     toLOWER_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0))
 
 #define isPSXSPC_LC_utf8(c)    (isSPACE_LC_utf8(c) ||(c) == '\f')
 #define isBLANK_LC_utf8(c)     isBLANK(c) /* could be wrong */
index ff10c92..a489a15 100644 (file)
--- a/objXSUB.h
+++ b/objXSUB.h
 #define Perl_utf16_to_utf8_reversed    pPerl->Perl_utf16_to_utf8_reversed
 #undef  utf16_to_utf8_reversed
 #define utf16_to_utf8_reversed Perl_utf16_to_utf8_reversed
+#undef  Perl_utf8_length
+#define Perl_utf8_length       pPerl->Perl_utf8_length
+#undef  utf8_length
+#define utf8_length            Perl_utf8_length
 #undef  Perl_utf8_distance
 #define Perl_utf8_distance     pPerl->Perl_utf8_distance
 #undef  utf8_distance
diff --git a/op.c b/op.c
index fc305da..9b4437f 100644 (file)
--- a/op.c
+++ b/op.c
@@ -2899,7 +2899,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
            p = SvPV(pat, plen);
            pm->op_pmflags |= PMf_SKIPWHITE;
        }
-       if ((PL_hints & HINT_UTF8) || (SvUTF8(pat) && !(PL_hints & HINT_BYTE)))
+       if ((PL_hints & HINT_UTF8) || DO_UTF8(pat))
            pm->op_pmdynflags |= PMdf_UTF8;
        pm->op_pmregexp = CALLREGCOMP(aTHX_ p, p + plen, pm);
        if (strEQ("\\s+", pm->op_pmregexp->precomp))
diff --git a/perl.c b/perl.c
index 8c56df4..3f0c57a 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -2091,7 +2091,7 @@ Perl_moreswitches(pTHX_ char *s)
 #ifdef DEBUGGING
        forbid_setid("-D");
        if (isALPHA(s[1])) {
-           static char debopts[] = "psltocPmfrxuLHXDS";
+           static char debopts[] = "psltocPmfrxuLHXDST";
            char *d;
 
            for (s++; *s && (d = strchr(debopts,*s)); s++)
diff --git a/perl.h b/perl.h
index ebc4b48..01ee4b7 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -2136,6 +2136,7 @@ Gid_t getegid (void);
 #  else
 #    define DEBUG_S(a)
 #  endif
+#define DEBUG_T(a) if (PL_debug & (1<<17))     a
 #else
 #define DEB(a)
 #define DEBUG(a)
@@ -2156,6 +2157,7 @@ Gid_t getegid (void);
 #define DEBUG_X(a)
 #define DEBUG_D(a)
 #define DEBUG_S(a)
+#define DEBUG_T(a)
 #endif
 #define YYMAXDEPTH 300
 
index 03d3d0f..e12e2e1 100644 (file)
--- a/perlapi.c
+++ b/perlapi.c
@@ -3350,8 +3350,15 @@ Perl_utf16_to_utf8_reversed(pTHXo_ U8* p, U8 *d, I32 bytelen, I32 *newlen)
     return ((CPerlObj*)pPerl)->Perl_utf16_to_utf8_reversed(p, d, bytelen, newlen);
 }
 
+#undef  Perl_utf8_length
+STRLEN
+Perl_utf8_length(pTHXo_ U8* s, U8 *e)
+{
+    return ((CPerlObj*)pPerl)->Perl_utf8_length(s, e);
+}
+
 #undef  Perl_utf8_distance
-I32
+IV
 Perl_utf8_distance(pTHXo_ U8 *a, U8 *b)
 {
     return ((CPerlObj*)pPerl)->Perl_utf8_distance(a, b);
index be99949..e134979 100644 (file)
@@ -1165,7 +1165,7 @@ eligible for inlining at compile-time.
        void    newCONSTSUB(HV* stash, char* name, SV* sv)
 
 =for hackers
-Found in file op.c
+Found in file opmini.c
 
 =item newHV
 
@@ -1298,7 +1298,7 @@ Found in file sv.c
 Used by C<xsubpp> to hook up XSUBs as Perl subs.
 
 =for hackers
-Found in file op.c
+Found in file opmini.c
 
 =item newXSproto
 
@@ -3200,9 +3200,10 @@ If C<s> does not point to a well-formed UTF8 character, the behaviour
 is dependent on the value of C<flags>: if it contains UTF8_CHECK_ONLY,
 it is assumed that the caller will raise a warning, and this function
 will set C<retlen> to C<-1> and return.  The C<flags> can also contain
-various flags to allow deviations from the strict UTF-8 encoding.
+various flags to allow deviations from the strict UTF-8 encoding 
+(see F<utf8.h>).
 
-       U8* s   utf8_to_uv(STRLEN curlen, I32 *retlen, U32 flags)
+       U8* s   utf8_to_uv(STRLEN curlen, STRLEN *retlen, U32 flags)
 
 =for hackers
 Found in file utf8.c
index 37d5491..3b69179 100644 (file)
@@ -3800,6 +3800,10 @@ but in actual fact, you got
 
 So put in parentheses to say what you really mean.
 
+=item Wide character in %s
+
+(F) Perl met a wide character (>255) when it wasn't expecting one.
+
 =item write() on closed filehandle %s
 
 (W closed) The filehandle you're writing to got itself closed sometime
index d532912..4a4c957 100644 (file)
@@ -322,6 +322,7 @@ equivalent to B<-Dtls>):
     16384  X  Scratchpad allocation
     32768  D  Cleaning up
     65536  S  Thread synchronization
+   131072  T  Tokenising
 
 All these flags require B<-DDEBUGGING> when you compile the Perl
 executable.  See the F<INSTALL> file in the Perl source distribution 
diff --git a/proto.h b/proto.h
index 1390e48..c7c88a6 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -805,7 +805,8 @@ PERL_CALLCONV void  Perl_unshare_hek(pTHX_ HEK* hek);
 PERL_CALLCONV void     Perl_utilize(pTHX_ int aver, I32 floor, OP* version, OP* id, OP* arg);
 PERL_CALLCONV U8*      Perl_utf16_to_utf8(pTHX_ U8* p, U8 *d, I32 bytelen, I32 *newlen);
 PERL_CALLCONV U8*      Perl_utf16_to_utf8_reversed(pTHX_ U8* p, U8 *d, I32 bytelen, I32 *newlen);
-PERL_CALLCONV I32      Perl_utf8_distance(pTHX_ U8 *a, U8 *b);
+PERL_CALLCONV STRLEN   Perl_utf8_length(pTHX_ U8* s, U8 *e);
+PERL_CALLCONV IV       Perl_utf8_distance(pTHX_ U8 *a, U8 *b);
 PERL_CALLCONV U8*      Perl_utf8_hop(pTHX_ U8 *s, I32 off);
 PERL_CALLCONV U8*      Perl_utf8_to_bytes(pTHX_ U8 *s, STRLEN *len);
 PERL_CALLCONV U8*      Perl_bytes_to_utf8(pTHX_ U8 *s, STRLEN *len);
diff --git a/sv.c b/sv.c
index 1bd4b7a..899cd1b 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -2436,17 +2436,26 @@ bool
 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
 {
     if (SvPOK(sv) && SvUTF8(sv)) {
-        char *c = SvPVX(sv);
-       STRLEN len = SvCUR(sv) + 1;     /* include trailing NUL */
-        if (!utf8_to_bytes((U8*)c, &len)) {
-           if (fail_ok)
-               return FALSE;
-           else
-               Perl_croak(aTHX_ "big byte");
+        if (SvCUR(sv)) {
+           char *c = SvPVX(sv);
+           STRLEN len = SvCUR(sv);
+
+           if (!utf8_to_bytes((U8*)c, &len)) {
+               if (fail_ok)
+                   return FALSE;
+               else {
+                   if (PL_op)
+                       Perl_croak(aTHX_ "Wide character in %s",
+                                  PL_op_desc[PL_op->op_type]);
+                   else
+                       Perl_croak(aTHX_ "Wide character");
+               }
+           }
+           SvCUR(sv) = len;
        }
-       SvCUR(sv) = len - 1;
        SvUTF8_off(sv);
     }
+
     return TRUE;
 }
 
@@ -3955,26 +3964,20 @@ UTF8 bytes as a single character.
 STRLEN
 Perl_sv_len_utf8(pTHX_ register SV *sv)
 {
-    U8 *s;
-    U8 *send;
-    STRLEN len;
-
     if (!sv)
        return 0;
 
 #ifdef NOTYET
     if (SvGMAGICAL(sv))
-       len = mg_length(sv);
+       return mg_length(sv);
     else
 #endif
-       s = (U8*)SvPV(sv, len);
-    send = s + len;
-    len = 0;
-    while (s < send) {
-       s += UTF8SKIP(s);
-       len++;
+    {
+       STRLEN len;
+       U8 *s = (U8*)SvPV(sv, len);
+
+       return Perl_utf8_length(s, s + len);
     }
-    return len;
 }
 
 void
index 3580c5c..1090e11 100644 (file)
@@ -46,8 +46,8 @@ a[b-d]        aac     y       $&      ac
 a[-b]  a-      y       $&      a-
 a[b-]  a-      y       $&      a-
 a[b-a] -       c       -       Invalid [] range "b-a" before HERE mark in regex m/a[b-a << HERE ]/
-a[]b   -       c       -       Unmatched [ before HERE mark in regex m/a[ << HERE ]b/ at (eval 96) line 1, <TESTS> line 49.
-a[     -       c       -       Unmatched [ before HERE mark in regex m/a[ << HERE / at (eval 97) line 1, <TESTS> line 50.
+a[]b   -       c       -       Unmatched [ before HERE mark in regex m/a[ << HERE ]b/
+a[     -       c       -       Unmatched [ before HERE mark in regex m/a[ << HERE /
 a]     a]      y       $&      a]
 a[]]b  a]b     y       $&      a]b
 a[^bc]d        aed     y       $&      aed
@@ -95,21 +95,21 @@ a[\S]b      a-b     y       -       -
 ab|cd  abc     y       $&      ab
 ab|cd  abcd    y       $&      ab
 ()ef   def     y       $&-$1   ef-
-*a     -       c       -       Quantifier follows nothing before HERE mark in regex m/* << HERE a/ at (eval 192) line 1, <TESTS> line 98.
-(*)b   -       c       -       Quantifier follows nothing before HERE mark in regex m/(* << HERE )b/ at (eval 193) line 1, <TESTS> line 99.
+*a     -       c       -       Quantifier follows nothing before HERE mark in regex m/* << HERE a/
+(*)b   -       c       -       Quantifier follows nothing before HERE mark in regex m/(* << HERE )b/
 $b     b       n       -       -
 a\     -       c       -       Search pattern not terminated
 a\(b   a(b     y       $&-$1   a(b-
 a\(*b  ab      y       $&      ab
 a\(*b  a((b    y       $&      a((b
 a\\b   a\b     y       $&      a\b
-abc)   -       c       -       Unmatched ) before HERE mark in regex m/abc) << HERE / at (eval 205) line 1, <TESTS> line 106.
-(abc   -       c       -       Unmatched ( before HERE mark in regex m/( << HERE abc/ at (eval 206) line 1, <TESTS> line 107.
+abc)   -       c       -       Unmatched ) before HERE mark in regex m/abc) << HERE /
+(abc   -       c       -       Unmatched ( before HERE mark in regex m/( << HERE abc/
 ((a))  abc     y       $&-$1-$2        a-a-a
 (a)b(c)        abc     y       $&-$1-$2        abc-a-c
 a+b+c  aabbabc y       $&      abc
 a{1,}b{1,}c    aabbabc y       $&      abc
-a**    -       c       -       Nested quantifiers before HERE mark in regex m/a** << HERE / at (eval 215) line 1, <TESTS> line 112.
+a**    -       c       -       Nested quantifiers before HERE mark in regex m/a** << HERE /
 a.+?c  abcabc  y       $&      abc
 (a+|b)*        ab      y       $&-$1   ab-b
 (a+|b){0,}     ab      y       $&-$1   ab-b
@@ -117,7 +117,7 @@ a.+?c       abcabc  y       $&      abc
 (a+|b){1,}     ab      y       $&-$1   ab-b
 (a+|b)?        ab      y       $&-$1   a-a
 (a+|b){0,1}    ab      y       $&-$1   a-a
-)(     -       c       -       Unmatched ) before HERE mark in regex m/) << HERE (/ at (eval 230) line 1, <TESTS> line 120.
+)(     -       c       -       Unmatched ) before HERE mark in regex m/) << HERE (/
 [^ab]* cde     y       $&      cde
 abc            n       -       -
 a*             y       $&      
@@ -219,8 +219,8 @@ a[-]?c      ac      y       $&      ac
 'a[-b]'i       A-      y       $&      A-
 'a[b-]'i       A-      y       $&      A-
 'a[b-a]'i      -       c       -       Invalid [] range "b-a" before HERE mark in regex m/a[b-a << HERE ]/
-'a[]b'i        -       c       -       Unmatched [ before HERE mark in regex m/a[ << HERE ]b/ at (eval 431) line 1, <TESTS> line 222.
-'a['i  -       c       -       Unmatched [ before HERE mark in regex m/a[ << HERE / at (eval 432) line 1, <TESTS> line 223.
+'a[]b'i        -       c       -       Unmatched [ before HERE mark in regex m/a[ << HERE ]b/
+'a['i  -       c       -       Unmatched [ before HERE mark in regex m/a[ << HERE /
 'a]'i  A]      y       $&      A]
 'a[]]b'i       A]B     y       $&      A]B
 'a[^bc]d'i     AED     y       $&      AED
@@ -232,21 +232,21 @@ a[-]?c    ac      y       $&      ac
 'ab|cd'i       ABC     y       $&      AB
 'ab|cd'i       ABCD    y       $&      AB
 '()ef'i        DEF     y       $&-$1   EF-
-'*a'i  -       c       -       Quantifier follows nothing before HERE mark in regex m/* << HERE a/ at (eval 455) line 1, <TESTS> line 235.
-'(*)b'i        -       c       -       Quantifier follows nothing before HERE mark in regex m/(* << HERE )b/ at (eval 456) line 1, <TESTS> line 236.
+'*a'i  -       c       -       Quantifier follows nothing before HERE mark in regex m/* << HERE a/
+'(*)b'i        -       c       -       Quantifier follows nothing before HERE mark in regex m/(* << HERE )b/
 '$b'i  B       n       -       -
 'a\'i  -       c       -       Search pattern not terminated
 'a\(b'i        A(B     y       $&-$1   A(B-
 'a\(*b'i       AB      y       $&      AB
 'a\(*b'i       A((B    y       $&      A((B
 'a\\b'i        A\B     y       $&      A\B
-'abc)'i        -       c       -       Unmatched ) before HERE mark in regex m/abc) << HERE / at (eval 468) line 1, <TESTS> line 243.
-'(abc'i        -       c       -       Unmatched ( before HERE mark in regex m/( << HERE abc/ at (eval 469) line 1, <TESTS> line 244.
+'abc)'i        -       c       -       Unmatched ) before HERE mark in regex m/abc) << HERE /
+'(abc'i        -       c       -       Unmatched ( before HERE mark in regex m/( << HERE abc/
 '((a))'i       ABC     y       $&-$1-$2        A-A-A
 '(a)b(c)'i     ABC     y       $&-$1-$2        ABC-A-C
 'a+b+c'i       AABBABC y       $&      ABC
 'a{1,}b{1,}c'i AABBABC y       $&      ABC
-'a**'i -       c       -       Nested quantifiers before HERE mark in regex m/a** << HERE / at (eval 478) line 1, <TESTS> line 249.
+'a**'i -       c       -       Nested quantifiers before HERE mark in regex m/a** << HERE /
 'a.+?c'i       ABCABC  y       $&      ABC
 'a.*?c'i       ABCABC  y       $&      ABC
 'a.{0,5}?c'i   ABCABC  y       $&      ABC
@@ -257,7 +257,7 @@ a[-]?c      ac      y       $&      ac
 '(a+|b)?'i     AB      y       $&-$1   A-A
 '(a+|b){0,1}'i AB      y       $&-$1   A-A
 '(a+|b){0,1}?'i        AB      y       $&-$1   -
-')('i  -       c       -       Unmatched ) before HERE mark in regex m/) << HERE (/ at (eval 499) line 1, <TESTS> line 260.
+')('i  -       c       -       Unmatched ) before HERE mark in regex m/) << HERE (/
 '[^ab]*'i      CDE     y       $&      CDE
 'abc'i         n       -       -
 'a*'i          y       $&      
@@ -397,10 +397,10 @@ a(?:b|(c|e){1,2}?|d)+?(.) ace     y       $1$2    ce
 '(ab)\d\1'i    ab4Ab   y       $1      ab
 foo\w*\d{4}baz foobar1234baz   y       $&      foobar1234baz
 a(?{})b        cabd    y       $&      ab
-a(?{)b -       c       -       Sequence (?{...}) not terminated or not {}-balanced before HERE mark in regex m/a(?{ << HERE )b/ at (eval 780) line 1, <TESTS> line 400.
-a(?{{})b       -       c       -       Sequence (?{...}) not terminated or not {}-balanced before HERE mark in regex m/a(?{ << HERE {})b/ at (eval 781) line 1, <TESTS> line 401.
+a(?{)b -       c       -       Sequence (?{...}) not terminated or not {}-balanced before HERE mark in regex m/a(?{ << HERE )b/
+a(?{{})b       -       c       -       Sequence (?{...}) not terminated or not {}-balanced before HERE mark in regex m/a(?{ << HERE {})b/
 a(?{}})b       -       c       -       
-a(?{"{"})b     -       c       -       Sequence (?{...}) not terminated or not {}-balanced before HERE mark in regex m/a(?{ << HERE "{"})b/ at (eval 783) line 1, <TESTS> line 403.
+a(?{"{"})b     -       c       -       Sequence (?{...}) not terminated or not {}-balanced before HERE mark in regex m/a(?{ << HERE "{"})b/
 a(?{"\{"})b    cabd    y       $&      ab
 a(?{"{"}})b    -       c       -       Unmatched right curly bracket
 a(?{$bl="\{"}).b       caxbd   y       $bl     {
@@ -441,7 +441,7 @@ x(~~)*(?:(?:F)?)?   x~~     y       -       -
 ^(\(+)?blah(?(1)(\)))$ blah    y       ($2)    ()
 ^(\(+)?blah(?(1)(\)))$ blah)   n       -       -
 ^(\(+)?blah(?(1)(\)))$ (blah   n       -       -
-(?(1?)a|b)     a       c       -       Switch condition not recognized before HERE mark in regex m/(?(1? << HERE )a|b)/ at (eval 868) line 1, <TESTS> line 444.
+(?(1?)a|b)     a       c       -       Switch condition not recognized before HERE mark in regex m/(?(1? << HERE )a|b)/
 (?(1)a|b|c)    a       c       -       Switch (?(condition)... contains too many branches
 (?(?{0})a|b)   a       n       -       -
 (?(?{0})b|a)   a       y       $&      a
@@ -473,7 +473,7 @@ $(?<=^(a))  a       y       $1      a
 ([[:]+)        a:[b]:  y       $1      :[
 ([[=]+)        a=[b]=  y       $1      =[
 ([[.]+)        a.[b].  y       $1      .[
-[a[:xyz:       -       c       -       Unmatched [ before HERE mark in regex m/[ << HERE a[:xyz:/ at (eval 950) line 1, <TESTS> line 476.
+[a[:xyz:       -       c       -       Unmatched [ before HERE mark in regex m/[ << HERE a[:xyz:/
 [a[:xyz:]      -       c       -       POSIX class [:xyz:] unknown before HERE mark in regex m/[a[:xyz:] << HERE /
 [a[:]b[:c]     abc     y       $&      abc
 ([a[:xyz:]b]+) pbaq    c       -       POSIX class [:xyz:] unknown before HERE mark in regex m/([a[:xyz:] << HERE b]+)/
index 2fb5b7c..ab58206 100755 (executable)
@@ -569,12 +569,15 @@ sub nok_bytes {
 # http://www.cl.cam.ac.uk/~mgk25/ucs/examples/UTF-8-test.txt,
 # version dated 2000-09-02. 
 
+# Note the \0 instead of a raw zero byte in 2.1.1: for example
+# GNU patch v2.1 has "issues" with raw zero bytes.
+
 my @MK = split(/\n/, <<__EOMK__);
 1      Correct UTF-8
 1.1.1 y "κόσμε"  -               11      ce:ba:e1:bd:b9:cf:83:ce:bc:ce:b5        5
 2      Boundary conditions 
 2.1    First possible sequence of certain length
-2.1.1 y "\0                   0               1       00      1
+2.1.1 y "\0"                   0               1       00      1
 2.1.2 y "\80"                   80              2       c2:80   1
 2.1.3 y "ࠀ"          800             3       e0:a0:80        1
 2.1.4 y "𐀀"         10000           4       f0:90:80:80     1
diff --git a/toke.c b/toke.c
index 5d10691..937e992 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -2099,6 +2099,9 @@ Perl_yylex(pTHX)
        char pit = PL_pending_ident;
        PL_pending_ident = 0;
 
+       DEBUG_T({ PerlIO_printf(Perl_debug_log,
+              "### Tokener saw identifier '%s'\n", PL_tokenbuf); })
+
        /* if we're in a my(), we can't allow dynamics here.
           $foo'bar has already been turned into $foo::bar, so
           just check for colons.
@@ -2236,6 +2239,10 @@ Perl_yylex(pTHX)
            PL_expect = PL_lex_expect;
            PL_lex_defer = LEX_NORMAL;
        }
+       DEBUG_T({ PerlIO_printf(Perl_debug_log,
+              "### Next token after '%s' was known, type %"IVdf"\n", PL_bufptr,
+              (IV)PL_nexttype[PL_nexttoke]); })
+
        return(PL_nexttype[PL_nexttoke]);
 
     /* interpolated case modifiers like \L \U, including \Q and \E.
@@ -2267,6 +2274,8 @@ Perl_yylex(pTHX)
            return yylex();
        }
        else {
+           DEBUG_T({ PerlIO_printf(Perl_debug_log,
+              "### Saw case modifier at '%s'\n", PL_bufptr); })
            s = PL_bufptr + 1;
            if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
                tmp = *s, *s = s[2], s[2] = tmp;        /* misordered... */
@@ -2317,6 +2326,8 @@ Perl_yylex(pTHX)
     case LEX_INTERPSTART:
        if (PL_bufptr == PL_bufend)
            return sublex_done();
+       DEBUG_T({ PerlIO_printf(Perl_debug_log,
+              "### Interpolated variable at '%s'\n", PL_bufptr); })
        PL_expect = XTERM;
        PL_lex_dojoin = (*PL_bufptr == '@');
        PL_lex_state = LEX_INTERPNORMAL;
@@ -2413,7 +2424,7 @@ Perl_yylex(pTHX)
     s = PL_bufptr;
     PL_oldoldbufptr = PL_oldbufptr;
     PL_oldbufptr = s;
-    DEBUG_p( {
+    DEBUG_T( {
        PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at %s\n",
                      exp_name[PL_expect], s);
     } )
@@ -2433,6 +2444,9 @@ Perl_yylex(pTHX)
            PL_last_lop = 0;
            if (PL_lex_brackets)
                yyerror("Missing right curly or square bracket");
+            DEBUG_T( { PerlIO_printf(Perl_debug_log, 
+                        "### Tokener got EOF\n");
+            } )
            TOKEN(0);
        }
        if (s++ < PL_bufend)
@@ -2781,10 +2795,16 @@ Perl_yylex(pTHX)
 
            if (strnEQ(s,"=>",2)) {
                s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
+                DEBUG_T( { PerlIO_printf(Perl_debug_log, 
+                            "### Saw unary minus before =>, forcing word '%s'\n", s);
+                } )
                OPERATOR('-');          /* unary minus */
            }
            PL_last_uni = PL_oldbufptr;
            PL_last_lop_op = OP_FTEREAD;        /* good enough */
+            DEBUG_T( { PerlIO_printf(Perl_debug_log, 
+                        "### Saw file test %c\n", (int)tmp);
+            } )
            switch (tmp) {
            case 'r': FTST(OP_FTEREAD);
            case 'w': FTST(OP_FTEWRITE);
@@ -3560,12 +3580,18 @@ Perl_yylex(pTHX)
     case '0': case '1': case '2': case '3': case '4':
     case '5': case '6': case '7': case '8': case '9':
        s = scan_num(s, &yylval);
+        DEBUG_T( { PerlIO_printf(Perl_debug_log, 
+                    "### Saw number in '%s'\n", s);
+        } )
        if (PL_expect == XOPERATOR)
            no_op("Number",s);
        TERM(THING);
 
     case '\'':
        s = scan_str(s,FALSE,FALSE);
+        DEBUG_T( { PerlIO_printf(Perl_debug_log, 
+                    "### Saw string in '%s'\n", s);
+        } )
        if (PL_expect == XOPERATOR) {
            if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
                PL_expect = XTERM;
@@ -3582,6 +3608,9 @@ Perl_yylex(pTHX)
 
     case '"':
        s = scan_str(s,FALSE,FALSE);
+        DEBUG_T( { PerlIO_printf(Perl_debug_log, 
+                    "### Saw string in '%s'\n", s);
+        } )
        if (PL_expect == XOPERATOR) {
            if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
                PL_expect = XTERM;
@@ -3604,6 +3633,9 @@ Perl_yylex(pTHX)
 
     case '`':
        s = scan_str(s,FALSE,FALSE);
+        DEBUG_T( { PerlIO_printf(Perl_debug_log, 
+                    "### Saw backtick string in '%s'\n", s);
+        } )
        if (PL_expect == XOPERATOR)
            no_op("Backticks",s);
        if (!s)
diff --git a/utf8.c b/utf8.c
index 5694ce4..e61b037 100644 (file)
--- a/utf8.c
+++ b/utf8.c
@@ -69,7 +69,7 @@ Perl_uv_to_utf8(pTHX_ U8 *d, UV uv)
        return d;
     }
 #ifdef HAS_QUAD
-    if (uv < 0x1000000000LL)
+    if (uv < UTF8_QUAD_MAX)
 #endif
     {
        *d++ =                        0xfe;     /* Can't match U+FEFF! */
@@ -171,7 +171,7 @@ Perl_is_utf8_string(pTHX_ U8 *s, STRLEN len)
 }
 
 /*
-=for apidoc Am|U8* s|utf8_to_uv|STRLEN curlen|I32 *retlen|U32 flags
+=for apidoc Am|U8* s|utf8_to_uv|STRLEN curlen|STRLEN *retlen|U32 flags
 
 Returns the character value of the first character in the string C<s>
 which is assumed to be in UTF8 encoding and no longer than C<curlen>;
@@ -182,7 +182,8 @@ If C<s> does not point to a well-formed UTF8 character, the behaviour
 is dependent on the value of C<flags>: if it contains UTF8_CHECK_ONLY,
 it is assumed that the caller will raise a warning, and this function
 will set C<retlen> to C<-1> and return.  The C<flags> can also contain
-various flags to allow deviations from the strict UTF-8 encoding.
+various flags to allow deviations from the strict UTF-8 encoding 
+(see F<utf8.h>).
 
 =cut */
 
@@ -350,28 +351,67 @@ returned and retlen is set, if possible, to -1.
 UV
 Perl_utf8_to_uv_simple(pTHX_ U8* s, STRLEN* retlen)
 {
-    return Perl_utf8_to_uv(aTHX_ s, (STRLEN)-1, retlen, 0);
+    return Perl_utf8_to_uv(aTHX_ s, UTF8_MAXLEN, retlen, 0);
+}
+
+/*
+=for apidoc|utf8_length|U8 *s|U8 *e
+
+Return the length of the UTF-8 char encoded string C<s> in characters.
+Stops at C<e> (inclusive).  If C<e E<lt> s> or if the scan would end
+up past C<e>, croaks.
+
+=cut
+*/
+
+STRLEN
+Perl_utf8_length(pTHX_ U8* s, U8* e)
+{
+    STRLEN len = 0;
+
+    if (e < s)
+       Perl_croak(aTHX_ "panic: utf8_length: unexpected end");
+    while (s < e) {
+       U8 t = UTF8SKIP(s);
+
+       if (e - s < t)
+           Perl_croak(aTHX_ "panic: utf8_length: unaligned end");
+       s += t;
+       len++;
+    }
+
+    return len;
 }
 
 /* utf8_distance(a,b) returns the number of UTF8 characters between
    the pointers a and b                                                        */
 
-I32
+IV
 Perl_utf8_distance(pTHX_ U8 *a, U8 *b)
 {
-    I32 off = 0;
+    IV off = 0;
+
     if (a < b) {
        while (a < b) {
-           a += UTF8SKIP(a);
+           U8 c = UTF8SKIP(a);
+
+           if (b - a < c)
+               Perl_croak(aTHX_ "panic: utf8_distance: unaligned end");
+           a += c;
            off--;
        }
     }
     else {
        while (b < a) {
-           b += UTF8SKIP(b);
+           U8 c = UTF8SKIP(b);
+
+           if (a - b < c)
+               Perl_croak(aTHX_ "panic: utf8_distance: unaligned end");
+           b += c;
            off++;
        }
     }
+
     return off;
 }
 
@@ -961,7 +1001,7 @@ Perl_to_utf8_upper(pTHX_ U8 *p)
     if (!PL_utf8_toupper)
        PL_utf8_toupper = swash_init("utf8", "ToUpper", &PL_sv_undef, 4, 0);
     uv = swash_fetch(PL_utf8_toupper, p);
-    return uv ? uv : utf8_to_uv(p,STRLEN_MAX,0,0);
+    return uv ? uv : utf8_to_uv(p,UTF8_MAXLEN,0,0);
 }
 
 UV
@@ -972,7 +1012,7 @@ Perl_to_utf8_title(pTHX_ U8 *p)
     if (!PL_utf8_totitle)
        PL_utf8_totitle = swash_init("utf8", "ToTitle", &PL_sv_undef, 4, 0);
     uv = swash_fetch(PL_utf8_totitle, p);
-    return uv ? uv : utf8_to_uv(p,STRLEN_MAX,0,0);
+    return uv ? uv : utf8_to_uv(p,UTF8_MAXLEN,0,0);
 }
 
 UV
@@ -983,7 +1023,7 @@ Perl_to_utf8_lower(pTHX_ U8 *p)
     if (!PL_utf8_tolower)
        PL_utf8_tolower = swash_init("utf8", "ToLower", &PL_sv_undef, 4, 0);
     uv = swash_fetch(PL_utf8_tolower, p);
-    return uv ? uv : utf8_to_uv(p,STRLEN_MAX,0,0);
+    return uv ? uv : utf8_to_uv(p,UTF8_MAXLEN,0,0);
 }
 
 /* a "swash" is a swatch hash */
@@ -1073,7 +1113,7 @@ Perl_swash_fetch(pTHX_ SV *sv, U8 *ptr)
            PUSHMARK(SP);
            EXTEND(SP,3);
            PUSHs((SV*)sv);
-           PUSHs(sv_2mortal(newSViv(utf8_to_uv(ptr, STRLEN_MAX, 0, 0) & ~(needents - 1))));
+           PUSHs(sv_2mortal(newSViv(utf8_to_uv(ptr, UTF8_MAXLEN, 0, 0) & ~(needents - 1))));
            PUSHs(sv_2mortal(newSViv(needents)));
            PUTBACK;
            if (call_method("SWASHGET", G_SCALAR))
diff --git a/utf8.h b/utf8.h
index 269ad3e..522f4a9 100644 (file)
--- a/utf8.h
+++ b/utf8.h
@@ -9,6 +9,8 @@
 
 START_EXTERN_C
 
+#include "handy.h"
+
 #ifdef DOINIT
 EXTCONST unsigned char PL_utf8skip[] = {
 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, /* ascii */
@@ -48,6 +50,8 @@ END_EXTERN_C
 
 #define UTF8SKIP(s) PL_utf8skip[*(U8*)s]
 
+#define UTF8_QUAD_MAX  UINT64_C(0x1000000000)
+
 #ifdef HAS_QUAD
 #define UNISKIP(uv) ( (uv) < 0x80           ? 1 : \
                      (uv) < 0x800          ? 2 : \
@@ -55,7 +59,7 @@ END_EXTERN_C
                      (uv) < 0x200000       ? 4 : \
                      (uv) < 0x4000000      ? 5 : \
                      (uv) < 0x80000000     ? 6 : \
-                      (uv) < 0x1000000000LL ? 7 : 13 ) 
+                      (uv) < UTF8_QUAD_MAX ? 7 : 13 ) 
 #else
 /* No, I'm not even going to *TRY* putting #ifdef inside a #define */
 #define UNISKIP(uv) ( (uv) < 0x80           ? 1 : \