################################################################################
##
## 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
__UNDEFINED__
/sv_\w+_mg/
sv_magic_portable
=implementation
__UNDEFINED__ SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END
__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
=xsubs
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, '~');
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 => 15
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');