magic

source of perl for linux application,

################################################################################
##
##  $Revision: 15 $
##  $Author: mhx $
##  $Date: 2007/09/11 23:20:42 +0200 $
##
################################################################################
##
##  Version 3.x, Copyright (C) 2004-2007, 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');

my $ver = eval qq[qv("v1.2.0")];
ok($[ < 5.009 || $@ eq '');
ok($@ || 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');