1################################################################################ 2## 3## Version 3.x, Copyright (C) 2004-2013, Marcus Holland-Moritz. 4## Version 2.x, Copyright (C) 2001, Paul Marquess. 5## Version 1.x, Copyright (C) 1999, Kenneth Albanowski. 6## 7## This program is free software; you can redistribute it and/or 8## modify it under the same terms as Perl itself. 9## 10################################################################################ 11 12=provides 13 14mg_findext 15sv_unmagicext 16 17__UNDEFINED__ 18/sv_\w+_mg/ 19sv_magic_portable 20 21SvIV_nomg 22SvUV_nomg 23SvNV_nomg 24SvTRUE_nomg 25 26=implementation 27 28#undef SvGETMAGIC 29__UNDEFINED__ SvGETMAGIC(x) ((void)(UNLIKELY(SvGMAGICAL(x)) && mg_get(x))) 30 31/* That's the best we can do... */ 32__UNDEFINED__ sv_catpvn_nomg sv_catpvn 33__UNDEFINED__ sv_catsv_nomg sv_catsv 34__UNDEFINED__ sv_setsv_nomg sv_setsv 35__UNDEFINED__ sv_pvn_nomg sv_pvn 36 37#ifdef SVf_IVisUV 38#if defined(PERL_USE_GCC_BRACE_GROUPS) 39__UNDEFINED__ SvIV_nomg(sv) (!SvGMAGICAL((sv)) ? SvIV((sv)) : ({ SV *_sviv = sv_mortalcopy_flags((sv), SV_NOSTEAL); IV _iv = SvIV(_sviv); SvFLAGS((sv)) = (SvFLAGS((sv)) & ~SVf_IVisUV) | (SvFLAGS(_sviv) & SVf_IVisUV); _iv; })) 40__UNDEFINED__ SvUV_nomg(sv) (!SvGMAGICAL((sv)) ? SvUV((sv)) : ({ SV *_svuv = sv_mortalcopy_flags((sv), SV_NOSTEAL); UV _uv = SvUV(_svuv); SvFLAGS((sv)) = (SvFLAGS((sv)) & ~SVf_IVisUV) | (SvFLAGS(_svuv) & SVf_IVisUV); _uv; })) 41#else 42__UNDEFINED__ SvIV_nomg(sv) (!SvGMAGICAL((sv)) ? SvIV((sv)) : ((PL_Sv = sv_mortalcopy_flags((sv), SV_NOSTEAL)), sv_upgrade(PL_Sv, SVt_PVIV), (SvIVX(PL_Sv) = SvIV(PL_Sv)), (SvFLAGS((sv)) = (SvFLAGS((sv)) & ~SVf_IVisUV) | (SvFLAGS(PL_Sv) & SVf_IVisUV)), SvIVX(PL_Sv))) 43__UNDEFINED__ SvUV_nomg(sv) (!SvGMAGICAL((sv)) ? SvIV((sv)) : ((PL_Sv = sv_mortalcopy_flags((sv), SV_NOSTEAL)), sv_upgrade(PL_Sv, SVt_PVIV), (SvUVX(PL_Sv) = SvUV(PL_Sv)), (SvFLAGS((sv)) = (SvFLAGS((sv)) & ~SVf_IVisUV) | (SvFLAGS(PL_Sv) & SVf_IVisUV)), SvUVX(PL_Sv))) 44#endif 45#else 46__UNDEFINED__ SvIV_nomg(sv) (!SvGMAGICAL((sv)) ? SvIV((sv)) : SvIVx(sv_mortalcopy_flags((sv), SV_NOSTEAL))) 47__UNDEFINED__ SvUV_nomg(sv) (!SvGMAGICAL((sv)) ? SvUV((sv)) : SvUVx(sv_mortalcopy_flags((sv), SV_NOSTEAL))) 48#endif 49 50__UNDEFINED__ SvNV_nomg(sv) (!SvGMAGICAL((sv)) ? SvNV((sv)) : SvNVx(sv_mortalcopy_flags((sv), SV_NOSTEAL))) 51__UNDEFINED__ SvTRUE_nomg(sv) (!SvGMAGICAL((sv)) ? SvTRUE((sv)) : SvTRUEx(sv_mortalcopy_flags((sv), SV_NOSTEAL))) 52 53#ifndef sv_catpv_mg 54# define sv_catpv_mg(sv, ptr) \ 55 STMT_START { \ 56 SV *TeMpSv = sv; \ 57 sv_catpv(TeMpSv,ptr); \ 58 SvSETMAGIC(TeMpSv); \ 59 } STMT_END 60#endif 61 62#ifndef sv_catpvn_mg 63# define sv_catpvn_mg(sv, ptr, len) \ 64 STMT_START { \ 65 SV *TeMpSv = sv; \ 66 sv_catpvn(TeMpSv,ptr,len); \ 67 SvSETMAGIC(TeMpSv); \ 68 } STMT_END 69#endif 70 71#ifndef sv_catsv_mg 72# define sv_catsv_mg(dsv, ssv) \ 73 STMT_START { \ 74 SV *TeMpSv = dsv; \ 75 sv_catsv(TeMpSv,ssv); \ 76 SvSETMAGIC(TeMpSv); \ 77 } STMT_END 78#endif 79 80#ifndef sv_setiv_mg 81# define sv_setiv_mg(sv, i) \ 82 STMT_START { \ 83 SV *TeMpSv = sv; \ 84 sv_setiv(TeMpSv,i); \ 85 SvSETMAGIC(TeMpSv); \ 86 } STMT_END 87#endif 88 89#ifndef sv_setnv_mg 90# define sv_setnv_mg(sv, num) \ 91 STMT_START { \ 92 SV *TeMpSv = sv; \ 93 sv_setnv(TeMpSv,num); \ 94 SvSETMAGIC(TeMpSv); \ 95 } STMT_END 96#endif 97 98#ifndef sv_setpv_mg 99# define sv_setpv_mg(sv, ptr) \ 100 STMT_START { \ 101 SV *TeMpSv = sv; \ 102 sv_setpv(TeMpSv,ptr); \ 103 SvSETMAGIC(TeMpSv); \ 104 } STMT_END 105#endif 106 107#ifndef sv_setpvn_mg 108# define sv_setpvn_mg(sv, ptr, len) \ 109 STMT_START { \ 110 SV *TeMpSv = sv; \ 111 sv_setpvn(TeMpSv,ptr,len); \ 112 SvSETMAGIC(TeMpSv); \ 113 } STMT_END 114#endif 115 116#ifndef sv_setsv_mg 117# define sv_setsv_mg(dsv, ssv) \ 118 STMT_START { \ 119 SV *TeMpSv = dsv; \ 120 sv_setsv(TeMpSv,ssv); \ 121 SvSETMAGIC(TeMpSv); \ 122 } STMT_END 123#endif 124 125#ifndef sv_setuv_mg 126# define sv_setuv_mg(sv, i) \ 127 STMT_START { \ 128 SV *TeMpSv = sv; \ 129 sv_setuv(TeMpSv,i); \ 130 SvSETMAGIC(TeMpSv); \ 131 } STMT_END 132#endif 133 134#ifndef sv_usepvn_mg 135# define sv_usepvn_mg(sv, ptr, len) \ 136 STMT_START { \ 137 SV *TeMpSv = sv; \ 138 sv_usepvn(TeMpSv,ptr,len); \ 139 SvSETMAGIC(TeMpSv); \ 140 } STMT_END 141#endif 142 143__UNDEFINED__ SvVSTRING_mg(sv) (SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_vstring) : NULL) 144 145/* Hint: sv_magic_portable 146 * This is a compatibility function that is only available with 147 * Devel::PPPort. It is NOT in the perl core. 148 * Its purpose is to mimic the 5.8.0 behaviour of sv_magic() when 149 * it is being passed a name pointer with namlen == 0. In that 150 * case, perl 5.8.0 and later store the pointer, not a copy of it. 151 * The compatibility can be provided back to perl 5.004. With 152 * earlier versions, the code will not compile. 153 */ 154 155#if { VERSION < 5.004 } 156 157 /* code that uses sv_magic_portable will not compile */ 158 159#elif { VERSION < 5.8.0 } 160 161# define sv_magic_portable(sv, obj, how, name, namlen) \ 162 STMT_START { \ 163 SV *SvMp_sv = (sv); \ 164 char *SvMp_name = (char *) (name); \ 165 I32 SvMp_namlen = (namlen); \ 166 if (SvMp_name && SvMp_namlen == 0) \ 167 { \ 168 MAGIC *mg; \ 169 sv_magic(SvMp_sv, obj, how, 0, 0); \ 170 mg = SvMAGIC(SvMp_sv); \ 171 mg->mg_len = -42; /* XXX: this is the tricky part */ \ 172 mg->mg_ptr = SvMp_name; \ 173 } \ 174 else \ 175 { \ 176 sv_magic(SvMp_sv, obj, how, SvMp_name, SvMp_namlen); \ 177 } \ 178 } STMT_END 179 180#else 181 182# define sv_magic_portable(a, b, c, d, e) sv_magic(a, b, c, d, e) 183 184#endif 185 186#if !defined(mg_findext) 187#if { NEED mg_findext } 188 189MAGIC * 190mg_findext(const SV * sv, int type, const MGVTBL *vtbl) { 191 if (sv) { 192 MAGIC *mg; 193 194#ifdef AvPAD_NAMELIST 195 assert(!(SvTYPE(sv) == SVt_PVAV && AvPAD_NAMELIST(sv))); 196#endif 197 198 for (mg = SvMAGIC (sv); mg; mg = mg->mg_moremagic) { 199 if (mg->mg_type == type && mg->mg_virtual == vtbl) 200 return mg; 201 } 202 } 203 204 return NULL; 205} 206 207#endif 208#endif 209 210#if !defined(sv_unmagicext) 211#if { NEED sv_unmagicext } 212 213int 214sv_unmagicext(pTHX_ SV *const sv, const int type, const MGVTBL *vtbl) 215{ 216 MAGIC* mg; 217 MAGIC** mgp; 218 219 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv)) 220 return 0; 221 mgp = &(SvMAGIC(sv)); 222 for (mg = *mgp; mg; mg = *mgp) { 223 const MGVTBL* const virt = mg->mg_virtual; 224 if (mg->mg_type == type && virt == vtbl) { 225 *mgp = mg->mg_moremagic; 226 if (virt && virt->svt_free) 227 virt->svt_free(aTHX_ sv, mg); 228 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) { 229 if (mg->mg_len > 0) 230 Safefree(mg->mg_ptr); 231 else if (mg->mg_len == HEf_SVKEY) /* Questionable on older perls... */ 232 SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr)); 233 else if (mg->mg_type == PERL_MAGIC_utf8) 234 Safefree(mg->mg_ptr); 235 } 236 if (mg->mg_flags & MGf_REFCOUNTED) 237 SvREFCNT_dec(mg->mg_obj); 238 Safefree(mg); 239 } 240 else 241 mgp = &mg->mg_moremagic; 242 } 243 if (SvMAGIC(sv)) { 244 if (SvMAGICAL(sv)) /* if we're under save_magic, wait for restore_magic; */ 245 mg_magical(sv); /* else fix the flags now */ 246 } 247 else { 248 SvMAGICAL_off(sv); 249 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT; 250 } 251 return 0; 252} 253 254#endif 255#endif 256 257=xsinit 258 259#define NEED_mg_findext 260#define NEED_sv_unmagicext 261 262#ifndef STATIC 263#define STATIC static 264#endif 265 266STATIC MGVTBL null_mg_vtbl = { 267 NULL, /* get */ 268 NULL, /* set */ 269 NULL, /* len */ 270 NULL, /* clear */ 271 NULL, /* free */ 272#if MGf_COPY 273 NULL, /* copy */ 274#endif /* MGf_COPY */ 275#if MGf_DUP 276 NULL, /* dup */ 277#endif /* MGf_DUP */ 278#if MGf_LOCAL 279 NULL, /* local */ 280#endif /* MGf_LOCAL */ 281}; 282 283STATIC MGVTBL other_mg_vtbl = { 284 NULL, /* get */ 285 NULL, /* set */ 286 NULL, /* len */ 287 NULL, /* clear */ 288 NULL, /* free */ 289#if MGf_COPY 290 NULL, /* copy */ 291#endif /* MGf_COPY */ 292#if MGf_DUP 293 NULL, /* dup */ 294#endif /* MGf_DUP */ 295#if MGf_LOCAL 296 NULL, /* local */ 297#endif /* MGf_LOCAL */ 298}; 299 300=xsubs 301 302SV * 303new_with_other_mg(package, ...) 304 SV *package 305 PREINIT: 306 HV *self; 307 HV *stash; 308 SV *self_ref; 309 const char *data = "hello\0"; 310 MAGIC *mg; 311 CODE: 312 self = newHV(); 313 stash = gv_stashpv(SvPV_nolen(package), 0); 314 315 self_ref = newRV_noinc((SV*)self); 316 317 sv_magic((SV*)self, NULL, PERL_MAGIC_ext, data, strlen(data)); 318 mg = mg_find((SV*)self, PERL_MAGIC_ext); 319 if (mg) 320 mg->mg_virtual = &other_mg_vtbl; 321 else 322 croak("No mg!"); 323 324 RETVAL = sv_bless(self_ref, stash); 325 OUTPUT: 326 RETVAL 327 328SV * 329new_with_mg(package, ...) 330 SV *package 331 PREINIT: 332 HV *self; 333 HV *stash; 334 SV *self_ref; 335 const char *data = "hello\0"; 336 MAGIC *mg; 337 CODE: 338 self = newHV(); 339 stash = gv_stashpv(SvPV_nolen(package), 0); 340 341 self_ref = newRV_noinc((SV*)self); 342 343 sv_magic((SV*)self, NULL, PERL_MAGIC_ext, data, strlen(data)); 344 mg = mg_find((SV*)self, PERL_MAGIC_ext); 345 if (mg) 346 mg->mg_virtual = &null_mg_vtbl; 347 else 348 croak("No mg!"); 349 350 RETVAL = sv_bless(self_ref, stash); 351 OUTPUT: 352 RETVAL 353 354void 355remove_null_magic(self) 356 SV *self 357 PREINIT: 358 HV *obj; 359 PPCODE: 360 obj = (HV*) SvRV(self); 361 362 sv_unmagicext((SV*)obj, PERL_MAGIC_ext, &null_mg_vtbl); 363 364void 365remove_other_magic(self) 366 SV *self 367 PREINIT: 368 HV *obj; 369 PPCODE: 370 obj = (HV*) SvRV(self); 371 372 sv_unmagicext((SV*)obj, PERL_MAGIC_ext, &other_mg_vtbl); 373 374void 375as_string(self) 376 SV *self 377 PREINIT: 378 HV *obj; 379 MAGIC *mg; 380 PPCODE: 381 obj = (HV*) SvRV(self); 382 383 if ((mg = mg_findext((SV*)obj, PERL_MAGIC_ext, &null_mg_vtbl))) { 384 XPUSHs(sv_2mortal(newSVpv(mg->mg_ptr, strlen(mg->mg_ptr)))); 385 } else { 386 XPUSHs(sv_2mortal(newSVpvs("Sorry, your princess is in another castle."))); 387 } 388 389void 390sv_catpv_mg(sv, string) 391 SV *sv; 392 char *string; 393 CODE: 394 sv_catpv_mg(sv, string); 395 396void 397sv_catpvn_mg(sv, sv2) 398 SV *sv; 399 SV *sv2; 400 PREINIT: 401 char *str; 402 STRLEN len; 403 CODE: 404 str = SvPV(sv2, len); 405 sv_catpvn_mg(sv, str, len); 406 407void 408sv_catsv_mg(sv, sv2) 409 SV *sv; 410 SV *sv2; 411 CODE: 412 sv_catsv_mg(sv, sv2); 413 414void 415sv_setiv_mg(sv, iv) 416 SV *sv; 417 IV iv; 418 CODE: 419 sv_setiv_mg(sv, iv); 420 421void 422sv_setnv_mg(sv, nv) 423 SV *sv; 424 NV nv; 425 CODE: 426 sv_setnv_mg(sv, nv); 427 428void 429sv_setpv_mg(sv, pv) 430 SV *sv; 431 char *pv; 432 CODE: 433 sv_setpv_mg(sv, pv); 434 435void 436sv_setpvn_mg(sv, sv2) 437 SV *sv; 438 SV *sv2; 439 PREINIT: 440 char *str; 441 STRLEN len; 442 CODE: 443 str = SvPV(sv2, len); 444 sv_setpvn_mg(sv, str, len); 445 446void 447sv_setsv_mg(sv, sv2) 448 SV *sv; 449 SV *sv2; 450 CODE: 451 sv_setsv_mg(sv, sv2); 452 453void 454sv_setuv_mg(sv, uv) 455 SV *sv; 456 UV uv; 457 CODE: 458 sv_setuv_mg(sv, uv); 459 460void 461sv_usepvn_mg(sv, sv2) 462 SV *sv; 463 SV *sv2; 464 PREINIT: 465 char *str, *copy; 466 STRLEN len; 467 CODE: 468 str = SvPV(sv2, len); 469 New(42, copy, len+1, char); 470 Copy(str, copy, len+1, char); 471 sv_usepvn_mg(sv, copy, len); 472 473int 474SvVSTRING_mg(sv) 475 SV *sv; 476 CODE: 477 RETVAL = SvVSTRING_mg(sv) != NULL; 478 OUTPUT: 479 RETVAL 480 481int 482sv_magic_portable(sv) 483 SV *sv 484 PREINIT: 485 MAGIC *mg; 486 const char *foo = "foo"; 487 CODE: 488#if { VERSION >= 5.004 } 489 sv_magic_portable(sv, 0, '~', foo, 0); 490 mg = mg_find(sv, '~'); 491 if (!mg) 492 croak("No mg!"); 493 494 RETVAL = mg->mg_ptr == foo; 495#else 496 sv_magic(sv, 0, '~', (char *) foo, strlen(foo)); 497 mg = mg_find(sv, '~'); 498 RETVAL = strEQ(mg->mg_ptr, foo); 499#endif 500 sv_unmagic(sv, '~'); 501 OUTPUT: 502 RETVAL 503 504UV 505above_IV_MAX() 506 CODE: 507 RETVAL = (UV)IV_MAX+100; 508 OUTPUT: 509 RETVAL 510 511#ifdef SVf_IVisUV 512 513U32 514SVf_IVisUV(sv) 515 SV *sv 516 CODE: 517 RETVAL = (SvFLAGS(sv) & SVf_IVisUV); 518 OUTPUT: 519 RETVAL 520 521#endif 522 523#ifdef SvIV_nomg 524 525IV 526magic_SvIV_nomg(sv) 527 SV *sv 528 CODE: 529 RETVAL = SvIV_nomg(sv); 530 OUTPUT: 531 RETVAL 532 533#endif 534 535#ifdef SvUV_nomg 536 537UV 538magic_SvUV_nomg(sv) 539 SV *sv 540 CODE: 541 RETVAL = SvUV_nomg(sv); 542 OUTPUT: 543 RETVAL 544 545#endif 546 547#ifdef SvNV_nomg 548 549NV 550magic_SvNV_nomg(sv) 551 SV *sv 552 CODE: 553 RETVAL = SvNV_nomg(sv); 554 OUTPUT: 555 RETVAL 556 557#endif 558 559#ifdef SvTRUE_nomg 560 561bool 562magic_SvTRUE_nomg(sv) 563 SV *sv 564 CODE: 565 RETVAL = SvTRUE_nomg(sv); 566 OUTPUT: 567 RETVAL 568 569#endif 570 571#ifdef SvPV_nomg_nolen 572 573char * 574magic_SvPV_nomg_nolen(sv) 575 SV *sv 576 CODE: 577 RETVAL = SvPV_nomg_nolen(sv); 578 OUTPUT: 579 RETVAL 580 581#endif 582 583=tests plan => 63 584 585# Find proper magic 586ok(my $obj1 = Devel::PPPort->new_with_mg()); 587is(Devel::PPPort::as_string($obj1), 'hello'); 588 589# Find with no magic 590my $obj = bless {}, 'Fake::Class'; 591is(Devel::PPPort::as_string($obj), "Sorry, your princess is in another castle."); 592 593# Find with other magic (not the magic we are looking for) 594ok($obj = Devel::PPPort->new_with_other_mg()); 595is(Devel::PPPort::as_string($obj), "Sorry, your princess is in another castle."); 596 597# Okay, attempt to remove magic that isn't there 598Devel::PPPort::remove_other_magic($obj1); 599is(Devel::PPPort::as_string($obj1), 'hello'); 600 601# Remove magic that IS there 602Devel::PPPort::remove_null_magic($obj1); 603is(Devel::PPPort::as_string($obj1), "Sorry, your princess is in another castle."); 604 605# Removing when no magic present 606Devel::PPPort::remove_null_magic($obj1); 607is(Devel::PPPort::as_string($obj1), "Sorry, your princess is in another castle."); 608 609use Tie::Hash; 610my %h; 611tie %h, 'Tie::StdHash'; 612$h{foo} = 'foo'; 613$h{bar} = ''; 614 615&Devel::PPPort::sv_catpv_mg($h{foo}, 'bar'); 616is($h{foo}, 'foobar'); 617 618&Devel::PPPort::sv_catpvn_mg($h{bar}, 'baz'); 619is($h{bar}, 'baz'); 620 621&Devel::PPPort::sv_catsv_mg($h{foo}, '42'); 622is($h{foo}, 'foobar42'); 623 624&Devel::PPPort::sv_setiv_mg($h{bar}, 42); 625is($h{bar}, 42); 626 627&Devel::PPPort::sv_setnv_mg($h{PI}, 3.14159); 628ok(abs($h{PI} - 3.14159) < 0.01); 629 630&Devel::PPPort::sv_setpv_mg($h{mhx}, 'mhx'); 631is($h{mhx}, 'mhx'); 632 633&Devel::PPPort::sv_setpvn_mg($h{mhx}, 'Marcus'); 634is($h{mhx}, 'Marcus'); 635 636&Devel::PPPort::sv_setsv_mg($h{sv}, 'SV'); 637is($h{sv}, 'SV'); 638 639&Devel::PPPort::sv_setuv_mg($h{sv}, 4711); 640is($h{sv}, 4711); 641 642&Devel::PPPort::sv_usepvn_mg($h{sv}, 'Perl'); 643is($h{sv}, 'Perl'); 644 645# v1 is treated as a bareword in older perls... 646my $ver = do { local $SIG{'__WARN__'} = sub {}; eval qq[v1.2.0] }; 647ok(ivers($]) < ivers("5.009") || $@ eq ''); 648ok(ivers($]) < ivers("5.009") || Devel::PPPort::SvVSTRING_mg($ver)); 649ok(!Devel::PPPort::SvVSTRING_mg(4711)); 650 651my $foo = 'bar'; 652ok(Devel::PPPort::sv_magic_portable($foo)); 653ok($foo eq 'bar'); 654 655 tie my $scalar, 'TieScalarCounter', 10; 656 my $fetch = $scalar; 657 658 is tied($scalar)->{fetch}, 1; 659 is tied($scalar)->{store}, 0; 660 is Devel::PPPort::magic_SvIV_nomg($scalar), 10; 661 is tied($scalar)->{fetch}, 1; 662 is tied($scalar)->{store}, 0; 663 is Devel::PPPort::magic_SvUV_nomg($scalar), 10; 664 is tied($scalar)->{fetch}, 1; 665 is tied($scalar)->{store}, 0; 666 is Devel::PPPort::magic_SvNV_nomg($scalar), 10; 667 is tied($scalar)->{fetch}, 1; 668 is tied($scalar)->{store}, 0; 669 is Devel::PPPort::magic_SvPV_nomg_nolen($scalar), 10; 670 is tied($scalar)->{fetch}, 1; 671 is tied($scalar)->{store}, 0; 672 ok Devel::PPPort::magic_SvTRUE_nomg($scalar); 673 is tied($scalar)->{fetch}, 1; 674 is tied($scalar)->{store}, 0; 675 676 my $object = OverloadedObject->new('string', 5.5, 0); 677 678 is Devel::PPPort::magic_SvIV_nomg($object), 5; 679 is Devel::PPPort::magic_SvUV_nomg($object), 5; 680 is Devel::PPPort::magic_SvNV_nomg($object), 5.5; 681 is Devel::PPPort::magic_SvPV_nomg_nolen($object), 'string'; 682 ok !Devel::PPPort::magic_SvTRUE_nomg($object); 683 684tie my $negative, 'TieScalarCounter', -1; 685$fetch = $negative; 686 687is tied($negative)->{fetch}, 1; 688is tied($negative)->{store}, 0; 689is Devel::PPPort::magic_SvIV_nomg($negative), -1; 690if (ivers($]) >= ivers("5.6")) { 691 ok !Devel::PPPort::SVf_IVisUV($negative); 692} else { 693 skip 'SVf_IVisUV is unsupported', 1; 694} 695is tied($negative)->{fetch}, 1; 696is tied($negative)->{store}, 0; 697Devel::PPPort::magic_SvUV_nomg($negative); 698if (ivers($]) >= ivers("5.6")) { 699 ok !Devel::PPPort::SVf_IVisUV($negative); 700} else { 701 skip 'SVf_IVisUV is unsupported', 1; 702} 703is tied($negative)->{fetch}, 1; 704is tied($negative)->{store}, 0; 705 706tie my $big, 'TieScalarCounter', Devel::PPPort::above_IV_MAX(); 707$fetch = $big; 708 709is tied($big)->{fetch}, 1; 710is tied($big)->{store}, 0; 711Devel::PPPort::magic_SvIV_nomg($big); 712if (ivers($]) >= ivers("5.6")) { 713 ok Devel::PPPort::SVf_IVisUV($big); 714} else { 715 skip 'SVf_IVisUV is unsupported', 1; 716} 717is tied($big)->{fetch}, 1; 718is tied($big)->{store}, 0; 719is Devel::PPPort::magic_SvUV_nomg($big), Devel::PPPort::above_IV_MAX(); 720if (ivers($]) >= ivers("5.6")) { 721 ok Devel::PPPort::SVf_IVisUV($big); 722} else { 723 skip 'SVf_IVisUV is unsupported', 1; 724} 725is tied($big)->{fetch}, 1; 726is tied($big)->{store}, 0; 727 728package TieScalarCounter; 729 730sub TIESCALAR { 731 my ($class, $value) = @_; 732 return bless { fetch => 0, store => 0, value => $value }, $class; 733} 734 735sub FETCH { 736 my ($self) = @_; 737 $self->{fetch}++; 738 return $self->{value}; 739} 740 741sub STORE { 742 my ($self, $value) = @_; 743 $self->{store}++; 744 $self->{value} = $value; 745} 746 747package OverloadedObject; 748 749sub new { 750 my ($class, $str, $num, $bool) = @_; 751 return bless { str => $str, num => $num, bool => $bool }, $class; 752} 753 754use overload 755 '""' => sub { $_[0]->{str} }, 756 '0+' => sub { $_[0]->{num} }, 757 'bool' => sub { $_[0]->{bool} }, 758 ; 759