diff options
| -rw-r--r-- | embed.fnc | 3 | ||||
| -rw-r--r-- | embed.h | 12 | ||||
| -rw-r--r-- | ext/B/t/concise-xs.t | 2 | ||||
| -rw-r--r-- | ext/Opcode/Opcode.pm | 3 | ||||
| -rw-r--r-- | op.c | 88 | ||||
| -rw-r--r-- | opcode.h | 5 | ||||
| -rwxr-xr-x | opcode.pl | 2 | ||||
| -rw-r--r-- | opnames.h | 3 | ||||
| -rw-r--r-- | pp.c | 18 | ||||
| -rw-r--r-- | pp.sym | 1 | ||||
| -rw-r--r-- | pp_proto.h | 1 | ||||
| -rw-r--r-- | proto.h | 7 | ||||
| -rw-r--r-- | t/op/each.t | 37 | ||||
| -rw-r--r-- | t/op/tie.t | 8 |
14 files changed, 181 insertions, 9 deletions
@@ -502,6 +502,9 @@ ApR |bool |is_utf8_mark |NN const U8 *p p |OP* |jmaybe |NN OP *o : Used in pp.c pP |I32 |keyword |NN const char *name|I32 len|bool all_keywords +#if defined(PERL_IN_OP_C) || defined(PERL_DECL_PROT) +s |OP* |opt_scalarhv |NN OP* rep_op +#endif Ap |void |leave_scope |I32 base : Used in pp_ctl.c, and by Data::Alias EXp |void |lex_end @@ -391,6 +391,11 @@ #define jmaybe Perl_jmaybe #define keyword Perl_keyword #endif +#if defined(PERL_IN_OP_C) || defined(PERL_DECL_PROT) +#ifdef PERL_CORE +#define opt_scalarhv S_opt_scalarhv +#endif +#endif #define leave_scope Perl_leave_scope #if defined(PERL_CORE) || defined(PERL_EXT) #define lex_end Perl_lex_end @@ -2050,6 +2055,7 @@ #define pp_bit_or Perl_pp_bit_or #define pp_bit_xor Perl_pp_bit_xor #define pp_bless Perl_pp_bless +#define pp_boolkeys Perl_pp_boolkeys #define pp_break Perl_pp_break #define pp_caller Perl_pp_caller #define pp_chdir Perl_pp_chdir @@ -2746,6 +2752,11 @@ #define jmaybe(a) Perl_jmaybe(aTHX_ a) #define keyword(a,b,c) Perl_keyword(aTHX_ a,b,c) #endif +#if defined(PERL_IN_OP_C) || defined(PERL_DECL_PROT) +#ifdef PERL_CORE +#define opt_scalarhv(a) S_opt_scalarhv(aTHX_ a) +#endif +#endif #define leave_scope(a) Perl_leave_scope(aTHX_ a) #if defined(PERL_CORE) || defined(PERL_EXT) #define lex_end() Perl_lex_end(aTHX) @@ -4419,6 +4430,7 @@ #define pp_bit_or() Perl_pp_bit_or(aTHX) #define pp_bit_xor() Perl_pp_bit_xor(aTHX) #define pp_bless() Perl_pp_bless(aTHX) +#define pp_boolkeys() Perl_pp_boolkeys(aTHX) #define pp_break() Perl_pp_break(aTHX) #define pp_caller() Perl_pp_caller(aTHX) #define pp_chdir() Perl_pp_chdir(aTHX) diff --git a/ext/B/t/concise-xs.t b/ext/B/t/concise-xs.t index b50cbb230d..d90011394d 100644 --- a/ext/B/t/concise-xs.t +++ b/ext/B/t/concise-xs.t @@ -148,7 +148,7 @@ my $testpkgs = { ), $] > 5.009 ? ('unitcheck_av') : ()], }, - B::Deparse => { dflt => 'perl', # 235 functions + B::Deparse => { dflt => 'perl', # 236 functions XS => [qw( svref_2object perlstring opnumber main_start main_root main_cv )], diff --git a/ext/Opcode/Opcode.pm b/ext/Opcode/Opcode.pm index d778294718..31b6f4471c 100644 --- a/ext/Opcode/Opcode.pm +++ b/ext/Opcode/Opcode.pm @@ -6,7 +6,7 @@ use strict; our($VERSION, @ISA, @EXPORT_OK); -$VERSION = "1.13"; +$VERSION = "1.14"; use Carp; use Exporter (); @@ -311,6 +311,7 @@ invert_opset function. rv2av aassign aelem aelemfast aslice av2arylen rv2hv helem hslice each values keys exists delete aeach akeys avalues + boolkeys preinc i_preinc predec i_predec postinc i_postinc postdec i_postdec int hex oct abs pow multiply i_multiply divide i_divide @@ -8276,6 +8276,33 @@ Perl_ck_each(pTHX_ OP *o) return ck_fun(o); } +/* caller is supposed to assign the return to the + container of the rep_op var */ +OP * +S_opt_scalarhv(pTHX_ OP *rep_op) { + UNOP *unop; + + PERL_ARGS_ASSERT_OPT_SCALARHV; + + NewOp(1101, unop, 1, UNOP); + unop->op_type = (OPCODE)OP_BOOLKEYS; + unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS]; + unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS ); + unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8)); + unop->op_first = rep_op; + unop->op_next = rep_op->op_next; + rep_op->op_next = (OP*)unop; + rep_op->op_flags|=(OPf_REF | OPf_MOD); + unop->op_sibling = rep_op->op_sibling; + rep_op->op_sibling = NULL; + /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */ + if (rep_op->op_type == OP_PADHV) { + rep_op->op_flags &= ~OPf_WANT_SCALAR; + rep_op->op_flags |= OPf_WANT_LIST; + } + return (OP*)unop; +} + /* A peephole optimizer. We visit the ops in the order they're to execute. * See the comments at the top of this file for more details about when * peep() is called */ @@ -8462,12 +8489,67 @@ Perl_peep(pTHX_ register OP *o) } break; + + { + OP *fop; + OP *sop; + + case OP_NOT: + fop = cUNOP->op_first; + sop = NULL; + goto stitch_keys; + break; - case OP_MAPWHILE: - case OP_GREPWHILE: - case OP_AND: + case OP_AND: case OP_OR: case OP_DOR: + fop = cLOGOP->op_first; + sop = fop->op_sibling; + while (cLOGOP->op_other->op_type == OP_NULL) + cLOGOP->op_other = cLOGOP->op_other->op_next; + peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */ + + stitch_keys: + o->op_opt = 1; + if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV) + || ( sop && + (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV) + ) + ){ + OP * nop = o; + OP * lop = o; + if (!(nop->op_flags && OPf_WANT_VOID)) { + while (nop && nop->op_next) { + switch (nop->op_next->op_type) { + case OP_NOT: + case OP_AND: + case OP_OR: + case OP_DOR: + lop = nop = nop->op_next; + break; + case OP_NULL: + nop = nop->op_next; + break; + default: + nop = NULL; + break; + } + } + } + if (lop->op_flags && OPf_WANT_VOID) { + if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV) + cLOGOP->op_first = opt_scalarhv(fop); + if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)) + cLOGOP->op_first->op_sibling = opt_scalarhv(sop); + } + } + + + break; + } + + case OP_MAPWHILE: + case OP_GREPWHILE: case OP_ANDASSIGN: case OP_ORASSIGN: case OP_DORASSIGN: @@ -398,6 +398,7 @@ EXTCONST char* const PL_op_name[] = { "lock", "once", "custom", + "boolkeys", }; #endif @@ -770,6 +771,7 @@ EXTCONST char* const PL_op_desc[] = { "lock", "once", "unknown custom operator", + "boolkeys", }; #endif @@ -1156,6 +1158,7 @@ EXT Perl_ppaddr_t PL_ppaddr[] /* or perlvars.h */ MEMBER_TO_FPTR(Perl_pp_lock), MEMBER_TO_FPTR(Perl_pp_once), MEMBER_TO_FPTR(Perl_unimplemented_op), /* Perl_pp_custom */ + MEMBER_TO_FPTR(Perl_pp_boolkeys), } #endif #ifdef PERL_PPADDR_INITED @@ -1539,6 +1542,7 @@ EXT Perl_check_t PL_check[] /* or perlvars.h */ MEMBER_TO_FPTR(Perl_ck_rfun), /* lock */ MEMBER_TO_FPTR(Perl_ck_null), /* once */ MEMBER_TO_FPTR(Perl_ck_null), /* custom */ + MEMBER_TO_FPTR(Perl_ck_fun), /* boolkeys */ } #endif #ifdef PERL_CHECK_INITED @@ -1916,6 +1920,7 @@ EXTCONST U32 PL_opargs[] = { 0x0000f604, /* lock */ 0x00000600, /* once */ 0x00000000, /* custom */ + 0x00009600, /* boolkeys */ }; #endif @@ -1116,3 +1116,5 @@ lock lock ck_rfun s% R once once ck_null | custom unknown custom operator ck_null 0 + +boolkeys boolkeys ck_fun % H @@ -380,10 +380,11 @@ typedef enum opcode { OP_LOCK = 362, OP_ONCE = 363, OP_CUSTOM = 364, + OP_BOOLKEYS = 365, OP_max } opcode; -#define MAXO 365 +#define MAXO 366 #define OP_phoney_INPUT_ONLY -1 #define OP_phoney_OUTPUT_ONLY -2 @@ -5325,6 +5325,24 @@ PP(unimplemented_op) PL_op->op_type); } +PP(pp_boolkeys) +{ + dVAR; + dSP; + HV * const hv = (HV*)POPs; + + if (SvRMAGICAL(hv)) { + MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_tied); + if (mg) { + XPUSHs(magic_scalarpack(hv, mg)); + RETURN; + } + } + + XPUSHs(boolSV(HvKEYS(hv) != 0)); + RETURN; +} + /* * Local variables: * c-indentation-style: bsd @@ -408,5 +408,6 @@ Perl_pp_getlogin Perl_pp_syscall Perl_pp_lock Perl_pp_once +Perl_pp_boolkeys # ex: set ro: diff --git a/pp_proto.h b/pp_proto.h index 0c1829ad74..16c5c8c898 100644 --- a/pp_proto.h +++ b/pp_proto.h @@ -409,5 +409,6 @@ PERL_PPDEF(Perl_pp_getlogin) PERL_PPDEF(Perl_pp_syscall) PERL_PPDEF(Perl_pp_lock) PERL_PPDEF(Perl_pp_once) +PERL_PPDEF(Perl_pp_boolkeys) /* ex: set ro: */ @@ -1400,6 +1400,13 @@ PERL_CALLCONV I32 Perl_keyword(pTHX_ const char *name, I32 len, bool all_keyword #define PERL_ARGS_ASSERT_KEYWORD \ assert(name) +#if defined(PERL_IN_OP_C) || defined(PERL_DECL_PROT) +STATIC OP* S_opt_scalarhv(pTHX_ OP* rep_op) + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_OPT_SCALARHV \ + assert(rep_op) + +#endif PERL_CALLCONV void Perl_leave_scope(pTHX_ I32 base); PERL_CALLCONV void Perl_lex_end(pTHX); PERL_CALLCONV void Perl_lex_start(pTHX_ SV* line, PerlIO *rsfp, bool new_filter); diff --git a/t/op/each.t b/t/op/each.t index b88f1ea825..02438f2002 100644 --- a/t/op/each.t +++ b/t/op/each.t @@ -6,7 +6,7 @@ BEGIN { require './test.pl'; } -plan tests => 42; +plan tests => 52; $h{'abc'} = 'ABC'; $h{'def'} = 'DEF'; @@ -193,3 +193,38 @@ for my $k (qw(each keys values)) { eval $k; like($@, qr/^Not enough arguments for $k/, "$k demands argument"); } + +{ + my %foo=(1..10); + my ($k,$v); + my $count=keys %foo; + my ($k1,$v1)=each(%foo); + my $yes = 0; + if (%foo) { $yes++ } + my ($k2,$v2)=each(%foo); + my $rest=0; + while (each(%foo)) {$rest++}; + is($yes,1,"if(%foo) was true"); + isnt($k1,$k2,"if(%foo) didnt mess with each (key)"); + isnt($v1,$v2,"if(%foo) didnt mess with each (value)"); + is($rest,3,"Got the expect number of keys"); + my $hsv=1 && %foo; + like($hsv,'/',"Got bucket stats from %foo in scalar assignment context"); +} +{ + our %foo=(1..10); + my ($k,$v); + my $count=keys %foo; + my ($k1,$v1)=each(%foo); + my $yes = 0; + if (%foo) { $yes++ } + my ($k2,$v2)=each(%foo); + my $rest=0; + while (each(%foo)) {$rest++}; + is($yes,1,"if(%foo) was true"); + isnt($k1,$k2,"if(%foo) didnt mess with each (key)"); + isnt($v1,$v2,"if(%foo) didnt mess with each (value)"); + is($rest,3,"Got the expect number of keys"); + my $hsv=1 && %foo; + like($hsv,'/',"Got bucket stats from %foo in scalar assignment context"); +} diff --git a/t/op/tie.t b/t/op/tie.t index 51c84845bf..8298ed2c8e 100644 --- a/t/op/tie.t +++ b/t/op/tie.t @@ -506,13 +506,17 @@ package main; tie my %h => "TieScalar"; $h{key1} = "val1"; $h{key2} = "val2"; -print scalar %h, "\n"; +print scalar %h, "\n" + if %h; # this should also call SCALAR but implicitly %h = (); -print scalar %h, "\n"; +print scalar %h, "\n" + if !%h; # this should also call SCALAR but implicitly EXPECT SCALAR +SCALAR 2/2 SCALAR +SCALAR 0 ######## |