Upper.xs

   1 /* This file is part of the Scope::Upper Perl module.
   2  * See http://search.cpan.org/dist/Scope-Upper/ */
   3
   4 #define PERL_NO_GET_CONTEXT
   5 #include "EXTERN.h"
   6 #include "perl.h"
   7 #include "XSUB.h"
   8
   9 #ifndef SU_DEBUG
  10 # define SU_DEBUG 0
  11 #endif
  12
  13 #ifndef STMT_START
  14 # define STMT_START do
  15 #endif
  16
  17 #ifndef STMT_END
  18 # define STMT_END while (0)
  19 #endif
  20
  21 #if SU_DEBUG
  22 # define SU_D(X) STMT_START X STMT_END
  23 #else
  24 # define SU_D(X)
  25 #endif
  26
  27 #ifndef SvPV_const
  28 # define SvPV_const(S, L) SvPV(S, L)
  29 #endif
  30
  31 #ifndef SvPV_nolen_const
  32 # define SvPV_nolen_const(S) SvPV_nolen(S)
  33 #endif
  34
  35 #ifndef HvNAME_get
  36 # define HvNAME_get(H) HvNAME(H)
  37 #endif
  38
  39 #ifndef gv_fetchpvn_flags
  40 # define gv_fetchpvn_flags(A, B, C, D) gv_fetchpv((A), (C), (D))
  41 #endif
  42
  43 #define SU_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
  44
  45 typedef struct {
  46  I32 depth;
  47  I32 *origin;
  48  void (*handler)(pTHX_ void *);
  49 } su_ud_common;
  50
  51 #define SU_UD_DEPTH(U)   (((su_ud_common *) (U))->depth)
  52 #define SU_UD_ORIGIN(U)  (((su_ud_common *) (U))->origin)
  53 #define SU_UD_HANDLER(U) (((su_ud_common *) (U))->handler)
  54
  55 #define SU_UD_FREE(U) do { \
  56  if (SU_UD_ORIGIN(U)) Safefree(SU_UD_ORIGIN(U)); \
  57  Safefree(U); \
  58 } while (0)
  59
  60 typedef struct {
  61  su_ud_common ci;
  62  SV *cb;
  63 } su_ud_reap;
  64
  65 STATIC void su_call(pTHX_ void *ud_) {
  66  su_ud_reap *ud = (su_ud_reap *) ud_;
  67 #if SU_HAS_PERL(5, 10, 0)
  68  I32 dieing = PL_op->op_type == OP_DIE;
  69 #endif
  70
  71  dSP;
  72
  73  SU_D(PerlIO_printf(Perl_debug_log, "%p: @@@ call at %d (save is %d)\n",
  74                                      ud, PL_scopestack_ix, PL_savestack_ix));
  75  ENTER;
  76  SAVETMPS;
  77
  78  PUSHMARK(SP);
  79  PUTBACK;
  80
  81  /* If cxstack_ix isn't incremented there, the eval context will be overwritten
  82   * when the new sub scope will be created in call_sv. */
  83
  84 #if SU_HAS_PERL(5, 10, 0)
  85  if (dieing)
  86   if (cxstack_ix < cxstack_max)
  87    ++cxstack_ix;
  88   else
  89    cxstack_ix = Perl_cxinc(aTHX);
  90 #endif
  91
  92  call_sv(ud->cb, G_VOID);
  93
  94 #if SU_HAS_PERL(5, 10, 0)
  95  if (dieing && cxstack_ix > 0)
  96   --cxstack_ix;
  97 #endif
  98
  99  SPAGAIN;
 100  PUTBACK;
 101
 102  FREETMPS;
 103  LEAVE;
 104
 105  SvREFCNT_dec(ud->cb);
 106  SU_UD_FREE(ud);
 107 }
 108
 109 STATIC void su_reap(pTHX_ void *ud) {
 110 #define su_reap(U) su_reap(aTHX_ (U))
 111  SU_D(PerlIO_printf(Perl_debug_log, "%p: === reap at %d (save is %d)\n",
 112                                      ud, PL_scopestack_ix, PL_savestack_ix));
 113  SAVEDESTRUCTOR_X(su_call, ud);
 114  SU_D(PerlIO_printf(Perl_debug_log, "%p: savestack is now at %d, base at %d\n",
 115                                      ud, PL_savestack_ix,
 116                                          PL_scopestack[PL_scopestack_ix]));
 117 }
 118
 119 typedef struct {
 120  su_ud_common ci;
 121  SV *sv;
 122  SV *val;
 123  SV *elem;
 124 } su_ud_localize;
 125
 126 /* Those two functions are courtesy of pp_hot.c:pp_helem */
 127
 128 STATIC I32 su_hv_preeminent(pTHX_ HV *hv, SV *keysv) {
 129 #define su_hv_preeminent(H, K) su_hv_preeminent(aTHX_ (H), (K))
 130  MAGIC *mg;
 131  HV *stash;
 132  return (!SvRMAGICAL(hv)
 133          || mg_find((SV *) hv, PERL_MAGIC_env)
 134          || ((mg = mg_find((SV *) hv, PERL_MAGIC_tied))
 135                    /* Try to preserve the existenceness of a tied hash
 136                     * element by using EXISTS and DELETE if possible.
 137                     * Fallback to FETCH and STORE otherwise */
 138              && (stash = SvSTASH(SvRV(SvTIED_obj((SV *) hv, mg))))
 139              && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
 140              && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
 141             )
 142         ) ? hv_exists_ent(hv, keysv, 0) : 1;
 143 }
 144
 145 STATIC void su_save_helem(pTHX_ HV *hv, SV *keysv, SV **svp, I32 preeminent) {
 146 #define su_save_helem(H, K, S, P) su_save_helem(aTHX_ (H), (K), (S), (P))
 147  if (HvNAME_get(hv) && isGV(*svp)) {
 148   save_gp((GV *) *svp, 0);
 149   return;
 150  }
 151  if (!preeminent) {
 152   STRLEN keylen;
 153   const char * const key = SvPV_const(keysv, keylen);
 154   SAVEDELETE(hv, savepvn(key, keylen),
 155                  SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
 156  } else {
 157   save_helem(hv, keysv, svp);
 158  }
 159 }
 160
 161 STATIC void su_localize(pTHX_ void *ud_) {
 162 #define su_localize(U) su_localize(aTHX_ (U))
 163  su_ud_localize *ud = (su_ud_localize *) ud_;
 164  SV *sv   = ud->sv;
 165  SV *val  = ud->val;
 166  SV *elem = ud->elem;
 167  GV *gv;
 168  UV deref = 0;
 169  svtype t = SVt_NULL;
 170
 171  if (SvTYPE(sv) >= SVt_PVGV) {
 172   gv = (GV *) sv;
 173   if (!SvROK(val))
 174    goto assign;
 175   t = SvTYPE(SvRV(val));
 176   deref = 1;
 177  } else {
 178   STRLEN len, l;
 179   const char *p = SvPV_const(sv, len), *s;
 180   for (s = p, l = len; l > 0 && isSPACE(*s); ++s, --l) { }
 181   if (!l) {
 182    l = len;
 183    s = p;
 184   }
 185   switch (*s) {
 186    case '$': t = SVt_PV;   break;
 187    case '@': t = SVt_PVAV; break;
 188    case '%': t = SVt_PVHV; break;
 189    case '&': t = SVt_PVCV; break;
 190    case '*': t = SVt_PVGV; break;
 191   }
 192   if (t == SVt_NULL) {
 193    if (SvROK(val) && !sv_isobject(val)) {
 194     t = SvTYPE(SvRV(val));
 195     deref = 1;
 196    } else {
 197     t = SvTYPE(val);
 198    }
 199   } else {
 200    ++s;
 201    --l;
 202   }
 203   gv = gv_fetchpvn_flags(s, l, GV_ADDMULTI, SVt_PVGV);
 204  }
 205
 206  SU_D({
 207   SV *z = newSV_type(t);
 208   PerlIO_printf(Perl_debug_log, "%p: === localize a %s at %d (save is %d)\n",
 209                                  ud, sv_reftype(z, 0),
 210                                      PL_scopestack_ix, PL_savestack_ix);
 211   SvREFCNT_dec(z);
 212  });
 213
 214  /* Inspired from Alias.pm */
 215  switch (t) {
 216   case SVt_PVAV:
 217    if (elem) {
 218     I32 idx  = SvIV(elem);
 219     AV *av   = GvAV(gv);
 220     SV **svp = av_fetch(av, idx, 1);
 221     if (!*svp || *svp == &PL_sv_undef) croak(PL_no_aelem, idx);
 222     save_aelem(av, idx, svp);
 223     gv = (GV *) *svp;
 224     goto maybe_deref;
 225    } else
 226     save_ary(gv);
 227    break;
 228   case SVt_PVHV:
 229    if (elem) {
 230     HV *hv   = GvHV(gv);
 231     I32 preeminent = hv ? su_hv_preeminent(hv, elem) : 0;
 232     HE *he   = hv_fetch_ent(hv, elem, 1, 0);
 233     SV **svp = he ? &HeVAL(he) : NULL;
 234     if (!svp || *svp == &PL_sv_undef) croak("Modification of non-creatable hash value attempted, subscript \"%s\"", SvPV_nolen_const(*svp));
 235     su_save_helem(hv, elem, svp, preeminent);
 236     gv = (GV *) *svp;
 237     goto maybe_deref;
 238    } else
 239     save_hash(gv);
 240    break;
 241   case SVt_PVGV:
 242    save_gp(gv, 1); /* hide previous entry in symtab */
 243    break;
 244   case SVt_PVCV:
 245    SAVESPTR(GvCV(gv));
 246    GvCV(gv) = NULL;
 247    break;
 248   default:
 249    gv = (GV *) save_scalar(gv);
 250 maybe_deref:
 251    if (deref)
 252     val = SvRV(val);
 253    break;
 254  }
 255
 256  SU_D(PerlIO_printf(Perl_debug_log, "%p: savestack is now at %d, base at %d\n",
 257                                      ud, PL_savestack_ix,
 258                                          PL_scopestack[PL_scopestack_ix]));
 259
 260 assign:
 261  SvSetMagicSV((SV *) gv, val);
 262
 263  SvREFCNT_dec(ud->elem);
 264  SvREFCNT_dec(ud->val);
 265  SvREFCNT_dec(ud->sv);
 266  SU_UD_FREE(ud);
 267 }
 268
 269 #if SU_DEBUG
 270 # ifdef DEBUGGING
 271 #  define SU_CXNAME PL_block_type[CxTYPE(&cxstack[cxstack_ix])]
 272 # else
 273 #  define SU_CXNAME "XXX"
 274 # endif
 275 #endif
 276
 277 STATIC void su_pop(pTHX_ void *ud) {
 278 #define su_pop(U) su_pop(aTHX_ (U))
 279  I32 depth, base, mark, *origin;
 280  depth = SU_UD_DEPTH(ud);
 281
 282  SU_D(PerlIO_printf(Perl_debug_log, "%p: --- pop %s at %d from %d to %d [%d]\n",
 283                                      ud, SU_CXNAME,
 284                                          PL_scopestack_ix, PL_savestack_ix,
 285                                          PL_scopestack[PL_scopestack_ix],
 286                                          depth));
 287
 288  origin = SU_UD_ORIGIN(ud);
 289  mark   = origin[depth];
 290  base   = origin[depth - 1];
 291
 292  SU_D(PerlIO_printf(Perl_debug_log, "%p: clean from %d down to %d\n",
 293                                      ud, mark, base));
 294
 295  if (base < mark) {
 296   PL_savestack_ix = mark;
 297   leave_scope(base);
 298  }
 299  PL_savestack_ix = base;
 300  if (--depth > 0) {
 301   SU_UD_DEPTH(ud) = depth;
 302   SU_D(PerlIO_printf(Perl_debug_log, "%p: save new destructor at %d [%d]\n",
 303                                       ud, PL_savestack_ix, depth));
 304   SAVEDESTRUCTOR_X(su_pop, ud);
 305   SU_D(PerlIO_printf(Perl_debug_log, "%p: pop end at at %d [%d]\n",
 306                                       ud, PL_savestack_ix, depth));
 307  } else {
 308   SU_UD_HANDLER(ud)(aTHX_ ud);
 309  }
 310 }
 311
 312 STATIC I32 su_init(pTHX_ I32 level, void *ud, I32 size) {
 313 #define su_init(L, U, S) su_init(aTHX_ (L), (U), (S))
 314  I32 i, depth = 0, *origin;
 315  I32 cur, last, step;
 316
 317  SU_D(PerlIO_printf(Perl_debug_log, "%p: ### init for level %d\n", ud, level));
 318
 319  for (i = 0; i < level; ++i) {
 320   PERL_CONTEXT *cx = &cxstack[cxstack_ix - i];
 321   switch (CxTYPE(cx)) {
 322 #if SU_HAS_PERL(5, 11, 0)
 323    case CXt_LOOP_FOR:
 324    case CXt_LOOP_PLAIN:
 325    case CXt_LOOP_LAZYSV:
 326    case CXt_LOOP_LAZYIV:
 327 #else
 328    case CXt_LOOP:
 329 #endif
 330     SU_D(PerlIO_printf(Perl_debug_log, "%p: cx %d is loop\n", ud, i));
 331     depth += 2;
 332     break;
 333    default:
 334     SU_D(PerlIO_printf(Perl_debug_log, "%p: cx %d is normal\n", ud, i));
 335     depth++;
 336     break;
 337   }
 338  }
 339  SU_D(PerlIO_printf(Perl_debug_log, "%p: depth is %d\n", ud, depth));
 340
 341  Newx(origin, depth + 1, I32);
 342  origin[0] = PL_scopestack[PL_scopestack_ix - depth];
 343  PL_scopestack[PL_scopestack_ix - depth] += size;
 344  for (i = depth - 1; i >= 1; --i) {
 345   I32 j = PL_scopestack_ix - i;
 346   origin[depth - i] = PL_scopestack[j];
 347   PL_scopestack[j] += 3;
 348  }
 349  origin[depth] = PL_savestack_ix;
 350
 351  SU_D({
 352   PerlIO_printf(Perl_debug_log, "%p: d=%d s=%d x=%d c=%d o=%d\n", ud,
 353                 depth, 0, PL_scopestack_ix - 1, PL_savestack_ix, origin[depth]);
 354   for (i = depth - 1; i >= 0; --i) {
 355    I32 x = PL_scopestack_ix  - depth + i;
 356    PerlIO_printf(Perl_debug_log, "%p: d=%d s=%d x=%d c=%d o=%d\n", ud,
 357                                   i, depth - i, x, PL_scopestack[x], origin[i]);
 358   }
 359  });
 360
 361  SU_UD_ORIGIN(ud) = origin;
 362  SU_UD_DEPTH(ud)  = depth;
 363  return depth;
 364 }
 365
 366 #define SU_GET_LEVEL(A)  \
 367  if (items > A) {        \
 368   SV *lsv = ST(A);       \
 369   if (SvOK(lsv))         \
 370    level = SvUV(lsv);    \
 371   if (level < 0)         \
 372    XSRETURN(0);          \
 373  }                       \
 374  if (level > cxstack_ix) \
 375   level = cxstack_ix;
 376
 377 /* --- XS ------------------------------------------------------------------ */
 378
 379 MODULE = Scope::Upper            PACKAGE = Scope::Upper
 380
 381 PROTOTYPES: ENABLE
 382
 383 SV *
 384 TOPLEVEL()
 385 PROTOTYPE:
 386 CODE:
 387  RETVAL = newSViv(cxstack_ix);
 388 OUTPUT:
 389  RETVAL
 390
 391 void
 392 reap(SV *hook, ...)
 393 PROTOTYPE: &;$
 394 PREINIT:
 395  I32 level = 0;
 396  su_ud_reap *ud;
 397 CODE:
 398  SU_GET_LEVEL(1);
 399  Newx(ud, 1, su_ud_reap);
 400  SU_UD_ORIGIN(ud)  = NULL;
 401  SU_UD_HANDLER(ud) = su_reap;
 402  ud->cb = newSVsv(hook);
 403  LEAVE;
 404  if (level) {
 405   I32 depth = su_init(level, ud, 3);
 406   SU_D(PerlIO_printf(Perl_debug_log, "%p: set original destructor at %d [%d]\n",
 407                                       ud, PL_savestack_ix, depth));
 408   SAVEDESTRUCTOR_X(su_pop, ud);
 409  } else
 410   su_reap(ud);
 411  ENTER;
 412
 413 void
 414 localize(SV *sv, SV *val, ...)
 415 PROTOTYPE: $$;$
 416 PREINIT:
 417  I32 level = 0;
 418  su_ud_localize *ud;
 419 CODE:
 420  SU_GET_LEVEL(2);
 421  Newx(ud, 1, su_ud_localize);
 422  SU_UD_ORIGIN(ud)  = NULL;
 423  SU_UD_HANDLER(ud) = su_localize;
 424  SvREFCNT_inc(sv);
 425  ud->sv   = sv;
 426  ud->val  = newSVsv(val);
 427  ud->elem = NULL;
 428  LEAVE;
 429  if (level) {
 430   I32 depth = su_init(level, ud, 3);
 431   SU_D(PerlIO_printf(Perl_debug_log, "%p: set original destructor at %d [%d]\n",
 432                                       ud, PL_savestack_ix, depth));
 433   SAVEDESTRUCTOR_X(su_pop, ud);
 434  } else
 435   su_localize(ud);
 436  ENTER;
 437
 438 void
 439 localize_elem(SV *sv, SV *elem, SV *val, ...)
 440 PROTOTYPE: $$$;$
 441 PREINIT:
 442  I32 level = 0;
 443  su_ud_localize *ud;
 444 CODE:
 445  SU_GET_LEVEL(3);
 446  Newx(ud, 1, su_ud_localize);
 447  SU_UD_ORIGIN(ud)  = NULL;
 448  SU_UD_HANDLER(ud) = su_localize;
 449  SvREFCNT_inc(sv);
 450  ud->sv   = sv;
 451  ud->val  = newSVsv(val);
 452  SvREFCNT_inc(elem);
 453  ud->elem = elem;
 454  LEAVE;
 455  if (level) {
 456   I32 depth = su_init(level, ud, 4);
 457   SU_D(PerlIO_printf(Perl_debug_log, "%p: set original destructor at %d [%d]\n",
 458                                       ud, PL_savestack_ix, depth));
 459   SAVEDESTRUCTOR_X(su_pop, ud);
 460  } else
 461   su_localize(ud);
 462  ENTER;
 463