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