This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
add Perl_op_class(o) API function
authorDavid Mitchell <davem@iabyn.com>
Wed, 18 Jan 2017 12:35:50 +0000 (12:35 +0000)
committerDavid Mitchell <davem@iabyn.com>
Sat, 21 Jan 2017 10:04:44 +0000 (10:04 +0000)
Given an op, this function determines what type of struct it has been
allocated as. Returns one of the OPclass enums, such as OPclass_LISTOP.

Originally this was a static function in B.xs, but it has wider
applicability; indeed several XS modules on CPAN have cut and pasted it.

It adds the OPclass enum to op.h. In B.xs there was a similar enum, but
with names like OPc_LISTOP. I've renamed them to OPclass_LISTOP etc. so as
not to clash with the cut+paste code already on CPAN.

dump.c
embed.fnc
embed.h
ext/B/B.pm
ext/B/B.xs
op.h
pod/perldiag.pod
proto.h

diff --git a/dump.c b/dump.c
index 3915af1..5a3f281 100644 (file)
--- a/dump.c
+++ b/dump.c
@@ -2563,6 +2563,154 @@ Perl_debop(pTHX_ const OP *o)
     return 0;
 }
 
+
+/*
+=for apidoc op_class
+
+Given an op, determine what type of struct it has been allocated as.
+Returns one of the OPclass enums, such as OPclass_LISTOP.
+
+=cut
+*/
+
+
+OPclass
+Perl_op_class(pTHX_ const OP *o)
+{
+    bool custom = 0;
+
+    if (!o)
+       return OPclass_NULL;
+
+    if (o->op_type == 0) {
+       if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE)
+           return OPclass_COP;
+       return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP;
+    }
+
+    if (o->op_type == OP_SASSIGN)
+       return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPclass_UNOP : OPclass_BINOP);
+
+    if (o->op_type == OP_AELEMFAST) {
+#ifdef USE_ITHREADS
+           return OPclass_PADOP;
+#else
+           return OPclass_SVOP;
+#endif
+    }
+    
+#ifdef USE_ITHREADS
+    if (o->op_type == OP_GV || o->op_type == OP_GVSV ||
+       o->op_type == OP_RCATLINE)
+       return OPclass_PADOP;
+#endif
+
+    if (o->op_type == OP_CUSTOM)
+        custom = 1;
+
+    switch (OP_CLASS(o)) {
+    case OA_BASEOP:
+       return OPclass_BASEOP;
+
+    case OA_UNOP:
+       return OPclass_UNOP;
+
+    case OA_BINOP:
+       return OPclass_BINOP;
+
+    case OA_LOGOP:
+       return OPclass_LOGOP;
+
+    case OA_LISTOP:
+       return OPclass_LISTOP;
+
+    case OA_PMOP:
+       return OPclass_PMOP;
+
+    case OA_SVOP:
+       return OPclass_SVOP;
+
+    case OA_PADOP:
+       return OPclass_PADOP;
+
+    case OA_PVOP_OR_SVOP:
+        /*
+         * Character translations (tr///) are usually a PVOP, keeping a 
+         * pointer to a table of shorts used to look up translations.
+         * Under utf8, however, a simple table isn't practical; instead,
+         * the OP is an SVOP (or, under threads, a PADOP),
+         * and the SV is a reference to a swash
+         * (i.e., an RV pointing to an HV).
+         */
+       return (!custom &&
+                  (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
+              )
+#if  defined(USE_ITHREADS)
+               ? OPclass_PADOP : OPclass_PVOP;
+#else
+               ? OPclass_SVOP : OPclass_PVOP;
+#endif
+
+    case OA_LOOP:
+       return OPclass_LOOP;
+
+    case OA_COP:
+       return OPclass_COP;
+
+    case OA_BASEOP_OR_UNOP:
+       /*
+        * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
+        * whether parens were seen. perly.y uses OPf_SPECIAL to
+        * signal whether a BASEOP had empty parens or none.
+        * Some other UNOPs are created later, though, so the best
+        * test is OPf_KIDS, which is set in newUNOP.
+        */
+       return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP;
+
+    case OA_FILESTATOP:
+       /*
+        * The file stat OPs are created via UNI(OP_foo) in toke.c but use
+        * the OPf_REF flag to distinguish between OP types instead of the
+        * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
+        * return OPclass_UNOP so that walkoptree can find our children. If
+        * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
+        * (no argument to the operator) it's an OP; with OPf_REF set it's
+        * an SVOP (and op_sv is the GV for the filehandle argument).
+        */
+       return ((o->op_flags & OPf_KIDS) ? OPclass_UNOP :
+#ifdef USE_ITHREADS
+               (o->op_flags & OPf_REF) ? OPclass_PADOP : OPclass_BASEOP);
+#else
+               (o->op_flags & OPf_REF) ? OPclass_SVOP : OPclass_BASEOP);
+#endif
+    case OA_LOOPEXOP:
+       /*
+        * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
+        * label was omitted (in which case it's a BASEOP) or else a term was
+        * seen. In this last case, all except goto are definitely PVOP but
+        * goto is either a PVOP (with an ordinary constant label), an UNOP
+        * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
+        * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
+        * get set.
+        */
+       if (o->op_flags & OPf_STACKED)
+           return OPclass_UNOP;
+       else if (o->op_flags & OPf_SPECIAL)
+           return OPclass_BASEOP;
+       else
+           return OPclass_PVOP;
+    case OA_METHOP:
+       return OPclass_METHOP;
+    case OA_UNOP_AUX:
+       return OPclass_UNOP_AUX;
+    }
+    Perl_warn(aTHX_ "Can't determine class of operator %s, assuming BASEOP\n",
+        OP_NAME(o));
+    return OPclass_BASEOP;
+}
+
+
+
 STATIC CV*
 S_deb_curcv(pTHX_ I32 ix)
 {
index 656afe5..0ee3fc8 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -506,6 +506,7 @@ p   |void   |dump_all_perl  |bool justperl
 Ap     |void   |dump_eval
 Ap     |void   |dump_form      |NN const GV* gv
 Ap     |void   |gv_dump        |NULLOK GV* gv
+Apd    |OPclass|op_class       |NULLOK const OP *o
 Ap     |void   |op_dump        |NN const OP *o
 Ap     |void   |pmop_dump      |NULLOK PMOP* pm
 Ap     |void   |dump_packsubs  |NN const HV* stash
diff --git a/embed.h b/embed.h
index ba7b2ca..2233a35 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define nothreadhook()         Perl_nothreadhook(aTHX)
 #define op_append_elem(a,b,c)  Perl_op_append_elem(aTHX_ a,b,c)
 #define op_append_list(a,b,c)  Perl_op_append_list(aTHX_ a,b,c)
+#define op_class(a)            Perl_op_class(aTHX_ a)
 #define op_contextualize(a,b)  Perl_op_contextualize(aTHX_ a,b)
 #define op_convert_list(a,b,c) Perl_op_convert_list(aTHX_ a,b,c)
 #define op_dump(a)             Perl_op_dump(aTHX_ a)
index e0f9e21..9e58700 100644 (file)
@@ -15,7 +15,7 @@ require Exporter;
 # walkoptree comes from B.xs
 
 BEGIN {
-    $B::VERSION = '1.65';
+    $B::VERSION = '1.66';
     @B::EXPORT_OK = ();
 
     # Our BOOT code needs $VERSION set, and will append to @EXPORT_OK.
index 2279f36..5143305 100644 (file)
@@ -39,22 +39,6 @@ static const char* const svclassnames[] = {
     "B::IO",
 };
 
-typedef enum {
-    OPc_NULL,  /* 0 */
-    OPc_BASEOP,        /* 1 */
-    OPc_UNOP,  /* 2 */
-    OPc_BINOP, /* 3 */
-    OPc_LOGOP, /* 4 */
-    OPc_LISTOP,        /* 5 */
-    OPc_PMOP,  /* 6 */
-    OPc_SVOP,  /* 7 */
-    OPc_PADOP, /* 8 */
-    OPc_PVOP,  /* 9 */
-    OPc_LOOP,  /* 10 */
-    OPc_COP,   /* 11 */
-    OPc_METHOP,        /* 12 */
-    OPc_UNOP_AUX /* 13 */
-} opclass;
 
 static const char* const opclassnames[] = {
     "B::NULL",
@@ -113,146 +97,12 @@ static void B_init_my_cxt(pTHX_ my_cxt_t * cxt) {
     cxt->x_specialsv_list[6] = (SV *) pWARN_STD;
 }
 
-static opclass
-cc_opclass(pTHX_ const OP *o)
-{
-    bool custom = 0;
-
-    if (!o)
-       return OPc_NULL;
-
-    if (o->op_type == 0) {
-       if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE)
-           return OPc_COP;
-       return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
-    }
-
-    if (o->op_type == OP_SASSIGN)
-       return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
-
-    if (o->op_type == OP_AELEMFAST) {
-#ifdef USE_ITHREADS
-           return OPc_PADOP;
-#else
-           return OPc_SVOP;
-#endif
-    }
-    
-#ifdef USE_ITHREADS
-    if (o->op_type == OP_GV || o->op_type == OP_GVSV ||
-       o->op_type == OP_RCATLINE)
-       return OPc_PADOP;
-#endif
-
-    if (o->op_type == OP_CUSTOM)
-        custom = 1;
-
-    switch (OP_CLASS(o)) {
-    case OA_BASEOP:
-       return OPc_BASEOP;
-
-    case OA_UNOP:
-       return OPc_UNOP;
-
-    case OA_BINOP:
-       return OPc_BINOP;
-
-    case OA_LOGOP:
-       return OPc_LOGOP;
-
-    case OA_LISTOP:
-       return OPc_LISTOP;
-
-    case OA_PMOP:
-       return OPc_PMOP;
-
-    case OA_SVOP:
-       return OPc_SVOP;
-
-    case OA_PADOP:
-       return OPc_PADOP;
-
-    case OA_PVOP_OR_SVOP:
-        /*
-         * Character translations (tr///) are usually a PVOP, keeping a 
-         * pointer to a table of shorts used to look up translations.
-         * Under utf8, however, a simple table isn't practical; instead,
-         * the OP is an SVOP (or, under threads, a PADOP),
-         * and the SV is a reference to a swash
-         * (i.e., an RV pointing to an HV).
-         */
-       return (!custom &&
-                  (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
-              )
-#if  defined(USE_ITHREADS)
-               ? OPc_PADOP : OPc_PVOP;
-#else
-               ? OPc_SVOP : OPc_PVOP;
-#endif
-
-    case OA_LOOP:
-       return OPc_LOOP;
-
-    case OA_COP:
-       return OPc_COP;
-
-    case OA_BASEOP_OR_UNOP:
-       /*
-        * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
-        * whether parens were seen. perly.y uses OPf_SPECIAL to
-        * signal whether a BASEOP had empty parens or none.
-        * Some other UNOPs are created later, though, so the best
-        * test is OPf_KIDS, which is set in newUNOP.
-        */
-       return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
-
-    case OA_FILESTATOP:
-       /*
-        * The file stat OPs are created via UNI(OP_foo) in toke.c but use
-        * the OPf_REF flag to distinguish between OP types instead of the
-        * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
-        * return OPc_UNOP so that walkoptree can find our children. If
-        * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
-        * (no argument to the operator) it's an OP; with OPf_REF set it's
-        * an SVOP (and op_sv is the GV for the filehandle argument).
-        */
-       return ((o->op_flags & OPf_KIDS) ? OPc_UNOP :
-#ifdef USE_ITHREADS
-               (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP);
-#else
-               (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP);
-#endif
-    case OA_LOOPEXOP:
-       /*
-        * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
-        * label was omitted (in which case it's a BASEOP) or else a term was
-        * seen. In this last case, all except goto are definitely PVOP but
-        * goto is either a PVOP (with an ordinary constant label), an UNOP
-        * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
-        * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
-        * get set.
-        */
-       if (o->op_flags & OPf_STACKED)
-           return OPc_UNOP;
-       else if (o->op_flags & OPf_SPECIAL)
-           return OPc_BASEOP;
-       else
-           return OPc_PVOP;
-    case OA_METHOP:
-       return OPc_METHOP;
-    case OA_UNOP_AUX:
-       return OPc_UNOP_AUX;
-    }
-    warn("can't determine class of operator %s, assuming BASEOP\n",
-        OP_NAME(o));
-    return OPc_BASEOP;
-}
 
 static SV *
 make_op_object(pTHX_ const OP *o)
 {
     SV *opsv = sv_newmortal();
-    sv_setiv(newSVrv(opsv, opclassnames[cc_opclass(aTHX_ o)]), PTR2IV(o));
+    sv_setiv(newSVrv(opsv, opclassnames[op_class(o)]), PTR2IV(o));
     return opsv;
 }
 
@@ -509,7 +359,7 @@ walkoptree(pTHX_ OP *o, const char *method, SV *ref)
     dSP;
     OP *kid;
     SV *object;
-    const char *const classname = opclassnames[cc_opclass(aTHX_ o)];
+    const char *const classname = opclassnames[op_class(o)];
     dMY_CXT;
 
     /* Check that no-one has changed our reference, or is holding a reference
@@ -542,7 +392,7 @@ walkoptree(pTHX_ OP *o, const char *method, SV *ref)
            ref = walkoptree(aTHX_ kid, method, ref);
        }
     }
-    if (o && (cc_opclass(aTHX_ o) == OPc_PMOP) && o->op_type != OP_SPLIT
+    if (o && (op_class(o) == OPclass_PMOP) && o->op_type != OP_SPLIT
            && (kid = PMOP_pmreplroot(cPMOPo)))
     {
        ref = walkoptree(aTHX_ kid, method, ref);
@@ -1083,7 +933,7 @@ next(o)
                    : &PL_sv_undef);
                break;
            case 26: /* B::OP::size */
-               ret = sv_2mortal(newSVuv((UV)(opsizes[cc_opclass(aTHX_ o)])));
+               ret = sv_2mortal(newSVuv((UV)(opsizes[op_class(o)])));
                break;
            case 27: /* B::OP::name */
            case 28: /* B::OP::desc */
diff --git a/op.h b/op.h
index 90f63e3..4e3012f 100644 (file)
--- a/op.h
+++ b/op.h
@@ -475,6 +475,24 @@ struct loop {
 #define kLOOP          cLOOPx(kid)
 
 
+typedef enum {
+    OPclass_NULL,     /*  0 */
+    OPclass_BASEOP,   /*  1 */
+    OPclass_UNOP,     /*  2 */
+    OPclass_BINOP,    /*  3 */
+    OPclass_LOGOP,    /*  4 */
+    OPclass_LISTOP,   /*  5 */
+    OPclass_PMOP,     /*  6 */
+    OPclass_SVOP,     /*  7 */
+    OPclass_PADOP,    /*  8 */
+    OPclass_PVOP,     /*  9 */
+    OPclass_LOOP,     /* 10 */
+    OPclass_COP,      /* 11 */
+    OPclass_METHOP,   /* 12 */
+    OPclass_UNOP_AUX  /* 13 */
+} OPclass;
+
+
 #ifdef USE_ITHREADS
 #  define      cGVOPx_gv(o)    ((GV*)PAD_SVl(cPADOPx(o)->op_padix))
 #  ifndef PERL_CORE
index afdcb73..9038b2b 100644 (file)
@@ -839,6 +839,13 @@ C<foreach> loop nor a C<given> block.  (Note that this error is
 issued on exit from the C<default> block, so you won't get the
 error if you use an explicit C<continue>.)
 
+=item Can't determine class of operator %s, assuming BASEOP
+
+(S) This warning indicates something wrong in the internals of perl.
+Perl was trying to find the class (e.g. LISTOP) of a particular OP,
+and was unable to do so. This is likely to be due to a bug in the perl
+internals, or due to a bug in XS code which manipulates perl optrees.
+
 =item Can't do inplace edit: %s is not a regular file
 
 (S inplace) You tried to use the B<-i> switch on a special file, such as
diff --git a/proto.h b/proto.h
index 2fd8a51..e3c04dc 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -2343,6 +2343,7 @@ PERL_CALLCONV OP* Perl_oopsHV(pTHX_ OP* o)
 
 PERL_CALLCONV OP*      Perl_op_append_elem(pTHX_ I32 optype, OP* first, OP* last);
 PERL_CALLCONV OP*      Perl_op_append_list(pTHX_ I32 optype, OP* first, OP* last);
+PERL_CALLCONV OPclass  Perl_op_class(pTHX_ const OP *o);
 PERL_CALLCONV void     Perl_op_clear(pTHX_ OP* o);
 #define PERL_ARGS_ASSERT_OP_CLEAR      \
        assert(o)