File Coverage

File:Magic.xs
Coverage:96.8%

linestmtbrancondsubpodtimecode
1/* This file is part of the Variable::Magic Perl module.
2 * See http://search.cpan.org/dist/Variable-Magic/ */
3
4#include <stdarg.h> /* <va_list>, va_{start,arg,end}, ... */
5
6#include <stdio.h> /* sprintf() */
7
8#define PERL_NO_GET_CONTEXT
9#include "EXTERN.h"
10#include "perl.h"
11#include "XSUB.h"
12
13#define __PACKAGE__ "Variable::Magic"
14
15#undef VOID2
16#ifdef __cplusplus
17# define VOID2(T, P) static_cast<T>(P)
18#else
19# define VOID2(T, P) (P)
20#endif
21
22#ifndef VMG_PERL_PATCHLEVEL
23# ifdef PERL_PATCHNUM
24# define VMG_PERL_PATCHLEVEL PERL_PATCHNUM
25# else
26# define VMG_PERL_PATCHLEVEL 0
27# endif
28#endif
29
30#define VMG_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
31
32#define VMG_HAS_PERL_BRANCH(R, V, S) (PERL_REVISION == (R) && PERL_VERSION == (V) && PERL_SUBVERSION >= (S))
33
34#define VMG_HAS_PERL_MAINT(R, V, S, P) (PERL_REVISION == (R) && PERL_VERSION == (V) && (VMG_PERL_PATCHLEVEL >= (P) || (!VMG_PERL_PATCHLEVEL && PERL_SUBVERSION >= (S))))
35
36/* --- Threads and multiplicity -------------------------------------------- */
37
38#ifndef NOOP
39# define NOOP
40#endif
41
42#ifndef dNOOP
43# define dNOOP
44#endif
45
46/* Safe unless stated otherwise in Makefile.PL */
47#ifndef VMG_FORKSAFE
48# define VMG_FORKSAFE 1
49#endif
50
51#ifndef VMG_MULTIPLICITY
52# if defined(MULTIPLICITY) || defined(PERL_IMPLICIT_CONTEXT)
53# define VMG_MULTIPLICITY 1
54# else
55# define VMG_MULTIPLICITY 0
56# endif
57#endif
58#if VMG_MULTIPLICITY && !defined(tTHX)
59# define tTHX PerlInterpreter*
60#endif
61
62#if VMG_MULTIPLICITY && defined(USE_ITHREADS) && defined(dMY_CXT) && defined(MY_CXT) && defined(START_MY_CXT) && defined(MY_CXT_INIT) && (defined(MY_CXT_CLONE) || defined(dMY_CXT_SV))
63# define VMG_THREADSAFE 1
64# ifndef MY_CXT_CLONE
65# define MY_CXT_CLONE \
66    dMY_CXT_SV; \
67    my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1)); \
68    Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t); \
69    sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
70# endif
71#else
72# define VMG_THREADSAFE 0
73# undef dMY_CXT
74# define dMY_CXT dNOOP
75# undef MY_CXT
76# define MY_CXT vmg_globaldata
77# undef START_MY_CXT
78# define START_MY_CXT STATIC my_cxt_t MY_CXT;
79# undef MY_CXT_INIT
80# define MY_CXT_INIT NOOP
81# undef MY_CXT_CLONE
82# define MY_CXT_CLONE NOOP
83#endif
84
85#if VMG_THREADSAFE
86
87STATIC SV *vmg_clone(pTHX_ SV *sv, tTHX owner) {
88#define vmg_clone(P, O) vmg_clone(aTHX_ (P), (O))
89 SV *dupsv;
90
91#if VMG_HAS_PERL(5, 13, 2)
92 CLONE_PARAMS *param = Perl_clone_params_new(owner, aTHX);
93
94 dupsv = sv_dup(sv, param);
95
96 Perl_clone_params_del(param);
97#else
98 CLONE_PARAMS param;
99
100 param.stashes = NULL; /* don't need it unless sv is a PVHV */
101 param.flags = 0;
102 param.proto_perl = owner;
103
104 dupsv = sv_dup(sv, &param);
105#endif
106
107 return SvREFCNT_inc(dupsv);
108}
109
110#endif /* VMG_THREADSAFE */
111
112/* --- Compatibility ------------------------------------------------------- */
113
114#ifndef Newx
115# define Newx(v, n, c) New(0, v, n, c)
116#endif
117
118#ifndef SvMAGIC_set
119# define SvMAGIC_set(sv, val) (SvMAGIC(sv) = (val))
120#endif
121
122#ifndef SvRV_const
123# define SvRV_const(sv) SvRV((SV *) sv)
124#endif
125
126#ifndef SvREFCNT_inc_simple_void
127# define SvREFCNT_inc_simple_void(sv) SvREFCNT_inc(sv)
128#endif
129
130#ifndef mPUSHu
131# define mPUSHu(U) PUSHs(sv_2mortal(newSVuv(U)))
132#endif
133
134#ifndef PERL_MAGIC_ext
135# define PERL_MAGIC_ext '~'
136#endif
137
138#ifndef PERL_MAGIC_tied
139# define PERL_MAGIC_tied 'P'
140#endif
141
142#ifndef MGf_COPY
143# define MGf_COPY 0
144#endif
145
146#ifndef MGf_DUP
147# define MGf_DUP 0
148#endif
149
150#ifndef MGf_LOCAL
151# define MGf_LOCAL 0
152#endif
153
154#ifndef IN_PERL_COMPILETIME
155# define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling)
156#endif
157
158/* uvar magic and Hash::Util::FieldHash were commited with 28419, but we only
159 * enable them on 5.10 */
160#if VMG_HAS_PERL(5, 10, 0)
161# define VMG_UVAR 1
162#else
163# define VMG_UVAR 0
164#endif
165
166/* Applied to dev-5.9 as 25854, integrated to maint-5.8 as 28160, partially
167 * reverted to dev-5.11 as 9cdcb38b */
168#if VMG_HAS_PERL_MAINT(5, 8, 9, 28160) || VMG_HAS_PERL_MAINT(5, 9, 3, 25854) || VMG_HAS_PERL(5, 10, 0)
169# ifndef VMG_COMPAT_ARRAY_PUSH_NOLEN
170# if VMG_HAS_PERL(5, 11, 0)
171# define VMG_COMPAT_ARRAY_PUSH_NOLEN 0
172# else
173# define VMG_COMPAT_ARRAY_PUSH_NOLEN 1
174# endif
175# endif
176# ifndef VMG_COMPAT_ARRAY_PUSH_NOLEN_VOID
177# define VMG_COMPAT_ARRAY_PUSH_NOLEN_VOID 1
178# endif
179#else
180# ifndef VMG_COMPAT_ARRAY_PUSH_NOLEN
181# define VMG_COMPAT_ARRAY_PUSH_NOLEN 0
182# endif
183# ifndef VMG_COMPAT_ARRAY_PUSH_NOLEN_VOID
184# define VMG_COMPAT_ARRAY_PUSH_NOLEN_VOID 0
185# endif
186#endif
187
188/* Applied to dev-5.11 as 34908 */
189#if VMG_HAS_PERL_MAINT(5, 11, 0, 34908) || VMG_HAS_PERL(5, 12, 0)
190# define VMG_COMPAT_ARRAY_UNSHIFT_NOLEN_VOID 1
191#else
192# define VMG_COMPAT_ARRAY_UNSHIFT_NOLEN_VOID 0
193#endif
194
195/* Applied to dev-5.9 as 31473 (see #43357), integrated to maint-5.8 as 32542 */
196#if VMG_HAS_PERL_MAINT(5, 8, 9, 32542) || VMG_HAS_PERL_MAINT(5, 9, 5, 31473) || VMG_HAS_PERL(5, 10, 0)
197# define VMG_COMPAT_ARRAY_UNDEF_CLEAR 1
198#else
199# define VMG_COMPAT_ARRAY_UNDEF_CLEAR 0
200#endif
201
202#if VMG_HAS_PERL_MAINT(5, 11, 0, 32969) || VMG_HAS_PERL(5, 12, 0)
203# define VMG_COMPAT_SCALAR_LENGTH_NOLEN 1
204#else
205# define VMG_COMPAT_SCALAR_LENGTH_NOLEN 0
206#endif
207
208#if VMG_HAS_PERL(5, 13, 2)
209# define VMG_COMPAT_GLOB_GET 1
210#else
211# define VMG_COMPAT_GLOB_GET 0
212#endif
213
214/* ... Bug-free mg_magical ................................................. */
215
216/* See the discussion at http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2008-01/msg00036.html */
217
218#if VMG_HAS_PERL(5, 11, 3)
219
220#define vmg_mg_magical(S) mg_magical(S)
221
222#else
223
224STATIC void vmg_mg_magical(SV *sv) {
225 const MAGIC *mg;
226
227 SvMAGICAL_off(sv);
228 if ((mg = SvMAGIC(sv))) {
229  do {
230   const MGVTBL* const vtbl = mg->mg_virtual;
231   if (vtbl) {
232    if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
233     SvGMAGICAL_on(sv);
234    if (vtbl->svt_set)
235     SvSMAGICAL_on(sv);
236    if (vtbl->svt_clear)
237     SvRMAGICAL_on(sv);
238   }
239  } while ((mg = mg->mg_moremagic));
240  if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)))
241   SvRMAGICAL_on(sv);
242 }
243}
244
245#endif
246
247/* ... Safe version of call_sv() ........................................... */
248
249#define VMG_SAVE_LAST_CX (!VMG_HAS_PERL(5, 8, 4) || VMG_HAS_PERL(5, 9, 5))
250
251
398
STATIC I32 vmg_call_sv(pTHX_ SV *sv, I32 flags, I32 destructor) {
252#define vmg_call_sv(S, F, D) vmg_call_sv(aTHX_ (S), (F), (D))
253
398
 I32 ret, cxix = 0, in_eval = 0;
254#if VMG_SAVE_LAST_CX
255 PERL_CONTEXT saved_cx;
256#endif
257
398
 SV *old_err = NULL;
258
259
398
 if (SvTRUE(ERRSV)) {
260
15
  old_err = ERRSV;
261
15
  ERRSV = newSV(0);
262 }
263
264
398
 if (cxstack_ix < cxstack_max) {
265
398
  cxix = cxstack_ix + 1;
266
398
  if (destructor && CxTYPE(cxstack + cxix) == CXt_EVAL)
267
6
   in_eval = 1;
268 }
269
270#if VMG_SAVE_LAST_CX
271 /* The last popped context will be reused by call_sv(), but our callers may
272  * still need its previous value. Back it up so that it isn't clobbered. */
273
398
 saved_cx = cxstack[cxix];
274#endif
275
276
398
 ret = call_sv(sv, flags | G_EVAL);
277
278#if VMG_SAVE_LAST_CX
279
398
 cxstack[cxix] = saved_cx;
280#endif
281
282
398
 if (SvTRUE(ERRSV)) {
283
39
  if (old_err) {
284
13
   sv_setsv(old_err, ERRSV);
285
13
   SvREFCNT_dec(ERRSV);
286
13
   ERRSV = old_err;
287  }
288
39
  if (IN_PERL_COMPILETIME) {
289
3
   if (!PL_in_eval) {
290
0
    if (PL_errors)
291
0
     sv_catsv(PL_errors, ERRSV);
292    else
293
0
     Perl_warn(aTHX_ "%s", SvPV_nolen(ERRSV));
294
0
    SvCUR_set(ERRSV, 0);
295   }
296#if VMG_HAS_PERL(5, 10, 0) || defined(PL_parser)
297
3
   if (PL_parser)
298
3
    ++PL_parser->error_count;
299#elif defined(PL_error_count)
300   ++PL_error_count;
301#else
302   ++PL_Ierror_count;
303#endif
304
36
   } else if (!in_eval)
305
35
    croak(NULL);
306 } else {
307
359
  if (old_err) {
308
2
   SvREFCNT_dec(ERRSV);
309
2
   ERRSV = old_err;
310  }
311 }
312
313
363
 return ret;
314}
315
316/* --- Stolen chunk of B --------------------------------------------------- */
317
318typedef enum {
319 OPc_NULL = 0,
320 OPc_BASEOP = 1,
321 OPc_UNOP = 2,
322 OPc_BINOP = 3,
323 OPc_LOGOP = 4,
324 OPc_LISTOP = 5,
325 OPc_PMOP = 6,
326 OPc_SVOP = 7,
327 OPc_PADOP = 8,
328 OPc_PVOP = 9,
329 OPc_LOOP = 10,
330 OPc_COP = 11,
331 OPc_MAX = 12
332} opclass;
333
334STATIC const char *const vmg_opclassnames[] = {
335 "B::NULL",
336 "B::OP",
337 "B::UNOP",
338 "B::BINOP",
339 "B::LOGOP",
340 "B::LISTOP",
341 "B::PMOP",
342 "B::SVOP",
343 "B::PADOP",
344 "B::PVOP",
345 "B::LOOP",
346 "B::COP"
347};
348
349
24
STATIC opclass vmg_opclass(const OP *o) {
350#if 0
351 if (!o)
352  return OPc_NULL;
353#endif
354
355
24
 if (o->op_type == 0)
356
0
  return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
357
358
24
 if (o->op_type == OP_SASSIGN)
359
3
  return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
360
361
21
 if (o->op_type == OP_AELEMFAST) {
362
0
  if (o->op_flags & OPf_SPECIAL)
363
0
   return OPc_BASEOP;
364  else
365#ifdef USE_ITHREADS
366   return OPc_PADOP;
367#else
368
0
   return OPc_SVOP;
369#endif
370 }
371
372#ifdef USE_ITHREADS
373 if (o->op_type == OP_GV || o->op_type == OP_GVSV || o->op_type == OP_RCATLINE)
374  return OPc_PADOP;
375#endif
376
377
21
 switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
378  case OA_BASEOP:
379
1
   return OPc_BASEOP;
380  case OA_UNOP:
381
1
   return OPc_UNOP;
382  case OA_BINOP:
383
1
   return OPc_BINOP;
384  case OA_LOGOP:
385
1
   return OPc_LOGOP;
386  case OA_LISTOP:
387
1
   return OPc_LISTOP;
388  case OA_PMOP:
389
1
   return OPc_PMOP;
390  case OA_SVOP:
391
3
   return OPc_SVOP;
392  case OA_PADOP:
393
0
   return OPc_PADOP;
394  case OA_PVOP_OR_SVOP:
395
1
   return (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF)) ? OPc_SVOP : OPc_PVOP;
396  case OA_LOOP:
397
6
   return OPc_LOOP;
398  case OA_COP:
399
0
   return OPc_COP;
400  case OA_BASEOP_OR_UNOP:
401
1
   return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
402  case OA_FILESTATOP:
403
1
   return ((o->op_flags & OPf_KIDS) ? OPc_UNOP :
404#ifdef USE_ITHREADS
405           (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP);
406#else
407
0
           (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP);
408#endif
409  case OA_LOOPEXOP:
410
3
   if (o->op_flags & OPf_STACKED)
411
1
    return OPc_UNOP;
412
2
   else if (o->op_flags & OPf_SPECIAL)
413
1
    return OPc_BASEOP;
414   else
415
1
    return OPc_PVOP;
416 }
417
418
24
 return OPc_BASEOP;
419}
420
421/* --- Error messages ------------------------------------------------------ */
422
423STATIC const char vmg_invalid_wiz[] = "Invalid wizard object";
424STATIC const char vmg_wrongargnum[] = "Wrong number of arguments";
425STATIC const char vmg_argstorefailed[] = "Error while storing arguments";
426
427/* --- Signatures ---------------------------------------------------------- */
428
429#define SIG_WZO ((U16) (0x3891))
430#define SIG_WIZ ((U16) (0x3892))
431
432/* --- MGWIZ structure ----------------------------------------------------- */
433
434typedef struct {
435 MGVTBL *vtbl;
436
437 U8 opinfo;
438 U8 uvar;
439
440 SV *cb_data;
441 SV *cb_get, *cb_set, *cb_len, *cb_clear, *cb_free;
442#if MGf_COPY
443 SV *cb_copy;
444#endif /* MGf_COPY */
445#if MGf_DUP
446 SV *cb_dup;
447#endif /* MGf_DUP */
448#if MGf_LOCAL
449 SV *cb_local;
450#endif /* MGf_LOCAL */
451#if VMG_UVAR
452 SV *cb_fetch, *cb_store, *cb_exists, *cb_delete;
453#endif /* VMG_UVAR */
454
455#if VMG_MULTIPLICITY
456 tTHX owner;
457#endif /* VMG_MULTIPLICITY */
458} MGWIZ;
459
460
88
STATIC void vmg_mgwiz_free(pTHX_ MGWIZ *w) {
461#define vmg_mgwiz_free(W) vmg_mgwiz_free(aTHX_ (W))
462
88
 if (!w)
463
0
  return;
464
465 /* We reach this point in dirty state when ptable_free() is called from the
466  * atexit cleanup callback, and that the global table still holds a live
467  * wizard. This happens before all the SV bodies are freed, so all the wizard
468  * callbacks are still alive (as they are referenced by the undead wizard).
469  * Hence it is safe to decrement their refcount. Later on, the wizard free
470  * callback itself will trigger when the wizard body is reaped, but it will
471  * be skipped as it guards against dirty state - which is good since nothing
472  * has to be done anymore at that point. */
473
474
88
 SvREFCNT_dec(w->cb_data);
475
88
 SvREFCNT_dec(w->cb_get);
476
88
 SvREFCNT_dec(w->cb_set);
477
88
 SvREFCNT_dec(w->cb_len);
478
88
 SvREFCNT_dec(w->cb_clear);
479
88
 SvREFCNT_dec(w->cb_free);
480#if MGf_COPY
481
88
 SvREFCNT_dec(w->cb_copy);
482#endif /* MGf_COPY */
483#if 0 /* MGf_DUP */
484 SvREFCNT_dec(w->cb_dup);
485#endif /* MGf_DUP */
486#if MGf_LOCAL
487
88
 SvREFCNT_dec(w->cb_local);
488#endif /* MGf_LOCAL */
489#if VMG_UVAR
490
88
 SvREFCNT_dec(w->cb_fetch);
491
88
 SvREFCNT_dec(w->cb_store);
492
88
 SvREFCNT_dec(w->cb_exists);
493
88
 SvREFCNT_dec(w->cb_delete);
494#endif /* VMG_UVAR */
495
496
88
 Safefree(w->vtbl);
497
88
 Safefree(w);
498
499
88
 return;
500}
501
502#if VMG_THREADSAFE
503
504#define VMG_CLONE_CB(N) \
505 z->cb_ ## N = (w->cb_ ## N) ? vmg_clone(w->cb_ ## N, w->owner) \
506                             : NULL;
507
508STATIC MGWIZ *vmg_mgwiz_clone(pTHX_ const MGWIZ *w) {
509#define vmg_mgwiz_clone(W) vmg_mgwiz_clone(aTHX_ (W))
510 MGVTBL *t;
511 MGWIZ *z;
512
513 if (!w)
514  return NULL;
515
516 Newx(t, 1, MGVTBL);
517 Copy(w->vtbl, t, 1, MGVTBL);
518
519 Newx(z, 1, MGWIZ);
520
521 z->vtbl = t;
522 z->uvar = w->uvar;
523 z->opinfo = w->opinfo;
524
525 VMG_CLONE_CB(data);
526 VMG_CLONE_CB(get);
527 VMG_CLONE_CB(set);
528 VMG_CLONE_CB(len);
529 VMG_CLONE_CB(clear);
530 VMG_CLONE_CB(free);
531#if MGf_COPY
532 VMG_CLONE_CB(copy);
533#endif /* MGf_COPY */
534#if MGf_DUP
535 VMG_CLONE_CB(dup);
536#endif /* MGf_DUP */
537#if MGf_LOCAL
538 VMG_CLONE_CB(local);
539#endif /* MGf_LOCAL */
540#if VMG_UVAR
541 VMG_CLONE_CB(fetch);
542 VMG_CLONE_CB(store);
543 VMG_CLONE_CB(exists);
544 VMG_CLONE_CB(delete);
545#endif /* VMG_UVAR */
546
547 z->owner = aTHX;
548
549 return z;
550}
551
552#endif /* VMG_THREADSAFE */
553
554/* --- Context-safe global data -------------------------------------------- */
555
556#if VMG_THREADSAFE
557
558#define PTABLE_NAME ptable
559#define PTABLE_VAL_FREE(V) vmg_mgwiz_free(VOID2(MGWIZ *, (V)))
560
561#define pPTBL pTHX
562#define pPTBL_ pTHX_
563#define aPTBL aTHX
564#define aPTBL_ aTHX_
565
566#include "ptable.h"
567
568#define ptable_store(T, K, V) ptable_store(aTHX_ (T), (K), (V))
569#define ptable_clear(T) ptable_clear(aTHX_ (T))
570#define ptable_free(T) ptable_free(aTHX_ (T))
571
572#endif /* VMG_THREADSAFE */
573
574#define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION
575
576typedef struct {
577#if VMG_THREADSAFE
578 ptable *wizards;
579 tTHX owner;
580#endif
581 HV *b__op_stashes[OPc_MAX];
582} my_cxt_t;
583
584START_MY_CXT
585
586#if VMG_THREADSAFE
587
588STATIC void vmg_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) {
589 my_cxt_t *ud = VOID2(my_cxt_t *, ud_);
590 MGWIZ *w;
591
592 if (ud->owner == aTHX)
593  return;
594
595 w = vmg_mgwiz_clone(VOID2(MGWIZ *, ent->val));
596 if (w)
597  ptable_store(ud->wizards, ent->key, w);
598}
599
600#endif /* VMG_THREADSAFE */
601
602/* --- Wizard objects ------------------------------------------------------ */
603
604STATIC int vmg_wizard_free(pTHX_ SV *sv, MAGIC *mg);
605
606STATIC MGVTBL vmg_wizard_vtbl = {
607 NULL, /* get */
608 NULL, /* set */
609 NULL, /* len */
610 NULL, /* clear */
611 vmg_wizard_free, /* free */
612#if MGf_COPY
613 NULL, /* copy */
614#endif /* MGf_COPY */
615#if MGf_DUP
616 NULL, /* dup */
617#endif /* MGf_DUP */
618#if MGf_LOCAL
619 NULL, /* local */
620#endif /* MGf_LOCAL */
621};
622
623/* ... Wizard constructor .................................................. */
624
625
99
STATIC SV *vmg_wizard_new(pTHX_ const MGWIZ *w) {
626#define vmg_wizard_new(W) vmg_wizard_new(aTHX_ (W))
627
99
 SV *wiz = newSVuv(PTR2IV(w));
628
629
99
 if (w) {
630
99
  MAGIC *mg = sv_magicext(wiz, NULL, PERL_MAGIC_ext, &vmg_wizard_vtbl, NULL, 0);
631
99
  mg->mg_private = SIG_WZO;
632 }
633
99
 SvREADONLY_on(wiz);
634
635
99
 return wiz;
636}
637
638
189
STATIC const SV *vmg_wizard_validate(pTHX_ const SV *wiz) {
639#define vmg_wizard_validate(W) vmg_wizard_validate(aTHX_ (W))
640
189
 if (SvROK(wiz)) {
641
186
  wiz = SvRV_const(wiz);
642
186
  if (SvIOK(wiz))
643
184
   return wiz;
644 }
645
646
5
 croak(vmg_invalid_wiz);
647 /* Not reached */
648 return NULL;
649}
650
651#define vmg_wizard_id(W) SvIVX((const SV *) (W))
652#define vmg_wizard_main_mgwiz(W) INT2PTR(const MGWIZ *, vmg_wizard_id(W))
653
654/* ... Wizard destructor ................................................... */
655
656
89
STATIC int vmg_wizard_free(pTHX_ SV *sv, MAGIC *mg) {
657 MGWIZ *w;
658
659
89
 if (PL_dirty) /* During global destruction, the context is already freed */
660
1
  return 0;
661
662
88
 w = (MGWIZ *) vmg_wizard_main_mgwiz(sv);
663
664#if VMG_THREADSAFE
665 {
666  dMY_CXT;
667  ptable_store(MY_CXT.wizards, w, NULL);
668 }
669#else /* VMG_THREADSAFE */
670
88
 vmg_mgwiz_free(w);
671#endif /* !VMG_THREADSAFE */
672
673
89
 return 0;
674}
675
676#if VMG_THREADSAFE
677
678STATIC const MGWIZ *vmg_wizard_mgwiz(pTHX_ const SV *wiz) {
679#define vmg_wizard_mgwiz(W) vmg_wizard_mgwiz(aTHX_ ((const SV *) (W)))
680 const MGWIZ *w;
681
682 w = vmg_wizard_main_mgwiz(wiz);
683 if (w->owner == aTHX)
684  return w;
685
686 {
687  dMY_CXT;
688  return VOID2(const MGWIZ *, ptable_fetch(MY_CXT.wizards, w));
689 }
690}
691
692#else /* VMG_THREADSAFE */
693
694#define vmg_wizard_mgwiz(W) vmg_wizard_main_mgwiz(W)
695
696#endif /* !VMG_THREADSAFE */
697
698/* --- User-level functions implementation --------------------------------- */
699
700
154
STATIC const MAGIC *vmg_find(const SV *sv, const SV *wiz) {
701 const MAGIC *mg, *moremagic;
702 IV wid;
703
704
154
 if (SvTYPE(sv) < SVt_PVMG)
705
85
  return NULL;
706
707
69
 wid = vmg_wizard_id(wiz);
708
90
 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
709
31
  moremagic = mg->mg_moremagic;
710
31
  if (mg->mg_type == PERL_MAGIC_ext && mg->mg_private == SIG_WIZ) {
711
17
   IV zid = vmg_wizard_id(mg->mg_ptr);
712
17
   if (zid == wid)
713
10
    return mg;
714  }
715 }
716
717
154
 return NULL;
718}
719
720/* ... Construct private data .............................................. */
721
722
47
STATIC SV *vmg_data_new(pTHX_ SV *ctor, SV *sv, SV **args, I32 items) {
723#define vmg_data_new(C, S, A, I) vmg_data_new(aTHX_ (C), (S), (A), (I))
724 I32 i;
725 SV *nsv;
726
727
47
 dSP;
728
729
47
 ENTER;
730
47
 SAVETMPS;
731
732
47
 PUSHMARK(SP);
733
47
 EXTEND(SP, items + 1);
734
47
 PUSHs(sv_2mortal(newRV_inc(sv)));
735
85
 for (i = 0; i < items; ++i)
736
38
  PUSHs(args[i]);
737
47
 PUTBACK;
738
739
47
 vmg_call_sv(ctor, G_SCALAR, 0);
740
741
39
 SPAGAIN;
742
39
 nsv = POPs;
743#if VMG_HAS_PERL(5, 8, 3)
744
39
 SvREFCNT_inc_simple_void(nsv); /* Or it will be destroyed in FREETMPS */
745#else
746 nsv = sv_newref(nsv); /* Workaround some bug in SvREFCNT_inc() */
747#endif
748
39
 PUTBACK;
749
750
39
 FREETMPS;
751
39
 LEAVE;
752
753
39
 return nsv;
754}
755
756
10
STATIC SV *vmg_data_get(pTHX_ SV *sv, const SV *wiz) {
757#define vmg_data_get(S, W) vmg_data_get(aTHX_ (S), (W))
758
10
 const MAGIC *mg = vmg_find(sv, wiz);
759
10
 return mg ? mg->mg_obj : NULL;
760}
761
762/* ... Magic cast/dispell .................................................. */
763
764#if VMG_UVAR
765STATIC I32 vmg_svt_val(pTHX_ IV, SV *);
766
767
10
STATIC void vmg_uvar_del(SV *sv, MAGIC *prevmagic, MAGIC *mg, MAGIC *moremagic) {
768
10
 if (prevmagic) {
769
1
  prevmagic->mg_moremagic = moremagic;
770 } else {
771
9
  SvMAGIC_set(sv, moremagic);
772 }
773
10
 mg->mg_moremagic = NULL;
774
10
 Safefree(mg->mg_ptr);
775
10
 Safefree(mg);
776
10
}
777#endif /* VMG_UVAR */
778
779
144
STATIC UV vmg_cast(pTHX_ SV *sv, const SV *wiz, SV **args, I32 items) {
780#define vmg_cast(S, W, A, I) vmg_cast(aTHX_ (S), (W), (A), (I))
781 MAGIC *mg;
782 SV *data;
783 const MGWIZ *w;
784 U32 oldgmg;
785
786
144
 if (vmg_find(sv, wiz))
787
1
  return 1;
788
789
143
 w = vmg_wizard_mgwiz(wiz);
790
143
 oldgmg = SvGMAGICAL(sv);
791
792
143
 data = (w->cb_data) ? vmg_data_new(w->cb_data, sv, args, items) : NULL;
793 /* sv_magicext() calls mg_magical and increments data's refcount */
794
135
 mg = sv_magicext(sv, data, PERL_MAGIC_ext, w->vtbl,
795                              (const char *) wiz, HEf_SVKEY);
796
135
 SvREFCNT_dec(data);
797
135
 mg->mg_private = SIG_WIZ;
798#if MGf_COPY
799
135
 if (w->cb_copy)
800
18
  mg->mg_flags |= MGf_COPY;
801#endif /* MGf_COPY */
802#if 0 /* MGf_DUP */
803 if (w->cb_dup)
804  mg->mg_flags |= MGf_DUP;
805#endif /* MGf_DUP */
806#if MGf_LOCAL
807
135
 if (w->cb_local)
808
15
  mg->mg_flags |= MGf_LOCAL;
809#endif /* MGf_LOCAL */
810
811
135
 if (SvTYPE(sv) < SVt_PVHV)
812
108
  goto done;
813
814 /* The GMAGICAL flag only says that a hash is tied or has uvar magic - get
815  * magic is actually never called for them. If the GMAGICAL flag was off before
816  * calling sv_magicext(), the hash isn't tied and has no uvar magic. If it's
817  * now on, then this wizard has get magic. Hence we can work around the
818  * get/clear shortcoming by turning the GMAGICAL flag off. If the current magic
819  * has uvar callbacks, it will be turned back on later. */
820
27
 if (!oldgmg && SvGMAGICAL(sv))
821
5
  SvGMAGICAL_off(sv);
822
823#if VMG_UVAR
824
27
 if (w->uvar) {
825
21
  MAGIC *prevmagic, *moremagic = NULL;
826  struct ufuncs uf[2];
827
828
21
  uf[0].uf_val = vmg_svt_val;
829
21
  uf[0].uf_set = NULL;
830
21
  uf[0].uf_index = 0;
831
21
  uf[1].uf_val = NULL;
832
21
  uf[1].uf_set = NULL;
833
21
  uf[1].uf_index = 0;
834
835  /* One uvar magic in the chain is enough. */
836
44
  for (prevmagic = NULL, mg = SvMAGIC(sv); mg; prevmagic = mg, mg = moremagic) {
837
26
   moremagic = mg->mg_moremagic;
838
26
   if (mg->mg_type == PERL_MAGIC_uvar)
839
3
    break;
840  }
841
842
21
  if (mg) { /* Found another uvar magic. */
843
3
   struct ufuncs *olduf = (struct ufuncs *) mg->mg_ptr;
844
3
   if (olduf->uf_val == vmg_svt_val) {
845    /* It's our uvar magic, nothing to do. oldgmg was true. */
846
2
    goto done;
847   } else {
848    /* It's another uvar magic, backup it and replace it by ours. */
849
1
    uf[1] = *olduf;
850
1
    vmg_uvar_del(sv, prevmagic, mg, moremagic);
851   }
852  }
853
854
19
  sv_magic(sv, NULL, PERL_MAGIC_uvar, (const char *) &uf, sizeof(uf));
855
19
  vmg_mg_magical(sv);
856  /* Our hash now carries uvar magic. The uvar/clear shortcoming has to be
857   * handled by our uvar callback. */
858 }
859#endif /* VMG_UVAR */
860
861done:
862
136
 return 1;
863}
864
865
30
STATIC UV vmg_dispell(pTHX_ SV *sv, const SV *wiz) {
866#define vmg_dispell(S, W) vmg_dispell(aTHX_ (S), (W))
867#if VMG_UVAR
868
30
 U32 uvars = 0;
869#endif /* VMG_UVAR */
870
30
 MAGIC *mg, *prevmagic, *moremagic = NULL;
871
30
 IV wid = vmg_wizard_id(wiz);
872
873
30
 if (SvTYPE(sv) < SVt_PVMG)
874
1
  return 0;
875
876
42
 for (prevmagic = NULL, mg = SvMAGIC(sv); mg; prevmagic = mg, mg = moremagic) {
877
41
  moremagic = mg->mg_moremagic;
878
41
  if (mg->mg_type == PERL_MAGIC_ext && mg->mg_private == SIG_WIZ) {
879#if VMG_UVAR
880
31
   const MGWIZ *z = vmg_wizard_mgwiz(mg->mg_ptr);
881#endif /* VMG_UVAR */
882
31
   IV zid = vmg_wizard_id(mg->mg_ptr);
883
31
   if (zid == wid) {
884#if VMG_UVAR
885    /* If the current has no uvar, short-circuit uvar deletion. */
886
28
    uvars = z->uvar ? (uvars + 1) : 0;
887#endif /* VMG_UVAR */
888
28
    break;
889#if VMG_UVAR
890
3
   } else if (z->uvar) {
891
1
    ++uvars;
892    /* We can't break here since we need to find the ext magic to delete. */
893#endif /* VMG_UVAR */
894   }
895  }
896 }
897
29
 if (!mg)
898
1
  return 0;
899
900
28
 if (prevmagic) {
901
13
  prevmagic->mg_moremagic = moremagic;
902 } else {
903
15
  SvMAGIC_set(sv, moremagic);
904 }
905
28
 mg->mg_moremagic = NULL;
906
907 /* Destroy private data */
908
28
 if (mg->mg_obj != sv)
909
28
  SvREFCNT_dec(mg->mg_obj);
910 /* Unreference the wizard */
911
28
 SvREFCNT_dec((SV *) mg->mg_ptr);
912
28
 Safefree(mg);
913
914#if VMG_UVAR
915
28
 if (uvars == 1 && SvTYPE(sv) >= SVt_PVHV) {
916  /* mg was the first ext magic in the chain that had uvar */
917
918
12
  for (mg = moremagic; mg; mg = mg->mg_moremagic) {
919
2
   if (mg->mg_type == PERL_MAGIC_ext && mg->mg_private == SIG_WIZ) {
920
1
    const MGWIZ *z = vmg_wizard_mgwiz(mg->mg_ptr);
921
1
    if (z->uvar) {
922
1
     ++uvars;
923
1
     break;
924    }
925   }
926  }
927
928
11
  if (uvars == 1) {
929   struct ufuncs *uf;
930
10
   for (prevmagic = NULL, mg = SvMAGIC(sv); mg; prevmagic = mg, mg = moremagic){
931
10
    moremagic = mg->mg_moremagic;
932
10
    if (mg->mg_type == PERL_MAGIC_uvar)
933
10
     break;
934   }
935   /* assert(mg); */
936
10
   uf = (struct ufuncs *) mg->mg_ptr;
937   /* assert(uf->uf_val == vmg_svt_val); */
938
10
   if (uf[1].uf_val || uf[1].uf_set) {
939    /* Revert the original uvar magic. */
940
1
    uf[0] = uf[1];
941
1
    Renew(uf, 1, struct ufuncs);
942
1
    mg->mg_ptr = (char *) uf;
943
1
    mg->mg_len = sizeof(struct ufuncs);
944   } else {
945    /* Remove the uvar magic. */
946
9
    vmg_uvar_del(sv, prevmagic, mg, moremagic);
947   }
948  }
949 }
950#endif /* VMG_UVAR */
951
952
28
 vmg_mg_magical(sv);
953
954
30
 return 1;
955}
956
957/* ... OP info ............................................................. */
958
959#define VMG_OP_INFO_NAME 1
960#define VMG_OP_INFO_OBJECT 2
961
962#if VMG_THREADSAFE
963STATIC perl_mutex vmg_op_name_init_mutex;
964#endif
965
966STATIC U32 vmg_op_name_init = 0;
967STATIC unsigned char vmg_op_name_len[MAXO] = { 0 };
968
969
37
STATIC void vmg_op_info_init(pTHX_ unsigned int opinfo) {
970#define vmg_op_info_init(W) vmg_op_info_init(aTHX_ (W))
971
37
 switch (opinfo) {
972  case VMG_OP_INFO_NAME:
973#if VMG_THREADSAFE
974   MUTEX_LOCK(&vmg_op_name_init_mutex);
975#endif
976
18
   if (!vmg_op_name_init) {
977    OPCODE t;
978
742
    for (t = 0; t < OP_max; ++t)
979
740
     vmg_op_name_len[t] = strlen(PL_op_name[t]);
980
2
    vmg_op_name_init = 1;
981   }
982#if VMG_THREADSAFE
983   MUTEX_UNLOCK(&vmg_op_name_init_mutex);
984#endif
985
18
   break;
986  case VMG_OP_INFO_OBJECT: {
987   dMY_CXT;
988
18
   if (!MY_CXT.b__op_stashes[0]) {
989    int c;
990
2
    require_pv("B.pm");
991
26
    for (c = OPc_NULL; c < OPc_MAX; ++c)
992
24
     MY_CXT.b__op_stashes[c] = gv_stashpv(vmg_opclassnames[c], 1);
993   }
994
18
   break;
995  }
996  default:
997
1
   break;
998 }
999
37
}
1000
1001
56
STATIC SV *vmg_op_info(pTHX_ unsigned int opinfo) {
1002#define vmg_op_info(W) vmg_op_info(aTHX_ (W))
1003
56
 if (!PL_op)
1004
6
  return &PL_sv_undef;
1005
1006
50
 switch (opinfo) {
1007  case VMG_OP_INFO_NAME: {
1008
25
   OPCODE t = PL_op->op_type;
1009
25
   return sv_2mortal(newSVpvn(PL_op_name[t], vmg_op_name_len[t]));
1010  }
1011  case VMG_OP_INFO_OBJECT: {
1012   dMY_CXT;
1013
24
   return sv_bless(sv_2mortal(newRV_noinc(newSViv(PTR2IV(PL_op)))),
1014                   MY_CXT.b__op_stashes[vmg_opclass(PL_op)]);
1015  }
1016  default:
1017   break;
1018 }
1019
1020
56
 return &PL_sv_undef;
1021}
1022
1023/* ... svt callbacks ....................................................... */
1024
1025#define VMG_CB_CALL_ARGS_MASK 15
1026#define VMG_CB_CALL_ARGS_SHIFT 4
1027#define VMG_CB_CALL_OPINFO (VMG_OP_INFO_NAME|VMG_OP_INFO_OBJECT)
1028
1029
294
STATIC int vmg_cb_call(pTHX_ SV *cb, unsigned int flags, SV *sv, ...) {
1030 va_list ap;
1031
294
 int ret = 0;
1032 unsigned int i, args, opinfo;
1033 SV *svr;
1034
1035
294
 dSP;
1036
1037
294
 args = flags & VMG_CB_CALL_ARGS_MASK;
1038
294
 flags >>= VMG_CB_CALL_ARGS_SHIFT;
1039
294
 opinfo = flags & VMG_CB_CALL_OPINFO;
1040
1041
294
 ENTER;
1042
294
 SAVETMPS;
1043
1044
294
 PUSHMARK(SP);
1045
294
 EXTEND(SP, args + 1);
1046
294
 PUSHs(sv_2mortal(newRV_inc(sv)));
1047
294
 va_start(ap, sv);
1048
751
 for (i = 0; i < args; ++i) {
1049
457
  SV *sva = va_arg(ap, SV *);
1050
457
  PUSHs(sva ? sva : &PL_sv_undef);
1051 }
1052
294
 va_end(ap);
1053
294
 if (opinfo)
1054
50
  XPUSHs(vmg_op_info(opinfo));
1055
294
 PUTBACK;
1056
1057
294
 vmg_call_sv(cb, G_SCALAR, 0);
1058
1059
278
 SPAGAIN;
1060
278
 svr = POPs;
1061
278
 if (SvOK(svr))
1062
161
  ret = (int) SvIV(svr);
1063
278
 PUTBACK;
1064
1065
278
 FREETMPS;
1066
278
 LEAVE;
1067
1068
278
 return ret;
1069}
1070
1071#define VMG_CB_FLAGS(OI, A) \
1072        ((((unsigned int) (OI)) << VMG_CB_CALL_ARGS_SHIFT) | (A))
1073
1074#define vmg_cb_call1(I, OI, S, A1) \
1075        vmg_cb_call(aTHX_ (I), VMG_CB_FLAGS((OI), 1), (S), (A1))
1076#define vmg_cb_call2(I, OI, S, A1, A2) \
1077        vmg_cb_call(aTHX_ (I), VMG_CB_FLAGS((OI), 2), (S), (A1), (A2))
1078#define vmg_cb_call3(I, OI, S, A1, A2, A3) \
1079        vmg_cb_call(aTHX_ (I), VMG_CB_FLAGS((OI), 3), (S), (A1), (A2), (A3))
1080
1081
89
STATIC int vmg_svt_get(pTHX_ SV *sv, MAGIC *mg) {
1082
89
 const MGWIZ *w = vmg_wizard_mgwiz(mg->mg_ptr);
1083
89
 return vmg_cb_call1(w->cb_get, w->opinfo, sv, mg->mg_obj);
1084}
1085
1086
50
STATIC int vmg_svt_set(pTHX_ SV *sv, MAGIC *mg) {
1087
50
 const MGWIZ *w = vmg_wizard_mgwiz(mg->mg_ptr);
1088
50
 return vmg_cb_call1(w->cb_set, w->opinfo, sv, mg->mg_obj);
1089}
1090
1091
35
STATIC U32 vmg_svt_len(pTHX_ SV *sv, MAGIC *mg) {
1092
35
 const MGWIZ *w = vmg_wizard_mgwiz(mg->mg_ptr);
1093
35
 unsigned int opinfo = w->opinfo;
1094 U32 len, ret;
1095 SV *svr;
1096
35
 svtype t = SvTYPE(sv);
1097
1098
35
 dSP;
1099
1100
35
 ENTER;
1101
35
 SAVETMPS;
1102
1103
35
 PUSHMARK(SP);
1104
35
 EXTEND(SP, 3);
1105
35
 PUSHs(sv_2mortal(newRV_inc(sv)));
1106
35
 PUSHs(mg->mg_obj ? mg->mg_obj : &PL_sv_undef);
1107
35
 if (t < SVt_PVAV) {
1108  STRLEN l;
1109#if VMG_HAS_PERL(5, 9, 3)
1110
2
  const U8 *s = VOID2(const U8 *, VOID2(const void *, SvPV_const(sv, l)));
1111#else
1112  U8 *s = SvPV(sv, l);
1113#endif
1114
2
  if (DO_UTF8(sv))
1115
1
   len = utf8_length(s, s + l);
1116  else
1117
1
   len = l;
1118
2
  mPUSHu(len);
1119
33
 } else if (t == SVt_PVAV) {
1120
33
  len = av_len((AV *) sv) + 1;
1121
33
  mPUSHu(len);
1122 } else {
1123
0
  len = 0;
1124
0
  PUSHs(&PL_sv_undef);
1125 }
1126
35
 if (opinfo)
1127
2
  XPUSHs(vmg_op_info(opinfo));
1128
35
 PUTBACK;
1129
1130
35
 vmg_call_sv(w->cb_len, G_SCALAR, 0);
1131
1132
26
 SPAGAIN;
1133
26
 svr = POPs;
1134
26
 ret = SvOK(svr) ? (U32) SvUV(svr) : len;
1135
26
 if (t == SVt_PVAV)
1136
24
  --ret;
1137
26
 PUTBACK;
1138
1139
26
 FREETMPS;
1140
26
 LEAVE;
1141
1142
26
 return ret;
1143}
1144
1145
12
STATIC int vmg_svt_clear(pTHX_ SV *sv, MAGIC *mg) {
1146
12
 const MGWIZ *w = vmg_wizard_mgwiz(mg->mg_ptr);
1147
12
 return vmg_cb_call1(w->cb_clear, w->opinfo, sv, mg->mg_obj);
1148}
1149
1150
23
STATIC int vmg_svt_free(pTHX_ SV *sv, MAGIC *mg) {
1151 const MGWIZ *w;
1152
23
 int ret = 0;
1153 SV *svr;
1154
1155
23
 dSP;
1156
1157 /* Don't even bother if we are in global destruction - the wizard is prisoner
1158  * of circular references and we are way beyond user realm */
1159
23
 if (PL_dirty)
1160
1
  return 0;
1161
1162
22
 w = vmg_wizard_mgwiz(mg->mg_ptr);
1163
1164 /* So that it survives the temp cleanup below */
1165
22
 SvREFCNT_inc_simple_void(sv);
1166
1167#if !(VMG_HAS_PERL_MAINT(5, 11, 0, 32686) || VMG_HAS_PERL(5, 12, 0))
1168 /* The previous magic tokens were freed but the magic chain wasn't updated, so
1169  * if you access the sv from the callback the old deleted magics will trigger
1170  * and cause memory misreads. Change 32686 solved it that way : */
1171 SvMAGIC_set(sv, mg);
1172#endif
1173
1174
22
 ENTER;
1175
22
 SAVETMPS;
1176
1177
22
 PUSHMARK(SP);
1178
22
 EXTEND(SP, 2);
1179
22
 PUSHs(sv_2mortal(newRV_inc(sv)));
1180
22
 PUSHs(mg->mg_obj ? mg->mg_obj : &PL_sv_undef);
1181
22
 if (w->opinfo)
1182
4
  XPUSHs(vmg_op_info(w->opinfo));
1183
22
 PUTBACK;
1184
1185
22
 vmg_call_sv(w->cb_free, G_SCALAR, 1);
1186
1187
20
 SPAGAIN;
1188
20
 svr = POPs;
1189
20
 if (SvOK(svr))
1190
10
  ret = (int) SvIV(svr);
1191
20
 PUTBACK;
1192
1193
20
 FREETMPS;
1194
20
 LEAVE;
1195
1196 /* Calling SvREFCNT_dec() will trigger destructors in an infinite loop, so
1197  * we have to rely on SvREFCNT() being a lvalue. Heck, even the core does it */
1198
20
 --SvREFCNT(sv);
1199
1200 /* Perl_mg_free will get rid of the magic and decrement mg->mg_obj and
1201  * mg->mg_ptr reference count */
1202
21
 return ret;
1203}
1204
1205#if MGf_COPY
1206
21
STATIC int vmg_svt_copy(pTHX_ SV *sv, MAGIC *mg, SV *nsv, const char *key,
1207# if VMG_HAS_PERL_MAINT(5, 11, 0, 33256) || VMG_HAS_PERL(5, 12, 0)
1208  I32 keylen
1209# else
1210  int keylen
1211# endif
1212 ) {
1213 SV *keysv;
1214
21
 const MGWIZ *w = vmg_wizard_mgwiz(mg->mg_ptr);
1215 int ret;
1216
1217
21
 if (keylen == HEf_SVKEY) {
1218
13
  keysv = (SV *) key;
1219 } else {
1220
8
  keysv = newSVpvn(key, keylen);
1221 }
1222
1223
21
 ret = vmg_cb_call3(w->cb_copy, w->opinfo, sv, mg->mg_obj, keysv, nsv);
1224
1225
21
 if (keylen != HEf_SVKEY) {
1226
8
  SvREFCNT_dec(keysv);
1227 }
1228
1229
21
 return ret;
1230}
1231#endif /* MGf_COPY */
1232
1233#if 0 /* MGf_DUP */
1234STATIC int vmg_svt_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) {
1235 return 0;
1236}
1237#endif /* MGf_DUP */
1238
1239#if MGf_LOCAL
1240
1
STATIC int vmg_svt_local(pTHX_ SV *nsv, MAGIC *mg) {
1241
1
 const MGWIZ *w = vmg_wizard_mgwiz(mg->mg_ptr);
1242
1
 return vmg_cb_call1(w->cb_local, w->opinfo, nsv, mg->mg_obj);
1243}
1244#endif /* MGf_LOCAL */
1245
1246#if VMG_UVAR
1247
10
STATIC OP *vmg_pp_resetuvar(pTHX) {
1248
10
 SvRMAGICAL_on(cSVOP_sv);
1249
10
 return NORMAL;
1250}
1251
1252
149
STATIC I32 vmg_svt_val(pTHX_ IV action, SV *sv) {
1253 struct ufuncs *uf;
1254 MAGIC *mg, *umg;
1255
149
 SV *key = NULL, *newkey = NULL;
1256
149
 int tied = 0;
1257
1258
149
 umg = mg_find(sv, PERL_MAGIC_uvar);
1259 /* umg can't be NULL or we wouldn't be there. */
1260
149
 key = umg->mg_obj;
1261
149
 uf = (struct ufuncs *) umg->mg_ptr;
1262
1263
149
 if (uf[1].uf_val)
1264
3
  uf[1].uf_val(aTHX_ action, sv);
1265
149
 if (uf[1].uf_set)
1266
0
  uf[1].uf_set(aTHX_ action, sv);
1267
1268
149
 action &= HV_FETCH_ISSTORE | HV_FETCH_ISEXISTS | HV_FETCH_LVALUE | HV_DELETE;
1269
461
 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
1270  const MGWIZ *w;
1271
312
  switch (mg->mg_type) {
1272   case PERL_MAGIC_ext:
1273    break;
1274   case PERL_MAGIC_tied:
1275
4
    ++tied;
1276
4
    continue;
1277   default:
1278
149
    continue;
1279  }
1280
159
  if (mg->mg_private != SIG_WIZ) continue;
1281
159
  w = vmg_wizard_mgwiz(mg->mg_ptr);
1282
159
  switch (w->uvar) {
1283   case 0:
1284
1
    continue;
1285   case 2:
1286
24
    if (!newkey)
1287
24
     newkey = key = umg->mg_obj = sv_mortalcopy(umg->mg_obj);
1288  }
1289
158
  switch (action) {
1290   case 0:
1291
62
    if (w->cb_fetch)
1292
48
     vmg_cb_call2(w->cb_fetch, w->opinfo, sv, mg->mg_obj, key);
1293
62
    break;
1294   case HV_FETCH_ISSTORE:
1295   case HV_FETCH_LVALUE:
1296   case (HV_FETCH_ISSTORE|HV_FETCH_LVALUE):
1297
61
    if (w->cb_store)
1298
60
     vmg_cb_call2(w->cb_store, w->opinfo, sv, mg->mg_obj, key);
1299
61
    break;
1300   case HV_FETCH_ISEXISTS:
1301
23
    if (w->cb_exists)
1302
9
     vmg_cb_call2(w->cb_exists, w->opinfo, sv, mg->mg_obj, key);
1303
23
    break;
1304   case HV_DELETE:
1305
4
    if (w->cb_delete)
1306
4
     vmg_cb_call2(w->cb_delete, w->opinfo, sv, mg->mg_obj, key);
1307
4
    break;
1308  }
1309 }
1310
1311
149
 if (SvRMAGICAL(sv) && !tied) {
1312  /* Temporarily hide the RMAGICAL flag of the hash so it isn't wrongly
1313   * mistaken for a tied hash by the rest of hv_common. It will be reset by
1314   * the op_ppaddr of a new fake op injected between the current and the next
1315   * one. */
1316
10
  OP *o = PL_op;
1317
10
  if (!o->op_next || o->op_next->op_ppaddr != vmg_pp_resetuvar) {
1318   SVOP *svop;
1319
8
   NewOp(1101, svop, 1, SVOP);
1320
8
   svop->op_type = OP_STUB;
1321
8
   svop->op_ppaddr = vmg_pp_resetuvar;
1322
8
   svop->op_next = o->op_next;
1323
8
   svop->op_flags = 0;
1324
8
   svop->op_sv = sv;
1325
8
   o->op_next = (OP *) svop;
1326  }
1327
10
  SvRMAGICAL_off(sv);
1328 }
1329
1330
149
 return 0;
1331}
1332#endif /* VMG_UVAR */
1333
1334/* --- Macros for the XS section ------------------------------------------- */
1335
1336#define VMG_SET_CB(S, N) \
1337 cb = (S); \
1338 w->cb_ ## N = (SvOK(cb) && SvROK(cb)) ? SvREFCNT_inc(SvRV(cb)) : NULL;
1339
1340#define VMG_SET_SVT_CB(S, N) \
1341 cb = (S); \
1342 if (SvOK(cb) && SvROK(cb)) { \
1343  t->svt_ ## N = vmg_svt_ ## N; \
1344  w->cb_ ## N = SvREFCNT_inc(SvRV(cb)); \
1345 } else { \
1346  t->svt_ ## N = NULL; \
1347  w->cb_ ## N = NULL; \
1348 }
1349
1350#if VMG_THREADSAFE
1351
1352STATIC void vmg_cleanup(pTHX_ void *ud) {
1353 dMY_CXT;
1354
1355 ptable_free(MY_CXT.wizards);
1356 MY_CXT.wizards = NULL;
1357}
1358
1359#endif /* VMG_THREADSAFE */
1360
1361/* --- XS ------------------------------------------------------------------ */
1362
1363MODULE = Variable::Magic PACKAGE = Variable::Magic
1364
1365PROTOTYPES: ENABLE
1366
1367BOOT:
1368{
1369 HV *stash;
1370
1371 MY_CXT_INIT;
1372#if VMG_THREADSAFE
1373 MY_CXT.wizards = ptable_new();
1374 MY_CXT.owner = aTHX;
1375#endif
1376
26
 MY_CXT.b__op_stashes[0] = NULL;
1377#if VMG_THREADSAFE
1378 MUTEX_INIT(&vmg_op_name_init_mutex);
1379 call_atexit(vmg_cleanup, NULL);
1380#endif
1381
1382
26
 stash = gv_stashpv(__PACKAGE__, 1);
1383
26
 newCONSTSUB(stash, "MGf_COPY", newSVuv(MGf_COPY));
1384
26
 newCONSTSUB(stash, "MGf_DUP", newSVuv(MGf_DUP));
1385
26
 newCONSTSUB(stash, "MGf_LOCAL", newSVuv(MGf_LOCAL));
1386
26
 newCONSTSUB(stash, "VMG_UVAR", newSVuv(VMG_UVAR));
1387
26
 newCONSTSUB(stash, "VMG_COMPAT_ARRAY_PUSH_NOLEN",
1388                    newSVuv(VMG_COMPAT_ARRAY_PUSH_NOLEN));
1389
26
 newCONSTSUB(stash, "VMG_COMPAT_ARRAY_PUSH_NOLEN_VOID",
1390                    newSVuv(VMG_COMPAT_ARRAY_PUSH_NOLEN_VOID));
1391
26
 newCONSTSUB(stash, "VMG_COMPAT_ARRAY_UNSHIFT_NOLEN_VOID",
1392                    newSVuv(VMG_COMPAT_ARRAY_UNSHIFT_NOLEN_VOID));
1393
26
 newCONSTSUB(stash, "VMG_COMPAT_ARRAY_UNDEF_CLEAR",
1394                    newSVuv(VMG_COMPAT_ARRAY_UNDEF_CLEAR));
1395
26
 newCONSTSUB(stash, "VMG_COMPAT_SCALAR_LENGTH_NOLEN",
1396                    newSVuv(VMG_COMPAT_SCALAR_LENGTH_NOLEN));
1397
26
 newCONSTSUB(stash, "VMG_COMPAT_GLOB_GET", newSVuv(VMG_COMPAT_GLOB_GET));
1398
26
 newCONSTSUB(stash, "VMG_PERL_PATCHLEVEL", newSVuv(VMG_PERL_PATCHLEVEL));
1399
26
 newCONSTSUB(stash, "VMG_THREADSAFE", newSVuv(VMG_THREADSAFE));
1400
26
 newCONSTSUB(stash, "VMG_FORKSAFE", newSVuv(VMG_FORKSAFE));
1401
26
 newCONSTSUB(stash, "VMG_OP_INFO_NAME", newSVuv(VMG_OP_INFO_NAME));
1402
26
 newCONSTSUB(stash, "VMG_OP_INFO_OBJECT", newSVuv(VMG_OP_INFO_OBJECT));
1403}
1404
1405#if VMG_THREADSAFE
1406
1407void
1408CLONE(...)
1409PROTOTYPE: DISABLE
1410PREINIT:
1411 ptable *t;
1412 U32 had_b__op_stash = 0;
1413 int c;
1414PPCODE:
1415 {
1416  my_cxt_t ud;
1417  dMY_CXT;
1418
1419  ud.wizards = t = ptable_new();
1420  ud.owner = MY_CXT.owner;
1421  ptable_walk(MY_CXT.wizards, vmg_ptable_clone, &ud);
1422
1423  for (c = OPc_NULL; c < OPc_MAX; ++c) {
1424   if (MY_CXT.b__op_stashes[c])
1425    had_b__op_stash |= (((U32) 1) << c);
1426  }
1427 }
1428 {
1429  MY_CXT_CLONE;
1430  MY_CXT.wizards = t;
1431  MY_CXT.owner = aTHX;
1432  for (c = OPc_NULL; c < OPc_MAX; ++c) {
1433   MY_CXT.b__op_stashes[c] = (had_b__op_stash & (((U32) 1) << c))
1434                              ? gv_stashpv(vmg_opclassnames[c], 1) : NULL;
1435  }
1436 }
1437 XSRETURN(0);
1438
1439#endif /* VMG_THREADSAFE */
1440
1441SV *_wizard(...)
1442PROTOTYPE: DISABLE
1443PREINIT:
1444
120
 I32 i = 0;
1445 UV opinfo;
1446 MGWIZ *w;
1447 MGVTBL *t;
1448 SV *cb;
1449CODE:
1450 dMY_CXT;
1451
1452
120
 if (items != 7
1453#if MGf_COPY
1454              + 1
1455#endif /* MGf_COPY */
1456#if MGf_DUP
1457              + 1
1458#endif /* MGf_DUP */
1459#if MGf_LOCAL
1460              + 1
1461#endif /* MGf_LOCAL */
1462#if VMG_UVAR
1463              + 5
1464#endif /* VMG_UVAR */
1465
20
              ) { croak(vmg_wrongargnum); }
1466
1467
100
 Newx(t, 1, MGVTBL);
1468
100
 Newx(w, 1, MGWIZ);
1469
1470
100
 VMG_SET_CB(ST(i++), data);
1471
1472
100
 cb = ST(i++);
1473
100
 opinfo = SvOK(cb) ? SvUV(cb) : 0;
1474
99
 w->opinfo = (U8) ((opinfo < 255) ? opinfo : 255);
1475
99
 if (w->opinfo)
1476
37
  vmg_op_info_init(w->opinfo);
1477
1478
99
 VMG_SET_SVT_CB(ST(i++), get);
1479
99
 VMG_SET_SVT_CB(ST(i++), set);
1480
99
 VMG_SET_SVT_CB(ST(i++), len);
1481
99
 VMG_SET_SVT_CB(ST(i++), clear);
1482
99
 VMG_SET_SVT_CB(ST(i++), free);
1483#if MGf_COPY
1484
99
 VMG_SET_SVT_CB(ST(i++), copy);
1485#endif /* MGf_COPY */
1486#if MGf_DUP
1487 /* VMG_SET_SVT_CB(ST(i++), dup); */
1488
99
 i++;
1489
99
 t->svt_dup = NULL;
1490
99
 w->cb_dup = NULL;
1491#endif /* MGf_DUP */
1492#if MGf_LOCAL
1493
99
 VMG_SET_SVT_CB(ST(i++), local);
1494#endif /* MGf_LOCAL */
1495#if VMG_UVAR
1496
99
 VMG_SET_CB(ST(i++), fetch);
1497
99
 VMG_SET_CB(ST(i++), store);
1498
99
 VMG_SET_CB(ST(i++), exists);
1499
99
 VMG_SET_CB(ST(i++), delete);
1500
99
 cb = ST(i++);
1501
99
 if (w->cb_fetch || w->cb_store || w->cb_exists || w->cb_delete)
1502
19
  w->uvar = SvTRUE(cb) ? 2 : 1;
1503 else
1504
80
  w->uvar = 0;
1505#endif /* VMG_UVAR */
1506#if VMG_MULTIPLICITY
1507 w->owner = aTHX;
1508#endif /* VMG_MULTIPLICITY */
1509
99
 w->vtbl = t;
1510#if VMG_THREADSAFE
1511 ptable_store(MY_CXT.wizards, w, w);
1512#endif /* VMG_THREADSAFE */
1513
1514
99
 RETVAL = newRV_noinc(vmg_wizard_new(w));
1515OUTPUT:
1516 RETVAL
1517
1518SV *cast(SV *sv, SV *wiz, ...)
1519PROTOTYPE: \[$@%&*]$@
1520PREINIT:
1521
145
 SV **args = NULL;
1522
145
 I32 i = 0;
1523CODE:
1524
145
 if (items > 2) {
1525
36
  i = items - 2;
1526
36
  args = &ST(2);
1527 }
1528
145
 RETVAL = newSVuv(vmg_cast(SvRV(sv), vmg_wizard_validate(wiz), args, i));
1529OUTPUT:
1530 RETVAL
1531
1532void
1533getdata(SV *sv, SV *wiz)
1534PROTOTYPE: \[$@%&*]$
1535PREINIT:
1536 SV *data;
1537PPCODE:
1538
12
 data = vmg_data_get(SvRV(sv), vmg_wizard_validate(wiz));
1539
10
 if (!data)
1540
2
  XSRETURN_EMPTY;
1541
8
 ST(0) = data;
1542
10
 XSRETURN(1);
1543
1544SV *dispell(SV *sv, SV *wiz)
1545PROTOTYPE: \[$@%&*]$
1546CODE:
1547
32
 RETVAL = newSVuv(vmg_dispell(SvRV(sv), vmg_wizard_validate(wiz)));
1548OUTPUT:
1549 RETVAL