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