1 #define PERL_NO_GET_CONTEXT
8 /* Not yet in ppport.h */
10 # define CvISXSUB(cv) (CvXSUB(cv) ? TRUE : FALSE)
13 # define SvRV_const(rv) SvRV(rv)
16 # define SvOOK_offset(sv, len) STMT_START { len = SvIVX(sv); } STMT_END
20 # define PL_opargs opargs
21 # define PL_op_name op_name
25 /* "structured exception" handling is a Microsoft extension to C and C++.
26 It's *not* C++ exception handling - C++ exception handling can't capture
27 SEGVs and suchlike, whereas this can. There's no known analagous
28 functionality on other platforms. */
30 # define TRY_TO_CATCH_SEGV __try
31 # define CAUGHT_EXCEPTION __except(EXCEPTION EXCEPTION_EXECUTE_HANDLER)
33 # define TRY_TO_CATCH_SEGV if(1)
34 # define CAUGHT_EXCEPTION else
38 # define __attribute__(x)
41 #if 0 && defined(DEBUGGING)
42 #define dbg_printf(x) printf x
47 #define TAG /* printf( "# %s(%d)\n", __FILE__, __LINE__ ) */
50 /* The idea is to have a tree structure to store 1 bit per possible pointer
51 address. The lowest 16 bits are stored in a block of 8092 bytes.
52 The blocks are in a 256-way tree, indexed by the reset of the pointer.
53 This can cope with 32 and 64 bit pointers, and any address space layout,
54 without excessive memory needs. The assumption is that your CPU cache
55 works :-) (And that we're not going to bust it) */
58 #define LEAF_BITS (16 - BYTE_BITS)
59 #define LEAF_MASK 0x1FFF
67 /* My hunch (not measured) is that for most architectures pointers will
68 start with 0 bits, hence the start of this array will be hot, and the
69 end unused. So put the flags next to the hot end. */
74 Checks to see if thing is in the bitstring.
75 Returns true or false, and
76 notes thing in the segmented bitstring.
79 check_new(struct state *st, const void *const p) {
80 unsigned int bits = 8 * sizeof(void*);
81 const size_t raw_p = PTR2nat(p);
82 /* This effectively rotates the value right by the number of low always-0
83 bits in an aligned pointer. The assmption is that most (if not all)
84 pointers are aligned, and these will be in the same chain of nodes
85 (and hence hot in the cache) but we can still deal with any unaligned
88 = (raw_p >> ALIGN_BITS) | (raw_p << (bits - ALIGN_BITS));
89 const U8 this_bit = 1 << (cooked_p & 0x7);
93 void **tv_p = (void **) (st->tracking);
95 if (NULL == p) return FALSE;
97 const char c = *(const char *)p;
100 if (st->dangle_whine)
101 warn( "Devel::Size: Encountered invalid pointer: %p\n", p );
107 /* bits now 24 (32 bit pointers) or 56 (64 bit pointers) */
109 /* First level is always present. */
111 i = (unsigned int)((cooked_p >> bits) & 0xFF);
113 Newxz(tv_p[i], 256, void *);
114 tv_p = (void **)(tv_p[i]);
116 } while (bits > LEAF_BITS + BYTE_BITS);
117 /* bits now 16 always */
118 #if !defined(MULTIPLICITY) || PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 8)
119 /* 5.8.8 and early have an assert() macro that uses Perl_croak, hence needs
120 a my_perl under multiplicity */
123 leaf_p = (U8 **)tv_p;
124 i = (unsigned int)((cooked_p >> bits) & 0xFF);
126 Newxz(leaf_p[i], 1 << LEAF_BITS, U8);
131 i = (unsigned int)((cooked_p >> BYTE_BITS) & LEAF_MASK);
133 if(leaf[i] & this_bit)
141 free_tracking_at(void **tv, int level)
149 free_tracking_at(tv[i], level);
163 free_state(struct state *st)
165 const int top_level = (sizeof(void *) * 8 - LEAF_BITS - BYTE_BITS) / 8;
166 free_tracking_at((void **)st->tracking, top_level);
170 /* For now, this is somewhat a compatibility bodge until the plan comes
171 together for fine grained recursion control. total_size() would recurse into
172 hash and array members, whereas sv_size() would not. However, sv_size() is
173 called with CvSTASH() of a CV, which means that if it (also) starts to
174 recurse fully, then the size of any CV now becomes the size of the entire
175 symbol table reachable from it, and potentially the entire symbol table, if
176 any subroutine makes a reference to a global (such as %SIG). The historical
177 implementation of total_size() didn't report "everything", and changing the
178 only available size to "everything" doesn't feel at all useful. */
180 #define NO_RECURSION 0
181 #define SOME_RECURSION 1
182 #define TOTAL_SIZE_RECURSION 2
184 static void sv_size(pTHX_ struct state *, const SV *const, const int recurse);
200 , OPc_CONDOP /* 12 */
209 cc_opclass(const OP * const o)
215 return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
217 if (o->op_type == OP_SASSIGN)
218 return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
221 if (o->op_type == OP_GV || o->op_type == OP_GVSV || o->op_type == OP_AELEMFAST)
225 if ((o->op_type == OP_TRANS)) {
229 switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
261 #ifdef OA_PVOP_OR_SVOP
262 case OA_PVOP_OR_SVOP: TAG;
264 * Character translations (tr///) are usually a PVOP, keeping a
265 * pointer to a table of shorts used to look up translations.
266 * Under utf8, however, a simple table isn't practical; instead,
267 * the OP is an SVOP, and the SV is a reference to a swash
268 * (i.e., an RV pointing to an HV).
270 return (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
271 ? OPc_SVOP : OPc_PVOP;
280 case OA_BASEOP_OR_UNOP: TAG;
282 * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
283 * whether parens were seen. perly.y uses OPf_SPECIAL to
284 * signal whether a BASEOP had empty parens or none.
285 * Some other UNOPs are created later, though, so the best
286 * test is OPf_KIDS, which is set in newUNOP.
288 return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
290 case OA_FILESTATOP: TAG;
292 * The file stat OPs are created via UNI(OP_foo) in toke.c but use
293 * the OPf_REF flag to distinguish between OP types instead of the
294 * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
295 * return OPc_UNOP so that walkoptree can find our children. If
296 * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
297 * (no argument to the operator) it's an OP; with OPf_REF set it's
298 * an SVOP (and op_sv is the GV for the filehandle argument).
300 return ((o->op_flags & OPf_KIDS) ? OPc_UNOP :
302 (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP);
304 (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP);
306 case OA_LOOPEXOP: TAG;
308 * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
309 * label was omitted (in which case it's a BASEOP) or else a term was
310 * seen. In this last case, all except goto are definitely PVOP but
311 * goto is either a PVOP (with an ordinary constant label), an UNOP
312 * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
313 * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
316 if (o->op_flags & OPf_STACKED)
318 else if (o->op_flags & OPf_SPECIAL)
328 warn("Devel::Size: Can't determine class of operator %s, assuming BASEOP\n",
329 PL_op_name[o->op_type]);
335 /* Figure out how much magic is attached to the SV and return the
338 magic_size(pTHX_ const SV * const thing, struct state *st) {
339 MAGIC *magic_pointer = SvMAGIC(thing);
341 /* Have we seen the magic pointer? (NULL has always been seen before) */
342 while (check_new(st, magic_pointer)) {
343 st->total_size += sizeof(MAGIC);
344 /* magic vtables aren't freed when magic is freed, so don't count them.
345 (They are static structures. Anything that assumes otherwise is buggy.)
350 sv_size(aTHX_ st, magic_pointer->mg_obj, TOTAL_SIZE_RECURSION);
351 if (magic_pointer->mg_len == HEf_SVKEY) {
352 sv_size(aTHX_ st, (SV *)magic_pointer->mg_ptr, TOTAL_SIZE_RECURSION);
354 #if defined(PERL_MAGIC_utf8) && defined (PERL_MAGIC_UTF8_CACHESIZE)
355 else if (magic_pointer->mg_type == PERL_MAGIC_utf8) {
356 if (check_new(st, magic_pointer->mg_ptr)) {
357 st->total_size += PERL_MAGIC_UTF8_CACHESIZE * 2 * sizeof(STRLEN);
361 else if (magic_pointer->mg_len > 0) {
362 if (check_new(st, magic_pointer->mg_ptr)) {
363 st->total_size += magic_pointer->mg_len;
367 /* Get the next in the chain */
368 magic_pointer = magic_pointer->mg_moremagic;
371 if (st->dangle_whine)
372 warn( "Devel::Size: Encountered bad magic at: %p\n", magic_pointer );
378 check_new_and_strlen(struct state *st, const char *const p) {
380 st->total_size += 1 + strlen(p);
384 regex_size(const REGEXP * const baseregex, struct state *st) {
385 if(!check_new(st, baseregex))
387 st->total_size += sizeof(REGEXP);
388 #if (PERL_VERSION < 11)
389 /* Note the size of the paren offset thing */
390 st->total_size += sizeof(I32) * baseregex->nparens * 2;
391 st->total_size += strlen(baseregex->precomp);
393 st->total_size += sizeof(struct regexp);
394 st->total_size += sizeof(I32) * SvANY(baseregex)->nparens * 2;
395 /*st->total_size += strlen(SvANY(baseregex)->subbeg);*/
397 if (st->go_yell && !st->regex_whine) {
398 carp("Devel::Size: Calculated sizes for compiled regexes are incompatible, and probably always will be");
404 op_size(pTHX_ const OP * const baseop, struct state *st)
408 if(!check_new(st, baseop))
411 op_size(aTHX_ baseop->op_next, st);
413 switch (cc_opclass(baseop)) {
414 case OPc_BASEOP: TAG;
415 st->total_size += sizeof(struct op);
418 st->total_size += sizeof(struct unop);
419 op_size(aTHX_ ((UNOP *)baseop)->op_first, st);
422 st->total_size += sizeof(struct binop);
423 op_size(aTHX_ ((BINOP *)baseop)->op_first, st);
424 op_size(aTHX_ ((BINOP *)baseop)->op_last, st);
427 st->total_size += sizeof(struct logop);
428 op_size(aTHX_ ((BINOP *)baseop)->op_first, st);
429 op_size(aTHX_ ((LOGOP *)baseop)->op_other, st);
432 case OPc_CONDOP: TAG;
433 st->total_size += sizeof(struct condop);
434 op_size(aTHX_ ((BINOP *)baseop)->op_first, st);
435 op_size(aTHX_ ((CONDOP *)baseop)->op_true, st);
436 op_size(aTHX_ ((CONDOP *)baseop)->op_false, st);
439 case OPc_LISTOP: TAG;
440 st->total_size += sizeof(struct listop);
441 op_size(aTHX_ ((LISTOP *)baseop)->op_first, st);
442 op_size(aTHX_ ((LISTOP *)baseop)->op_last, st);
445 st->total_size += sizeof(struct pmop);
446 op_size(aTHX_ ((PMOP *)baseop)->op_first, st);
447 op_size(aTHX_ ((PMOP *)baseop)->op_last, st);
448 #if PERL_VERSION < 9 || (PERL_VERSION == 9 && PERL_SUBVERSION < 5)
449 op_size(aTHX_ ((PMOP *)baseop)->op_pmreplroot, st);
450 op_size(aTHX_ ((PMOP *)baseop)->op_pmreplstart, st);
452 /* This is defined away in perl 5.8.x, but it is in there for
455 regex_size(PM_GETRE((PMOP *)baseop), st);
457 regex_size(((PMOP *)baseop)->op_pmregexp, st);
461 st->total_size += sizeof(struct pmop);
462 if (!(baseop->op_type == OP_AELEMFAST
463 && baseop->op_flags & OPf_SPECIAL)) {
464 /* not an OP_PADAV replacement */
465 sv_size(aTHX_ st, ((SVOP *)baseop)->op_sv, SOME_RECURSION);
470 st->total_size += sizeof(struct padop);
475 st->total_size += sizeof(struct gvop);
476 sv_size(aTHX_ st, ((GVOP *)baseop)->op_gv, SOME_RECURSION);
480 check_new_and_strlen(st, ((PVOP *)baseop)->op_pv);
483 st->total_size += sizeof(struct loop);
484 op_size(aTHX_ ((LOOP *)baseop)->op_first, st);
485 op_size(aTHX_ ((LOOP *)baseop)->op_last, st);
486 op_size(aTHX_ ((LOOP *)baseop)->op_redoop, st);
487 op_size(aTHX_ ((LOOP *)baseop)->op_nextop, st);
488 op_size(aTHX_ ((LOOP *)baseop)->op_lastop, st);
493 basecop = (COP *)baseop;
494 st->total_size += sizeof(struct cop);
496 /* Change 33656 by nicholas@mouse-mill on 2008/04/07 11:29:51
497 Eliminate cop_label from struct cop by storing a label as the first
498 entry in the hints hash. Most statements don't have labels, so this
499 will save memory. Not sure how much.
500 The check below will be incorrect fail on bleadperls
501 before 5.11 @33656, but later than 5.10, producing slightly too
502 small memory sizes on these Perls. */
503 #if (PERL_VERSION < 11)
504 check_new_and_strlen(st, basecop->cop_label);
507 check_new_and_strlen(st, basecop->cop_file);
508 check_new_and_strlen(st, basecop->cop_stashpv);
510 sv_size(aTHX_ st, (SV *)basecop->cop_stash, SOME_RECURSION);
511 sv_size(aTHX_ st, (SV *)basecop->cop_filegv, SOME_RECURSION);
521 if (st->dangle_whine)
522 warn( "Devel::Size: Encountered dangling pointer in opcode at: %p\n", baseop );
526 #if PERL_VERSION < 8 || PERL_SUBVERSION < 9
531 # define MAYBE_PURIFY(normal, pure) (pure)
532 # define MAYBE_OFFSET(struct_name, member) 0
534 # define MAYBE_PURIFY(normal, pure) (normal)
535 # define MAYBE_OFFSET(struct_name, member) STRUCT_OFFSET(struct_name, member)
538 const U8 body_sizes[SVt_LAST] = {
541 MAYBE_PURIFY(sizeof(IV), sizeof(XPVIV)), /* SVt_IV */
542 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
543 sizeof(XRV), /* SVt_RV */
544 sizeof(XPV), /* SVt_PV */
545 sizeof(XPVIV), /* SVt_PVIV */
546 sizeof(XPVNV), /* SVt_PVNV */
547 sizeof(XPVMG), /* SVt_PVMG */
548 sizeof(XPVBM), /* SVt_PVBM */
549 sizeof(XPVLV), /* SVt_PVLV */
550 sizeof(XPVAV), /* SVt_PVAV */
551 sizeof(XPVHV), /* SVt_PVHV */
552 sizeof(XPVCV), /* SVt_PVCV */
553 sizeof(XPVGV), /* SVt_PVGV */
554 sizeof(XPVFM), /* SVt_PVFM */
555 sizeof(XPVIO) /* SVt_PVIO */
556 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 0
560 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
562 MAYBE_PURIFY(sizeof(xpv_allocated), sizeof(XPV)), /* SVt_PV */
563 MAYBE_PURIFY(sizeof(xpviv_allocated), sizeof(XPVIV)),/* SVt_PVIV */
564 sizeof(XPVNV), /* SVt_PVNV */
565 sizeof(XPVMG), /* SVt_PVMG */
566 sizeof(XPVGV), /* SVt_PVGV */
567 sizeof(XPVLV), /* SVt_PVLV */
568 MAYBE_PURIFY(sizeof(xpvav_allocated), sizeof(XPVAV)),/* SVt_PVAV */
569 MAYBE_PURIFY(sizeof(xpvhv_allocated), sizeof(XPVHV)),/* SVt_PVHV */
570 MAYBE_PURIFY(sizeof(xpvcv_allocated), sizeof(XPVCV)),/* SVt_PVCV */
571 MAYBE_PURIFY(sizeof(xpvfm_allocated), sizeof(XPVFM)),/* SVt_PVFM */
572 sizeof(XPVIO), /* SVt_PVIO */
573 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 1
577 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
579 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
580 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
581 sizeof(XPVNV), /* SVt_PVNV */
582 sizeof(XPVMG), /* SVt_PVMG */
583 sizeof(XPVGV), /* SVt_PVGV */
584 sizeof(XPVLV), /* SVt_PVLV */
585 sizeof(XPVAV) - MAYBE_OFFSET(XPVAV, xav_fill), /* SVt_PVAV */
586 sizeof(XPVHV) - MAYBE_OFFSET(XPVHV, xhv_fill), /* SVt_PVHV */
587 sizeof(XPVCV) - MAYBE_OFFSET(XPVCV, xpv_cur), /* SVt_PVCV */
588 sizeof(XPVFM) - MAYBE_OFFSET(XPVFM, xpv_cur), /* SVt_PVFM */
589 sizeof(XPVIO) /* SVt_PVIO */
590 #elif PERL_VERSION < 13
594 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
595 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
596 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
597 sizeof(XPVNV), /* SVt_PVNV */
598 sizeof(XPVMG), /* SVt_PVMG */
599 sizeof(regexp) - MAYBE_OFFSET(regexp, xpv_cur), /* SVt_REGEXP */
600 sizeof(XPVGV), /* SVt_PVGV */
601 sizeof(XPVLV), /* SVt_PVLV */
602 sizeof(XPVAV) - MAYBE_OFFSET(XPVAV, xav_fill), /* SVt_PVAV */
603 sizeof(XPVHV) - MAYBE_OFFSET(XPVHV, xhv_fill), /* SVt_PVHV */
604 sizeof(XPVCV) - MAYBE_OFFSET(XPVCV, xpv_cur), /* SVt_PVCV */
605 sizeof(XPVFM) - MAYBE_OFFSET(XPVFM, xpv_cur), /* SVt_PVFM */
606 sizeof(XPVIO) /* SVt_PVIO */
611 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
612 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
613 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
614 sizeof(XPVNV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVNV */
615 sizeof(XPVMG), /* SVt_PVMG */
616 sizeof(regexp), /* SVt_REGEXP */
617 sizeof(XPVGV), /* SVt_PVGV */
618 sizeof(XPVLV), /* SVt_PVLV */
619 sizeof(XPVAV), /* SVt_PVAV */
620 sizeof(XPVHV), /* SVt_PVHV */
621 sizeof(XPVCV), /* SVt_PVCV */
622 sizeof(XPVFM), /* SVt_PVFM */
623 sizeof(XPVIO) /* SVt_PVIO */
628 sv_size(pTHX_ struct state *const st, const SV * const orig_thing,
630 const SV *thing = orig_thing;
633 if(!check_new(st, thing))
636 type = SvTYPE(thing);
637 if (type > SVt_LAST) {
638 warn("Devel::Size: Unknown variable type: %d encountered\n", type);
641 st->total_size += sizeof(SV) + body_sizes[type];
643 if (type >= SVt_PVMG) {
644 magic_size(aTHX_ thing, st);
648 #if (PERL_VERSION < 11)
649 /* Is it a reference? */
654 if(recurse && SvROK(thing))
655 sv_size(aTHX_ st, SvRV_const(thing), recurse);
659 /* Is there anything in the array? */
660 if (AvMAX(thing) != -1) {
661 /* an array with 10 slots has AvMax() set to 9 - te 2007-04-22 */
662 st->total_size += sizeof(SV *) * (AvMAX(thing) + 1);
663 dbg_printf(("total_size: %li AvMAX: %li av_len: $i\n", st->total_size, AvMAX(thing), av_len((AV*)thing)));
665 if (recurse >= TOTAL_SIZE_RECURSION) {
666 SSize_t i = AvFILLp(thing) + 1;
669 sv_size(aTHX_ st, AvARRAY(thing)[i], recurse);
672 /* Add in the bits on the other side of the beginning */
674 dbg_printf(("total_size %li, sizeof(SV *) %li, AvARRAY(thing) %li, AvALLOC(thing)%li , sizeof(ptr) %li \n",
675 st->total_size, sizeof(SV*), AvARRAY(thing), AvALLOC(thing), sizeof( thing )));
677 /* under Perl 5.8.8 64bit threading, AvARRAY(thing) was a pointer while AvALLOC was 0,
678 resulting in grossly overstated sized for arrays. Technically, this shouldn't happen... */
679 if (AvALLOC(thing) != 0) {
680 st->total_size += (sizeof(SV *) * (AvARRAY(thing) - AvALLOC(thing)));
682 #if (PERL_VERSION < 9)
683 /* Is there something hanging off the arylen element?
684 Post 5.9.something this is stored in magic, so will be found there,
685 and Perl_av_arylen_p() takes a non-const AV*, hence compilers rightly
686 complain about AvARYLEN() passing thing to it. */
687 sv_size(aTHX_ st, AvARYLEN(thing), recurse);
691 /* Now the array of buckets */
692 st->total_size += (sizeof(HE *) * (HvMAX(thing) + 1));
693 /* Now walk the bucket chain */
694 if (HvARRAY(thing)) {
697 for (cur_bucket = 0; cur_bucket <= HvMAX(thing); cur_bucket++) {
698 cur_entry = *(HvARRAY(thing) + cur_bucket);
700 st->total_size += sizeof(HE);
701 if (cur_entry->hent_hek) {
702 /* Hash keys can be shared. Have we seen this before? */
703 if (check_new(st, cur_entry->hent_hek)) {
704 st->total_size += HEK_BASESIZE + cur_entry->hent_hek->hek_len + 2;
707 if (recurse >= TOTAL_SIZE_RECURSION)
708 sv_size(aTHX_ st, HeVAL(cur_entry), recurse);
709 cur_entry = cur_entry->hent_next;
717 sv_size(aTHX_ st, (SV *)CvPADLIST(thing), SOME_RECURSION);
718 sv_size(aTHX_ st, (SV *)CvOUTSIDE(thing), recurse);
720 if (st->go_yell && !st->fm_whine) {
721 carp("Devel::Size: Calculated sizes for FMs are incomplete");
727 sv_size(aTHX_ st, (SV *)CvSTASH(thing), SOME_RECURSION);
728 sv_size(aTHX_ st, (SV *)SvSTASH(thing), SOME_RECURSION);
729 sv_size(aTHX_ st, (SV *)CvGV(thing), SOME_RECURSION);
730 sv_size(aTHX_ st, (SV *)CvPADLIST(thing), SOME_RECURSION);
731 sv_size(aTHX_ st, (SV *)CvOUTSIDE(thing), recurse);
732 if (CvISXSUB(thing)) {
733 sv_size(aTHX_ st, cv_const_sv((CV *)thing), recurse);
735 op_size(aTHX_ CvSTART(thing), st);
736 op_size(aTHX_ CvROOT(thing), st);
741 /* Some embedded char pointers */
742 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_top_name);
743 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_fmt_name);
744 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_bottom_name);
745 /* Throw the GVs on the list to be walked if they're not-null */
746 sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_top_gv, recurse);
747 sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_bottom_gv, recurse);
748 sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_fmt_gv, recurse);
750 /* Only go trotting through the IO structures if they're really
751 trottable. If USE_PERLIO is defined we can do this. If
752 not... we can't, so we don't even try */
754 /* Dig into xio_ifp and xio_ofp here */
755 warn("Devel::Size: Can't size up perlio layers yet\n");
760 #if (PERL_VERSION < 9)
765 if(isGV_with_GP(thing)) {
766 st->total_size += GvNAMELEN(thing);
768 # if !defined(USE_ITHREADS) || (PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 8))
769 /* With itreads, before 5.8.9, this can end up pointing to freed memory
770 if the GV was created in an eval, as GvFILE() points to CopFILE(),
771 and the relevant COP has been freed on scope cleanup after the eval.
772 5.8.9 adds a binary compatible fudge that catches the vast majority
773 of cases. 5.9.something added a proper fix, by converting the GP to
774 use a shared hash key (porperly reference counted), instead of a
775 char * (owned by who knows? possibly no-one now) */
776 check_new_and_strlen(st, GvFILE(thing));
779 /* Is there something hanging off the glob? */
780 if (check_new(st, GvGP(thing))) {
781 st->total_size += sizeof(GP);
782 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_sv), recurse);
783 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_form), recurse);
784 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_av), recurse);
785 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_hv), recurse);
786 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_egv), recurse);
787 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_cv), recurse);
789 #if (PERL_VERSION >= 9)
793 #if PERL_VERSION <= 8
801 if(recurse && SvROK(thing))
802 sv_size(aTHX_ st, SvRV_const(thing), recurse);
804 st->total_size += SvLEN(thing);
808 SvOOK_offset(thing, len);
809 st->total_size += len;
817 static struct state *
823 Newxz(st, 1, struct state);
825 if (NULL != (warn_flag = perl_get_sv("Devel::Size::warn", FALSE))) {
826 st->dangle_whine = st->go_yell = SvIV(warn_flag) ? TRUE : FALSE;
828 if (NULL != (warn_flag = perl_get_sv("Devel::Size::dangle", FALSE))) {
829 st->dangle_whine = SvIV(warn_flag) ? TRUE : FALSE;
831 check_new(st, &PL_sv_undef);
832 check_new(st, &PL_sv_no);
833 check_new(st, &PL_sv_yes);
834 #if PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 0)
835 check_new(st, &PL_sv_placeholder);
840 MODULE = Devel::Size PACKAGE = Devel::Size
848 total_size = TOTAL_SIZE_RECURSION
851 SV *thing = orig_thing;
852 struct state *st = new_state(aTHX);
854 /* If they passed us a reference then dereference it. This is the
855 only way we can check the sizes of arrays and hashes */
860 sv_size(aTHX_ st, thing, ix);
861 RETVAL = st->total_size;