1 #define PERL_NO_GET_CONTEXT
8 /* Not yet in ppport.h */
10 # define CvISXSUB(cv) (CvXSUB(cv) ? TRUE : FALSE)
14 /* "structured exception" handling is a Microsoft extension to C and C++.
15 It's *not* C++ exception handling - C++ exception handling can't capture
16 SEGVs and suchlike, whereas this can. There's no known analagous
17 functionality on other platforms. */
19 # define TRY_TO_CATCH_SEGV __try
20 # define CAUGHT_EXCEPTION __except(EXCEPTION EXCEPTION_EXECUTE_HANDLER)
22 # define TRY_TO_CATCH_SEGV if(1)
23 # define CAUGHT_EXCEPTION else
27 # define __attribute__(x)
30 static int regex_whine;
32 static int dangle_whine = 0;
34 #if 0 && defined(DEBUGGING)
35 #define dbg_printf(x) printf x
40 #define TAG /* printf( "# %s(%d)\n", __FILE__, __LINE__ ) */
43 /* The idea is to have a tree structure to store 1 bit per possible pointer
44 address. The lowest 16 bits are stored in a block of 8092 bytes.
45 The blocks are in a 256-way tree, indexed by the reset of the pointer.
46 This can cope with 32 and 64 bit pointers, and any address space layout,
47 without excessive memory needs. The assumption is that your CPU cache
48 works :-) (And that we're not going to bust it) */
50 #define ALIGN_BITS ( sizeof(void*) >> 1 )
52 #define LEAF_BITS (16 - BYTE_BITS)
53 #define LEAF_MASK 0x1FFF
55 typedef void * TRACKING[256];
58 Checks to see if thing is in the bitstring.
59 Returns true or false, and
60 notes thing in the segmented bitstring.
63 check_new(TRACKING *tv, const void *const p) {
64 unsigned int bits = 8 * sizeof(void*);
65 const size_t raw_p = PTR2nat(p);
66 /* This effectively rotates the value right by the number of low always-0
67 bits in an aligned pointer. The assmption is that most (if not all)
68 pointers are aligned, and these will be in the same chain of nodes
69 (and hence hot in the cache) but we can still deal with any unaligned
72 = (raw_p >> ALIGN_BITS) | (raw_p << (bits - BYTE_BITS));
73 const U8 this_bit = 1 << (cooked_p & 0x7);
77 void **tv_p = (void **) tv;
80 if (NULL == p) return FALSE;
82 const char c = *(const char *)p;
86 warn( "Devel::Size: Encountered invalid pointer: %p\n", p );
92 /* bits now 24 (32 bit pointers) or 56 (64 bit pointers) */
94 /* First level is always present. */
96 i = (unsigned int)((cooked_p >> bits) & 0xFF);
98 Newxz(tv_p[i], 256, void *);
99 tv_p = (void **)(tv_p[i]);
101 } while (bits > LEAF_BITS + BYTE_BITS);
102 /* bits now 16 always */
104 leaf_p = (U8 **)tv_p;
105 i = (unsigned int)((cooked_p >> bits) & 0xFF);
107 Newxz(leaf_p[i], 1 << LEAF_BITS, U8);
112 i = (unsigned int)((cooked_p >> BYTE_BITS) & LEAF_MASK);
114 if(leaf[i] & this_bit)
122 free_tracking_at(void **tv, int level)
130 free_tracking_at(tv[i], level);
144 free_tracking(TRACKING *tv)
146 const int top_level = (sizeof(void *) * 8 - LEAF_BITS - BYTE_BITS) / 8;
147 free_tracking_at((void **)tv, top_level);
151 static UV thing_size(pTHX_ const SV *const, TRACKING *);
168 cc_opclass(const OP * const o)
174 return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
176 if (o->op_type == OP_SASSIGN)
177 return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
180 if (o->op_type == OP_GV || o->op_type == OP_GVSV || o->op_type == OP_AELEMFAST)
184 if ((o->op_type == OP_TRANS)) {
188 switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
213 case OA_PVOP_OR_SVOP: TAG;
215 * Character translations (tr///) are usually a PVOP, keeping a
216 * pointer to a table of shorts used to look up translations.
217 * Under utf8, however, a simple table isn't practical; instead,
218 * the OP is an SVOP, and the SV is a reference to a swash
219 * (i.e., an RV pointing to an HV).
221 return (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
222 ? OPc_SVOP : OPc_PVOP;
230 case OA_BASEOP_OR_UNOP: TAG;
232 * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
233 * whether parens were seen. perly.y uses OPf_SPECIAL to
234 * signal whether a BASEOP had empty parens or none.
235 * Some other UNOPs are created later, though, so the best
236 * test is OPf_KIDS, which is set in newUNOP.
238 return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
240 case OA_FILESTATOP: TAG;
242 * The file stat OPs are created via UNI(OP_foo) in toke.c but use
243 * the OPf_REF flag to distinguish between OP types instead of the
244 * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
245 * return OPc_UNOP so that walkoptree can find our children. If
246 * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
247 * (no argument to the operator) it's an OP; with OPf_REF set it's
248 * an SVOP (and op_sv is the GV for the filehandle argument).
250 return ((o->op_flags & OPf_KIDS) ? OPc_UNOP :
252 (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP);
254 (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP);
256 case OA_LOOPEXOP: TAG;
258 * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
259 * label was omitted (in which case it's a BASEOP) or else a term was
260 * seen. In this last case, all except goto are definitely PVOP but
261 * goto is either a PVOP (with an ordinary constant label), an UNOP
262 * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
263 * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
266 if (o->op_flags & OPf_STACKED)
268 else if (o->op_flags & OPf_SPECIAL)
273 warn("Devel::Size: Can't determine class of operator %s, assuming BASEOP\n",
274 PL_op_name[o->op_type]);
285 static int go_yell = 1;
287 /* Figure out how much magic is attached to the SV and return the
289 IV magic_size(const SV * const thing, TRACKING *tv) {
291 MAGIC *magic_pointer;
294 if (!SvMAGIC(thing)) {
299 /* Get the base magic pointer */
300 magic_pointer = SvMAGIC(thing);
302 /* Have we seen the magic pointer? */
303 while (magic_pointer && check_new(tv, magic_pointer)) {
304 total_size += sizeof(MAGIC);
307 /* Have we seen the magic vtable? */
308 if (magic_pointer->mg_virtual &&
309 check_new(tv, magic_pointer->mg_virtual)) {
310 total_size += sizeof(MGVTBL);
313 /* Get the next in the chain */
314 magic_pointer = magic_pointer->mg_moremagic;
318 warn( "Devel::Size: Encountered bad magic at: %p\n", magic_pointer );
324 UV regex_size(const REGEXP * const baseregex, TRACKING *tv) {
327 total_size += sizeof(REGEXP);
328 #if (PERL_VERSION < 11)
329 /* Note the size of the paren offset thing */
330 total_size += sizeof(I32) * baseregex->nparens * 2;
331 total_size += strlen(baseregex->precomp);
333 total_size += sizeof(struct regexp);
334 total_size += sizeof(I32) * SvANY(baseregex)->nparens * 2;
335 /*total_size += strlen(SvANY(baseregex)->subbeg);*/
337 if (go_yell && !regex_whine) {
338 carp("Devel::Size: Calculated sizes for compiled regexes are incompatible, and probably always will be");
346 op_size(pTHX_ const OP * const baseop, TRACKING *tv) {
350 if (check_new(tv, baseop->op_next)) {
351 total_size += op_size(aTHX_ baseop->op_next, tv);
354 switch (cc_opclass(baseop)) {
355 case OPc_BASEOP: TAG;
356 total_size += sizeof(struct op);
359 total_size += sizeof(struct unop);
360 if (check_new(tv, cUNOPx(baseop)->op_first)) {
361 total_size += op_size(aTHX_ cUNOPx(baseop)->op_first, tv);
365 total_size += sizeof(struct binop);
366 if (check_new(tv, cBINOPx(baseop)->op_first)) {
367 total_size += op_size(aTHX_ cBINOPx(baseop)->op_first, tv);
369 if (check_new(tv, cBINOPx(baseop)->op_last)) {
370 total_size += op_size(aTHX_ cBINOPx(baseop)->op_last, tv);
374 total_size += sizeof(struct logop);
375 if (check_new(tv, cLOGOPx(baseop)->op_first)) {
376 total_size += op_size(aTHX_ cBINOPx(baseop)->op_first, tv);
378 if (check_new(tv, cLOGOPx(baseop)->op_other)) {
379 total_size += op_size(aTHX_ cLOGOPx(baseop)->op_other, tv);
382 case OPc_LISTOP: TAG;
383 total_size += sizeof(struct listop);
384 if (check_new(tv, cLISTOPx(baseop)->op_first)) {
385 total_size += op_size(aTHX_ cLISTOPx(baseop)->op_first, tv);
387 if (check_new(tv, cLISTOPx(baseop)->op_last)) {
388 total_size += op_size(aTHX_ cLISTOPx(baseop)->op_last, tv);
392 total_size += sizeof(struct pmop);
393 if (check_new(tv, cPMOPx(baseop)->op_first)) {
394 total_size += op_size(aTHX_ cPMOPx(baseop)->op_first, tv);
396 if (check_new(tv, cPMOPx(baseop)->op_last)) {
397 total_size += op_size(aTHX_ cPMOPx(baseop)->op_last, tv);
399 #if PERL_VERSION < 9 || (PERL_VERSION == 9 && PERL_SUBVERSION < 5)
400 if (check_new(tv, cPMOPx(baseop)->op_pmreplroot)) {
401 total_size += op_size(aTHX_ cPMOPx(baseop)->op_pmreplroot, tv);
403 if (check_new(tv, cPMOPx(baseop)->op_pmreplstart)) {
404 total_size += op_size(aTHX_ cPMOPx(baseop)->op_pmreplstart, tv);
406 if (check_new(tv, cPMOPx(baseop)->op_pmnext)) {
407 total_size += op_size(aTHX_ (OP *)cPMOPx(baseop)->op_pmnext, tv);
410 /* This is defined away in perl 5.8.x, but it is in there for
413 if (check_new(tv, PM_GETRE((cPMOPx(baseop))))) {
414 total_size += regex_size(PM_GETRE(cPMOPx(baseop)), tv);
417 if (check_new(tv, cPMOPx(baseop)->op_pmregexp)) {
418 total_size += regex_size(cPMOPx(baseop)->op_pmregexp, tv);
423 total_size += sizeof(struct pmop);
424 if (check_new(tv, cSVOPx(baseop)->op_sv)) {
425 total_size += thing_size(aTHX_ cSVOPx(baseop)->op_sv, tv);
429 total_size += sizeof(struct padop);
432 if (check_new(tv, cPVOPx(baseop)->op_pv)) {
433 total_size += strlen(cPVOPx(baseop)->op_pv);
436 total_size += sizeof(struct loop);
437 if (check_new(tv, cLOOPx(baseop)->op_first)) {
438 total_size += op_size(aTHX_ cLOOPx(baseop)->op_first, tv);
440 if (check_new(tv, cLOOPx(baseop)->op_last)) {
441 total_size += op_size(aTHX_ cLOOPx(baseop)->op_last, tv);
443 if (check_new(tv, cLOOPx(baseop)->op_redoop)) {
444 total_size += op_size(aTHX_ cLOOPx(baseop)->op_redoop, tv);
446 if (check_new(tv, cLOOPx(baseop)->op_nextop)) {
447 total_size += op_size(aTHX_ cLOOPx(baseop)->op_nextop, tv);
449 if (check_new(tv, cLOOPx(baseop)->op_lastop)) {
450 total_size += op_size(aTHX_ cLOOPx(baseop)->op_lastop, tv);
457 basecop = (COP *)baseop;
458 total_size += sizeof(struct cop);
460 /* Change 33656 by nicholas@mouse-mill on 2008/04/07 11:29:51
461 Eliminate cop_label from struct cop by storing a label as the first
462 entry in the hints hash. Most statements don't have labels, so this
463 will save memory. Not sure how much.
464 The check below will be incorrect fail on bleadperls
465 before 5.11 @33656, but later than 5.10, producing slightly too
466 small memory sizes on these Perls. */
467 #if (PERL_VERSION < 11)
468 if (check_new(tv, basecop->cop_label)) {
469 total_size += strlen(basecop->cop_label);
473 if (check_new(tv, basecop->cop_file)) {
474 total_size += strlen(basecop->cop_file);
476 if (check_new(tv, basecop->cop_stashpv)) {
477 total_size += strlen(basecop->cop_stashpv);
480 if (check_new(tv, basecop->cop_stash)) {
481 total_size += thing_size(aTHX_ (SV *)basecop->cop_stash, tv);
483 if (check_new(tv, basecop->cop_filegv)) {
484 total_size += thing_size(aTHX_ (SV *)basecop->cop_filegv, tv);
496 warn( "Devel::Size: Encountered dangling pointer in opcode at: %p\n", baseop );
501 #if PERL_VERSION > 9 || (PERL_VERSION == 9 && PERL_SUBVERSION > 2)
502 # define NEW_HEAD_LAYOUT
506 thing_size(pTHX_ const SV * const orig_thing, TRACKING *tv) {
507 const SV *thing = orig_thing;
508 UV total_size = sizeof(SV);
510 switch (SvTYPE(thing)) {
514 /* Just a plain integer. This will be differently sized depending
515 on whether purify's been compiled in */
517 #ifndef NEW_HEAD_LAYOUT
519 total_size += sizeof(sizeof(XPVIV));
521 total_size += sizeof(IV);
525 /* Is it a float? Like the int, it depends on purify */
528 total_size += sizeof(sizeof(XPVNV));
530 total_size += sizeof(NV);
533 #if (PERL_VERSION < 11)
534 /* Is it a reference? */
536 #ifndef NEW_HEAD_LAYOUT
537 total_size += sizeof(XRV);
541 /* How about a plain string? In which case we need to add in how
542 much has been allocated */
544 total_size += sizeof(XPV);
545 #if (PERL_VERSION < 11)
546 total_size += SvROK(thing) ? thing_size(aTHX_ SvRV(thing), tv) : SvLEN(thing);
548 total_size += SvLEN(thing);
551 /* A string with an integer part? */
553 total_size += sizeof(XPVIV);
554 #if (PERL_VERSION < 11)
555 total_size += SvROK(thing) ? thing_size(aTHX_ SvRV(thing), tv) : SvLEN(thing);
557 total_size += SvLEN(thing);
560 total_size += SvIVX(thing);
563 /* A scalar/string/reference with a float part? */
565 total_size += sizeof(XPVNV);
566 #if (PERL_VERSION < 11)
567 total_size += SvROK(thing) ? thing_size(aTHX_ SvRV(thing), tv) : SvLEN(thing);
569 total_size += SvLEN(thing);
573 total_size += sizeof(XPVMG);
574 #if (PERL_VERSION < 11)
575 total_size += SvROK(thing) ? thing_size(aTHX_ SvRV(thing), tv) : SvLEN(thing);
577 total_size += SvLEN(thing);
579 total_size += magic_size(thing, tv);
581 #if PERL_VERSION <= 8
583 total_size += sizeof(XPVBM);
584 #if (PERL_VERSION < 11)
585 total_size += SvROK(thing) ? thing_size(aTHX_ SvRV(thing), tv) : SvLEN(thing);
587 total_size += SvLEN(thing);
589 total_size += magic_size(thing, tv);
593 total_size += sizeof(XPVLV);
594 #if (PERL_VERSION < 11)
595 total_size += SvROK(thing) ? thing_size(aTHX_ SvRV(thing), tv) : SvLEN(thing);
597 total_size += SvLEN(thing);
599 total_size += magic_size(thing, tv);
601 /* How much space is dedicated to the array? Not counting the
602 elements in the array, mind, just the array itself */
604 total_size += sizeof(XPVAV);
605 /* Is there anything in the array? */
606 if (AvMAX(thing) != -1) {
607 /* an array with 10 slots has AvMax() set to 9 - te 2007-04-22 */
608 total_size += sizeof(SV *) * (AvMAX(thing) + 1);
609 dbg_printf(("total_size: %li AvMAX: %li av_len: $i\n", total_size, AvMAX(thing), av_len((AV*)thing)));
611 /* Add in the bits on the other side of the beginning */
613 dbg_printf(("total_size %li, sizeof(SV *) %li, AvARRAY(thing) %li, AvALLOC(thing)%li , sizeof(ptr) %li \n",
614 total_size, sizeof(SV*), AvARRAY(thing), AvALLOC(thing), sizeof( thing )));
616 /* under Perl 5.8.8 64bit threading, AvARRAY(thing) was a pointer while AvALLOC was 0,
617 resulting in grossly overstated sized for arrays. Technically, this shouldn't happen... */
618 if (AvALLOC(thing) != 0) {
619 total_size += (sizeof(SV *) * (AvARRAY(thing) - AvALLOC(thing)));
621 #if (PERL_VERSION < 9)
622 /* Is there something hanging off the arylen element?
623 Post 5.9.something this is stored in magic, so will be found there,
624 and Perl_av_arylen_p() takes a non-const AV*, hence compilers rightly
625 complain about AvARYLEN() passing thing to it. */
626 if (AvARYLEN(thing)) {
627 if (check_new(tv, AvARYLEN(thing))) {
628 total_size += thing_size(aTHX_ AvARYLEN(thing), tv);
632 total_size += magic_size(thing, tv);
635 /* First the base struct */
636 total_size += sizeof(XPVHV);
637 /* Now the array of buckets */
638 total_size += (sizeof(HE *) * (HvMAX(thing) + 1));
639 /* Now walk the bucket chain */
640 if (HvARRAY(thing)) {
643 for (cur_bucket = 0; cur_bucket <= HvMAX(thing); cur_bucket++) {
644 cur_entry = *(HvARRAY(thing) + cur_bucket);
646 total_size += sizeof(HE);
647 if (cur_entry->hent_hek) {
648 /* Hash keys can be shared. Have we seen this before? */
649 if (check_new(tv, cur_entry->hent_hek)) {
650 total_size += HEK_BASESIZE + cur_entry->hent_hek->hek_len + 2;
653 cur_entry = cur_entry->hent_next;
657 total_size += magic_size(thing, tv);
660 total_size += sizeof(XPVCV);
661 total_size += magic_size(thing, tv);
663 total_size += ((XPVIO *) SvANY(thing))->xpv_len;
664 if (check_new(tv, CvSTASH(thing))) {
665 total_size += thing_size(aTHX_ (SV *)CvSTASH(thing), tv);
667 if (check_new(tv, SvSTASH(thing))) {
668 total_size += thing_size(aTHX_ (SV *)SvSTASH(thing), tv);
670 if (check_new(tv, CvGV(thing))) {
671 total_size += thing_size(aTHX_ (SV *)CvGV(thing), tv);
673 if (check_new(tv, CvPADLIST(thing))) {
674 total_size += thing_size(aTHX_ (SV *)CvPADLIST(thing), tv);
676 if (check_new(tv, CvOUTSIDE(thing))) {
677 total_size += thing_size(aTHX_ (SV *)CvOUTSIDE(thing), tv);
679 if (CvISXSUB(thing)) {
680 SV *sv = cv_const_sv((CV *)thing);
682 total_size += thing_size(aTHX_ sv, tv);
685 if (check_new(tv, CvSTART(thing))) {
686 total_size += op_size(aTHX_ CvSTART(thing), tv);
688 if (check_new(tv, CvROOT(thing))) {
689 total_size += op_size(aTHX_ CvROOT(thing), tv);
695 total_size += magic_size(thing, tv);
696 total_size += sizeof(XPVGV);
697 total_size += GvNAMELEN(thing);
699 /* Is there a file? */
701 if (check_new(tv, GvFILE(thing))) {
702 total_size += strlen(GvFILE(thing));
706 /* Is there something hanging off the glob? */
708 if (check_new(tv, GvGP(thing))) {
709 total_size += sizeof(GP);
712 if ((generic_thing = (SV *)(GvGP(thing)->gp_sv))) {
713 total_size += thing_size(aTHX_ generic_thing, tv);
715 if ((generic_thing = (SV *)(GvGP(thing)->gp_form))) {
716 total_size += thing_size(aTHX_ generic_thing, tv);
718 if ((generic_thing = (SV *)(GvGP(thing)->gp_av))) {
719 total_size += thing_size(aTHX_ generic_thing, tv);
721 if ((generic_thing = (SV *)(GvGP(thing)->gp_hv))) {
722 total_size += thing_size(aTHX_ generic_thing, tv);
724 if ((generic_thing = (SV *)(GvGP(thing)->gp_egv))) {
725 total_size += thing_size(aTHX_ generic_thing, tv);
727 if ((generic_thing = (SV *)(GvGP(thing)->gp_cv))) {
728 total_size += thing_size(aTHX_ generic_thing, tv);
735 total_size += sizeof(XPVFM);
736 total_size += magic_size(thing, tv);
737 total_size += ((XPVIO *) SvANY(thing))->xpv_len;
738 if (check_new(tv, CvPADLIST(thing))) {
739 total_size += thing_size(aTHX_ (SV *)CvPADLIST(thing), tv);
741 if (check_new(tv, CvOUTSIDE(thing))) {
742 total_size += thing_size(aTHX_ (SV *)CvOUTSIDE(thing), tv);
745 if (go_yell && !fm_whine) {
746 carp("Devel::Size: Calculated sizes for FMs are incomplete");
751 total_size += sizeof(XPVIO);
752 total_size += magic_size(thing, tv);
753 if (check_new(tv, (SvPVX_const(thing)))) {
754 total_size += ((XPVIO *) SvANY(thing))->xpv_cur;
756 /* Some embedded char pointers */
757 if (check_new(tv, ((XPVIO *) SvANY(thing))->xio_top_name)) {
758 total_size += strlen(((XPVIO *) SvANY(thing))->xio_top_name);
760 if (check_new(tv, ((XPVIO *) SvANY(thing))->xio_fmt_name)) {
761 total_size += strlen(((XPVIO *) SvANY(thing))->xio_fmt_name);
763 if (check_new(tv, ((XPVIO *) SvANY(thing))->xio_bottom_name)) {
764 total_size += strlen(((XPVIO *) SvANY(thing))->xio_bottom_name);
766 /* Throw the GVs on the list to be walked if they're not-null */
767 if (((XPVIO *) SvANY(thing))->xio_top_gv) {
768 total_size += thing_size(aTHX_ (SV *)((XPVIO *) SvANY(thing))->xio_top_gv,
771 if (((XPVIO *) SvANY(thing))->xio_bottom_gv) {
772 total_size += thing_size(aTHX_ (SV *)((XPVIO *) SvANY(thing))->xio_bottom_gv,
775 if (((XPVIO *) SvANY(thing))->xio_fmt_gv) {
776 total_size += thing_size(aTHX_ (SV *)((XPVIO *) SvANY(thing))->xio_fmt_gv,
780 /* Only go trotting through the IO structures if they're really
781 trottable. If USE_PERLIO is defined we can do this. If
782 not... we can't, so we don't even try */
784 /* Dig into xio_ifp and xio_ofp here */
785 warn("Devel::Size: Can't size up perlio layers yet\n");
789 warn("Devel::Size: Unknown variable type: %d encountered\n", SvTYPE(thing) );
794 MODULE = Devel::Size PACKAGE = Devel::Size
803 SV *thing = orig_thing;
806 Newz( 0xfc0ff, tv, 1, TRACKING );
808 /* Check warning status */
813 if (NULL != (warn_flag = perl_get_sv("Devel::Size::warn", FALSE))) {
814 dangle_whine = go_yell = SvIV(warn_flag);
816 if (NULL != (warn_flag = perl_get_sv("Devel::Size::dangle", FALSE))) {
817 dangle_whine = SvIV(warn_flag);
820 /* If they passed us a reference then dereference it. This is the
821 only way we can check the sizes of arrays and hashes */
822 #if (PERL_VERSION < 11)
823 if (SvOK(thing) && SvROK(thing)) {
832 RETVAL = thing_size(aTHX_ thing, tv);
840 total_size(orig_thing)
844 SV *thing = orig_thing;
846 /* Array with things we still need to do */
851 /* Size starts at zero */
854 /* Check warning status */
859 if (NULL != (warn_flag = perl_get_sv("Devel::Size::warn", FALSE))) {
860 dangle_whine = go_yell = SvIV(warn_flag);
862 if (NULL != (warn_flag = perl_get_sv("Devel::Size::dangle", FALSE))) {
863 dangle_whine = SvIV(warn_flag);
866 /* init these after the go_yell above */
867 Newz( 0xfc0ff, tv, 1, TRACKING );
868 pending_array = newAV();
870 /* We cannot push HV/AV directly, only the RV. So deref it
871 later (see below for "*** dereference later") and adjust here for
873 This is the only way we can check the sizes of arrays and hashes. */
875 RETVAL -= thing_size(aTHX_ thing, NULL);
878 /* Put it on the pending array */
879 av_push(pending_array, thing);
881 /* Now just yank things off the end of the array until it's done */
882 while (av_len(pending_array) >= 0) {
883 thing = av_pop(pending_array);
884 /* Process it if we've not seen it */
885 if (check_new(tv, thing)) {
886 dbg_printf(("# Found type %i at %p\n", SvTYPE(thing), thing));
889 /* Yes, it is. So let's check the type */
890 switch (SvTYPE(thing)) {
891 /* fix for bug #24846 (Does not correctly recurse into references in a PVNV-type scalar) */
895 av_push(pending_array, SvRV(thing));
899 /* this is the "*** dereference later" part - see above */
900 #if (PERL_VERSION < 11)
905 dbg_printf(("# Found RV\n"));
907 dbg_printf(("# Found RV\n"));
908 av_push(pending_array, SvRV(thing));
914 AV *tempAV = (AV *)thing;
917 dbg_printf(("# Found type AV\n"));
918 /* Quick alias to cut down on casting */
921 if (av_len(tempAV) != -1) {
923 /* Run through them all */
924 for (index = 0; index <= av_len(tempAV); index++) {
925 /* Did we get something? */
926 if ((tempSV = av_fetch(tempAV, index, 0))) {
928 if (*tempSV != &PL_sv_undef) {
929 /* Apparently not. Save it for later */
930 av_push(pending_array, *tempSV);
939 dbg_printf(("# Found type HV\n"));
940 /* Is there anything in here? */
941 if (hv_iterinit((HV *)thing)) {
943 while ((temp_he = hv_iternext((HV *)thing))) {
944 av_push(pending_array, hv_iterval((HV *)thing, temp_he));
950 dbg_printf(("# Found type GV\n"));
951 /* Run through all the pieces and push the ones with bits */
953 av_push(pending_array, (SV *)GvSV(thing));
956 av_push(pending_array, (SV *)GvFORM(thing));
959 av_push(pending_array, (SV *)GvAV(thing));
962 av_push(pending_array, (SV *)GvHV(thing));
965 av_push(pending_array, (SV *)GvCV(thing));
973 size = thing_size(aTHX_ thing, tv);
976 /* check_new() returned false: */
977 #ifdef DEVEL_SIZE_DEBUGGING
978 if (SvOK(sv)) printf("# Ignore ref copy 0x%x\n", sv);
979 else printf("# Ignore non-sv 0x%x\n", sv);
985 SvREFCNT_dec(pending_array);