From 1e85b6586ab5aca2ff20296114f8e70b45956a92 Mon Sep 17 00:00:00 2001 From: David Mitchell Date: Wed, 18 Jan 2017 12:35:50 +0000 Subject: [PATCH] add Perl_op_class(o) API function 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 | 148 +++++++++++++++++++++++++++++++++++++++++++++++++++ embed.fnc | 1 + embed.h | 1 + ext/B/B.pm | 2 +- ext/B/B.xs | 158 ++----------------------------------------------------- op.h | 18 +++++++ pod/perldiag.pod | 7 +++ proto.h | 1 + 8 files changed, 181 insertions(+), 155 deletions(-) diff --git a/dump.c b/dump.c index 3915af1..5a3f281 100644 --- 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) { diff --git a/embed.fnc b/embed.fnc index 656afe5..0ee3fc8 100644 --- 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 --- a/embed.h +++ b/embed.h @@ -434,6 +434,7 @@ #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) diff --git a/ext/B/B.pm b/ext/B/B.pm index e0f9e21..9e58700 100644 --- a/ext/B/B.pm +++ b/ext/B/B.pm @@ -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. diff --git a/ext/B/B.xs b/ext/B/B.xs index 2279f36..5143305 100644 --- a/ext/B/B.xs +++ b/ext/B/B.xs @@ -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 --- 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 diff --git a/pod/perldiag.pod b/pod/perldiag.pod index afdcb73..9038b2b 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -839,6 +839,13 @@ C loop nor a C block. (Note that this error is issued on exit from the C block, so you won't get the error if you use an explicit C.) +=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 --- 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) -- 1.8.3.1