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