From 7d7892821ccfd0b84576fc06764ec467e8ca7678 Mon Sep 17 00:00:00 2001 From: Father Chrysostomos Date: Sun, 30 Oct 2011 14:33:06 -0700 Subject: Add evalbytes function MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 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. --- MANIFEST | 1 + dist/B-Deparse/Deparse.pm | 23 ++- dist/B-Deparse/t/core.t | 7 +- dist/B-Deparse/t/deparse.t | 1 + ext/B/t/concise-xs.t | 2 +- keywords.c | 48 ++++-- keywords.h | 393 +++++++++++++++++++++++---------------------- lib/feature.pm | 4 +- op.c | 38 ++++- op.h | 2 + opcode.h | 2 +- pp_ctl.c | 17 +- regen/keywords.pl | 3 + regen/opcodes | 2 +- t/op/coreamp.t | 29 +++- t/op/coresubs.t | 2 +- t/op/cproto.t | 3 +- t/op/evalbytes.t | 34 ++++ toke.c | 4 + 19 files changed, 379 insertions(+), 236 deletions(-) create mode 100644 t/op/evalbytes.t diff --git a/MANIFEST b/MANIFEST index 058a57203f..30dfe5703d 100644 --- 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 diff --git a/dist/B-Deparse/Deparse.pm b/dist/B-Deparse/Deparse.pm index b8b30f3729..428466b519 100644 --- a/dist/B-Deparse/Deparse.pm +++ b/dist/B-Deparse/Deparse.pm @@ -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") } diff --git a/dist/B-Deparse/t/core.t b/dist/B-Deparse/t/core.t index 2d5aa32919..81d9038b8a 100644 --- a/dist/B-Deparse/t/core.t +++ b/dist/B-Deparse/t/core.t @@ -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 diff --git a/dist/B-Deparse/t/deparse.t b/dist/B-Deparse/t/deparse.t index 53b8d23202..ef66090ee5 100644 --- a/dist/B-Deparse/t/deparse.t +++ b/dist/B-Deparse/t/deparse.t @@ -765,6 +765,7 @@ CORE::given ($x) { CORE::break; } } +CORE::evalbytes ''; #### # $#- $#+ $#{%} etc. my @x; diff --git a/ext/B/t/concise-xs.t b/ext/B/t/concise-xs.t index 67b8591701..5e88b9fe63 100644 --- a/ext/B/t/concise-xs.t +++ b/ext/B/t/concise-xs.t @@ -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 ], diff --git a/keywords.c b/keywords.c index b9ef465967..921d55077e 100644 --- a/keywords.c +++ b/keywords.c @@ -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: */ diff --git a/keywords.h b/keywords.h index 83ad0efb56..c33f6687c1 100644 --- a/keywords.h +++ b/keywords.h @@ -71,202 +71,203 @@ #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: */ diff --git a/lib/feature.pm b/lib/feature.pm index 459c03c506..dd44d7327d 100644 --- a/lib/feature.pm +++ b/lib/feature.pm @@ -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 d5f1dd91a0..fc6cd04d78 100644 --- 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 a9ecedb8e4..f82758e46e 100644 --- a/op.h +++ b/op.h @@ -296,6 +296,8 @@ Deprecated. Use C 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) */ diff --git a/opcode.h b/opcode.h index 34f8b48752..99b25240aa 100644 --- 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 */ diff --git a/pp_ctl.c b/pp_ctl.c index 153d98e604..9b9bff9a8f 100644 --- 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)); diff --git a/regen/keywords.pl b/regen/keywords.pl index 5f7f1ef851..c4cd187273 100755 --- a/regen/keywords.pl +++ b/regen/keywords.pl @@ -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 diff --git a/regen/opcodes b/regen/opcodes index 5b988a11aa..45cf693673 100644 --- a/regen/opcodes +++ b/regen/opcodes @@ -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| diff --git a/t/op/coreamp.t b/t/op/coreamp.t index 2027f41ac5..d3f03eb58a 100644 --- a/t/op/coreamp.t +++ b/t/op/coreamp.t @@ -30,6 +30,7 @@ package sov { } my %op_desc = ( + evalbytes=> 'eval "string"', join => 'join or string', readline => '', 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", diff --git a/t/op/coresubs.t b/t/op/coresubs.t index 60aa1b7814..1665cf6ab6 100644 --- a/t/op/coresubs.t +++ b/t/op/coresubs.t @@ -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 = diff --git a/t/op/cproto.t b/t/op/cproto.t index c9cfe466ca..ad2249df2c 100644 --- a/t/op/cproto.t +++ b/t/op/cproto.t @@ -7,7 +7,7 @@ BEGIN { } BEGIN { require './test.pl'; } -plan tests => 245; +plan tests => 246; while () { 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 index 0000000000..4a60614814 --- /dev/null +++ b/t/op/evalbytes.t @@ -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 3720a83101..b1acdd3408 100644 --- 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); -- cgit v1.2.1