Fix debugger compatibility with perl 5.17.1 and above

[perl/modules/Scope-Upper.git] / Upper.xs

diff --git a/Upper.xs b/Upper.xs
index 0d51f43925ba86c1823e3e3d447d508ab538a05f..3de19a9b6e5c04726e706fd1eda47d405c9a15a3 100644 (file)
--- a/Upper.xs
+++ b/Upper.xs
@@ -1119,6 +1119,7 @@ STATIC void su_unwind(pTHX_ void *ud_) {
 STATIC void su_yield(pTHX_ void *ud_) {
  dMY_CXT;
  PERL_CONTEXT *cx;
+ const char   *which = ud_;
  I32 cxix      = MY_CXT.yield_storage.cxix;
  I32 items     = MY_CXT.yield_storage.items;
  opcode  type  = OP_NULL;
@@ -1243,10 +1244,11 @@ cxt_when:
    break;
 #endif
   case CXt_SUBST:
-   croak("yield() cannot target a substitution context");
+   croak("%s() can't target a substitution context", which);
    break;
   default:
-   croak("yield() don't know how to leave a %s context", SU_CXNAME(cxstack + cxix));
+   croak("%s() doesn't know how to leave a %s context",
+          which,                         SU_CXNAME(cxstack + cxix));
    break;
  }
 
@@ -1975,6 +1977,9 @@ STATIC I32 su_context_skip_db(pTHX_ I32 cxix) {
   PERL_CONTEXT *cx = cxstack + i;
 
   switch (CxTYPE(cx)) {
+#if SU_HAS_PERL(5, 17, 1)
+   case CXt_LOOP_PLAIN:
+#endif
    case CXt_BLOCK:
     if (cx->blk_oldcop && CopSTASH(cx->blk_oldcop) == GvSTASH(PL_DBgv))
      continue;
@@ -2210,6 +2215,8 @@ XS(XS_Scope__Upper_unwind) {
  croak("Can't return outside a subroutine");
 }
 
+STATIC const char su_yield_name[] = "yield";
+
 XS(XS_Scope__Upper_yield); /* prototype to pass -Wmissing-prototypes */
 
 XS(XS_Scope__Upper_yield) {
@@ -2235,7 +2242,33 @@ XS(XS_Scope__Upper_yield) {
  /* See XS_Scope__Upper_unwind */
  if (GIMME_V == G_SCALAR)
   PL_stack_sp = PL_stack_base + PL_markstack_ptr[1] + 1;
- SAVEDESTRUCTOR_X(su_yield, NULL);
+ SAVEDESTRUCTOR_X(su_yield, su_yield_name);
+ return;
+}
+
+STATIC const char su_leave_name[] = "leave";
+
+XS(XS_Scope__Upper_leave); /* prototype to pass -Wmissing-prototypes */
+
+XS(XS_Scope__Upper_leave) {
+#ifdef dVAR
+ dVAR; dXSARGS;
+#else
+ dXSARGS;
+#endif
+ dMY_CXT;
+ I32 cxix;
+
+ PERL_UNUSED_VAR(cv); /* -W */
+ PERL_UNUSED_VAR(ax); /* -Wall */
+
+ MY_CXT.yield_storage.cxix   = su_context_here();
+ MY_CXT.yield_storage.items  = items;
+ MY_CXT.yield_storage.savesp = PL_stack_sp;
+ /* See XS_Scope__Upper_unwind */
+ if (GIMME_V == G_SCALAR)
+  PL_stack_sp = PL_stack_base + PL_markstack_ptr[1] + 1;
+ SAVEDESTRUCTOR_X(su_yield, su_leave_name);
  return;
 }
 
@@ -2258,6 +2291,7 @@ BOOT:
 
  newXSproto("Scope::Upper::unwind", XS_Scope__Upper_unwind, file, NULL);
  newXSproto("Scope::Upper::yield",  XS_Scope__Upper_yield,  file, NULL);
+ newXSproto("Scope::Upper::leave",  XS_Scope__Upper_leave,  file, NULL);
 
  su_setup();
 }