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
21SvIV_nomg
22SvUV_nomg
23SvNV_nomg
24SvTRUE_nomg
25
26=implementation
27
28__UNDEFINED__  SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END
29
30/* That's the best we can do... */
31__UNDEFINED__  sv_catpvn_nomg     sv_catpvn
32__UNDEFINED__  sv_catsv_nomg      sv_catsv
33__UNDEFINED__  sv_setsv_nomg      sv_setsv
34__UNDEFINED__  sv_pvn_nomg        sv_pvn
35
36#ifdef SVf_IVisUV
37#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
38__UNDEFINED__ SvIV_nomg(sv) (!SvGMAGICAL((sv)) ? SvIV((sv)) : ({ SV *_sviv = sv_mortalcopy_flags((sv), SV_NOSTEAL); IV _iv = SvIV(_sviv); SvFLAGS((sv)) = (SvFLAGS((sv)) & ~SVf_IVisUV) | (SvFLAGS(_sviv) & SVf_IVisUV); _iv; }))
39__UNDEFINED__ SvUV_nomg(sv) (!SvGMAGICAL((sv)) ? SvUV((sv)) : ({ SV *_svuv = sv_mortalcopy_flags((sv), SV_NOSTEAL); UV _uv = SvUV(_svuv); SvFLAGS((sv)) = (SvFLAGS((sv)) & ~SVf_IVisUV) | (SvFLAGS(_svuv) & SVf_IVisUV); _uv; }))
40#else
41__UNDEFINED__ SvIV_nomg(sv) (!SvGMAGICAL((sv)) ? SvIV((sv)) : ((PL_Sv = sv_mortalcopy_flags((sv), SV_NOSTEAL)), sv_upgrade(PL_Sv, SVt_PVIV), (SvIVX(PL_Sv) = SvIV(PL_Sv)), (SvFLAGS((sv)) = (SvFLAGS((sv)) & ~SVf_IVisUV) | (SvFLAGS(PL_Sv) & SVf_IVisUV)), SvIVX(PL_Sv)))
42__UNDEFINED__ SvUV_nomg(sv) (!SvGMAGICAL((sv)) ? SvIV((sv)) : ((PL_Sv = sv_mortalcopy_flags((sv), SV_NOSTEAL)), sv_upgrade(PL_Sv, SVt_PVIV), (SvUVX(PL_Sv) = SvUV(PL_Sv)), (SvFLAGS((sv)) = (SvFLAGS((sv)) & ~SVf_IVisUV) | (SvFLAGS(PL_Sv) & SVf_IVisUV)), SvUVX(PL_Sv)))
43#endif
44#else
45__UNDEFINED__ SvIV_nomg(sv) (!SvGMAGICAL((sv)) ? SvIV((sv)) : SvIVx(sv_mortalcopy_flags((sv), SV_NOSTEAL)))
46__UNDEFINED__ SvUV_nomg(sv) (!SvGMAGICAL((sv)) ? SvUV((sv)) : SvUVx(sv_mortalcopy_flags((sv), SV_NOSTEAL)))
47#endif
48
49__UNDEFINED__ SvNV_nomg(sv) (!SvGMAGICAL((sv)) ? SvNV((sv)) : SvNVx(sv_mortalcopy_flags((sv), SV_NOSTEAL)))
50__UNDEFINED__ SvTRUE_nomg(sv) (!SvGMAGICAL((sv)) ? SvTRUE((sv)) : SvTRUEx(sv_mortalcopy_flags((sv), SV_NOSTEAL)))
51
52#ifndef sv_catpv_mg
53#  define sv_catpv_mg(sv, ptr)          \
54   STMT_START {                         \
55     SV *TeMpSv = sv;                   \
56     sv_catpv(TeMpSv,ptr);              \
57     SvSETMAGIC(TeMpSv);                \
58   } STMT_END
59#endif
60
61#ifndef sv_catpvn_mg
62#  define sv_catpvn_mg(sv, ptr, len)    \
63   STMT_START {                         \
64     SV *TeMpSv = sv;                   \
65     sv_catpvn(TeMpSv,ptr,len);         \
66     SvSETMAGIC(TeMpSv);                \
67   } STMT_END
68#endif
69
70#ifndef sv_catsv_mg
71#  define sv_catsv_mg(dsv, ssv)         \
72   STMT_START {                         \
73     SV *TeMpSv = dsv;                  \
74     sv_catsv(TeMpSv,ssv);              \
75     SvSETMAGIC(TeMpSv);                \
76   } STMT_END
77#endif
78
79#ifndef sv_setiv_mg
80#  define sv_setiv_mg(sv, i)            \
81   STMT_START {                         \
82     SV *TeMpSv = sv;                   \
83     sv_setiv(TeMpSv,i);                \
84     SvSETMAGIC(TeMpSv);                \
85   } STMT_END
86#endif
87
88#ifndef sv_setnv_mg
89#  define sv_setnv_mg(sv, num)          \
90   STMT_START {                         \
91     SV *TeMpSv = sv;                   \
92     sv_setnv(TeMpSv,num);              \
93     SvSETMAGIC(TeMpSv);                \
94   } STMT_END
95#endif
96
97#ifndef sv_setpv_mg
98#  define sv_setpv_mg(sv, ptr)          \
99   STMT_START {                         \
100     SV *TeMpSv = sv;                   \
101     sv_setpv(TeMpSv,ptr);              \
102     SvSETMAGIC(TeMpSv);                \
103   } STMT_END
104#endif
105
106#ifndef sv_setpvn_mg
107#  define sv_setpvn_mg(sv, ptr, len)    \
108   STMT_START {                         \
109     SV *TeMpSv = sv;                   \
110     sv_setpvn(TeMpSv,ptr,len);         \
111     SvSETMAGIC(TeMpSv);                \
112   } STMT_END
113#endif
114
115#ifndef sv_setsv_mg
116#  define sv_setsv_mg(dsv, ssv)         \
117   STMT_START {                         \
118     SV *TeMpSv = dsv;                  \
119     sv_setsv(TeMpSv,ssv);              \
120     SvSETMAGIC(TeMpSv);                \
121   } STMT_END
122#endif
123
124#ifndef sv_setuv_mg
125#  define sv_setuv_mg(sv, i)            \
126   STMT_START {                         \
127     SV *TeMpSv = sv;                   \
128     sv_setuv(TeMpSv,i);                \
129     SvSETMAGIC(TeMpSv);                \
130   } STMT_END
131#endif
132
133#ifndef sv_usepvn_mg
134#  define sv_usepvn_mg(sv, ptr, len)    \
135   STMT_START {                         \
136     SV *TeMpSv = sv;                   \
137     sv_usepvn(TeMpSv,ptr,len);         \
138     SvSETMAGIC(TeMpSv);                \
139   } STMT_END
140#endif
141
142__UNDEFINED__  SvVSTRING_mg(sv)  (SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_vstring) : NULL)
143
144/* Hint: sv_magic_portable
145 * This is a compatibility function that is only available with
146 * Devel::PPPort. It is NOT in the perl core.
147 * Its purpose is to mimic the 5.8.0 behaviour of sv_magic() when
148 * it is being passed a name pointer with namlen == 0. In that
149 * case, perl 5.8.0 and later store the pointer, not a copy of it.
150 * The compatibility can be provided back to perl 5.004. With
151 * earlier versions, the code will not compile.
152 */
153
154#if { VERSION < 5.004 }
155
156  /* code that uses sv_magic_portable will not compile */
157
158#elif { VERSION < 5.8.0 }
159
160#  define sv_magic_portable(sv, obj, how, name, namlen)     \
161   STMT_START {                                             \
162     SV *SvMp_sv = (sv);                                    \
163     char *SvMp_name = (char *) (name);                     \
164     I32 SvMp_namlen = (namlen);                            \
165     if (SvMp_name && SvMp_namlen == 0)                     \
166     {                                                      \
167       MAGIC *mg;                                           \
168       sv_magic(SvMp_sv, obj, how, 0, 0);                   \
169       mg = SvMAGIC(SvMp_sv);                               \
170       mg->mg_len = -42; /* XXX: this is the tricky part */ \
171       mg->mg_ptr = SvMp_name;                              \
172     }                                                      \
173     else                                                   \
174     {                                                      \
175       sv_magic(SvMp_sv, obj, how, SvMp_name, SvMp_namlen); \
176     }                                                      \
177   } STMT_END
178
179#else
180
181#  define sv_magic_portable(a, b, c, d, e)  sv_magic(a, b, c, d, e)
182
183#endif
184
185#if !defined(mg_findext)
186#if { NEED mg_findext }
187
188MAGIC *
189mg_findext(const SV * sv, int type, const MGVTBL *vtbl) {
190    if (sv) {
191        MAGIC *mg;
192
193#ifdef AvPAD_NAMELIST
194        assert(!(SvTYPE(sv) == SVt_PVAV && AvPAD_NAMELIST(sv)));
195#endif
196
197        for (mg = SvMAGIC (sv); mg; mg = mg->mg_moremagic) {
198            if (mg->mg_type == type && mg->mg_virtual == vtbl)
199                return mg;
200        }
201    }
202
203    return NULL;
204}
205
206#endif
207#endif
208
209#if !defined(sv_unmagicext)
210#if { NEED sv_unmagicext }
211
212int
213sv_unmagicext(pTHX_ SV *const sv, const int type, MGVTBL *vtbl)
214{
215    MAGIC* mg;
216    MAGIC** mgp;
217
218    if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
219	return 0;
220    mgp = &(SvMAGIC(sv));
221    for (mg = *mgp; mg; mg = *mgp) {
222	const MGVTBL* const virt = mg->mg_virtual;
223	if (mg->mg_type == type && virt == vtbl) {
224	    *mgp = mg->mg_moremagic;
225	    if (virt && virt->svt_free)
226		virt->svt_free(aTHX_ sv, mg);
227	    if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
228		if (mg->mg_len > 0)
229		    Safefree(mg->mg_ptr);
230		else if (mg->mg_len == HEf_SVKEY) /* Questionable on older perls... */
231		    SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
232		else if (mg->mg_type == PERL_MAGIC_utf8)
233		    Safefree(mg->mg_ptr);
234            }
235	    if (mg->mg_flags & MGf_REFCOUNTED)
236		SvREFCNT_dec(mg->mg_obj);
237	    Safefree(mg);
238	}
239	else
240	    mgp = &mg->mg_moremagic;
241    }
242    if (SvMAGIC(sv)) {
243	if (SvMAGICAL(sv))	/* if we're under save_magic, wait for restore_magic; */
244	    mg_magical(sv);	/*    else fix the flags now */
245    }
246    else {
247	SvMAGICAL_off(sv);
248	SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
249    }
250    return 0;
251}
252
253#endif
254#endif
255
256=xsinit
257
258#define NEED_mg_findext
259#define NEED_sv_unmagicext
260
261#ifndef STATIC
262#define STATIC static
263#endif
264
265STATIC MGVTBL null_mg_vtbl = {
266    NULL, /* get */
267    NULL, /* set */
268    NULL, /* len */
269    NULL, /* clear */
270    NULL, /* free */
271#if MGf_COPY
272    NULL, /* copy */
273#endif /* MGf_COPY */
274#if MGf_DUP
275    NULL, /* dup */
276#endif /* MGf_DUP */
277#if MGf_LOCAL
278    NULL, /* local */
279#endif /* MGf_LOCAL */
280};
281
282STATIC MGVTBL other_mg_vtbl = {
283    NULL, /* get */
284    NULL, /* set */
285    NULL, /* len */
286    NULL, /* clear */
287    NULL, /* free */
288#if MGf_COPY
289    NULL, /* copy */
290#endif /* MGf_COPY */
291#if MGf_DUP
292    NULL, /* dup */
293#endif /* MGf_DUP */
294#if MGf_LOCAL
295    NULL, /* local */
296#endif /* MGf_LOCAL */
297};
298
299=xsubs
300
301SV *
302new_with_other_mg(package, ...)
303    SV *package
304  PREINIT:
305    HV *self;
306    HV *stash;
307    SV *self_ref;
308    const char *data = "hello\0";
309    MAGIC *mg;
310  CODE:
311    self = newHV();
312    stash = gv_stashpv(SvPV_nolen(package), 0);
313
314    self_ref = newRV_noinc((SV*)self);
315
316    sv_magic((SV*)self, NULL, PERL_MAGIC_ext, data, strlen(data));
317    mg = mg_find((SV*)self, PERL_MAGIC_ext);
318    if (mg)
319      mg->mg_virtual = &other_mg_vtbl;
320    else
321      croak("No mg!");
322
323    RETVAL = sv_bless(self_ref, stash);
324  OUTPUT:
325    RETVAL
326
327SV *
328new_with_mg(package, ...)
329    SV *package
330  PREINIT:
331    HV *self;
332    HV *stash;
333    SV *self_ref;
334    const char *data = "hello\0";
335    MAGIC *mg;
336  CODE:
337    self = newHV();
338    stash = gv_stashpv(SvPV_nolen(package), 0);
339
340    self_ref = newRV_noinc((SV*)self);
341
342    sv_magic((SV*)self, NULL, PERL_MAGIC_ext, data, strlen(data));
343    mg = mg_find((SV*)self, PERL_MAGIC_ext);
344    if (mg)
345      mg->mg_virtual = &null_mg_vtbl;
346    else
347      croak("No mg!");
348
349    RETVAL = sv_bless(self_ref, stash);
350  OUTPUT:
351    RETVAL
352
353void
354remove_null_magic(self)
355    SV *self
356  PREINIT:
357    HV *obj;
358  PPCODE:
359    obj = (HV*) SvRV(self);
360
361    sv_unmagicext((SV*)obj, PERL_MAGIC_ext, &null_mg_vtbl);
362
363void
364remove_other_magic(self)
365    SV *self
366  PREINIT:
367    HV *obj;
368  PPCODE:
369    obj = (HV*) SvRV(self);
370
371    sv_unmagicext((SV*)obj, PERL_MAGIC_ext, &other_mg_vtbl);
372
373void
374as_string(self)
375    SV *self
376  PREINIT:
377    HV *obj;
378    MAGIC *mg;
379  PPCODE:
380    obj = (HV*) SvRV(self);
381
382    if ((mg = mg_findext((SV*)obj, PERL_MAGIC_ext, &null_mg_vtbl))) {
383        XPUSHs(sv_2mortal(newSVpv(mg->mg_ptr, strlen(mg->mg_ptr))));
384    } else {
385        XPUSHs(sv_2mortal(newSVpvs("Sorry, your princess is in another castle.")));
386    }
387
388void
389sv_catpv_mg(sv, string)
390        SV *sv;
391        char *string;
392        CODE:
393                sv_catpv_mg(sv, string);
394
395void
396sv_catpvn_mg(sv, sv2)
397        SV *sv;
398        SV *sv2;
399        PREINIT:
400                char *str;
401                STRLEN len;
402        CODE:
403                str = SvPV(sv2, len);
404                sv_catpvn_mg(sv, str, len);
405
406void
407sv_catsv_mg(sv, sv2)
408        SV *sv;
409        SV *sv2;
410        CODE:
411                sv_catsv_mg(sv, sv2);
412
413void
414sv_setiv_mg(sv, iv)
415        SV *sv;
416        IV iv;
417        CODE:
418                sv_setiv_mg(sv, iv);
419
420void
421sv_setnv_mg(sv, nv)
422        SV *sv;
423        NV nv;
424        CODE:
425                sv_setnv_mg(sv, nv);
426
427void
428sv_setpv_mg(sv, pv)
429        SV *sv;
430        char *pv;
431        CODE:
432                sv_setpv_mg(sv, pv);
433
434void
435sv_setpvn_mg(sv, sv2)
436        SV *sv;
437        SV *sv2;
438        PREINIT:
439                char *str;
440                STRLEN len;
441        CODE:
442                str = SvPV(sv2, len);
443                sv_setpvn_mg(sv, str, len);
444
445void
446sv_setsv_mg(sv, sv2)
447        SV *sv;
448        SV *sv2;
449        CODE:
450                sv_setsv_mg(sv, sv2);
451
452void
453sv_setuv_mg(sv, uv)
454        SV *sv;
455        UV uv;
456        CODE:
457                sv_setuv_mg(sv, uv);
458
459void
460sv_usepvn_mg(sv, sv2)
461        SV *sv;
462        SV *sv2;
463        PREINIT:
464                char *str, *copy;
465                STRLEN len;
466        CODE:
467                str = SvPV(sv2, len);
468                New(42, copy, len+1, char);
469                Copy(str, copy, len+1, char);
470                sv_usepvn_mg(sv, copy, len);
471
472int
473SvVSTRING_mg(sv)
474        SV *sv;
475        CODE:
476                RETVAL = SvVSTRING_mg(sv) != NULL;
477        OUTPUT:
478                RETVAL
479
480int
481sv_magic_portable(sv)
482        SV *sv
483        PREINIT:
484                MAGIC *mg;
485                const char *foo = "foo";
486        CODE:
487#if { VERSION >= 5.004 }
488                sv_magic_portable(sv, 0, '~', foo, 0);
489                mg = mg_find(sv, '~');
490                if (!mg)
491                  croak("No mg!");
492
493                RETVAL = mg->mg_ptr == foo;
494#else
495                sv_magic(sv, 0, '~', (char *) foo, strlen(foo));
496                mg = mg_find(sv, '~');
497                RETVAL = strEQ(mg->mg_ptr, foo);
498#endif
499                sv_unmagic(sv, '~');
500        OUTPUT:
501                RETVAL
502
503UV
504above_IV_MAX()
505        CODE:
506                RETVAL = (UV)IV_MAX+100;
507        OUTPUT:
508                RETVAL
509
510#ifdef SVf_IVisUV
511
512U32
513SVf_IVisUV(sv)
514        SV *sv
515        CODE:
516                RETVAL = (SvFLAGS(sv) & SVf_IVisUV);
517        OUTPUT:
518                RETVAL
519
520#endif
521
522#ifdef SvIV_nomg
523
524IV
525magic_SvIV_nomg(sv)
526        SV *sv
527        CODE:
528                RETVAL = SvIV_nomg(sv);
529        OUTPUT:
530                RETVAL
531
532#endif
533
534#ifdef SvUV_nomg
535
536UV
537magic_SvUV_nomg(sv)
538        SV *sv
539        CODE:
540                RETVAL = SvUV_nomg(sv);
541        OUTPUT:
542                RETVAL
543
544#endif
545
546#ifdef SvNV_nomg
547
548NV
549magic_SvNV_nomg(sv)
550        SV *sv
551        CODE:
552                RETVAL = SvNV_nomg(sv);
553        OUTPUT:
554                RETVAL
555
556#endif
557
558#ifdef SvTRUE_nomg
559
560bool
561magic_SvTRUE_nomg(sv)
562        SV *sv
563        CODE:
564                RETVAL = SvTRUE_nomg(sv);
565        OUTPUT:
566                RETVAL
567
568#endif
569
570#ifdef SvPV_nomg_nolen
571
572char *
573magic_SvPV_nomg_nolen(sv)
574        SV *sv
575        CODE:
576                RETVAL = SvPV_nomg_nolen(sv);
577        OUTPUT:
578                RETVAL
579
580#endif
581
582=tests plan => 63
583
584# Find proper magic
585ok(my $obj1 = Devel::PPPort->new_with_mg());
586is(Devel::PPPort::as_string($obj1), 'hello');
587
588# Find with no magic
589my $obj = bless {}, 'Fake::Class';
590is(Devel::PPPort::as_string($obj), "Sorry, your princess is in another castle.");
591
592# Find with other magic (not the magic we are looking for)
593ok($obj = Devel::PPPort->new_with_other_mg());
594is(Devel::PPPort::as_string($obj), "Sorry, your princess is in another castle.");
595
596# Okay, attempt to remove magic that isn't there
597Devel::PPPort::remove_other_magic($obj1);
598is(Devel::PPPort::as_string($obj1), 'hello');
599
600# Remove magic that IS there
601Devel::PPPort::remove_null_magic($obj1);
602is(Devel::PPPort::as_string($obj1), "Sorry, your princess is in another castle.");
603
604# Removing when no magic present
605Devel::PPPort::remove_null_magic($obj1);
606is(Devel::PPPort::as_string($obj1), "Sorry, your princess is in another castle.");
607
608use Tie::Hash;
609my %h;
610tie %h, 'Tie::StdHash';
611$h{foo} = 'foo';
612$h{bar} = '';
613
614&Devel::PPPort::sv_catpv_mg($h{foo}, 'bar');
615is($h{foo}, 'foobar');
616
617&Devel::PPPort::sv_catpvn_mg($h{bar}, 'baz');
618is($h{bar}, 'baz');
619
620&Devel::PPPort::sv_catsv_mg($h{foo}, '42');
621is($h{foo}, 'foobar42');
622
623&Devel::PPPort::sv_setiv_mg($h{bar}, 42);
624is($h{bar}, 42);
625
626&Devel::PPPort::sv_setnv_mg($h{PI}, 3.14159);
627ok(abs($h{PI} - 3.14159) < 0.01);
628
629&Devel::PPPort::sv_setpv_mg($h{mhx}, 'mhx');
630is($h{mhx}, 'mhx');
631
632&Devel::PPPort::sv_setpvn_mg($h{mhx}, 'Marcus');
633is($h{mhx}, 'Marcus');
634
635&Devel::PPPort::sv_setsv_mg($h{sv}, 'SV');
636is($h{sv}, 'SV');
637
638&Devel::PPPort::sv_setuv_mg($h{sv}, 4711);
639is($h{sv}, 4711);
640
641&Devel::PPPort::sv_usepvn_mg($h{sv}, 'Perl');
642is($h{sv}, 'Perl');
643
644# v1 is treated as a bareword in older perls...
645my $ver = do { local $SIG{'__WARN__'} = sub {}; eval qq[v1.2.0] };
646ok("$]" < 5.009 || $@ eq '');
647ok("$]" < 5.009 || Devel::PPPort::SvVSTRING_mg($ver));
648ok(!Devel::PPPort::SvVSTRING_mg(4711));
649
650my $foo = 'bar';
651ok(Devel::PPPort::sv_magic_portable($foo));
652ok($foo eq 'bar');
653
654    tie my $scalar, 'TieScalarCounter', 10;
655    my $fetch = $scalar;
656
657    is tied($scalar)->{fetch}, 1;
658    is tied($scalar)->{store}, 0;
659    is Devel::PPPort::magic_SvIV_nomg($scalar), 10;
660    is tied($scalar)->{fetch}, 1;
661    is tied($scalar)->{store}, 0;
662    is Devel::PPPort::magic_SvUV_nomg($scalar), 10;
663    is tied($scalar)->{fetch}, 1;
664    is tied($scalar)->{store}, 0;
665    is Devel::PPPort::magic_SvNV_nomg($scalar), 10;
666    is tied($scalar)->{fetch}, 1;
667    is tied($scalar)->{store}, 0;
668    is Devel::PPPort::magic_SvPV_nomg_nolen($scalar), 10;
669    is tied($scalar)->{fetch}, 1;
670    is tied($scalar)->{store}, 0;
671    ok Devel::PPPort::magic_SvTRUE_nomg($scalar);
672    is tied($scalar)->{fetch}, 1;
673    is tied($scalar)->{store}, 0;
674
675    my $object = OverloadedObject->new('string', 5.5, 0);
676
677    is Devel::PPPort::magic_SvIV_nomg($object), 5;
678    is Devel::PPPort::magic_SvUV_nomg($object), 5;
679    is Devel::PPPort::magic_SvNV_nomg($object), 5.5;
680    is Devel::PPPort::magic_SvPV_nomg_nolen($object), 'string';
681    ok !Devel::PPPort::magic_SvTRUE_nomg($object);
682
683tie my $negative, 'TieScalarCounter', -1;
684$fetch = $negative;
685
686is tied($negative)->{fetch}, 1;
687is tied($negative)->{store}, 0;
688is Devel::PPPort::magic_SvIV_nomg($negative), -1;
689if (ivers($]) >= ivers(5.6)) {
690    ok !Devel::PPPort::SVf_IVisUV($negative);
691} else {
692    skip 'SVf_IVisUV is unsupported', 1;
693}
694is tied($negative)->{fetch}, 1;
695is tied($negative)->{store}, 0;
696Devel::PPPort::magic_SvUV_nomg($negative);
697if (ivers($]) >= ivers(5.6)) {
698    ok !Devel::PPPort::SVf_IVisUV($negative);
699} else {
700    skip 'SVf_IVisUV is unsupported', 1;
701}
702is tied($negative)->{fetch}, 1;
703is tied($negative)->{store}, 0;
704
705tie my $big, 'TieScalarCounter', Devel::PPPort::above_IV_MAX();
706$fetch = $big;
707
708is tied($big)->{fetch}, 1;
709is tied($big)->{store}, 0;
710Devel::PPPort::magic_SvIV_nomg($big);
711if (ivers($]) >= ivers(5.6)) {
712    ok Devel::PPPort::SVf_IVisUV($big);
713} else {
714    skip 'SVf_IVisUV is unsupported', 1;
715}
716is tied($big)->{fetch}, 1;
717is tied($big)->{store}, 0;
718is Devel::PPPort::magic_SvUV_nomg($big), Devel::PPPort::above_IV_MAX();
719if (ivers($]) >= ivers(5.6)) {
720    ok Devel::PPPort::SVf_IVisUV($big);
721} else {
722    skip 'SVf_IVisUV is unsupported', 1;
723}
724is tied($big)->{fetch}, 1;
725is tied($big)->{store}, 0;
726
727package TieScalarCounter;
728
729sub TIESCALAR {
730    my ($class, $value) = @_;
731    return bless { fetch => 0, store => 0, value => $value }, $class;
732}
733
734sub FETCH {
735    my ($self) = @_;
736    $self->{fetch}++;
737    return $self->{value};
738}
739
740sub STORE {
741    my ($self, $value) = @_;
742    $self->{store}++;
743    $self->{value} = $value;
744}
745
746package OverloadedObject;
747
748sub new {
749    my ($class, $str, $num, $bool) = @_;
750    return bless { str => $str, num => $num, bool => $bool }, $class;
751}
752
753use overload
754    '""' => sub { $_[0]->{str} },
755    '0+' => sub { $_[0]->{num} },
756    'bool' => sub { $_[0]->{bool} },
757    ;
758