X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=Upper.xs;h=cba5d3d048b81e46ad212c51ae6714df5e89d2e5;hb=b608ef9d319ec77f82c32837676ab68cc2e6b4cc;hp=14923a61b4903b5c1c2885c01ad645e305ca6ead;hpb=da0237ee151a65dff50933a7af535ea0541c2ac2;p=perl%2Fmodules%2FScope-Upper.git

diff --git a/Upper.xs b/Upper.xs
index 14923a6..cba5d3d 100644
--- a/Upper.xs
+++ b/Upper.xs
@@ -137,7 +137,6 @@ STATIC I32 su_av_key2idx(pTHX_ AV *av, I32 key) {
  if (SvRMAGICAL(av)) {
   const MAGIC * const tied_magic = mg_find((SV *) av, PERL_MAGIC_tied);
   if (tied_magic) {
-   int adjust_index = 1;
    SV * const * const negative_indices_glob =
                     hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *) (av), tied_magic))),
                              NEGATIVE_INDICES_VAR, 16, 0);
@@ -248,7 +247,7 @@ STATIC void su_save_helem(pTHX_ HV *hv, SV *keysv, SV *val) {
  if (val) { /* local $x{$keysv} = $val; */
   SvSetMagicSV(*svp, val);
  } else {   /* local $x{$keysv}; delete $x{$keysv}; */
-  hv_delete_ent(hv, keysv, G_DISCARD, HeHASH(he));
+  (void)hv_delete_ent(hv, keysv, G_DISCARD, HeHASH(he));
  }
 }
 
@@ -296,11 +295,12 @@ STATIC void su_call(pTHX_ void *ud_) {
   * when the new sub scope will be created in call_sv. */
 
 #if SU_HAS_PERL(5, 10, 0)
- if (dieing)
+ if (dieing) {
   if (cxstack_ix < cxstack_max)
    ++cxstack_ix;
   else
    cxstack_ix = Perl_cxinc(aTHX);
+ }
 #endif
 
  call_sv(ud->cb, G_VOID);
@@ -421,7 +421,6 @@ STATIC void su_localize(pTHX_ void *ud_) {
    break;
   default:
    gv = (GV *) save_scalar(gv);
-maybe_deref:
    if (deref) /* val != NULL */
     val = SvRV(val);
    break;
@@ -492,7 +491,6 @@ STATIC void su_pop(pTHX_ void *ud) {
 STATIC I32 su_init(pTHX_ I32 cxix, void *ud, I32 size) {
 #define su_init(L, U, S) su_init(aTHX_ (L), (U), (S))
  I32 i, depth = 0, *origin;
- I32 cur, last, step;
 
  LEAVE;
 
@@ -581,6 +579,8 @@ STATIC void su_unwind(pTHX_ void *ud_) {
  SV **savesp = MY_CXT.savesp;
  I32 mark;
 
+ PERL_UNUSED_VAR(ud_);
+
  if (savesp)
   PL_stack_sp = savesp;
 
@@ -629,11 +629,11 @@ STATIC void su_unwind(pTHX_ void *ud_) {
    if (CxTYPE(cx) == CXt_BLOCK && (C) >= i) { \
     --cx;                                     \
     if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.cv == GvCV(PL_DBsub)) { \
-     (C) -= i + 1;                \
-     break;                       \
-    }                             \
-   } else                         \
-    break;                        \
+     (C) -= i + 1;                 \
+     break;                        \
+    }                              \
+   } else                          \
+    break;                         \
   } while (++i <= SU_SKIP_DB_MAX); \
  } STMT_END
 
@@ -647,10 +647,23 @@ STATIC void su_unwind(pTHX_ void *ud_) {
     cxix = 0;                  \
    else if (cxix > cxstack_ix) \
     cxix = cxstack_ix;         \
-  } else                       \
+  } else {                     \
    cxix = cxstack_ix;          \
-  if (PL_DBsub)                \
-   SU_SKIP_DB(cxix);           \
+   if (PL_DBsub)               \
+    SU_SKIP_DB(cxix);          \
+  }                            \
+ } STMT_END
+
+#define SU_GET_LEVEL(A, B) \
+ STMT_START {              \
+  if (items > 0) {         \
+   SV *lsv = ST(B);        \
+   if (SvOK(lsv))          \
+    level = SvIV(lsv);     \
+   if (level < 0)          \
+    level = 0;             \
+  } else                   \
+   level = 0;              \
  } STMT_END
 
 XS(XS_Scope__Upper_unwind); /* prototype to pass -Wmissing-prototypes */
@@ -709,12 +722,15 @@ BOOT:
  newXSproto("Scope::Upper::unwind", XS_Scope__Upper_unwind, file, NULL);
 }
 
+#if SU_THREADSAFE
+
 void
 CLONE(...)
 PROTOTYPE: DISABLE
 CODE:
-#if SU_THREADSAFE
+ PERL_UNUSED_VAR(items);
  MY_CXT_CLONE;
+
 #endif /* SU_THREADSAFE */
 
 SV *
@@ -785,18 +801,36 @@ PPCODE:
  XSRETURN_UNDEF;
 
 void
-CALLER(...)
+SCOPE(...)
 PROTOTYPE: ;$
 PREINIT:
- I32 cxix, caller = 0;
+ I32 cxix, level;
 PPCODE:
- if (items) {
-  SV *csv = ST(0);
-  if (SvOK(csv))
-   caller = SvIV(csv);
-  if (caller < 0)
-   caller = 0;
+ SU_GET_LEVEL(0, 0);
+ cxix = cxstack_ix;
+ if (PL_DBsub) {
+  SU_SKIP_DB(cxix);
+  while (cxix > 0) {
+   if (--level < 0)
+    break;
+   --cxix;
+   SU_SKIP_DB(cxix);
+  }
+ } else {
+  cxix -= level;
+  if (cxix < 0)
+   cxix = 0;
  }
+ ST(0) = sv_2mortal(newSViv(cxix));
+ XSRETURN(1);
+
+void
+CALLER(...)
+PROTOTYPE: ;$
+PREINIT:
+ I32 cxix, level;
+PPCODE:
+ SU_GET_LEVEL(0, 0);
  for (cxix = cxstack_ix; cxix > 0; --cxix) {
   PERL_CONTEXT *cx = cxstack + cxix;
   switch (CxTYPE(cx)) {
@@ -805,8 +839,7 @@ PPCODE:
      continue;
    case CXt_EVAL:
    case CXt_FORMAT:
-    --caller;
-    if (caller < 0)
+    if (--level < 0)
      goto done;
     break;
   }