################################################################################
##
## 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
MUTABLE_PTR
MUTABLE_SV
=implementation
__UNDEFINED__ SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END
/* Some random bits for sv_unmagicext. These should probably be pulled in for
real and organized at some point */
__UNDEFINED__ HEf_SVKEY -2
#ifndef MUTABLE_PTR
#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
# define MUTABLE_PTR(p) ({ void *_p = (p); _p; })
#else
# define MUTABLE_PTR(p) ((void *) (p))
#endif
#endif
__UNDEFINED__ MUTABLE_SV(p) ((SV *)MUTABLE_PTR(p))
/* end of random bits */
__UNDEFINED__ PERL_MAGIC_sv '\0'
__UNDEFINED__ PERL_MAGIC_overload 'A'
__UNDEFINED__ PERL_MAGIC_overload_elem 'a'
__UNDEFINED__ PERL_MAGIC_overload_table 'c'
__UNDEFINED__ PERL_MAGIC_bm 'B'
__UNDEFINED__ PERL_MAGIC_regdata 'D'
__UNDEFINED__ PERL_MAGIC_regdatum 'd'
__UNDEFINED__ PERL_MAGIC_env 'E'
__UNDEFINED__ PERL_MAGIC_envelem 'e'
__UNDEFINED__ PERL_MAGIC_fm 'f'
__UNDEFINED__ PERL_MAGIC_regex_global 'g'
__UNDEFINED__ PERL_MAGIC_isa 'I'
__UNDEFINED__ PERL_MAGIC_isaelem 'i'
__UNDEFINED__ PERL_MAGIC_nkeys 'k'
__UNDEFINED__ PERL_MAGIC_dbfile 'L'
__UNDEFINED__ PERL_MAGIC_dbline 'l'
__UNDEFINED__ PERL_MAGIC_mutex 'm'
__UNDEFINED__ PERL_MAGIC_shared 'N'
__UNDEFINED__ PERL_MAGIC_shared_scalar 'n'
__UNDEFINED__ PERL_MAGIC_collxfrm 'o'
__UNDEFINED__ PERL_MAGIC_tied 'P'
__UNDEFINED__ PERL_MAGIC_tiedelem 'p'
__UNDEFINED__ PERL_MAGIC_tiedscalar 'q'
__UNDEFINED__ PERL_MAGIC_qr 'r'
__UNDEFINED__ PERL_MAGIC_sig 'S'
__UNDEFINED__ PERL_MAGIC_sigelem 's'
__UNDEFINED__ PERL_MAGIC_taint 't'
__UNDEFINED__ PERL_MAGIC_uvar 'U'
__UNDEFINED__ PERL_MAGIC_uvar_elem 'u'
__UNDEFINED__ PERL_MAGIC_vstring 'V'
__UNDEFINED__ PERL_MAGIC_vec 'v'
__UNDEFINED__ PERL_MAGIC_utf8 'w'
__UNDEFINED__ PERL_MAGIC_substr 'x'
__UNDEFINED__ PERL_MAGIC_defelem 'y'
__UNDEFINED__ PERL_MAGIC_glob '*'
__UNDEFINED__ PERL_MAGIC_arylen '#'
__UNDEFINED__ PERL_MAGIC_pos '.'
__UNDEFINED__ PERL_MAGIC_backref '<'
__UNDEFINED__ PERL_MAGIC_ext '~'
/* 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');