Improve custom OP support.

Change the custom op registrations from two separate hashes to one hash
holding structure pointers, and add API functions to register ops and
look them up. This will make it easier to add new properties of custom
ops in the future. Copy entries across from the old hashes where
necessary, to preserve compatibility.

Add two new properties, in addition to the already-existing 'name' and
'description': 'class' and 'peep'. 'class' is one of the OA_*OP
constants, and allows B and other introspection mechanisms to work with
custom ops that aren't BASEOPs. 'peep' is a pointer to a function that
will be called for ops of this type from Perl_rpeep.

Adjust B.xs to take account of the new properties, and also to give
custom ops their registered name rather than simply 'custom'.

13 files changed, 158 insertions, 43 deletions

diff --git a/embed.fnc b/embed.fnc
index 7188db971d..ad7e7a4de0 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1489,8 +1489,11 @@ Ap	|void	|sys_intern_clear
 Ap	|void	|sys_intern_init
 #endif
 
+AopP	|const XOP *	|custom_op_xop	|NN const OP *o
 ApR	|const char *	|custom_op_name	|NN const OP *o
 ApR	|const char *	|custom_op_desc	|NN const OP *o
+Aop	|void	|custom_op_register	|NN Perl_ppaddr_t ppaddr \
+			|NN const XOP *xop
 
 Adp	|void	|sv_nosharing	|NULLOK SV *sv
 Adpbm	|void	|sv_nolocking	|NULLOK SV *sv
diff --git a/embedvar.h b/embedvar.h
index 290d40262c..65b38f0667 100644
--- a/embedvar.h
+++ b/embedvar.h
@@ -106,6 +106,7 @@
 #define PL_curstname		(vTHX->Icurstname)
 #define PL_custom_op_descs	(vTHX->Icustom_op_descs)
 #define PL_custom_op_names	(vTHX->Icustom_op_names)
+#define PL_custom_ops		(vTHX->Icustom_ops)
 #define PL_cv_has_eval		(vTHX->Icv_has_eval)
 #define PL_dbargs		(vTHX->Idbargs)
 #define PL_debstash		(vTHX->Idebstash)
@@ -436,6 +437,7 @@
 #define PL_Icurstname		PL_curstname
 #define PL_Icustom_op_descs	PL_custom_op_descs
 #define PL_Icustom_op_names	PL_custom_op_names
+#define PL_Icustom_ops		PL_custom_ops
 #define PL_Icv_has_eval		PL_cv_has_eval
 #define PL_Idbargs		PL_dbargs
 #define PL_Idebstash		PL_debstash
diff --git a/ext/B/B.xs b/ext/B/B.xs
index ad9c0a676d..2a950d355c 100644
--- a/ext/B/B.xs
+++ b/ext/B/B.xs
@@ -113,6 +113,8 @@ START_MY_CXT
 static opclass
 cc_opclass(pTHX_ const OP *o)
 {
+    bool custom = 0;
+
     if (!o)
 	return OPc_NULL;
 
@@ -139,7 +141,10 @@ cc_opclass(pTHX_ const OP *o)
 	return OPc_PADOP;
 #endif
 
-    switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
+    if (o->op_type == OP_CUSTOM)
+        custom = 1;
+
+    switch (OP_CLASS(o)) {
     case OA_BASEOP:
 	return OPc_BASEOP;
 
@@ -173,7 +178,9 @@ cc_opclass(pTHX_ const OP *o)
          * and the SV is a reference to a swash
          * (i.e., an RV pointing to an HV).
          */
-	return (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
+	return (!custom &&
+		   (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
+	       )
 #if  defined(USE_ITHREADS) \
   && (PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION >= 9))
 		? OPc_PADOP : OPc_PVOP;
@@ -231,7 +238,7 @@ cc_opclass(pTHX_ const OP *o)
 	    return OPc_PVOP;
     }
     warn("can't determine class of operator %s, assuming BASEOP\n",
-	 PL_op_name[o->op_type]);
+	 OP_NAME(o));
     return OPc_BASEOP;
 }
 
@@ -962,7 +969,7 @@ name(o)
     ALIAS:
 	desc = 1
     CODE:
-	RETVAL = (char *)(ix ? PL_op_desc : PL_op_name)[o->op_type];
+	RETVAL = (char *)(ix ? OP_DESC(o) : OP_NAME(o));
     OUTPUT:
 	RETVAL
 
diff --git a/global.sym b/global.sym
index fbfa98bd1e..23e7bb99ce 100644
--- a/global.sym
+++ b/global.sym
@@ -70,6 +70,8 @@ Perl_croak_sv
 Perl_croak_xs_usage
 Perl_custom_op_desc
 Perl_custom_op_name
+Perl_custom_op_register
+Perl_custom_op_xop
 Perl_cv_const_sv
 Perl_cv_get_call_checker
 Perl_cv_set_call_checker
diff --git a/intrpvar.h b/intrpvar.h
index 1ba3ab8000..d10feec23e 100644
--- a/intrpvar.h
+++ b/intrpvar.h
@@ -770,6 +770,8 @@ PERLVAR(Iblockhooks, AV *)
 /* Everything that folds to a character, for case insensitivity regex matching */
 PERLVARI(Iutf8_foldclosures,	HV *, NULL)
 
+PERLVAR(Icustom_ops, HV *)      /* custom op registrations */
+
 /* If you are adding a U8 or U16, check to see if there are 'Space' comments
  * above on where there are gaps which currently will be structure padding.  */
 
diff --git a/mathoms.c b/mathoms.c
index 78516b3d4b..ccefceb154 100644
--- a/mathoms.c
+++ b/mathoms.c
@@ -1554,6 +1554,20 @@ Perl_sv_2bool(pTHX_ register SV *const sv)
     return sv_2bool_flags(sv, SV_GMAGIC);
 }
 
+
+const char*
+Perl_custom_op_name(pTHX_ const OP* o)
+{
+    PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
+    return XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_name);
+}
+
+const char*
+Perl_custom_op_desc(pTHX_ const OP* o)
+{
+    PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
+    return XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_desc);
+}
 #endif /* NO_MATHOMS */
 
 /*
diff --git a/op.c b/op.c
index 7a6dbcdb83..199a9d0ec9 100644
--- a/op.c
+++ b/op.c
@@ -10020,6 +10020,15 @@ Perl_rpeep(pTHX_ register OP *o)
 		assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
 	    }
 	    break;
+
+	case OP_CUSTOM: {
+	    Perl_cpeep_t cpeep = 
+		XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_peep);
+	    if (cpeep)
+		cpeep(aTHX_ o, oldop);
+	    break;
+	}
+	    
 	}
 	oldop = o;
     }
@@ -10032,48 +10041,73 @@ Perl_peep(pTHX_ register OP *o)
     CALL_RPEEP(o);
 }
 
-const char*
-Perl_custom_op_name(pTHX_ const OP* o)
+const XOP *
+Perl_custom_op_xop(pTHX_ const OP *o)
 {
-    dVAR;
-    const IV index = PTR2IV(o->op_ppaddr);
-    SV* keysv;
-    HE* he;
+    SV *keysv;
+    HE *he = NULL;
+    XOP *xop;
+
+    static const XOP xop_null = { 0, 0, 0, 0, 0 };
 
-    PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
+    PERL_ARGS_ASSERT_CUSTOM_OP_XOP;
+    assert(o->op_type == OP_CUSTOM);
 
-    if (!PL_custom_op_names) /* This probably shouldn't happen */
-        return (char *)PL_op_name[OP_CUSTOM];
+    /* This is wrong. It assumes a function pointer can be cast to IV,
+     * which isn't guaranteed, but this is what the old custom OP code
+     * did. In principle it should be safer to Copy the bytes of the
+     * pointer into a PV: since the new interface is hidden behind
+     * functions, this can be changed later if necessary.  */
+    /* Change custom_op_xop if this ever happens */
+    keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
 
-    keysv = sv_2mortal(newSViv(index));
+    if (PL_custom_ops)
+	he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
+
+    /* assume noone will have just registered a desc */
+    if (!he && PL_custom_op_names &&
+	(he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
+    ) {
+	const char *pv;
+	STRLEN l;
+
+	/* XXX does all this need to be shared mem? */
+	Newx(xop, 1, XOP);
+	pv = SvPV(HeVAL(he), l);
+	XopENTRY_set(xop, xop_name, savepvn(pv, l));
+	if (PL_custom_op_descs &&
+	    (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
+	) {
+	    pv = SvPV(HeVAL(he), l);
+	    XopENTRY_set(xop, xop_desc, savepvn(pv, l));
+	}
+	Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
+	return xop;
+    }
 
-    he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
-    if (!he)
-        return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
+    if (!he) return &xop_null;
 
-    return SvPV_nolen(HeVAL(he));
+    xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
+    return xop;
 }
 
-const char*
-Perl_custom_op_desc(pTHX_ const OP* o)
-{
-    dVAR;
-    const IV index = PTR2IV(o->op_ppaddr);
-    SV* keysv;
-    HE* he;
 
-    PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
 
-    if (!PL_custom_op_descs)
-        return (char *)PL_op_desc[OP_CUSTOM];
+void
+Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
+{
+    SV *keysv;
+
+    PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
 
-    keysv = sv_2mortal(newSViv(index));
+    /* see the comment in custom_op_xop */
+    keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
 
-    he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
-    if (!he)
-        return (char *)PL_op_desc[OP_CUSTOM];
+    if (!PL_custom_ops)
+	PL_custom_ops = newHV();
 
-    return SvPV_nolen(HeVAL(he));
+    if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
+	Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
 }
 
 #include "XSUB.h"
diff --git a/op.h b/op.h
index a10069bfa0..a4921e1188 100644
--- a/op.h
+++ b/op.h
@@ -760,6 +760,52 @@ preprocessing token; the type of I<arg> depends on I<which>.
 #define RV2CVOPCV_MARK_EARLY     0x00000001
 #define RV2CVOPCV_RETURN_NAME_GV 0x00000002
 
+struct custom_op {
+    U32		    xop_flags;    
+    const char	   *xop_name;
+    const char	   *xop_desc;
+    U32		    xop_class;
+    void	  (*xop_peep)(pTHX_ OP *o, OP *oldop);
+};
+
+#define XopFLAGS(xop) ((xop)->xop_flags)
+
+#define XOPf_xop_name	0x01
+#define XOPf_xop_desc	0x02
+#define XOPf_xop_class	0x04
+#define XOPf_xop_peep	0x08
+
+#define XOPd_xop_name	PL_op_name[OP_CUSTOM]
+#define XOPd_xop_desc	PL_op_desc[OP_CUSTOM]
+#define XOPd_xop_class	OA_BASEOP
+#define XOPd_xop_peep	((Perl_cpeep_t)0)
+
+#define XopENTRY_set(xop, which, to) \
+    STMT_START { \
+	(xop)->which = (to); \
+	(xop)->xop_flags |= XOPf_ ## which; \
+    } STMT_END
+
+#define XopENTRY(xop, which) \
+    ((XopFLAGS(xop) & XOPf_ ## which) ? (xop)->which : XOPd_ ## which)
+
+#define XopDISABLE(xop, which) ((xop)->xop_flags &= ~XOPf_ ## which)
+#define XopENABLE(xop, which) \
+    STMT_START { \
+	(xop)->xop_flags |= XOPf_ ## which; \
+	assert(XopENTRY(xop, which)); \
+    } STMT_END
+
+#define OP_NAME(o) ((o)->op_type == OP_CUSTOM \
+		    ? XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_name) \
+		    : PL_op_name[(o)->op_type])
+#define OP_DESC(o) ((o)->op_type == OP_CUSTOM \
+		    ? XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_desc) \
+		    : PL_op_desc[(o)->op_type])
+#define OP_CLASS(o) ((o)->op_type == OP_CUSTOM \
+		     ? XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_class) \
+		     : (PL_opargs[(o)->op_type] & OA_CLASS_MASK))
+
 #ifdef PERL_MAD
 #  define MAD_NULL 1
 #  define MAD_PV 2
diff --git a/opcode.h b/opcode.h
index bb07bef589..122c67f572 100644
--- a/opcode.h
+++ b/opcode.h
@@ -24,11 +24,6 @@ PERL_PPDEF(Perl_unimplemented_op)
 
 START_EXTERN_C
 
-#define OP_NAME(o) ((o)->op_type == OP_CUSTOM ? custom_op_name(o) : \
-                    PL_op_name[(o)->op_type])
-#define OP_DESC(o) ((o)->op_type == OP_CUSTOM ? custom_op_desc(o) : \
-                    PL_op_desc[(o)->op_type])
-
 #ifndef DOINIT
 EXTCONST char* const PL_op_name[];
 #else
diff --git a/perl.h b/perl.h
index 22bb6d8e36..522df7259e 100644
--- a/perl.h
+++ b/perl.h
@@ -2410,6 +2410,7 @@ typedef struct pvop PVOP;
 typedef struct loop LOOP;
 
 typedef struct block_hooks BHK;
+typedef struct custom_op XOP;
 
 typedef struct interpreter PerlInterpreter;
 
@@ -4909,6 +4910,7 @@ typedef OP* (*Perl_ppaddr_t)(pTHX);
 typedef OP* (*Perl_check_t) (pTHX_ OP*);
 typedef void(*Perl_ophook_t)(pTHX_ OP*);
 typedef int (*Perl_keyword_plugin_t)(pTHX_ char*, STRLEN, OP**);
+typedef void(*Perl_cpeep_t)(pTHX_ OP *, OP *);
 
 #define KEYWORD_PLUGIN_DECLINE 0
 #define KEYWORD_PLUGIN_STMT    1
diff --git a/proto.h b/proto.h
index 3bae4fe52b..3a80ae2ae1 100644
--- a/proto.h
+++ b/proto.h
@@ -588,6 +588,18 @@ PERL_CALLCONV const char *	Perl_custom_op_name(pTHX_ const OP *o)
 #define PERL_ARGS_ASSERT_CUSTOM_OP_NAME	\
 	assert(o)
 
+PERL_CALLCONV void	Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
+			__attribute__nonnull__(pTHX_1)
+			__attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER	\
+	assert(ppaddr); assert(xop)
+
+PERL_CALLCONV const XOP *	Perl_custom_op_xop(pTHX_ const OP *o)
+			__attribute__pure__
+			__attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CUSTOM_OP_XOP	\
+	assert(o)
+
 PERL_CALLCONV void	Perl_cv_ckproto_len(pTHX_ const CV* cv, const GV* gv, const char* p, const STRLEN len)
 			__attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_CV_CKPROTO_LEN	\
diff --git a/regen/opcode.pl b/regen/opcode.pl
index 90c1bc0326..bd3d55adae 100755
--- a/regen/opcode.pl
+++ b/regen/opcode.pl
@@ -181,11 +181,6 @@ print $on "#define OP_phoney_OUTPUT_ONLY -2\n\n";
 print <<END;
 START_EXTERN_C
 
-#define OP_NAME(o) ((o)->op_type == OP_CUSTOM ? custom_op_name(o) : \\
-                    PL_op_name[(o)->op_type])
-#define OP_DESC(o) ((o)->op_type == OP_CUSTOM ? custom_op_desc(o) : \\
-                    PL_op_desc[(o)->op_type])
-
 #ifndef DOINIT
 EXTCONST char* const PL_op_name[];
 #else
diff --git a/sv.c b/sv.c
index 04e1df13a6..57db4f4894 100644
--- a/sv.c
+++ b/sv.c
@@ -12901,6 +12901,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_modglobal	= hv_dup_inc(proto_perl->Imodglobal, param);
     PL_custom_op_names  = hv_dup_inc(proto_perl->Icustom_op_names,param);
     PL_custom_op_descs  = hv_dup_inc(proto_perl->Icustom_op_descs,param);
+    PL_custom_ops	= hv_dup_inc(proto_perl->Icustom_ops, param);
 
     PL_profiledata	= NULL;