X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=Magic.xs;h=9da0b256a39cfdd5f42b20b1fb7301440f2290e5;hb=705dd25f6bac4f48abb98f534cc33e5f918b9faa;hp=003f52ef84d7df4c91f6a9d0a3cdcba776708cf5;hpb=700dd2952631bcc41697ee3d10e01ed088f01c45;p=perl%2Fmodules%2FVariable-Magic.git

diff --git a/Magic.xs b/Magic.xs
index 003f52e..9da0b25 100644
--- a/Magic.xs
+++ b/Magic.xs
@@ -104,10 +104,6 @@ STATIC SV *vmg_clone(pTHX_ SV *sv, tTHX owner) {
 # define mPUSHu(U) PUSHs(sv_2mortal(newSVuv(U)))
 #endif
 
-#ifndef SvPV_const
-# define SvPV_const SvPV
-#endif
-
 #ifndef PERL_MAGIC_ext
 # define PERL_MAGIC_ext '~'
 #endif
@@ -335,8 +331,8 @@ STATIC const char vmg_argstorefailed[] = "Error while storing arguments";
 typedef struct {
  MGVTBL *vtbl;
 
- U8 uvar;
  U8 opinfo;
+ U8 uvar;
 
  SV *cb_data;
  SV *cb_get, *cb_set, *cb_len, *cb_clear, *cb_free;
@@ -394,8 +390,7 @@ STATIC void vmg_mgwiz_free(pTHX_ MGWIZ *w) {
 #if VMG_THREADSAFE
 
 #define VMG_CLONE_CB(N) \
- z->cb_ ## N = (w->cb_ ## N) ? newRV_noinc(vmg_clone(SvRV(w->cb_ ## N), \
-                                           w->owner))                   \
+ z->cb_ ## N = (w->cb_ ## N) ? vmg_clone(w->cb_ ## N, w->owner) \
                              : NULL;
 
 STATIC MGWIZ *vmg_mgwiz_clone(pTHX_ const MGWIZ *w) {
@@ -490,22 +485,6 @@ STATIC void vmg_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) {
   ptable_store(ud->wizards, ent->key, w);
 }
 
-STATIC void vmg_thread_cleanup(pTHX_ void *);
-
-STATIC void vmg_thread_cleanup(pTHX_ void *ud) {
- int *level = ud;
-
- if (*level) {
-  --*level;
-  LEAVE;
-  SAVEDESTRUCTOR_X(vmg_thread_cleanup, level);
-  ENTER;
- } else {
-  dMY_CXT;
-  PerlMemShared_free(level);
-  ptable_free(MY_CXT.wizards);
- }
-}
 #endif /* VMG_THREADSAFE */
 
 /* --- Wizard objects ------------------------------------------------------ */
@@ -553,6 +532,8 @@ STATIC const SV *vmg_wizard_validate(pTHX_ const SV *wiz) {
  }
 
  croak(vmg_invalid_wiz);
+ /* Not reached */
+ return NULL;
 }
 
 #define vmg_wizard_id(W)         SvIVX((const SV *) (W))
@@ -606,7 +587,7 @@ STATIC const MGWIZ *vmg_wizard_mgwiz(pTHX_ const SV *wiz) {
 
 STATIC const MAGIC *vmg_find(const SV *sv, const SV *wiz) {
  const MAGIC *mg, *moremagic;
- UV wid;
+ IV wid;
 
  if (SvTYPE(sv) < SVt_PVMG)
   return NULL;
@@ -615,7 +596,7 @@ STATIC const MAGIC *vmg_find(const SV *sv, const SV *wiz) {
  for (mg = SvMAGIC(sv); mg; mg = moremagic) {
   moremagic = mg->mg_moremagic;
   if (mg->mg_type == PERL_MAGIC_ext && mg->mg_private == SIG_WIZ) {
-   UV zid = vmg_wizard_id(mg->mg_ptr);
+   IV zid = vmg_wizard_id(mg->mg_ptr);
    if (zid == wid)
     return mg;
   }
@@ -626,10 +607,10 @@ STATIC const MAGIC *vmg_find(const SV *sv, const SV *wiz) {
 
 /* ... Construct private data .............................................. */
 
-STATIC SV *vmg_data_new(pTHX_ SV *ctor, SV *sv, AV *args) {
-#define vmg_data_new(C, S, A) vmg_data_new(aTHX_ (C), (S), (A))
+STATIC SV *vmg_data_new(pTHX_ SV *ctor, SV *sv, SV **args, I32 items) {
+#define vmg_data_new(C, S, A, I) vmg_data_new(aTHX_ (C), (S), (A), (I))
+ I32 i;
  SV *nsv;
- I32 i, alen = (args == NULL) ? 0 : av_len(args);
 
  dSP;
 
@@ -637,10 +618,10 @@ STATIC SV *vmg_data_new(pTHX_ SV *ctor, SV *sv, AV *args) {
  SAVETMPS;
 
  PUSHMARK(SP);
- EXTEND(SP, alen + 1);
+ EXTEND(SP, items + 1);
  PUSHs(sv_2mortal(newRV_inc(sv)));
- for (i = 0; i < alen; ++i)
-  PUSHs(*av_fetch(args, i, 0));
+ for (i = 0; i < items; ++i)
+  PUSHs(args[i]);
  PUTBACK;
 
  call_sv(ctor, G_SCALAR);
@@ -683,8 +664,8 @@ STATIC void vmg_uvar_del(SV *sv, MAGIC *prevmagic, MAGIC *mg, MAGIC *moremagic)
 }
 #endif /* VMG_UVAR */
 
-STATIC UV vmg_cast(pTHX_ SV *sv, const SV *wiz, AV *args) {
-#define vmg_cast(S, W, A) vmg_cast(aTHX_ (S), (W), (A))
+STATIC UV vmg_cast(pTHX_ SV *sv, const SV *wiz, SV **args, I32 items) {
+#define vmg_cast(S, W, A, I) vmg_cast(aTHX_ (S), (W), (A), (I))
  MAGIC       *mg, *moremagic = NULL;
  SV          *data;
  const MGWIZ *w;
@@ -696,8 +677,9 @@ STATIC UV vmg_cast(pTHX_ SV *sv, const SV *wiz, AV *args) {
  w = vmg_wizard_mgwiz(wiz);
  oldgmg = SvGMAGICAL(sv);
 
- data = (w->cb_data) ? vmg_data_new(w->cb_data, sv, args) : NULL;
+ data = (w->cb_data) ? vmg_data_new(w->cb_data, sv, args, items) : NULL;
  mg = sv_magicext(sv, data, PERL_MAGIC_ext, w->vtbl, (const char *) wiz, HEf_SVKEY);
+ SvREFCNT_dec(data);
  mg->mg_private = SIG_WIZ;
 #if MGf_COPY
  if (w->cb_copy)
@@ -771,7 +753,7 @@ STATIC UV vmg_dispell(pTHX_ SV *sv, const SV *wiz) {
  U32 uvars = 0;
 #endif /* VMG_UVAR */
  MAGIC *mg, *prevmagic, *moremagic = NULL;
- UV wid = vmg_wizard_id(wiz);
+ IV wid = vmg_wizard_id(wiz);
 
  if (SvTYPE(sv) < SVt_PVMG)
   return 0;
@@ -780,7 +762,7 @@ STATIC UV vmg_dispell(pTHX_ SV *sv, const SV *wiz) {
   moremagic = mg->mg_moremagic;
   if (mg->mg_type == PERL_MAGIC_ext && mg->mg_private == SIG_WIZ) {
    const MGWIZ *z   = vmg_wizard_mgwiz(mg->mg_ptr);
-   UV           zid = vmg_wizard_id(mg->mg_ptr);
+   IV           zid = vmg_wizard_id(mg->mg_ptr);
    if (zid == wid) {
 #if VMG_UVAR
     /* If the current has no uvar, short-circuit uvar deletion. */
@@ -887,7 +869,7 @@ STATIC void vmg_op_info_init(pTHX_ unsigned int opinfo) {
    if (!MY_CXT.b__op_stashes[0]) {
     opclass c;
     require_pv("B.pm");
-    for (c = 0; c < OPc_MAX; ++c)
+    for (c = OPc_NULL; c < OPc_MAX; ++c)
      MY_CXT.b__op_stashes[c] = gv_stashpv(vmg_opclassnames[c], 1);
    }
    break;
@@ -921,23 +903,15 @@ STATIC SV *vmg_op_info(pTHX_ unsigned int opinfo) {
 
 /* ... svt callbacks ....................................................... */
 
-#define VMG_CB_CALL_SET_RET(D) \
- {            \
-  SV *svr;    \
-  SPAGAIN;    \
-  svr = POPs; \
-  ret = SvOK(svr) ? SvIV(svr) : (D); \
-  PUTBACK;    \
- }
-
 #define VMG_CB_CALL_ARGS_MASK  15
 #define VMG_CB_CALL_ARGS_SHIFT 4
 #define VMG_CB_CALL_OPINFO     (VMG_OP_INFO_NAME|VMG_OP_INFO_OBJECT)
 
 STATIC int vmg_cb_call(pTHX_ SV *cb, unsigned int flags, SV *sv, ...) {
  va_list ap;
- int ret;
+ int ret = 0;
  unsigned int i, args, opinfo;
+ SV *svr;
 
  dSP;
 
@@ -963,7 +937,11 @@ STATIC int vmg_cb_call(pTHX_ SV *cb, unsigned int flags, SV *sv, ...) {
 
  call_sv(cb, G_SCALAR);
 
- VMG_CB_CALL_SET_RET(0);
+ SPAGAIN;
+ svr = POPs;
+ if (SvOK(svr))
+  ret = (int) SvIV(svr);
+ PUTBACK;
 
  FREETMPS;
  LEAVE;
@@ -971,12 +949,15 @@ STATIC int vmg_cb_call(pTHX_ SV *cb, unsigned int flags, SV *sv, ...) {
  return ret;
 }
 
-#define vmg_cb_call1(I, F, S, A1) \
-        vmg_cb_call(aTHX_ (I), (((F) << VMG_CB_CALL_ARGS_SHIFT) | 1), (S), (A1))
-#define vmg_cb_call2(I, F, S, A1, A2) \
-        vmg_cb_call(aTHX_ (I), (((F) << VMG_CB_CALL_ARGS_SHIFT) | 2), (S), (A1), (A2))
-#define vmg_cb_call3(I, F, S, A1, A2, A3) \
-        vmg_cb_call(aTHX_ (I), (((F) << VMG_CB_CALL_ARGS_SHIFT) | 3), (S), (A1), (A2), (A3))
+#define VMG_CB_FLAGS(OI, A) \
+        ((((unsigned int) (OI)) << VMG_CB_CALL_ARGS_SHIFT) | (A))
+
+#define vmg_cb_call1(I, OI, S, A1) \
+        vmg_cb_call(aTHX_ (I), VMG_CB_FLAGS((OI), 1), (S), (A1))
+#define vmg_cb_call2(I, OI, S, A1, A2) \
+        vmg_cb_call(aTHX_ (I), VMG_CB_FLAGS((OI), 2), (S), (A1), (A2))
+#define vmg_cb_call3(I, OI, S, A1, A2, A3) \
+        vmg_cb_call(aTHX_ (I), VMG_CB_FLAGS((OI), 3), (S), (A1), (A2), (A3))
 
 STATIC int vmg_svt_get(pTHX_ SV *sv, MAGIC *mg) {
  const MGWIZ *w = vmg_wizard_mgwiz(mg->mg_ptr);
@@ -992,6 +973,7 @@ STATIC U32 vmg_svt_len(pTHX_ SV *sv, MAGIC *mg) {
  const MGWIZ *w = vmg_wizard_mgwiz(mg->mg_ptr);
  unsigned int opinfo = w->opinfo;
  U32 len, ret;
+ SV *svr;
  svtype t = SvTYPE(sv);
 
  dSP;
@@ -1005,7 +987,11 @@ STATIC U32 vmg_svt_len(pTHX_ SV *sv, MAGIC *mg) {
  PUSHs(mg->mg_obj ? mg->mg_obj : &PL_sv_undef);
  if (t < SVt_PVAV) {
   STRLEN l;
-  const U8 *s = (const U8 *) SvPV_const(sv, l);
+#if VMG_HAS_PERL(5, 9, 2)
+  const U8 *s = SvPV_const(sv, l);
+#else
+  U8 *s = SvPV(sv, l);
+#endif
   if (DO_UTF8(sv))
    len = utf8_length(s, s + l);
   else
@@ -1024,12 +1010,17 @@ STATIC U32 vmg_svt_len(pTHX_ SV *sv, MAGIC *mg) {
 
  call_sv(w->cb_len, G_SCALAR);
 
- VMG_CB_CALL_SET_RET(len);
+ SPAGAIN;
+ svr = POPs;
+ ret = SvOK(svr) ? (U32) SvUV(svr) : len;
+ if (t == SVt_PVAV)
+   --ret;
+ PUTBACK;
 
  FREETMPS;
  LEAVE;
 
- return t == SVt_PVAV ? ret - 1 : ret;
+ return ret;
 }
 
 STATIC int vmg_svt_clear(pTHX_ SV *sv, MAGIC *mg) {
@@ -1043,8 +1034,9 @@ STATIC int vmg_svt_free(pTHX_ SV *sv, MAGIC *mg) {
  PERL_CONTEXT saved_cx;
  I32 cxix;
 #endif
- unsigned int had_err, has_err, flags = G_SCALAR | G_EVAL;
+ I32 had_err, has_err, flags = G_SCALAR | G_EVAL;
  int ret = 0;
+ SV *svr;
 
  dSP;
 
@@ -1101,7 +1093,11 @@ STATIC int vmg_svt_free(pTHX_ SV *sv, MAGIC *mg) {
  if (IN_PERL_COMPILETIME && !had_err && has_err)
   ++PL_error_count;
 
- VMG_CB_CALL_SET_RET(0);
+ SPAGAIN;
+ svr = POPs;
+ if (SvOK(svr))
+  ret = (int) SvIV(svr);
+ PUTBACK;
 
  FREETMPS;
  LEAVE;
@@ -1248,18 +1244,29 @@ STATIC I32 vmg_svt_val(pTHX_ IV action, SV *sv) {
 
 #define VMG_SET_CB(S, N)              \
  cb = (S);                            \
- w->cb_ ## N = (SvOK(cb) && SvROK(cb)) ? newRV_inc(SvRV(cb)) : NULL;
+ w->cb_ ## N = (SvOK(cb) && SvROK(cb)) ? SvREFCNT_inc(SvRV(cb)) : NULL;
 
 #define VMG_SET_SVT_CB(S, N)          \
  cb = (S);                            \
  if (SvOK(cb) && SvROK(cb)) {         \
   t->svt_ ## N = vmg_svt_ ## N;       \
-  w->cb_  ## N = newRV_inc(SvRV(cb)); \
+  w->cb_  ## N = SvREFCNT_inc(SvRV(cb)); \
  } else {                             \
   t->svt_ ## N = NULL;                \
   w->cb_  ## N = NULL;                \
  }
 
+#if VMG_THREADSAFE
+
+STATIC void vmg_cleanup(pTHX_ void *ud) {
+ dMY_CXT;
+
+ ptable_free(MY_CXT.wizards);
+ MY_CXT.wizards = NULL;
+}
+
+#endif /* VMG_THREADSAFE */
+
 /* --- XS ------------------------------------------------------------------ */
 
 MODULE = Variable::Magic            PACKAGE = Variable::Magic
@@ -1278,6 +1285,7 @@ BOOT:
  MY_CXT.b__op_stashes[0] = NULL;
 #if VMG_THREADSAFE
  MUTEX_INIT(&vmg_op_name_init_mutex);
+ call_atexit(vmg_cleanup, NULL);
 #endif
 
  stash = gv_stashpv(__PACKAGE__, 1);
@@ -1320,7 +1328,7 @@ PPCODE:
   ud.owner   = MY_CXT.owner;
   ptable_walk(MY_CXT.wizards, vmg_ptable_clone, &ud);
 
-  for (c = 0; c < OPc_MAX; ++c) {
+  for (c = OPc_NULL; c < OPc_MAX; ++c) {
    if (MY_CXT.b__op_stashes[c])
     had_b__op_stash |= (((U32) 1) << c);
   }
@@ -1329,19 +1337,11 @@ PPCODE:
   MY_CXT_CLONE;
   MY_CXT.wizards = t;
   MY_CXT.owner   = aTHX;
-  for (c = 0; c < OPc_MAX; ++c) {
+  for (c = OPc_NULL; c < OPc_MAX; ++c) {
    MY_CXT.b__op_stashes[c] = (had_b__op_stash & (((U32) 1) << c))
                               ? gv_stashpv(vmg_opclassnames[c], 1) : NULL;
   }
  }
- {
-  int *level;
-  level = PerlMemShared_malloc(sizeof *level);
-  *level = 1;
-  LEAVE;
-  SAVEDESTRUCTOR_X(vmg_thread_cleanup, level);
-  ENTER;
- }
  XSRETURN(0);
 
 #endif /* VMG_THREADSAFE */
@@ -1350,6 +1350,7 @@ SV *_wizard(...)
 PROTOTYPE: DISABLE
 PREINIT:
  I32 i = 0;
+ UV opinfo;
  MGWIZ *w;
  MGVTBL *t;
  SV *cb;
@@ -1375,10 +1376,13 @@ CODE:
  Newx(w, 1, MGWIZ);
 
  VMG_SET_CB(ST(i++), data);
+
  cb = ST(i++);
- w->opinfo = SvOK(cb) ? SvUV(cb) : 0;
+ opinfo = SvOK(cb) ? SvUV(cb) : 0;
+ w->opinfo = (U8) ((opinfo < 255) ? opinfo : 255);
  if (w->opinfo)
   vmg_op_info_init(w->opinfo);
+
  VMG_SET_SVT_CB(ST(i++), get);
  VMG_SET_SVT_CB(ST(i++), set);
  VMG_SET_SVT_CB(ST(i++), len);
@@ -1422,22 +1426,14 @@ OUTPUT:
 SV *cast(SV *sv, SV *wiz, ...)
 PROTOTYPE: \[$@%&*]$@
 PREINIT:
- AV *args = NULL;
- SV *ret;
+ SV **args = NULL;
+ I32 i = 0;
 CODE:
  if (items > 2) {
-  I32 i;
-  args = newAV();
-  av_fill(args, items - 2);
-  for (i = 2; i < items; ++i) {
-   SV *arg = ST(i);
-   SvREFCNT_inc(arg);
-   if (av_store(args, i - 2, arg) == NULL) croak(vmg_argstorefailed);
-  }
+  i = items - 2;
+  args = &ST(2);
  }
- ret = newSVuv(vmg_cast(SvRV(sv), vmg_wizard_validate(wiz), args));
- SvREFCNT_dec(args);
- RETVAL = ret;
+ RETVAL = newSVuv(vmg_cast(SvRV(sv), vmg_wizard_validate(wiz), args, i));
 OUTPUT:
  RETVAL