This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add evalbytes function
authorFather Chrysostomos <sprout@cpan.org>
Sun, 30 Oct 2011 21:33:06 +0000 (14:33 -0700)
committerFather Chrysostomos <sprout@cpan.org>
Sun, 6 Nov 2011 08:13:48 +0000 (01:13 -0700)
This function evaluates its argument as a byte string, regardless of
the internal encoding.  It croaks if the string contains characters
outside the byte range.  Hence evalbytes(" use utf8; '\xc4\x80' ")
will return "\x{100}", even if the original string had the UTF8 flag
on, and evalbytes(" '\xc4\x80' ") will return "\xc4\x80".

This has the side effect of fixing the deparsing of CORE::break under
‘use feature’ when there is an override.

19 files changed:
MANIFEST
dist/B-Deparse/Deparse.pm
dist/B-Deparse/t/core.t
dist/B-Deparse/t/deparse.t
ext/B/t/concise-xs.t
keywords.c
keywords.h
lib/feature.pm
op.c
op.h
opcode.h
pp_ctl.c
regen/keywords.pl
regen/opcodes
t/op/coreamp.t
t/op/coresubs.t
t/op/cproto.t
t/op/evalbytes.t [new file with mode: 0644]
toke.c

index 058a572..30dfe57 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -5091,6 +5091,7 @@ t/op/dor.t                        See if defined-or (//) works
 t/op/do.t                      See if subroutines work
 t/op/each_array.t              See if array iterators work
 t/op/each.t                    See if hash iterators work
+t/op/evalbytes.t               See if evalbytes operator works
 t/op/eval.t                    See if eval operator works
 t/op/exec.t                    See if exec, system and qx work
 t/op/exists_sub.t              See if exists(&sub) works
index b8b30f3..428466b 100644 (file)
@@ -33,7 +33,10 @@ use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
             # version number bumped to 5.15.3, this can be reduced to
             # just test $] < 5.015003.
             ($] < 5.015002 || do { require B; exists(&B::OPpCONST_ARYBASE) })
-            ? qw(OPpCONST_ARYBASE) : ());
+            ? qw(OPpCONST_ARYBASE) : ()),
+        ($] < 5.015005 &&
+            ($] < 5.015004 || do { require B; exists(&B::OPpEVAL_BYTES) })
+            ? qw(OPpEVAL_BYTES) : ());
 $VERSION = "1.09";
 use strict;
 use vars qw/$AUTOLOAD/;
@@ -44,7 +47,7 @@ BEGIN {
     # be to fake up a dummy constant that will never actually be true.
     foreach (qw(OPpSORT_INPLACE OPpSORT_DESCEND OPpITER_REVERSED OPpCONST_NOVER
                OPpPAD_STATE RXf_SKIPWHITE CVf_LOCKED OPpREVERSE_INPLACE
-               PMf_NONDESTRUCT OPpCONST_ARYBASE)) {
+               PMf_NONDESTRUCT OPpCONST_ARYBASE OPpEVAL_BYTES)) {
        no strict 'refs';
        *{$_} = sub () {0} unless *{$_}{CODE};
     }
@@ -1557,6 +1560,7 @@ my %feature_keywords = (
     when    => 'switch',
     default => 'switch',
     break   => 'switch',
+    evalbytes=>'evalbytes',
 );
 
 sub keyword {
@@ -1564,11 +1568,9 @@ sub keyword {
     my $name = shift;
     return $name if $name =~ /^CORE::/; # just in case
     if (exists $feature_keywords{$name}) {
-       return
-         $self->{'hinthash'}
-          && $self->{'hinthash'}{"feature_$feature_keywords{$name}"}
-           ? $name
-           : "CORE::$name";
+       return "CORE::$name"
+        if !$self->{'hinthash'}
+        || !$self->{'hinthash'}{"feature_$feature_keywords{$name}"}
     }
     if (
       $name !~ /^(?:chom?p|do|exec|glob|s(?:elect|ystem))\z/
@@ -1766,7 +1768,12 @@ sub pp_alarm { unop(@_, "alarm") }
 sub pp_sleep { maybe_targmy(@_, \&unop, "sleep") }
 
 sub pp_dofile { unop(@_, "do") }
-sub pp_entereval { unop(@_, "eval") }
+sub pp_entereval {
+    unop(
+      @_,
+      $_[1]->private & OPpEVAL_BYTES ? $_[0]->keyword('evalbytes') : "eval"
+    )
+}
 
 sub pp_ghbyname { unop(@_, "gethostbyname") }
 sub pp_gnbyname { unop(@_, "getnetbyname") }
index 2d5aa32..81d9038 100644 (file)
@@ -10,6 +10,8 @@ BEGIN {
 
 use strict;
 use Test::More;
+use feature (sprintf(":%vd", $^V)); # to avoid relying on the feature
+                                    # logic to add CORE::
 
 # Many functions appear in multiple lists, so that shift() and shift(foo)
 # are both tested.
@@ -18,7 +20,8 @@ my @nary = (
  # nullary functions
      [qw( abs alarm break chr cos chop close chdir chomp chmod chown
           chroot caller continue die dump exp exit exec endgrent
-          endpwent endnetent endhostent endservent endprotoent fork glob
+          endpwent endnetent endhostent endservent
+          endprotoent evalbytes fork glob
           getppid getpwent getprotoent gethostent getnetent getservent
           getgrent getlogin getc gmtime hex int lc log lstat length
           lcfirst localtime mkdir ord oct pop quotemeta ref rand
@@ -28,7 +31,7 @@ my @nary = (
  # unary
      [qw( abs alarm bless binmode chr cos chop close chdir chomp
           chmod chown chroot closedir die do dump exp exit exec
-          each fileno getpgrp getpwnam getpwuid getpeername
+          each evalbytes fileno getpgrp getpwnam getpwuid getpeername
           getprotobyname getprotobynumber gethostbyname
           getnetbyname getsockname getgrnam getgrgid
           getc glob gmtime hex int join keys kill lc
index 53b8d23..ef66090 100644 (file)
@@ -765,6 +765,7 @@ CORE::given ($x) {
         CORE::break;
     }
 }
+CORE::evalbytes '';
 ####
 # $#- $#+ $#{%} etc.
 my @x;
index 67b8591..5e88b9f 100644 (file)
@@ -169,7 +169,7 @@ my $testpkgs = {
                     PMf_MULTILINE PMf_ONCE PMf_SINGLELINE
                     POSTFIX SVf_FAKE SVf_IOK SVf_NOK SVf_POK SVf_ROK
                     SVpad_OUR SVs_RMG SVs_SMG SWAP_CHILDREN OPpPAD_STATE
-                    OPpCONST_ARYBASE
+                    OPpCONST_ARYBASE OPpEVAL_BYTES
                     /, $] > 5.009 ? ('RXf_SKIPWHITE') : ('PMf_SKIPWHITE'),
                    'CVf_LOCKED', # This ends up as a constant, pre or post 5.10
                    ],
index b9ef465..921d550 100644 (file)
@@ -2740,7 +2740,7 @@ Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords)
           goto unknown;
       }
 
-    case 9: /* 9 tokens of length 9 */
+    case 9: /* 10 tokens of length 9 */
       switch (name[0])
       {
         case 'U':
@@ -2759,19 +2759,39 @@ Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords)
           goto unknown;
 
         case 'e':
-          if (name[1] == 'n' &&
-              name[2] == 'd' &&
-              name[3] == 'n' &&
-              name[4] == 'e' &&
-              name[5] == 't' &&
-              name[6] == 'e' &&
-              name[7] == 'n' &&
-              name[8] == 't')
-          {                                       /* endnetent        */
-            return -KEY_endnetent;
-          }
+          switch (name[1])
+          {
+            case 'n':
+              if (name[2] == 'd' &&
+                  name[3] == 'n' &&
+                  name[4] == 'e' &&
+                  name[5] == 't' &&
+                  name[6] == 'e' &&
+                  name[7] == 'n' &&
+                  name[8] == 't')
+              {                                   /* endnetent        */
+                return -KEY_endnetent;
+              }
 
-          goto unknown;
+              goto unknown;
+
+            case 'v':
+              if (name[2] == 'a' &&
+                  name[3] == 'l' &&
+                  name[4] == 'b' &&
+                  name[5] == 'y' &&
+                  name[6] == 't' &&
+                  name[7] == 'e' &&
+                  name[8] == 's')
+              {                                   /* evalbytes        */
+                return (all_keywords || FEATURE_IS_ENABLED("evalbytes") ? -KEY_evalbytes : 0);
+              }
+
+              goto unknown;
+
+            default:
+              goto unknown;
+          }
 
         case 'g':
           if (name[1] == 'e' &&
@@ -3399,5 +3419,5 @@ unknown:
 }
 
 /* Generated from:
- * 6563b55da87af894b79ef9d777217633eee6c7b5f352ff4c17317f562247f5fc regen/keywords.pl
+ * 370a83cf6eed30dfe61a9dc611013e1014e0c5f537dc4f3872576ba8b9ef7572 regen/keywords.pl
  * ex: set ro: */
index 83ad0ef..c33f668 100644 (file)
 #define KEY_eof                        55
 #define KEY_eq                 56
 #define KEY_eval               57
-#define KEY_exec               58
-#define KEY_exists             59
-#define KEY_exit               60
-#define KEY_exp                        61
-#define KEY_fcntl              62
-#define KEY_fileno             63
-#define KEY_flock              64
-#define KEY_for                        65
-#define KEY_foreach            66
-#define KEY_fork               67
-#define KEY_format             68
-#define KEY_formline           69
-#define KEY_ge                 70
-#define KEY_getc               71
-#define KEY_getgrent           72
-#define KEY_getgrgid           73
-#define KEY_getgrnam           74
-#define KEY_gethostbyaddr      75
-#define KEY_gethostbyname      76
-#define KEY_gethostent         77
-#define KEY_getlogin           78
-#define KEY_getnetbyaddr       79
-#define KEY_getnetbyname       80
-#define KEY_getnetent          81
-#define KEY_getpeername                82
-#define KEY_getpgrp            83
-#define KEY_getppid            84
-#define KEY_getpriority                85
-#define KEY_getprotobyname     86
-#define KEY_getprotobynumber   87
-#define KEY_getprotoent                88
-#define KEY_getpwent           89
-#define KEY_getpwnam           90
-#define KEY_getpwuid           91
-#define KEY_getservbyname      92
-#define KEY_getservbyport      93
-#define KEY_getservent         94
-#define KEY_getsockname                95
-#define KEY_getsockopt         96
-#define KEY_given              97
-#define KEY_glob               98
-#define KEY_gmtime             99
-#define KEY_goto               100
-#define KEY_grep               101
-#define KEY_gt                 102
-#define KEY_hex                        103
-#define KEY_if                 104
-#define KEY_index              105
-#define KEY_int                        106
-#define KEY_ioctl              107
-#define KEY_join               108
-#define KEY_keys               109
-#define KEY_kill               110
-#define KEY_last               111
-#define KEY_lc                 112
-#define KEY_lcfirst            113
-#define KEY_le                 114
-#define KEY_length             115
-#define KEY_link               116
-#define KEY_listen             117
-#define KEY_local              118
-#define KEY_localtime          119
-#define KEY_lock               120
-#define KEY_log                        121
-#define KEY_lstat              122
-#define KEY_lt                 123
-#define KEY_m                  124
-#define KEY_map                        125
-#define KEY_mkdir              126
-#define KEY_msgctl             127
-#define KEY_msgget             128
-#define KEY_msgrcv             129
-#define KEY_msgsnd             130
-#define KEY_my                 131
-#define KEY_ne                 132
-#define KEY_next               133
-#define KEY_no                 134
-#define KEY_not                        135
-#define KEY_oct                        136
-#define KEY_open               137
-#define KEY_opendir            138
-#define KEY_or                 139
-#define KEY_ord                        140
-#define KEY_our                        141
-#define KEY_pack               142
-#define KEY_package            143
-#define KEY_pipe               144
-#define KEY_pop                        145
-#define KEY_pos                        146
-#define KEY_print              147
-#define KEY_printf             148
-#define KEY_prototype          149
-#define KEY_push               150
-#define KEY_q                  151
-#define KEY_qq                 152
-#define KEY_qr                 153
-#define KEY_quotemeta          154
-#define KEY_qw                 155
-#define KEY_qx                 156
-#define KEY_rand               157
-#define KEY_read               158
-#define KEY_readdir            159
-#define KEY_readline           160
-#define KEY_readlink           161
-#define KEY_readpipe           162
-#define KEY_recv               163
-#define KEY_redo               164
-#define KEY_ref                        165
-#define KEY_rename             166
-#define KEY_require            167
-#define KEY_reset              168
-#define KEY_return             169
-#define KEY_reverse            170
-#define KEY_rewinddir          171
-#define KEY_rindex             172
-#define KEY_rmdir              173
-#define KEY_s                  174
-#define KEY_say                        175
-#define KEY_scalar             176
-#define KEY_seek               177
-#define KEY_seekdir            178
-#define KEY_select             179
-#define KEY_semctl             180
-#define KEY_semget             181
-#define KEY_semop              182
-#define KEY_send               183
-#define KEY_setgrent           184
-#define KEY_sethostent         185
-#define KEY_setnetent          186
-#define KEY_setpgrp            187
-#define KEY_setpriority                188
-#define KEY_setprotoent                189
-#define KEY_setpwent           190
-#define KEY_setservent         191
-#define KEY_setsockopt         192
-#define KEY_shift              193
-#define KEY_shmctl             194
-#define KEY_shmget             195
-#define KEY_shmread            196
-#define KEY_shmwrite           197
-#define KEY_shutdown           198
-#define KEY_sin                        199
-#define KEY_sleep              200
-#define KEY_socket             201
-#define KEY_socketpair         202
-#define KEY_sort               203
-#define KEY_splice             204
-#define KEY_split              205
-#define KEY_sprintf            206
-#define KEY_sqrt               207
-#define KEY_srand              208
-#define KEY_stat               209
-#define KEY_state              210
-#define KEY_study              211
-#define KEY_sub                        212
-#define KEY_substr             213
-#define KEY_symlink            214
-#define KEY_syscall            215
-#define KEY_sysopen            216
-#define KEY_sysread            217
-#define KEY_sysseek            218
-#define KEY_system             219
-#define KEY_syswrite           220
-#define KEY_tell               221
-#define KEY_telldir            222
-#define KEY_tie                        223
-#define KEY_tied               224
-#define KEY_time               225
-#define KEY_times              226
-#define KEY_tr                 227
-#define KEY_truncate           228
-#define KEY_uc                 229
-#define KEY_ucfirst            230
-#define KEY_umask              231
-#define KEY_undef              232
-#define KEY_unless             233
-#define KEY_unlink             234
-#define KEY_unpack             235
-#define KEY_unshift            236
-#define KEY_untie              237
-#define KEY_until              238
-#define KEY_use                        239
-#define KEY_utime              240
-#define KEY_values             241
-#define KEY_vec                        242
-#define KEY_wait               243
-#define KEY_waitpid            244
-#define KEY_wantarray          245
-#define KEY_warn               246
-#define KEY_when               247
-#define KEY_while              248
-#define KEY_write              249
-#define KEY_x                  250
-#define KEY_xor                        251
-#define KEY_y                  252
+#define KEY_evalbytes          58
+#define KEY_exec               59
+#define KEY_exists             60
+#define KEY_exit               61
+#define KEY_exp                        62
+#define KEY_fcntl              63
+#define KEY_fileno             64
+#define KEY_flock              65
+#define KEY_for                        66
+#define KEY_foreach            67
+#define KEY_fork               68
+#define KEY_format             69
+#define KEY_formline           70
+#define KEY_ge                 71
+#define KEY_getc               72
+#define KEY_getgrent           73
+#define KEY_getgrgid           74
+#define KEY_getgrnam           75
+#define KEY_gethostbyaddr      76
+#define KEY_gethostbyname      77
+#define KEY_gethostent         78
+#define KEY_getlogin           79
+#define KEY_getnetbyaddr       80
+#define KEY_getnetbyname       81
+#define KEY_getnetent          82
+#define KEY_getpeername                83
+#define KEY_getpgrp            84
+#define KEY_getppid            85
+#define KEY_getpriority                86
+#define KEY_getprotobyname     87
+#define KEY_getprotobynumber   88
+#define KEY_getprotoent                89
+#define KEY_getpwent           90
+#define KEY_getpwnam           91
+#define KEY_getpwuid           92
+#define KEY_getservbyname      93
+#define KEY_getservbyport      94
+#define KEY_getservent         95
+#define KEY_getsockname                96
+#define KEY_getsockopt         97
+#define KEY_given              98
+#define KEY_glob               99
+#define KEY_gmtime             100
+#define KEY_goto               101
+#define KEY_grep               102
+#define KEY_gt                 103
+#define KEY_hex                        104
+#define KEY_if                 105
+#define KEY_index              106
+#define KEY_int                        107
+#define KEY_ioctl              108
+#define KEY_join               109
+#define KEY_keys               110
+#define KEY_kill               111
+#define KEY_last               112
+#define KEY_lc                 113
+#define KEY_lcfirst            114
+#define KEY_le                 115
+#define KEY_length             116
+#define KEY_link               117
+#define KEY_listen             118
+#define KEY_local              119
+#define KEY_localtime          120
+#define KEY_lock               121
+#define KEY_log                        122
+#define KEY_lstat              123
+#define KEY_lt                 124
+#define KEY_m                  125
+#define KEY_map                        126
+#define KEY_mkdir              127
+#define KEY_msgctl             128
+#define KEY_msgget             129
+#define KEY_msgrcv             130
+#define KEY_msgsnd             131
+#define KEY_my                 132
+#define KEY_ne                 133
+#define KEY_next               134
+#define KEY_no                 135
+#define KEY_not                        136
+#define KEY_oct                        137
+#define KEY_open               138
+#define KEY_opendir            139
+#define KEY_or                 140
+#define KEY_ord                        141
+#define KEY_our                        142
+#define KEY_pack               143
+#define KEY_package            144
+#define KEY_pipe               145
+#define KEY_pop                        146
+#define KEY_pos                        147
+#define KEY_print              148
+#define KEY_printf             149
+#define KEY_prototype          150
+#define KEY_push               151
+#define KEY_q                  152
+#define KEY_qq                 153
+#define KEY_qr                 154
+#define KEY_quotemeta          155
+#define KEY_qw                 156
+#define KEY_qx                 157
+#define KEY_rand               158
+#define KEY_read               159
+#define KEY_readdir            160
+#define KEY_readline           161
+#define KEY_readlink           162
+#define KEY_readpipe           163
+#define KEY_recv               164
+#define KEY_redo               165
+#define KEY_ref                        166
+#define KEY_rename             167
+#define KEY_require            168
+#define KEY_reset              169
+#define KEY_return             170
+#define KEY_reverse            171
+#define KEY_rewinddir          172
+#define KEY_rindex             173
+#define KEY_rmdir              174
+#define KEY_s                  175
+#define KEY_say                        176
+#define KEY_scalar             177
+#define KEY_seek               178
+#define KEY_seekdir            179
+#define KEY_select             180
+#define KEY_semctl             181
+#define KEY_semget             182
+#define KEY_semop              183
+#define KEY_send               184
+#define KEY_setgrent           185
+#define KEY_sethostent         186
+#define KEY_setnetent          187
+#define KEY_setpgrp            188
+#define KEY_setpriority                189
+#define KEY_setprotoent                190
+#define KEY_setpwent           191
+#define KEY_setservent         192
+#define KEY_setsockopt         193
+#define KEY_shift              194
+#define KEY_shmctl             195
+#define KEY_shmget             196
+#define KEY_shmread            197
+#define KEY_shmwrite           198
+#define KEY_shutdown           199
+#define KEY_sin                        200
+#define KEY_sleep              201
+#define KEY_socket             202
+#define KEY_socketpair         203
+#define KEY_sort               204
+#define KEY_splice             205
+#define KEY_split              206
+#define KEY_sprintf            207
+#define KEY_sqrt               208
+#define KEY_srand              209
+#define KEY_stat               210
+#define KEY_state              211
+#define KEY_study              212
+#define KEY_sub                        213
+#define KEY_substr             214
+#define KEY_symlink            215
+#define KEY_syscall            216
+#define KEY_sysopen            217
+#define KEY_sysread            218
+#define KEY_sysseek            219
+#define KEY_system             220
+#define KEY_syswrite           221
+#define KEY_tell               222
+#define KEY_telldir            223
+#define KEY_tie                        224
+#define KEY_tied               225
+#define KEY_time               226
+#define KEY_times              227
+#define KEY_tr                 228
+#define KEY_truncate           229
+#define KEY_uc                 230
+#define KEY_ucfirst            231
+#define KEY_umask              232
+#define KEY_undef              233
+#define KEY_unless             234
+#define KEY_unlink             235
+#define KEY_unpack             236
+#define KEY_unshift            237
+#define KEY_untie              238
+#define KEY_until              239
+#define KEY_use                        240
+#define KEY_utime              241
+#define KEY_values             242
+#define KEY_vec                        243
+#define KEY_wait               244
+#define KEY_waitpid            245
+#define KEY_wantarray          246
+#define KEY_warn               247
+#define KEY_when               248
+#define KEY_while              249
+#define KEY_write              250
+#define KEY_x                  251
+#define KEY_xor                        252
+#define KEY_y                  253
 
 /* Generated from:
- * 6563b55da87af894b79ef9d777217633eee6c7b5f352ff4c17317f562247f5fc regen/keywords.pl
+ * 370a83cf6eed30dfe61a9dc611013e1014e0c5f537dc4f3872576ba8b9ef7572 regen/keywords.pl
  * ex: set ro: */
index 459c03c..dd44d73 100644 (file)
@@ -7,6 +7,7 @@ my %feature = (
     say             => 'feature_say',
     state           => 'feature_state',
     switch          => 'feature_switch',
+    evalbytes       => 'feature_evalbytes',
     unicode_eval    => 'feature_unieval',
     unicode_strings => 'feature_unicode',
 );
@@ -24,7 +25,8 @@ my %feature_bundle = (
     "5.12" => [qw(say state switch unicode_strings)],
     "5.13" => [qw(say state switch unicode_strings)],
     "5.14" => [qw(say state switch unicode_strings)],
-    "5.15" => [qw(say state switch unicode_strings unicode_eval)],
+    "5.15" => [qw(say state switch unicode_strings unicode_eval
+                  evalbytes)],
 );
 
 # special case
diff --git a/op.c b/op.c
index d5f1dd9..fc6cd04 100644 (file)
--- a/op.c
+++ b/op.c
@@ -3598,6 +3598,11 @@ Perl_newOP(pTHX_ I32 type, I32 flags)
     dVAR;
     OP *o;
 
+    if (type == -OP_ENTEREVAL) {
+       type = OP_ENTEREVAL;
+       flags |= OPpEVAL_BYTES<<8;
+    }
+
     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
        || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
        || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
@@ -3640,6 +3645,11 @@ Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
     dVAR;
     UNOP *unop;
 
+    if (type == -OP_ENTEREVAL) {
+       type = OP_ENTEREVAL;
+       flags |= OPpEVAL_BYTES<<8;
+    }
+
     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
        || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
        || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
@@ -7469,22 +7479,26 @@ Perl_ck_eval(pTHX_ OP *o)
        }
     }
     else {
+       U8 priv = o->op_private;
 #ifdef PERL_MAD
        OP* const oldo = o;
 #else
        op_free(o);
 #endif
-       o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
+       o = newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
        op_getmad(oldo,o,'O');
     }
     o->op_targ = (PADOFFSET)PL_hints;
-    if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
+    if ((PL_hints & HINT_LOCALIZE_HH) != 0
+     && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
        /* Store a copy of %^H that pp_entereval can pick up. */
        OP *hhop = newSVOP(OP_HINTSEVAL, 0,
                           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"))
+
+       if (!(o->op_private & OPpEVAL_BYTES)
+        && FEATURE_IS_ENABLED("unieval"))
            o->op_private |= OPpEVAL_UNICODE;
     }
     return o;
@@ -9356,7 +9370,7 @@ Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
     }
     else {
        OP *prev, *cvop;
-       U32 paren;
+       U32 flags;
 #ifdef PERL_MAD
        bool seenarg = FALSE;
 #endif
@@ -9375,16 +9389,20 @@ Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
 #endif
            ;
        prev->op_sibling = NULL;
-       paren = OPf_SPECIAL * !(cvop->op_private & OPpENTERSUB_NOPAREN);
+       flags = OPf_SPECIAL * !(cvop->op_private & OPpENTERSUB_NOPAREN);
        op_free(cvop);
        if (aop == cvop) aop = NULL;
        op_free(entersubop);
 
+       if (opnum == OP_ENTEREVAL
+        && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
+           flags |= OPpEVAL_BYTES <<8;
+       
        switch (PL_opargs[opnum] & OA_CLASS_MASK) {
        case OA_UNOP:
        case OA_BASEOP_OR_UNOP:
        case OA_FILESTATOP:
-           return aop ? newUNOP(opnum,paren,aop) : newOP(opnum,paren);
+           return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
        case OA_BASEOP:
            if (aop) {
 #ifdef PERL_MAD
@@ -10338,6 +10356,8 @@ Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
        retsetpvs("+;$$@", OP_SPLICE);
     case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
        retsetpvs("", 0);
+    case KEY_evalbytes:
+       name = "entereval"; break;
     case KEY_readpipe:
        name = "backtick";
     }
@@ -10435,7 +10455,11 @@ Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
                              opnum == OP_WANTARRAY ? OPpOFFBYONE << 8 : 0)
                   );
        case OA_BASEOP_OR_UNOP:
-           o = newUNOP(opnum,0,argop);
+           if (opnum == OP_ENTEREVAL) {
+               o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
+               if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
+           }
+           else o = newUNOP(opnum,0,argop);
            if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
            else {
          onearg:
diff --git a/op.h b/op.h
index a9ecedb..f82758e 100644 (file)
--- a/op.h
+++ b/op.h
@@ -296,6 +296,8 @@ 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
+#define OPpEVAL_BYTES          8
+#define OPpEVAL_COPHH          16      /* Construct %^H from cop hints */
     
 /* Private for OP_CALLER and OP_WANTARRAY */
 #define OPpOFFBYONE            128     /* Treat caller(1) as caller(2) */
index 34f8b48..99b2524 100644 (file)
--- a/opcode.h
+++ b/opcode.h
@@ -2023,7 +2023,7 @@ EXTCONST U32 PL_opargs[] = {
        0x00009bc0,     /* require */
        0x00001140,     /* dofile */
        0x00000604,     /* hintseval */
-       0x00001b40,     /* entereval */
+       0x00009bc0,     /* entereval */
        0x00001100,     /* leaveeval */
        0x00000340,     /* entertry */
        0x00000400,     /* leavetry */
index 153d98e..9b9bff9 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -4131,6 +4131,11 @@ PP(pp_entereval)
     if (PL_op->op_private & OPpEVAL_HAS_HH) {
        saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
     }
+    else if (PL_op->op_private & OPpEVAL_COPHH
+         && PL_curcop->cop_hints & HINT_LOCALIZE_HH) {
+       saved_hh = cop_hints_2hv(PL_curcop, 0);
+       hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
+    }
     sv = POPs;
     if (!SvPOK(sv)) {
        /* make sure we've got a plain PV (no overload etc) before testing
@@ -4140,6 +4145,15 @@ PP(pp_entereval)
        const char * const p = SvPV_const(sv, len);
 
        sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
+
+       if (PL_op->op_private & OPpEVAL_BYTES && SvUTF8(sv))
+           SvPVbyte_force(sv, len);
+    }
+    else if (PL_op->op_private & OPpEVAL_BYTES && SvUTF8(sv)) {
+       /* Don’t modify someone else’s scalar */
+       STRLEN len;
+       sv = newSVsv(sv);
+       SvPVbyte_force(sv,len);
     }
 
     TAINT_IF(SvTAINTED(sv));
@@ -4173,7 +4187,8 @@ PP(pp_entereval)
        ensues, we always turn GvMULTI_on for any globals that were
        introduced within evals. See force_ident(). GSAR 96-10-12 */
     SAVEHINTS();
-    PL_hints = PL_op->op_targ;
+    PL_hints = PL_op->op_private & OPpEVAL_COPHH
+                ? PL_curcop->cop_hints : PL_op->op_targ;
     if (saved_hh) {
        /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
        SvREFCNT_dec(GvHV(PL_hintgv));
index 5f7f1ef..c4cd187 100755 (executable)
@@ -45,6 +45,8 @@ my %feature_kw = (
        say     => 'say',
 
        state   => 'state',
+
+       evalbytes=>'evalbytes',
        );
 
 my %pos = map { ($_ => 1) } @{$by_strength{'+'}};
@@ -165,6 +167,7 @@ __END__
 -eof
 -eq
 +eval
+-evalbytes
 -exec
 +exists
 -exit
index 5b988a1..45cf693 100644 (file)
@@ -483,7 +483,7 @@ semctl              semctl                  ck_fun          imst@   S S S S
 require                require                 ck_require      du%     S?
 dofile         do "file"               ck_fun          d1      S
 hintseval      eval hints              ck_svconst      s$
-entereval      eval "string"           ck_eval         d%      S
+entereval      eval "string"           ck_eval         du%     S?
 leaveeval      eval "string" exit      ck_null         1       S
 #evalonce      eval constant string    ck_null         d1      S
 entertry       eval {block}            ck_eval         d|      
index 2027f41..d3f03eb 100644 (file)
@@ -30,6 +30,7 @@ package sov {
 }
 
 my %op_desc = (
+ evalbytes=> 'eval "string"',
  join     => 'join or string',
  readline => '<HANDLE>',
  readpipe => 'quoted execution (``, qx)',
@@ -118,10 +119,11 @@ sub test_proto {
   elsif ($p =~ '^([$*]+);?\z') { # Fixed-length $$$ or ***
     my $args = length $1;
     $tests += 2;    
+    my $desc = quotemeta op_desc($o);
     eval " &CORE::$o((1)x($args-1)) ";
-    like $@, qr/^Not enough arguments for $o at /, "&$o with too few args";
+    like $@, qr/^Not enough arguments for $desc at /, "&$o w/too few args";
     eval " &CORE::$o((1)x($args+1)) ";
-    like $@, qr/^Too many arguments for $o at /, "&$o with too many args";
+    like $@, qr/^Too many arguments for $desc at /, "&$o w/too many args";
   }
   elsif ($p =~ '^([$*]+);([$*]+)\z') { # Variable-length $$$ or ***
     my $minargs = length $1;
@@ -396,6 +398,29 @@ test_proto $_ for qw(
  endgrent endhostent endnetent endprotoent endpwent endservent
 );
 
+test_proto 'evalbytes';
+$tests += 4;
+{
+  chop(my $upgraded = "use utf8; '\xc4\x80'" . chr 256);
+  is &myevalbytes($upgraded), chr 256, '&evalbytes';
+  # Test hints
+  require strict;
+  strict->import;
+  &myevalbytes('
+    is someone, "someone", "run-time hint bits do not leak into &evalbytes"
+  ');
+  use strict;
+  BEGIN { $^H{coreamp} = 42 }
+  $^H{coreamp} = 75;
+  &myevalbytes('
+    BEGIN {
+      is $^H{coreamp}, 42, "compile-time hh propagates into &evalbytes";
+    }
+    ${"frobnicate"}
+  ');
+  like $@, qr/strict/, 'compile-time hint bits propagate into &evalbytes';
+}
+
 test_proto 'exit';
 $tests ++;
 is runperl(prog => '&CORE::exit; END { print qq-ok\n- }'), "ok\n",
index 60aa1b7..1665cf6 100644 (file)
@@ -84,7 +84,7 @@ while(<$kh>) {
       # These ops currently accept any number of args, despite their
       # prototypes, if they have any:
       next if $word =~ /^(?:chom?p|exec|keys|each|not|read(?:lin|pip)e
-                           |reset|system|values|l?stat)/x;
+                           |reset|system|values|l?stat)|evalbytes/x;
 
       $tests ++;
       $code =
index c9cfe46..ad2249d 100644 (file)
@@ -7,7 +7,7 @@ BEGIN {
 }
 
 BEGIN { require './test.pl'; }
-plan tests => 245;
+plan tests => 246;
 
 while (<DATA>) {
     chomp;
@@ -77,6 +77,7 @@ endservent ()
 eof (;*)
 eq undef
 eval undef
+evalbytes (_)
 exec undef
 exists undef
 exit (;$)
diff --git a/t/op/evalbytes.t b/t/op/evalbytes.t
new file mode 100644 (file)
index 0000000..4a60614
--- /dev/null
@@ -0,0 +1,34 @@
+#!./perl
+
+BEGIN {
+    chdir 't';
+    @INC = '../lib';
+    require './test.pl';
+}
+
+plan(tests => 8);
+
+{
+    local $SIG{__WARN__} = sub {};
+    eval "evalbytes 'foo'";
+    like $@, qr/syntax error/, 'evalbytes outside feature scope';
+}
+
+# We enable unicode_eval just to test that it does not interfere.
+use feature 'evalbytes', 'unicode_eval';
+
+is evalbytes("1+7"), 8, 'evalbytes basic sanity check';
+
+my $code = 'qq(\xff\xfe)';
+is evalbytes($code), "\xff\xfe", 'evalbytes on extra-ASCII bytes';
+chop((my $upcode = $code) .= chr 256);
+is evalbytes($upcode), "\xff\xfe", 'evalbytes on upgraded extra-ASCII';
+{
+    use utf8;
+    is evalbytes($code), "\xff\xfe", 'evalbytes ignores outer utf8 pragma';
+}
+is evalbytes "use utf8; '\xc4\x80'", chr 256, 'use utf8 within evalbytes';
+chop($upcode = "use utf8; '\xc4\x80'" . chr 256);
+is evalbytes $upcode, chr 256, 'use utf8 within evalbytes on utf8 string';
+eval { evalbytes chr 256 };
+like $@, qr/Wide character/, 'evalbytes croaks on non-bytes';
diff --git a/toke.c b/toke.c
index 3720a83..b1acdd3 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -7248,6 +7248,10 @@ Perl_yylex(pTHX)
                UNIBRACK(OP_ENTEREVAL);
            }
 
+       case KEY_evalbytes:
+           PL_expect = XTERM;
+           UNIBRACK(-OP_ENTEREVAL);
+
        case KEY_eof:
            UNI(OP_EOF);