X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FScope-Upper.git;a=blobdiff_plain;f=Upper.xs;h=27397091936b248267348e9bbe075f900311671f;hp=b1d9a08ef9b9a1ef08163998992b2d11091111f9;hb=3beb96a81eebadf62454ea90eecd4b9dd36bdce5;hpb=1cac52223ba0983d5d4007ab608fe4ea645eb037

diff --git a/Upper.xs b/Upper.xs
index b1d9a08..2739709 100644
--- a/Upper.xs
+++ b/Upper.xs
@@ -80,6 +80,13 @@ STATIC SV *su_newSV_type(pTHX_ svtype t) {
 # define newSV_type(T) su_newSV_type(aTHX_ (T))
 #endif
 
+#ifdef newSVpvn_flags
+# define su_newmortal_pvn(S, L) newSVpvn_flags((S), (L), SVs_TEMP)
+#else
+# define su_newmortal_pvn(S, L) sv_2mortal(newSVpvn((S), (L)))
+#endif
+#define su_newmortal_pvs(S) su_newmortal_pvn((S), sizeof(S)-1)
+
 #ifndef SvPV_const
 # define SvPV_const(S, L) SvPV(S, L)
 #endif
@@ -125,14 +132,55 @@ STATIC SV *su_newSV_type(pTHX_ svtype t) {
 # define CxHASARGS(C) ((C)->blk_sub.hasargs)
 #endif
 
+#ifndef CxGIMME
+# ifdef G_WANT
+#  define CxGIMME(C) ((C)->blk_gimme & G_WANT)
+# else
+#  define CxGIMME(C) ((C)->blk_gimme)
+# endif
+#endif
+
+#ifndef CxOLD_OP_TYPE
+# define CxOLD_OP_TYPE(C) (C)->blk_eval.old_op_type
+#endif
+
+#ifndef OutCopFILE
+# define OutCopFILE(C) CopFILE(C)
+#endif
+
+#ifndef OutCopFILE_len
+# define OutCopFILE_len(C) strlen(OutCopFILE(C))
+#endif
+
+#ifndef CopHINTS_get
+# define CopHINTS_get(C) ((I32) (C)->op_private & HINT_PRIVATE_MASK)
+#endif
+
+#ifndef CopHINTHASH_get
+# define CopHINTHASH_get(C) (C)->cop_hints_hash
+#endif
+
+#ifndef cophh_2hv
+# define COPHH           struct refcounted_he
+# define cophh_2hv(H, F) Perl_refcounted_he_chain_2hv(aTHX_ (H))
+#endif
+
 #ifndef HvNAME_get
 # define HvNAME_get(H) HvNAME(H)
 #endif
 
+#ifndef HvNAMELEN
+# define HvNAMELEN(H) strlen(HvNAME(H))
+#endif
+
 #ifndef gv_fetchpvn_flags
 # define gv_fetchpvn_flags(A, B, C, D) gv_fetchpv((A), (C), (D))
 #endif
 
+#ifndef hv_fetchs
+# define hv_fetchs(H, K, L) hv_fetch((H), (K), sizeof(K)-1, (L))
+#endif
+
 #ifndef OP_GIMME_REVERSE
 STATIC U8 su_op_gimme_reverse(U8 gimme) {
  switch (gimme) {
@@ -149,6 +197,14 @@ STATIC U8 su_op_gimme_reverse(U8 gimme) {
 #define OP_GIMME_REVERSE(G) su_op_gimme_reverse(G)
 #endif
 
+#ifndef OpSIBLING
+# ifdef OP_SIBLING
+#  define OpSIBLING(O) OP_SIBLING(O)
+# else
+#  define OpSIBLING(O) ((O)->op_sibling)
+# endif
+#endif
+
 #ifndef PERL_MAGIC_tied
 # define PERL_MAGIC_tied 'P'
 #endif
@@ -1071,23 +1127,26 @@ STATIC I32 su_init(pTHX_ void *ud, I32 cxix, I32 size) {
 
 STATIC void su_unwind(pTHX_ void *ud_) {
  dMY_CXT;
- I32 cxix    = MY_CXT.unwind_storage.cxix;
- I32 items   = MY_CXT.unwind_storage.items - 1;
- SV **savesp = MY_CXT.unwind_storage.savesp;
+ I32 cxix  = MY_CXT.unwind_storage.cxix;
+ I32 items = MY_CXT.unwind_storage.items;
  I32 mark;
 
  PERL_UNUSED_VAR(ud_);
 
- if (savesp)
-  PL_stack_sp = savesp;
+ PL_stack_sp = MY_CXT.unwind_storage.savesp;
+#if SU_HAS_PERL(5, 19, 4)
+ {
+  I32 i;
+  SV **sp = PL_stack_sp;
+  for (i = -items + 1; i <= 0; ++i)
+   if (!SvTEMP(sp[i]))
+    sv_2mortal(SvREFCNT_inc(sp[i]));
+ }
+#endif
 
  if (cxstack_ix > cxix)
   dounwind(cxix);
 
- /* Hide the level */
- if (items >= 0)
-  PL_stack_sp--;
-
  mark = PL_markstack[cxstack[cxix].blk_oldmarksp];
  *PL_markstack_ptr = PL_stack_sp - PL_stack_base - items;
 
@@ -1125,18 +1184,15 @@ 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 - 1;
- SV **savesp   = MY_CXT.yield_storage.savesp;
+ I32 items     = MY_CXT.yield_storage.items;
  opcode  type  = OP_NULL;
  U8      flags = 0;
  OP     *next;
 
  PERL_UNUSED_VAR(ud_);
 
- if (savesp)
-  PL_stack_sp = savesp;
-
  cx = cxstack + cxix;
  switch (CxTYPE(cx)) {
   case CXt_BLOCK: {
@@ -1253,22 +1309,28 @@ 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;
  }
 
+ PL_stack_sp = MY_CXT.yield_storage.savesp;
+#if SU_HAS_PERL(5, 19, 4)
+ {
+  I32 i;
+  SV **sp = PL_stack_sp;
+  for (i = -items + 1; i <= 0; ++i)
+   if (!SvTEMP(sp[i]))
+    sv_2mortal(SvREFCNT_inc(sp[i]));
+ }
+#endif
+
  if (cxstack_ix > cxix)
   dounwind(cxix);
 
- /* Hide the level */
- if (items >= 0)
-  PL_stack_sp--;
- else
-  items = 0;
-
  /* Copy the arguments passed to yield() where the leave op expects to find
   * them. */
  if (items)
@@ -1347,7 +1409,7 @@ STATIC void su_uplevel_storage_delete(pTHX_ su_uplevel_ud *sud) {
 }
 
 STATIC int su_uplevel_goto_static(const OP *o) {
- for (; o; o = o->op_sibling) {
+ for (; o; o = OpSIBLING(o)) {
   /* goto ops are unops with kids. */
   if (!(o->op_flags & OPf_KIDS))
    continue;
@@ -1475,8 +1537,10 @@ STATIC void su_uplevel_restore(pTHX_ void *sus_) {
   * depth to be 0, or perl would complain about it being "still in use".
   * But we *know* that it cannot be so. */
  if (sud->renamed) {
-  CvDEPTH(sud->renamed)   = 0;
-  CvPADLIST(sud->renamed) = NULL;
+  if (!CvISXSUB(sud->renamed)) {
+   CvDEPTH(sud->renamed)   = 0;
+   CvPADLIST(sud->renamed) = NULL;
+  }
   SvREFCNT_dec(sud->renamed);
  }
 
@@ -1610,6 +1674,9 @@ STATIC CV *su_cv_clone(pTHX_ CV *proto, GV *gv) {
 #endif
 
  CvGV_set(cv, gv);
+#if SU_RELEASE && SU_HAS_PERL_EXACT(5, 21, 4)
+ CvNAMED_off(cv);
+#endif
  CvSTASH_set(cv, CvSTASH(proto));
  /* Commit 4c74a7df, publicized with perl 5.13.3, began to add backrefs to
   * stashes. CvSTASH_set() started to do it as well with commit c68d95645
@@ -1627,13 +1694,13 @@ STATIC CV *su_cv_clone(pTHX_ CV *proto, GV *gv) {
   CvROOT(cv)       = OpREFCNT_inc(CvROOT(proto));
   OP_REFCNT_UNLOCK;
   CvSTART(cv)      = CvSTART(proto);
+  CvPADLIST(cv)    = CvPADLIST(proto);
  }
  CvOUTSIDE(cv)     = CvOUTSIDE(proto);
 #ifdef CVf_WEAKOUTSIDE
  if (!(CvFLAGS(proto) & CVf_WEAKOUTSIDE))
 #endif
   SvREFCNT_inc_simple_void(CvOUTSIDE(cv));
- CvPADLIST(cv)     = CvPADLIST(proto);
 #ifdef CvOUTSIDE_SEQ
  CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
 #endif
@@ -1989,6 +2056,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;
@@ -2036,8 +2106,8 @@ STATIC I32 su_context_normalize_up(pTHX_ I32 cxix) {
      return cxix - 1;
     break;
    case CXt_SUBST:
-    if (cx->blk_oldcop && cx->blk_oldcop->op_sibling
-                       && cx->blk_oldcop->op_sibling->op_type == OP_SUBST)
+    if (cx->blk_oldcop && OpSIBLING(cx->blk_oldcop)
+                       && OpSIBLING(cx->blk_oldcop)->op_type == OP_SUBST)
      return cxix - 1;
     break;
   }
@@ -2072,8 +2142,8 @@ STATIC I32 su_context_normalize_down(pTHX_ I32 cxix) {
      return cxix + 1;
     break;
    case CXt_SUBST:
-    if (next->blk_oldcop && next->blk_oldcop->op_sibling
-                         && next->blk_oldcop->op_sibling->op_type == OP_SUBST)
+    if (next->blk_oldcop && OpSIBLING(next->blk_oldcop)
+                         && OpSIBLING(next->blk_oldcop)->op_type == OP_SUBST)
      return cxix + 1;
     break;
   }
@@ -2084,6 +2154,48 @@ STATIC I32 su_context_normalize_down(pTHX_ I32 cxix) {
 
 #define su_context_here() su_context_normalize_up(su_context_skip_db(cxstack_ix))
 
+STATIC I32 su_context_gimme(pTHX_ I32 cxix) {
+#define su_context_gimme(C) su_context_gimme(aTHX_ (C))
+ I32 i;
+
+ for (i = cxix; i >= 0; --i) {
+  PERL_CONTEXT *cx = cxstack + i;
+
+  switch (CxTYPE(cx)) {
+   /* gimme is always G_ARRAY for loop contexts. */
+#if SU_HAS_PERL(5, 11, 0)
+   case CXt_LOOP_FOR:
+   case CXt_LOOP_PLAIN:
+   case CXt_LOOP_LAZYSV:
+   case CXt_LOOP_LAZYIV:
+#else
+   case CXt_LOOP:
+#endif
+   case CXt_SUBST: {
+    const COP *cop = cx->blk_oldcop;
+    if (cop && OpSIBLING(cop)) {
+     switch (OpSIBLING(cop)->op_flags & OPf_WANT) {
+      case OPf_WANT_VOID:
+       return G_VOID;
+      case OPf_WANT_SCALAR:
+       return G_SCALAR;
+      case OPf_WANT_LIST:
+       return G_ARRAY;
+      default:
+       break;
+     }
+    }
+    break;
+   }
+   default:
+    return CxGIMME(cx);
+    break;
+  }
+ }
+
+ return G_VOID;
+}
+
 /* --- Interpreter setup/teardown ------------------------------------------ */
 
 STATIC void su_teardown(pTHX_ void *param) {
@@ -2180,6 +2292,12 @@ default_cx:                     \
   }                        \
  } STMT_END
 
+#if SU_HAS_PERL(5, 10, 0)
+# define SU_INFO_COUNT 11
+#else
+# define SU_INFO_COUNT 10
+#endif
+
 XS(XS_Scope__Upper_unwind); /* prototype to pass -Wmissing-prototypes */
 
 XS(XS_Scope__Upper_unwind) {
@@ -2203,17 +2321,18 @@ XS(XS_Scope__Upper_unwind) {
      continue;
    case CXt_EVAL:
    case CXt_FORMAT:
-    MY_CXT.unwind_storage.cxix  = cxix;
-    MY_CXT.unwind_storage.items = items;
+    MY_CXT.unwind_storage.cxix   = cxix;
+    MY_CXT.unwind_storage.items  = items;
+    MY_CXT.unwind_storage.savesp = PL_stack_sp;
+    if (items > 0) {
+     MY_CXT.unwind_storage.items--;
+     MY_CXT.unwind_storage.savesp--;
+    }
     /* pp_entersub will want to sanitize the stack after returning from there
-     * Screw that, we're insane */
-    if (GIMME_V == G_SCALAR) {
-     MY_CXT.unwind_storage.savesp = PL_stack_sp;
-     /* dXSARGS calls POPMARK, so we need to match PL_markstack_ptr[1] */
+     * Screw that, we're insane!
+     * dXSARGS calls POPMARK, so we need to match PL_markstack_ptr[1] */
+    if (GIMME_V == G_SCALAR)
      PL_stack_sp = PL_stack_base + PL_markstack_ptr[1] + 1;
-    } else {
-     MY_CXT.unwind_storage.savesp = NULL;
-    }
     SAVEDESTRUCTOR_X(su_unwind, NULL);
     return;
    default:
@@ -2223,6 +2342,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) {
@@ -2238,16 +2359,42 @@ XS(XS_Scope__Upper_yield) {
  PERL_UNUSED_VAR(ax); /* -Wall */
 
  SU_GET_CONTEXT(0, items - 1, su_context_here());
- MY_CXT.yield_storage.cxix  = cxix;
- MY_CXT.yield_storage.items = items;
+ MY_CXT.yield_storage.cxix   = cxix;
+ MY_CXT.yield_storage.items  = items;
+ MY_CXT.yield_storage.savesp = PL_stack_sp;
+ if (items > 0) {
+  MY_CXT.yield_storage.items--;
+  MY_CXT.yield_storage.savesp--;
+ }
  /* See XS_Scope__Upper_unwind */
- if (GIMME_V == G_SCALAR) {
-  MY_CXT.yield_storage.savesp = PL_stack_sp;
+ if (GIMME_V == G_SCALAR)
   PL_stack_sp = PL_stack_base + PL_markstack_ptr[1] + 1;
- } else {
-  MY_CXT.yield_storage.savesp = NULL;
- }
- 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;
+
+ 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;
 }
 
@@ -2270,6 +2417,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();
 }
@@ -2441,6 +2589,160 @@ PPCODE:
  }
  XSRETURN_UNDEF;
 
+void
+context_info(...)
+PROTOTYPE: ;$
+PREINIT:
+ I32 cxix;
+ const PERL_CONTEXT *cx, *dbcx;
+ COP *cop;
+PPCODE:
+ SU_GET_CONTEXT(0, 0, su_context_skip_db(cxstack_ix));
+ cxix = su_context_normalize_up(cxix);
+ cx   = cxstack + cxix;
+ dbcx = cx;
+ if (PL_DBsub && cxix && (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)) {
+  I32 i = su_context_skip_db(cxix - 1) + 1;
+  if (i < cxix && CxTYPE(cxstack + i) == CXt_SUB)
+   cx = cxstack + i;
+ }
+ cop  = cx->blk_oldcop;
+ EXTEND(SP, SU_INFO_COUNT);
+ /* stash (0) */
+ {
+  HV *stash = CopSTASH(cop);
+  if (stash)
+   PUSHs(su_newmortal_pvn(HvNAME(stash), HvNAMELEN(stash)));
+  else
+   PUSHs(&PL_sv_undef);
+ }
+ /* file (1) */
+ PUSHs(su_newmortal_pvn(OutCopFILE(cop), OutCopFILE_len(cop)));
+ /* line (2) */
+ mPUSHi(CopLINE(cop));
+ /* subroutine (3) and has_args (4) */
+ switch (CxTYPE(cx)) {
+  case CXt_SUB:
+  case CXt_FORMAT: {
+   GV *cvgv = CvGV(dbcx->blk_sub.cv);
+   if (cvgv && isGV(cvgv)) {
+    SV *sv = sv_newmortal();
+    gv_efullname3(sv, cvgv, NULL);
+    PUSHs(sv);
+   } else {
+    PUSHs(su_newmortal_pvs("(unknown)"));
+   }
+   if (CxHASARGS(cx))
+    PUSHs(&PL_sv_yes);
+   else
+    PUSHs(&PL_sv_no);
+   break;
+  }
+  case CXt_EVAL:
+   PUSHs(su_newmortal_pvs("(eval)"));
+   mPUSHi(0);
+   break;
+  default:
+   PUSHs(&PL_sv_undef);
+   PUSHs(&PL_sv_undef);
+ }
+ /* gimme (5) */
+ switch (su_context_gimme(cxix)) {
+  case G_ARRAY:
+   PUSHs(&PL_sv_yes);
+   break;
+  case G_SCALAR:
+   PUSHs(&PL_sv_no);
+   break;
+  default: /* G_VOID */
+   PUSHs(&PL_sv_undef);
+   break;
+ }
+ /* eval text (6) and is_require (7) */
+ switch (CxTYPE(cx)) {
+  case CXt_EVAL:
+   if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
+    /* eval STRING */
+#if SU_HAS_PERL(5, 17, 4)
+    PUSHs(newSVpvn_flags(SvPVX(cx->blk_eval.cur_text),
+                         SvCUR(cx->blk_eval.cur_text)-2,
+                         SvUTF8(cx->blk_eval.cur_text)|SVs_TEMP));
+#else
+    PUSHs(cx->blk_eval.cur_text);
+#endif
+    PUSHs(&PL_sv_no);
+    break;
+   } else if (cx->blk_eval.old_namesv) {
+    /* require */
+    PUSHs(sv_mortalcopy(cx->blk_eval.old_namesv));
+    PUSHs(&PL_sv_yes);
+    break;
+   }
+   /* FALLTHROUGH */
+  default:
+   /* Anything else including eval BLOCK */
+   PUSHs(&PL_sv_undef);
+   PUSHs(&PL_sv_undef);
+   break;
+ }
+ /* hints (8) */
+ mPUSHi(CopHINTS_get(cop));
+ /* warnings (9) */
+ {
+  SV *mask = NULL;
+#if SU_HAS_PERL(5, 9, 4)
+  STRLEN *old_warnings = cop->cop_warnings;
+#else
+  SV *old_warnings = cop->cop_warnings;
+#endif
+  if (old_warnings == pWARN_STD) {
+   if (PL_dowarn & G_WARN_ON)
+    goto context_info_warnings_on;
+   else
+#if SU_HAS_PERL(5, 17, 4)
+    mask = &PL_sv_undef;
+#else
+    goto context_info_warnings_off;
+#endif
+  } else if (old_warnings == pWARN_NONE) {
+context_info_warnings_off:
+   mask = su_newmortal_pvn(WARN_NONEstring, WARNsize);
+  } else if (old_warnings == pWARN_ALL) {
+   HV *bits;
+context_info_warnings_on:
+#if SU_HAS_PERL(5, 8, 7)
+   bits = get_hv("warnings::Bits", 0);
+   if (bits) {
+    SV **bits_all = hv_fetchs(bits, "all", FALSE);
+    if (bits_all)
+     mask = sv_mortalcopy(*bits_all);
+   }
+#endif
+   if (!mask)
+    mask = su_newmortal_pvn(WARN_ALLstring, WARNsize);
+  } else {
+#if SU_HAS_PERL(5, 9, 4)
+   mask = su_newmortal_pvn((char *) (old_warnings + 1), old_warnings[0]);
+#else
+   mask = sv_mortalcopy(old_warnings);
+#endif
+  }
+  PUSHs(mask);
+ }
+#if SU_HAS_PERL(5, 10, 0)
+ /* hints hash (10) */
+ {
+  COPHH *hints_hash = CopHINTHASH_get(cop);
+  if (hints_hash) {
+   SV *rhv = sv_2mortal(newRV_noinc((SV *) cophh_2hv(hints_hash, 0)));
+   PUSHs(rhv);
+  } else {
+   PUSHs(&PL_sv_undef);
+  }
+ }
+#endif
+ XSRETURN(SU_INFO_COUNT);
+
 void
 reap(SV *hook, ...)
 PROTOTYPE: &;$