mg_findext sv_unmagicext

__UNDEFINED__ /sv_\w+_mg/ sv_magic_portable MUTABLE_PTR MUTABLE_SV

__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

#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

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

#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 */ };

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

# 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');

cpanm Devel::PPPort

perl -MCPAN -e shell
install Devel::PPPort