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