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
22 # define PL_opargs opargs
23 # define PL_op_name op_name
27 /* "structured exception" handling is a Microsoft extension to C and C++.
28 It's *not* C++ exception handling - C++ exception handling can't capture
29 SEGVs and suchlike, whereas this can. There's no known analagous
30 functionality on other platforms. */
32 # define TRY_TO_CATCH_SEGV __try
33 # define CAUGHT_EXCEPTION __except(EXCEPTION EXCEPTION_EXECUTE_HANDLER)
35 # define TRY_TO_CATCH_SEGV if(1)
36 # define CAUGHT_EXCEPTION else
40 # define __attribute__(x)
43 #if 0 && defined(DEBUGGING)
44 #define dbg_printf(x) printf x
49 #define TAG /* printf( "# %s(%d)\n", __FILE__, __LINE__ ) */
52 /* The idea is to have a tree structure to store 1 bit per possible pointer
53 address. The lowest 16 bits are stored in a block of 8092 bytes.
54 The blocks are in a 256-way tree, indexed by the reset of the pointer.
55 This can cope with 32 and 64 bit pointers, and any address space layout,
56 without excessive memory needs. The assumption is that your CPU cache
57 works :-) (And that we're not going to bust it) */
60 #define LEAF_BITS (16 - BYTE_BITS)
61 #define LEAF_MASK 0x1FFF
69 /* My hunch (not measured) is that for most architectures pointers will
70 start with 0 bits, hence the start of this array will be hot, and the
71 end unused. So put the flags next to the hot end. */
76 Checks to see if thing is in the bitstring.
77 Returns true or false, and
78 notes thing in the segmented bitstring.
81 check_new(struct state *st, const void *const p) {
82 unsigned int bits = 8 * sizeof(void*);
83 const size_t raw_p = PTR2nat(p);
84 /* This effectively rotates the value right by the number of low always-0
85 bits in an aligned pointer. The assmption is that most (if not all)
86 pointers are aligned, and these will be in the same chain of nodes
87 (and hence hot in the cache) but we can still deal with any unaligned
90 = (raw_p >> ALIGN_BITS) | (raw_p << (bits - ALIGN_BITS));
91 const U8 this_bit = 1 << (cooked_p & 0x7);
95 void **tv_p = (void **) (st->tracking);
97 if (NULL == p) return FALSE;
99 const char c = *(const char *)p;
102 if (st->dangle_whine)
103 warn( "Devel::Size: Encountered invalid pointer: %p\n", p );
109 /* bits now 24 (32 bit pointers) or 56 (64 bit pointers) */
111 /* First level is always present. */
113 i = (unsigned int)((cooked_p >> bits) & 0xFF);
115 Newxz(tv_p[i], 256, void *);
116 tv_p = (void **)(tv_p[i]);
118 } while (bits > LEAF_BITS + BYTE_BITS);
119 /* bits now 16 always */
120 #if !defined(MULTIPLICITY) || PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 8)
121 /* 5.8.8 and early have an assert() macro that uses Perl_croak, hence needs
122 a my_perl under multiplicity */
125 leaf_p = (U8 **)tv_p;
126 i = (unsigned int)((cooked_p >> bits) & 0xFF);
128 Newxz(leaf_p[i], 1 << LEAF_BITS, U8);
133 i = (unsigned int)((cooked_p >> BYTE_BITS) & LEAF_MASK);
135 if(leaf[i] & this_bit)
143 free_tracking_at(void **tv, int level)
151 free_tracking_at((void **) tv[i], level);
165 free_state(struct state *st)
167 const int top_level = (sizeof(void *) * 8 - LEAF_BITS - BYTE_BITS) / 8;
168 free_tracking_at((void **)st->tracking, top_level);
172 /* For now, this is somewhat a compatibility bodge until the plan comes
173 together for fine grained recursion control. total_size() would recurse into
174 hash and array members, whereas sv_size() would not. However, sv_size() is
175 called with CvSTASH() of a CV, which means that if it (also) starts to
176 recurse fully, then the size of any CV now becomes the size of the entire
177 symbol table reachable from it, and potentially the entire symbol table, if
178 any subroutine makes a reference to a global (such as %SIG). The historical
179 implementation of total_size() didn't report "everything", and changing the
180 only available size to "everything" doesn't feel at all useful. */
182 #define NO_RECURSION 0
183 #define SOME_RECURSION 1
184 #define TOTAL_SIZE_RECURSION 2
186 static void sv_size(pTHX_ struct state *, const SV *const, const int recurse);
202 , OPc_CONDOP /* 12 */
211 cc_opclass(const OP * const o)
217 return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
219 if (o->op_type == OP_SASSIGN)
220 return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
223 if (o->op_type == OP_GV || o->op_type == OP_GVSV || o->op_type == OP_AELEMFAST)
227 if ((o->op_type == OP_TRANS)) {
231 switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
263 #ifdef OA_PVOP_OR_SVOP
264 case OA_PVOP_OR_SVOP: TAG;
266 * Character translations (tr///) are usually a PVOP, keeping a
267 * pointer to a table of shorts used to look up translations.
268 * Under utf8, however, a simple table isn't practical; instead,
269 * the OP is an SVOP, and the SV is a reference to a swash
270 * (i.e., an RV pointing to an HV).
272 return (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
273 ? OPc_SVOP : OPc_PVOP;
282 case OA_BASEOP_OR_UNOP: TAG;
284 * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
285 * whether parens were seen. perly.y uses OPf_SPECIAL to
286 * signal whether a BASEOP had empty parens or none.
287 * Some other UNOPs are created later, though, so the best
288 * test is OPf_KIDS, which is set in newUNOP.
290 return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
292 case OA_FILESTATOP: TAG;
294 * The file stat OPs are created via UNI(OP_foo) in toke.c but use
295 * the OPf_REF flag to distinguish between OP types instead of the
296 * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
297 * return OPc_UNOP so that walkoptree can find our children. If
298 * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
299 * (no argument to the operator) it's an OP; with OPf_REF set it's
300 * an SVOP (and op_sv is the GV for the filehandle argument).
302 return ((o->op_flags & OPf_KIDS) ? OPc_UNOP :
304 (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP);
306 (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP);
308 case OA_LOOPEXOP: TAG;
310 * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
311 * label was omitted (in which case it's a BASEOP) or else a term was
312 * seen. In this last case, all except goto are definitely PVOP but
313 * goto is either a PVOP (with an ordinary constant label), an UNOP
314 * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
315 * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
318 if (o->op_flags & OPf_STACKED)
320 else if (o->op_flags & OPf_SPECIAL)
330 warn("Devel::Size: Can't determine class of operator %s, assuming BASEOP\n",
331 PL_op_name[o->op_type]);
337 /* Figure out how much magic is attached to the SV and return the
340 magic_size(pTHX_ const SV * const thing, struct state *st) {
341 MAGIC *magic_pointer = SvMAGIC(thing);
343 /* Have we seen the magic pointer? (NULL has always been seen before) */
344 while (check_new(st, magic_pointer)) {
345 st->total_size += sizeof(MAGIC);
346 /* magic vtables aren't freed when magic is freed, so don't count them.
347 (They are static structures. Anything that assumes otherwise is buggy.)
352 sv_size(aTHX_ st, magic_pointer->mg_obj, TOTAL_SIZE_RECURSION);
353 if (magic_pointer->mg_len == HEf_SVKEY) {
354 sv_size(aTHX_ st, (SV *)magic_pointer->mg_ptr, TOTAL_SIZE_RECURSION);
356 #if defined(PERL_MAGIC_utf8) && defined (PERL_MAGIC_UTF8_CACHESIZE)
357 else if (magic_pointer->mg_type == PERL_MAGIC_utf8) {
358 if (check_new(st, magic_pointer->mg_ptr)) {
359 st->total_size += PERL_MAGIC_UTF8_CACHESIZE * 2 * sizeof(STRLEN);
363 else if (magic_pointer->mg_len > 0) {
364 if (check_new(st, magic_pointer->mg_ptr)) {
365 st->total_size += magic_pointer->mg_len;
369 /* Get the next in the chain */
370 magic_pointer = magic_pointer->mg_moremagic;
373 if (st->dangle_whine)
374 warn( "Devel::Size: Encountered bad magic at: %p\n", magic_pointer );
380 check_new_and_strlen(struct state *st, const char *const p) {
382 st->total_size += 1 + strlen(p);
386 regex_size(const REGEXP * const baseregex, struct state *st) {
387 if(!check_new(st, baseregex))
389 st->total_size += sizeof(REGEXP);
390 #if (PERL_VERSION < 11)
391 /* Note the size of the paren offset thing */
392 st->total_size += sizeof(I32) * baseregex->nparens * 2;
393 st->total_size += strlen(baseregex->precomp);
395 st->total_size += sizeof(struct regexp);
396 st->total_size += sizeof(I32) * SvANY(baseregex)->nparens * 2;
397 /*st->total_size += strlen(SvANY(baseregex)->subbeg);*/
399 if (st->go_yell && !st->regex_whine) {
400 carp("Devel::Size: Calculated sizes for compiled regexes are incompatible, and probably always will be");
406 op_size(pTHX_ const OP * const baseop, struct state *st)
410 if(!check_new(st, baseop))
413 op_size(aTHX_ baseop->op_next, st);
415 switch (cc_opclass(baseop)) {
416 case OPc_BASEOP: TAG;
417 st->total_size += sizeof(struct op);
420 st->total_size += sizeof(struct unop);
421 op_size(aTHX_ ((UNOP *)baseop)->op_first, st);
424 st->total_size += sizeof(struct binop);
425 op_size(aTHX_ ((BINOP *)baseop)->op_first, st);
426 op_size(aTHX_ ((BINOP *)baseop)->op_last, st);
429 st->total_size += sizeof(struct logop);
430 op_size(aTHX_ ((BINOP *)baseop)->op_first, st);
431 op_size(aTHX_ ((LOGOP *)baseop)->op_other, st);
434 case OPc_CONDOP: TAG;
435 st->total_size += sizeof(struct condop);
436 op_size(aTHX_ ((BINOP *)baseop)->op_first, st);
437 op_size(aTHX_ ((CONDOP *)baseop)->op_true, st);
438 op_size(aTHX_ ((CONDOP *)baseop)->op_false, st);
441 case OPc_LISTOP: TAG;
442 st->total_size += sizeof(struct listop);
443 op_size(aTHX_ ((LISTOP *)baseop)->op_first, st);
444 op_size(aTHX_ ((LISTOP *)baseop)->op_last, st);
447 st->total_size += sizeof(struct pmop);
448 op_size(aTHX_ ((PMOP *)baseop)->op_first, st);
449 op_size(aTHX_ ((PMOP *)baseop)->op_last, st);
450 #if PERL_VERSION < 9 || (PERL_VERSION == 9 && PERL_SUBVERSION < 5)
451 op_size(aTHX_ ((PMOP *)baseop)->op_pmreplroot, st);
452 op_size(aTHX_ ((PMOP *)baseop)->op_pmreplstart, st);
454 /* This is defined away in perl 5.8.x, but it is in there for
457 regex_size(PM_GETRE((PMOP *)baseop), st);
459 regex_size(((PMOP *)baseop)->op_pmregexp, st);
463 st->total_size += sizeof(struct pmop);
464 if (!(baseop->op_type == OP_AELEMFAST
465 && baseop->op_flags & OPf_SPECIAL)) {
466 /* not an OP_PADAV replacement */
467 sv_size(aTHX_ st, ((SVOP *)baseop)->op_sv, SOME_RECURSION);
472 st->total_size += sizeof(struct padop);
477 st->total_size += sizeof(struct gvop);
478 sv_size(aTHX_ st, ((GVOP *)baseop)->op_gv, SOME_RECURSION);
482 check_new_and_strlen(st, ((PVOP *)baseop)->op_pv);
485 st->total_size += sizeof(struct loop);
486 op_size(aTHX_ ((LOOP *)baseop)->op_first, st);
487 op_size(aTHX_ ((LOOP *)baseop)->op_last, st);
488 op_size(aTHX_ ((LOOP *)baseop)->op_redoop, st);
489 op_size(aTHX_ ((LOOP *)baseop)->op_nextop, st);
490 op_size(aTHX_ ((LOOP *)baseop)->op_lastop, st);
495 basecop = (COP *)baseop;
496 st->total_size += sizeof(struct cop);
498 /* Change 33656 by nicholas@mouse-mill on 2008/04/07 11:29:51
499 Eliminate cop_label from struct cop by storing a label as the first
500 entry in the hints hash. Most statements don't have labels, so this
501 will save memory. Not sure how much.
502 The check below will be incorrect fail on bleadperls
503 before 5.11 @33656, but later than 5.10, producing slightly too
504 small memory sizes on these Perls. */
505 #if (PERL_VERSION < 11)
506 check_new_and_strlen(st, basecop->cop_label);
509 check_new_and_strlen(st, basecop->cop_file);
510 check_new_and_strlen(st, basecop->cop_stashpv);
512 sv_size(aTHX_ st, (SV *)basecop->cop_stash, SOME_RECURSION);
513 sv_size(aTHX_ st, (SV *)basecop->cop_filegv, SOME_RECURSION);
523 if (st->dangle_whine)
524 warn( "Devel::Size: Encountered dangling pointer in opcode at: %p\n", baseop );
529 hek_size(pTHX_ struct state *st, HEK *hek, U32 shared)
531 /* Hash keys can be shared. Have we seen this before? */
532 if (!check_new(st, hek))
534 st->total_size += HEK_BASESIZE + hek->hek_len
536 + 1 /* No hash key flags prior to 5.8.0 */
542 #if PERL_VERSION < 10
543 st->total_size += sizeof(struct he);
545 st->total_size += STRUCT_OFFSET(struct shared_he, shared_he_hek);
551 #if PERL_VERSION < 8 || PERL_SUBVERSION < 9
556 # define MAYBE_PURIFY(normal, pure) (pure)
557 # define MAYBE_OFFSET(struct_name, member) 0
559 # define MAYBE_PURIFY(normal, pure) (normal)
560 # define MAYBE_OFFSET(struct_name, member) STRUCT_OFFSET(struct_name, member)
563 const U8 body_sizes[SVt_LAST] = {
566 MAYBE_PURIFY(sizeof(IV), sizeof(XPVIV)), /* SVt_IV */
567 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
568 sizeof(XRV), /* SVt_RV */
569 sizeof(XPV), /* SVt_PV */
570 sizeof(XPVIV), /* SVt_PVIV */
571 sizeof(XPVNV), /* SVt_PVNV */
572 sizeof(XPVMG), /* SVt_PVMG */
573 sizeof(XPVBM), /* SVt_PVBM */
574 sizeof(XPVLV), /* SVt_PVLV */
575 sizeof(XPVAV), /* SVt_PVAV */
576 sizeof(XPVHV), /* SVt_PVHV */
577 sizeof(XPVCV), /* SVt_PVCV */
578 sizeof(XPVGV), /* SVt_PVGV */
579 sizeof(XPVFM), /* SVt_PVFM */
580 sizeof(XPVIO) /* SVt_PVIO */
581 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 0
585 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
587 MAYBE_PURIFY(sizeof(xpv_allocated), sizeof(XPV)), /* SVt_PV */
588 MAYBE_PURIFY(sizeof(xpviv_allocated), sizeof(XPVIV)),/* SVt_PVIV */
589 sizeof(XPVNV), /* SVt_PVNV */
590 sizeof(XPVMG), /* SVt_PVMG */
591 sizeof(XPVGV), /* SVt_PVGV */
592 sizeof(XPVLV), /* SVt_PVLV */
593 MAYBE_PURIFY(sizeof(xpvav_allocated), sizeof(XPVAV)),/* SVt_PVAV */
594 MAYBE_PURIFY(sizeof(xpvhv_allocated), sizeof(XPVHV)),/* SVt_PVHV */
595 MAYBE_PURIFY(sizeof(xpvcv_allocated), sizeof(XPVCV)),/* SVt_PVCV */
596 MAYBE_PURIFY(sizeof(xpvfm_allocated), sizeof(XPVFM)),/* SVt_PVFM */
597 sizeof(XPVIO), /* SVt_PVIO */
598 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 1
602 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
604 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
605 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
606 sizeof(XPVNV), /* SVt_PVNV */
607 sizeof(XPVMG), /* SVt_PVMG */
608 sizeof(XPVGV), /* SVt_PVGV */
609 sizeof(XPVLV), /* SVt_PVLV */
610 sizeof(XPVAV) - MAYBE_OFFSET(XPVAV, xav_fill), /* SVt_PVAV */
611 sizeof(XPVHV) - MAYBE_OFFSET(XPVHV, xhv_fill), /* SVt_PVHV */
612 sizeof(XPVCV) - MAYBE_OFFSET(XPVCV, xpv_cur), /* SVt_PVCV */
613 sizeof(XPVFM) - MAYBE_OFFSET(XPVFM, xpv_cur), /* SVt_PVFM */
614 sizeof(XPVIO) /* SVt_PVIO */
615 #elif PERL_VERSION < 13
619 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
620 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
621 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
622 sizeof(XPVNV), /* SVt_PVNV */
623 sizeof(XPVMG), /* SVt_PVMG */
624 sizeof(regexp) - MAYBE_OFFSET(regexp, xpv_cur), /* SVt_REGEXP */
625 sizeof(XPVGV), /* SVt_PVGV */
626 sizeof(XPVLV), /* SVt_PVLV */
627 sizeof(XPVAV) - MAYBE_OFFSET(XPVAV, xav_fill), /* SVt_PVAV */
628 sizeof(XPVHV) - MAYBE_OFFSET(XPVHV, xhv_fill), /* SVt_PVHV */
629 sizeof(XPVCV) - MAYBE_OFFSET(XPVCV, xpv_cur), /* SVt_PVCV */
630 sizeof(XPVFM) - MAYBE_OFFSET(XPVFM, xpv_cur), /* SVt_PVFM */
631 sizeof(XPVIO) /* SVt_PVIO */
636 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
637 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
638 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
639 sizeof(XPVNV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVNV */
640 sizeof(XPVMG), /* SVt_PVMG */
641 sizeof(regexp), /* SVt_REGEXP */
642 sizeof(XPVGV), /* SVt_PVGV */
643 sizeof(XPVLV), /* SVt_PVLV */
644 sizeof(XPVAV), /* SVt_PVAV */
645 sizeof(XPVHV), /* SVt_PVHV */
646 sizeof(XPVCV), /* SVt_PVCV */
647 sizeof(XPVFM), /* SVt_PVFM */
648 sizeof(XPVIO) /* SVt_PVIO */
653 sv_size(pTHX_ struct state *const st, const SV * const orig_thing,
655 const SV *thing = orig_thing;
658 if(!check_new(st, thing))
661 type = SvTYPE(thing);
662 if (type > SVt_LAST) {
663 warn("Devel::Size: Unknown variable type: %d encountered\n", type);
666 st->total_size += sizeof(SV) + body_sizes[type];
668 if (type >= SVt_PVMG) {
669 magic_size(aTHX_ thing, st);
673 #if (PERL_VERSION < 11)
674 /* Is it a reference? */
679 if(recurse && SvROK(thing))
680 sv_size(aTHX_ st, SvRV_const(thing), recurse);
684 /* Is there anything in the array? */
685 if (AvMAX(thing) != -1) {
686 /* an array with 10 slots has AvMax() set to 9 - te 2007-04-22 */
687 st->total_size += sizeof(SV *) * (AvMAX(thing) + 1);
688 dbg_printf(("total_size: %li AvMAX: %li av_len: $i\n", st->total_size, AvMAX(thing), av_len((AV*)thing)));
690 if (recurse >= TOTAL_SIZE_RECURSION) {
691 SSize_t i = AvFILLp(thing) + 1;
694 sv_size(aTHX_ st, AvARRAY(thing)[i], recurse);
697 /* Add in the bits on the other side of the beginning */
699 dbg_printf(("total_size %li, sizeof(SV *) %li, AvARRAY(thing) %li, AvALLOC(thing)%li , sizeof(ptr) %li \n",
700 st->total_size, sizeof(SV*), AvARRAY(thing), AvALLOC(thing), sizeof( thing )));
702 /* under Perl 5.8.8 64bit threading, AvARRAY(thing) was a pointer while AvALLOC was 0,
703 resulting in grossly overstated sized for arrays. Technically, this shouldn't happen... */
704 if (AvALLOC(thing) != 0) {
705 st->total_size += (sizeof(SV *) * (AvARRAY(thing) - AvALLOC(thing)));
707 #if (PERL_VERSION < 9)
708 /* Is there something hanging off the arylen element?
709 Post 5.9.something this is stored in magic, so will be found there,
710 and Perl_av_arylen_p() takes a non-const AV*, hence compilers rightly
711 complain about AvARYLEN() passing thing to it. */
712 sv_size(aTHX_ st, AvARYLEN(thing), recurse);
716 /* Now the array of buckets */
717 st->total_size += (sizeof(HE *) * (HvMAX(thing) + 1));
718 /* Now walk the bucket chain */
719 if (HvARRAY(thing)) {
722 for (cur_bucket = 0; cur_bucket <= HvMAX(thing); cur_bucket++) {
723 cur_entry = *(HvARRAY(thing) + cur_bucket);
725 st->total_size += sizeof(HE);
726 hek_size(aTHX_ st, cur_entry->hent_hek, HvSHAREKEYS(thing));
727 if (recurse >= TOTAL_SIZE_RECURSION)
728 sv_size(aTHX_ st, HeVAL(cur_entry), recurse);
729 cur_entry = cur_entry->hent_next;
737 sv_size(aTHX_ st, (SV *)CvPADLIST(thing), SOME_RECURSION);
738 sv_size(aTHX_ st, (SV *)CvOUTSIDE(thing), recurse);
740 if (st->go_yell && !st->fm_whine) {
741 carp("Devel::Size: Calculated sizes for FMs are incomplete");
747 sv_size(aTHX_ st, (SV *)CvSTASH(thing), SOME_RECURSION);
748 sv_size(aTHX_ st, (SV *)SvSTASH(thing), SOME_RECURSION);
749 sv_size(aTHX_ st, (SV *)CvGV(thing), SOME_RECURSION);
750 sv_size(aTHX_ st, (SV *)CvPADLIST(thing), SOME_RECURSION);
751 sv_size(aTHX_ st, (SV *)CvOUTSIDE(thing), recurse);
752 if (CvISXSUB(thing)) {
753 sv_size(aTHX_ st, cv_const_sv((CV *)thing), recurse);
755 op_size(aTHX_ CvSTART(thing), st);
756 op_size(aTHX_ CvROOT(thing), st);
761 /* Some embedded char pointers */
762 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_top_name);
763 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_fmt_name);
764 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_bottom_name);
765 /* Throw the GVs on the list to be walked if they're not-null */
766 sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_top_gv, recurse);
767 sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_bottom_gv, recurse);
768 sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_fmt_gv, recurse);
770 /* Only go trotting through the IO structures if they're really
771 trottable. If USE_PERLIO is defined we can do this. If
772 not... we can't, so we don't even try */
774 /* Dig into xio_ifp and xio_ofp here */
775 warn("Devel::Size: Can't size up perlio layers yet\n");
780 #if (PERL_VERSION < 9)
785 if(isGV_with_GP(thing)) {
786 st->total_size += GvNAMELEN(thing);
788 # if !defined(USE_ITHREADS) || (PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 8))
789 /* With itreads, before 5.8.9, this can end up pointing to freed memory
790 if the GV was created in an eval, as GvFILE() points to CopFILE(),
791 and the relevant COP has been freed on scope cleanup after the eval.
792 5.8.9 adds a binary compatible fudge that catches the vast majority
793 of cases. 5.9.something added a proper fix, by converting the GP to
794 use a shared hash key (porperly reference counted), instead of a
795 char * (owned by who knows? possibly no-one now) */
796 check_new_and_strlen(st, GvFILE(thing));
799 /* Is there something hanging off the glob? */
800 if (check_new(st, GvGP(thing))) {
801 st->total_size += sizeof(GP);
802 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_sv), recurse);
803 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_form), recurse);
804 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_av), recurse);
805 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_hv), recurse);
806 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_egv), recurse);
807 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_cv), recurse);
809 #if (PERL_VERSION >= 9)
813 #if PERL_VERSION <= 8
821 if(recurse && SvROK(thing))
822 sv_size(aTHX_ st, SvRV_const(thing), recurse);
824 st->total_size += SvLEN(thing);
828 SvOOK_offset(thing, len);
829 st->total_size += len;
837 static struct state *
843 Newxz(st, 1, struct state);
845 if (NULL != (warn_flag = perl_get_sv("Devel::Size::warn", FALSE))) {
846 st->dangle_whine = st->go_yell = SvIV(warn_flag) ? TRUE : FALSE;
848 if (NULL != (warn_flag = perl_get_sv("Devel::Size::dangle", FALSE))) {
849 st->dangle_whine = SvIV(warn_flag) ? TRUE : FALSE;
851 check_new(st, &PL_sv_undef);
852 check_new(st, &PL_sv_no);
853 check_new(st, &PL_sv_yes);
854 #if PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 0)
855 check_new(st, &PL_sv_placeholder);
860 MODULE = Devel::Size PACKAGE = Devel::Size
868 total_size = TOTAL_SIZE_RECURSION
871 SV *thing = orig_thing;
872 struct state *st = new_state(aTHX);
874 /* If they passed us a reference then dereference it. This is the
875 only way we can check the sizes of arrays and hashes */
880 sv_size(aTHX_ st, thing, ix);
881 RETVAL = st->total_size;