int je_ret; /* last exception thrown */
bool je_mustcatch; /* need to call longjmp()? */
U16 je_old_delaymagic; /* saved PL_delaymagic */
+ SSize_t je_old_stack_hwm;
};
typedef struct jmpenv JMPENV;
+#if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
+# define JE_OLD_STACK_HWM_zero PL_start_env.je_old_stack_hwm = 0
+# define JE_OLD_STACK_HWM_save(je) \
+ (je).je_old_stack_hwm = PL_curstackinfo->si_stack_hwm
+# define JE_OLD_STACK_HWM_restore(je) \
+ if (PL_curstackinfo->si_stack_hwm < (je).je_old_stack_hwm) \
+ PL_curstackinfo->si_stack_hwm = (je).je_old_stack_hwm
+#else
+# define JE_OLD_STACK_HWM_zero NOOP
+# define JE_OLD_STACK_HWM_save(je) NOOP
+# define JE_OLD_STACK_HWM_restore(je) NOOP
+#endif
+
/*
* How to build the first jmpenv.
*
PL_start_env.je_ret = -1; \
PL_start_env.je_mustcatch = TRUE; \
PL_start_env.je_old_delaymagic = 0; \
+ JE_OLD_STACK_HWM_zero; \
} STMT_END
/*
Perl_deb(aTHX_ "JUMPENV_PUSH level=%d at %s:%d\n", \
i, __FILE__, __LINE__);}) \
cur_env.je_prev = PL_top_env; \
+ JE_OLD_STACK_HWM_save(cur_env); \
cur_env.je_ret = PerlProc_setjmp(cur_env.je_buf, SCOPE_SAVES_SIGNAL_MASK); \
+ JE_OLD_STACK_HWM_restore(cur_env); \
PL_top_env = &cur_env; \
cur_env.je_mustcatch = FALSE; \
cur_env.je_old_delaymagic = PL_delaymagic; \
Perl_refcounted_he_fetch_pvn(aTHX_ cophh, keypv, keylen, hash, flags)
/*
-=for apidoc Amx|SV *|cophh_fetch_pvs|const COPHH *cophh|const char *key|U32 flags
+=for apidoc Amx|SV *|cophh_fetch_pvs|const COPHH *cophh|"key"|U32 flags
-Like L</cophh_fetch_pvn>, but takes a C<NUL>-terminated literal string instead
+Like L</cophh_fetch_pvn>, but takes a literal string instead
of a string/length pair, and no precomputed hash.
=cut
Perl_refcounted_he_new_pvn(aTHX_ cophh, keypv, keylen, hash, value, flags)
/*
-=for apidoc Amx|COPHH *|cophh_store_pvs|const COPHH *cophh|const char *key|SV *value|U32 flags
+=for apidoc Amx|COPHH *|cophh_store_pvs|const COPHH *cophh|"key"|SV *value|U32 flags
-Like L</cophh_store_pvn>, but takes a C<NUL>-terminated literal string instead
+Like L</cophh_store_pvn>, but takes a literal string instead
of a string/length pair, and no precomputed hash.
=cut
(SV *)NULL, flags)
/*
-=for apidoc Amx|COPHH *|cophh_delete_pvs|const COPHH *cophh|const char *key|U32 flags
+=for apidoc Amx|COPHH *|cophh_delete_pvs|const COPHH *cophh|"key"|U32 flags
-Like L</cophh_delete_pvn>, but takes a C<NUL>-terminated literal string instead
+Like L</cophh_delete_pvn>, but takes a literal string instead
of a string/length pair, and no precomputed hash.
=cut
cophh_fetch_pvn(CopHINTHASH_get(cop), keypv, keylen, hash, flags)
/*
-=for apidoc Am|SV *|cop_hints_fetch_pvs|const COP *cop|const char *key|U32 flags
+=for apidoc Am|SV *|cop_hints_fetch_pvs|const COP *cop|"key"|U32 flags
-Like L</cop_hints_fetch_pvn>, but takes a C<NUL>-terminated literal string
+Like L</cop_hints_fetch_pvn>, but takes a literal string
instead of a string/length pair, and no precomputed hash.
=cut
#define cop_hints_2hv(cop, flags) \
cophh_2hv(CopHINTHASH_get(cop), flags)
+/*
+=for apidoc Am|const char *|CopLABEL|COP *const cop
+
+Returns the label attached to a cop.
+
+=for apidoc Am|const char *|CopLABEL_len|COP *const cop|STRLEN *len
+
+Returns the label attached to a cop, and stores its length in bytes into
+C<*len>.
+
+=for apidoc Am|const char *|CopLABEL_len_flags|COP *const cop|STRLEN *len|U32 *flags
+
+Returns the label attached to a cop, and stores its length in bytes into
+C<*len>. Upon return, C<*flags> will be set to either C<SVf_UTF8> or 0.
+
+=cut
+*/
+
#define CopLABEL(c) Perl_cop_fetch_label(aTHX_ (c), NULL, NULL)
#define CopLABEL_len(c,len) Perl_cop_fetch_label(aTHX_ (c), len, NULL)
#define CopLABEL_len_flags(c,len,flags) Perl_cop_fetch_label(aTHX_ (c), len, flags)
/* subroutine context */
struct block_sub {
OP * retop; /* op to execute on exit from sub */
+ I32 old_cxsubix; /* previous value of si_cxsubix */
/* Above here is the same for sub, format and eval. */
PAD *prevcomppad; /* the caller's PL_comppad */
CV * cv;
/* format context */
struct block_format {
OP * retop; /* op to execute on exit from sub */
+ I32 old_cxsubix; /* previous value of si_cxsubix */
/* Above here is the same for sub, format and eval. */
PAD *prevcomppad; /* the caller's PL_comppad */
CV * cv;
/* eval context */
struct block_eval {
OP * retop; /* op to execute on exit from eval */
+ I32 old_cxsubix; /* previous value of si_cxsubix */
/* Above here is the same for sub, format and eval. */
SV * old_namesv;
OP * old_eval_root;
*/
/*
-=for apidoc AmU||G_SCALAR
+=for apidoc AmnU||G_SCALAR
Used to indicate scalar context. See C<L</GIMME_V>>, C<L</GIMME>>, and
L<perlcall>.
-=for apidoc AmU||G_ARRAY
+=for apidoc AmnU||G_ARRAY
Used to indicate list context. See C<L</GIMME_V>>, C<L</GIMME>> and
L<perlcall>.
-=for apidoc AmU||G_VOID
+=for apidoc AmnU||G_VOID
Used to indicate void context. See C<L</GIMME_V>> and L<perlcall>.
-=for apidoc AmU||G_DISCARD
+=for apidoc AmnU||G_DISCARD
Indicates that arguments returned from a callback should be discarded. See
L<perlcall>.
-=for apidoc AmU||G_EVAL
+=for apidoc AmnU||G_EVAL
Used to force a Perl C<eval> wrapper around a callback. See
L<perlcall>.
-=for apidoc AmU||G_NOARGS
+=for apidoc AmnU||G_NOARGS
Indicates that no arguments are being sent to a callback. See
L<perlcall>.
#define G_WANT 3
/* extra flags for Perl_call_* routines */
-#define G_DISCARD 4 /* Call FREETMPS.
+#define G_DISCARD 0x4 /* Call FREETMPS.
Don't change this without consulting the
hash actions codes defined in hv.h */
-#define G_EVAL 8 /* Assume eval {} around subroutine call. */
-#define G_NOARGS 16 /* Don't construct a @_ array. */
-#define G_KEEPERR 32 /* Warn for errors, don't overwrite $@ */
-#define G_NODEBUG 64 /* Disable debugging at toplevel. */
-#define G_METHOD 128 /* Calling method. */
-#define G_FAKINGEVAL 256 /* Faking an eval context for call_sv or
+#define G_EVAL 0x8 /* Assume eval {} around subroutine call. */
+#define G_NOARGS 0x10 /* Don't construct a @_ array. */
+#define G_KEEPERR 0x20 /* Warn for errors, don't overwrite $@ */
+#define G_NODEBUG 0x40 /* Disable debugging at toplevel. */
+#define G_METHOD 0x80 /* Calling method. */
+#define G_FAKINGEVAL 0x100 /* Faking an eval context for call_sv or
fold_constants. */
-#define G_UNDEF_FILL 512 /* Fill the stack with &PL_sv_undef
+#define G_UNDEF_FILL 0x200 /* Fill the stack with &PL_sv_undef
A special case for UNSHIFT in
Perl_magic_methcall(). */
-#define G_WRITING_TO_STDERR 1024 /* Perl_write_to_stderr() is calling
+#define G_WRITING_TO_STDERR 0x400 /* Perl_write_to_stderr() is calling
Perl_magic_methcall(). */
-#define G_RE_REPARSING 0x800 /* compiling a run-time /(?{..})/ */
-#define G_METHOD_NAMED 4096 /* calling named method, eg without :: or ' */
+#define G_RE_REPARSING 0x800 /* compiling a run-time /(?{..})/ */
+#define G_METHOD_NAMED 0x1000 /* calling named method, eg without :: or ' */
+#define G_RETHROW 0x2000 /* eval_sv(): re-throw any error */
/* flag bits for PL_in_eval */
#define EVAL_NULL 0 /* not in an eval */
struct stackinfo * si_next;
I32 si_cxix; /* current context index */
I32 si_cxmax; /* maximum allocated index */
+ I32 si_cxsubix; /* topmost sub/eval/format */
I32 si_type; /* type of runlevel */
I32 si_markoff; /* offset where markstack begins for us.
* currently used only with DEBUGGING,
* but not #ifdef-ed for bincompat */
+#if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
+/* high water mark: for checking if the stack was correctly extended /
+ * tested for extension by each pp function */
+ SSize_t si_stack_hwm;
+#endif
+
};
typedef struct stackinfo PERL_SI;
# define SET_MARK_OFFSET NOOP
#endif
+#if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
+# define PUSHSTACK_INIT_HWM(si) ((si)->si_stack_hwm = 0)
+#else
+# define PUSHSTACK_INIT_HWM(si) NOOP
+#endif
+
#define PUSHSTACKi(type) \
STMT_START { \
PERL_SI *next = PL_curstackinfo->si_next; \
} \
next->si_type = type; \
next->si_cxix = -1; \
+ next->si_cxsubix = -1; \
+ PUSHSTACK_INIT_HWM(next); \
AvFILLp(next->si_stack) = 0; \
SWITCHSTACK(PL_curstack,next->si_stack); \
PL_curstackinfo = next; \
/*
=head1 Multicall Functions
-=for apidoc Ams||dMULTICALL
+=for apidoc Amns||dMULTICALL
Declare local variables for a multicall. See L<perlcall/LIGHTWEIGHT CALLBACKS>.
-=for apidoc Ams||PUSH_MULTICALL
+=for apidoc Ams||PUSH_MULTICALL|CV* the_cv
Opening bracket for a lightweight callback.
See L<perlcall/LIGHTWEIGHT CALLBACKS>.
-=for apidoc Ams||MULTICALL
+=for apidoc Amns||MULTICALL
Make a lightweight callback. See L<perlcall/LIGHTWEIGHT CALLBACKS>.
-=for apidoc Ams||POP_MULTICALL
+=for apidoc Amns||POP_MULTICALL
Closing bracket for a lightweight callback.
See L<perlcall/LIGHTWEIGHT CALLBACKS>.