This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
eval STRING UTF8 cleanup.
authorBrian Fraser <fraserbn@gmail.com>
Fri, 5 Aug 2011 10:30:11 +0000 (11:30 +0100)
committerFather Chrysostomos <sprout@cpan.org>
Sun, 6 Nov 2011 08:13:45 +0000 (01:13 -0700)
(modified by the committer only to apply when the unicode_eval
feature is enabled)

MANIFEST
op.c
op.h
parser.h
pp_ctl.c
t/uni/eval.t [new file with mode: 0644]
toke.c

index 3dcf36d..058a572 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -5333,6 +5333,7 @@ t/uni/case.pl                     See if Unicode casing works
 t/uni/chomp.t                  See if Unicode chomp works
 t/uni/chr.t                    See if Unicode chr works
 t/uni/class.t                  See if Unicode classes work (\p)
+t/uni/eval.t                   See if Unicode hints don't affect eval()
 t/uni/fold.t                   See if Unicode folding works
 t/uni/goto.t                   See if Unicode goto &sub works
 t/uni/greek.t                  See if Unicode in greek works
diff --git a/op.c b/op.c
index ba24365..d5f1dd9 100644 (file)
--- a/op.c
+++ b/op.c
@@ -7484,6 +7484,8 @@ Perl_ck_eval(pTHX_ OP *o)
                           MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
        cUNOPo->op_first->op_sibling = hhop;
        o->op_private |= OPpEVAL_HAS_HH;
+       if (FEATURE_IS_ENABLED("unieval"))
+           o->op_private |= OPpEVAL_UNICODE;
     }
     return o;
 }
diff --git a/op.h b/op.h
index 76b17bb..a9ecedb 100644 (file)
--- a/op.h
+++ b/op.h
@@ -295,6 +295,7 @@ Deprecated.  Use C<GIMME_V> instead.
     
 /* Private for OP_ENTEREVAL */
 #define OPpEVAL_HAS_HH         2       /* Does it have a copy of %^H */
+#define OPpEVAL_UNICODE                4
     
 /* Private for OP_CALLER and OP_WANTARRAY */
 #define OPpOFFBYONE            128     /* Treat caller(1) as caller(2) */
index 17ced8f..bbf3bf3 100644 (file)
--- a/parser.h
+++ b/parser.h
@@ -107,6 +107,7 @@ typedef struct yy_parser {
 
     bool       in_pod;         /* lexer is within a =pod section */
     U8         lex_fakeeof;    /* precedence at which to fake EOF */
+    U32                lex_flags;
 } yy_parser;
 
 /* flags for lexer API */
@@ -118,6 +119,7 @@ typedef struct yy_parser {
 
 /* flags for parser API */
 #define PARSE_OPTIONAL          0x00000001
+#define LEX_IGNORE_UTF8_HINTS  0x00000002
 
 /* values for lex_fakeeof */
 enum {
index 6405924..153d98e 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -4146,7 +4146,9 @@ PP(pp_entereval)
     TAINT_PROPER("eval");
 
     ENTER_with_name("eval");
-    lex_start(sv, NULL, LEX_START_SAME_FILTER);
+    lex_start(sv, NULL, LEX_START_SAME_FILTER |
+                         ( PL_op->op_private & OPpEVAL_UNICODE
+                            ? LEX_IGNORE_UTF8_HINTS : 0 ));
     SAVETMPS;
 
     /* switch to eval mode */
diff --git a/t/uni/eval.t b/t/uni/eval.t
new file mode 100644 (file)
index 0000000..f08c706
--- /dev/null
@@ -0,0 +1,42 @@
+#!./perl
+
+# Check if eval correctly ignores the UTF-8 hint.
+
+BEGIN {
+    require './test.pl';
+}
+
+plan (tests => 5);
+
+use open qw( :utf8 :std );
+use feature 'unicode_eval';
+
+{
+    my $w;
+    $SIG{__WARN__} = sub { $w = shift };
+    use utf8;
+    my $prog = "qq!\x{f9}!";
+
+    eval $prog;
+    ok !$w;
+
+    $w = "";
+    utf8::upgrade($prog);
+    eval $prog;
+    is $w, '';
+}
+
+{
+    use utf8;
+    isnt eval "q!\360\237\220\252!", eval "q!\x{1f42a}!";
+}
+
+{
+    no utf8; #Let's make real sure.
+    my $not_utf8 = "q!\343\203\213!";
+    isnt eval $not_utf8, eval "q!\x{30cb}!";
+    {
+        use utf8;
+        isnt eval $not_utf8, eval "q!\x{30cb}!";
+    }
+}
diff --git a/toke.c b/toke.c
index aaeff85..43ca704 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -133,7 +133,7 @@ static const char ident_too_long[] = "Identifier too long";
 #ifdef USE_UTF8_SCRIPTS
 #   define UTF (!IN_BYTES)
 #else
-#   define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || (PL_hints & HINT_UTF8))
+#   define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || ( !(PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS) && (PL_hints & HINT_UTF8)))
 #endif
 
 /* The maximum number of characters preceding the unrecognized one to display */
@@ -686,7 +686,7 @@ Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags)
     const char *s = NULL;
     STRLEN len;
     yy_parser *parser, *oparser;
-    if (flags && flags != LEX_START_SAME_FILTER)
+    if (flags && flags & ~(LEX_START_SAME_FILTER|LEX_IGNORE_UTF8_HINTS))
        Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_start");
 
     /* create and initialise a parser */
@@ -743,6 +743,7 @@ Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags)
        parser->linestart = SvPVX(parser->linestr);
     parser->bufend = parser->bufptr + SvCUR(parser->linestr);
     parser->last_lop = parser->last_uni = NULL;
+    parser->lex_flags = flags & LEX_IGNORE_UTF8_HINTS;
 
     parser->in_pod = 0;
 }