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