X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/1fced1a2c6a67934990a50b61e729760a556308b..843fe1cac3dd0142b6beb4102c4616fff1a0ac38:/cop.h

diff --git a/cop.h b/cop.h
index ce688ab..f9bf852 100644
--- a/cop.h
+++ b/cop.h
@@ -35,10 +35,24 @@ struct jmpenv {
     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.
  *
@@ -57,6 +71,7 @@ typedef struct jmpenv 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
 
 /*
@@ -102,7 +117,9 @@ typedef struct jmpenv JMPENV;
 	    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;			\
@@ -173,9 +190,9 @@ associated with the key.
     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
@@ -279,9 +296,9 @@ be stored with referential integrity, but will be coerced to strings.
     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
@@ -336,9 +353,9 @@ hash of the key string, or zero if it has not been precomputed.
 	(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
@@ -476,9 +493,9 @@ associated with the key.
     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
@@ -524,6 +541,24 @@ be zero.
 #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)
@@ -550,6 +585,7 @@ be zero.
 /* 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;
@@ -562,6 +598,7 @@ struct block_sub {
 /* 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;
@@ -628,6 +665,7 @@ struct block_format {
 /* 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;
@@ -905,27 +943,27 @@ struct context {
 */
 
 /*
-=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>.
@@ -939,23 +977,24 @@ 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 */
@@ -990,6 +1029,7 @@ struct stackinfo {
     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,
@@ -1016,7 +1056,7 @@ typedef struct stackinfo PERL_SI;
 #endif
 
 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
-#  define PUSHSTACK_INIT_HWM(si) si->si_stack_hwm = 0
+#  define PUSHSTACK_INIT_HWM(si) ((si)->si_stack_hwm = 0)
 #else
 #  define PUSHSTACK_INIT_HWM(si) NOOP
 #endif
@@ -1036,6 +1076,7 @@ typedef struct stackinfo PERL_SI;
 	}								\
 	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);			\
@@ -1081,17 +1122,17 @@ typedef struct stackinfo PERL_SI;
 /*
 =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>.