1 ################################################################################
5 ## $Date: 2009/01/18 14:10:55 +0100 $
7 ################################################################################
9 ## Version 3.x, Copyright (C) 2004-2009, Marcus Holland-Moritz.
10 ## Version 2.x, Copyright (C) 2001, Paul Marquess.
11 ## Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
13 ## This program is free software; you can redistribute it and/or
14 ## modify it under the same terms as Perl itself.
16 ################################################################################
26 __UNDEFINED__ SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END
28 __UNDEFINED__ PERL_MAGIC_sv '\0'
29 __UNDEFINED__ PERL_MAGIC_overload 'A'
30 __UNDEFINED__ PERL_MAGIC_overload_elem 'a'
31 __UNDEFINED__ PERL_MAGIC_overload_table 'c'
32 __UNDEFINED__ PERL_MAGIC_bm 'B'
33 __UNDEFINED__ PERL_MAGIC_regdata 'D'
34 __UNDEFINED__ PERL_MAGIC_regdatum 'd'
35 __UNDEFINED__ PERL_MAGIC_env 'E'
36 __UNDEFINED__ PERL_MAGIC_envelem 'e'
37 __UNDEFINED__ PERL_MAGIC_fm 'f'
38 __UNDEFINED__ PERL_MAGIC_regex_global 'g'
39 __UNDEFINED__ PERL_MAGIC_isa 'I'
40 __UNDEFINED__ PERL_MAGIC_isaelem 'i'
41 __UNDEFINED__ PERL_MAGIC_nkeys 'k'
42 __UNDEFINED__ PERL_MAGIC_dbfile 'L'
43 __UNDEFINED__ PERL_MAGIC_dbline 'l'
44 __UNDEFINED__ PERL_MAGIC_mutex 'm'
45 __UNDEFINED__ PERL_MAGIC_shared 'N'
46 __UNDEFINED__ PERL_MAGIC_shared_scalar 'n'
47 __UNDEFINED__ PERL_MAGIC_collxfrm 'o'
48 __UNDEFINED__ PERL_MAGIC_tied 'P'
49 __UNDEFINED__ PERL_MAGIC_tiedelem 'p'
50 __UNDEFINED__ PERL_MAGIC_tiedscalar 'q'
51 __UNDEFINED__ PERL_MAGIC_qr 'r'
52 __UNDEFINED__ PERL_MAGIC_sig 'S'
53 __UNDEFINED__ PERL_MAGIC_sigelem 's'
54 __UNDEFINED__ PERL_MAGIC_taint 't'
55 __UNDEFINED__ PERL_MAGIC_uvar 'U'
56 __UNDEFINED__ PERL_MAGIC_uvar_elem 'u'
57 __UNDEFINED__ PERL_MAGIC_vstring 'V'
58 __UNDEFINED__ PERL_MAGIC_vec 'v'
59 __UNDEFINED__ PERL_MAGIC_utf8 'w'
60 __UNDEFINED__ PERL_MAGIC_substr 'x'
61 __UNDEFINED__ PERL_MAGIC_defelem 'y'
62 __UNDEFINED__ PERL_MAGIC_glob '*'
63 __UNDEFINED__ PERL_MAGIC_arylen '#'
64 __UNDEFINED__ PERL_MAGIC_pos '.'
65 __UNDEFINED__ PERL_MAGIC_backref '<'
66 __UNDEFINED__ PERL_MAGIC_ext '~'
68 /* That's the best we can do... */
69 __UNDEFINED__ sv_catpvn_nomg sv_catpvn
70 __UNDEFINED__ sv_catsv_nomg sv_catsv
71 __UNDEFINED__ sv_setsv_nomg sv_setsv
72 __UNDEFINED__ sv_pvn_nomg sv_pvn
73 __UNDEFINED__ SvIV_nomg SvIV
74 __UNDEFINED__ SvUV_nomg SvUV
77 # define sv_catpv_mg(sv, ptr) \
80 sv_catpv(TeMpSv,ptr); \
86 # define sv_catpvn_mg(sv, ptr, len) \
89 sv_catpvn(TeMpSv,ptr,len); \
95 # define sv_catsv_mg(dsv, ssv) \
98 sv_catsv(TeMpSv,ssv); \
104 # define sv_setiv_mg(sv, i) \
107 sv_setiv(TeMpSv,i); \
108 SvSETMAGIC(TeMpSv); \
113 # define sv_setnv_mg(sv, num) \
116 sv_setnv(TeMpSv,num); \
117 SvSETMAGIC(TeMpSv); \
122 # define sv_setpv_mg(sv, ptr) \
125 sv_setpv(TeMpSv,ptr); \
126 SvSETMAGIC(TeMpSv); \
131 # define sv_setpvn_mg(sv, ptr, len) \
134 sv_setpvn(TeMpSv,ptr,len); \
135 SvSETMAGIC(TeMpSv); \
140 # define sv_setsv_mg(dsv, ssv) \
143 sv_setsv(TeMpSv,ssv); \
144 SvSETMAGIC(TeMpSv); \
149 # define sv_setuv_mg(sv, i) \
152 sv_setuv(TeMpSv,i); \
153 SvSETMAGIC(TeMpSv); \
158 # define sv_usepvn_mg(sv, ptr, len) \
161 sv_usepvn(TeMpSv,ptr,len); \
162 SvSETMAGIC(TeMpSv); \
166 __UNDEFINED__ SvVSTRING_mg(sv) (SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_vstring) : NULL)
168 /* Hint: sv_magic_portable
169 * This is a compatibility function that is only available with
170 * Devel::PPPort. It is NOT in the perl core.
171 * Its purpose is to mimic the 5.8.0 behaviour of sv_magic() when
172 * it is being passed a name pointer with namlen == 0. In that
173 * case, perl 5.8.0 and later store the pointer, not a copy of it.
174 * The compatibility can be provided back to perl 5.004. With
175 * earlier versions, the code will not compile.
178 #if { VERSION < 5.004 }
180 /* code that uses sv_magic_portable will not compile */
182 #elif { VERSION < 5.8.0 }
184 # define sv_magic_portable(sv, obj, how, name, namlen) \
186 SV *SvMp_sv = (sv); \
187 char *SvMp_name = (char *) (name); \
188 I32 SvMp_namlen = (namlen); \
189 if (SvMp_name && SvMp_namlen == 0) \
192 sv_magic(SvMp_sv, obj, how, 0, 0); \
193 mg = SvMAGIC(SvMp_sv); \
194 mg->mg_len = -42; /* XXX: this is the tricky part */ \
195 mg->mg_ptr = SvMp_name; \
199 sv_magic(SvMp_sv, obj, how, SvMp_name, SvMp_namlen); \
205 # define sv_magic_portable(a, b, c, d, e) sv_magic(a, b, c, d, e)
212 sv_catpv_mg(sv, string)
216 sv_catpv_mg(sv, string);
219 sv_catpvn_mg(sv, sv2)
226 str = SvPV(sv2, len);
227 sv_catpvn_mg(sv, str, len);
234 sv_catsv_mg(sv, sv2);
258 sv_setpvn_mg(sv, sv2)
265 str = SvPV(sv2, len);
266 sv_setpvn_mg(sv, str, len);
273 sv_setsv_mg(sv, sv2);
283 sv_usepvn_mg(sv, sv2)
290 str = SvPV(sv2, len);
291 New(42, copy, len+1, char);
292 Copy(str, copy, len+1, char);
293 sv_usepvn_mg(sv, copy, len);
299 RETVAL = SvVSTRING_mg(sv) != NULL;
304 sv_magic_portable(sv)
308 const char *foo = "foo";
310 #if { VERSION >= 5.004 }
311 sv_magic_portable(sv, 0, '~', foo, 0);
312 mg = mg_find(sv, '~');
313 RETVAL = mg->mg_ptr == foo;
315 sv_magic(sv, 0, '~', (char *) foo, strlen(foo));
316 mg = mg_find(sv, '~');
317 RETVAL = strEQ(mg->mg_ptr, foo);
327 tie %h, 'Tie::StdHash';
331 &Devel::PPPort::sv_catpv_mg($h{foo}, 'bar');
332 ok($h{foo}, 'foobar');
334 &Devel::PPPort::sv_catpvn_mg($h{bar}, 'baz');
337 &Devel::PPPort::sv_catsv_mg($h{foo}, '42');
338 ok($h{foo}, 'foobar42');
340 &Devel::PPPort::sv_setiv_mg($h{bar}, 42);
343 &Devel::PPPort::sv_setnv_mg($h{PI}, 3.14159);
344 ok(abs($h{PI} - 3.14159) < 0.01);
346 &Devel::PPPort::sv_setpv_mg($h{mhx}, 'mhx');
349 &Devel::PPPort::sv_setpvn_mg($h{mhx}, 'Marcus');
350 ok($h{mhx}, 'Marcus');
352 &Devel::PPPort::sv_setsv_mg($h{sv}, 'SV');
355 &Devel::PPPort::sv_setuv_mg($h{sv}, 4711);
358 &Devel::PPPort::sv_usepvn_mg($h{sv}, 'Perl');
361 my $ver = eval qq[qv("v1.2.0")];
362 ok($[ < 5.009 || $@ eq '');
363 ok($@ || Devel::PPPort::SvVSTRING_mg($ver));
364 ok(!Devel::PPPort::SvVSTRING_mg(4711));
367 ok(Devel::PPPort::sv_magic_portable($foo));