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 #if PERL_VERSION < 17 || (PERL_VERSION == 17 && PERL_SUBVERSION == 0)
522 /* This pointer is owned by the COP, and freed with it. */
523 check_new_and_strlen(st, basecop->cop_stashpv);
525 /* A per-interpreter pointer for this stash is allocated in
527 if (check_new(st, PL_stashpad + basecop->cop_stashoff))
528 st->total_size += sizeof(PL_stashpad[basecop->cop_stashoff]);
531 sv_size(aTHX_ st, (SV *)basecop->cop_filegv, SOME_RECURSION);
541 if (st->dangle_whine)
542 warn( "Devel::Size: Encountered dangling pointer in opcode at: %p\n", baseop );
547 hek_size(pTHX_ struct state *st, HEK *hek, U32 shared)
549 /* Hash keys can be shared. Have we seen this before? */
550 if (!check_new(st, hek))
552 st->total_size += HEK_BASESIZE + hek->hek_len
554 + 1 /* No hash key flags prior to 5.8.0 */
560 #if PERL_VERSION < 10
561 st->total_size += sizeof(struct he);
563 st->total_size += STRUCT_OFFSET(struct shared_he, shared_he_hek);
569 #if PERL_VERSION < 8 || PERL_SUBVERSION < 9
574 # define MAYBE_PURIFY(normal, pure) (pure)
575 # define MAYBE_OFFSET(struct_name, member) 0
577 # define MAYBE_PURIFY(normal, pure) (normal)
578 # define MAYBE_OFFSET(struct_name, member) STRUCT_OFFSET(struct_name, member)
581 const U8 body_sizes[SVt_LAST] = {
584 MAYBE_PURIFY(sizeof(IV), sizeof(XPVIV)), /* SVt_IV */
585 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
586 sizeof(XRV), /* SVt_RV */
587 sizeof(XPV), /* SVt_PV */
588 sizeof(XPVIV), /* SVt_PVIV */
589 sizeof(XPVNV), /* SVt_PVNV */
590 sizeof(XPVMG), /* SVt_PVMG */
591 sizeof(XPVBM), /* SVt_PVBM */
592 sizeof(XPVLV), /* SVt_PVLV */
593 sizeof(XPVAV), /* SVt_PVAV */
594 sizeof(XPVHV), /* SVt_PVHV */
595 sizeof(XPVCV), /* SVt_PVCV */
596 sizeof(XPVGV), /* SVt_PVGV */
597 sizeof(XPVFM), /* SVt_PVFM */
598 sizeof(XPVIO) /* SVt_PVIO */
599 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 0
603 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
605 MAYBE_PURIFY(sizeof(xpv_allocated), sizeof(XPV)), /* SVt_PV */
606 MAYBE_PURIFY(sizeof(xpviv_allocated), sizeof(XPVIV)),/* SVt_PVIV */
607 sizeof(XPVNV), /* SVt_PVNV */
608 sizeof(XPVMG), /* SVt_PVMG */
609 sizeof(XPVGV), /* SVt_PVGV */
610 sizeof(XPVLV), /* SVt_PVLV */
611 MAYBE_PURIFY(sizeof(xpvav_allocated), sizeof(XPVAV)),/* SVt_PVAV */
612 MAYBE_PURIFY(sizeof(xpvhv_allocated), sizeof(XPVHV)),/* SVt_PVHV */
613 MAYBE_PURIFY(sizeof(xpvcv_allocated), sizeof(XPVCV)),/* SVt_PVCV */
614 MAYBE_PURIFY(sizeof(xpvfm_allocated), sizeof(XPVFM)),/* SVt_PVFM */
615 sizeof(XPVIO), /* SVt_PVIO */
616 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 1
620 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
622 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
623 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
624 sizeof(XPVNV), /* SVt_PVNV */
625 sizeof(XPVMG), /* SVt_PVMG */
626 sizeof(XPVGV), /* SVt_PVGV */
627 sizeof(XPVLV), /* SVt_PVLV */
628 sizeof(XPVAV) - MAYBE_OFFSET(XPVAV, xav_fill), /* SVt_PVAV */
629 sizeof(XPVHV) - MAYBE_OFFSET(XPVHV, xhv_fill), /* SVt_PVHV */
630 sizeof(XPVCV) - MAYBE_OFFSET(XPVCV, xpv_cur), /* SVt_PVCV */
631 sizeof(XPVFM) - MAYBE_OFFSET(XPVFM, xpv_cur), /* SVt_PVFM */
632 sizeof(XPVIO) /* SVt_PVIO */
633 #elif PERL_VERSION < 13
637 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
638 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
639 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
640 sizeof(XPVNV), /* SVt_PVNV */
641 sizeof(XPVMG), /* SVt_PVMG */
642 sizeof(regexp) - MAYBE_OFFSET(regexp, xpv_cur), /* SVt_REGEXP */
643 sizeof(XPVGV), /* SVt_PVGV */
644 sizeof(XPVLV), /* SVt_PVLV */
645 sizeof(XPVAV) - MAYBE_OFFSET(XPVAV, xav_fill), /* SVt_PVAV */
646 sizeof(XPVHV) - MAYBE_OFFSET(XPVHV, xhv_fill), /* SVt_PVHV */
647 sizeof(XPVCV) - MAYBE_OFFSET(XPVCV, xpv_cur), /* SVt_PVCV */
648 sizeof(XPVFM) - MAYBE_OFFSET(XPVFM, xpv_cur), /* SVt_PVFM */
649 sizeof(XPVIO) /* SVt_PVIO */
654 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
655 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
656 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
657 sizeof(XPVNV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVNV */
658 sizeof(XPVMG), /* SVt_PVMG */
659 sizeof(regexp), /* SVt_REGEXP */
660 sizeof(XPVGV), /* SVt_PVGV */
661 sizeof(XPVLV), /* SVt_PVLV */
662 sizeof(XPVAV), /* SVt_PVAV */
663 sizeof(XPVHV), /* SVt_PVHV */
664 sizeof(XPVCV), /* SVt_PVCV */
665 sizeof(XPVFM), /* SVt_PVFM */
666 sizeof(XPVIO) /* SVt_PVIO */
672 padlist_size(pTHX_ struct state *const st, const PADLIST * const padl,
675 if (!check_new(st, padl))
677 /* This relies on PADNAMELIST and PAD being typedefed to AV. If that
678 ever changes, this code will need an update. */
679 st->total_size += sizeof(PADLIST);
680 sv_size(aTHX_ st, (SV*)PadlistNAMES(padl), recurse);
681 i = PadlistMAX(padl) + 1;
682 st->total_size += sizeof(PAD*) * i;
684 sv_size(aTHX_ st, (SV*)PadlistARRAY(padl)[i], recurse);
688 padlist_size(pTHX_ struct state *const st, const AV * const padl,
690 sv_size(aTHX_ st, (SV*)padl, recurse);
695 sv_size(pTHX_ struct state *const st, const SV * const orig_thing,
697 const SV *thing = orig_thing;
700 if(!check_new(st, thing))
703 type = SvTYPE(thing);
704 if (type > SVt_LAST) {
705 warn("Devel::Size: Unknown variable type: %d encountered\n", type);
708 st->total_size += sizeof(SV) + body_sizes[type];
710 if (SvMAGICAL(thing)) {
711 magic_size(aTHX_ thing, st);
715 #if (PERL_VERSION < 11)
716 /* Is it a reference? */
721 if(recurse && SvROK(thing))
722 sv_size(aTHX_ st, SvRV_const(thing), recurse);
726 /* Is there anything in the array? */
727 if (AvMAX(thing) != -1) {
728 /* an array with 10 slots has AvMax() set to 9 - te 2007-04-22 */
729 st->total_size += sizeof(SV *) * (AvMAX(thing) + 1);
730 dbg_printf(("total_size: %li AvMAX: %li av_len: $i\n", st->total_size, AvMAX(thing), av_len((AV*)thing)));
732 if (recurse >= TOTAL_SIZE_RECURSION) {
733 SSize_t i = AvFILLp(thing) + 1;
736 sv_size(aTHX_ st, AvARRAY(thing)[i], recurse);
739 /* Add in the bits on the other side of the beginning */
741 dbg_printf(("total_size %li, sizeof(SV *) %li, AvARRAY(thing) %li, AvALLOC(thing)%li , sizeof(ptr) %li \n",
742 st->total_size, sizeof(SV*), AvARRAY(thing), AvALLOC(thing), sizeof( thing )));
744 /* under Perl 5.8.8 64bit threading, AvARRAY(thing) was a pointer while AvALLOC was 0,
745 resulting in grossly overstated sized for arrays. Technically, this shouldn't happen... */
746 if (AvALLOC(thing) != 0) {
747 st->total_size += (sizeof(SV *) * (AvARRAY(thing) - AvALLOC(thing)));
749 #if (PERL_VERSION < 9)
750 /* Is there something hanging off the arylen element?
751 Post 5.9.something this is stored in magic, so will be found there,
752 and Perl_av_arylen_p() takes a non-const AV*, hence compilers rightly
753 complain about AvARYLEN() passing thing to it. */
754 sv_size(aTHX_ st, AvARYLEN(thing), recurse);
758 /* Now the array of buckets */
759 st->total_size += (sizeof(HE *) * (HvMAX(thing) + 1));
760 /* Now walk the bucket chain */
761 if (HvARRAY(thing)) {
764 for (cur_bucket = 0; cur_bucket <= HvMAX(thing); cur_bucket++) {
765 cur_entry = *(HvARRAY(thing) + cur_bucket);
767 st->total_size += sizeof(HE);
768 hek_size(aTHX_ st, cur_entry->hent_hek, HvSHAREKEYS(thing));
769 if (recurse >= TOTAL_SIZE_RECURSION)
770 sv_size(aTHX_ st, HeVAL(cur_entry), recurse);
771 cur_entry = cur_entry->hent_next;
777 /* This direct access is arguably "naughty": */
778 struct mro_meta *meta = HvAUX(thing)->xhv_mro_meta;
779 #if PERL_VERSION > 13 || PERL_SUBVERSION > 8
781 I32 count = HvAUX(thing)->xhv_name_count;
784 HEK **names = HvAUX(thing)->xhv_name_u.xhvnameu_names;
788 hek_size(aTHX_ st, names[count], 1);
793 hek_size(aTHX_ st, HvNAME_HEK(thing), 1);
796 st->total_size += sizeof(struct xpvhv_aux);
798 st->total_size += sizeof(struct mro_meta);
799 sv_size(aTHX_ st, (SV *)meta->mro_nextmethod, TOTAL_SIZE_RECURSION);
800 #if PERL_VERSION > 10 || (PERL_VERSION == 10 && PERL_SUBVERSION > 0)
801 sv_size(aTHX_ st, (SV *)meta->isa, TOTAL_SIZE_RECURSION);
803 #if PERL_VERSION > 10
804 sv_size(aTHX_ st, (SV *)meta->mro_linear_all, TOTAL_SIZE_RECURSION);
805 sv_size(aTHX_ st, meta->mro_linear_current, TOTAL_SIZE_RECURSION);
807 sv_size(aTHX_ st, (SV *)meta->mro_linear_dfs, TOTAL_SIZE_RECURSION);
808 sv_size(aTHX_ st, (SV *)meta->mro_linear_c3, TOTAL_SIZE_RECURSION);
813 check_new_and_strlen(st, HvNAME_get(thing));
819 padlist_size(aTHX_ st, CvPADLIST(thing), SOME_RECURSION);
820 sv_size(aTHX_ st, (SV *)CvOUTSIDE(thing), recurse);
822 if (st->go_yell && !st->fm_whine) {
823 carp("Devel::Size: Calculated sizes for FMs are incomplete");
829 sv_size(aTHX_ st, (SV *)CvSTASH(thing), SOME_RECURSION);
830 sv_size(aTHX_ st, (SV *)SvSTASH(thing), SOME_RECURSION);
831 sv_size(aTHX_ st, (SV *)CvGV(thing), SOME_RECURSION);
832 padlist_size(aTHX_ st, CvPADLIST(thing), SOME_RECURSION);
833 sv_size(aTHX_ st, (SV *)CvOUTSIDE(thing), recurse);
834 if (CvISXSUB(thing)) {
835 sv_size(aTHX_ st, cv_const_sv((CV *)thing), recurse);
836 } else if (CvROOT(thing)) {
837 op_size(aTHX_ CvSTART(thing), st);
838 op_size(aTHX_ CvROOT(thing), st);
843 /* Some embedded char pointers */
844 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_top_name);
845 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_fmt_name);
846 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_bottom_name);
847 /* Throw the GVs on the list to be walked if they're not-null */
848 sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_top_gv, recurse);
849 sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_bottom_gv, recurse);
850 sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_fmt_gv, recurse);
852 /* Only go trotting through the IO structures if they're really
853 trottable. If USE_PERLIO is defined we can do this. If
854 not... we can't, so we don't even try */
856 /* Dig into xio_ifp and xio_ofp here */
857 warn("Devel::Size: Can't size up perlio layers yet\n");
862 #if (PERL_VERSION < 9)
867 if(isGV_with_GP(thing)) {
869 hek_size(aTHX_ st, GvNAME_HEK(thing), 1);
871 st->total_size += GvNAMELEN(thing);
874 hek_size(aTHX_ st, GvFILE_HEK(thing), 1);
875 #elif defined(GvFILE)
876 # if !defined(USE_ITHREADS) || (PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 8))
877 /* With itreads, before 5.8.9, this can end up pointing to freed memory
878 if the GV was created in an eval, as GvFILE() points to CopFILE(),
879 and the relevant COP has been freed on scope cleanup after the eval.
880 5.8.9 adds a binary compatible fudge that catches the vast majority
881 of cases. 5.9.something added a proper fix, by converting the GP to
882 use a shared hash key (porperly reference counted), instead of a
883 char * (owned by who knows? possibly no-one now) */
884 check_new_and_strlen(st, GvFILE(thing));
887 /* Is there something hanging off the glob? */
888 if (check_new(st, GvGP(thing))) {
889 st->total_size += sizeof(GP);
890 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_sv), recurse);
891 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_form), recurse);
892 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_av), recurse);
893 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_hv), recurse);
894 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_egv), recurse);
895 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_cv), recurse);
897 #if (PERL_VERSION >= 9)
901 #if PERL_VERSION <= 8
909 if(recurse && SvROK(thing))
910 sv_size(aTHX_ st, SvRV_const(thing), recurse);
911 else if (SvIsCOW_shared_hash(thing))
912 hek_size(aTHX_ st, SvSHARED_HEK_FROM_PV(SvPVX(thing)), 1);
914 st->total_size += SvLEN(thing);
918 SvOOK_offset(thing, len);
919 st->total_size += len;
927 static struct state *
933 Newxz(st, 1, struct state);
935 if (NULL != (warn_flag = perl_get_sv("Devel::Size::warn", FALSE))) {
936 st->dangle_whine = st->go_yell = SvIV(warn_flag) ? TRUE : FALSE;
938 if (NULL != (warn_flag = perl_get_sv("Devel::Size::dangle", FALSE))) {
939 st->dangle_whine = SvIV(warn_flag) ? TRUE : FALSE;
941 check_new(st, &PL_sv_undef);
942 check_new(st, &PL_sv_no);
943 check_new(st, &PL_sv_yes);
944 #if PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 0)
945 check_new(st, &PL_sv_placeholder);
950 MODULE = Devel::Size PACKAGE = Devel::Size
958 total_size = TOTAL_SIZE_RECURSION
961 SV *thing = orig_thing;
962 struct state *st = new_state(aTHX);
964 /* If they passed us a reference then dereference it. This is the
965 only way we can check the sizes of arrays and hashes */
970 sv_size(aTHX_ st, thing, ix);
971 RETVAL = st->total_size;