diff options
| -rw-r--r-- | embed.h | 1 | ||||
| -rw-r--r-- | ext/Opcode/Opcode.pm | 3 | ||||
| -rw-r--r-- | lib/B/Op_private.pm | 4 | ||||
| -rw-r--r-- | op.c | 30 | ||||
| -rw-r--r-- | opcode.h | 9 | ||||
| -rw-r--r-- | opnames.h | 3 | ||||
| -rw-r--r-- | pp.c | 72 | ||||
| -rw-r--r-- | pp_proto.h | 1 | ||||
| -rw-r--r-- | proto.h | 6 | ||||
| -rw-r--r-- | regen/op_private | 4 | ||||
| -rw-r--r-- | regen/opcodes | 3 |
11 files changed, 134 insertions, 2 deletions
@@ -1262,6 +1262,7 @@ #define ck_fun(a) Perl_ck_fun(aTHX_ a) #define ck_glob(a) Perl_ck_glob(aTHX_ a) #define ck_grep(a) Perl_ck_grep(aTHX_ a) +#define ck_helemexistsor(a) Perl_ck_helemexistsor(aTHX_ a) #define ck_index(a) Perl_ck_index(aTHX_ a) #define ck_isa(a) Perl_ck_isa(aTHX_ a) #define ck_join(a) Perl_ck_join(aTHX_ a) diff --git a/ext/Opcode/Opcode.pm b/ext/Opcode/Opcode.pm index 9f28f900bf..5b0092d1bb 100644 --- a/ext/Opcode/Opcode.pm +++ b/ext/Opcode/Opcode.pm @@ -1,4 +1,4 @@ -package Opcode 1.62; +package Opcode 1.63; use strict; @@ -332,6 +332,7 @@ invert_opset function. list lslice splice push pop shift unshift reverse cond_expr flip flop andassign orassign dorassign and or dor xor + helemexistsor warn die lineseq nextstate scope enter leave diff --git a/lib/B/Op_private.pm b/lib/B/Op_private.pm index 28ae8fc649..bf189a128b 100644 --- a/lib/B/Op_private.pm +++ b/lib/B/Op_private.pm @@ -384,6 +384,7 @@ $bits{grepwhile}{0} = $bf[0]; @{$bits{gt}}{1,0} = ($bf[1], $bf[1]); $bits{gv}{5} = 'OPpEARLY_CV'; @{$bits{helem}}{5,4,1,0} = ($bf[8], $bf[8], $bf[1], $bf[1]); +@{$bits{helemexistsor}}{7,0} = ('OPpHELEMEXISTSOR_DELETE', $bf[0]); $bits{hex}{0} = $bf[0]; @{$bits{i_add}}{1,0} = ($bf[1], $bf[1]); @{$bits{i_divide}}{1,0} = ($bf[1], $bf[1]); @@ -643,6 +644,7 @@ our %defines = ( OPpFT_AFTER_t => 16, OPpFT_STACKED => 4, OPpFT_STACKING => 8, + OPpHELEMEXISTSOR_DELETE => 128, OPpHINT_STRICT_REFS => 2, OPpHUSH_VMSISH => 32, OPpINDEX_BOOLNEG => 64, @@ -753,6 +755,7 @@ our %labels = ( OPpFT_AFTER_t => 'FTAFTERt', OPpFT_STACKED => 'FTSTACKED', OPpFT_STACKING => 'FTSTACKING', + OPpHELEMEXISTSOR_DELETE => 'DELETE', OPpHINT_STRICT_REFS => 'STRICT', OPpHUSH_VMSISH => 'HUSH', OPpINDEX_BOOLNEG => 'NEG', @@ -834,6 +837,7 @@ our %ops_using = ( OPpFLIP_LINENUM => [qw(flip flop)], OPpFT_ACCESS => [qw(fteexec fteread ftewrite ftrexec ftrread ftrwrite)], OPpFT_AFTER_t => [qw(ftatime ftbinary ftblk ftchr ftctime ftdir fteexec fteowned fteread ftewrite ftfile ftis ftlink ftmtime ftpipe ftrexec ftrowned ftrread ftrwrite ftsgid ftsize ftsock ftsuid ftsvtx fttext fttty ftzero)], + OPpHELEMEXISTSOR_DELETE => [qw(helemexistsor)], OPpHINT_STRICT_REFS => [qw(entersub multideref rv2av rv2cv rv2gv rv2hv rv2sv)], OPpHUSH_VMSISH => [qw(dbstate nextstate)], OPpINDEX_BOOLNEG => [qw(index rindex)], @@ -12227,6 +12227,36 @@ Perl_ck_exists(pTHX_ OP *o) } OP * +Perl_ck_helemexistsor(pTHX_ OP *o) +{ + PERL_ARGS_ASSERT_CK_HELEMEXISTSOR; + + o = ck_fun(o); + + OP *first; + if(!(o->op_flags & OPf_KIDS) || + !(first = cLOGOPo->op_first) || + first->op_type != OP_HELEM) + /* As this opcode isn't currently exposed to pure-perl, only core or XS + * authors are ever going to see this message. We don't need to list it + * in perldiag as to do so would require documenting OP_HELEMEXISTSOR + * itself + */ + /* diag_listed_as: SKIPME */ + croak("OP_HELEMEXISTSOR argument is not a HASH element"); + + OP *hvop = cBINOPx(first)->op_first; + OP *keyop = OpSIBLING(hvop); + assert(!OpSIBLING(keyop)); + + op_null(first); // null out the OP_HELEM + + keyop->op_next = o; + + return o; +} + +OP * Perl_ck_rvconst(pTHX_ OP *o) { SVOP * const kid = cSVOPx(cUNOPo->op_first); @@ -564,6 +564,7 @@ EXTCONST char* const PL_op_name[] INIT({ [OP_CEIL] = "ceil", [OP_FLOOR] = "floor", [OP_IS_TAINTED] = "is_tainted", + [OP_HELEMEXISTSOR] = "helemexistsor", [OP_max] = "freed", }); @@ -986,6 +987,7 @@ EXTCONST char* const PL_op_desc[] INIT({ [OP_CEIL] = "ceil", [OP_FLOOR] = "floor", [OP_IS_TAINTED] = "is_tainted", + [OP_HELEMEXISTSOR] = "hash element exists or", [OP_max] = "freed op", }); @@ -1413,6 +1415,7 @@ INIT({ [OP_CEIL] = Perl_pp_ceil, [OP_FLOOR] = Perl_pp_floor, [OP_IS_TAINTED] = Perl_pp_is_tainted, + [OP_HELEMEXISTSOR] = Perl_pp_helemexistsor, }); EXT Perl_check_t PL_check[] /* or perlvars.h */ @@ -1835,6 +1838,7 @@ INIT({ [OP_CEIL] = Perl_ck_null, [OP_FLOOR] = Perl_ck_null, [OP_IS_TAINTED] = Perl_ck_null, + [OP_HELEMEXISTSOR] = Perl_ck_helemexistsor, }); EXTCONST U32 PL_opargs[] INIT({ @@ -2256,6 +2260,7 @@ EXTCONST U32 PL_opargs[] INIT({ [OP_CEIL] = 0x0000011e, [OP_FLOOR] = 0x0000011e, [OP_IS_TAINTED] = 0x00000106, + [OP_HELEMEXISTSOR] = 0x00011300, }); END_EXTERN_C @@ -2369,6 +2374,7 @@ END_EXTERN_C #define OPpCOREARGS_PUSHMARK 0x80 #define OPpDEFER_FINALLY 0x80 #define OPpENTERSUB_NOPAREN 0x80 +#define OPpHELEMEXISTSOR_DELETE 0x80 #define OPpLVALUE 0x80 #define OPpLVAL_INTRO 0x80 #define OPpOFFBYONE 0x80 @@ -2948,6 +2954,7 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = { [OP_CEIL] = 78, [OP_FLOOR] = 78, [OP_IS_TAINTED] = 0, + [OP_HELEMEXISTSOR] = 253, }; @@ -3042,6 +3049,7 @@ EXTCONST U16 PL_op_private_bitdefs[] = { 0x353c, 0x4638, 0x04f6, 0x2f0c, 0x1ac8, 0x0003, /* lvref */ 0x353d, /* lvrefslice */ 0x1dfc, 0x0003, /* pushdefer */ + 0x131c, 0x0003, /* helemexistsor */ }; @@ -3468,6 +3476,7 @@ EXTCONST U8 PL_op_private_valid[] = { [OP_CEIL] = (OPpARG1_MASK|OPpTARGET_MY), [OP_FLOOR] = (OPpARG1_MASK|OPpTARGET_MY), [OP_IS_TAINTED] = (OPpARG1_MASK), + [OP_HELEMEXISTSOR] = (OPpARG1_MASK|OPpHELEMEXISTSOR_DELETE), }; @@ -432,10 +432,11 @@ typedef enum opcode { OP_CEIL = 415, OP_FLOOR = 416, OP_IS_TAINTED = 417, + OP_HELEMEXISTSOR = 418, OP_max } opcode; -#define MAXO 418 +#define MAXO 419 #define OP_FREED MAXO /* the OP_IS_* macros are optimized to a simple range check because @@ -5380,6 +5380,78 @@ PP(pp_exists) RETPUSHNO; } +/* OP_HELEMEXISTSOR is a LOGOP not currently available to pure Perl code, but + * is defined for use by the core for new features, optimisations, or XS + * modules. + * + * Constructing it consumes two optrees, the first of which must be an + * OP_HELEM. + * + * OP *o = newLOGOP(OP_HELEMEXISTSOR, 0, helemop, otherop); + * + * If the hash element exists (by the same rules as OP_EXISTS would find + * true) the op pushes it to the stack in the same way as a regular OP_HELEM + * and invokes op_next. If the element does not exist, then op_other is + * invoked instead. This is roughly equivalent to the perl code + * + * exists $hash{$key} ? $hash{$key} : OTHER + * + * Except that any expressions or side-effects involved in obtaining the HV + * or the key are only invoked once, and it is a little more efficient when + * run on regular (non-magical) HVs. + * + * Combined with the OPpHELEMEXISTSOR_DELETE flag in op_private, this + * additionally deletes the element if found. + * + * On a tied HV, the 'EXISTS' method will be run as expected. If the method + * returns true then either the 'FETCH' or 'DELETE' method will also be run + * as required. + */ + +PP(pp_helemexistsor) +{ + dSP; + SV *keysv = POPs; + HV *hv = MUTABLE_HV(POPs); + bool is_delete = PL_op->op_private & OPpHELEMEXISTSOR_DELETE; + + assert(SvTYPE(hv) == SVt_PVHV); + + bool hv_is_magical = UNLIKELY(SvMAGICAL(hv)); + + SV *val = NULL; + + /* For magical HVs we have to ensure we invoke the EXISTS method first. + * For regular HVs we can just skip this and use the "pointer or NULL" + * result of the real hv_* functions + */ + if(hv_is_magical && !hv_exists_ent(hv, keysv, 0)) + goto other; + + if(is_delete) { + val = hv_delete_ent(hv, keysv, 0, 0); + } + else { + HE *he = hv_fetch_ent(hv, keysv, 0, 0); + val = he ? HeVAL(he) : NULL; + + /* A magical HV hasn't yet actually invoked the FETCH method. We must + * ask it to do so now + */ + if(hv_is_magical && val) + SvGETMAGIC(val); + } + + if(!val) { +other: + PUTBACK; + return cLOGOP->op_other; + } + + PUSHs(val); + RETURN; +} + PP(pp_hslice) { dSP; dMARK; dORIGMARK; diff --git a/pp_proto.h b/pp_proto.h index 7963abb885..66f4a420c9 100644 --- a/pp_proto.h +++ b/pp_proto.h @@ -116,6 +116,7 @@ PERL_CALLCONV OP *Perl_pp_gt(pTHX) __attribute__visibility__("hidden"); PERL_CALLCONV OP *Perl_pp_gv(pTHX) __attribute__visibility__("hidden"); PERL_CALLCONV OP *Perl_pp_gvsv(pTHX) __attribute__visibility__("hidden"); PERL_CALLCONV OP *Perl_pp_helem(pTHX) __attribute__visibility__("hidden"); +PERL_CALLCONV OP *Perl_pp_helemexistsor(pTHX) __attribute__visibility__("hidden"); PERL_CALLCONV OP *Perl_pp_hintseval(pTHX) __attribute__visibility__("hidden"); PERL_CALLCONV OP *Perl_pp_hslice(pTHX) __attribute__visibility__("hidden"); PERL_CALLCONV OP *Perl_pp_i_add(pTHX) __attribute__visibility__("hidden"); @@ -611,6 +611,12 @@ PERL_CALLCONV OP * Perl_ck_grep(pTHX_ OP *o) #define PERL_ARGS_ASSERT_CK_GREP \ assert(o) +PERL_CALLCONV OP * Perl_ck_helemexistsor(pTHX_ OP *o) + __attribute__warn_unused_result__ + __attribute__visibility__("hidden"); +#define PERL_ARGS_ASSERT_CK_HELEMEXISTSOR \ + assert(o) + PERL_CALLCONV OP * Perl_ck_index(pTHX_ OP *o) __attribute__warn_unused_result__ __attribute__visibility__("hidden"); diff --git a/regen/op_private b/regen/op_private index f4b0a44067..b074a95c50 100644 --- a/regen/op_private +++ b/regen/op_private @@ -872,6 +872,10 @@ addbits('argdefelem', 6 => qw(OPpARG_IF_FALSE IF_FALSE), ); +addbits('helemexistsor', + 7 => qw(OPpHELEMEXISTSOR_DELETE DELETE), +); + 1; # ex: set ts=8 sts=4 sw=4 et: diff --git a/regen/opcodes b/regen/opcodes index c48c337076..98669955f2 100644 --- a/regen/opcodes +++ b/regen/opcodes @@ -597,3 +597,6 @@ reftype reftype ck_null fsT1 ceil ceil ck_null fsT1 floor floor ck_null fsT1 is_tainted is_tainted ck_null fs1 + +# exists-or; not currently exposed as a Perl-callable op +helemexistsor hash element exists or ck_helemexistsor | S S |