toke.c: Fix bugs where UTF-8 is turned on in mid chunk
authorKarl Williamson <khw@cpan.org>
Mon, 13 Feb 2017 19:35:18 +0000 (12:35 -0700)
committerKarl Williamson <khw@cpan.org>
Tue, 14 Feb 2017 04:24:08 +0000 (21:24 -0700)
Previous commits have tightened up the checking of UTF-8 for
well-formedness in the input program or string eval.  This is done in
lex_next_chunk and lex_start.  But it doesn't handle the case of

    use utf8; foo

because 'foo' is checked while UTF-8 is still off.  This solves that
problem by noticing when utf8 is turned on, and then rechecking at the
next opportunity.

See thread beginning at
http://nntp.perl.org/group/perl.perl5.porters/242916

This fixes [perl #130675].  A test will be added in a future commit

This catches some errors earlier than they used to be and aborts. so
some tests in the suite had to be split into multiple parts.

embed.fnc
embed.h
lib/utf8.t
mg.c
parser.h
proto.h
sv.c
t/lib/croak/toke
t/lib/croak/toke_l1
t/uni/parser.t
toke.c

index d548f5d..2ce7274 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -859,6 +859,7 @@ pP  |I32    |keyword        |NN const char *name|I32 len|bool all_keywords
 s      |void   |inplace_aassign        |NN OP* o
 #endif
 Ap     |void   |leave_scope    |I32 base
+p      |void   |notify_parser_that_changed_to_utf8
 : Public lexer API
 AMpd   |void   |lex_start      |NULLOK SV* line|NULLOK PerlIO *rsfp|U32 flags
 AMpd   |bool   |lex_bufutf8
diff --git a/embed.h b/embed.h
index 2233a35..ce7b9c6 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define newXS_len_flags(a,b,c,d,e,f,g) Perl_newXS_len_flags(aTHX_ a,b,c,d,e,f,g)
 #define nextargv(a,b)          Perl_nextargv(aTHX_ a,b)
 #define noperl_die             Perl_noperl_die
+#define notify_parser_that_changed_to_utf8()   Perl_notify_parser_that_changed_to_utf8(aTHX)
 #define oopsAV(a)              Perl_oopsAV(aTHX_ a)
 #define oopsHV(a)              Perl_oopsHV(aTHX_ a)
 #define op_unscope(a)          Perl_op_unscope(aTHX_ a)
index e5f9547..d35110b 100644 (file)
@@ -168,7 +168,7 @@ no utf8; # Ironic, no?
     use utf8; %a = ("$malformed" =>"sterling");
     print 'start'; printf '%x,', ord \$_ foreach keys %a; print "end\n";
 BANG
-             qr/^Malformed UTF-8 character: .*? \(too short; \d bytes? available, need \d\).*start\d+,end$/sm
+             qr/^Malformed UTF-8 character: .*? \(unexpected non-continuation byte/
             ],
             );
     foreach (@tests) {
diff --git a/mg.c b/mg.c
index f15eef4..6e648d8 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -2737,7 +2737,15 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
        PL_maxsysfd = SvIV(sv);
        break;
     case '\010':       /* ^H */
+        {
+            U32 save_hints = PL_hints;
             PL_hints = SvUV(sv);
+
+            /* If wasn't UTF-8, and now is, notify the parser */
+            if ((PL_hints & HINT_UTF8) && ! (save_hints & HINT_UTF8)) {
+                notify_parser_that_changed_to_utf8();
+            }
+        }
        break;
     case '\011':       /* ^I */ /* NOT \t in EBCDIC */
        Safefree(PL_inplace);
index ad148c2..4187e0a 100644 (file)
--- a/parser.h
+++ b/parser.h
@@ -115,6 +115,8 @@ typedef struct yy_parser {
     IV          sig_optelems;   /* number of optional signature elems seen */
     char        sig_slurpy;     /* the sigil of the slurpy var (or null) */
 
+    bool        recheck_utf8_validity;
+
     PERL_BITFIELD16    in_pod:1;      /* lexer is within a =pod section */
     PERL_BITFIELD16    filtered:1;    /* source filters in evalbytes */
     PERL_BITFIELD16    saw_infix_sigil:1; /* saw & or * or % operator */
diff --git a/proto.h b/proto.h
index 7ec7849..076df94 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -2331,6 +2331,7 @@ PERL_CALLCONV_NO_RET void Perl_noperl_die(const char* pat, ...)
        assert(pat)
 
 PERL_CALLCONV int      Perl_nothreadhook(pTHX);
+PERL_CALLCONV void     Perl_notify_parser_that_changed_to_utf8(pTHX);
 PERL_CALLCONV OP*      Perl_oopsAV(pTHX_ OP* o)
                        __attribute__warn_unused_result__;
 #define PERL_ARGS_ASSERT_OOPSAV        \
diff --git a/sv.c b/sv.c
index 472d69c..e0c327a 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -13204,6 +13204,7 @@ Perl_parser_dup(pTHX_ const yy_parser *const proto, CLONE_PARAMS *const param)
     parser->sig_elems  = proto->sig_elems;
     parser->sig_optelems= proto->sig_optelems;
     parser->sig_slurpy  = proto->sig_slurpy;
+    parser->recheck_utf8_validity = proto->recheck_utf8_validity;
     parser->linestr    = sv_dup_inc(proto->linestr, param);
 
     {
index f1817b3..4035495 100644 (file)
@@ -180,9 +180,16 @@ Execution of - aborted due to compilation errors.
 # NAME Regexp constant overloading when *^H is undefined
 use overload;
 BEGIN { overload::constant qr => sub {}; undef *^H }
-/a/, m'a'
+/a/
 EXPECT
 Constant(qq) unknown at - line 3, within pattern
+Execution of - aborted due to compilation errors.
+########
+# NAME Regexp constant overloading when *^H is undefined
+use overload;
+BEGIN { overload::constant qr => sub {}; undef *^H }
+m'a'
+EXPECT
 Constant(q) unknown at - line 3, within pattern
 Execution of - aborted due to compilation errors.
 ########
@@ -232,9 +239,16 @@ Execution of - aborted due to compilation errors.
 # NAME Regexp constant overloading returning undef
 use overload;
 BEGIN { overload::constant qr => sub {} }
-/a/, m'a'
+/a/
 EXPECT
 Constant(qq): Call to &{$^H{qr}} did not return a defined value at - line 3, within pattern
+Execution of - aborted due to compilation errors.
+########
+# NAME Regexp constant overloading returning undef
+use overload;
+BEGIN { overload::constant qr => sub {} }
+m'a'
+EXPECT
 Constant(q): Call to &{$^H{qr}} did not return a defined value at - line 3, within pattern
 Execution of - aborted due to compilation errors.
 ########
index bb85b02..7cef6e6 100644 (file)
Binary files a/t/lib/croak/toke_l1 and b/t/lib/croak/toke_l1 differ
index 624fdd0..2c68fb0 100644 (file)
@@ -197,7 +197,7 @@ like( $@, qr/Bad name after Foo'/, 'Bad name after Foo\'' );
                            ? "\x{74}\x{41}"
                            : "\x{c0}\x{a0}";
     CORE::evalbytes "use charnames ':full'; use utf8; my \$x = \"\\N{abc$malformed_to_be}\"";
-    like( $@, qr/Malformed UTF-8 character immediately after '\\N\{abc' at .* within string/, 'Malformed UTF-8 input to \N{}');
+    like( $@, qr/Malformed UTF-8 character \(fatal\) at /, 'Malformed UTF-8 input to \N{}');
 }
 
 # RT# 124216: Perl_sv_clear: Assertion
diff --git a/toke.c b/toke.c
index b7d78f7..3fe5bda 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -727,6 +727,7 @@ Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags)
     parser->lex_state = LEX_NORMAL;
     parser->expect = XSTATE;
     parser->rsfp = rsfp;
+    parser->recheck_utf8_validity = FALSE;
     parser->rsfp_filters =
       !(flags & LEX_START_SAME_FILTER) || !oparser
         ? NULL
@@ -1275,6 +1276,24 @@ Perl_lex_discard_to(pTHX_ char *ptr)
        PL_parser->last_lop -= discard_len;
 }
 
+void
+Perl_notify_parser_that_changed_to_utf8(pTHX)
+{
+    /* Called when $^H is changed to indicate that HINT_UTF8 has changed from
+     * off to on.  At compile time, this has the effect of entering a 'use
+     * utf8' section.  This means that any input was not previously checked for
+     * UTF-8 (because it was off), but now we do need to check it, or our
+     * assumptions about the input being sane could be wrong, and we could
+     * segfault.  This routine just sets a flag so that the next time we look
+     * at the input we do the well-formed UTF-8 check.  If we aren't in the
+     * proper phase, there may not be a parser object, but if there is, setting
+     * the flag is harmless */
+
+    if (PL_parser) {
+        PL_parser->recheck_utf8_validity = TRUE;
+    }
+}
+
 /*
 =for apidoc Amx|bool|lex_next_chunk|U32 flags
 
@@ -4762,6 +4781,20 @@ Perl_yylex(pTHX)
     GV *gv = NULL;
     GV **gvp = NULL;
 
+    if (UNLIKELY(PL_parser->recheck_utf8_validity)) {
+        const U8* first_bad_char_loc;
+        if (UTF && UNLIKELY(! is_utf8_string_loc((U8 *) PL_bufptr,
+                                                        PL_bufend - PL_bufptr,
+                                                        &first_bad_char_loc)))
+        {
+            _force_out_malformed_utf8_message(first_bad_char_loc,
+                                              (U8 *) PL_bufend,
+                                              0,
+                                              1 /* 1 means die */ );
+            NOT_REACHED; /* NOTREACHED */
+        }
+        PL_parser->recheck_utf8_validity = FALSE;
+    }
     DEBUG_T( {
        SV* tmp = newSVpvs("");
        PerlIO_printf(Perl_debug_log, "### %" IVdf ":LEX_%s/X%s %s\n",