Commit | Line | Data |
adfe19db |
1 | ################################################################################ |
2 | ## |
bfc37ff7 |
3 | ## $Revision: 21 $ |
adfe19db |
4 | ## $Author: mhx $ |
bfc37ff7 |
5 | ## $Date: 2010/03/07 13:15:49 +0100 $ |
adfe19db |
6 | ## |
7 | ################################################################################ |
8 | ## |
bfc37ff7 |
9 | ## Version 3.x, Copyright (C) 2004-2010, Marcus Holland-Moritz. |
adfe19db |
10 | ## Version 2.x, Copyright (C) 2001, Paul Marquess. |
11 | ## Version 1.x, Copyright (C) 1999, Kenneth Albanowski. |
12 | ## |
13 | ## This program is free software; you can redistribute it and/or |
14 | ## modify it under the same terms as Perl itself. |
15 | ## |
16 | ################################################################################ |
17 | |
18 | =provides |
19 | |
20 | __UNDEFINED__ |
21 | /sv_\w+_mg/ |
679ad62d |
22 | sv_magic_portable |
adfe19db |
23 | |
24 | =implementation |
25 | |
26 | __UNDEFINED__ SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END |
27 | |
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 '~' |
67 | |
68 | /* That's the best we can do... */ |
adfe19db |
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 |
75 | |
76 | #ifndef sv_catpv_mg |
77 | # define sv_catpv_mg(sv, ptr) \ |
78 | STMT_START { \ |
79 | SV *TeMpSv = sv; \ |
80 | sv_catpv(TeMpSv,ptr); \ |
81 | SvSETMAGIC(TeMpSv); \ |
82 | } STMT_END |
83 | #endif |
84 | |
85 | #ifndef sv_catpvn_mg |
86 | # define sv_catpvn_mg(sv, ptr, len) \ |
87 | STMT_START { \ |
88 | SV *TeMpSv = sv; \ |
89 | sv_catpvn(TeMpSv,ptr,len); \ |
90 | SvSETMAGIC(TeMpSv); \ |
91 | } STMT_END |
92 | #endif |
93 | |
94 | #ifndef sv_catsv_mg |
95 | # define sv_catsv_mg(dsv, ssv) \ |
96 | STMT_START { \ |
97 | SV *TeMpSv = dsv; \ |
98 | sv_catsv(TeMpSv,ssv); \ |
99 | SvSETMAGIC(TeMpSv); \ |
100 | } STMT_END |
101 | #endif |
102 | |
103 | #ifndef sv_setiv_mg |
104 | # define sv_setiv_mg(sv, i) \ |
105 | STMT_START { \ |
106 | SV *TeMpSv = sv; \ |
107 | sv_setiv(TeMpSv,i); \ |
108 | SvSETMAGIC(TeMpSv); \ |
109 | } STMT_END |
110 | #endif |
111 | |
112 | #ifndef sv_setnv_mg |
113 | # define sv_setnv_mg(sv, num) \ |
114 | STMT_START { \ |
115 | SV *TeMpSv = sv; \ |
116 | sv_setnv(TeMpSv,num); \ |
117 | SvSETMAGIC(TeMpSv); \ |
118 | } STMT_END |
119 | #endif |
120 | |
121 | #ifndef sv_setpv_mg |
122 | # define sv_setpv_mg(sv, ptr) \ |
123 | STMT_START { \ |
124 | SV *TeMpSv = sv; \ |
125 | sv_setpv(TeMpSv,ptr); \ |
126 | SvSETMAGIC(TeMpSv); \ |
127 | } STMT_END |
128 | #endif |
129 | |
130 | #ifndef sv_setpvn_mg |
131 | # define sv_setpvn_mg(sv, ptr, len) \ |
132 | STMT_START { \ |
133 | SV *TeMpSv = sv; \ |
134 | sv_setpvn(TeMpSv,ptr,len); \ |
135 | SvSETMAGIC(TeMpSv); \ |
136 | } STMT_END |
137 | #endif |
138 | |
139 | #ifndef sv_setsv_mg |
140 | # define sv_setsv_mg(dsv, ssv) \ |
141 | STMT_START { \ |
142 | SV *TeMpSv = dsv; \ |
143 | sv_setsv(TeMpSv,ssv); \ |
144 | SvSETMAGIC(TeMpSv); \ |
145 | } STMT_END |
146 | #endif |
147 | |
148 | #ifndef sv_setuv_mg |
149 | # define sv_setuv_mg(sv, i) \ |
150 | STMT_START { \ |
151 | SV *TeMpSv = sv; \ |
152 | sv_setuv(TeMpSv,i); \ |
153 | SvSETMAGIC(TeMpSv); \ |
154 | } STMT_END |
155 | #endif |
156 | |
157 | #ifndef sv_usepvn_mg |
158 | # define sv_usepvn_mg(sv, ptr, len) \ |
159 | STMT_START { \ |
160 | SV *TeMpSv = sv; \ |
161 | sv_usepvn(TeMpSv,ptr,len); \ |
162 | SvSETMAGIC(TeMpSv); \ |
163 | } STMT_END |
164 | #endif |
165 | |
f2ab5a41 |
166 | __UNDEFINED__ SvVSTRING_mg(sv) (SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_vstring) : NULL) |
167 | |
679ad62d |
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. |
176 | */ |
177 | |
178 | #if { VERSION < 5.004 } |
179 | |
180 | /* code that uses sv_magic_portable will not compile */ |
181 | |
182 | #elif { VERSION < 5.8.0 } |
183 | |
c83e6f19 |
184 | # define sv_magic_portable(sv, obj, how, name, namlen) \ |
185 | STMT_START { \ |
186 | SV *SvMp_sv = (sv); \ |
187 | char *SvMp_name = (char *) (name); \ |
188 | I32 SvMp_namlen = (namlen); \ |
189 | if (SvMp_name && SvMp_namlen == 0) \ |
190 | { \ |
191 | MAGIC *mg; \ |
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; \ |
196 | } \ |
197 | else \ |
198 | { \ |
199 | sv_magic(SvMp_sv, obj, how, SvMp_name, SvMp_namlen); \ |
200 | } \ |
679ad62d |
201 | } STMT_END |
202 | |
203 | #else |
204 | |
205 | # define sv_magic_portable(a, b, c, d, e) sv_magic(a, b, c, d, e) |
206 | |
207 | #endif |
208 | |
adfe19db |
209 | =xsubs |
210 | |
211 | void |
212 | sv_catpv_mg(sv, string) |
213 | SV *sv; |
214 | char *string; |
215 | CODE: |
216 | sv_catpv_mg(sv, string); |
217 | |
218 | void |
219 | sv_catpvn_mg(sv, sv2) |
220 | SV *sv; |
221 | SV *sv2; |
222 | PREINIT: |
223 | char *str; |
224 | STRLEN len; |
225 | CODE: |
226 | str = SvPV(sv2, len); |
227 | sv_catpvn_mg(sv, str, len); |
228 | |
229 | void |
230 | sv_catsv_mg(sv, sv2) |
231 | SV *sv; |
232 | SV *sv2; |
233 | CODE: |
234 | sv_catsv_mg(sv, sv2); |
235 | |
236 | void |
237 | sv_setiv_mg(sv, iv) |
238 | SV *sv; |
239 | IV iv; |
240 | CODE: |
241 | sv_setiv_mg(sv, iv); |
242 | |
243 | void |
244 | sv_setnv_mg(sv, nv) |
245 | SV *sv; |
246 | NV nv; |
247 | CODE: |
248 | sv_setnv_mg(sv, nv); |
249 | |
250 | void |
251 | sv_setpv_mg(sv, pv) |
252 | SV *sv; |
253 | char *pv; |
254 | CODE: |
255 | sv_setpv_mg(sv, pv); |
256 | |
257 | void |
258 | sv_setpvn_mg(sv, sv2) |
259 | SV *sv; |
260 | SV *sv2; |
261 | PREINIT: |
262 | char *str; |
263 | STRLEN len; |
264 | CODE: |
265 | str = SvPV(sv2, len); |
266 | sv_setpvn_mg(sv, str, len); |
267 | |
268 | void |
269 | sv_setsv_mg(sv, sv2) |
270 | SV *sv; |
271 | SV *sv2; |
272 | CODE: |
273 | sv_setsv_mg(sv, sv2); |
274 | |
275 | void |
276 | sv_setuv_mg(sv, uv) |
277 | SV *sv; |
278 | UV uv; |
279 | CODE: |
280 | sv_setuv_mg(sv, uv); |
281 | |
282 | void |
283 | sv_usepvn_mg(sv, sv2) |
284 | SV *sv; |
285 | SV *sv2; |
286 | PREINIT: |
287 | char *str, *copy; |
288 | STRLEN len; |
289 | CODE: |
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); |
294 | |
f2ab5a41 |
295 | int |
296 | SvVSTRING_mg(sv) |
297 | SV *sv; |
298 | CODE: |
299 | RETVAL = SvVSTRING_mg(sv) != NULL; |
300 | OUTPUT: |
301 | RETVAL |
302 | |
679ad62d |
303 | int |
304 | sv_magic_portable(sv) |
305 | SV *sv |
306 | PREINIT: |
307 | MAGIC *mg; |
308 | const char *foo = "foo"; |
309 | CODE: |
310 | #if { VERSION >= 5.004 } |
311 | sv_magic_portable(sv, 0, '~', foo, 0); |
312 | mg = mg_find(sv, '~'); |
313 | RETVAL = mg->mg_ptr == foo; |
314 | #else |
aab9a3b6 |
315 | sv_magic(sv, 0, '~', (char *) foo, strlen(foo)); |
679ad62d |
316 | mg = mg_find(sv, '~'); |
317 | RETVAL = strEQ(mg->mg_ptr, foo); |
318 | #endif |
319 | sv_unmagic(sv, '~'); |
320 | OUTPUT: |
321 | RETVAL |
322 | |
323 | =tests plan => 15 |
adfe19db |
324 | |
325 | use Tie::Hash; |
326 | my %h; |
327 | tie %h, 'Tie::StdHash'; |
328 | $h{foo} = 'foo'; |
329 | $h{bar} = ''; |
330 | |
331 | &Devel::PPPort::sv_catpv_mg($h{foo}, 'bar'); |
332 | ok($h{foo}, 'foobar'); |
333 | |
334 | &Devel::PPPort::sv_catpvn_mg($h{bar}, 'baz'); |
335 | ok($h{bar}, 'baz'); |
336 | |
337 | &Devel::PPPort::sv_catsv_mg($h{foo}, '42'); |
338 | ok($h{foo}, 'foobar42'); |
339 | |
340 | &Devel::PPPort::sv_setiv_mg($h{bar}, 42); |
341 | ok($h{bar}, 42); |
342 | |
343 | &Devel::PPPort::sv_setnv_mg($h{PI}, 3.14159); |
344 | ok(abs($h{PI} - 3.14159) < 0.01); |
345 | |
346 | &Devel::PPPort::sv_setpv_mg($h{mhx}, 'mhx'); |
347 | ok($h{mhx}, 'mhx'); |
348 | |
349 | &Devel::PPPort::sv_setpvn_mg($h{mhx}, 'Marcus'); |
350 | ok($h{mhx}, 'Marcus'); |
351 | |
352 | &Devel::PPPort::sv_setsv_mg($h{sv}, 'SV'); |
353 | ok($h{sv}, 'SV'); |
354 | |
355 | &Devel::PPPort::sv_setuv_mg($h{sv}, 4711); |
356 | ok($h{sv}, 4711); |
357 | |
358 | &Devel::PPPort::sv_usepvn_mg($h{sv}, 'Perl'); |
359 | ok($h{sv}, 'Perl'); |
360 | |
bfc37ff7 |
361 | # v1 is treated as a bareword in older perls... |
362 | my $ver = do { local $SIG{'__WARN__'} = sub {}; eval qq[v1.2.0] }; |
363 | ok($] < 5.009 || $@ eq ''); |
364 | ok($] < 5.009 || Devel::PPPort::SvVSTRING_mg($ver)); |
f2ab5a41 |
365 | ok(!Devel::PPPort::SvVSTRING_mg(4711)); |
366 | |
679ad62d |
367 | my $foo = 'bar'; |
368 | ok(Devel::PPPort::sv_magic_portable($foo)); |
369 | ok($foo eq 'bar'); |
370 | |