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 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_stash, SOME_RECURSION);
524 sv_size(aTHX_ st, (SV *)basecop->cop_filegv, SOME_RECURSION);
534 if (st->dangle_whine)
535 warn( "Devel::Size: Encountered dangling pointer in opcode at: %p\n", baseop );
540 hek_size(pTHX_ struct state *st, HEK *hek, U32 shared)
542 /* Hash keys can be shared. Have we seen this before? */
543 if (!check_new(st, hek))
545 st->total_size += HEK_BASESIZE + hek->hek_len
547 + 1 /* No hash key flags prior to 5.8.0 */
553 #if PERL_VERSION < 10
554 st->total_size += sizeof(struct he);
556 st->total_size += STRUCT_OFFSET(struct shared_he, shared_he_hek);
562 #if PERL_VERSION < 8 || PERL_SUBVERSION < 9
567 # define MAYBE_PURIFY(normal, pure) (pure)
568 # define MAYBE_OFFSET(struct_name, member) 0
570 # define MAYBE_PURIFY(normal, pure) (normal)
571 # define MAYBE_OFFSET(struct_name, member) STRUCT_OFFSET(struct_name, member)
574 const U8 body_sizes[SVt_LAST] = {
577 MAYBE_PURIFY(sizeof(IV), sizeof(XPVIV)), /* SVt_IV */
578 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
579 sizeof(XRV), /* SVt_RV */
580 sizeof(XPV), /* SVt_PV */
581 sizeof(XPVIV), /* SVt_PVIV */
582 sizeof(XPVNV), /* SVt_PVNV */
583 sizeof(XPVMG), /* SVt_PVMG */
584 sizeof(XPVBM), /* SVt_PVBM */
585 sizeof(XPVLV), /* SVt_PVLV */
586 sizeof(XPVAV), /* SVt_PVAV */
587 sizeof(XPVHV), /* SVt_PVHV */
588 sizeof(XPVCV), /* SVt_PVCV */
589 sizeof(XPVGV), /* SVt_PVGV */
590 sizeof(XPVFM), /* SVt_PVFM */
591 sizeof(XPVIO) /* SVt_PVIO */
592 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 0
596 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
598 MAYBE_PURIFY(sizeof(xpv_allocated), sizeof(XPV)), /* SVt_PV */
599 MAYBE_PURIFY(sizeof(xpviv_allocated), sizeof(XPVIV)),/* SVt_PVIV */
600 sizeof(XPVNV), /* SVt_PVNV */
601 sizeof(XPVMG), /* SVt_PVMG */
602 sizeof(XPVGV), /* SVt_PVGV */
603 sizeof(XPVLV), /* SVt_PVLV */
604 MAYBE_PURIFY(sizeof(xpvav_allocated), sizeof(XPVAV)),/* SVt_PVAV */
605 MAYBE_PURIFY(sizeof(xpvhv_allocated), sizeof(XPVHV)),/* SVt_PVHV */
606 MAYBE_PURIFY(sizeof(xpvcv_allocated), sizeof(XPVCV)),/* SVt_PVCV */
607 MAYBE_PURIFY(sizeof(xpvfm_allocated), sizeof(XPVFM)),/* SVt_PVFM */
608 sizeof(XPVIO), /* SVt_PVIO */
609 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 1
613 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
615 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
616 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
617 sizeof(XPVNV), /* SVt_PVNV */
618 sizeof(XPVMG), /* SVt_PVMG */
619 sizeof(XPVGV), /* SVt_PVGV */
620 sizeof(XPVLV), /* SVt_PVLV */
621 sizeof(XPVAV) - MAYBE_OFFSET(XPVAV, xav_fill), /* SVt_PVAV */
622 sizeof(XPVHV) - MAYBE_OFFSET(XPVHV, xhv_fill), /* SVt_PVHV */
623 sizeof(XPVCV) - MAYBE_OFFSET(XPVCV, xpv_cur), /* SVt_PVCV */
624 sizeof(XPVFM) - MAYBE_OFFSET(XPVFM, xpv_cur), /* SVt_PVFM */
625 sizeof(XPVIO) /* SVt_PVIO */
626 #elif PERL_VERSION < 13
630 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
631 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
632 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
633 sizeof(XPVNV), /* SVt_PVNV */
634 sizeof(XPVMG), /* SVt_PVMG */
635 sizeof(regexp) - MAYBE_OFFSET(regexp, xpv_cur), /* SVt_REGEXP */
636 sizeof(XPVGV), /* SVt_PVGV */
637 sizeof(XPVLV), /* SVt_PVLV */
638 sizeof(XPVAV) - MAYBE_OFFSET(XPVAV, xav_fill), /* SVt_PVAV */
639 sizeof(XPVHV) - MAYBE_OFFSET(XPVHV, xhv_fill), /* SVt_PVHV */
640 sizeof(XPVCV) - MAYBE_OFFSET(XPVCV, xpv_cur), /* SVt_PVCV */
641 sizeof(XPVFM) - MAYBE_OFFSET(XPVFM, xpv_cur), /* SVt_PVFM */
642 sizeof(XPVIO) /* SVt_PVIO */
647 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
648 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
649 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
650 sizeof(XPVNV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVNV */
651 sizeof(XPVMG), /* SVt_PVMG */
652 sizeof(regexp), /* SVt_REGEXP */
653 sizeof(XPVGV), /* SVt_PVGV */
654 sizeof(XPVLV), /* SVt_PVLV */
655 sizeof(XPVAV), /* SVt_PVAV */
656 sizeof(XPVHV), /* SVt_PVHV */
657 sizeof(XPVCV), /* SVt_PVCV */
658 sizeof(XPVFM), /* SVt_PVFM */
659 sizeof(XPVIO) /* SVt_PVIO */
664 sv_size(pTHX_ struct state *const st, const SV * const orig_thing,
666 const SV *thing = orig_thing;
669 if(!check_new(st, thing))
672 type = SvTYPE(thing);
673 if (type > SVt_LAST) {
674 warn("Devel::Size: Unknown variable type: %d encountered\n", type);
677 st->total_size += sizeof(SV) + body_sizes[type];
679 if (type >= SVt_PVMG) {
680 magic_size(aTHX_ thing, st);
684 #if (PERL_VERSION < 11)
685 /* Is it a reference? */
690 if(recurse && SvROK(thing))
691 sv_size(aTHX_ st, SvRV_const(thing), recurse);
695 /* Is there anything in the array? */
696 if (AvMAX(thing) != -1) {
697 /* an array with 10 slots has AvMax() set to 9 - te 2007-04-22 */
698 st->total_size += sizeof(SV *) * (AvMAX(thing) + 1);
699 dbg_printf(("total_size: %li AvMAX: %li av_len: $i\n", st->total_size, AvMAX(thing), av_len((AV*)thing)));
701 if (recurse >= TOTAL_SIZE_RECURSION) {
702 SSize_t i = AvFILLp(thing) + 1;
705 sv_size(aTHX_ st, AvARRAY(thing)[i], recurse);
708 /* Add in the bits on the other side of the beginning */
710 dbg_printf(("total_size %li, sizeof(SV *) %li, AvARRAY(thing) %li, AvALLOC(thing)%li , sizeof(ptr) %li \n",
711 st->total_size, sizeof(SV*), AvARRAY(thing), AvALLOC(thing), sizeof( thing )));
713 /* under Perl 5.8.8 64bit threading, AvARRAY(thing) was a pointer while AvALLOC was 0,
714 resulting in grossly overstated sized for arrays. Technically, this shouldn't happen... */
715 if (AvALLOC(thing) != 0) {
716 st->total_size += (sizeof(SV *) * (AvARRAY(thing) - AvALLOC(thing)));
718 #if (PERL_VERSION < 9)
719 /* Is there something hanging off the arylen element?
720 Post 5.9.something this is stored in magic, so will be found there,
721 and Perl_av_arylen_p() takes a non-const AV*, hence compilers rightly
722 complain about AvARYLEN() passing thing to it. */
723 sv_size(aTHX_ st, AvARYLEN(thing), recurse);
727 /* Now the array of buckets */
728 st->total_size += (sizeof(HE *) * (HvMAX(thing) + 1));
729 /* Now walk the bucket chain */
730 if (HvARRAY(thing)) {
733 for (cur_bucket = 0; cur_bucket <= HvMAX(thing); cur_bucket++) {
734 cur_entry = *(HvARRAY(thing) + cur_bucket);
736 st->total_size += sizeof(HE);
737 hek_size(aTHX_ st, cur_entry->hent_hek, HvSHAREKEYS(thing));
738 if (recurse >= TOTAL_SIZE_RECURSION)
739 sv_size(aTHX_ st, HeVAL(cur_entry), recurse);
740 cur_entry = cur_entry->hent_next;
748 sv_size(aTHX_ st, (SV *)CvPADLIST(thing), SOME_RECURSION);
749 sv_size(aTHX_ st, (SV *)CvOUTSIDE(thing), recurse);
751 if (st->go_yell && !st->fm_whine) {
752 carp("Devel::Size: Calculated sizes for FMs are incomplete");
758 sv_size(aTHX_ st, (SV *)CvSTASH(thing), SOME_RECURSION);
759 sv_size(aTHX_ st, (SV *)SvSTASH(thing), SOME_RECURSION);
760 sv_size(aTHX_ st, (SV *)CvGV(thing), SOME_RECURSION);
761 sv_size(aTHX_ st, (SV *)CvPADLIST(thing), SOME_RECURSION);
762 sv_size(aTHX_ st, (SV *)CvOUTSIDE(thing), recurse);
763 if (CvISXSUB(thing)) {
764 sv_size(aTHX_ st, cv_const_sv((CV *)thing), recurse);
766 op_size(aTHX_ CvSTART(thing), st);
767 op_size(aTHX_ CvROOT(thing), st);
772 /* Some embedded char pointers */
773 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_top_name);
774 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_fmt_name);
775 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_bottom_name);
776 /* Throw the GVs on the list to be walked if they're not-null */
777 sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_top_gv, recurse);
778 sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_bottom_gv, recurse);
779 sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_fmt_gv, recurse);
781 /* Only go trotting through the IO structures if they're really
782 trottable. If USE_PERLIO is defined we can do this. If
783 not... we can't, so we don't even try */
785 /* Dig into xio_ifp and xio_ofp here */
786 warn("Devel::Size: Can't size up perlio layers yet\n");
791 #if (PERL_VERSION < 9)
796 if(isGV_with_GP(thing)) {
798 hek_size(aTHX_ st, GvNAME_HEK(thing), 1);
800 st->total_size += GvNAMELEN(thing);
803 hek_size(aTHX_ st, GvFILE_HEK(thing), 1);
804 #elif defined(GvFILE)
805 # if !defined(USE_ITHREADS) || (PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 8))
806 /* With itreads, before 5.8.9, this can end up pointing to freed memory
807 if the GV was created in an eval, as GvFILE() points to CopFILE(),
808 and the relevant COP has been freed on scope cleanup after the eval.
809 5.8.9 adds a binary compatible fudge that catches the vast majority
810 of cases. 5.9.something added a proper fix, by converting the GP to
811 use a shared hash key (porperly reference counted), instead of a
812 char * (owned by who knows? possibly no-one now) */
813 check_new_and_strlen(st, GvFILE(thing));
816 /* Is there something hanging off the glob? */
817 if (check_new(st, GvGP(thing))) {
818 st->total_size += sizeof(GP);
819 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_sv), recurse);
820 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_form), recurse);
821 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_av), recurse);
822 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_hv), recurse);
823 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_egv), recurse);
824 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_cv), recurse);
826 #if (PERL_VERSION >= 9)
830 #if PERL_VERSION <= 8
838 if(recurse && SvROK(thing))
839 sv_size(aTHX_ st, SvRV_const(thing), recurse);
840 else if (SvIsCOW_shared_hash(thing))
841 hek_size(aTHX_ st, SvSHARED_HEK_FROM_PV(SvPVX(thing)), 1);
843 st->total_size += SvLEN(thing);
847 SvOOK_offset(thing, len);
848 st->total_size += len;
856 static struct state *
862 Newxz(st, 1, struct state);
864 if (NULL != (warn_flag = perl_get_sv("Devel::Size::warn", FALSE))) {
865 st->dangle_whine = st->go_yell = SvIV(warn_flag) ? TRUE : FALSE;
867 if (NULL != (warn_flag = perl_get_sv("Devel::Size::dangle", FALSE))) {
868 st->dangle_whine = SvIV(warn_flag) ? TRUE : FALSE;
870 check_new(st, &PL_sv_undef);
871 check_new(st, &PL_sv_no);
872 check_new(st, &PL_sv_yes);
873 #if PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 0)
874 check_new(st, &PL_sv_placeholder);
879 MODULE = Devel::Size PACKAGE = Devel::Size
887 total_size = TOTAL_SIZE_RECURSION
890 SV *thing = orig_thing;
891 struct state *st = new_state(aTHX);
893 /* If they passed us a reference then dereference it. This is the
894 only way we can check the sizes of arrays and hashes */
899 sv_size(aTHX_ st, thing, ix);
900 RETVAL = st->total_size;