[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

=implementation

__UNDEFINED__  SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END

/* 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
__UNDEFINED__  SvIV_nomg          SvIV
__UNDEFINED__  SvUV_nomg          SvUV

#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(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

=tests plan => 23

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

# Find with no magic
my $obj = bless {}, 'Fake::Class';
ok(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());
ok(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);
ok(Devel::PPPort::as_string($obj1), 'hello');

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

# Removing when no magic present
Devel::PPPort::remove_null_magic($obj1);
ok(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');
ok($h{foo}, 'foobar');

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

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

&Devel::PPPort::sv_setiv_mg($h{bar}, 42);
ok($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');
ok($h{mhx}, 'mhx');

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

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

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

&Devel::PPPort::sv_usepvn_mg($h{sv}, 'Perl');
ok($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("$]" < 5.009 || $@ eq '');
ok("$]" < 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');
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 MHM	20
	21	=implementation
	22
	23	__UNDEFINED__ SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END
	24
adfe19db	25	/* That's the best we can do... */
adfe19db MHM	26	__UNDEFINED__ sv_catpvn_nomg sv_catpvn
	27	__UNDEFINED__ sv_catsv_nomg sv_catsv
	28	__UNDEFINED__ sv_setsv_nomg sv_setsv
	29	__UNDEFINED__ sv_pvn_nomg sv_pvn
	30	__UNDEFINED__ SvIV_nomg SvIV
	31	__UNDEFINED__ SvUV_nomg SvUV
	32
	33	#ifndef sv_catpv_mg
	34	# define sv_catpv_mg(sv, ptr) \
	35	STMT_START { \
	36	SV *TeMpSv = sv; \
	37	sv_catpv(TeMpSv,ptr); \
	38	SvSETMAGIC(TeMpSv); \
	39	} STMT_END
	40	#endif
	41
	42	#ifndef sv_catpvn_mg
	43	# define sv_catpvn_mg(sv, ptr, len) \
	44	STMT_START { \
	45	SV *TeMpSv = sv; \
	46	sv_catpvn(TeMpSv,ptr,len); \
	47	SvSETMAGIC(TeMpSv); \
	48	} STMT_END
	49	#endif
	50
	51	#ifndef sv_catsv_mg
	52	# define sv_catsv_mg(dsv, ssv) \
	53	STMT_START { \
	54	SV *TeMpSv = dsv; \
	55	sv_catsv(TeMpSv,ssv); \
	56	SvSETMAGIC(TeMpSv); \
	57	} STMT_END
	58	#endif
	59
	60	#ifndef sv_setiv_mg
	61	# define sv_setiv_mg(sv, i) \
	62	STMT_START { \
	63	SV *TeMpSv = sv; \
	64	sv_setiv(TeMpSv,i); \
	65	SvSETMAGIC(TeMpSv); \
	66	} STMT_END
	67	#endif
	68
	69	#ifndef sv_setnv_mg
	70	# define sv_setnv_mg(sv, num) \
	71	STMT_START { \
	72	SV *TeMpSv = sv; \
	73	sv_setnv(TeMpSv,num); \
	74	SvSETMAGIC(TeMpSv); \
	75	} STMT_END
	76	#endif
	77
	78	#ifndef sv_setpv_mg
	79	# define sv_setpv_mg(sv, ptr) \
	80	STMT_START { \
	81	SV *TeMpSv = sv; \
	82	sv_setpv(TeMpSv,ptr); \
	83	SvSETMAGIC(TeMpSv); \
	84	} STMT_END
	85	#endif
	86
	87	#ifndef sv_setpvn_mg
	88	# define sv_setpvn_mg(sv, ptr, len) \
	89	STMT_START { \
90	SV *TeMpSv = sv; \
91	sv_setpvn(TeMpSv,ptr,len); \
92	SvSETMAGIC(TeMpSv); \
93	} STMT_END
94	#endif
95
96	#ifndef sv_setsv_mg
97	# define sv_setsv_mg(dsv, ssv) \
98	STMT_START { \
99	SV *TeMpSv = dsv; \
100	sv_setsv(TeMpSv,ssv); \
101	SvSETMAGIC(TeMpSv); \
102	} STMT_END
103	#endif
104
105	#ifndef sv_setuv_mg
106	# define sv_setuv_mg(sv, i) \
107	STMT_START { \
108	SV *TeMpSv = sv; \
109	sv_setuv(TeMpSv,i); \
110	SvSETMAGIC(TeMpSv); \
111	} STMT_END
112	#endif
113
114	#ifndef sv_usepvn_mg
115	# define sv_usepvn_mg(sv, ptr, len) \
116	STMT_START { \
117	SV *TeMpSv = sv; \
118	sv_usepvn(TeMpSv,ptr,len); \
119	SvSETMAGIC(TeMpSv); \
120	} STMT_END
121	#endif
122
f2ab5a41 MHM	123	__UNDEFINED__ SvVSTRING_mg(sv) (SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_vstring) : NULL)
f2ab5a41 MHM	124
679ad62d MHM	125	/* Hint: sv_magic_portable
	126	* This is a compatibility function that is only available with
	127	* Devel::PPPort. It is NOT in the perl core.
	128	* Its purpose is to mimic the 5.8.0 behaviour of sv_magic() when
	129	* it is being passed a name pointer with namlen == 0. In that
	130	* case, perl 5.8.0 and later store the pointer, not a copy of it.
	131	* The compatibility can be provided back to perl 5.004. With
	132	* earlier versions, the code will not compile.
	133	*/
	134
	135	#if { VERSION < 5.004 }
	136
	137	/* code that uses sv_magic_portable will not compile */
	138
	139	#elif { VERSION < 5.8.0 }
	140
c83e6f19 MHM	141	# define sv_magic_portable(sv, obj, how, name, namlen) \
	142	STMT_START { \
	143	SV *SvMp_sv = (sv); \
	144	char SvMp_name = (char ) (name); \
	145	I32 SvMp_namlen = (namlen); \
	146	if (SvMp_name && SvMp_namlen == 0) \
	147	{ \
	148	MAGIC *mg; \
	149	sv_magic(SvMp_sv, obj, how, 0, 0); \
	150	mg = SvMAGIC(SvMp_sv); \
	151	mg->mg_len = -42; /* XXX: this is the tricky part */ \
	152	mg->mg_ptr = SvMp_name; \
	153	} \
	154	else \
	155	{ \
	156	sv_magic(SvMp_sv, obj, how, SvMp_name, SvMp_namlen); \
	157	} \
679ad62d MHM	158	} STMT_END
	159
	160	#else
	161
	162	# define sv_magic_portable(a, b, c, d, e) sv_magic(a, b, c, d, e)
	163
	164	#endif
	165
ea4b7f32 JH	166	#if !defined(mg_findext)
	167	#if { NEED mg_findext }
	168
	169	MAGIC *
744ef08f	170	mg_findext(SV * sv, int type, const MGVTBL *vtbl) {
ea4b7f32 JH	171	if (sv) {
	172	MAGIC *mg;
	173
	174	#ifdef AvPAD_NAMELIST
744ef08f	175	assert(!(SvTYPE(sv) == SVt_PVAV && AvPAD_NAMELIST(sv)));
ea4b7f32 JH	176	#endif
	177
	178	for (mg = SvMAGIC (sv); mg; mg = mg->mg_moremagic) {
	179	if (mg->mg_type == type && mg->mg_virtual == vtbl)
	180	return mg;
	181	}
	182	}
	183
	184	return NULL;
	185	}
	186
	187	#endif
	188	#endif
	189
	190	#if !defined(sv_unmagicext)
	191	#if { NEED sv_unmagicext }
	192
	193	int
	194	sv_unmagicext(pTHX_ SV const sv, const int type, MGVTBL vtbl)
	195	{
	196	MAGIC* mg;
	197	MAGIC** mgp;
	198
	199	if (SvTYPE(sv) < SVt_PVMG \|\| !SvMAGIC(sv))
	200	return 0;
	201	mgp = &(SvMAGIC(sv));
	202	for (mg = mgp; mg; mg = mgp) {
	203	const MGVTBL* const virt = mg->mg_virtual;
	204	if (mg->mg_type == type && virt == vtbl) {
	205	*mgp = mg->mg_moremagic;
	206	if (virt && virt->svt_free)
	207	virt->svt_free(aTHX_ sv, mg);
	208	if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
	209	if (mg->mg_len > 0)
	210	Safefree(mg->mg_ptr);
	211	else if (mg->mg_len == HEf_SVKEY) /* Questionable on older perls... */
	212	SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
	213	else if (mg->mg_type == PERL_MAGIC_utf8)
	214	Safefree(mg->mg_ptr);
	215	}
	216	if (mg->mg_flags & MGf_REFCOUNTED)
	217	SvREFCNT_dec(mg->mg_obj);
	218	Safefree(mg);
	219	}
	220	else
	221	mgp = &mg->mg_moremagic;
	222	}
	223	if (SvMAGIC(sv)) {
	224	if (SvMAGICAL(sv)) /* if we're under save_magic, wait for restore_magic; */
	225	mg_magical(sv); /* else fix the flags now */
	226	}
	227	else {
	228	SvMAGICAL_off(sv);
	229	SvFLAGS(sv) \|= (SvFLAGS(sv) & (SVp_IOK\|SVp_NOK\|SVp_POK)) >> PRIVSHIFT;
	230	}
	231	return 0;
	232	}
	233
	234	#endif
	235	#endif
	236
	237	=xsinit
	238
	239	#define NEED_mg_findext
240	#define NEED_sv_unmagicext
241
242	#ifndef STATIC
243	#define STATIC static
244	#endif
245
246	STATIC MGVTBL null_mg_vtbl = {
247	NULL, /* get */
248	NULL, /* set */
249	NULL, /* len */
250	NULL, /* clear */
251	NULL, /* free */
252	#if MGf_COPY
253	NULL, /* copy */
254	#endif /* MGf_COPY */
255	#if MGf_DUP
256	NULL, /* dup */
257	#endif /* MGf_DUP */
258	#if MGf_LOCAL
259	NULL, /* local */
260	#endif /* MGf_LOCAL */
261	};
262
263	STATIC MGVTBL other_mg_vtbl = {
264	NULL, /* get */
265	NULL, /* set */
266	NULL, /* len */
267	NULL, /* clear */
268	NULL, /* free */
269	#if MGf_COPY
270	NULL, /* copy */
271	#endif /* MGf_COPY */
272	#if MGf_DUP
273	NULL, /* dup */
274	#endif /* MGf_DUP */
275	#if MGf_LOCAL
276	NULL, /* local */
277	#endif /* MGf_LOCAL */
278	};
279
adfe19db MHM	280	=xsubs
adfe19db MHM	281
ea4b7f32 JH	282	SV *
	283	new_with_other_mg(package, ...)
	284	SV *package
	285	PREINIT:
	286	HV *self;
	287	HV *stash;
	288	SV *self_ref;
ea4b7f32 JH	289	const char *data = "hello\0";
	290	MAGIC *mg;
	291	CODE:
	292	self = newHV();
	293	stash = gv_stashpv(SvPV_nolen(package), 0);
	294
	295	self_ref = newRV_noinc((SV*)self);
	296
	297	sv_magic((SV*)self, NULL, PERL_MAGIC_ext, data, strlen(data));
	298	mg = mg_find((SV*)self, PERL_MAGIC_ext);
494d0b3d MH	299	if (mg)
	300	mg->mg_virtual = &other_mg_vtbl;
	301	else
	302	croak("No mg!");
ea4b7f32 JH	303
	304	RETVAL = sv_bless(self_ref, stash);
	305	OUTPUT:
	306	RETVAL
	307
	308	SV *
	309	new_with_mg(package, ...)
	310	SV *package
	311	PREINIT:
	312	HV *self;
	313	HV *stash;
	314	SV *self_ref;
ea4b7f32 JH	315	const char *data = "hello\0";
	316	MAGIC *mg;
	317	CODE:
	318	self = newHV();
	319	stash = gv_stashpv(SvPV_nolen(package), 0);
	320
	321	self_ref = newRV_noinc((SV*)self);
	322
	323	sv_magic((SV*)self, NULL, PERL_MAGIC_ext, data, strlen(data));
	324	mg = mg_find((SV*)self, PERL_MAGIC_ext);
494d0b3d MH	325	if (mg)
	326	mg->mg_virtual = &null_mg_vtbl;
	327	else
	328	croak("No mg!");
ea4b7f32 JH	329
	330	RETVAL = sv_bless(self_ref, stash);
	331	OUTPUT:
	332	RETVAL
	333
	334	void
	335	remove_null_magic(self)
	336	SV *self
	337	PREINIT:
	338	HV *obj;
	339	PPCODE:
	340	obj = (HV*) SvRV(self);
	341
	342	sv_unmagicext((SV*)obj, PERL_MAGIC_ext, &null_mg_vtbl);
	343
	344	void
	345	remove_other_magic(self)
	346	SV *self
	347	PREINIT:
	348	HV *obj;
	349	PPCODE:
	350	obj = (HV*) SvRV(self);
	351
	352	sv_unmagicext((SV*)obj, PERL_MAGIC_ext, &other_mg_vtbl);
	353
	354	void
	355	as_string(self)
	356	SV *self
	357	PREINIT:
	358	HV *obj;
	359	MAGIC *mg;
	360	PPCODE:
	361	obj = (HV*) SvRV(self);
	362
	363	if ((mg = mg_findext((SV*)obj, PERL_MAGIC_ext, &null_mg_vtbl))) {
	364	XPUSHs(sv_2mortal(newSVpv(mg->mg_ptr, strlen(mg->mg_ptr))));
	365	} else {
744ef08f	366	XPUSHs(sv_2mortal(newSVpvs("Sorry, your princess is in another castle.")));
ea4b7f32 JH	367	}
ea4b7f32 JH	368
adfe19db MHM	369	void
adfe19db MHM	370	sv_catpv_mg(sv, string)
b2049988 MHM	371	SV *sv;
	372	char *string;
	373	CODE:
	374	sv_catpv_mg(sv, string);
adfe19db MHM	375
	376	void
	377	sv_catpvn_mg(sv, sv2)
b2049988 MHM	378	SV *sv;
	379	SV *sv2;
	380	PREINIT:
	381	char *str;
	382	STRLEN len;
	383	CODE:
	384	str = SvPV(sv2, len);
	385	sv_catpvn_mg(sv, str, len);
adfe19db MHM	386
	387	void
	388	sv_catsv_mg(sv, sv2)
b2049988 MHM	389	SV *sv;
	390	SV *sv2;
	391	CODE:
	392	sv_catsv_mg(sv, sv2);
adfe19db MHM	393
	394	void
	395	sv_setiv_mg(sv, iv)
b2049988 MHM	396	SV *sv;
	397	IV iv;
	398	CODE:
	399	sv_setiv_mg(sv, iv);
adfe19db MHM	400
	401	void
	402	sv_setnv_mg(sv, nv)
b2049988 MHM	403	SV *sv;
	404	NV nv;
	405	CODE:
	406	sv_setnv_mg(sv, nv);
adfe19db MHM	407
	408	void
	409	sv_setpv_mg(sv, pv)
b2049988 MHM	410	SV *sv;
	411	char *pv;
	412	CODE:
	413	sv_setpv_mg(sv, pv);
adfe19db MHM	414
	415	void
	416	sv_setpvn_mg(sv, sv2)
b2049988 MHM	417	SV *sv;
	418	SV *sv2;
	419	PREINIT:
	420	char *str;
	421	STRLEN len;
	422	CODE:
	423	str = SvPV(sv2, len);
	424	sv_setpvn_mg(sv, str, len);
adfe19db MHM	425
	426	void
	427	sv_setsv_mg(sv, sv2)
b2049988 MHM	428	SV *sv;
	429	SV *sv2;
	430	CODE:
	431	sv_setsv_mg(sv, sv2);
adfe19db MHM	432
	433	void
	434	sv_setuv_mg(sv, uv)
b2049988 MHM	435	SV *sv;
	436	UV uv;
	437	CODE:
	438	sv_setuv_mg(sv, uv);
adfe19db MHM	439
	440	void
	441	sv_usepvn_mg(sv, sv2)
b2049988 MHM	442	SV *sv;
	443	SV *sv2;
	444	PREINIT:
	445	char str, copy;
	446	STRLEN len;
	447	CODE:
	448	str = SvPV(sv2, len);
	449	New(42, copy, len+1, char);
	450	Copy(str, copy, len+1, char);
	451	sv_usepvn_mg(sv, copy, len);
adfe19db	452
f2ab5a41 MHM	453	int
f2ab5a41 MHM	454	SvVSTRING_mg(sv)
b2049988 MHM	455	SV *sv;
	456	CODE:
	457	RETVAL = SvVSTRING_mg(sv) != NULL;
	458	OUTPUT:
	459	RETVAL
f2ab5a41	460
679ad62d MHM	461	int
679ad62d MHM	462	sv_magic_portable(sv)
b2049988 MHM	463	SV *sv
	464	PREINIT:
	465	MAGIC *mg;
	466	const char *foo = "foo";
	467	CODE:
679ad62d	468	#if { VERSION >= 5.004 }
b2049988 MHM	469	sv_magic_portable(sv, 0, '~', foo, 0);
b2049988 MHM	470	mg = mg_find(sv, '~');
494d0b3d MH	471	if (!mg)
	472	croak("No mg!");
	473
b2049988	474	RETVAL = mg->mg_ptr == foo;
679ad62d	475	#else
b2049988 MHM	476	sv_magic(sv, 0, '~', (char *) foo, strlen(foo));
	477	mg = mg_find(sv, '~');
	478	RETVAL = strEQ(mg->mg_ptr, foo);
679ad62d	479	#endif
b2049988 MHM	480	sv_unmagic(sv, '~');
	481	OUTPUT:
	482	RETVAL
679ad62d	483
ea4b7f32 JH	484	=tests plan => 23
	485
	486	# Find proper magic
	487	ok(my $obj1 = Devel::PPPort->new_with_mg());
	488	ok(Devel::PPPort::as_string($obj1), 'hello');
	489
	490	# Find with no magic
	491	my $obj = bless {}, 'Fake::Class';
	492	ok(Devel::PPPort::as_string($obj), "Sorry, your princess is in another castle.");
	493
	494	# Find with other magic (not the magic we are looking for)
	495	ok($obj = Devel::PPPort->new_with_other_mg());
	496	ok(Devel::PPPort::as_string($obj), "Sorry, your princess is in another castle.");
	497
	498	# Okay, attempt to remove magic that isn't there
	499	Devel::PPPort::remove_other_magic($obj1);
	500	ok(Devel::PPPort::as_string($obj1), 'hello');
	501
	502	# Remove magic that IS there
	503	Devel::PPPort::remove_null_magic($obj1);
	504	ok(Devel::PPPort::as_string($obj1), "Sorry, your princess is in another castle.");
	505
	506	# Removing when no magic present
	507	Devel::PPPort::remove_null_magic($obj1);
	508	ok(Devel::PPPort::as_string($obj1), "Sorry, your princess is in another castle.");
adfe19db MHM	509
	510	use Tie::Hash;
	511	my %h;
	512	tie %h, 'Tie::StdHash';
	513	$h{foo} = 'foo';
	514	$h{bar} = '';
	515
	516	&Devel::PPPort::sv_catpv_mg($h{foo}, 'bar');
	517	ok($h{foo}, 'foobar');
	518
	519	&Devel::PPPort::sv_catpvn_mg($h{bar}, 'baz');
	520	ok($h{bar}, 'baz');
	521
	522	&Devel::PPPort::sv_catsv_mg($h{foo}, '42');
	523	ok($h{foo}, 'foobar42');
	524
	525	&Devel::PPPort::sv_setiv_mg($h{bar}, 42);
	526	ok($h{bar}, 42);
	527
	528	&Devel::PPPort::sv_setnv_mg($h{PI}, 3.14159);
	529	ok(abs($h{PI} - 3.14159) < 0.01);
	530
	531	&Devel::PPPort::sv_setpv_mg($h{mhx}, 'mhx');
	532	ok($h{mhx}, 'mhx');
	533
	534	&Devel::PPPort::sv_setpvn_mg($h{mhx}, 'Marcus');
	535	ok($h{mhx}, 'Marcus');
	536
	537	&Devel::PPPort::sv_setsv_mg($h{sv}, 'SV');
	538	ok($h{sv}, 'SV');
	539
	540	&Devel::PPPort::sv_setuv_mg($h{sv}, 4711);
	541	ok($h{sv}, 4711);
	542
	543	&Devel::PPPort::sv_usepvn_mg($h{sv}, 'Perl');
	544	ok($h{sv}, 'Perl');
	545
49ef49fe CBW	546	# v1 is treated as a bareword in older perls...
49ef49fe CBW	547	my $ver = do { local $SIG{'__WARN__'} = sub {}; eval qq[v1.2.0] };
f551177d S	548	ok("$]" < 5.009 \|\| $@ eq '');
f551177d S	549	ok("$]" < 5.009 \|\| Devel::PPPort::SvVSTRING_mg($ver));
f2ab5a41 MHM	550	ok(!Devel::PPPort::SvVSTRING_mg(4711));
f2ab5a41 MHM	551
679ad62d MHM	552	my $foo = 'bar';
	553	ok(Devel::PPPort::sv_magic_portable($foo));
	554	ok($foo eq 'bar');