Define OP_HELEMEXISTSOR, a handy LOGOP shortcut for HELEM existence t…

…ests

This op is constructed using an OP_HELEM as the op_first and any scalar
expression as the op_other.

It is roughly equivalent to the following perl code:

  exists $hv{$key} ? $hv{$key} : OTHER

except that the HV and the KEY expression are evaluated only once, and
only one hv_* function is invoked to both test and obtain the value. It
is therefore smaller and more efficient.

Likewise, adding the OPpHELEMEXISTSOR_DELETE flag turns it into the
equivalent of

  exists $hv{$key} ? delete $hv{$key} : OTHER

embed.h

@@ -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)

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
 

op.c

@@ -12226,6 +12226,36 @@ Perl_ck_exists(pTHX_ OP *o)
     return 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)
 {

pp.c

@@ -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;

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:

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