: Used in perl.c
p |void |boot_core_PerlIO
Ap |void |call_list |I32 oldscope|NN AV *paramList
+Apd |const PERL_CONTEXT * |caller_cx|I32 level \
+ |NULLOK const PERL_CONTEXT **dbcxp
: Used in serveral source files
pR |bool |cando |Mode_t mode|bool effective|NN const Stat_t* statbufp
ApR |U32 |cast_ulong |NV f
#endif
: Used in perly.y
pR |OP* |convert |I32 optype|I32 flags|NULLOK OP* o
+Apd |HV* |cop_hints_2hv |NN const COP *cop
+Apd |SV* |cop_hints_fetchpvn|NN const COP *cop|NN const char *key \
+ |STRLEN klen|int flags|U32 hash
+Amd |SV* |cop_hints_fetchpvs|NN const COP *cop|NN const char *const key
+Amd |SV* |cop_hints_fetchsv|NN const COP *cop|NN SV *keysv|U32 hash
: Used in op.c and perl.c
pM |PERL_CONTEXT* |create_eval_scope|U32 flags
Aprd |void |croak_sv |NN SV *baseex
}
/*
+=for apidoc cop_hints_2hv
+
+Generates and returns a C<HV *> from the hinthash in the provided
+C<COP>. Returns C<NULL> if there isn't one there.
+
+=cut
+*/
+HV *
+Perl_cop_hints_2hv(pTHX_ const COP *cop)
+{
+ PERL_ARGS_ASSERT_COP_HINTS_2HV;
+
+ if (!cop->cop_hints_hash)
+ return NULL;
+
+ return Perl_refcounted_he_chain_2hv(aTHX_ cop->cop_hints_hash);
+}
+
+/*
+=for apidoc cop_hints_fetchsv
+
+Fetches an entry from the hinthash in the provided C<COP>. Returns NULL
+if the entry isn't there.
+
+=for apidoc cop_hints_fetchpvn
+
+See L</cop_hints_fetchsv>. If C<flags> includes C<HVhek_UTF8>, C<key> is
+in UTF-8.
+
+=for apidoc cop_hints_fetchpvs
+
+See L</cop_hints_fetchpvn>. This is a macro that takes a constant string
+for its argument, which is assumed to be ASCII (rather than UTF-8).
+
+=cut
+*/
+SV *
+Perl_cop_hints_fetchpvn(pTHX_ const COP *cop, const char *key, STRLEN klen,
+ int flags, U32 hash)
+{
+ PERL_ARGS_ASSERT_COP_HINTS_FETCHPVN;
+
+ /* refcounted_he_fetch takes more flags than we do. Make sure
+ * noone's depending on being able to pass them here. */
+ flags &= ~HVhek_UTF8;
+
+ return Perl_refcounted_he_fetch(aTHX_ cop->cop_hints_hash, NULL,
+ key, klen, flags, hash);
+}
+
+/*
=for apidoc refcounted_he_chain_2hv
Generates and returns a C<HV *> by walking up the tree starting at the passed
between threads (because it hangs from OPs, which are shared), hence the
alternate definition and mutex. */
+#define cop_hints_fetchsv(cop, keysv, hash) \
+ Perl_cop_hints_fetchpvn(aTHX_ (cop), SvPV_nolen(keysv), SvCUR(keysv), \
+ (SvUTF8(keysv) ? HVhek_UTF8 : 0), (hash))
+
+#define cop_hints_fetchpvs(cop, key) \
+ Perl_cop_hints_fetchpvn(aTHX_ (cop), STR_WITH_LEN(key), 0, 0)
+
struct refcounted_he;
#ifdef PERL_CORE
RETSETNO;
}
-PP(pp_caller)
+/*
+=for apidoc caller_cx
+
+The XSUB-writer's equivalent of L<caller()|perlfunc/caller>. The
+returned C<PERL_CONTEXT> structure can be interrogated to find all the
+information returned to Perl by C<caller>. Note that XSUBs don't get a
+stack frame, so C<caller_cx(0, NULL)> will return information for the
+immediately-surrounding Perl code.
+
+This function skips over the automatic calls to C<&DB::sub> made on the
+behalf of the debugger. If the stack frame requested was a sub called by
+C<DB::sub>, the return value will be the frame for the call to
+C<DB::sub>, since that has the correct line number/etc. for the call
+site. If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
+frame for the sub call itself.
+
+=cut
+*/
+
+const PERL_CONTEXT *
+Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
{
- dVAR;
- dSP;
register I32 cxix = dopoptosub(cxstack_ix);
register const PERL_CONTEXT *cx;
register const PERL_CONTEXT *ccstack = cxstack;
const PERL_SI *top_si = PL_curstackinfo;
- I32 gimme;
- const char *stashname;
- I32 count = 0;
-
- if (MAXARG)
- count = POPi;
for (;;) {
/* we may be in a higher stacklevel, so dig down deeper */
ccstack = top_si->si_cxstack;
cxix = dopoptosub_at(ccstack, top_si->si_cxix);
}
- if (cxix < 0) {
- if (GIMME != G_ARRAY) {
- EXTEND(SP, 1);
- RETPUSHUNDEF;
- }
- RETURN;
- }
+ if (cxix < 0)
+ return NULL;
/* caller() should not report the automatic calls to &DB::sub */
if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
}
cx = &ccstack[cxix];
+ if (dbcxp) *dbcxp = cx;
+
if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
/* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
cx = &ccstack[dbcxix];
}
+ return cx;
+}
+
+PP(pp_caller)
+{
+ dVAR;
+ dSP;
+ register const PERL_CONTEXT *cx;
+ const PERL_CONTEXT *dbcx;
+ I32 gimme;
+ const char *stashname;
+ I32 count = 0;
+
+ if (MAXARG)
+ count = POPi;
+
+ cx = caller_cx(count, &dbcx);
+ if (!cx) {
+ if (GIMME != G_ARRAY) {
+ EXTEND(SP, 1);
+ RETPUSHUNDEF;
+ }
+ RETURN;
+ }
+
stashname = CopSTASHPV(cx->blk_oldcop);
if (GIMME != G_ARRAY) {
EXTEND(SP, 1);
if (!MAXARG)
RETURN;
if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
- GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
+ GV * const cvgv = CvGV(dbcx->blk_sub.cv);
/* So is ccstack[dbcxix]. */
if (isGV(cvgv)) {
SV * const sv = newSV(0);