3 #define PERL_NO_GET_CONTEXT
10 /* Not yet in ppport.h */
12 # define CvISXSUB(cv) (CvXSUB(cv) ? TRUE : FALSE)
15 # define SvRV_const(rv) SvRV(rv)
18 # define SvOOK_offset(sv, len) STMT_START { len = SvIVX(sv); } STMT_END
21 # define SvIsCOW(sv) ((SvFLAGS(sv) & (SVf_FAKE | SVf_READONLY)) == \
22 (SVf_FAKE | SVf_READONLY))
24 #ifndef SvIsCOW_shared_hash
25 # define SvIsCOW_shared_hash(sv) (SvIsCOW(sv) && SvLEN(sv) == 0)
27 #ifndef SvSHARED_HEK_FROM_PV
28 # define SvSHARED_HEK_FROM_PV(pvx) \
29 ((struct hek*)(pvx - STRUCT_OFFSET(struct hek, hek_key)))
33 # define PL_opargs opargs
34 # define PL_op_name op_name
38 /* "structured exception" handling is a Microsoft extension to C and C++.
39 It's *not* C++ exception handling - C++ exception handling can't capture
40 SEGVs and suchlike, whereas this can. There's no known analagous
41 functionality on other platforms. */
43 # define TRY_TO_CATCH_SEGV __try
44 # define CAUGHT_EXCEPTION __except(EXCEPTION_EXECUTE_HANDLER)
46 # define TRY_TO_CATCH_SEGV if(1)
47 # define CAUGHT_EXCEPTION else
51 # define __attribute__(x)
54 #if 0 && defined(DEBUGGING)
55 #define dbg_printf(x) printf x
60 #define TAG /* printf( "# %s(%d)\n", __FILE__, __LINE__ ) */
63 /* The idea is to have a tree structure to store 1 bit per possible pointer
64 address. The lowest 16 bits are stored in a block of 8092 bytes.
65 The blocks are in a 256-way tree, indexed by the reset of the pointer.
66 This can cope with 32 and 64 bit pointers, and any address space layout,
67 without excessive memory needs. The assumption is that your CPU cache
68 works :-) (And that we're not going to bust it) */
71 #define LEAF_BITS (16 - BYTE_BITS)
72 #define LEAF_MASK 0x1FFF
80 /* My hunch (not measured) is that for most architectures pointers will
81 start with 0 bits, hence the start of this array will be hot, and the
82 end unused. So put the flags next to the hot end. */
87 Checks to see if thing is in the bitstring.
88 Returns true or false, and
89 notes thing in the segmented bitstring.
92 check_new(struct state *st, const void *const p) {
93 unsigned int bits = 8 * sizeof(void*);
94 const size_t raw_p = PTR2nat(p);
95 /* This effectively rotates the value right by the number of low always-0
96 bits in an aligned pointer. The assmption is that most (if not all)
97 pointers are aligned, and these will be in the same chain of nodes
98 (and hence hot in the cache) but we can still deal with any unaligned
100 const size_t cooked_p
101 = (raw_p >> ALIGN_BITS) | (raw_p << (bits - ALIGN_BITS));
102 const U8 this_bit = 1 << (cooked_p & 0x7);
106 void **tv_p = (void **) (st->tracking);
108 if (NULL == p) return FALSE;
110 const char c = *(const char *)p;
113 if (st->dangle_whine)
114 warn( "Devel::Size: Encountered invalid pointer: %p\n", p );
120 /* bits now 24 (32 bit pointers) or 56 (64 bit pointers) */
122 /* First level is always present. */
124 i = (unsigned int)((cooked_p >> bits) & 0xFF);
126 Newxz(tv_p[i], 256, void *);
127 tv_p = (void **)(tv_p[i]);
129 } while (bits > LEAF_BITS + BYTE_BITS);
130 /* bits now 16 always */
131 #if !defined(MULTIPLICITY) || PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 8)
132 /* 5.8.8 and early have an assert() macro that uses Perl_croak, hence needs
133 a my_perl under multiplicity */
136 leaf_p = (U8 **)tv_p;
137 i = (unsigned int)((cooked_p >> bits) & 0xFF);
139 Newxz(leaf_p[i], 1 << LEAF_BITS, U8);
144 i = (unsigned int)((cooked_p >> BYTE_BITS) & LEAF_MASK);
146 if(leaf[i] & this_bit)
154 free_tracking_at(void **tv, int level)
162 free_tracking_at((void **) tv[i], level);
176 free_state(struct state *st)
178 const int top_level = (sizeof(void *) * 8 - LEAF_BITS - BYTE_BITS) / 8;
179 free_tracking_at((void **)st->tracking, top_level);
183 /* For now, this is somewhat a compatibility bodge until the plan comes
184 together for fine grained recursion control. total_size() would recurse into
185 hash and array members, whereas sv_size() would not. However, sv_size() is
186 called with CvSTASH() of a CV, which means that if it (also) starts to
187 recurse fully, then the size of any CV now becomes the size of the entire
188 symbol table reachable from it, and potentially the entire symbol table, if
189 any subroutine makes a reference to a global (such as %SIG). The historical
190 implementation of total_size() didn't report "everything", and changing the
191 only available size to "everything" doesn't feel at all useful. */
193 #define NO_RECURSION 0
194 #define SOME_RECURSION 1
195 #define TOTAL_SIZE_RECURSION 2
197 static void sv_size(pTHX_ struct state *, const SV *const, const int recurse);
213 , OPc_CONDOP /* 12 */
222 cc_opclass(const OP * const o)
228 return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
230 if (o->op_type == OP_SASSIGN)
231 return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
234 if (o->op_type == OP_GV || o->op_type == OP_GVSV || o->op_type == OP_AELEMFAST)
238 if ((o->op_type == OP_TRANS)) {
242 switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
274 #ifdef OA_PVOP_OR_SVOP
275 case OA_PVOP_OR_SVOP: TAG;
277 * Character translations (tr///) are usually a PVOP, keeping a
278 * pointer to a table of shorts used to look up translations.
279 * Under utf8, however, a simple table isn't practical; instead,
280 * the OP is an SVOP, and the SV is a reference to a swash
281 * (i.e., an RV pointing to an HV).
283 return (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
284 ? OPc_SVOP : OPc_PVOP;
293 case OA_BASEOP_OR_UNOP: TAG;
295 * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
296 * whether parens were seen. perly.y uses OPf_SPECIAL to
297 * signal whether a BASEOP had empty parens or none.
298 * Some other UNOPs are created later, though, so the best
299 * test is OPf_KIDS, which is set in newUNOP.
301 return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
303 case OA_FILESTATOP: TAG;
305 * The file stat OPs are created via UNI(OP_foo) in toke.c but use
306 * the OPf_REF flag to distinguish between OP types instead of the
307 * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
308 * return OPc_UNOP so that walkoptree can find our children. If
309 * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
310 * (no argument to the operator) it's an OP; with OPf_REF set it's
311 * an SVOP (and op_sv is the GV for the filehandle argument).
313 return ((o->op_flags & OPf_KIDS) ? OPc_UNOP :
315 (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP);
317 (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP);
319 case OA_LOOPEXOP: TAG;
321 * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
322 * label was omitted (in which case it's a BASEOP) or else a term was
323 * seen. In this last case, all except goto are definitely PVOP but
324 * goto is either a PVOP (with an ordinary constant label), an UNOP
325 * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
326 * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
329 if (o->op_flags & OPf_STACKED)
331 else if (o->op_flags & OPf_SPECIAL)
341 warn("Devel::Size: Can't determine class of operator %s, assuming BASEOP\n",
342 PL_op_name[o->op_type]);
348 /* Figure out how much magic is attached to the SV and return the
351 magic_size(pTHX_ const SV * const thing, struct state *st) {
352 MAGIC *magic_pointer = SvMAGIC(thing);
354 /* Have we seen the magic pointer? (NULL has always been seen before) */
355 while (check_new(st, magic_pointer)) {
356 st->total_size += sizeof(MAGIC);
357 /* magic vtables aren't freed when magic is freed, so don't count them.
358 (They are static structures. Anything that assumes otherwise is buggy.)
363 sv_size(aTHX_ st, magic_pointer->mg_obj, TOTAL_SIZE_RECURSION);
364 if (magic_pointer->mg_len == HEf_SVKEY) {
365 sv_size(aTHX_ st, (SV *)magic_pointer->mg_ptr, TOTAL_SIZE_RECURSION);
367 #if defined(PERL_MAGIC_utf8) && defined (PERL_MAGIC_UTF8_CACHESIZE)
368 else if (magic_pointer->mg_type == PERL_MAGIC_utf8) {
369 if (check_new(st, magic_pointer->mg_ptr)) {
370 st->total_size += PERL_MAGIC_UTF8_CACHESIZE * 2 * sizeof(STRLEN);
374 else if (magic_pointer->mg_len > 0) {
375 if (check_new(st, magic_pointer->mg_ptr)) {
376 st->total_size += magic_pointer->mg_len;
380 /* Get the next in the chain */
381 magic_pointer = magic_pointer->mg_moremagic;
384 if (st->dangle_whine)
385 warn( "Devel::Size: Encountered bad magic at: %p\n", magic_pointer );
391 check_new_and_strlen(struct state *st, const char *const p) {
393 st->total_size += 1 + strlen(p);
397 regex_size(const REGEXP * const baseregex, struct state *st) {
398 if(!check_new(st, baseregex))
400 st->total_size += sizeof(REGEXP);
401 #if (PERL_VERSION < 11)
402 /* Note the size of the paren offset thing */
403 st->total_size += sizeof(I32) * baseregex->nparens * 2;
404 st->total_size += strlen(baseregex->precomp);
406 st->total_size += sizeof(struct regexp);
407 st->total_size += sizeof(I32) * SvANY(baseregex)->nparens * 2;
408 /*st->total_size += strlen(SvANY(baseregex)->subbeg);*/
410 if (st->go_yell && !st->regex_whine) {
411 carp("Devel::Size: Calculated sizes for compiled regexes are incompatible, and probably always will be");
417 op_size(pTHX_ const OP * const baseop, struct state *st)
421 if(!check_new(st, baseop))
424 op_size(aTHX_ baseop->op_next, st);
426 switch (cc_opclass(baseop)) {
427 case OPc_BASEOP: TAG;
428 st->total_size += sizeof(struct op);
431 st->total_size += sizeof(struct unop);
432 op_size(aTHX_ ((UNOP *)baseop)->op_first, st);
435 st->total_size += sizeof(struct binop);
436 op_size(aTHX_ ((BINOP *)baseop)->op_first, st);
437 op_size(aTHX_ ((BINOP *)baseop)->op_last, st);
440 st->total_size += sizeof(struct logop);
441 op_size(aTHX_ ((BINOP *)baseop)->op_first, st);
442 op_size(aTHX_ ((LOGOP *)baseop)->op_other, st);
445 case OPc_CONDOP: TAG;
446 st->total_size += sizeof(struct condop);
447 op_size(aTHX_ ((BINOP *)baseop)->op_first, st);
448 op_size(aTHX_ ((CONDOP *)baseop)->op_true, st);
449 op_size(aTHX_ ((CONDOP *)baseop)->op_false, st);
452 case OPc_LISTOP: TAG;
453 st->total_size += sizeof(struct listop);
454 op_size(aTHX_ ((LISTOP *)baseop)->op_first, st);
455 op_size(aTHX_ ((LISTOP *)baseop)->op_last, st);
458 st->total_size += sizeof(struct pmop);
459 op_size(aTHX_ ((PMOP *)baseop)->op_first, st);
460 op_size(aTHX_ ((PMOP *)baseop)->op_last, st);
461 #if PERL_VERSION < 9 || (PERL_VERSION == 9 && PERL_SUBVERSION < 5)
462 op_size(aTHX_ ((PMOP *)baseop)->op_pmreplroot, st);
463 op_size(aTHX_ ((PMOP *)baseop)->op_pmreplstart, st);
465 /* This is defined away in perl 5.8.x, but it is in there for
468 regex_size(PM_GETRE((PMOP *)baseop), st);
470 regex_size(((PMOP *)baseop)->op_pmregexp, st);
474 st->total_size += sizeof(struct pmop);
475 if (!(baseop->op_type == OP_AELEMFAST
476 && baseop->op_flags & OPf_SPECIAL)) {
477 /* not an OP_PADAV replacement */
478 sv_size(aTHX_ st, ((SVOP *)baseop)->op_sv, SOME_RECURSION);
483 st->total_size += sizeof(struct padop);
488 st->total_size += sizeof(struct gvop);
489 sv_size(aTHX_ st, ((GVOP *)baseop)->op_gv, SOME_RECURSION);
493 check_new_and_strlen(st, ((PVOP *)baseop)->op_pv);
496 st->total_size += sizeof(struct loop);
497 op_size(aTHX_ ((LOOP *)baseop)->op_first, st);
498 op_size(aTHX_ ((LOOP *)baseop)->op_last, st);
499 op_size(aTHX_ ((LOOP *)baseop)->op_redoop, st);
500 op_size(aTHX_ ((LOOP *)baseop)->op_nextop, st);
501 op_size(aTHX_ ((LOOP *)baseop)->op_lastop, st);
506 basecop = (COP *)baseop;
507 st->total_size += sizeof(struct cop);
509 /* Change 33656 by nicholas@mouse-mill on 2008/04/07 11:29:51
510 Eliminate cop_label from struct cop by storing a label as the first
511 entry in the hints hash. Most statements don't have labels, so this
512 will save memory. Not sure how much.
513 The check below will be incorrect fail on bleadperls
514 before 5.11 @33656, but later than 5.10, producing slightly too
515 small memory sizes on these Perls. */
516 #if (PERL_VERSION < 11)
517 check_new_and_strlen(st, basecop->cop_label);
520 check_new_and_strlen(st, basecop->cop_file);
521 check_new_and_strlen(st, basecop->cop_stashpv);
523 sv_size(aTHX_ st, (SV *)basecop->cop_filegv, SOME_RECURSION);
533 if (st->dangle_whine)
534 warn( "Devel::Size: Encountered dangling pointer in opcode at: %p\n", baseop );
539 hek_size(pTHX_ struct state *st, HEK *hek, U32 shared)
541 /* Hash keys can be shared. Have we seen this before? */
542 if (!check_new(st, hek))
544 st->total_size += HEK_BASESIZE + hek->hek_len
546 + 1 /* No hash key flags prior to 5.8.0 */
552 #if PERL_VERSION < 10
553 st->total_size += sizeof(struct he);
555 st->total_size += STRUCT_OFFSET(struct shared_he, shared_he_hek);
561 #if PERL_VERSION < 8 || PERL_SUBVERSION < 9
566 # define MAYBE_PURIFY(normal, pure) (pure)
567 # define MAYBE_OFFSET(struct_name, member) 0
569 # define MAYBE_PURIFY(normal, pure) (normal)
570 # define MAYBE_OFFSET(struct_name, member) STRUCT_OFFSET(struct_name, member)
573 const U8 body_sizes[SVt_LAST] = {
576 MAYBE_PURIFY(sizeof(IV), sizeof(XPVIV)), /* SVt_IV */
577 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
578 sizeof(XRV), /* SVt_RV */
579 sizeof(XPV), /* SVt_PV */
580 sizeof(XPVIV), /* SVt_PVIV */
581 sizeof(XPVNV), /* SVt_PVNV */
582 sizeof(XPVMG), /* SVt_PVMG */
583 sizeof(XPVBM), /* SVt_PVBM */
584 sizeof(XPVLV), /* SVt_PVLV */
585 sizeof(XPVAV), /* SVt_PVAV */
586 sizeof(XPVHV), /* SVt_PVHV */
587 sizeof(XPVCV), /* SVt_PVCV */
588 sizeof(XPVGV), /* SVt_PVGV */
589 sizeof(XPVFM), /* SVt_PVFM */
590 sizeof(XPVIO) /* SVt_PVIO */
591 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 0
595 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
597 MAYBE_PURIFY(sizeof(xpv_allocated), sizeof(XPV)), /* SVt_PV */
598 MAYBE_PURIFY(sizeof(xpviv_allocated), sizeof(XPVIV)),/* SVt_PVIV */
599 sizeof(XPVNV), /* SVt_PVNV */
600 sizeof(XPVMG), /* SVt_PVMG */
601 sizeof(XPVGV), /* SVt_PVGV */
602 sizeof(XPVLV), /* SVt_PVLV */
603 MAYBE_PURIFY(sizeof(xpvav_allocated), sizeof(XPVAV)),/* SVt_PVAV */
604 MAYBE_PURIFY(sizeof(xpvhv_allocated), sizeof(XPVHV)),/* SVt_PVHV */
605 MAYBE_PURIFY(sizeof(xpvcv_allocated), sizeof(XPVCV)),/* SVt_PVCV */
606 MAYBE_PURIFY(sizeof(xpvfm_allocated), sizeof(XPVFM)),/* SVt_PVFM */
607 sizeof(XPVIO), /* SVt_PVIO */
608 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 1
612 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
614 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
615 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
616 sizeof(XPVNV), /* SVt_PVNV */
617 sizeof(XPVMG), /* SVt_PVMG */
618 sizeof(XPVGV), /* SVt_PVGV */
619 sizeof(XPVLV), /* SVt_PVLV */
620 sizeof(XPVAV) - MAYBE_OFFSET(XPVAV, xav_fill), /* SVt_PVAV */
621 sizeof(XPVHV) - MAYBE_OFFSET(XPVHV, xhv_fill), /* SVt_PVHV */
622 sizeof(XPVCV) - MAYBE_OFFSET(XPVCV, xpv_cur), /* SVt_PVCV */
623 sizeof(XPVFM) - MAYBE_OFFSET(XPVFM, xpv_cur), /* SVt_PVFM */
624 sizeof(XPVIO) /* SVt_PVIO */
625 #elif PERL_VERSION < 13
629 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
630 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
631 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
632 sizeof(XPVNV), /* SVt_PVNV */
633 sizeof(XPVMG), /* SVt_PVMG */
634 sizeof(regexp) - MAYBE_OFFSET(regexp, xpv_cur), /* SVt_REGEXP */
635 sizeof(XPVGV), /* SVt_PVGV */
636 sizeof(XPVLV), /* SVt_PVLV */
637 sizeof(XPVAV) - MAYBE_OFFSET(XPVAV, xav_fill), /* SVt_PVAV */
638 sizeof(XPVHV) - MAYBE_OFFSET(XPVHV, xhv_fill), /* SVt_PVHV */
639 sizeof(XPVCV) - MAYBE_OFFSET(XPVCV, xpv_cur), /* SVt_PVCV */
640 sizeof(XPVFM) - MAYBE_OFFSET(XPVFM, xpv_cur), /* SVt_PVFM */
641 sizeof(XPVIO) /* SVt_PVIO */
646 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
647 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
648 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
649 sizeof(XPVNV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVNV */
650 sizeof(XPVMG), /* SVt_PVMG */
651 sizeof(regexp), /* SVt_REGEXP */
652 sizeof(XPVGV), /* SVt_PVGV */
653 sizeof(XPVLV), /* SVt_PVLV */
654 sizeof(XPVAV), /* SVt_PVAV */
655 sizeof(XPVHV), /* SVt_PVHV */
656 sizeof(XPVCV), /* SVt_PVCV */
657 sizeof(XPVFM), /* SVt_PVFM */
658 sizeof(XPVIO) /* SVt_PVIO */
664 padlist_size(pTHX_ struct state *const st, const PADLIST * const padl,
667 if (!check_new(st, padl))
669 /* This relies on PADNAMELIST and PAD being typedefed to AV. If that
670 ever changes, this code will need an update. */
671 st->total_size += sizeof(PADLIST);
672 sv_size(aTHX_ st, (SV*)PadlistNAMES(padl), recurse);
673 i = PadlistMAX(padl) + 1;
674 st->total_size += sizeof(PAD*) * i;
676 sv_size(aTHX_ st, (SV*)PadlistARRAY(padl)[i], recurse);
680 padlist_size(pTHX_ struct state *const st, const AV * const padl,
682 sv_size(aTHX_ st, (SV*)padl, recurse);
687 sv_size(pTHX_ struct state *const st, const SV * const orig_thing,
689 const SV *thing = orig_thing;
692 if(!check_new(st, thing))
695 type = SvTYPE(thing);
696 if (type > SVt_LAST) {
697 warn("Devel::Size: Unknown variable type: %d encountered\n", type);
700 st->total_size += sizeof(SV) + body_sizes[type];
702 if (type >= SVt_PVMG) {
703 magic_size(aTHX_ thing, st);
707 #if (PERL_VERSION < 11)
708 /* Is it a reference? */
713 if(recurse && SvROK(thing))
714 sv_size(aTHX_ st, SvRV_const(thing), recurse);
718 /* Is there anything in the array? */
719 if (AvMAX(thing) != -1) {
720 /* an array with 10 slots has AvMax() set to 9 - te 2007-04-22 */
721 st->total_size += sizeof(SV *) * (AvMAX(thing) + 1);
722 dbg_printf(("total_size: %li AvMAX: %li av_len: $i\n", st->total_size, AvMAX(thing), av_len((AV*)thing)));
724 if (recurse >= TOTAL_SIZE_RECURSION) {
725 SSize_t i = AvFILLp(thing) + 1;
728 sv_size(aTHX_ st, AvARRAY(thing)[i], recurse);
731 /* Add in the bits on the other side of the beginning */
733 dbg_printf(("total_size %li, sizeof(SV *) %li, AvARRAY(thing) %li, AvALLOC(thing)%li , sizeof(ptr) %li \n",
734 st->total_size, sizeof(SV*), AvARRAY(thing), AvALLOC(thing), sizeof( thing )));
736 /* under Perl 5.8.8 64bit threading, AvARRAY(thing) was a pointer while AvALLOC was 0,
737 resulting in grossly overstated sized for arrays. Technically, this shouldn't happen... */
738 if (AvALLOC(thing) != 0) {
739 st->total_size += (sizeof(SV *) * (AvARRAY(thing) - AvALLOC(thing)));
741 #if (PERL_VERSION < 9)
742 /* Is there something hanging off the arylen element?
743 Post 5.9.something this is stored in magic, so will be found there,
744 and Perl_av_arylen_p() takes a non-const AV*, hence compilers rightly
745 complain about AvARYLEN() passing thing to it. */
746 sv_size(aTHX_ st, AvARYLEN(thing), recurse);
750 /* Now the array of buckets */
751 st->total_size += (sizeof(HE *) * (HvMAX(thing) + 1));
752 /* Now walk the bucket chain */
753 if (HvARRAY(thing)) {
756 for (cur_bucket = 0; cur_bucket <= HvMAX(thing); cur_bucket++) {
757 cur_entry = *(HvARRAY(thing) + cur_bucket);
759 st->total_size += sizeof(HE);
760 hek_size(aTHX_ st, cur_entry->hent_hek, HvSHAREKEYS(thing));
761 if (recurse >= TOTAL_SIZE_RECURSION)
762 sv_size(aTHX_ st, HeVAL(cur_entry), recurse);
763 cur_entry = cur_entry->hent_next;
769 /* This direct access is arguably "naughty": */
770 struct mro_meta *meta = HvAUX(thing)->xhv_mro_meta;
771 #if PERL_VERSION > 13 || PERL_SUBVERSION > 8
773 I32 count = HvAUX(thing)->xhv_name_count;
776 HEK **names = HvAUX(thing)->xhv_name_u.xhvnameu_names;
780 hek_size(aTHX_ st, names[count], 1);
785 hek_size(aTHX_ st, HvNAME_HEK(thing), 1);
788 st->total_size += sizeof(struct xpvhv_aux);
790 st->total_size += sizeof(struct mro_meta);
791 sv_size(aTHX_ st, (SV *)meta->mro_nextmethod, TOTAL_SIZE_RECURSION);
792 #if PERL_VERSION > 10 || (PERL_VERSION == 10 && PERL_SUBVERSION > 0)
793 sv_size(aTHX_ st, (SV *)meta->isa, TOTAL_SIZE_RECURSION);
795 #if PERL_VERSION > 10
796 sv_size(aTHX_ st, (SV *)meta->mro_linear_all, TOTAL_SIZE_RECURSION);
797 sv_size(aTHX_ st, meta->mro_linear_current, TOTAL_SIZE_RECURSION);
799 sv_size(aTHX_ st, (SV *)meta->mro_linear_dfs, TOTAL_SIZE_RECURSION);
800 sv_size(aTHX_ st, (SV *)meta->mro_linear_c3, TOTAL_SIZE_RECURSION);
805 check_new_and_strlen(st, HvNAME_get(thing));
811 padlist_size(aTHX_ st, CvPADLIST(thing), SOME_RECURSION);
812 sv_size(aTHX_ st, (SV *)CvOUTSIDE(thing), recurse);
814 if (st->go_yell && !st->fm_whine) {
815 carp("Devel::Size: Calculated sizes for FMs are incomplete");
821 sv_size(aTHX_ st, (SV *)CvSTASH(thing), SOME_RECURSION);
822 sv_size(aTHX_ st, (SV *)SvSTASH(thing), SOME_RECURSION);
823 sv_size(aTHX_ st, (SV *)CvGV(thing), SOME_RECURSION);
824 padlist_size(aTHX_ st, CvPADLIST(thing), SOME_RECURSION);
825 sv_size(aTHX_ st, (SV *)CvOUTSIDE(thing), recurse);
826 if (CvISXSUB(thing)) {
827 sv_size(aTHX_ st, cv_const_sv((CV *)thing), recurse);
828 } else if (CvROOT(thing)) {
829 op_size(aTHX_ CvSTART(thing), st);
830 op_size(aTHX_ CvROOT(thing), st);
835 /* Some embedded char pointers */
836 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_top_name);
837 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_fmt_name);
838 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_bottom_name);
839 /* Throw the GVs on the list to be walked if they're not-null */
840 sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_top_gv, recurse);
841 sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_bottom_gv, recurse);
842 sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_fmt_gv, recurse);
844 /* Only go trotting through the IO structures if they're really
845 trottable. If USE_PERLIO is defined we can do this. If
846 not... we can't, so we don't even try */
848 /* Dig into xio_ifp and xio_ofp here */
849 warn("Devel::Size: Can't size up perlio layers yet\n");
854 #if (PERL_VERSION < 9)
859 if(isGV_with_GP(thing)) {
861 hek_size(aTHX_ st, GvNAME_HEK(thing), 1);
863 st->total_size += GvNAMELEN(thing);
866 hek_size(aTHX_ st, GvFILE_HEK(thing), 1);
867 #elif defined(GvFILE)
868 # if !defined(USE_ITHREADS) || (PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 8))
869 /* With itreads, before 5.8.9, this can end up pointing to freed memory
870 if the GV was created in an eval, as GvFILE() points to CopFILE(),
871 and the relevant COP has been freed on scope cleanup after the eval.
872 5.8.9 adds a binary compatible fudge that catches the vast majority
873 of cases. 5.9.something added a proper fix, by converting the GP to
874 use a shared hash key (porperly reference counted), instead of a
875 char * (owned by who knows? possibly no-one now) */
876 check_new_and_strlen(st, GvFILE(thing));
879 /* Is there something hanging off the glob? */
880 if (check_new(st, GvGP(thing))) {
881 st->total_size += sizeof(GP);
882 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_sv), recurse);
883 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_form), recurse);
884 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_av), recurse);
885 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_hv), recurse);
886 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_egv), recurse);
887 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_cv), recurse);
889 #if (PERL_VERSION >= 9)
893 #if PERL_VERSION <= 8
901 if(recurse && SvROK(thing))
902 sv_size(aTHX_ st, SvRV_const(thing), recurse);
903 else if (SvIsCOW_shared_hash(thing))
904 hek_size(aTHX_ st, SvSHARED_HEK_FROM_PV(SvPVX(thing)), 1);
906 st->total_size += SvLEN(thing);
910 SvOOK_offset(thing, len);
911 st->total_size += len;
919 static struct state *
925 Newxz(st, 1, struct state);
927 if (NULL != (warn_flag = perl_get_sv("Devel::Size::warn", FALSE))) {
928 st->dangle_whine = st->go_yell = SvIV(warn_flag) ? TRUE : FALSE;
930 if (NULL != (warn_flag = perl_get_sv("Devel::Size::dangle", FALSE))) {
931 st->dangle_whine = SvIV(warn_flag) ? TRUE : FALSE;
933 check_new(st, &PL_sv_undef);
934 check_new(st, &PL_sv_no);
935 check_new(st, &PL_sv_yes);
936 #if PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 0)
937 check_new(st, &PL_sv_placeholder);
942 MODULE = Devel::Size PACKAGE = Devel::Size
950 total_size = TOTAL_SIZE_RECURSION
953 SV *thing = orig_thing;
954 struct state *st = new_state(aTHX);
956 /* If they passed us a reference then dereference it. This is the
957 only way we can check the sizes of arrays and hashes */
962 sv_size(aTHX_ st, thing, ix);
963 RETVAL = st->total_size;