dist/Devel-PPPort/parts/inc/magic

   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
  14 mg_findext
  15 sv_unmagicext
  16
  17 __UNDEFINED__
  18 /sv_\w+_mg/
  19 sv_magic_portable
  20
  21 SvIV_nomg
  22 SvUV_nomg
  23 SvNV_nomg
  24 SvTRUE_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(PERL_USE_GCC_BRACE_GROUPS)
  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
 188 MAGIC *
 189 mg_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
 212 int
 213 sv_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
 265 STATIC 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
 282 STATIC 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
 301 SV *
 302 new_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
 327 SV *
 328 new_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
 353 void
 354 remove_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
 363 void
 364 remove_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
 373 void
 374 as_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
 388 void
 389 sv_catpv_mg(sv, string)
 390         SV *sv;
 391         char *string;
 392         CODE:
 393                 sv_catpv_mg(sv, string);
 394
 395 void
 396 sv_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
 406 void
 407 sv_catsv_mg(sv, sv2)
 408         SV *sv;
 409         SV *sv2;
 410         CODE:
 411                 sv_catsv_mg(sv, sv2);
 412
 413 void
 414 sv_setiv_mg(sv, iv)
 415         SV *sv;
 416         IV iv;
 417         CODE:
 418                 sv_setiv_mg(sv, iv);
 419
 420 void
 421 sv_setnv_mg(sv, nv)
 422         SV *sv;
 423         NV nv;
 424         CODE:
 425                 sv_setnv_mg(sv, nv);
 426
 427 void
 428 sv_setpv_mg(sv, pv)
 429         SV *sv;
 430         char *pv;
 431         CODE:
 432                 sv_setpv_mg(sv, pv);
 433
 434 void
 435 sv_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
 445 void
 446 sv_setsv_mg(sv, sv2)
 447         SV *sv;
 448         SV *sv2;
 449         CODE:
 450                 sv_setsv_mg(sv, sv2);
 451
 452 void
 453 sv_setuv_mg(sv, uv)
 454         SV *sv;
 455         UV uv;
 456         CODE:
 457                 sv_setuv_mg(sv, uv);
 458
 459 void
 460 sv_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
 472 int
 473 SvVSTRING_mg(sv)
 474         SV *sv;
 475         CODE:
 476                 RETVAL = SvVSTRING_mg(sv) != NULL;
 477         OUTPUT:
 478                 RETVAL
 479
 480 int
 481 sv_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
 503 UV
 504 above_IV_MAX()
 505         CODE:
 506                 RETVAL = (UV)IV_MAX+100;
 507         OUTPUT:
 508                 RETVAL
 509
 510 #ifdef SVf_IVisUV
 511
 512 U32
 513 SVf_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
 524 IV
 525 magic_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
 536 UV
 537 magic_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
 548 NV
 549 magic_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
 560 bool
 561 magic_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
 572 char *
 573 magic_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
 585 ok(my $obj1 = Devel::PPPort->new_with_mg());
 586 is(Devel::PPPort::as_string($obj1), 'hello');
 587
 588 # Find with no magic
 589 my $obj = bless {}, 'Fake::Class';
 590 is(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)
 593 ok($obj = Devel::PPPort->new_with_other_mg());
 594 is(Devel::PPPort::as_string($obj), "Sorry, your princess is in another castle.");
 595
 596 # Okay, attempt to remove magic that isn't there
 597 Devel::PPPort::remove_other_magic($obj1);
 598 is(Devel::PPPort::as_string($obj1), 'hello');
 599
 600 # Remove magic that IS there
 601 Devel::PPPort::remove_null_magic($obj1);
 602 is(Devel::PPPort::as_string($obj1), "Sorry, your princess is in another castle.");
 603
 604 # Removing when no magic present
 605 Devel::PPPort::remove_null_magic($obj1);
 606 is(Devel::PPPort::as_string($obj1), "Sorry, your princess is in another castle.");
 607
 608 use Tie::Hash;
 609 my %h;
 610 tie %h, 'Tie::StdHash';
 611 $h{foo} = 'foo';
 612 $h{bar} = '';
 613
 614 &Devel::PPPort::sv_catpv_mg($h{foo}, 'bar');
 615 is($h{foo}, 'foobar');
 616
 617 &Devel::PPPort::sv_catpvn_mg($h{bar}, 'baz');
 618 is($h{bar}, 'baz');
 619
 620 &Devel::PPPort::sv_catsv_mg($h{foo}, '42');
 621 is($h{foo}, 'foobar42');
 622
 623 &Devel::PPPort::sv_setiv_mg($h{bar}, 42);
 624 is($h{bar}, 42);
 625
 626 &Devel::PPPort::sv_setnv_mg($h{PI}, 3.14159);
 627 ok(abs($h{PI} - 3.14159) < 0.01);
 628
 629 &Devel::PPPort::sv_setpv_mg($h{mhx}, 'mhx');
 630 is($h{mhx}, 'mhx');
 631
 632 &Devel::PPPort::sv_setpvn_mg($h{mhx}, 'Marcus');
 633 is($h{mhx}, 'Marcus');
 634
 635 &Devel::PPPort::sv_setsv_mg($h{sv}, 'SV');
 636 is($h{sv}, 'SV');
 637
 638 &Devel::PPPort::sv_setuv_mg($h{sv}, 4711);
 639 is($h{sv}, 4711);
 640
 641 &Devel::PPPort::sv_usepvn_mg($h{sv}, 'Perl');
 642 is($h{sv}, 'Perl');
 643
 644 # v1 is treated as a bareword in older perls...
 645 my $ver = do { local $SIG{'__WARN__'} = sub {}; eval qq[v1.2.0] };
 646 ok(ivers($]) < ivers("5.009") || $@ eq '');
 647 ok(ivers($]) < ivers("5.009") || Devel::PPPort::SvVSTRING_mg($ver));
 648 ok(!Devel::PPPort::SvVSTRING_mg(4711));
 649
 650 my $foo = 'bar';
 651 ok(Devel::PPPort::sv_magic_portable($foo));
 652 ok($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
 683 tie my $negative, 'TieScalarCounter', -1;
 684 $fetch = $negative;
 685
 686 is tied($negative)->{fetch}, 1;
 687 is tied($negative)->{store}, 0;
 688 is Devel::PPPort::magic_SvIV_nomg($negative), -1;
 689 if (ivers($]) >= ivers("5.6")) {
 690     ok !Devel::PPPort::SVf_IVisUV($negative);
 691 } else {
 692     skip 'SVf_IVisUV is unsupported', 1;
 693 }
 694 is tied($negative)->{fetch}, 1;
 695 is tied($negative)->{store}, 0;
 696 Devel::PPPort::magic_SvUV_nomg($negative);
 697 if (ivers($]) >= ivers("5.6")) {
 698     ok !Devel::PPPort::SVf_IVisUV($negative);
 699 } else {
 700     skip 'SVf_IVisUV is unsupported', 1;
 701 }
 702 is tied($negative)->{fetch}, 1;
 703 is tied($negative)->{store}, 0;
 704
 705 tie my $big, 'TieScalarCounter', Devel::PPPort::above_IV_MAX();
 706 $fetch = $big;
 707
 708 is tied($big)->{fetch}, 1;
 709 is tied($big)->{store}, 0;
 710 Devel::PPPort::magic_SvIV_nomg($big);
 711 if (ivers($]) >= ivers("5.6")) {
 712     ok Devel::PPPort::SVf_IVisUV($big);
 713 } else {
 714     skip 'SVf_IVisUV is unsupported', 1;
 715 }
 716 is tied($big)->{fetch}, 1;
 717 is tied($big)->{store}, 0;
 718 is Devel::PPPort::magic_SvUV_nomg($big), Devel::PPPort::above_IV_MAX();
 719 if (ivers($]) >= ivers("5.6")) {
 720     ok Devel::PPPort::SVf_IVisUV($big);
 721 } else {
 722     skip 'SVf_IVisUV is unsupported', 1;
 723 }
 724 is tied($big)->{fetch}, 1;
 725 is tied($big)->{store}, 0;
 726
 727 package TieScalarCounter;
 728
 729 sub TIESCALAR {
 730     my ($class, $value) = @_;
 731     return bless { fetch => 0, store => 0, value => $value }, $class;
 732 }
 733
 734 sub FETCH {
 735     my ($self) = @_;
 736     $self->{fetch}++;
 737     return $self->{value};
 738 }
 739
 740 sub STORE {
 741     my ($self, $value) = @_;
 742     $self->{store}++;
 743     $self->{value} = $value;
 744 }
 745
 746 package OverloadedObject;
 747
 748 sub new {
 749     my ($class, $str, $num, $bool) = @_;
 750     return bless { str => $str, num => $num, bool => $bool }, $class;
 751 }
 752
 753 use overload
 754     '""' => sub { $_[0]->{str} },
 755     '0+' => sub { $_[0]->{num} },
 756     'bool' => sub { $_[0]->{bool} },
 757     ;