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 );
528 #if PERL_VERSION < 8 || PERL_SUBVERSION < 9
533 # define MAYBE_PURIFY(normal, pure) (pure)
534 # define MAYBE_OFFSET(struct_name, member) 0
536 # define MAYBE_PURIFY(normal, pure) (normal)
537 # define MAYBE_OFFSET(struct_name, member) STRUCT_OFFSET(struct_name, member)
540 const U8 body_sizes[SVt_LAST] = {
543 MAYBE_PURIFY(sizeof(IV), sizeof(XPVIV)), /* SVt_IV */
544 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
545 sizeof(XRV), /* SVt_RV */
546 sizeof(XPV), /* SVt_PV */
547 sizeof(XPVIV), /* SVt_PVIV */
548 sizeof(XPVNV), /* SVt_PVNV */
549 sizeof(XPVMG), /* SVt_PVMG */
550 sizeof(XPVBM), /* SVt_PVBM */
551 sizeof(XPVLV), /* SVt_PVLV */
552 sizeof(XPVAV), /* SVt_PVAV */
553 sizeof(XPVHV), /* SVt_PVHV */
554 sizeof(XPVCV), /* SVt_PVCV */
555 sizeof(XPVGV), /* SVt_PVGV */
556 sizeof(XPVFM), /* SVt_PVFM */
557 sizeof(XPVIO) /* SVt_PVIO */
558 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 0
562 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
564 MAYBE_PURIFY(sizeof(xpv_allocated), sizeof(XPV)), /* SVt_PV */
565 MAYBE_PURIFY(sizeof(xpviv_allocated), sizeof(XPVIV)),/* SVt_PVIV */
566 sizeof(XPVNV), /* SVt_PVNV */
567 sizeof(XPVMG), /* SVt_PVMG */
568 sizeof(XPVGV), /* SVt_PVGV */
569 sizeof(XPVLV), /* SVt_PVLV */
570 MAYBE_PURIFY(sizeof(xpvav_allocated), sizeof(XPVAV)),/* SVt_PVAV */
571 MAYBE_PURIFY(sizeof(xpvhv_allocated), sizeof(XPVHV)),/* SVt_PVHV */
572 MAYBE_PURIFY(sizeof(xpvcv_allocated), sizeof(XPVCV)),/* SVt_PVCV */
573 MAYBE_PURIFY(sizeof(xpvfm_allocated), sizeof(XPVFM)),/* SVt_PVFM */
574 sizeof(XPVIO), /* SVt_PVIO */
575 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 1
579 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
581 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
582 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
583 sizeof(XPVNV), /* SVt_PVNV */
584 sizeof(XPVMG), /* SVt_PVMG */
585 sizeof(XPVGV), /* SVt_PVGV */
586 sizeof(XPVLV), /* SVt_PVLV */
587 sizeof(XPVAV) - MAYBE_OFFSET(XPVAV, xav_fill), /* SVt_PVAV */
588 sizeof(XPVHV) - MAYBE_OFFSET(XPVHV, xhv_fill), /* SVt_PVHV */
589 sizeof(XPVCV) - MAYBE_OFFSET(XPVCV, xpv_cur), /* SVt_PVCV */
590 sizeof(XPVFM) - MAYBE_OFFSET(XPVFM, xpv_cur), /* SVt_PVFM */
591 sizeof(XPVIO) /* SVt_PVIO */
592 #elif PERL_VERSION < 13
596 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
597 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
598 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
599 sizeof(XPVNV), /* SVt_PVNV */
600 sizeof(XPVMG), /* SVt_PVMG */
601 sizeof(regexp) - MAYBE_OFFSET(regexp, xpv_cur), /* SVt_REGEXP */
602 sizeof(XPVGV), /* SVt_PVGV */
603 sizeof(XPVLV), /* SVt_PVLV */
604 sizeof(XPVAV) - MAYBE_OFFSET(XPVAV, xav_fill), /* SVt_PVAV */
605 sizeof(XPVHV) - MAYBE_OFFSET(XPVHV, xhv_fill), /* SVt_PVHV */
606 sizeof(XPVCV) - MAYBE_OFFSET(XPVCV, xpv_cur), /* SVt_PVCV */
607 sizeof(XPVFM) - MAYBE_OFFSET(XPVFM, xpv_cur), /* SVt_PVFM */
608 sizeof(XPVIO) /* SVt_PVIO */
613 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) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVNV */
617 sizeof(XPVMG), /* SVt_PVMG */
618 sizeof(regexp), /* SVt_REGEXP */
619 sizeof(XPVGV), /* SVt_PVGV */
620 sizeof(XPVLV), /* SVt_PVLV */
621 sizeof(XPVAV), /* SVt_PVAV */
622 sizeof(XPVHV), /* SVt_PVHV */
623 sizeof(XPVCV), /* SVt_PVCV */
624 sizeof(XPVFM), /* SVt_PVFM */
625 sizeof(XPVIO) /* SVt_PVIO */
630 sv_size(pTHX_ struct state *const st, const SV * const orig_thing,
632 const SV *thing = orig_thing;
635 if(!check_new(st, thing))
638 type = SvTYPE(thing);
639 if (type > SVt_LAST) {
640 warn("Devel::Size: Unknown variable type: %d encountered\n", type);
643 st->total_size += sizeof(SV) + body_sizes[type];
645 if (type >= SVt_PVMG) {
646 magic_size(aTHX_ thing, st);
650 #if (PERL_VERSION < 11)
651 /* Is it a reference? */
656 if(recurse && SvROK(thing))
657 sv_size(aTHX_ st, SvRV_const(thing), recurse);
661 /* Is there anything in the array? */
662 if (AvMAX(thing) != -1) {
663 /* an array with 10 slots has AvMax() set to 9 - te 2007-04-22 */
664 st->total_size += sizeof(SV *) * (AvMAX(thing) + 1);
665 dbg_printf(("total_size: %li AvMAX: %li av_len: $i\n", st->total_size, AvMAX(thing), av_len((AV*)thing)));
667 if (recurse >= TOTAL_SIZE_RECURSION) {
668 SSize_t i = AvFILLp(thing) + 1;
671 sv_size(aTHX_ st, AvARRAY(thing)[i], recurse);
674 /* Add in the bits on the other side of the beginning */
676 dbg_printf(("total_size %li, sizeof(SV *) %li, AvARRAY(thing) %li, AvALLOC(thing)%li , sizeof(ptr) %li \n",
677 st->total_size, sizeof(SV*), AvARRAY(thing), AvALLOC(thing), sizeof( thing )));
679 /* under Perl 5.8.8 64bit threading, AvARRAY(thing) was a pointer while AvALLOC was 0,
680 resulting in grossly overstated sized for arrays. Technically, this shouldn't happen... */
681 if (AvALLOC(thing) != 0) {
682 st->total_size += (sizeof(SV *) * (AvARRAY(thing) - AvALLOC(thing)));
684 #if (PERL_VERSION < 9)
685 /* Is there something hanging off the arylen element?
686 Post 5.9.something this is stored in magic, so will be found there,
687 and Perl_av_arylen_p() takes a non-const AV*, hence compilers rightly
688 complain about AvARYLEN() passing thing to it. */
689 sv_size(aTHX_ st, AvARYLEN(thing), recurse);
693 /* Now the array of buckets */
694 st->total_size += (sizeof(HE *) * (HvMAX(thing) + 1));
695 /* Now walk the bucket chain */
696 if (HvARRAY(thing)) {
699 for (cur_bucket = 0; cur_bucket <= HvMAX(thing); cur_bucket++) {
700 cur_entry = *(HvARRAY(thing) + cur_bucket);
702 st->total_size += sizeof(HE);
703 if (cur_entry->hent_hek) {
704 /* Hash keys can be shared. Have we seen this before? */
705 if (check_new(st, cur_entry->hent_hek)) {
706 st->total_size += HEK_BASESIZE + cur_entry->hent_hek->hek_len + 2;
709 if (recurse >= TOTAL_SIZE_RECURSION)
710 sv_size(aTHX_ st, HeVAL(cur_entry), recurse);
711 cur_entry = cur_entry->hent_next;
719 sv_size(aTHX_ st, (SV *)CvPADLIST(thing), SOME_RECURSION);
720 sv_size(aTHX_ st, (SV *)CvOUTSIDE(thing), recurse);
722 if (st->go_yell && !st->fm_whine) {
723 carp("Devel::Size: Calculated sizes for FMs are incomplete");
729 sv_size(aTHX_ st, (SV *)CvSTASH(thing), SOME_RECURSION);
730 sv_size(aTHX_ st, (SV *)SvSTASH(thing), SOME_RECURSION);
731 sv_size(aTHX_ st, (SV *)CvGV(thing), SOME_RECURSION);
732 sv_size(aTHX_ st, (SV *)CvPADLIST(thing), SOME_RECURSION);
733 sv_size(aTHX_ st, (SV *)CvOUTSIDE(thing), recurse);
734 if (CvISXSUB(thing)) {
735 sv_size(aTHX_ st, cv_const_sv((CV *)thing), recurse);
737 op_size(aTHX_ CvSTART(thing), st);
738 op_size(aTHX_ CvROOT(thing), st);
743 /* Some embedded char pointers */
744 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_top_name);
745 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_fmt_name);
746 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_bottom_name);
747 /* Throw the GVs on the list to be walked if they're not-null */
748 sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_top_gv, recurse);
749 sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_bottom_gv, recurse);
750 sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_fmt_gv, recurse);
752 /* Only go trotting through the IO structures if they're really
753 trottable. If USE_PERLIO is defined we can do this. If
754 not... we can't, so we don't even try */
756 /* Dig into xio_ifp and xio_ofp here */
757 warn("Devel::Size: Can't size up perlio layers yet\n");
762 #if (PERL_VERSION < 9)
767 if(isGV_with_GP(thing)) {
768 st->total_size += GvNAMELEN(thing);
770 # if !defined(USE_ITHREADS) || (PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 8))
771 /* With itreads, before 5.8.9, this can end up pointing to freed memory
772 if the GV was created in an eval, as GvFILE() points to CopFILE(),
773 and the relevant COP has been freed on scope cleanup after the eval.
774 5.8.9 adds a binary compatible fudge that catches the vast majority
775 of cases. 5.9.something added a proper fix, by converting the GP to
776 use a shared hash key (porperly reference counted), instead of a
777 char * (owned by who knows? possibly no-one now) */
778 check_new_and_strlen(st, GvFILE(thing));
781 /* Is there something hanging off the glob? */
782 if (check_new(st, GvGP(thing))) {
783 st->total_size += sizeof(GP);
784 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_sv), recurse);
785 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_form), recurse);
786 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_av), recurse);
787 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_hv), recurse);
788 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_egv), recurse);
789 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_cv), recurse);
791 #if (PERL_VERSION >= 9)
795 #if PERL_VERSION <= 8
803 if(recurse && SvROK(thing))
804 sv_size(aTHX_ st, SvRV_const(thing), recurse);
806 st->total_size += SvLEN(thing);
810 SvOOK_offset(thing, len);
811 st->total_size += len;
819 static struct state *
825 Newxz(st, 1, struct state);
827 if (NULL != (warn_flag = perl_get_sv("Devel::Size::warn", FALSE))) {
828 st->dangle_whine = st->go_yell = SvIV(warn_flag) ? TRUE : FALSE;
830 if (NULL != (warn_flag = perl_get_sv("Devel::Size::dangle", FALSE))) {
831 st->dangle_whine = SvIV(warn_flag) ? TRUE : FALSE;
833 check_new(st, &PL_sv_undef);
834 check_new(st, &PL_sv_no);
835 check_new(st, &PL_sv_yes);
836 #if PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 0)
837 check_new(st, &PL_sv_placeholder);
842 MODULE = Devel::Size PACKAGE = Devel::Size
850 total_size = TOTAL_SIZE_RECURSION
853 SV *thing = orig_thing;
854 struct state *st = new_state(aTHX);
856 /* If they passed us a reference then dereference it. This is the
857 only way we can check the sizes of arrays and hashes */
862 sv_size(aTHX_ st, thing, ix);
863 RETVAL = st->total_size;