[perl5.git] / dist / Devel-PPPort / parts / inc / magic

################################################################################
##
##  Version 3.x, Copyright (C) 2004-2013, Marcus Holland-Moritz.
##  Version 2.x, Copyright (C) 2001, Paul Marquess.
##  Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
##
##  This program is free software; you can redistribute it and/or
##  modify it under the same terms as Perl itself.
##
################################################################################

=provides

mg_findext
sv_unmagicext

__UNDEFINED__
/sv_\w+_mg/
sv_magic_portable

SvIV_nomg
SvUV_nomg
SvNV_nomg
SvTRUE_nomg

=implementation

#undef  SvGETMAGIC
__UNDEFINED__  SvGETMAGIC(x) ((void)(UNLIKELY(SvGMAGICAL(x)) && mg_get(x)))

/* That's the best we can do... */
__UNDEFINED__  sv_catpvn_nomg     sv_catpvn
__UNDEFINED__  sv_catsv_nomg      sv_catsv
__UNDEFINED__  sv_setsv_nomg      sv_setsv
__UNDEFINED__  sv_pvn_nomg        sv_pvn

#ifdef SVf_IVisUV
#if defined(PERL_USE_GCC_BRACE_GROUPS)
__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; }))
__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; }))
#else
__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)))
__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)))
#endif
#else
__UNDEFINED__ SvIV_nomg(sv) (!SvGMAGICAL((sv)) ? SvIV((sv)) : SvIVx(sv_mortalcopy_flags((sv), SV_NOSTEAL)))
__UNDEFINED__ SvUV_nomg(sv) (!SvGMAGICAL((sv)) ? SvUV((sv)) : SvUVx(sv_mortalcopy_flags((sv), SV_NOSTEAL)))
#endif

__UNDEFINED__ SvNV_nomg(sv) (!SvGMAGICAL((sv)) ? SvNV((sv)) : SvNVx(sv_mortalcopy_flags((sv), SV_NOSTEAL)))
__UNDEFINED__ SvTRUE_nomg(sv) (!SvGMAGICAL((sv)) ? SvTRUE((sv)) : SvTRUEx(sv_mortalcopy_flags((sv), SV_NOSTEAL)))

#ifndef sv_catpv_mg
#  define sv_catpv_mg(sv, ptr)          \
   STMT_START {                         \
     SV *TeMpSv = sv;                   \
     sv_catpv(TeMpSv,ptr);              \
     SvSETMAGIC(TeMpSv);                \
   } STMT_END
#endif

#ifndef sv_catpvn_mg
#  define sv_catpvn_mg(sv, ptr, len)    \
   STMT_START {                         \
     SV *TeMpSv = sv;                   \
     sv_catpvn(TeMpSv,ptr,len);         \
     SvSETMAGIC(TeMpSv);                \
   } STMT_END
#endif

#ifndef sv_catsv_mg
#  define sv_catsv_mg(dsv, ssv)         \
   STMT_START {                         \
     SV *TeMpSv = dsv;                  \
     sv_catsv(TeMpSv,ssv);              \
     SvSETMAGIC(TeMpSv);                \
   } STMT_END
#endif

#ifndef sv_setiv_mg
#  define sv_setiv_mg(sv, i)            \
   STMT_START {                         \
     SV *TeMpSv = sv;                   \
     sv_setiv(TeMpSv,i);                \
     SvSETMAGIC(TeMpSv);                \
   } STMT_END
#endif

#ifndef sv_setnv_mg
#  define sv_setnv_mg(sv, num)          \
   STMT_START {                         \
     SV *TeMpSv = sv;                   \
     sv_setnv(TeMpSv,num);              \
     SvSETMAGIC(TeMpSv);                \
   } STMT_END
#endif

#ifndef sv_setpv_mg
#  define sv_setpv_mg(sv, ptr)          \
   STMT_START {                         \
     SV *TeMpSv = sv;                   \
     sv_setpv(TeMpSv,ptr);              \
     SvSETMAGIC(TeMpSv);                \
   } STMT_END
#endif

#ifndef sv_setpvn_mg
#  define sv_setpvn_mg(sv, ptr, len)    \
   STMT_START {                         \
     SV *TeMpSv = sv;                   \
     sv_setpvn(TeMpSv,ptr,len);         \
     SvSETMAGIC(TeMpSv);                \
   } STMT_END
#endif

#ifndef sv_setsv_mg
#  define sv_setsv_mg(dsv, ssv)         \
   STMT_START {                         \
     SV *TeMpSv = dsv;                  \
     sv_setsv(TeMpSv,ssv);              \
     SvSETMAGIC(TeMpSv);                \
   } STMT_END
#endif

#ifndef sv_setuv_mg
#  define sv_setuv_mg(sv, i)            \
   STMT_START {                         \
     SV *TeMpSv = sv;                   \
     sv_setuv(TeMpSv,i);                \
     SvSETMAGIC(TeMpSv);                \
   } STMT_END
#endif

#ifndef sv_usepvn_mg
#  define sv_usepvn_mg(sv, ptr, len)    \
   STMT_START {                         \
     SV *TeMpSv = sv;                   \
     sv_usepvn(TeMpSv,ptr,len);         \
     SvSETMAGIC(TeMpSv);                \
   } STMT_END
#endif

__UNDEFINED__  SvVSTRING_mg(sv)  (SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_vstring) : NULL)

/* Hint: sv_magic_portable
 * This is a compatibility function that is only available with
 * Devel::PPPort. It is NOT in the perl core.
 * Its purpose is to mimic the 5.8.0 behaviour of sv_magic() when
 * it is being passed a name pointer with namlen == 0. In that
 * case, perl 5.8.0 and later store the pointer, not a copy of it.
 * The compatibility can be provided back to perl 5.004. With
 * earlier versions, the code will not compile.
 */

#if { VERSION < 5.004 }

  /* code that uses sv_magic_portable will not compile */

#elif { VERSION < 5.8.0 }

#  define sv_magic_portable(sv, obj, how, name, namlen)     \
   STMT_START {                                             \
     SV *SvMp_sv = (sv);                                    \
     char *SvMp_name = (char *) (name);                     \
     I32 SvMp_namlen = (namlen);                            \
     if (SvMp_name && SvMp_namlen == 0)                     \
     {                                                      \
       MAGIC *mg;                                           \
       sv_magic(SvMp_sv, obj, how, 0, 0);                   \
       mg = SvMAGIC(SvMp_sv);                               \
       mg->mg_len = -42; /* XXX: this is the tricky part */ \
       mg->mg_ptr = SvMp_name;                              \
     }                                                      \
     else                                                   \
     {                                                      \
       sv_magic(SvMp_sv, obj, how, SvMp_name, SvMp_namlen); \
     }                                                      \
   } STMT_END

#else

#  define sv_magic_portable(a, b, c, d, e)  sv_magic(a, b, c, d, e)

#endif

#if !defined(mg_findext)
#if { NEED mg_findext }

MAGIC *
mg_findext(const SV * sv, int type, const MGVTBL *vtbl) {
    if (sv) {
        MAGIC *mg;

#ifdef AvPAD_NAMELIST
        assert(!(SvTYPE(sv) == SVt_PVAV && AvPAD_NAMELIST(sv)));
#endif

        for (mg = SvMAGIC (sv); mg; mg = mg->mg_moremagic) {
            if (mg->mg_type == type && mg->mg_virtual == vtbl)
                return mg;
        }
    }

    return NULL;
}

#endif
#endif

#if !defined(sv_unmagicext)
#if { NEED sv_unmagicext }

int
sv_unmagicext(pTHX_ SV *const sv, const int type, MGVTBL *vtbl)
{
    MAGIC* mg;
    MAGIC** mgp;

    if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
	return 0;
    mgp = &(SvMAGIC(sv));
    for (mg = *mgp; mg; mg = *mgp) {
	const MGVTBL* const virt = mg->mg_virtual;
	if (mg->mg_type == type && virt == vtbl) {
	    *mgp = mg->mg_moremagic;
	    if (virt && virt->svt_free)
		virt->svt_free(aTHX_ sv, mg);
	    if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
		if (mg->mg_len > 0)
		    Safefree(mg->mg_ptr);
		else if (mg->mg_len == HEf_SVKEY) /* Questionable on older perls... */
		    SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
		else if (mg->mg_type == PERL_MAGIC_utf8)
		    Safefree(mg->mg_ptr);
            }
	    if (mg->mg_flags & MGf_REFCOUNTED)
		SvREFCNT_dec(mg->mg_obj);
	    Safefree(mg);
	}
	else
	    mgp = &mg->mg_moremagic;
    }
    if (SvMAGIC(sv)) {
	if (SvMAGICAL(sv))	/* if we're under save_magic, wait for restore_magic; */
	    mg_magical(sv);	/*    else fix the flags now */
    }
    else {
	SvMAGICAL_off(sv);
	SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
    }
    return 0;
}

#endif
#endif

=xsinit

#define NEED_mg_findext
#define NEED_sv_unmagicext

#ifndef STATIC
#define STATIC static
#endif

STATIC MGVTBL null_mg_vtbl = {
    NULL, /* get */
    NULL, /* set */
    NULL, /* len */
    NULL, /* clear */
    NULL, /* free */
#if MGf_COPY
    NULL, /* copy */
#endif /* MGf_COPY */
#if MGf_DUP
    NULL, /* dup */
#endif /* MGf_DUP */
#if MGf_LOCAL
    NULL, /* local */
#endif /* MGf_LOCAL */
};

STATIC MGVTBL other_mg_vtbl = {
    NULL, /* get */
    NULL, /* set */
    NULL, /* len */
    NULL, /* clear */
    NULL, /* free */
#if MGf_COPY
    NULL, /* copy */
#endif /* MGf_COPY */
#if MGf_DUP
    NULL, /* dup */
#endif /* MGf_DUP */
#if MGf_LOCAL
    NULL, /* local */
#endif /* MGf_LOCAL */
};

=xsubs

SV *
new_with_other_mg(package, ...)
    SV *package
  PREINIT:
    HV *self;
    HV *stash;
    SV *self_ref;
    const char *data = "hello\0";
    MAGIC *mg;
  CODE:
    self = newHV();
    stash = gv_stashpv(SvPV_nolen(package), 0);

    self_ref = newRV_noinc((SV*)self);

    sv_magic((SV*)self, NULL, PERL_MAGIC_ext, data, strlen(data));
    mg = mg_find((SV*)self, PERL_MAGIC_ext);
    if (mg)
      mg->mg_virtual = &other_mg_vtbl;
    else
      croak("No mg!");

    RETVAL = sv_bless(self_ref, stash);
  OUTPUT:
    RETVAL

SV *
new_with_mg(package, ...)
    SV *package
  PREINIT:
    HV *self;
    HV *stash;
    SV *self_ref;
    const char *data = "hello\0";
    MAGIC *mg;
  CODE:
    self = newHV();
    stash = gv_stashpv(SvPV_nolen(package), 0);

    self_ref = newRV_noinc((SV*)self);

    sv_magic((SV*)self, NULL, PERL_MAGIC_ext, data, strlen(data));
    mg = mg_find((SV*)self, PERL_MAGIC_ext);
    if (mg)
      mg->mg_virtual = &null_mg_vtbl;
    else
      croak("No mg!");

    RETVAL = sv_bless(self_ref, stash);
  OUTPUT:
    RETVAL

void
remove_null_magic(self)
    SV *self
  PREINIT:
    HV *obj;
  PPCODE:
    obj = (HV*) SvRV(self);

    sv_unmagicext((SV*)obj, PERL_MAGIC_ext, &null_mg_vtbl);

void
remove_other_magic(self)
    SV *self
  PREINIT:
    HV *obj;
  PPCODE:
    obj = (HV*) SvRV(self);

    sv_unmagicext((SV*)obj, PERL_MAGIC_ext, &other_mg_vtbl);

void
as_string(self)
    SV *self
  PREINIT:
    HV *obj;
    MAGIC *mg;
  PPCODE:
    obj = (HV*) SvRV(self);

    if ((mg = mg_findext((SV*)obj, PERL_MAGIC_ext, &null_mg_vtbl))) {
        XPUSHs(sv_2mortal(newSVpv(mg->mg_ptr, strlen(mg->mg_ptr))));
    } else {
        XPUSHs(sv_2mortal(newSVpvs("Sorry, your princess is in another castle.")));
    }

void
sv_catpv_mg(sv, string)
        SV *sv;
        char *string;
        CODE:
                sv_catpv_mg(sv, string);

void
sv_catpvn_mg(sv, sv2)
        SV *sv;
        SV *sv2;
        PREINIT:
                char *str;
                STRLEN len;
        CODE:
                str = SvPV(sv2, len);
                sv_catpvn_mg(sv, str, len);

void
sv_catsv_mg(sv, sv2)
        SV *sv;
        SV *sv2;
        CODE:
                sv_catsv_mg(sv, sv2);

void
sv_setiv_mg(sv, iv)
        SV *sv;
        IV iv;
        CODE:
                sv_setiv_mg(sv, iv);

void
sv_setnv_mg(sv, nv)
        SV *sv;
        NV nv;
        CODE:
                sv_setnv_mg(sv, nv);

void
sv_setpv_mg(sv, pv)
        SV *sv;
        char *pv;
        CODE:
                sv_setpv_mg(sv, pv);

void
sv_setpvn_mg(sv, sv2)
        SV *sv;
        SV *sv2;
        PREINIT:
                char *str;
                STRLEN len;
        CODE:
                str = SvPV(sv2, len);
                sv_setpvn_mg(sv, str, len);

void
sv_setsv_mg(sv, sv2)
        SV *sv;
        SV *sv2;
        CODE:
                sv_setsv_mg(sv, sv2);

void
sv_setuv_mg(sv, uv)
        SV *sv;
        UV uv;
        CODE:
                sv_setuv_mg(sv, uv);

void
sv_usepvn_mg(sv, sv2)
        SV *sv;
        SV *sv2;
        PREINIT:
                char *str, *copy;
                STRLEN len;
        CODE:
                str = SvPV(sv2, len);
                New(42, copy, len+1, char);
                Copy(str, copy, len+1, char);
                sv_usepvn_mg(sv, copy, len);

int
SvVSTRING_mg(sv)
        SV *sv;
        CODE:
                RETVAL = SvVSTRING_mg(sv) != NULL;
        OUTPUT:
                RETVAL

int
sv_magic_portable(sv)
        SV *sv
        PREINIT:
                MAGIC *mg;
                const char *foo = "foo";
        CODE:
#if { VERSION >= 5.004 }
                sv_magic_portable(sv, 0, '~', foo, 0);
                mg = mg_find(sv, '~');
                if (!mg)
                  croak("No mg!");

                RETVAL = mg->mg_ptr == foo;
#else
                sv_magic(sv, 0, '~', (char *) foo, strlen(foo));
                mg = mg_find(sv, '~');
                RETVAL = strEQ(mg->mg_ptr, foo);
#endif
                sv_unmagic(sv, '~');
        OUTPUT:
                RETVAL

UV
above_IV_MAX()
        CODE:
                RETVAL = (UV)IV_MAX+100;
        OUTPUT:
                RETVAL

#ifdef SVf_IVisUV

U32
SVf_IVisUV(sv)
        SV *sv
        CODE:
                RETVAL = (SvFLAGS(sv) & SVf_IVisUV);
        OUTPUT:
                RETVAL

#endif

#ifdef SvIV_nomg

IV
magic_SvIV_nomg(sv)
        SV *sv
        CODE:
                RETVAL = SvIV_nomg(sv);
        OUTPUT:
                RETVAL

#endif

#ifdef SvUV_nomg

UV
magic_SvUV_nomg(sv)
        SV *sv
        CODE:
                RETVAL = SvUV_nomg(sv);
        OUTPUT:
                RETVAL

#endif

#ifdef SvNV_nomg

NV
magic_SvNV_nomg(sv)
        SV *sv
        CODE:
                RETVAL = SvNV_nomg(sv);
        OUTPUT:
                RETVAL

#endif

#ifdef SvTRUE_nomg

bool
magic_SvTRUE_nomg(sv)
        SV *sv
        CODE:
                RETVAL = SvTRUE_nomg(sv);
        OUTPUT:
                RETVAL

#endif

#ifdef SvPV_nomg_nolen

char *
magic_SvPV_nomg_nolen(sv)
        SV *sv
        CODE:
                RETVAL = SvPV_nomg_nolen(sv);
        OUTPUT:
                RETVAL

#endif

=tests plan => 63

# Find proper magic
ok(my $obj1 = Devel::PPPort->new_with_mg());
is(Devel::PPPort::as_string($obj1), 'hello');

# Find with no magic
my $obj = bless {}, 'Fake::Class';
is(Devel::PPPort::as_string($obj), "Sorry, your princess is in another castle.");

# Find with other magic (not the magic we are looking for)
ok($obj = Devel::PPPort->new_with_other_mg());
is(Devel::PPPort::as_string($obj), "Sorry, your princess is in another castle.");

# Okay, attempt to remove magic that isn't there
Devel::PPPort::remove_other_magic($obj1);
is(Devel::PPPort::as_string($obj1), 'hello');

# Remove magic that IS there
Devel::PPPort::remove_null_magic($obj1);
is(Devel::PPPort::as_string($obj1), "Sorry, your princess is in another castle.");

# Removing when no magic present
Devel::PPPort::remove_null_magic($obj1);
is(Devel::PPPort::as_string($obj1), "Sorry, your princess is in another castle.");

use Tie::Hash;
my %h;
tie %h, 'Tie::StdHash';
$h{foo} = 'foo';
$h{bar} = '';

&Devel::PPPort::sv_catpv_mg($h{foo}, 'bar');
is($h{foo}, 'foobar');

&Devel::PPPort::sv_catpvn_mg($h{bar}, 'baz');
is($h{bar}, 'baz');

&Devel::PPPort::sv_catsv_mg($h{foo}, '42');
is($h{foo}, 'foobar42');

&Devel::PPPort::sv_setiv_mg($h{bar}, 42);
is($h{bar}, 42);

&Devel::PPPort::sv_setnv_mg($h{PI}, 3.14159);
ok(abs($h{PI} - 3.14159) < 0.01);

&Devel::PPPort::sv_setpv_mg($h{mhx}, 'mhx');
is($h{mhx}, 'mhx');

&Devel::PPPort::sv_setpvn_mg($h{mhx}, 'Marcus');
is($h{mhx}, 'Marcus');

&Devel::PPPort::sv_setsv_mg($h{sv}, 'SV');
is($h{sv}, 'SV');

&Devel::PPPort::sv_setuv_mg($h{sv}, 4711);
is($h{sv}, 4711);

&Devel::PPPort::sv_usepvn_mg($h{sv}, 'Perl');
is($h{sv}, 'Perl');

# v1 is treated as a bareword in older perls...
my $ver = do { local $SIG{'__WARN__'} = sub {}; eval qq[v1.2.0] };
ok(ivers($]) < ivers("5.009") || $@ eq '');
ok(ivers($]) < ivers("5.009") || Devel::PPPort::SvVSTRING_mg($ver));
ok(!Devel::PPPort::SvVSTRING_mg(4711));

my $foo = 'bar';
ok(Devel::PPPort::sv_magic_portable($foo));
ok($foo eq 'bar');

    tie my $scalar, 'TieScalarCounter', 10;
    my $fetch = $scalar;

    is tied($scalar)->{fetch}, 1;
    is tied($scalar)->{store}, 0;
    is Devel::PPPort::magic_SvIV_nomg($scalar), 10;
    is tied($scalar)->{fetch}, 1;
    is tied($scalar)->{store}, 0;
    is Devel::PPPort::magic_SvUV_nomg($scalar), 10;
    is tied($scalar)->{fetch}, 1;
    is tied($scalar)->{store}, 0;
    is Devel::PPPort::magic_SvNV_nomg($scalar), 10;
    is tied($scalar)->{fetch}, 1;
    is tied($scalar)->{store}, 0;
    is Devel::PPPort::magic_SvPV_nomg_nolen($scalar), 10;
    is tied($scalar)->{fetch}, 1;
    is tied($scalar)->{store}, 0;
    ok Devel::PPPort::magic_SvTRUE_nomg($scalar);
    is tied($scalar)->{fetch}, 1;
    is tied($scalar)->{store}, 0;

    my $object = OverloadedObject->new('string', 5.5, 0);

    is Devel::PPPort::magic_SvIV_nomg($object), 5;
    is Devel::PPPort::magic_SvUV_nomg($object), 5;
    is Devel::PPPort::magic_SvNV_nomg($object), 5.5;
    is Devel::PPPort::magic_SvPV_nomg_nolen($object), 'string';
    ok !Devel::PPPort::magic_SvTRUE_nomg($object);

tie my $negative, 'TieScalarCounter', -1;
$fetch = $negative;

is tied($negative)->{fetch}, 1;
is tied($negative)->{store}, 0;
is Devel::PPPort::magic_SvIV_nomg($negative), -1;
if (ivers($]) >= ivers("5.6")) {
    ok !Devel::PPPort::SVf_IVisUV($negative);
} else {
    skip 'SVf_IVisUV is unsupported', 1;
}
is tied($negative)->{fetch}, 1;
is tied($negative)->{store}, 0;
Devel::PPPort::magic_SvUV_nomg($negative);
if (ivers($]) >= ivers("5.6")) {
    ok !Devel::PPPort::SVf_IVisUV($negative);
} else {
    skip 'SVf_IVisUV is unsupported', 1;
}
is tied($negative)->{fetch}, 1;
is tied($negative)->{store}, 0;

tie my $big, 'TieScalarCounter', Devel::PPPort::above_IV_MAX();
$fetch = $big;

is tied($big)->{fetch}, 1;
is tied($big)->{store}, 0;
Devel::PPPort::magic_SvIV_nomg($big);
if (ivers($]) >= ivers("5.6")) {
    ok Devel::PPPort::SVf_IVisUV($big);
} else {
    skip 'SVf_IVisUV is unsupported', 1;
}
is tied($big)->{fetch}, 1;
is tied($big)->{store}, 0;
is Devel::PPPort::magic_SvUV_nomg($big), Devel::PPPort::above_IV_MAX();
if (ivers($]) >= ivers("5.6")) {
    ok Devel::PPPort::SVf_IVisUV($big);
} else {
    skip 'SVf_IVisUV is unsupported', 1;
}
is tied($big)->{fetch}, 1;
is tied($big)->{store}, 0;

package TieScalarCounter;

sub TIESCALAR {
    my ($class, $value) = @_;
    return bless { fetch => 0, store => 0, value => $value }, $class;
}

sub FETCH {
    my ($self) = @_;
    $self->{fetch}++;
    return $self->{value};
}

sub STORE {
    my ($self, $value) = @_;
    $self->{store}++;
    $self->{value} = $value;
}

package OverloadedObject;

sub new {
    my ($class, $str, $num, $bool) = @_;
    return bless { str => $str, num => $num, bool => $bool }, $class;
}

use overload
    '""' => sub { $_[0]->{str} },
    '0+' => sub { $_[0]->{num} },
    'bool' => sub { $_[0]->{bool} },
    ;
Commit	Line	Data
adfe19db MHM	1	################################################################################
adfe19db MHM	2	##
b2049988	3	## Version 3.x, Copyright (C) 2004-2013, Marcus Holland-Moritz.
adfe19db MHM	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
ea4b7f32 JH	14	mg_findext
	15	sv_unmagicext
	16
adfe19db MHM	17	__UNDEFINED__
adfe19db MHM	18	/sv_\w+_mg/
679ad62d	19	sv_magic_portable
adfe19db	20
f626215a P	21	SvIV_nomg
	22	SvUV_nomg
	23	SvNV_nomg
	24	SvTRUE_nomg
	25
adfe19db MHM	26	=implementation
adfe19db MHM	27
07c06651 N	28	#undef SvGETMAGIC
07c06651 N	29	__UNDEFINED__ SvGETMAGIC(x) ((void)(UNLIKELY(SvGMAGICAL(x)) && mg_get(x)))
adfe19db	30
adfe19db	31	/* That's the best we can do... */
adfe19db MHM	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
f626215a	36
8f62b02f	37	#ifdef SVf_IVisUV
46677718	38	#if defined(PERL_USE_GCC_BRACE_GROUPS)
8f62b02f CBW	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
f626215a P	46	__UNDEFINED__ SvIV_nomg(sv) (!SvGMAGICAL((sv)) ? SvIV((sv)) : SvIVx(sv_mortalcopy_flags((sv), SV_NOSTEAL)))
f626215a P	47	__UNDEFINED__ SvUV_nomg(sv) (!SvGMAGICAL((sv)) ? SvUV((sv)) : SvUVx(sv_mortalcopy_flags((sv), SV_NOSTEAL)))
8f62b02f CBW	48	#endif
8f62b02f CBW	49
f626215a P	50	__UNDEFINED__ SvNV_nomg(sv) (!SvGMAGICAL((sv)) ? SvNV((sv)) : SvNVx(sv_mortalcopy_flags((sv), SV_NOSTEAL)))
f626215a P	51	__UNDEFINED__ SvTRUE_nomg(sv) (!SvGMAGICAL((sv)) ? SvTRUE((sv)) : SvTRUEx(sv_mortalcopy_flags((sv), SV_NOSTEAL)))
adfe19db MHM	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
f2ab5a41 MHM	143	__UNDEFINED__ SvVSTRING_mg(sv) (SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_vstring) : NULL)
f2ab5a41 MHM	144
679ad62d MHM	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
c83e6f19 MHM	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	} \
679ad62d MHM	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
ea4b7f32 JH	186	#if !defined(mg_findext)
	187	#if { NEED mg_findext }
	188
	189	MAGIC *
8ddf67eb	190	mg_findext(const SV * sv, int type, const MGVTBL *vtbl) {
ea4b7f32 JH	191	if (sv) {
	192	MAGIC *mg;
	193
	194	#ifdef AvPAD_NAMELIST
744ef08f	195	assert(!(SvTYPE(sv) == SVt_PVAV && AvPAD_NAMELIST(sv)));
ea4b7f32 JH	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, 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
adfe19db MHM	300	=xsubs
adfe19db MHM	301
ea4b7f32 JH	302	SV *
	303	new_with_other_mg(package, ...)
	304	SV *package
	305	PREINIT:
	306	HV *self;
	307	HV *stash;
	308	SV *self_ref;
ea4b7f32 JH	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);
494d0b3d MH	319	if (mg)
	320	mg->mg_virtual = &other_mg_vtbl;
	321	else
	322	croak("No mg!");
ea4b7f32 JH	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;
ea4b7f32 JH	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);
494d0b3d MH	345	if (mg)
	346	mg->mg_virtual = &null_mg_vtbl;
	347	else
	348	croak("No mg!");
ea4b7f32 JH	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 {
744ef08f	386	XPUSHs(sv_2mortal(newSVpvs("Sorry, your princess is in another castle.")));
ea4b7f32 JH	387	}
ea4b7f32 JH	388
adfe19db MHM	389	void
adfe19db MHM	390	sv_catpv_mg(sv, string)
b2049988 MHM	391	SV *sv;
	392	char *string;
	393	CODE:
	394	sv_catpv_mg(sv, string);
adfe19db MHM	395
	396	void
	397	sv_catpvn_mg(sv, sv2)
b2049988 MHM	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);
adfe19db MHM	406
	407	void
	408	sv_catsv_mg(sv, sv2)
b2049988 MHM	409	SV *sv;
	410	SV *sv2;
	411	CODE:
	412	sv_catsv_mg(sv, sv2);
adfe19db MHM	413
	414	void
	415	sv_setiv_mg(sv, iv)
b2049988 MHM	416	SV *sv;
	417	IV iv;
	418	CODE:
	419	sv_setiv_mg(sv, iv);
adfe19db MHM	420
	421	void
	422	sv_setnv_mg(sv, nv)
b2049988 MHM	423	SV *sv;
	424	NV nv;
	425	CODE:
	426	sv_setnv_mg(sv, nv);
adfe19db MHM	427
	428	void
	429	sv_setpv_mg(sv, pv)
b2049988 MHM	430	SV *sv;
	431	char *pv;
	432	CODE:
	433	sv_setpv_mg(sv, pv);
adfe19db MHM	434
	435	void
	436	sv_setpvn_mg(sv, sv2)
b2049988 MHM	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);
adfe19db MHM	445
	446	void
	447	sv_setsv_mg(sv, sv2)
b2049988 MHM	448	SV *sv;
	449	SV *sv2;
	450	CODE:
	451	sv_setsv_mg(sv, sv2);
adfe19db MHM	452
	453	void
	454	sv_setuv_mg(sv, uv)
b2049988 MHM	455	SV *sv;
	456	UV uv;
	457	CODE:
	458	sv_setuv_mg(sv, uv);
adfe19db MHM	459
	460	void
	461	sv_usepvn_mg(sv, sv2)
b2049988 MHM	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);
adfe19db	472
f2ab5a41 MHM	473	int
f2ab5a41 MHM	474	SvVSTRING_mg(sv)
b2049988 MHM	475	SV *sv;
	476	CODE:
	477	RETVAL = SvVSTRING_mg(sv) != NULL;
	478	OUTPUT:
	479	RETVAL
f2ab5a41	480
679ad62d MHM	481	int
679ad62d MHM	482	sv_magic_portable(sv)
b2049988 MHM	483	SV *sv
	484	PREINIT:
	485	MAGIC *mg;
	486	const char *foo = "foo";
	487	CODE:
679ad62d	488	#if { VERSION >= 5.004 }
b2049988 MHM	489	sv_magic_portable(sv, 0, '~', foo, 0);
b2049988 MHM	490	mg = mg_find(sv, '~');
494d0b3d MH	491	if (!mg)
	492	croak("No mg!");
	493
b2049988	494	RETVAL = mg->mg_ptr == foo;
679ad62d	495	#else
b2049988 MHM	496	sv_magic(sv, 0, '~', (char *) foo, strlen(foo));
	497	mg = mg_find(sv, '~');
	498	RETVAL = strEQ(mg->mg_ptr, foo);
679ad62d	499	#endif
b2049988 MHM	500	sv_unmagic(sv, '~');
	501	OUTPUT:
	502	RETVAL
679ad62d	503
8f62b02f CBW	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
f626215a P	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
8f62b02f	583	=tests plan => 63
ea4b7f32 JH	584
	585	# Find proper magic
	586	ok(my $obj1 = Devel::PPPort->new_with_mg());
8154c0b1	587	is(Devel::PPPort::as_string($obj1), 'hello');
ea4b7f32 JH	588
	589	# Find with no magic
	590	my $obj = bless {}, 'Fake::Class';
8154c0b1	591	is(Devel::PPPort::as_string($obj), "Sorry, your princess is in another castle.");
ea4b7f32 JH	592
	593	# Find with other magic (not the magic we are looking for)
	594	ok($obj = Devel::PPPort->new_with_other_mg());
8154c0b1	595	is(Devel::PPPort::as_string($obj), "Sorry, your princess is in another castle.");
ea4b7f32 JH	596
	597	# Okay, attempt to remove magic that isn't there
	598	Devel::PPPort::remove_other_magic($obj1);
8154c0b1	599	is(Devel::PPPort::as_string($obj1), 'hello');
ea4b7f32 JH	600
	601	# Remove magic that IS there
	602	Devel::PPPort::remove_null_magic($obj1);
8154c0b1	603	is(Devel::PPPort::as_string($obj1), "Sorry, your princess is in another castle.");
ea4b7f32 JH	604
	605	# Removing when no magic present
	606	Devel::PPPort::remove_null_magic($obj1);
8154c0b1	607	is(Devel::PPPort::as_string($obj1), "Sorry, your princess is in another castle.");
adfe19db MHM	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');
8154c0b1	616	is($h{foo}, 'foobar');
adfe19db MHM	617
adfe19db MHM	618	&Devel::PPPort::sv_catpvn_mg($h{bar}, 'baz');
8154c0b1	619	is($h{bar}, 'baz');
adfe19db MHM	620
adfe19db MHM	621	&Devel::PPPort::sv_catsv_mg($h{foo}, '42');
8154c0b1	622	is($h{foo}, 'foobar42');
adfe19db MHM	623
adfe19db MHM	624	&Devel::PPPort::sv_setiv_mg($h{bar}, 42);
8154c0b1	625	is($h{bar}, 42);
adfe19db MHM	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');
8154c0b1	631	is($h{mhx}, 'mhx');
adfe19db MHM	632
adfe19db MHM	633	&Devel::PPPort::sv_setpvn_mg($h{mhx}, 'Marcus');
8154c0b1	634	is($h{mhx}, 'Marcus');
adfe19db MHM	635
adfe19db MHM	636	&Devel::PPPort::sv_setsv_mg($h{sv}, 'SV');
8154c0b1	637	is($h{sv}, 'SV');
adfe19db MHM	638
adfe19db MHM	639	&Devel::PPPort::sv_setuv_mg($h{sv}, 4711);
8154c0b1	640	is($h{sv}, 4711);
adfe19db MHM	641
adfe19db MHM	642	&Devel::PPPort::sv_usepvn_mg($h{sv}, 'Perl');
8154c0b1	643	is($h{sv}, 'Perl');
adfe19db	644
49ef49fe CBW	645	# v1 is treated as a bareword in older perls...
49ef49fe CBW	646	my $ver = do { local $SIG{'__WARN__'} = sub {}; eval qq[v1.2.0] };
c8799aff N	647	ok(ivers($]) < ivers("5.009") \|\| $@ eq '');
c8799aff N	648	ok(ivers($]) < ivers("5.009") \|\| Devel::PPPort::SvVSTRING_mg($ver));
f2ab5a41 MHM	649	ok(!Devel::PPPort::SvVSTRING_mg(4711));
f2ab5a41 MHM	650
679ad62d MHM	651	my $foo = 'bar';
	652	ok(Devel::PPPort::sv_magic_portable($foo));
	653	ok($foo eq 'bar');
f626215a	654
f626215a P	655	tie my $scalar, 'TieScalarCounter', 10;
	656	my $fetch = $scalar;
	657
8154c0b1 KW	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;
f626215a	672	ok Devel::PPPort::magic_SvTRUE_nomg($scalar);
8154c0b1 KW	673	is tied($scalar)->{fetch}, 1;
8154c0b1 KW	674	is tied($scalar)->{store}, 0;
f626215a P	675
	676	my $object = OverloadedObject->new('string', 5.5, 0);
	677
8154c0b1 KW	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';
f626215a	682	ok !Devel::PPPort::magic_SvTRUE_nomg($object);
8f62b02f CBW	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;
c8799aff	690	if (ivers($]) >= ivers("5.6")) {
8f62b02f CBW	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);
c8799aff	698	if (ivers($]) >= ivers("5.6")) {
8f62b02f CBW	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);
c8799aff	712	if (ivers($]) >= ivers("5.6")) {
8f62b02f CBW	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();
c8799aff	720	if (ivers($]) >= ivers("5.6")) {
8f62b02f CBW	721	ok Devel::PPPort::SVf_IVisUV($big);
	722	} else {
	723	skip 'SVf_IVisUV is unsupported', 1;
f626215a	724	}
8f62b02f CBW	725	is tied($big)->{fetch}, 1;
8f62b02f CBW	726	is tied($big)->{store}, 0;
f626215a P	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	;