+/* A jmpenv packages the state required to perform a proper non-local jump.
+ * Note that there is a PL_start_env initialized when perl starts, and
+ * PL_top_env points to this initially, so PL_top_env should always be
+ * non-null.
+ *
+ * Existence of a non-null PL_top_env->je_prev implies it is valid to call
+ * longjmp() at that runlevel (we make sure PL_start_env.je_prev is always
+ * null to ensure this).
+ *
+ * je_mustcatch, when set at any runlevel to TRUE, means eval ops must
+ * establish a local jmpenv to handle exception traps. Care must be taken
+ * to restore the previous value of je_mustcatch before exiting the
+ * stack frame iff JMPENV_PUSH was not called in that stack frame.
+ * GSAR 97-03-27
+ */
+
+struct jmpenv {
+ struct jmpenv * je_prev;
+ Sigjmp_buf je_buf; /* only for use if !je_throw */
+ int je_ret; /* last exception thrown */
+ bool je_mustcatch; /* need to call longjmp()? */
+};
+
+typedef struct jmpenv JMPENV;
+
+#ifdef OP_IN_REGISTER
+#define OP_REG_TO_MEM PL_opsave = op
+#define OP_MEM_TO_REG op = PL_opsave
+#else
+#define OP_REG_TO_MEM NOOP
+#define OP_MEM_TO_REG NOOP
+#endif
+
+/*
+ * How to build the first jmpenv.
+ *
+ * top_env needs to be non-zero. It points to an area
+ * in which longjmp() stuff is stored, as C callstack
+ * info there at least is thread specific this has to
+ * be per-thread. Otherwise a 'die' in a thread gives
+ * that thread the C stack of last thread to do an eval {}!
+ */
+
+#define JMPENV_BOOTSTRAP \
+ STMT_START { \
+ Zero(&PL_start_env, 1, JMPENV); \
+ PL_start_env.je_ret = -1; \
+ PL_start_env.je_mustcatch = TRUE; \
+ PL_top_env = &PL_start_env; \
+ } STMT_END
+
+/*
+ * PERL_FLEXIBLE_EXCEPTIONS
+ *
+ * All the flexible exceptions code has been removed.
+ * See the following threads for details:
+ *
+ * http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2004-07/msg00378.html
+ *
+ * Joshua's original patches (which weren't applied) and discussion:
+ *
+ * http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg01396.html
+ * http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg01489.html
+ * http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg01491.html
+ * http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg01608.html
+ * http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg02144.html
+ * http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg02998.html
+ *
+ * Chip's reworked patch and discussion:
+ *
+ * http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1999-03/msg00520.html
+ *
+ * The flaw in these patches (which went unnoticed at the time) was
+ * that they moved some code that could potentially die() out of the
+ * region protected by the setjmp()s. This caused exceptions within
+ * END blocks and such to not be handled by the correct setjmp().
+ *
+ * The original patches that introduces flexible exceptions were:
+ *
+ * http://perl5.git.perl.org/perl.git/commit/312caa8e97f1c7ee342a9895c2f0e749625b4929
+ * http://perl5.git.perl.org/perl.git/commit/14dd3ad8c9bf82cf09798a22cc89a9862dfd6d1a
+ *
+ */
+
+#define dJMPENV JMPENV cur_env
+
+#define JMPENV_PUSH(v) \
+ STMT_START { \
+ DEBUG_l({ \
+ int i = 0; JMPENV *p = PL_top_env; \
+ while (p) { i++; p = p->je_prev; } \
+ Perl_deb(aTHX_ "JUMPENV_PUSH level=%d at %s:%d\n", \
+ i, __FILE__, __LINE__);}) \
+ cur_env.je_prev = PL_top_env; \
+ OP_REG_TO_MEM; \
+ cur_env.je_ret = PerlProc_setjmp(cur_env.je_buf, SCOPE_SAVES_SIGNAL_MASK); \
+ OP_MEM_TO_REG; \
+ PL_top_env = &cur_env; \
+ cur_env.je_mustcatch = FALSE; \
+ (v) = cur_env.je_ret; \
+ } STMT_END
+
+#define JMPENV_POP \
+ STMT_START { \
+ DEBUG_l({ \
+ int i = -1; JMPENV *p = PL_top_env; \
+ while (p) { i++; p = p->je_prev; } \
+ Perl_deb(aTHX_ "JUMPENV_POP level=%d at %s:%d\n", \
+ i, __FILE__, __LINE__);}) \
+ assert(PL_top_env == &cur_env); \
+ PL_top_env = cur_env.je_prev; \
+ } STMT_END
+
+#define JMPENV_JUMP(v) \
+ STMT_START { \
+ DEBUG_l({ \
+ int i = -1; JMPENV *p = PL_top_env; \
+ while (p) { i++; p = p->je_prev; } \
+ Perl_deb(aTHX_ "JUMPENV_JUMP(%d) level=%d at %s:%d\n", \
+ (int)v, i, __FILE__, __LINE__);}) \
+ OP_REG_TO_MEM; \
+ if (PL_top_env->je_prev) \
+ PerlProc_longjmp(PL_top_env->je_buf, (v)); \
+ if ((v) == 2) \
+ PerlProc_exit(STATUS_EXIT); \
+ PerlIO_printf(PerlIO_stderr(), "panic: top_env, v=%d\n", (int)v); \
+ PerlProc_exit(1); \
+ } STMT_END
+
+#define CATCH_GET (PL_top_env->je_mustcatch)
+#define CATCH_SET(v) \
+ STMT_START { \
+ DEBUG_l( \
+ Perl_deb(aTHX_ \
+ "JUMPLEVEL set catch %d => %d (for %p) at %s:%d\n", \
+ PL_top_env->je_mustcatch, v, (void*)PL_top_env, \
+ __FILE__, __LINE__);) \
+ PL_top_env->je_mustcatch = (v); \
+ } STMT_END
+
+/*
+=head1 COP Hint Hashes
+*/
+
+typedef struct refcounted_he COPHH;
+
+#define COPHH_KEY_UTF8 REFCOUNTED_HE_KEY_UTF8
+
+/*
+=for apidoc Amx|SV *|cophh_fetch_pvn|const COPHH *cophh|const char *keypv|STRLEN keylen|U32 hash|U32 flags
+
+Look up the entry in the cop hints hash I<cophh> with the key specified by
+I<keypv> and I<keylen>. If I<flags> has the C<COPHH_KEY_UTF8> bit set,
+the key octets are interpreted as UTF-8, otherwise they are interpreted
+as Latin-1. I<hash> is a precomputed hash of the key string, or zero if
+it has not been precomputed. Returns a mortal scalar copy of the value
+associated with the key, or C<&PL_sv_placeholder> if there is no value
+associated with the key.
+
+=cut
+*/
+
+#define cophh_fetch_pvn(cophh, keypv, keylen, hash, flags) \
+ 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
+
+Like L</cophh_fetch_pvn>, but takes a literal string instead of a
+string/length pair, and no precomputed hash.
+
+=cut
+*/
+
+#define cophh_fetch_pvs(cophh, key, flags) \
+ Perl_refcounted_he_fetch_pvn(aTHX_ cophh, STR_WITH_LEN(key), 0, flags)
+
+/*
+=for apidoc Amx|SV *|cophh_fetch_pv|const COPHH *cophh|const char *key|U32 hash|U32 flags
+
+Like L</cophh_fetch_pvn>, but takes a nul-terminated string instead of
+a string/length pair.
+
+=cut
+*/
+
+#define cophh_fetch_pv(cophh, key, hash, flags) \
+ Perl_refcounted_he_fetch_pv(aTHX_ cophh, key, hash, flags)
+
+/*
+=for apidoc Amx|SV *|cophh_fetch_sv|const COPHH *cophh|SV *key|U32 hash|U32 flags
+
+Like L</cophh_fetch_pvn>, but takes a Perl scalar instead of a
+string/length pair.
+
+=cut
+*/
+
+#define cophh_fetch_sv(cophh, key, hash, flags) \
+ Perl_refcounted_he_fetch_sv(aTHX_ cophh, key, hash, flags)
+
+/*
+=for apidoc Amx|HV *|cophh_2hv|const COPHH *cophh|U32 flags
+
+Generates and returns a standard Perl hash representing the full set of
+key/value pairs in the cop hints hash I<cophh>. I<flags> is currently
+unused and must be zero.
+
+=cut
+*/
+
+#define cophh_2hv(cophh, flags) \
+ Perl_refcounted_he_chain_2hv(aTHX_ cophh, flags)
+
+/*
+=for apidoc Amx|COPHH *|cophh_copy|COPHH *cophh
+
+Make and return a complete copy of the cop hints hash I<cophh>.
+
+=cut
+*/
+
+#define cophh_copy(cophh) Perl_refcounted_he_inc(aTHX_ cophh)
+
+/*
+=for apidoc Amx|void|cophh_free|COPHH *cophh
+
+Discard the cop hints hash I<cophh>, freeing all resources associated
+with it.
+
+=cut
+*/
+
+#define cophh_free(cophh) Perl_refcounted_he_free(aTHX_ cophh)
+
+/*
+=for apidoc Amx|COPHH *|cophh_new_empty
+
+Generate and return a fresh cop hints hash containing no entries.
+
+=cut
+*/
+
+#define cophh_new_empty() ((COPHH *)NULL)
+
+/*
+=for apidoc Amx|COPHH *|cophh_store_pvn|COPHH *cophh|const char *keypv|STRLEN keylen|U32 hash|SV *value|U32 flags
+
+Stores a value, associated with a key, in the cop hints hash I<cophh>,
+and returns the modified hash. The returned hash pointer is in general
+not the same as the hash pointer that was passed in. The input hash is
+consumed by the function, and the pointer to it must not be subsequently
+used. Use L</cophh_copy> if you need both hashes.
+
+The key is specified by I<keypv> and I<keylen>. If I<flags> has the
+C<COPHH_KEY_UTF8> bit set, the key octets are interpreted as UTF-8,
+otherwise they are interpreted as Latin-1. I<hash> is a precomputed
+hash of the key string, or zero if it has not been precomputed.
+
+I<value> is the scalar value to store for this key. I<value> is copied
+by this function, which thus does not take ownership of any reference
+to it, and later changes to the scalar will not be reflected in the
+value visible in the cop hints hash. Complex types of scalar will not
+be stored with referential integrity, but will be coerced to strings.
+
+=cut
+*/
+
+#define cophh_store_pvn(cophh, keypv, keylen, hash, value, flags) \
+ 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
+
+Like L</cophh_store_pvn>, but takes a literal string instead of a
+string/length pair, and no precomputed hash.
+
+=cut
+*/
+
+#define cophh_store_pvs(cophh, key, value, flags) \
+ Perl_refcounted_he_new_pvn(aTHX_ cophh, STR_WITH_LEN(key), 0, value, flags)
+
+/*
+=for apidoc Amx|COPHH *|cophh_store_pv|const COPHH *cophh|const char *key|U32 hash|SV *value|U32 flags
+
+Like L</cophh_store_pvn>, but takes a nul-terminated string instead of
+a string/length pair.
+
+=cut
+*/
+
+#define cophh_store_pv(cophh, key, hash, value, flags) \
+ Perl_refcounted_he_new_pv(aTHX_ cophh, key, hash, value, flags)
+
+/*
+=for apidoc Amx|COPHH *|cophh_store_sv|const COPHH *cophh|SV *key|U32 hash|SV *value|U32 flags
+
+Like L</cophh_store_pvn>, but takes a Perl scalar instead of a
+string/length pair.
+
+=cut
+*/
+
+#define cophh_store_sv(cophh, key, hash, value, flags) \
+ Perl_refcounted_he_new_sv(aTHX_ cophh, key, hash, value, flags)
+
+/*
+=for apidoc Amx|COPHH *|cophh_delete_pvn|COPHH *cophh|const char *keypv|STRLEN keylen|U32 hash|U32 flags
+
+Delete a key and its associated value from the cop hints hash I<cophh>,
+and returns the modified hash. The returned hash pointer is in general
+not the same as the hash pointer that was passed in. The input hash is
+consumed by the function, and the pointer to it must not be subsequently
+used. Use L</cophh_copy> if you need both hashes.
+
+The key is specified by I<keypv> and I<keylen>. If I<flags> has the
+C<COPHH_KEY_UTF8> bit set, the key octets are interpreted as UTF-8,
+otherwise they are interpreted as Latin-1. I<hash> is a precomputed
+hash of the key string, or zero if it has not been precomputed.
+
+=cut
+*/
+
+#define cophh_delete_pvn(cophh, keypv, keylen, hash, flags) \
+ Perl_refcounted_he_new_pvn(aTHX_ cophh, keypv, keylen, hash, \
+ (SV *)NULL, flags)
+
+/*
+=for apidoc Amx|COPHH *|cophh_delete_pvs|const COPHH *cophh|const char *key|U32 flags
+
+Like L</cophh_delete_pvn>, but takes a literal string instead of a
+string/length pair, and no precomputed hash.
+
+=cut
+*/
+
+#define cophh_delete_pvs(cophh, key, flags) \
+ Perl_refcounted_he_new_pvn(aTHX_ cophh, STR_WITH_LEN(key), 0, \
+ (SV *)NULL, flags)
+
+/*
+=for apidoc Amx|COPHH *|cophh_delete_pv|const COPHH *cophh|const char *key|U32 hash|U32 flags
+
+Like L</cophh_delete_pvn>, but takes a nul-terminated string instead of
+a string/length pair.
+
+=cut
+*/
+
+#define cophh_delete_pv(cophh, key, hash, flags) \
+ Perl_refcounted_he_new_pv(aTHX_ cophh, key, hash, (SV *)NULL, flags)
+
+/*
+=for apidoc Amx|COPHH *|cophh_delete_sv|const COPHH *cophh|SV *key|U32 hash|U32 flags
+
+Like L</cophh_delete_pvn>, but takes a Perl scalar instead of a
+string/length pair.
+
+=cut
+*/
+
+#define cophh_delete_sv(cophh, key, hash, flags) \
+ Perl_refcounted_he_new_sv(aTHX_ cophh, key, hash, (SV *)NULL, flags)
+
+#include "mydtrace.h"
+