This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Integrate changes #7941,7943,7944,7958,7967,7995,7996,7998,
authorJarkko Hietaniemi <jhi@iki.fi>
Sat, 27 Jan 2001 22:15:46 +0000 (22:15 +0000)
committerJarkko Hietaniemi <jhi@iki.fi>
Sat, 27 Jan 2001 22:15:46 +0000 (22:15 +0000)
8004,8005,8023,8024,8028,8030,8031,8033,8039,8042,8052[perlio],
8053[perlio],8054[perlio,+sv.c(-PerlIO_isutf8),+require.t],
8084,8204,8244,8333 from mainline.

For -Q where Q might be a one-letter sub name one does no more
get a warning about an unknown filetest (7941,7943,7944,8084).

Subject: Re: [ID 20001130.011] expression parsing bug ?

Make uv_to_utf8() to zero-terminate its output buffer.

Split off t/op/length.t (7995)

Split off t/op/utf8decode.t (7996)

Remove an unnecessary 'use utf8' from the utf8.t (7998)

Split off t/op/concat.t (8004)

Split off t/op/ver.t (8005)

Document utf8_length(), utf8_distance(), and utf8_hop().

Document utf8_to_uv() better.

Introduce macros for UTF8 decoding (8028,8033).

Add test for reverse() (8030,8031).

Subject: [PATCH] Re: ebcdic <-> ascii tables interjected in uv <-> utf8 considered harmful (8039,8333)

Do not return the Unicode replacement character on UTF-8
decoding failure.

Typo/thinko in S_scan_const() - seeing high bit sets has_utf8
not this_utf8 i.e. the output string has one, but don't mess
with source assumption. (8052,8053)

Tweak t/comp/require.t to add a 'use bytes' to permit its dubious
writing of BOM to a non-utf8 stream.  Fix SvPVutf8() - sv_2pv()
was not expecting to be called with something that was already
SvPOK() - (we just fossiked with SvUTF8 bit). Fix that and also
just use the SvPV macro in sv_2pvutf8() to avoid the issue/overhead.
(8054)

Recode the naughty binary bytes in utf8decode.t using the \xHH.

Make some panic messages a bit more logical.

p4raw-link: @7967 on //depot/perl: ad391ad9bbfeaf73d3944b50240313a5677bcc60
p4raw-link: @7958 on //depot/perl: 7b3fae3c4b820c030a968065a87feacf276c7a7f
p4raw-link: @7944 on //depot/perl: e5edeb50dffa2b3a1d6245f54a443cff2a31eb3f
p4raw-link: @7943 on //depot/perl: 4c32f29ba9da41e214e9e03a44a530ee0427f19a
p4raw-link: @7941 on //depot/perl: 3451b8f41d00bcd648d86872b906a29e6c9a3d51

p4raw-id: //depot/maint-5.6/perl@8570
p4raw-integrated: from //depot/perlio@8569 'copy in' t/comp/require.t
(@7388..)
p4raw-integrated: from //depot/perlio@8054 'edit in' MANIFEST (@8048..)
sv.c (@8049..)
p4raw-integrated: from //depot/perlio@8053 'edit in' toke.c (@8052..)
p4raw-branched: from //depot/perl@8569 'branch in' t/op/concat.t
t/op/reverse.t t/op/utf8decode.t (@8143..)
p4raw-integrated: from //depot/perl@8569 'copy in'
lib/ExtUtils/Liblist.pm (@8074..) 'edit in' t/pragma/warn/toke
(@7944..)
p4raw-integrated: from //depot/perl@8333 'edit in' doop.c (@8328..)
p4raw-integrated: from //depot/perl@8244 'edit in' pod/perldiag.pod
pp_hot.c (@8234..) pp.c (@8243..)
p4raw-integrated: from //depot/perl@8084 'edit in' toke.c (@8058..)
p4raw-integrated: from //depot/perl@8042 'edit in' utf8.c (@8039..)
'ignore' pod/perlapi.pod (@8033..)
p4raw-integrated: from //depot/perl@8033 'edit in' utf8.h (@8028..)
p4raw-integrated: from //depot/perl@8031 'edit in' MANIFEST (@8030..)
p4raw-integrated: from //depot/perl@8028 'copy in' t/pragma/warn/utf8
(@7697..)
p4raw-integrated: from //depot/perl@8023 'merge in' embed.pl (@7991..)
p4raw-integrated: from //depot/perl@8005 'copy in' t/op/ver.t (@7194..)
'edit in' t/pragma/utf8.t (@8004..)
p4raw-branched: from //depot/perl@7995 'branch in' t/op/length.t
p4raw-integrated: from //depot/perl@7967 'edit in' sv.c (@7936..)
'merge in' regcomp.c regexec.c (@7940..) op.c (@7959..)
p4raw-integrated: from //depot/perl@7943 'copy in' t/op/misc.t
(@7941..)

22 files changed:
MANIFEST
doop.c
embed.pl
op.c
pod/perlapi.pod
pod/perldiag.pod
pp.c
pp_hot.c
regcomp.c
regexec.c
sv.c
t/comp/require.t
t/op/concat.t [new file with mode: 0644]
t/op/length.t [new file with mode: 0644]
t/op/reverse.t [new file with mode: 0644]
t/op/utf8decode.t [new file with mode: 0644]
t/op/ver.t
t/pragma/utf8.t
t/pragma/warn/utf8
toke.c
utf8.c
utf8.h

index bb127f0..8ab83fc 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -1413,6 +1413,7 @@ t/op/chars.t              See if character escapes work
 t/op/chop.t            See if chop works
 t/op/closure.t         See if closures work
 t/op/cmp.t             See if the various string and numeric compare work
+t/op/concat.t          See if string concatenation works
 t/op/cond.t            See if conditional expressions work
 t/op/context.t         See if context propagation works
 t/op/defins.t          See if auto-insert of defined() works
@@ -1441,6 +1442,7 @@ t/op/inc.t                See if inc/dec of integers near 32 bit limit work
 t/op/index.t           See if index works
 t/op/int.t             See if int works
 t/op/join.t            See if join works
+t/op/length.t          See if length works
 t/op/lex_assign.t      See if ops involving lexicals or pad temps work
 t/op/lfs.t             See if large files work for perlio
 t/op/list.t            See if array lists work
@@ -1473,6 +1475,7 @@ t/op/regexp.t             See if regular expressions work
 t/op/regexp_noamp.t    See if regular expressions work with optimizations
 t/op/regmesg.t         See if one can get regular expression errors
 t/op/repeat.t          See if x operator works
+t/op/reverse.t         See if reverse operator works
 t/op/runlevel.t                See if die() works from perl_call_*()
 t/op/sleep.t           See if sleep works
 t/op/sort.t            See if sort works
@@ -1495,6 +1498,7 @@ t/op/tr.t         See if tr works
 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
+t/op/utf8decode.t      See if UTF-8 decoding works
 t/op/vec.t             See if vectors work
 t/op/ver.t             See if v-strings and the %v format flag work
 t/op/wantarray.t       See if wantarray works
diff --git a/doop.c b/doop.c
index edd20a3..5c07c5e 100644 (file)
--- a/doop.c
+++ b/doop.c
@@ -47,7 +47,7 @@ S_do_trans_simple(pTHX_ SV *sv)
 
     tbl = (short*)cPVOP->op_pv;
     if (!tbl)
-       Perl_croak(aTHX_ "panic: do_trans");
+       Perl_croak(aTHX_ "panic: do_trans_simple");
 
     s = (U8*)SvPV(sv, len);
     send = s + len;
@@ -78,10 +78,7 @@ S_do_trans_simple(pTHX_ SV *sv)
        c = utf8_to_uv(s, send - s, &ulen, 0);
         if (c < 0x100 && (ch = tbl[(short)c]) >= 0) {
             matches++;
-            if (ch < 0x80)
-                *d++ = ch;
-            else
-                d = uv_to_utf8(d,ch);
+           d = uv_to_utf8(d, ch);
             s += ulen;
         }
        else { /* No match -> copy */
@@ -110,7 +107,7 @@ S_do_trans_count(pTHX_ SV *sv)/* SPC - OK */
 
     tbl = (short*)cPVOP->op_pv;
     if (!tbl)
-       Perl_croak(aTHX_ "panic: do_trans");
+       Perl_croak(aTHX_ "panic: do_trans_count");
 
     s = (U8*)SvPV(sv, len);
     send = s + len;
@@ -151,7 +148,7 @@ S_do_trans_complex(pTHX_ SV *sv)/* SPC - NOT OK */
 
     tbl = (short*)cPVOP->op_pv;
     if (!tbl)
-       Perl_croak(aTHX_ "panic: do_trans");
+       Perl_croak(aTHX_ "panic: do_trans_complex");
 
     s = (U8*)SvPV(sv, len);
     send = s + len;
@@ -193,12 +190,9 @@ S_do_trans_complex(pTHX_ SV *sv)/* SPC - NOT OK */
                matches--;
            }
 
-           if (ch >= 0) {
-               if (hasutf)
-                 d = uv_to_utf8(d, ch);
-               else 
-                 *d++ = ch;
-           }
+           if (ch >= 0)
+               d = uv_to_utf8(d, ch);
+           
            matches++;
 
            s += hasutf && *s & 0x80 ? UNISKIP(*s) : 1;
index 8c0ce34..e815a44 100755 (executable)
--- a/embed.pl
+++ b/embed.pl
@@ -2077,7 +2077,7 @@ ApM       |U8*    |utf8_to_bytes  |U8 *s|STRLEN *len
 ApM    |U8*    |bytes_to_utf8  |U8 *s|STRLEN *len
 Ap     |UV     |utf8_to_uv_simple|U8 *s|STRLEN* retlen
 Ap     |UV     |utf8_to_uv     |U8 *s|STRLEN curlen|STRLEN* retlen|U32 flags
-Ap     |U8*    |uv_to_utf8|U8 *d|UV uv
+Ap     |U8*    |uv_to_utf8     |U8 *d|UV uv
 p      |void   |vivify_defelem |SV* sv
 p      |void   |vivify_ref     |SV* sv|U32 to_what
 p      |I32    |wait4pid       |Pid_t pid|int* statusp|int flags
diff --git a/op.c b/op.c
index 9b4437f..cce043c 100644 (file)
--- a/op.c
+++ b/op.c
@@ -2637,7 +2637,7 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
        I32 to_utf      = o->op_private & OPpTRANS_TO_UTF;
 
        if (complement) {
-           U8 tmpbuf[UTF8_MAXLEN];
+           U8 tmpbuf[UTF8_MAXLEN+1];
            U8** cp;
            I32* cl;
            UV nextmin = 0;
index e134979..9f00c3c 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 opmini.c
+Found in file op.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 opmini.c
+Found in file op.c
 
 =item newXSproto
 
@@ -2342,19 +2342,19 @@ false, defined or undefined.  Does not handle 'get' magic.
 =for hackers
 Found in file sv.h
 
-=item SvTYPE
-
-Returns the type of the SV.  See C<svtype>.
+=item svtype
 
-       svtype  SvTYPE(SV* sv)
+An enum of flags for Perl types.  These are found in the file B<sv.h> 
+in the C<svtype> enum.  Test these flags with the C<SvTYPE> macro.
 
 =for hackers
 Found in file sv.h
 
-=item svtype
+=item SvTYPE
 
-An enum of flags for Perl types.  These are found in the file B<sv.h> 
-in the C<svtype> enum.  Test these flags with the C<SvTYPE> macro.
+Returns the type of the SV.  See C<svtype>.
+
+       svtype  SvTYPE(SV* sv)
 
 =for hackers
 Found in file sv.h
@@ -3177,6 +3177,44 @@ string, false otherwise.
 =for hackers
 Found in file utf8.c
 
+=item utf8_distance
+
+Returns the number of UTF8 characters between the UTF-8 pointers C<a>
+and C<b>.
+
+WARNING: use only if you *know* that the pointers point inside the
+same UTF-8 buffer.
+
+       IV      utf8_distance(U8 *a, U8 *b)
+
+=for hackers
+Found in file utf8.c
+
+=item utf8_hop
+
+Return the UTF-8 pointer C<s> displaced by C<off> characters, either
+forward or backward.
+
+WARNING: do not use the following unless you *know* C<off> is within
+the UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned
+on the first byte of character or just after the last byte of a character.
+
+       U8*     utf8_hop(U8 *s, I32 off)
+
+=for hackers
+Found in file utf8.c
+
+=item utf8_length
+
+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.
+
+       STRLEN  utf8_length(U8* s, U8 *e)
+
+=for hackers
+Found in file utf8.c
+
 =item utf8_to_bytes
 
 Converts a string C<s> of length C<len> from UTF8 into byte encoding.
@@ -3199,9 +3237,13 @@ and the pointer C<s> will be advanced to the end of the character.
 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 
-(see F<utf8.h>).
+will silently just set C<retlen> to C<-1> and return zero.  If the
+C<flags> does not contain UTF8_CHECK_ONLY, warnings about
+malformations will be given, C<retlen> will be set to the expected
+length of the UTF-8 character in bytes, and zero will be returned.
+
+The C<flags> can also contain various flags to allow deviations from
+the strict UTF-8 encoding (see F<utf8.h>).
 
        U8* s   utf8_to_uv(STRLEN curlen, STRLEN *retlen, U32 flags)
 
index 3b69179..b680687 100644 (file)
@@ -2364,23 +2364,19 @@ reference.
 (P) We popped the context stack to an eval context, and then discovered
 it wasn't an eval context.
 
-=item panic: do_match
+=item panic: pp_match
 
 (P) The internal pp_match() routine was called with invalid operational
 data.
 
-=item panic: do_split
-
-(P) Something terrible went wrong in setting up for the split.
-
 =item panic: do_subst
 
 (P) The internal pp_subst() routine was called with invalid operational
 data.
 
-=item panic: do_trans
+=item panic: do_trans_%s
 
-(P) The internal do_trans() routine was called with invalid operational
+(P) The internal do_trans routines were called with invalid operational
 data.
 
 =item panic: frexp
@@ -2472,6 +2468,10 @@ and freeing temporaries and lexicals from.
 
 (P) The foreach iterator got called in a non-loop context frame.
 
+=item panic: pp_split
+
+(P) Something terrible went wrong in setting up for the split.
+
 =item panic: realloc
 
 (P) Something requested a negative number of bytes of realloc.
diff --git a/pp.c b/pp.c
index 0e48319..a366832 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -2313,7 +2313,7 @@ PP(pp_ucfirst)
 
     if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
        STRLEN ulen;
-       U8 tmpbuf[UTF8_MAXLEN];
+       U8 tmpbuf[UTF8_MAXLEN+1];
        U8 *tend;
        UV uv = utf8_to_uv(s, slen, &ulen, 0);
 
@@ -2372,7 +2372,7 @@ PP(pp_lcfirst)
 
     if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
        STRLEN ulen;
-       U8 tmpbuf[UTF8_MAXLEN];
+       U8 tmpbuf[UTF8_MAXLEN+1];
        U8 *tend;
        UV uv = utf8_to_uv(s, slen, &ulen, 0);
 
@@ -4715,7 +4715,7 @@ PP(pp_pack)
            while (len-- > 0) {
                fromstr = NEXTFROM;
                auint = SvUV(fromstr);
-               SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN);
+               SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
                SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
                               - SvPVX(cat));
            }
@@ -5059,7 +5059,7 @@ PP(pp_split)
     pm = (PMOP*)POPs;
 #endif
     if (!pm || !s)
-       DIE(aTHX_ "panic: do_split");
+       DIE(aTHX_ "panic: pp_split");
     rx = pm->op_pmregexp;
 
     TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
index 0673045..15a9ccd 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -142,19 +142,19 @@ PP(pp_concat)
     dPOPTOPssrl;
     STRLEN len;
     U8 *s;
-    bool left_utf;
-    bool right_utf;
+    bool left_utf8;
+    bool right_utf8;
 
     if (TARG == right && SvGMAGICAL(right))
         mg_get(right);
     if (SvGMAGICAL(left))
         mg_get(left);
 
-    left_utf  = DO_UTF8(left);
-    right_utf = DO_UTF8(right);
+    left_utf8  = DO_UTF8(left);
+    right_utf8 = DO_UTF8(right);
  
-    if (left_utf != right_utf) {
-        if (TARG == right && !right_utf) {
+    if (left_utf8 != right_utf8) {
+        if (TARG == right && !right_utf8) {
             sv_utf8_upgrade(TARG); /* Now straight binary copy */
             SvUTF8_on(TARG);
         }
@@ -163,7 +163,7 @@ PP(pp_concat)
             U8 *l, *c, *olds = NULL;
             STRLEN targlen;
            s = (U8*)SvPV(right,len);
-           right_utf |= DO_UTF8(right);
+           right_utf8 |= DO_UTF8(right);
             if (TARG == right) {
                /* Take a copy since we're about to overwrite TARG */
                olds = s = (U8*)savepvn((char*)s, len);
@@ -175,28 +175,28 @@ PP(pp_concat)
                    sv_setpv(left, ""); /* Suppress warning. */
            }
             l = (U8*)SvPV(left, targlen);
-           left_utf |= DO_UTF8(left);
+           left_utf8 |= DO_UTF8(left);
             if (TARG != left)
                 sv_setpvn(TARG, (char*)l, targlen);
-            if (!left_utf)
+            if (!left_utf8)
                 sv_utf8_upgrade(TARG);
             /* Extend TARG to length of right (s) */
             targlen = SvCUR(TARG) + len;
-            if (!right_utf) {
+            if (!right_utf8) {
                 /* plus one for each hi-byte char if we have to upgrade */
                 for (c = s; c < s + len; c++)  {
-                    if (*c & 0x80)
+                    if (UTF8_IS_CONTINUED(*c))
                         targlen++;
                 }
             }
             SvGROW(TARG, targlen+1);
             /* And now copy, maybe upgrading right to UTF8 on the fly */
-            for (c = (U8*)SvEND(TARG); len--; s++) {
-                 if (*s & 0x80 && !right_utf)
-                     c = uv_to_utf8(c, *s);
-                 else
-                     *c++ = *s;
-            }
+           if (right_utf8)
+               Copy(s, SvEND(TARG), len, U8);
+           else {
+               for (c = (U8*)SvEND(TARG); len--; s++)
+                   c = uv_to_utf8(c, *s);
+           }
             SvCUR_set(TARG, targlen);
             *SvEND(TARG) = '\0';
             SvUTF8_on(TARG);
@@ -235,7 +235,7 @@ PP(pp_concat)
     }
     else
        sv_setpvn(TARG, (char *)s, len);        /* suppress warning */
-    if (left_utf)
+    if (left_utf8)
        SvUTF8_on(TARG);
     SETTARG;
     RETURN;
@@ -1020,7 +1020,7 @@ PP(pp_match)
     s = SvPV(TARG, len);
     strend = s + len;
     if (!s)
-       DIE(aTHX_ "panic: do_match");
+       DIE(aTHX_ "panic: pp_match");
     rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
                 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
     TAINT_NOT;
@@ -1819,7 +1819,7 @@ PP(pp_subst)
 
   force_it:
     if (!pm || !s)
-       DIE(aTHX_ "panic: do_subst");
+       DIE(aTHX_ "panic: pp_subst");
 
     strend = s + len;
     maxiters = 2*(strend - s) + 10;    /* We can match twice at each 
index 975eeda..17fca93 100644 (file)
--- a/regcomp.c
+++ b/regcomp.c
@@ -3996,13 +3996,7 @@ STATIC void
 S_reguni(pTHX_ UV uv, char* s, STRLEN* lenp)
 {
     dTHR;
-    if (SIZE_ONLY) {
-       U8 tmpbuf[UTF8_MAXLEN];
-       *lenp = uv_to_utf8(tmpbuf, uv) - tmpbuf;
-    }
-    else
-       *lenp = uv_to_utf8((U8*)s, uv) - (U8*)s;
-
+    *lenp = SIZE_ONLY ? UNISKIP(uv) : (uv_to_utf8((U8*)s, uv) - (U8*)s);
 }
 
 /*
index d22101a..b3d281b 100644 (file)
--- a/regexec.c
+++ b/regexec.c
@@ -3819,7 +3819,7 @@ S_reginclassutf8(pTHX_ regnode *f, U8 *p)
     if (swash_fetch(sw, p))
        match = TRUE;
     else if (flags & ANYOF_FOLD) {
-       U8 tmpbuf[UTF8_MAXLEN];
+       U8 tmpbuf[UTF8_MAXLEN+1];
        if (flags & ANYOF_LOCALE) {
            PL_reg_flags |= RF_tainted;
            uv_to_utf8(tmpbuf, toLOWER_LC_utf8(p));
diff --git a/sv.c b/sv.c
index 68d1c1e..3bc2d63 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -2206,7 +2206,11 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
            return "";
        }
     }
-    if (SvNOKp(sv)) {                  /* See note in sv_2uv() */
+    if (SvPOK(sv)) {
+       *lp = SvCUR(sv);
+       return SvPVX(sv);
+    }
+    else if (SvNOKp(sv)) {                     /* See note in sv_2uv() */
        /* XXXX 64-bit?  IV may have better precision... */
        /* I tried changing this to be 64-bit-aware and
         * the t/op/numconvert.t became very, very, angry.
@@ -2345,7 +2349,7 @@ char *
 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
 {
     sv_utf8_upgrade(sv);
-    return sv_2pv(sv,lp);
+    return SvPV(sv,*lp);
 }
  
 /* This function is only called on magical items */
@@ -4324,14 +4328,23 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
 #endif
       SvCUR_set(sv, bytesread);
       buffer[bytesread] = '\0';
+      SvUTF8_off(sv);
       return(SvCUR(sv) ? SvPVX(sv) : Nullch);
     }
     else if (RsPARA(PL_rs)) {
        rsptr = "\n\n";
        rslen = 2;
     }
-    else
+    else {
+       /* Get $/ i.e. PL_rs into same encoding as stream wants */
+       if (SvUTF8(PL_rs)) {
+           if (!sv_utf8_downgrade(PL_rs, TRUE)) {
+               Perl_croak(aTHX_ "Wide character in $/");
+           }
+       }
        rsptr = SvPV(PL_rs, rslen);
+    }
+
     rslast = rslen ? rsptr[rslen - 1] : '\0';
 
     if (RsPARA(PL_rs)) {               /* have to do this both before and after */
@@ -4550,6 +4563,8 @@ screamer2:
        }
     }
 
+    SvUTF8_off(sv);
+
     return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
 }
 
@@ -5998,7 +6013,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
        bool is_utf = FALSE;
 
        char esignbuf[4];
-       U8 utf8buf[UTF8_MAXLEN];
+       U8 utf8buf[UTF8_MAXLEN+1];
        STRLEN esignlen = 0;
 
        char *eptr = Nullch;
index eaea3ad..e634532 100755 (executable)
@@ -21,6 +21,7 @@ sub write_file {
     my $f = shift;
     open(REQ,">$f") or die "Can't write '$f': $!";
     binmode REQ;
+    use bytes;
     print REQ @_;
     close REQ;
 }
@@ -132,7 +133,7 @@ $i++; do_require(qq(${utf8}print "ok $i\n"; 1;\n));
 
 sub bytes_to_utf16 {
     my $utf16 = pack("$_[0]*", unpack("C*", $_[1]));
-    return @_ == 3 && $_[2] ? pack("$_[0]", 0xFEFF) . $utf16 : $utf16; 
+    return @_ == 3 && $_[2] ? pack("$_[0]", 0xFEFF) . $utf16 : $utf16;
 }
 
 $i++; do_require(bytes_to_utf16('n', qq(print "ok $i\\n"; 1;\n), 1)); # BE
diff --git a/t/op/concat.t b/t/op/concat.t
new file mode 100644 (file)
index 0000000..76074e0
--- /dev/null
@@ -0,0 +1,100 @@
+#!./perl
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+}
+
+print "1..11\n";
+
+($a, $b, $c) = qw(foo bar);
+
+print "not " unless "$a" eq "foo";
+print "ok 1\n";
+
+print "not " unless "$a$b" eq "foobar";
+print "ok 2\n";
+
+print "not " unless "$c$a$c" eq "foo";
+print "ok 3\n";
+
+# Okay, so that wasn't very challenging.  Let's go Unicode.
+
+my $test = 4;
+
+{
+    # bug id 20000819.004 
+
+    $_ = $dx = "\x{10f2}";
+    s/($dx)/$dx$1/;
+    {
+       use bytes;
+       print "not " unless $_ eq "$dx$dx";
+       print "ok $test\n";
+       $test++;
+    }
+
+    $_ = $dx = "\x{10f2}";
+    s/($dx)/$1$dx/;
+    {
+       use bytes;
+       print "not " unless $_ eq "$dx$dx";
+       print "ok $test\n";
+       $test++;
+    }
+
+    $dx = "\x{10f2}";
+    $_  = "\x{10f2}\x{10f2}";
+    s/($dx)($dx)/$1$2/;
+    {
+       use bytes;
+       print "not " unless $_ eq "$dx$dx";
+       print "ok $test\n";
+       $test++;
+    }
+}
+
+{
+    # bug id 20000901.092
+    # test that undef left and right of utf8 results in a valid string
+
+    my $a;
+    $a .= "\x{1ff}";
+    print "not " unless $a eq "\x{1ff}";
+    print "ok $test\n";
+    $test++;
+}
+
+{
+    # ID 20001020.006
+
+    "x" =~ /(.)/; # unset $2
+
+    # Without the fix this 5.7.0 would croak:
+    # Modification of a read-only value attempted at ...
+    "$2\x{1234}";
+
+    print "ok $test\n";
+    $test++;
+
+    # For symmetry with the above.
+    "\x{1234}$2";
+
+    print "ok $test\n";
+    $test++;
+
+    *pi = \undef;
+    # This bug existed earlier than the $2 bug, but is fixed with the same
+    # patch. Without the fix this 5.7.0 would also croak:
+    # Modification of a read-only value attempted at ...
+    "$pi\x{1234}";
+
+    print "ok $test\n";
+    $test++;
+
+    # For symmetry with the above.
+    "\x{1234}$pi";
+
+    print "ok $test\n";
+    $test++;
+}
diff --git a/t/op/length.t b/t/op/length.t
new file mode 100644 (file)
index 0000000..ceb005e
--- /dev/null
@@ -0,0 +1,85 @@
+#!./perl
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+}
+
+print "1..13\n";
+
+print "not " unless length("")    == 0;
+print "ok 1\n";
+
+print "not " unless length("abc") == 3;
+print "ok 2\n";
+
+$_ = "foobar";
+print "not " unless length()      == 6;
+print "ok 3\n";
+
+# Okay, so that wasn't very challenging.  Let's go Unicode.
+
+{
+    my $a = "\x{41}";
+
+    print "not " unless length($a) == 1;
+    print "ok 4\n";
+    $test++;
+
+    use bytes;
+    print "not " unless $a eq "\x41" && length($a) == 1;
+    print "ok 5\n";
+    $test++;
+}
+
+{
+    my $a = "\x{80}";
+    
+    print "not " unless length($a) == 1;
+    print "ok 6\n";
+    $test++;
+    
+    use bytes;
+    print "not " unless $a eq "\xc2\x80" && length($a) == 2;
+    print "ok 7\n";
+    $test++;
+}
+
+{
+    my $a = "\x{100}";
+    
+    print "not " unless length($a) == 1;
+    print "ok 8\n";
+    $test++;
+    
+    use bytes;
+    print "not " unless $a eq "\xc4\x80" && length($a) == 2;
+    print "ok 9\n";
+    $test++;
+}
+
+{
+    my $a = "\x{100}\x{80}";
+    
+    print "not " unless length($a) == 2;
+    print "ok 10\n";
+    $test++;
+    
+    use bytes;
+    print "not " unless $a eq "\xc4\x80\xc2\x80" && length($a) == 4;
+    print "ok 11\n";
+    $test++;
+}
+
+{
+    my $a = "\x{80}\x{100}";
+    
+    print "not " unless length($a) == 2;
+    print "ok 12\n";
+    $test++;
+    
+    use bytes;
+    print "not " unless $a eq "\xc2\x80\xc4\x80" && length($a) == 4;
+    print "ok 13\n";
+    $test++;
+}
diff --git a/t/op/reverse.t b/t/op/reverse.t
new file mode 100644 (file)
index 0000000..bb7b9b7
--- /dev/null
@@ -0,0 +1,33 @@
+#!./perl
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+}
+
+print "1..4\n";
+
+print "not " unless reverse("abc")    eq "cba";
+print "ok 1\n";
+
+$_ = "foobar";
+print "not " unless reverse()         eq "raboof";
+print "ok 2\n";
+
+{
+    my @a = ("foo", "bar");
+    my @b = reverse @a;
+
+    print "not " unless $b[0] eq $a[1] && $b[1] eq $a[0];
+    print "ok 3\n";
+}
+
+{
+    # Unicode.
+
+    my $a = "\x{263A}\x{263A}x\x{263A}y\x{263A}";
+    my $b = scalar reverse($a);
+    my $c = scalar reverse($b);
+    print "not " unless $a eq $c;
+    print "ok 4\n";
+}
diff --git a/t/op/utf8decode.t b/t/op/utf8decode.t
new file mode 100644 (file)
index 0000000..4d05a6b
--- /dev/null
@@ -0,0 +1,183 @@
+#!./perl
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+}
+
+no utf8;
+
+print "1..78\n";
+
+my $test = 1;
+
+# This table is based on Markus Kuhn's UTF-8 Decode Stress Tester,
+# http://www.cl.cam.ac.uk/~mgk25/ucs/examples/UTF-8-test.txt,
+# version dated 2000-09-02. 
+
+# We use the \x notation instead of raw binary bytes for \x00-\x1f\x7f-\xff
+# because e.g. many patch programs have issues with binary data.
+
+my @MK = split(/\n/, <<__EOMK__);
+1      Correct UTF-8
+1.1.1 y "\xce\xba\xe1\xbd\xb9\xcf\x83\xce\xbc\xce\xb5" -               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 "\x00"                 0               1       00      1
+2.1.2 y "\xc2\x80"                     80              2       c2:80   1
+2.1.3 y "\xe0\xa0\x80"         800             3       e0:a0:80        1
+2.1.4 y "\xf0\x90\x80\x80"             10000           4       f0:90:80:80     1
+2.1.5 y "\xf8\x88\x80\x80\x80" 200000          5       f8:88:80:80:80  1
+2.1.6 y "\xfc\x84\x80\x80\x80\x80"     4000000         6       fc:84:80:80:80:80       1
+2.2    Last possible sequence of certain length
+2.2.1 y "\x7f"                 7f              1       7f      1
+2.2.2 y "\xdf\xbf"                     7ff             2       df:bf   1
+# The ffff is illegal unless UTF8_ALLOW_FFFF
+2.2.3 n "\xef\xbf\xbf"                 ffff            3       ef:bf:bf        1       character 0xffff
+2.2.4 y "\xf7\xbf\xbf\xbf"                     1fffff          4       f7:bf:bf:bf     1
+2.2.5 y "\xfb\xbf\xbf\xbf\xbf"                 3ffffff         5       fb:bf:bf:bf:bf  1
+2.2.6 y "\xfd\xbf\xbf\xbf\xbf\xbf"             7fffffff        6       fd:bf:bf:bf:bf:bf       1
+2.3    Other boundary conditions
+2.3.1 y "\xed\x9f\xbf"         d7ff            3       ed:9f:bf        1
+2.3.2 y "\xee\x80\x80"         e000            3       ee:80:80        1
+2.3.3 y "\xef\xbf\xbd"                 fffd            3       ef:bf:bd        1
+2.3.4 y "\xf4\x8f\xbf\xbf"             10ffff          4       f4:8f:bf:bf     1
+2.3.5 y "\xf4\x90\x80\x80"             110000          4       f4:90:80:80     1
+3      Malformed sequences
+3.1    Unexpected continuation bytes
+3.1.1 n "\x80"                 -               1       80      -       unexpected continuation byte 0x80
+3.1.2 n "\xbf"                 -               1       bf      -       unexpected continuation byte 0xbf
+3.1.3 n "\x80\xbf"                     -               2       80:bf   -       unexpected continuation byte 0x80
+3.1.4 n "\x80\xbf\x80"         -               3       80:bf:80        -       unexpected continuation byte 0x80
+3.1.5 n "\x80\xbf\x80\xbf"             -               4       80:bf:80:bf     -       unexpected continuation byte 0x80
+3.1.6 n "\x80\xbf\x80\xbf\x80" -               5       80:bf:80:bf:80  -       unexpected continuation byte 0x80
+3.1.7 n "\x80\xbf\x80\xbf\x80\xbf"     -               6       80:bf:80:bf:80:bf       -       unexpected continuation byte 0x80
+3.1.8 n "\x80\xbf\x80\xbf\x80\xbf\x80" -               7       80:bf:80:bf:80:bf:80    -       unexpected continuation byte 0x80
+3.1.9 n "\x80\x81\x82\x83\x84\x85\x86\x87\x88\x89\x8a\x8b\x8c\x8d\x8e\x8f\x90\x91\x92\x93\x94\x95\x96\x97\x98\x99\x9a\x9b\x9c\x9d\x9e\x9f\xa0\xa1\xa2\xa3\xa4\xa5\xa6\xa7\xa8\xa9\xaa\xab\xac\xad\xae\xaf\xb0\xb1\xb2\xb3\xb4\xb5\xb6\xb7\xb8\xb9\xba\xbb\xbc\xbd\xbe\xbf"                             -       64      80:81:82:83:84:85:86:87:88:89:8a:8b:8c:8d:8e:8f:90:91:92:93:94:95:96:97:98:99:9a:9b:9c:9d:9e:9f:a0:a1:a2:a3:a4:a5:a6:a7:a8:a9:aa:ab:ac:ad:ae:af:b0:b1:b2:b3:b4:b5:b6:b7:b8:b9:ba:bb:bc:bd:be:bf -       unexpected continuation byte 0x80
+3.2    Lonely start characters
+3.2.1 n "\xc0 \xc1 \xc2 \xc3 \xc4 \xc5 \xc6 \xc7 \xc8 \xc9 \xca \xcb \xcc \xcd \xce \xcf \xd0 \xd1 \xd2 \xd3 \xd4 \xd5 \xd6 \xd7 \xd8 \xd9 \xda \xdb \xdc \xdd \xde \xdf "     -       64      c0:20:c1:20:c2:20:c3:20:c4:20:c5:20:c6:20:c7:20:c8:20:c9:20:ca:20:cb:20:cc:20:cd:20:ce:20:cf:20:d0:20:d1:20:d2:20:d3:20:d4:20:d5:20:d6:20:d7:20:d8:20:d9:20:da:20:db:20:dc:20:dd:20:de:20:df:20 -       unexpected non-continuation byte 0x20 after start byte 0xc0
+3.2.2 n "\xe0 \xe1 \xe2 \xe3 \xe4 \xe5 \xe6 \xe7 \xe8 \xe9 \xea \xeb \xec \xed \xee \xef "     -       32      e0:20:e1:20:e2:20:e3:20:e4:20:e5:20:e6:20:e7:20:e8:20:e9:20:ea:20:eb:20:ec:20:ed:20:ee:20:ef:20 -       unexpected non-continuation byte 0x20 after start byte 0xe0
+3.2.3 n "\xf0 \xf1 \xf2 \xf3 \xf4 \xf5 \xf6 \xf7 "     -       16      f0:20:f1:20:f2:20:f3:20:f4:20:f5:20:f6:20:f7:20 -       unexpected non-continuation byte 0x20 after start byte 0xf0
+3.2.4 n "\xf8 \xf9 \xfa \xfb "         -       8       f8:20:f9:20:fa:20:fb:20 -       unexpected non-continuation byte 0x20 after start byte 0xf8
+3.2.5 n "\xfc \xfd "                   -       4       fc:20:fd:20     -       unexpected non-continuation byte 0x20 after start byte 0xfc
+3.3    Sequences with last continuation byte missing
+3.3.1 n "\xc0"                 -       1       c0      -       1 byte, need 2
+3.3.2 n "\xe0\x80"                     -       2       e0:80   -       2 bytes, need 3
+3.3.3 n "\xf0\x80\x80"         -       3       f0:80:80        -       3 bytes, need 4
+3.3.4 n "\xf8\x80\x80\x80"             -       4       f8:80:80:80     -       4 bytes, need 5
+3.3.5 n "\xfc\x80\x80\x80\x80" -       5       fc:80:80:80:80  -       5 bytes, need 6
+3.3.6 n "\xdf"                 -       1       df      -       1 byte, need 2
+3.3.7 n "\xef\xbf"                     -       2       ef:bf   -       2 bytes, need 3
+3.3.8 n "\xf7\xbf\xbf"                 -       3       f7:bf:bf        -       3 bytes, need 4
+3.3.9 n "\xfb\xbf\xbf\xbf"                     -       4       fb:bf:bf:bf     -       4 bytes, need 5
+3.3.10 n "\xfd\xbf\xbf\xbf\xbf"                -       5       fd:bf:bf:bf:bf  -       5 bytes, need 6
+3.4    Concatenation of incomplete sequences
+3.4.1 n "\xc0\xe0\x80\xf0\x80\x80\xf8\x80\x80\x80\xfc\x80\x80\x80\x80\xdf\xef\xbf\xf7\xbf\xbf\xfb\xbf\xbf\xbf\xfd\xbf\xbf\xbf\xbf"     -       30      c0:e0:80:f0:80:80:f8:80:80:80:fc:80:80:80:80:df:ef:bf:f7:bf:bf:fb:bf:bf:bf:fd:bf:bf:bf:bf       -       unexpected non-continuation byte 0xe0 after start byte 0xc0
+3.5    Impossible bytes
+3.5.1 n "\xfe"                 -       1       fe      -       byte 0xfe
+3.5.2 n "\xff"                 -       1       ff      -       byte 0xff
+3.5.3 n "\xfe\xfe\xff\xff"                     -       4       fe:fe:ff:ff     -       byte 0xfe
+4      Overlong sequences
+4.1    Examples of an overlong ASCII character
+4.1.1 n "\xc0\xaf"                     -       2       c0:af   -       2 bytes, need 1
+4.1.2 n "\xe0\x80\xaf"         -       3       e0:80:af        -       3 bytes, need 1
+4.1.3 n "\xf0\x80\x80\xaf"             -       4       f0:80:80:af     -       4 bytes, need 1
+4.1.4 n "\xf8\x80\x80\x80\xaf" -       5       f8:80:80:80:af  -       5 bytes, need 1
+4.1.5 n "\xfc\x80\x80\x80\x80\xaf"     -       6       fc:80:80:80:80:af       -       6 bytes, need 1
+4.2    Maximum overlong sequences
+4.2.1 n "\xc1\xbf"                     -       2       c1:bf   -       2 bytes, need 1
+4.2.2 n "\xe0\x9f\xbf"         -       3       e0:9f:bf        -       3 bytes, need 2
+4.2.3 n "\xf0\x8f\xbf\xbf"             -       4       f0:8f:bf:bf     -       4 bytes, need 3
+4.2.4 n "\xf8\x87\xbf\xbf\xbf"         -       5       f8:87:bf:bf:bf  -       5 bytes, need 4
+4.2.5 n "\xfc\x83\xbf\xbf\xbf\xbf"             -       6       fc:83:bf:bf:bf:bf       -       6 bytes, need 5
+4.3    Overlong representation of the NUL character
+4.3.1 n "\xc0\x80"                     -       2       c0:80   -       2 bytes, need 1
+4.3.2 n "\xe0\x80\x80"         -       3       e0:80:80        -       3 bytes, need 1
+4.3.3 n "\xf0\x80\x80\x80"             -       4       f0:80:80:80     -       4 bytes, need 1
+4.3.4 n "\xf8\x80\x80\x80\x80" -       5       f8:80:80:80:80  -       5 bytes, need 1
+4.3.5 n "\xfc\x80\x80\x80\x80\x80"     -       6       fc:80:80:80:80:80       -       6 bytes, need 1
+5      Illegal code positions
+5.1    Single UTF-16 surrogates
+5.1.1 n "\xed\xa0\x80"         -       3       ed:a0:80        -       UTF-16 surrogate 0xd800
+5.1.2 n "\xed\xad\xbf"                 -       3       ed:ad:bf        -       UTF-16 surrogate 0xdb7f
+5.1.3 n "\xed\xae\x80"         -       3       ed:ae:80        -       UTF-16 surrogate 0xdb80
+5.1.4 n "\xed\xaf\xbf"                 -       3       ed:af:bf        -       UTF-16 surrogate 0xdbff
+5.1.5 n "\xed\xb0\x80"         -       3       ed:b0:80        -       UTF-16 surrogate 0xdc00
+5.1.6 n "\xed\xbe\x80"         -       3       ed:be:80        -       UTF-16 surrogate 0xdf80
+5.1.7 n "\xed\xbf\xbf"                 -       3       ed:bf:bf        -       UTF-16 surrogate 0xdfff
+5.2    Paired UTF-16 surrogates
+5.2.1 n "\xed\xa0\x80\xed\xb0\x80"             -       6       ed:a0:80:ed:b0:80       -       UTF-16 surrogate 0xd800
+5.2.2 n "\xed\xa0\x80\xed\xbf\xbf"             -       6       ed:a0:80:ed:bf:bf       -       UTF-16 surrogate 0xd800
+5.2.3 n "\xed\xad\xbf\xed\xb0\x80"             -       6       ed:ad:bf:ed:b0:80       -       UTF-16 surrogate 0xdb7f
+5.2.4 n "\xed\xad\xbf\xed\xbf\xbf"             -       6       ed:ad:bf:ed:bf:bf       -       UTF-16 surrogate 0xdb7f
+5.2.5 n "\xed\xae\x80\xed\xb0\x80"             -       6       ed:ae:80:ed:b0:80       -       UTF-16 surrogate 0xdb80
+5.2.6 n "\xed\xae\x80\xed\xbf\xbf"             -       6       ed:ae:80:ed:bf:bf       -       UTF-16 surrogate 0xdb80
+5.2.7 n "\xed\xaf\xbf\xed\xb0\x80"             -       6       ed:af:bf:ed:b0:80       -       UTF-16 surrogate 0xdbff
+5.2.8 n "\xed\xaf\xbf\xed\xbf\xbf"             -       6       ed:af:bf:ed:bf:bf       -       UTF-16 surrogate 0xdbff
+5.3    Other illegal code positions
+5.3.1 n "\xef\xbf\xbe"                 -       3       ef:bf:be        -       byte order mark 0xfffe
+# The ffff is illegal unless UTF8_ALLOW_FFFF
+5.3.2 n "\xef\xbf\xbf"                 -       3       ef:bf:bf        -       character 0xffff
+__EOMK__
+
+# 104..181
+{
+    my $WARNCNT;
+    my $id;
+
+    local $SIG{__WARN__} =
+       sub {
+           print "# $id: @_";
+           $WARNCNT++;
+           $WARNMSG = "@_";
+       };
+
+    sub moan {
+       print "$id: @_";
+    }
+    
+    sub test_unpack_U {
+       $WARNCNT = 0;
+       $WARNMSG = "";
+       unpack('U*', $_[0]);
+    }
+
+    for (@MK) {
+       if (/^(?:\d+(?:\.\d+)?)\s/ || /^#/) {
+           # print "# $_\n";
+       } elsif (/^(\d+\.\d+\.\d+[bu]?)\s+([yn])\s+"(.+)"\s+([0-9a-f]{1,8}|-)\s+(\d+)\s+([0-9a-f]{2}(?::[0-9a-f]{2})*)(?:\s+((?:\d+|-)(?:\s+(.+))?))?$/) {
+           $id = $1;
+           my ($okay, $bytes, $Unicode, $byteslen, $hex, $charslen, $error) =
+               ($2, $3, $4, $5, $6, $7, $8);
+           my @hex = split(/:/, $hex);
+           unless (@hex == $byteslen) {
+               my $nhex = @hex;
+               moan "amount of hex ($nhex) not equal to byteslen ($byteslen)\n";
+           }
+           {
+               use bytes;
+               my $bytesbyteslen = length($bytes);
+               unless ($bytesbyteslen == $byteslen) {
+                   moan "bytes length() ($bytesbyteslen) not equal to $byteslen\n";
+               }
+           }
+           if ($okay eq 'y') {
+               test_unpack_U($bytes);
+               if ($WARNCNT) {
+                   moan "unpack('U*') false negative\n";
+                   print "not ";
+               }
+           } elsif ($okay eq 'n') {
+               test_unpack_U($bytes);
+               if ($WARNCNT == 0 || ($error ne '' && $WARNMSG !~ /$error/)) {
+                   moan "unpack('U*') false positive\n";
+                   print "not ";
+               }
+           }
+           print "ok $test\n";
+           $test++;
+       } else {
+           moan "unknown format\n";
+       }
+    }
+}
index 08beced..edfebd2 100755 (executable)
@@ -5,7 +5,7 @@ BEGIN {
     @INC = '../lib';
 }
 
-print "1..23\n";
+print "1..28\n";
 
 my $test = 1;
 
@@ -155,3 +155,27 @@ print "ok $test\n";  ++$test;
        eq '1##10110##11000101##10001101##11100001##10000101##10011100';
     print "ok $test\n";  ++$test;
 }
+
+{
+    # bug id 20000323.056
+
+    print "not " unless "\x{41}" eq +v65;
+    print "ok $test\n";
+    $test++;
+
+    print "not " unless "\x41" eq +v65;
+    print "ok $test\n";
+    $test++;
+
+    print "not " unless "\x{c8}" eq +v200;
+    print "ok $test\n";
+    $test++;
+
+    print "not " unless "\xc8" eq +v200;
+    print "ok $test\n";
+    $test++;
+
+    print "not " unless "\x{221b}" eq v8731;
+    print "ok $test\n";
+    $test++;
+}
index ab58206..e0a321a 100755 (executable)
@@ -10,7 +10,7 @@ BEGIN {
     }
 }
 
-print "1..191\n";
+print "1..90\n";
 
 my $test = 1;
 
@@ -104,6 +104,7 @@ sub nok_bytes {
     ok $1, '123alpha';
     $test++;                           # 12
 }
+
 {
     use utf8;
 
@@ -204,10 +205,8 @@ sub nok_bytes {
 
        ok $1, pack("C*", 0342);
        $test++;                                # 40
-
     }
 
-
     {
        no utf8;
        $_="\342\230\272>\342\230\272\342\230\272";
@@ -262,6 +261,7 @@ sub nok_bytes {
        ok $tmp, pack("C*", 0342, 0230, 0272);
        $test++;                                # 54
     }
+
     {
        use bytes;
        no utf8;
@@ -295,7 +295,6 @@ sub nok_bytes {
 
        ok $1, pack("C*", 0342);
        $test++;                                # 64
-
     }
 
     ok "\x{ab}" =~ /^\x{ab}$/, 1;
@@ -355,64 +354,6 @@ sub nok_bytes {
 }
 
 {
-    # bug id 20000819.004 
-
-    $_ = $dx = "\x{10f2}";
-    s/($dx)/$dx$1/;
-    {
-       use bytes;
-       print "not " unless $_ eq "$dx$dx";
-       print "ok $test\n";
-       $test++;
-    }
-
-    $_ = $dx = "\x{10f2}";
-    s/($dx)/$1$dx/;
-    {
-       use bytes;
-       print "not " unless $_ eq "$dx$dx";
-       print "ok $test\n";
-       $test++;
-    }
-
-    $dx = "\x{10f2}";
-    $_  = "\x{10f2}\x{10f2}";
-    s/($dx)($dx)/$1$2/;
-    {
-       use bytes;
-       print "not " unless $_ eq "$dx$dx";
-       print "ok $test\n";
-       $test++;
-    }
-}
-
-{
-    # bug id 20000323.056
-
-    use utf8;
-
-    print "not " unless "\x{41}" eq +v65;
-    print "ok $test\n";
-    $test++;
-
-    print "not " unless "\x41" eq +v65;
-    print "ok $test\n";
-    $test++;
-
-    print "not " unless "\x{c8}" eq +v200;
-    print "ok $test\n";
-    $test++;
-
-    print "not " unless "\xc8" eq +v200;
-    print "ok $test\n";
-    $test++;
-
-    print "not " unless "\x{221b}" eq v8731;
-    print "ok $test\n";
-    $test++;
-}
-
-{
     # bug id 20000427.003 
 
     use utf8;
@@ -433,17 +374,6 @@ sub nok_bytes {
 }
 
 {
-    # bug id 20000901.092
-    # test that undef left and right of utf8 results in a valid string
-
-    my $a;
-    $a .= "\x{1ff}";
-    print "not " unless $a eq "\x{1ff}";
-    print "ok $test\n";
-    $test++;
-}
-
-{
     # bug id 20000426.003
 
     use utf8;
@@ -530,276 +460,3 @@ sub nok_bytes {
        $test++;
     }
 }
-
-{
-    # ID 20001020.006
-
-    "x" =~ /(.)/; # unset $2
-
-    # Without the fix this will croak:
-    # Modification of a read-only value attempted at ...
-    "$2\x{1234}";
-
-    print "ok $test\n";
-    $test++;
-
-    # For symmetry with the above.
-    "\x{1234}$2";
-
-    print "ok $test\n";
-    $test++;
-
-    *pi = \undef;
-    # This bug existed earlier than the $2 bug, but is fixed with the same
-    # patch. Without the fix this will also croak:
-    # Modification of a read-only value attempted at ...
-    "$pi\x{1234}";
-
-    print "ok $test\n";
-    $test++;
-
-    # For symmetry with the above.
-    "\x{1234}$pi";
-
-    print "ok $test\n";
-    $test++;
-}
-
-# This table is based on Markus Kuhn's UTF-8 Decode Stress Tester,
-# 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.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
-2.1.5 y ""        200000          5       f8:88:80:80:80  1
-2.1.6 y ""       4000000         6       fc:84:80:80:80:80       1
-2.2    Last possible sequence of certain length
-2.2.1 y "\7f"                    7f              1       7f      1
-2.2.2 y "߿"                   7ff             2       df:bf   1
-# The ffff is illegal unless UTF8_ALLOW_FFFF
-2.2.3 n "￿"                  ffff            3       ef:bf:bf        1
-2.2.4 y ""                 1fffff          4       f7:bf:bf:bf     1
-2.2.5 y ""                        3ffffff         5       fb:bf:bf:bf:bf  1
-2.2.6 y ""               7fffffff        6       fd:bf:bf:bf:bf:bf       1
-2.3    Other boundary conditions
-2.3.1 y "퟿"          d7ff            3       ed:9f:bf        1
-2.3.2 y ""          e000            3       ee:80:80        1
-2.3.3 y "�"                  fffd            3       ef:bf:bd        1
-2.3.4 y "􏿿"         10ffff          4       f4:8f:bf:bf     1
-2.3.5 y ""         110000          4       f4:90:80:80     1
-3      Malformed sequences
-3.1    Unexpected continuation bytes
-3.1.1 n "\80"                    -               1       80
-3.1.2 n "¿"                    -               1       bf
-3.1.3 n "\80¿"                   -               2       80:bf
-3.1.4 n "\80¿\80"          -               3       80:bf:80
-3.1.5 n "\80¿\80¿"         -               4       80:bf:80:bf
-3.1.6 n "\80¿\80¿\80"        -               5       80:bf:80:bf:80
-3.1.7 n "\80¿\80¿\80¿"       -               6       80:bf:80:bf:80:bf
-3.1.8 n "\80¿\80¿\80¿\80"      -               7       80:bf:80:bf:80:bf:80
-3.1.9 n "\80\81\82\83\84\85\86\87\88\89\8a\8b\8c\8d\8e\8f\90\91\92\93\94\95\96\97\98\99\9a\9b\9c\9d\9e\9f ¡¢£¤¥¦§¨©ª«¬­®¯°±²³´µ¶·¸¹º»¼½¾¿"                             -       64      80:81:82:83:84:85:86:87:88:89:8a:8b:8c:8d:8e:8f:90:91:92:93:94:95:96:97:98:99:9a:9b:9c:9d:9e:9f:a0:a1:a2:a3:a4:a5:a6:a7:a8:a9:aa:ab:ac:ad:ae:af:b0:b1:b2:b3:b4:b5:b6:b7:b8:b9:ba:bb:bc:bd:be:bf
-3.2    Lonely start characters
-3.2.1 n "À Á Â Ã Ä Å Æ Ç È É Ê Ë Ì Í Î Ï Ð Ñ Ò Ó Ô Õ Ö × Ø Ù Ú Û Ü Ý Þ ß "     -       64      c0:20:c1:20:c2:20:c3:20:c4:20:c5:20:c6:20:c7:20:c8:20:c9:20:ca:20:cb:20:cc:20:cd:20:ce:20:cf:20:d0:20:d1:20:d2:20:d3:20:d4:20:d5:20:d6:20:d7:20:d8:20:d9:20:da:20:db:20:dc:20:dd:20:de:20:df:20
-3.2.2 n "à á â ã ä å æ ç è é ê ë ì í î ï "     -       32      e0:20:e1:20:e2:20:e3:20:e4:20:e5:20:e6:20:e7:20:e8:20:e9:20:ea:20:eb:20:ec:20:ed:20:ee:20:ef:20
-3.2.3 n "ð ñ ò ó ô õ ö ÷ "     -       16      f0:20:f1:20:f2:20:f3:20:f4:20:f5:20:f6:20:f7:20
-3.2.4 n "ø ù ú û "             -       8       f8:20:f9:20:fa:20:fb:20
-3.2.5 n "ü ý "                 -       4       fc:20:fd:20
-3.3    Sequences with last continuation byte missing
-3.3.1 n "À"                    -       1       c0
-3.3.2 n "à\80"                   -       2       e0:80
-3.3.3 n "ð\80\80"          -       3       f0:80:80
-3.3.4 n "ø\80\80\80"         -       4       f8:80:80:80
-3.3.5 n "ü\80\80\80\80"        -       5       fc:80:80:80:80
-3.3.6 n "ß"                    -       1       df
-3.3.7 n "ï¿"                   -       2       ef:bf
-3.3.8 n "÷¿¿"                  -       3       f7:bf:bf
-3.3.9 n "û¿¿¿"                 -       4       fb:bf:bf:bf
-3.3.10 n "ý¿¿¿¿"               -       5       fd:bf:bf:bf:bf
-3.4    Concatenation of incomplete sequences
-3.4.1 n "Àà\80ð\80\80ø\80\80\80ü\80\80\80\80ßï¿÷¿¿û¿¿¿ý¿¿¿¿"       -       30      c0:e0:80:f0:80:80:f8:80:80:80:fc:80:80:80:80:df:ef:bf:f7:bf:bf:fb:bf:bf:bf:fd:bf:bf:bf:bf
-3.5    Impossible bytes
-3.5.1 n "þ"                    -       1       fe
-3.5.2 n "ÿ"                    -       1       ff
-3.5.3 n "þþÿÿ"                 -       4       fe:fe:ff:ff
-4      Overlong sequences
-4.1    Examples of an overlong ASCII character
-4.1.1 n "À¯"                   -       2       c0:af
-4.1.2 n "à\80¯"          -       3       e0:80:af
-4.1.3 n "ð\80\80¯"         -       4       f0:80:80:af
-4.1.4 n "ø\80\80\80¯"        -       5       f8:80:80:80:af
-4.1.5 n "ü\80\80\80\80¯"       -       6       fc:80:80:80:80:af
-4.2    Maximum overlong sequences
-4.2.1 n "Á¿"                   -       2       c1:bf
-4.2.2 n "à\9f¿"          -       3       e0:9f:bf
-4.2.3 n "ð\8f¿¿"         -       4       f0:8f:bf:bf
-4.2.4 n "ø\87¿¿¿"                -       5       f8:87:bf:bf:bf
-4.2.5 n "ü\83¿¿¿¿"               -       6       fc:83:bf:bf:bf:bf
-4.3    Overlong representation of the NUL character
-4.3.1 n "À\80"                   -       2       c0:80
-4.3.2 n "à\80\80"          -       3       e0:80:80
-4.3.3 n "ð\80\80\80"         -       4       f0:80:80:80
-4.3.4 n "ø\80\80\80\80"        -       5       f8:80:80:80:80
-4.3.5 n "ü\80\80\80\80\80"       -       6       fc:80:80:80:80:80
-5      Illegal code positions
-5.1    Single UTF-16 surrogates
-5.1.1 n ""          -       3       ed:a0:80
-5.1.2 n ""                  -       3       ed:ad:bf
-5.1.3 n ""          -       3       ed:ae:80
-5.1.4 n ""                  -       3       ed:af:bf
-5.1.5 n ""          -       3       ed:b0:80
-5.1.6 n ""          -       3       ed:be:80
-5.1.7 n ""                  -       3       ed:bf:bf
-5.2    Paired UTF-16 surrogates
-5.2.1 n ""               -       6       ed:a0:80:ed:b0:80
-5.2.2 n ""               -       6       ed:a0:80:ed:bf:bf
-5.2.3 n ""               -       6       ed:ad:bf:ed:b0:80
-5.2.4 n ""               -       6       ed:ad:bf:ed:bf:bf
-5.2.5 n ""               -       6       ed:ae:80:ed:b0:80
-5.2.6 n ""               -       6       ed:ae:80:ed:bf:bf
-5.2.7 n ""               -       6       ed:af:bf:ed:b0:80
-5.2.8 n ""               -       6       ed:af:bf:ed:bf:bf
-5.3    Other illegal code positions
-5.3.1 n "￾"                  -       3       ef:bf:be
-# The ffff is illegal unless UTF8_ALLOW_FFFF
-5.3.2 n "￿"                  -       3       ef:bf:bf
-__EOMK__
-
-# 104..181
-{
-    my $WARN;
-    my $id;
-
-    local $SIG{__WARN__} =
-       sub {
-           # print "# $id: @_";
-           $WARN++;
-       };
-
-    sub moan {
-       print "$id: @_";
-    }
-    
-    sub test_unpack_U {
-       $WARN = 0;
-       unpack('U*', $_[0]);
-    }
-
-    for (@MK) {
-       if (/^(?:\d+(?:\.\d+)?)\s/ || /^#/) {
-           # print "# $_\n";
-       } elsif (/^(\d+\.\d+\.\d+[bu]?)\s+([yn])\s+"(.+)"\s+([0-9a-f]{1,8}|-)\s+(\d+)\s+([0-9a-f]{2}(?::[0-9a-f]{2})*)(?:\s+(\d+))?$/) {
-           $id = $1;
-           my ($okay, $bytes, $Unicode, $byteslen, $hex, $charslen) =
-               ($2, $3, $4, $5, $6, $7);
-           my @hex = split(/:/, $hex);
-           unless (@hex == $byteslen) {
-               my $nhex = @hex;
-               moan "amount of hex ($nhex) not equal to byteslen ($byteslen)\n";
-           }
-           {
-               use bytes;
-               my $bytesbyteslen = length($bytes);
-               unless ($bytesbyteslen == $byteslen) {
-                   moan "bytes length() ($bytesbyteslen) not equal to $byteslen\n";
-               }
-           }
-           if ($okay eq 'y') {
-               test_unpack_U($bytes);
-               unless ($WARN == 0) {
-                   moan "unpack('U*') false negative\n";
-                   print "not ";
-               }
-           } elsif ($okay eq 'n') {
-               test_unpack_U($bytes);
-               unless ($WARN) {
-                   moan "unpack('U*') false positive\n";
-                   print "not ";
-               }
-           }
-           print "ok $test\n";
-           $test++;
-       } else {
-           moan "unknown format\n";
-       }
-    }
-}
-
-{
-    # tests 182..191
-
-    {
-       my $a = "\x{41}";
-
-       print "not " unless length($a) == 1;
-       print "ok $test\n";
-       $test++;
-
-       use bytes;
-       print "not " unless $a eq "\x41" && length($a) == 1;
-       print "ok $test\n";
-       $test++;
-    }
-
-    {
-       my $a = "\x{80}";
-
-       print "not " unless length($a) == 1;
-       print "ok $test\n";
-       $test++;
-
-       use bytes;
-       print "not " unless $a eq "\xc2\x80" && length($a) == 2;
-       print "ok $test\n";
-       $test++;
-    }
-
-    {
-       my $a = "\x{100}";
-
-       print "not " unless length($a) == 1;
-       print "ok $test\n";
-       $test++;
-
-       use bytes;
-       print "not " unless $a eq "\xc4\x80" && length($a) == 2;
-       print "ok $test\n";
-       $test++;
-    }
-
-    {
-       my $a = "\x{100}\x{80}";
-
-       print "not " unless length($a) == 2;
-       print "ok $test\n";
-       $test++;
-
-       use bytes;
-       print "not " unless $a eq "\xc4\x80\xc2\x80" && length($a) == 4;
-       print "ok $test\n";
-       $test++;
-    }
-
-    {
-       my $a = "\x{80}\x{100}";
-
-       print "not " unless length($a) == 2;
-       print "ok $test\n";
-       $test++;
-
-       use bytes;
-       print "not " unless $a eq "\xc2\x80\xc4\x80" && length($a) == 4;
-       print "ok $test\n";
-       $test++;
-    }
-}
-
index adc10c6..9a7dbaf 100644 (file)
@@ -30,6 +30,6 @@ my $a = "sn
     my $a = "snøstorm";
 }
 EXPECT
-Malformed UTF-8 character (unexpected non-continuation byte 0x73 after byte 0xf8) at - line 9.
-Malformed UTF-8 character (unexpected non-continuation byte 0x73 after byte 0xf8) at - line 14.
+Malformed UTF-8 character (unexpected non-continuation byte 0x73 after start byte 0xf8) at - line 9.
+Malformed UTF-8 character (unexpected non-continuation byte 0x73 after start byte 0xf8) at - line 14.
 ########
diff --git a/toke.c b/toke.c
index 937e992..398f0ad 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -13,7 +13,7 @@
 
 /*
  * This file is the lexer for Perl.  It's closely linked to the
- * parser, perly.y.  
+ * parser, perly.y.
  *
  * The main routine is yylex(), which returns the next token.
  */
@@ -39,7 +39,7 @@ static I32 utf16rev_textfilter(pTHXo_ int idx, SV *sv, int maxlen);
 /*#define UTF (SvUTF8(PL_linestr) && !(PL_hints & HINT_BYTE))*/
 #define UTF (PL_hints & HINT_UTF8)
 
-/* In variables name $^X, these are the legal values for X.  
+/* In variables name $^X, these are the legal values for X.
  * 1999-02-27 mjd-perl-patch@plover.com */
 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
 
@@ -85,7 +85,7 @@ int yyactlevel = 0;
 #  define yylval (*yylval_pointer[yyactlevel])
 #  define yychar (*yychar_pointer[yyactlevel])
 #  define PERL_YYLEX_PARAM yylval_pointer[yyactlevel],yychar_pointer[yyactlevel]
-#  undef yylex 
+#  undef yylex
 #  define yylex()      Perl_yylex_r(aTHX_ yylval_pointer[yyactlevel],yychar_pointer[yyactlevel])
 #endif
 
@@ -121,7 +121,7 @@ int yyactlevel = 0;
  * Aop          : addition-level operator
  * Mop          : multiplication-level operator
  * Eop          : equality-testing operator
- * Rop        : relational operator <= != gt
+ * Rop          : relational operator <= != gt
  *
  * Also see LOP and lop() below.
  */
@@ -449,7 +449,7 @@ S_incline(pTHX_ char *s)
        return;
     if (*s == ' ' || *s == '\t')
        s++;
-    else 
+    else
        return;
     while (SPACE_OR_TAB(*s)) s++;
     if (!isDIGIT(*s))
@@ -626,8 +626,8 @@ S_check_uni(pTHX)
     if (ckWARN_d(WARN_AMBIGUOUS)){
         char ch = *s;
         *s = '\0';
-        Perl_warner(aTHX_ WARN_AMBIGUOUS, 
-                  "Warning: Use of \"%s\" without parens is ambiguous", 
+        Perl_warner(aTHX_ WARN_AMBIGUOUS,
+                  "Warning: Use of \"%s\" without parens is ambiguous",
                   PL_last_uni);
         *s = ch;
     }
@@ -707,7 +707,7 @@ S_lop(pTHX_ I32 f, int x, char *s)
  * handles the token correctly.
  */
 
-STATIC void 
+STATIC void
 S_force_next(pTHX_ I32 type)
 {
     PL_nexttype[PL_nexttoke] = type;
@@ -740,7 +740,7 @@ S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow
 {
     register char *s;
     STRLEN len;
-    
+
     start = skipspace(start);
     s = start;
     if (isIDFIRST_lazy_if(s,UTF) ||
@@ -822,7 +822,7 @@ Perl_str_to_version(pTHX_ SV *sv)
     return retval;
 }
 
-/* 
+/*
  * S_force_version
  * Forces the next token to be a version number.
  */
@@ -855,7 +855,7 @@ S_force_version(pTHX_ char *s)
 
     /* NOTE: The parser sees the package name and the VERSION swapped */
     PL_nextval[PL_nexttoke].opval = version;
-    force_next(WORD); 
+    force_next(WORD);
 
     return (s);
 }
@@ -963,7 +963,7 @@ S_sublex_start(pTHX)
                SvUTF8_on(nsv);
            SvREFCNT_dec(sv);
            sv = nsv;
-       } 
+       }
        yylval.opval = (OP*)newSVOP(op_type, 0, sv);
        PL_lex_stuff = Nullsv;
        return THING;
@@ -1169,7 +1169,7 @@ S_sublex_done(pTHX)
              } (end switch)
          } (end if backslash)
     } (end while character to read)
-                 
+               
 */
 
 STATIC char *
@@ -1266,9 +1266,9 @@ S_scan_const(pTHX_ char *start)
                while (count && (c = *regparse)) {
                    if (c == '\\' && regparse[1])
                        regparse++;
-                   else if (c == '{') 
+                   else if (c == '{')
                        count++;
-                   else if (c == '}') 
+                   else if (c == '}')
                        count--;
                    regparse++;
                }
@@ -1305,11 +1305,12 @@ S_scan_const(pTHX_ char *start)
 
        /* (now in tr/// code again) */
 
-       if (*s & 0x80 && this_utf8) {
-           STRLEN len;
+       if (*s & 0x80 && (this_utf8 || has_utf8)) {
+           STRLEN len = (STRLEN) -1;
            UV uv;
-
-           uv = utf8_to_uv((U8*)s, send - s, &len, UTF8_CHECK_ONLY);
+           if (this_utf8) {
+               uv = utf8_to_uv((U8*)s, send - s, &len, UTF8_CHECK_ONLY);
+           }
            if (len == (STRLEN)-1) {
                /* Illegal UTF8 (a high-bit byte), make it valid. */
                char *old_pvx = SvPVX(sv);
@@ -1449,7 +1450,7 @@ S_scan_const(pTHX_ char *start)
 
                     if (has_utf8 || uv > 255) {
                        d = (char*)uv_to_utf8((U8*)d, uv);
-                       this_utf8 = TRUE;
+                       has_utf8 = TRUE;
                     }
                    else {
                        *d++ = (char)uv;
@@ -1468,14 +1469,14 @@ S_scan_const(pTHX_ char *start)
                    SV *res;
                    STRLEN len;
                    char *str;
+
                    if (!e) {
                        yyerror("Missing right brace on \\N{}");
                        e = s - 1;
                        goto cont_scan;
                    }
                    res = newSVpvn(s + 1, e - s - 1);
-                   res = new_constant( Nullch, 0, "charnames", 
+                   res = new_constant( Nullch, 0, "charnames",
                                        res, Nullsv, "\\N{...}" );
                    str = SvPV(res,len);
                    if (!has_utf8 && SvUTF8(res)) {
@@ -1512,7 +1513,7 @@ S_scan_const(pTHX_ char *start)
                *d = *s++;
                if (isLOWER(*d))
                   *d = toUPPER(*d);
-               *d = toCTRL(*d); 
+               *d = toCTRL(*d);
                d++;
 #else
                {
@@ -1578,9 +1579,9 @@ S_scan_const(pTHX_ char *start)
     /* return the substring (via yylval) only if we parsed anything */
     if (s > PL_bufptr) {
        if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
-           sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"), 
+           sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
                              sv, Nullsv,
-                             ( PL_lex_inwhat == OP_TRANS 
+                             ( PL_lex_inwhat == OP_TRANS
                                ? "tr"
                                : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
                                    ? "s"
@@ -1851,7 +1852,7 @@ S_incl_perldb(pTHX)
 
 
 /* Encoded script support. filter_add() effectively inserts a
- * 'pre-processing' function into the current source input stream. 
+ * 'pre-processing' function into the current source input stream.
  * Note that the filter function only applies to the current source file
  * (e.g., it will not affect files 'require'd or 'use'd by this one).
  *
@@ -1887,7 +1888,7 @@ Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
     av_store(PL_rsfp_filters, 0, datasv) ;
     return(datasv);
 }
+
 
 /* Delete most recently added instance of this filter function.        */
 void
@@ -1914,8 +1915,8 @@ Perl_filter_del(pTHX_ filter_t funcp)
 /* Invoke the n'th filter function for the current rsfp.        */
 I32
 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
-            
-               
+
+
                                /* 0 = read one text line */
 {
     filter_t funcp;
@@ -1928,7 +1929,7 @@ Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
        /* Note that we append to the line. This is handy.      */
        DEBUG_P(PerlIO_printf(Perl_debug_log,
                              "filter_read %d: from rsfp\n", idx));
-       if (maxlen) { 
+       if (maxlen) {
            /* Want a block */
            int len ;
            int old_len = SvCUR(buf_sv) ;
@@ -2126,7 +2127,7 @@ Perl_yylex(pTHX)
            }
        }
 
-       /* 
+       /*
           build the ops for accesses to a my() variable.
 
           Deny my($a) or my($b) in a sort block, *if* $a or $b is
@@ -2444,7 +2445,7 @@ 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, 
+            DEBUG_T( { PerlIO_printf(Perl_debug_log,
                         "### Tokener got EOF\n");
             } )
            TOKEN(0);
@@ -2577,7 +2578,7 @@ Perl_yylex(pTHX)
                    PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
                    PL_doextract = FALSE;
                }
-           } 
+           }
            incline(s);
        } while (PL_doextract);
        PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
@@ -2750,7 +2751,7 @@ Perl_yylex(pTHX)
     case '\r':
 #ifdef PERL_STRICT_CR
        Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
-       Perl_croak(aTHX_ 
+       Perl_croak(aTHX_
       "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
 #endif
     case ' ': case '\t': case '\f': case 013:
@@ -2786,6 +2787,8 @@ Perl_yylex(pTHX)
        goto retry;
     case '-':
        if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
+           I32 ftst = 0;
+
            s++;
            PL_bufptr = s;
            tmp = *s++;
@@ -2795,48 +2798,64 @@ Perl_yylex(pTHX)
 
            if (strnEQ(s,"=>",2)) {
                s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
-                DEBUG_T( { PerlIO_printf(Perl_debug_log, 
+                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);
-           case 'x': FTST(OP_FTEEXEC);
-           case 'o': FTST(OP_FTEOWNED);
-           case 'R': FTST(OP_FTRREAD);
-           case 'W': FTST(OP_FTRWRITE);
-           case 'X': FTST(OP_FTREXEC);
-           case 'O': FTST(OP_FTROWNED);
-           case 'e': FTST(OP_FTIS);
-           case 'z': FTST(OP_FTZERO);
-           case 's': FTST(OP_FTSIZE);
-           case 'f': FTST(OP_FTFILE);
-           case 'd': FTST(OP_FTDIR);
-           case 'l': FTST(OP_FTLINK);
-           case 'p': FTST(OP_FTPIPE);
-           case 'S': FTST(OP_FTSOCK);
-           case 'u': FTST(OP_FTSUID);
-           case 'g': FTST(OP_FTSGID);
-           case 'k': FTST(OP_FTSVTX);
-           case 'b': FTST(OP_FTBLK);
-           case 'c': FTST(OP_FTCHR);
-           case 't': FTST(OP_FTTTY);
-           case 'T': FTST(OP_FTTEXT);
-           case 'B': FTST(OP_FTBINARY);
-           case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
-           case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
-           case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
+           case 'r': ftst = OP_FTEREAD;        break;
+           case 'w': ftst = OP_FTEWRITE;       break;
+           case 'x': ftst = OP_FTEEXEC;        break;
+           case 'o': ftst = OP_FTEOWNED;       break;
+           case 'R': ftst = OP_FTRREAD;        break;
+           case 'W': ftst = OP_FTRWRITE;       break;
+           case 'X': ftst = OP_FTREXEC;        break;
+           case 'O': ftst = OP_FTROWNED;       break;
+           case 'e': ftst = OP_FTIS;           break;
+           case 'z': ftst = OP_FTZERO;         break;
+           case 's': ftst = OP_FTSIZE;         break;
+           case 'f': ftst = OP_FTFILE;         break;
+           case 'd': ftst = OP_FTDIR;          break;
+           case 'l': ftst = OP_FTLINK;         break;
+           case 'p': ftst = OP_FTPIPE;         break;
+           case 'S': ftst = OP_FTSOCK;         break;
+           case 'u': ftst = OP_FTSUID;         break;
+           case 'g': ftst = OP_FTSGID;         break;
+           case 'k': ftst = OP_FTSVTX;         break;
+           case 'b': ftst = OP_FTBLK;          break;
+           case 'c': ftst = OP_FTCHR;          break;
+           case 't': ftst = OP_FTTTY;          break;
+           case 'T': ftst = OP_FTTEXT;         break;
+           case 'B': ftst = OP_FTBINARY;       break;
+           case 'M': case 'A': case 'C':
+               gv_fetchpv("\024",TRUE, SVt_PV);
+               switch (tmp) {
+               case 'M': ftst = OP_FTMTIME;    break;
+               case 'A': ftst = OP_FTATIME;    break;
+               case 'C': ftst = OP_FTCTIME;    break;
+               default:                        break;
+               }
+               break;
            default:
-               Perl_croak(aTHX_ "Unrecognized file test: -%c", (int)tmp);
                break;
            }
+           if (ftst) {
+               PL_last_lop_op = ftst;
+               DEBUG_T( { PerlIO_printf(Perl_debug_log,
+                        "### Saw file test %c\n", ftst);
+               } )
+               FTST(ftst);
+           }
+           else {
+               /* Assume it was a minus followed by a one-letter named
+                * subroutine call (or a -bareword), then. */
+               DEBUG_T( { PerlIO_printf(Perl_debug_log,
+                        "### %c looked like a file test but was not\n", ftst);
+               } )
+               s -= 2;
+           }
        }
        tmp = *s++;
        if (*s == tmp) {
@@ -3534,8 +3553,8 @@ Perl_yylex(pTHX)
     case '?':                  /* may either be conditional or pattern */
        if (PL_expect != XOPERATOR) {
            /* Disable warning on "study /blah/" */
-           if (PL_oldoldbufptr == PL_last_uni 
-               && (*PL_last_uni != 's' || s - PL_last_uni < 5 
+           if (PL_oldoldbufptr == PL_last_uni
+               && (*PL_last_uni != 's' || s - PL_last_uni < 5
                    || memNE(PL_last_uni, "study", 5)
                    || isALNUM_lazy_if(PL_last_uni+5,UTF)))
                check_uni();
@@ -3580,7 +3599,7 @@ 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, 
+        DEBUG_T( { PerlIO_printf(Perl_debug_log,
                     "### Saw number in '%s'\n", s);
         } )
        if (PL_expect == XOPERATOR)
@@ -3589,7 +3608,7 @@ Perl_yylex(pTHX)
 
     case '\'':
        s = scan_str(s,FALSE,FALSE);
-        DEBUG_T( { PerlIO_printf(Perl_debug_log, 
+        DEBUG_T( { PerlIO_printf(Perl_debug_log,
                     "### Saw string in '%s'\n", s);
         } )
        if (PL_expect == XOPERATOR) {
@@ -3608,7 +3627,7 @@ Perl_yylex(pTHX)
 
     case '"':
        s = scan_str(s,FALSE,FALSE);
-        DEBUG_T( { PerlIO_printf(Perl_debug_log, 
+        DEBUG_T( { PerlIO_printf(Perl_debug_log,
                     "### Saw string in '%s'\n", s);
         } )
        if (PL_expect == XOPERATOR) {
@@ -3633,7 +3652,7 @@ Perl_yylex(pTHX)
 
     case '`':
        s = scan_str(s,FALSE,FALSE);
-        DEBUG_T( { PerlIO_printf(Perl_debug_log, 
+        DEBUG_T( { PerlIO_printf(Perl_debug_log,
                     "### Saw backtick string in '%s'\n", s);
         } )
        if (PL_expect == XOPERATOR)
@@ -3835,7 +3854,7 @@ Perl_yylex(pTHX)
                    PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
                {
                    if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
-                       Perl_warner(aTHX_ WARN_BAREWORD, 
+                       Perl_warner(aTHX_ WARN_BAREWORD,
                            "Bareword \"%s\" refers to nonexistent package",
                             PL_tokenbuf);
                    len -= 2;
@@ -4231,7 +4250,7 @@ Perl_yylex(pTHX)
 
        case KEY_exists:
            UNI(OP_EXISTS);
-           
+       
        case KEY_exit:
            UNI(OP_EXIT);
 
@@ -4435,7 +4454,7 @@ Perl_yylex(pTHX)
        case KEY_last:
            s = force_word(s,WORD,TRUE,FALSE,FALSE);
            LOOPX(OP_LAST);
-           
+       
        case KEY_lc:
            UNI(OP_LC);
 
@@ -4580,7 +4599,7 @@ Perl_yylex(pTHX)
 
        case KEY_pos:
            UNI(OP_POS);
-           
+       
        case KEY_pack:
            LOP(OP_PACK,XTERM);
 
@@ -4742,7 +4761,7 @@ Perl_yylex(pTHX)
 
        case KEY_chomp:
            UNI(OP_CHOMP);
-           
+       
        case KEY_scalar:
            UNI(OP_SCALAR);
 
@@ -5031,7 +5050,7 @@ Perl_yylex(pTHX)
        case KEY_umask:
            if (ckWARN(WARN_UMASK)) {
                for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
-               if (*d != '0' && isDIGIT(*d)) 
+               if (*d != '0' && isDIGIT(*d))
                    Perl_warner(aTHX_ WARN_UMASK,
                                "umask: argument is missing initial 0");
            }
@@ -5086,7 +5105,7 @@ Perl_yylex(pTHX)
        {
            static char ctl_l[2];
 
-           if (ctl_l[0] == '\0') 
+           if (ctl_l[0] == '\0')
                ctl_l[0] = toCTRL('L');
            gv_fetchpv(ctl_l,TRUE, SVt_PV);
        }
@@ -5474,7 +5493,7 @@ Perl_keyword(pTHX_ register char *d, I32 len)
     case 'p':
        switch (len) {
        case 3:
-           if (strEQ(d,"pop"))                 return -KEY_pop; 
+           if (strEQ(d,"pop"))                 return -KEY_pop;
            if (strEQ(d,"pos"))                 return KEY_pos;
            break;
        case 4:
@@ -5795,14 +5814,14 @@ S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv,
     SV **cvp;
     SV *cv, *typesv;
     const char *why1, *why2, *why3;
-    
+
     if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
        SV *msg;
        
        why2 = strEQ(key,"charnames")
               ? "(possibly a missing \"use charnames ...\")"
               : "";
-       msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s", 
+       msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
                            (type ? type: "undef"), why2);
 
        /* This is convoluted and evil ("goto considered harmful")
@@ -5813,7 +5832,7 @@ S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv,
        goto msgdone;
 
     report:
-       msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s", 
+       msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
                            (type ? type: "undef"), why1, why2, why3);
     msgdone:
        yyerror(SvPVX(msg));
@@ -5835,11 +5854,11 @@ S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv,
        typesv = sv_2mortal(newSVpv(type, 0));
     else
        typesv = &PL_sv_undef;
-    
+
     PUSHSTACKi(PERLSI_OVERLOAD);
     ENTER ;
     SAVETMPS;
-    
+
     PUSHMARK(SP) ;
     EXTEND(sp, 3);
     if (pv)
@@ -5849,9 +5868,9 @@ S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv,
        PUSHs(typesv);
     PUTBACK;
     call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
-    
+
     SPAGAIN ;
-    
+
     /* Check the eval first */
     if (!PL_in_eval && SvTRUE(ERRSV)) {
        STRLEN n_a;
@@ -5864,12 +5883,12 @@ S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv,
        res = POPs;
        (void)SvREFCNT_inc(res);
     }
-    
+
     PUTBACK ;
     FREETMPS ;
     LEAVE ;
     POPSTACK;
-    
+
     if (!SvOK(res)) {
        why1 = "Call to &{$^H{";
        why2 = key;
@@ -5880,7 +5899,7 @@ S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv,
 
     return res;
 }
-  
+
 STATIC char *
 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
 {
@@ -6034,8 +6053,8 @@ S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN des
                PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
                return s;
            }
-       } 
-       /* Handle extended ${^Foo} variables 
+       }
+       /* Handle extended ${^Foo} variables
         * 1999-02-27 mjd-perl-patch@plover.com */
        else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
                 && isALNUM(*s))
@@ -6589,7 +6608,7 @@ S_scan_inputsymbol(pTHX_ char *start)
    calls scan_str().  s/// makes yylex() call scan_subst() which calls
    scan_str().  tr/// and y/// make yylex() call scan_trans() which
    calls scan_str().
-      
+
    It skips whitespace before the string starts, and treats the first
    character as the delimiter.  If the delimiter is one of ([{< then
    the corresponding "close" character )]}> is used as the closing
@@ -6756,7 +6775,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
        /* having changed the buffer, we must update PL_bufend */
        PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
     }
-    
+
     /* at this point, we have successfully read the delimited string */
 
     if (keep_delims)
@@ -6775,7 +6794,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
     /* decide whether this is the first or second quoted string we've read
        for this op
     */
-    
+
     if (PL_lex_stuff)
        PL_lex_repl = sv;
     else
@@ -6804,7 +6823,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
   try converting the number to an integer and see if it can do so
   without loss of precision.
 */
-  
+
 char *
 Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp)
 {
@@ -6822,7 +6841,7 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp)
     switch (*s) {
     default:
       Perl_croak(aTHX_ "panic: scan_num");
-      
+
     /* if it starts with a 0, it could be an octal number, a decimal in
        0.13 disguise, or a hexadecimal number, or a binary number. */
     case '0':
@@ -6992,7 +7011,7 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp)
 
        /* read next group of digits and _ and copy into d */
        while (isDIGIT(*s) || *s == '_') {
-           /* skip underscores, checking for misplaced ones 
+           /* skip underscores, checking for misplaced ones
               if -w is on
            */
            if (*s == '_') {
@@ -7121,7 +7140,7 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp)
           compilers have issues.  Then we try casting it back and see
           if it was the same [1].  We only do this if we know we
           specifically read an integer.  If floatit is true, then we
-          don't need to do the conversion at all. 
+          don't need to do the conversion at all.
 
           [1] Note that this is lossy if our NVs cannot preserve our
           UVs.  There are metaconfig defines NV_PRESERVES_UV (a boolean)
@@ -7132,7 +7151,7 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp)
           Maybe could do some tricks with DBL_DIG, LDBL_DIG and
           DBL_MANT_DIG and LDBL_MANT_DIG (these are already available
           as NV_DIG and NV_MANT_DIG)?
-          
+       
           --jhi
           */
        {
@@ -7149,7 +7168,7 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp)
 #endif
        if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
                       (PL_hints & HINT_NEW_INTEGER) )
-           sv = new_constant(PL_tokenbuf, d - PL_tokenbuf, 
+           sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
                              (floatit ? "float" : "integer"),
                              sv, Nullsv, NULL);
        break;
@@ -7164,7 +7183,7 @@ vstring:
                pos++;
            if (!isALPHA(*pos)) {
                UV rev;
-               U8 tmpbuf[UTF8_MAXLEN];
+               U8 tmpbuf[UTF8_MAXLEN+1];
                U8 *tmpend;
                bool utf8 = FALSE;
                s++;                            /* get past 'v' */
@@ -7470,8 +7489,8 @@ S_swallow_bom(pTHX_ U8 *s)
     STRLEN slen;
     slen = SvCUR(PL_linestr);
     switch (*s) {
-    case 0xFF:       
-       if (s[1] == 0xFE) { 
+    case 0xFF:
+       if (s[1] == 0xFE) {
            /* UTF-16 little-endian */
            if (s[2] == 0 && s[3] == 0)  /* UTF-32 little-endian */
                Perl_croak(aTHX_ "Unsupported script encoding");
@@ -7575,7 +7594,7 @@ utf16_textfilter(pTHXo_ int idx, SV *sv, int maxlen)
        if (!*SvPV_nolen(sv))
        /* Game over, but don't feed an odd-length string to utf16_to_utf8 */
        return count;
-       
+
        tend = utf16_to_utf8((U8*)SvPVX(sv), tmps, SvCUR(sv), &newlen);
        sv_usepvn(sv, (char*)tmps, tend - tmps);
     }
diff --git a/utf8.c b/utf8.c
index e61b037..fa84a8e 100644 (file)
--- a/utf8.c
+++ b/utf8.c
 /* Unicode support */
 
 U8 *
-Perl_uv_to_utf8(pTHX_ U8 *d, UV uv)
+Perl_uv_to_utf8(pTHX_ U8 *d, UV uv) /* the d must be UTF8_MAXLEN+1 deep */
 {
     if (uv < 0x80) {
        *d++ = uv;
+       *d   = 0;
        return d;
     }
     if (uv < 0x800) {
        *d++ = (( uv >>  6)         | 0xc0);
        *d++ = (( uv        & 0x3f) | 0x80);
+       *d   = 0;
        return d;
     }
     if (uv < 0x10000) {
        *d++ = (( uv >> 12)         | 0xe0);
        *d++ = (((uv >>  6) & 0x3f) | 0x80);
        *d++ = (( uv        & 0x3f) | 0x80);
+       *d   = 0;
        return d;
     }
     if (uv < 0x200000) {
@@ -49,6 +52,7 @@ Perl_uv_to_utf8(pTHX_ U8 *d, UV uv)
        *d++ = (((uv >> 12) & 0x3f) | 0x80);
        *d++ = (((uv >>  6) & 0x3f) | 0x80);
        *d++ = (( uv        & 0x3f) | 0x80);
+       *d   = 0;
        return d;
     }
     if (uv < 0x4000000) {
@@ -57,6 +61,7 @@ Perl_uv_to_utf8(pTHX_ U8 *d, UV uv)
        *d++ = (((uv >> 12) & 0x3f) | 0x80);
        *d++ = (((uv >>  6) & 0x3f) | 0x80);
        *d++ = (( uv        & 0x3f) | 0x80);
+       *d   = 0;
        return d;
     }
     if (uv < 0x80000000) {
@@ -66,6 +71,7 @@ Perl_uv_to_utf8(pTHX_ U8 *d, UV uv)
        *d++ = (((uv >> 12) & 0x3f) | 0x80);
        *d++ = (((uv >>  6) & 0x3f) | 0x80);
        *d++ = (( uv        & 0x3f) | 0x80);
+       *d   = 0;
        return d;
     }
 #ifdef HAS_QUAD
@@ -79,6 +85,7 @@ Perl_uv_to_utf8(pTHX_ U8 *d, UV uv)
        *d++ = (((uv >> 12) & 0x3f) | 0x80);
        *d++ = (((uv >>  6) & 0x3f) | 0x80);
        *d++ = (( uv        & 0x3f) | 0x80);
+       *d   = 0;
        return d;
     }
 #ifdef HAS_QUAD
@@ -96,6 +103,7 @@ Perl_uv_to_utf8(pTHX_ U8 *d, UV uv)
        *d++ = (((uv >> 12) & 0x3f) | 0x80);
        *d++ = (((uv >>  6) & 0x3f) | 0x80);
        *d++ = (( uv        & 0x3f) | 0x80);
+       *d   = 0;
        return d;
     }
 #endif
@@ -129,7 +137,7 @@ Perl_is_utf8_char(pTHX_ U8 *s)
     while (slen--) {
        if ((*s & 0xc0) != 0x80)
            return 0;
-       uv = (uv << 6) | (*s & 0x3f);
+       uv = UTF8_ACCUMULATE(uv, *s);
        if (uv < ouv)
            return 0;
        ouv = uv;
@@ -181,9 +189,13 @@ and the pointer C<s> will be advanced to the end of the character.
 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 
-(see F<utf8.h>).
+will silently just set C<retlen> to C<-1> and return zero.  If the
+C<flags> does not contain UTF8_CHECK_ONLY, warnings about
+malformations will be given, C<retlen> will be set to the expected
+length of the UTF-8 character in bytes, and zero will be returned.
+
+The C<flags> can also contain various flags to allow deviations from
+the strict UTF-8 encoding (see F<utf8.h>).
 
 =cut */
 
@@ -207,13 +219,13 @@ Perl_utf8_to_uv(pTHX_ U8* s, STRLEN curlen, STRLEN* retlen, U32 flags)
        goto malformed;
     }
 
-    if (uv <= 0x7f) { /* Pure ASCII. */
+    if (UTF8_IS_ASCII(uv)) {
        if (retlen)
            *retlen = 1;
        return *s;
     }
 
-    if ((uv >= 0x80 && uv <= 0xbf) &&
+    if (UTF8_IS_CONTINUATION(uv) &&
        !(flags & UTF8_ALLOW_CONTINUATION)) {
        if (dowarn)
            Perl_warner(aTHX_ WARN_UTF8,
@@ -222,11 +234,11 @@ Perl_utf8_to_uv(pTHX_ U8* s, STRLEN curlen, STRLEN* retlen, U32 flags)
        goto malformed;
     }
 
-    if ((uv >= 0xc0 && uv <= 0xfd && curlen > 1 && s[1] < 0x80) &&
+    if (UTF8_IS_START(uv) && curlen > 1 && !UTF8_IS_CONTINUATION(s[1]) &&
        !(flags & UTF8_ALLOW_NON_CONTINUATION)) {
        if (dowarn)
            Perl_warner(aTHX_ WARN_UTF8,
-                       "Malformed UTF-8 character (unexpected non-continuation byte 0x%02"UVxf" after byte 0x%02"UVxf")",
+                       "Malformed UTF-8 character (unexpected non-continuation byte 0x%02"UVxf" after start byte 0x%02"UVxf")",
                        (UV)s[1], uv);
        goto malformed;
     }
@@ -267,15 +279,16 @@ Perl_utf8_to_uv(pTHX_ U8* s, STRLEN curlen, STRLEN* retlen, U32 flags)
     ouv = uv;
 
     while (len--) {
-       if ((*s & 0xc0) != 0x80) {
+       if (!UTF8_IS_CONTINUATION(*s) &&
+           !(flags & UTF8_ALLOW_NON_CONTINUATION)) {
            if (dowarn)
                Perl_warner(aTHX_ WARN_UTF8,
-                           "Malformed UTF-8 character (unexpected continuation byte 0x%02x)",
+                           "Malformed UTF-8 character (unexpected non-continuation byte 0x%02x)",
                            *s);
            goto malformed;
        }
        else
-           uv = (uv << 6) | (*s & 0x3f);
+           uv = UTF8_ACCUMULATE(uv, *s);
        if (uv < ouv) {
            /* This cannot be allowed. */
            if (dowarn)
@@ -288,27 +301,20 @@ Perl_utf8_to_uv(pTHX_ U8* s, STRLEN curlen, STRLEN* retlen, U32 flags)
        ouv = uv;
     }
 
-    if ((uv >= 0xd800 && uv <= 0xdfff) &&
+    if (UNICODE_IS_SURROGATE(uv) &&
        !(flags & UTF8_ALLOW_SURROGATE)) {
        if (dowarn)
            Perl_warner(aTHX_ WARN_UTF8,
                        "Malformed UTF-8 character (UTF-16 surrogate 0x%04"UVxf")",
                        uv);
        goto malformed;
-    } else if ((uv == 0xfffe) &&
+    } else if (UNICODE_IS_BYTE_ORDER_MARK(uv) &&
               !(flags & UTF8_ALLOW_BOM)) {
        if (dowarn)
            Perl_warner(aTHX_ WARN_UTF8,
                        "Malformed UTF-8 character (byte order mark 0x%04"UVxf")",
                        uv);
        goto malformed;
-    } else if ((uv == 0xffff) &&
-              !(flags & UTF8_ALLOW_FFFF)) {
-       if (dowarn)
-           Perl_warner(aTHX_ WARN_UTF8,
-                       "Malformed UTF-8 character (character 0x%04"UVxf")",
-                       uv);
-       goto malformed;
     } else if ((expectlen > UNISKIP(uv)) &&
               !(flags & UTF8_ALLOW_LONG)) {
        if (dowarn)
@@ -316,6 +322,13 @@ Perl_utf8_to_uv(pTHX_ U8* s, STRLEN curlen, STRLEN* retlen, U32 flags)
                        "Malformed UTF-8 character (%d byte%s, need %d)",
                        expectlen, expectlen == 1 ? "": "s", UNISKIP(uv));
        goto malformed;
+    } else if (UNICODE_IS_ILLEGAL(uv) &&
+              !(flags & UTF8_ALLOW_FFFF)) {
+       if (dowarn)
+           Perl_warner(aTHX_ WARN_UTF8,
+                       "Malformed UTF-8 character (character 0x%04"UVxf")",
+                       uv);
+       goto malformed;
     }
 
     return uv;
@@ -331,7 +344,7 @@ malformed:
     if (retlen)
        *retlen = expectlen ? expectlen : len;
 
-    return UNICODE_REPLACEMENT_CHARACTER;
+    return 0;
 }
 
 /*
@@ -355,7 +368,7 @@ Perl_utf8_to_uv_simple(pTHX_ U8* s, STRLEN* retlen)
 }
 
 /*
-=for apidoc|utf8_length|U8 *s|U8 *e
+=for apidoc Am|STRLEN|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
@@ -369,6 +382,10 @@ Perl_utf8_length(pTHX_ U8* s, U8* e)
 {
     STRLEN len = 0;
 
+    /* Note: cannot use UTF8_IS_...() too eagerly here since e.g.
+     * the bitops (especially ~) can create illegal UTF-8.
+     * In other words: in Perl UTF-8 is not just for Unicode. */
+
     if (e < s)
        Perl_croak(aTHX_ "panic: utf8_length: unexpected end");
     while (s < e) {
@@ -383,14 +400,26 @@ Perl_utf8_length(pTHX_ U8* s, U8* e)
     return len;
 }
 
-/* utf8_distance(a,b) returns the number of UTF8 characters between
-   the pointers a and b                                                        */
+/*
+=for apidoc Am|IV|utf8_distance|U8 *a|U8 *b
+
+Returns the number of UTF8 characters between the UTF-8 pointers C<a>
+and C<b>.
+
+WARNING: use only if you *know* that the pointers point inside the
+same UTF-8 buffer.
+
+=cut */
 
 IV
 Perl_utf8_distance(pTHX_ U8 *a, U8 *b)
 {
     IV off = 0;
 
+    /* Note: cannot use UTF8_IS_...() too eagerly here since  e.g.
+     * the bitops (especially ~) can create illegal UTF-8.
+     * In other words: in Perl UTF-8 is not just for Unicode. */
+
     if (a < b) {
        while (a < b) {
            U8 c = UTF8SKIP(a);
@@ -415,11 +444,25 @@ Perl_utf8_distance(pTHX_ U8 *a, U8 *b)
     return off;
 }
 
-/* WARNING: do not use the following unless you *know* off is within bounds */
+/*
+=for apidoc Am|U8*|utf8_hop|U8 *s|I32 off
+
+Return the UTF-8 pointer C<s> displaced by C<off> characters, either
+forward or backward.
+
+WARNING: do not use the following unless you *know* C<off> is within
+the UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned
+on the first byte of character or just after the last byte of a character.
+
+=cut */
 
 U8 *
 Perl_utf8_hop(pTHX_ U8 *s, I32 off)
 {
+    /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
+     * the bitops (especially ~) can create illegal UTF-8.
+     * In other words: in Perl UTF-8 is not just for Unicode. */
+
     if (off >= 0) {
        while (off--)
            s += UTF8SKIP(s);
@@ -427,10 +470,8 @@ Perl_utf8_hop(pTHX_ U8 *s, I32 off)
     else {
        while (off++) {
            s--;
-           if (*s & 0x80) {
-               while ((*s & 0xc0) == 0x80)
-                   s--;
-           }
+           while (UTF8_IS_CONTINUATION(*s))
+               s--;
        }
     }
     return s;
@@ -468,14 +509,9 @@ Perl_utf8_to_bytes(pTHX_ U8* s, STRLEN *len)
 
     d = s = save;
     while (s < send) {
-        if (*s < 0x80) {
-           *d++ = *s++;
-       }
-        else {
-            STRLEN ulen;
-            *d++ = (U8)utf8_to_uv_simple(s, &ulen);
-            s += ulen;
-        }
+        STRLEN ulen;
+        *d++ = (U8)utf8_to_uv_simple(s, &ulen);
+        s += ulen;
     }
     *d = '\0';
     *len = d - save;
@@ -593,7 +629,7 @@ Perl_utf16_to_utf8_reversed(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
 bool
 Perl_is_uni_alnum(pTHX_ U32 c)
 {
-    U8 tmpbuf[UTF8_MAXLEN];
+    U8 tmpbuf[UTF8_MAXLEN+1];
     uv_to_utf8(tmpbuf, (UV)c);
     return is_utf8_alnum(tmpbuf);
 }
@@ -601,7 +637,7 @@ Perl_is_uni_alnum(pTHX_ U32 c)
 bool
 Perl_is_uni_alnumc(pTHX_ U32 c)
 {
-    U8 tmpbuf[UTF8_MAXLEN];
+    U8 tmpbuf[UTF8_MAXLEN+1];
     uv_to_utf8(tmpbuf, (UV)c);
     return is_utf8_alnumc(tmpbuf);
 }
@@ -609,7 +645,7 @@ Perl_is_uni_alnumc(pTHX_ U32 c)
 bool
 Perl_is_uni_idfirst(pTHX_ U32 c)
 {
-    U8 tmpbuf[UTF8_MAXLEN];
+    U8 tmpbuf[UTF8_MAXLEN+1];
     uv_to_utf8(tmpbuf, (UV)c);
     return is_utf8_idfirst(tmpbuf);
 }
@@ -617,7 +653,7 @@ Perl_is_uni_idfirst(pTHX_ U32 c)
 bool
 Perl_is_uni_alpha(pTHX_ U32 c)
 {
-    U8 tmpbuf[UTF8_MAXLEN];
+    U8 tmpbuf[UTF8_MAXLEN+1];
     uv_to_utf8(tmpbuf, (UV)c);
     return is_utf8_alpha(tmpbuf);
 }
@@ -625,7 +661,7 @@ Perl_is_uni_alpha(pTHX_ U32 c)
 bool
 Perl_is_uni_ascii(pTHX_ U32 c)
 {
-    U8 tmpbuf[UTF8_MAXLEN];
+    U8 tmpbuf[UTF8_MAXLEN+1];
     uv_to_utf8(tmpbuf, (UV)c);
     return is_utf8_ascii(tmpbuf);
 }
@@ -633,7 +669,7 @@ Perl_is_uni_ascii(pTHX_ U32 c)
 bool
 Perl_is_uni_space(pTHX_ U32 c)
 {
-    U8 tmpbuf[UTF8_MAXLEN];
+    U8 tmpbuf[UTF8_MAXLEN+1];
     uv_to_utf8(tmpbuf, (UV)c);
     return is_utf8_space(tmpbuf);
 }
@@ -641,7 +677,7 @@ Perl_is_uni_space(pTHX_ U32 c)
 bool
 Perl_is_uni_digit(pTHX_ U32 c)
 {
-    U8 tmpbuf[UTF8_MAXLEN];
+    U8 tmpbuf[UTF8_MAXLEN+1];
     uv_to_utf8(tmpbuf, (UV)c);
     return is_utf8_digit(tmpbuf);
 }
@@ -649,7 +685,7 @@ Perl_is_uni_digit(pTHX_ U32 c)
 bool
 Perl_is_uni_upper(pTHX_ U32 c)
 {
-    U8 tmpbuf[UTF8_MAXLEN];
+    U8 tmpbuf[UTF8_MAXLEN+1];
     uv_to_utf8(tmpbuf, (UV)c);
     return is_utf8_upper(tmpbuf);
 }
@@ -657,7 +693,7 @@ Perl_is_uni_upper(pTHX_ U32 c)
 bool
 Perl_is_uni_lower(pTHX_ U32 c)
 {
-    U8 tmpbuf[UTF8_MAXLEN];
+    U8 tmpbuf[UTF8_MAXLEN+1];
     uv_to_utf8(tmpbuf, (UV)c);
     return is_utf8_lower(tmpbuf);
 }
@@ -665,7 +701,7 @@ Perl_is_uni_lower(pTHX_ U32 c)
 bool
 Perl_is_uni_cntrl(pTHX_ U32 c)
 {
-    U8 tmpbuf[UTF8_MAXLEN];
+    U8 tmpbuf[UTF8_MAXLEN+1];
     uv_to_utf8(tmpbuf, (UV)c);
     return is_utf8_cntrl(tmpbuf);
 }
@@ -673,7 +709,7 @@ Perl_is_uni_cntrl(pTHX_ U32 c)
 bool
 Perl_is_uni_graph(pTHX_ U32 c)
 {
-    U8 tmpbuf[UTF8_MAXLEN];
+    U8 tmpbuf[UTF8_MAXLEN+1];
     uv_to_utf8(tmpbuf, (UV)c);
     return is_utf8_graph(tmpbuf);
 }
@@ -681,7 +717,7 @@ Perl_is_uni_graph(pTHX_ U32 c)
 bool
 Perl_is_uni_print(pTHX_ U32 c)
 {
-    U8 tmpbuf[UTF8_MAXLEN];
+    U8 tmpbuf[UTF8_MAXLEN+1];
     uv_to_utf8(tmpbuf, (UV)c);
     return is_utf8_print(tmpbuf);
 }
@@ -689,7 +725,7 @@ Perl_is_uni_print(pTHX_ U32 c)
 bool
 Perl_is_uni_punct(pTHX_ U32 c)
 {
-    U8 tmpbuf[UTF8_MAXLEN];
+    U8 tmpbuf[UTF8_MAXLEN+1];
     uv_to_utf8(tmpbuf, (UV)c);
     return is_utf8_punct(tmpbuf);
 }
@@ -697,7 +733,7 @@ Perl_is_uni_punct(pTHX_ U32 c)
 bool
 Perl_is_uni_xdigit(pTHX_ U32 c)
 {
-    U8 tmpbuf[UTF8_MAXLEN];
+    U8 tmpbuf[UTF8_MAXLEN+1];
     uv_to_utf8(tmpbuf, (UV)c);
     return is_utf8_xdigit(tmpbuf);
 }
@@ -705,7 +741,7 @@ Perl_is_uni_xdigit(pTHX_ U32 c)
 U32
 Perl_to_uni_upper(pTHX_ U32 c)
 {
-    U8 tmpbuf[UTF8_MAXLEN];
+    U8 tmpbuf[UTF8_MAXLEN+1];
     uv_to_utf8(tmpbuf, (UV)c);
     return to_utf8_upper(tmpbuf);
 }
@@ -713,7 +749,7 @@ Perl_to_uni_upper(pTHX_ U32 c)
 U32
 Perl_to_uni_title(pTHX_ U32 c)
 {
-    U8 tmpbuf[UTF8_MAXLEN];
+    U8 tmpbuf[UTF8_MAXLEN+1];
     uv_to_utf8(tmpbuf, (UV)c);
     return to_utf8_title(tmpbuf);
 }
@@ -721,7 +757,7 @@ Perl_to_uni_title(pTHX_ U32 c)
 U32
 Perl_to_uni_lower(pTHX_ U32 c)
 {
-    U8 tmpbuf[UTF8_MAXLEN];
+    U8 tmpbuf[UTF8_MAXLEN+1];
     uv_to_utf8(tmpbuf, (UV)c);
     return to_utf8_lower(tmpbuf);
 }
diff --git a/utf8.h b/utf8.h
index 522f4a9..9359721 100644 (file)
--- a/utf8.h
+++ b/utf8.h
@@ -48,10 +48,31 @@ END_EXTERN_C
 #define UTF8_ALLOW_ANY                 0x00ff
 #define UTF8_CHECK_ONLY                        0x0100
 
+#define UNICODE_SURROGATE_FIRST                0xd800
+#define UNICODE_SURROGATE_LAST         0xdfff
+#define UNICODE_REPLACEMENT            0xfffd
+#define UNICODE_BYTER_ORDER_MARK       0xfffe
+#define UNICODE_ILLEGAL                        0xffff
+
+#define UNICODE_IS_SURROGATE(c)                ((c) >= UNICODE_SURROGATE_FIRST && \
+                                        (c) <= UNICODE_SURROGATE_LAST)
+#define UNICODE_IS_REPLACEMENT(c)      ((c) == UNICODE_REPLACMENT)
+#define UNICODE_IS_BYTE_ORDER_MARK(c)  ((c) == UNICODE_BYTER_ORDER_MARK)
+#define UNICODE_IS_ILLEGAL(c)          ((c) == UNICODE_ILLEGAL)
+
 #define UTF8SKIP(s) PL_utf8skip[*(U8*)s]
 
 #define UTF8_QUAD_MAX  UINT64_C(0x1000000000)
 
+#define UTF8_IS_ASCII(c)               ((c) <  0x80)
+#define UTF8_IS_START(c)               ((c) >= 0xc0 && ((c) <= 0xfd))
+#define UTF8_IS_CONTINUATION(c)                ((c) >= 0x80 && ((c) <= 0xbf))
+#define UTF8_IS_CONTINUED(c)           ((c) &  0x80)
+
+#define UTF8_CONTINUATION_MASK         0x3f
+#define UTF8_ACCUMULATION_SHIFT                6
+#define UTF8_ACCUMULATE(old, new)      ((old) << UTF8_ACCUMULATION_SHIFT | ((new) & UTF8_CONTINUATION_MASK))
+
 #ifdef HAS_QUAD
 #define UNISKIP(uv) ( (uv) < 0x80           ? 1 : \
                      (uv) < 0x800          ? 2 : \
@@ -70,7 +91,6 @@ END_EXTERN_C
                      (uv) < 0x80000000     ? 6 : 7 )
 #endif
 
-#define UNICODE_REPLACEMENT_CHARACTER  0xfffd
 
 /*
  * Note: we try to be careful never to call the isXXX_utf8() functions