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