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 /* "structured exception" handling is a Microsoft extension to C and C++.
21 It's *not* C++ exception handling - C++ exception handling can't capture
22 SEGVs and suchlike, whereas this can. There's no known analagous
23 functionality on other platforms. */
25 # define TRY_TO_CATCH_SEGV __try
26 # define CAUGHT_EXCEPTION __except(EXCEPTION EXCEPTION_EXECUTE_HANDLER)
28 # define TRY_TO_CATCH_SEGV if(1)
29 # define CAUGHT_EXCEPTION else
33 # define __attribute__(x)
36 #if 0 && defined(DEBUGGING)
37 #define dbg_printf(x) printf x
42 #define TAG /* printf( "# %s(%d)\n", __FILE__, __LINE__ ) */
45 /* The idea is to have a tree structure to store 1 bit per possible pointer
46 address. The lowest 16 bits are stored in a block of 8092 bytes.
47 The blocks are in a 256-way tree, indexed by the reset of the pointer.
48 This can cope with 32 and 64 bit pointers, and any address space layout,
49 without excessive memory needs. The assumption is that your CPU cache
50 works :-) (And that we're not going to bust it) */
53 #define LEAF_BITS (16 - BYTE_BITS)
54 #define LEAF_MASK 0x1FFF
62 /* My hunch (not measured) is that for most architectures pointers will
63 start with 0 bits, hence the start of this array will be hot, and the
64 end unused. So put the flags next to the hot end. */
69 Checks to see if thing is in the bitstring.
70 Returns true or false, and
71 notes thing in the segmented bitstring.
74 check_new(struct state *st, const void *const p) {
75 unsigned int bits = 8 * sizeof(void*);
76 const size_t raw_p = PTR2nat(p);
77 /* This effectively rotates the value right by the number of low always-0
78 bits in an aligned pointer. The assmption is that most (if not all)
79 pointers are aligned, and these will be in the same chain of nodes
80 (and hence hot in the cache) but we can still deal with any unaligned
83 = (raw_p >> ALIGN_BITS) | (raw_p << (bits - ALIGN_BITS));
84 const U8 this_bit = 1 << (cooked_p & 0x7);
88 void **tv_p = (void **) (st->tracking);
90 if (NULL == p) return FALSE;
92 const char c = *(const char *)p;
96 warn( "Devel::Size: Encountered invalid pointer: %p\n", p );
102 /* bits now 24 (32 bit pointers) or 56 (64 bit pointers) */
104 /* First level is always present. */
106 i = (unsigned int)((cooked_p >> bits) & 0xFF);
108 Newxz(tv_p[i], 256, void *);
109 tv_p = (void **)(tv_p[i]);
111 } while (bits > LEAF_BITS + BYTE_BITS);
112 /* bits now 16 always */
113 #if !defined(MULTIPLICITY) || PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 8)
114 /* 5.8.8 and early have an assert() macro that uses Perl_croak, hence needs
115 a my_perl under multiplicity */
118 leaf_p = (U8 **)tv_p;
119 i = (unsigned int)((cooked_p >> bits) & 0xFF);
121 Newxz(leaf_p[i], 1 << LEAF_BITS, U8);
126 i = (unsigned int)((cooked_p >> BYTE_BITS) & LEAF_MASK);
128 if(leaf[i] & this_bit)
136 free_tracking_at(void **tv, int level)
144 free_tracking_at(tv[i], level);
158 free_state(struct state *st)
160 const int top_level = (sizeof(void *) * 8 - LEAF_BITS - BYTE_BITS) / 8;
161 free_tracking_at((void **)st->tracking, top_level);
165 /* For now, this is somewhat a compatibility bodge until the plan comes
166 together for fine grained recursion control. total_size() would recurse into
167 hash and array members, whereas sv_size() would not. However, sv_size() is
168 called with CvSTASH() of a CV, which means that if it (also) starts to
169 recurse fully, then the size of any CV now becomes the size of the entire
170 symbol table reachable from it, and potentially the entire symbol table, if
171 any subroutine makes a reference to a global (such as %SIG). The historical
172 implementation of total_size() didn't report "everything", and changing the
173 only available size to "everything" doesn't feel at all useful. */
175 #define NO_RECURSION 0
176 #define SOME_RECURSION 1
177 #define TOTAL_SIZE_RECURSION 2
179 static bool sv_size(pTHX_ struct state *, const SV *const, const int recurse);
197 cc_opclass(const OP * const o)
203 return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
205 if (o->op_type == OP_SASSIGN)
206 return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
209 if (o->op_type == OP_GV || o->op_type == OP_GVSV || o->op_type == OP_AELEMFAST)
213 if ((o->op_type == OP_TRANS)) {
217 switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
242 case OA_PVOP_OR_SVOP: TAG;
244 * Character translations (tr///) are usually a PVOP, keeping a
245 * pointer to a table of shorts used to look up translations.
246 * Under utf8, however, a simple table isn't practical; instead,
247 * the OP is an SVOP, and the SV is a reference to a swash
248 * (i.e., an RV pointing to an HV).
250 return (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
251 ? OPc_SVOP : OPc_PVOP;
259 case OA_BASEOP_OR_UNOP: TAG;
261 * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
262 * whether parens were seen. perly.y uses OPf_SPECIAL to
263 * signal whether a BASEOP had empty parens or none.
264 * Some other UNOPs are created later, though, so the best
265 * test is OPf_KIDS, which is set in newUNOP.
267 return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
269 case OA_FILESTATOP: TAG;
271 * The file stat OPs are created via UNI(OP_foo) in toke.c but use
272 * the OPf_REF flag to distinguish between OP types instead of the
273 * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
274 * return OPc_UNOP so that walkoptree can find our children. If
275 * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
276 * (no argument to the operator) it's an OP; with OPf_REF set it's
277 * an SVOP (and op_sv is the GV for the filehandle argument).
279 return ((o->op_flags & OPf_KIDS) ? OPc_UNOP :
281 (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP);
283 (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP);
285 case OA_LOOPEXOP: TAG;
287 * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
288 * label was omitted (in which case it's a BASEOP) or else a term was
289 * seen. In this last case, all except goto are definitely PVOP but
290 * goto is either a PVOP (with an ordinary constant label), an UNOP
291 * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
292 * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
295 if (o->op_flags & OPf_STACKED)
297 else if (o->op_flags & OPf_SPECIAL)
302 warn("Devel::Size: Can't determine class of operator %s, assuming BASEOP\n",
303 PL_op_name[o->op_type]);
309 /* Figure out how much magic is attached to the SV and return the
312 magic_size(pTHX_ const SV * const thing, struct state *st) {
313 MAGIC *magic_pointer = SvMAGIC(thing);
315 /* Have we seen the magic pointer? (NULL has always been seen before) */
316 while (check_new(st, magic_pointer)) {
317 st->total_size += sizeof(MAGIC);
318 /* magic vtables aren't freed when magic is freed, so don't count them.
319 (They are static structures. Anything that assumes otherwise is buggy.)
324 sv_size(aTHX_ st, magic_pointer->mg_obj, TOTAL_SIZE_RECURSION);
325 if (magic_pointer->mg_len == HEf_SVKEY) {
326 sv_size(aTHX_ st, (SV *)magic_pointer->mg_ptr, TOTAL_SIZE_RECURSION);
328 #if defined(PERL_MAGIC_utf8) && defined (PERL_MAGIC_UTF8_CACHESIZE)
329 else if (magic_pointer->mg_type == PERL_MAGIC_utf8) {
330 if (check_new(st, magic_pointer->mg_ptr)) {
331 st->total_size += PERL_MAGIC_UTF8_CACHESIZE * 2 * sizeof(STRLEN);
335 else if (magic_pointer->mg_len > 0) {
336 if (check_new(st, magic_pointer->mg_ptr)) {
337 st->total_size += magic_pointer->mg_len;
341 /* Get the next in the chain */
342 magic_pointer = magic_pointer->mg_moremagic;
345 if (st->dangle_whine)
346 warn( "Devel::Size: Encountered bad magic at: %p\n", magic_pointer );
352 check_new_and_strlen(struct state *st, const char *const p) {
354 st->total_size += 1 + strlen(p);
358 regex_size(const REGEXP * const baseregex, struct state *st) {
359 if(!check_new(st, baseregex))
361 st->total_size += sizeof(REGEXP);
362 #if (PERL_VERSION < 11)
363 /* Note the size of the paren offset thing */
364 st->total_size += sizeof(I32) * baseregex->nparens * 2;
365 st->total_size += strlen(baseregex->precomp);
367 st->total_size += sizeof(struct regexp);
368 st->total_size += sizeof(I32) * SvANY(baseregex)->nparens * 2;
369 /*st->total_size += strlen(SvANY(baseregex)->subbeg);*/
371 if (st->go_yell && !st->regex_whine) {
372 carp("Devel::Size: Calculated sizes for compiled regexes are incompatible, and probably always will be");
378 op_size(pTHX_ const OP * const baseop, struct state *st)
382 if(!check_new(st, baseop))
385 op_size(aTHX_ baseop->op_next, st);
387 switch (cc_opclass(baseop)) {
388 case OPc_BASEOP: TAG;
389 st->total_size += sizeof(struct op);
392 st->total_size += sizeof(struct unop);
393 op_size(aTHX_ ((UNOP *)baseop)->op_first, st);
396 st->total_size += sizeof(struct binop);
397 op_size(aTHX_ ((BINOP *)baseop)->op_first, st);
398 op_size(aTHX_ ((BINOP *)baseop)->op_last, st);
401 st->total_size += sizeof(struct logop);
402 op_size(aTHX_ ((BINOP *)baseop)->op_first, st);
403 op_size(aTHX_ ((LOGOP *)baseop)->op_other, st);
405 case OPc_LISTOP: TAG;
406 st->total_size += sizeof(struct listop);
407 op_size(aTHX_ ((LISTOP *)baseop)->op_first, st);
408 op_size(aTHX_ ((LISTOP *)baseop)->op_last, st);
411 st->total_size += sizeof(struct pmop);
412 op_size(aTHX_ ((PMOP *)baseop)->op_first, st);
413 op_size(aTHX_ ((PMOP *)baseop)->op_last, st);
414 #if PERL_VERSION < 9 || (PERL_VERSION == 9 && PERL_SUBVERSION < 5)
415 op_size(aTHX_ ((PMOP *)baseop)->op_pmreplroot, st);
416 op_size(aTHX_ ((PMOP *)baseop)->op_pmreplstart, st);
418 /* This is defined away in perl 5.8.x, but it is in there for
421 regex_size(PM_GETRE((PMOP *)baseop), st);
423 regex_size(((PMOP *)baseop)->op_pmregexp, st);
427 st->total_size += sizeof(struct pmop);
428 if (!(baseop->op_type == OP_AELEMFAST
429 && baseop->op_flags & OPf_SPECIAL)) {
430 /* not an OP_PADAV replacement */
431 sv_size(aTHX_ st, ((SVOP *)baseop)->op_sv, SOME_RECURSION);
435 st->total_size += sizeof(struct padop);
438 check_new_and_strlen(st, ((PVOP *)baseop)->op_pv);
441 st->total_size += sizeof(struct loop);
442 op_size(aTHX_ ((LOOP *)baseop)->op_first, st);
443 op_size(aTHX_ ((LOOP *)baseop)->op_last, st);
444 op_size(aTHX_ ((LOOP *)baseop)->op_redoop, st);
445 op_size(aTHX_ ((LOOP *)baseop)->op_nextop, st);
446 op_size(aTHX_ ((LOOP *)baseop)->op_lastop, st);
451 basecop = (COP *)baseop;
452 st->total_size += sizeof(struct cop);
454 /* Change 33656 by nicholas@mouse-mill on 2008/04/07 11:29:51
455 Eliminate cop_label from struct cop by storing a label as the first
456 entry in the hints hash. Most statements don't have labels, so this
457 will save memory. Not sure how much.
458 The check below will be incorrect fail on bleadperls
459 before 5.11 @33656, but later than 5.10, producing slightly too
460 small memory sizes on these Perls. */
461 #if (PERL_VERSION < 11)
462 check_new_and_strlen(st, basecop->cop_label);
465 check_new_and_strlen(st, basecop->cop_file);
466 check_new_and_strlen(st, basecop->cop_stashpv);
468 sv_size(aTHX_ st, (SV *)basecop->cop_stash, SOME_RECURSION);
469 sv_size(aTHX_ st, (SV *)basecop->cop_filegv, SOME_RECURSION);
479 if (st->dangle_whine)
480 warn( "Devel::Size: Encountered dangling pointer in opcode at: %p\n", baseop );
484 #if PERL_VERSION < 8 || PERL_SUBVERSION < 9
489 # define MAYBE_PURIFY(normal, pure) (pure)
490 # define MAYBE_OFFSET(struct_name, member) 0
492 # define MAYBE_PURIFY(normal, pure) (normal)
493 # define MAYBE_OFFSET(struct_name, member) STRUCT_OFFSET(struct_name, member)
496 const U8 body_sizes[SVt_LAST] = {
499 MAYBE_PURIFY(sizeof(IV), sizeof(XPVIV)), /* SVt_IV */
500 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
501 sizeof(XRV), /* SVt_RV */
502 sizeof(XPV), /* SVt_PV */
503 sizeof(XPVIV), /* SVt_PVIV */
504 sizeof(XPVNV), /* SVt_PVNV */
505 sizeof(XPVMG), /* SVt_PVMG */
506 sizeof(XPVBM), /* SVt_PVBM */
507 sizeof(XPVLV), /* SVt_PVLV */
508 sizeof(XPVAV), /* SVt_PVAV */
509 sizeof(XPVHV), /* SVt_PVHV */
510 sizeof(XPVCV), /* SVt_PVCV */
511 sizeof(XPVGV), /* SVt_PVGV */
512 sizeof(XPVFM), /* SVt_PVFM */
513 sizeof(XPVIO) /* SVt_PVIO */
514 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 0
518 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
520 MAYBE_PURIFY(sizeof(xpv_allocated), sizeof(XPV)), /* SVt_PV */
521 MAYBE_PURIFY(sizeof(xpviv_allocated), sizeof(XPVIV)),/* SVt_PVIV */
522 sizeof(XPVNV), /* SVt_PVNV */
523 sizeof(XPVMG), /* SVt_PVMG */
524 sizeof(XPVGV), /* SVt_PVGV */
525 sizeof(XPVLV), /* SVt_PVLV */
526 MAYBE_PURIFY(sizeof(xpvav_allocated), sizeof(XPVAV)),/* SVt_PVAV */
527 MAYBE_PURIFY(sizeof(xpvhv_allocated), sizeof(XPVHV)),/* SVt_PVHV */
528 MAYBE_PURIFY(sizeof(xpvcv_allocated), sizeof(XPVCV)),/* SVt_PVCV */
529 MAYBE_PURIFY(sizeof(xpvfm_allocated), sizeof(XPVFM)),/* SVt_PVFM */
530 sizeof(XPVIO), /* SVt_PVIO */
531 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 1
535 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
537 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
538 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
539 sizeof(XPVNV), /* SVt_PVNV */
540 sizeof(XPVMG), /* SVt_PVMG */
541 sizeof(XPVGV), /* SVt_PVGV */
542 sizeof(XPVLV), /* SVt_PVLV */
543 sizeof(XPVAV) - MAYBE_OFFSET(XPVAV, xav_fill), /* SVt_PVAV */
544 sizeof(XPVHV) - MAYBE_OFFSET(XPVHV, xhv_fill), /* SVt_PVHV */
545 sizeof(XPVCV) - MAYBE_OFFSET(XPVCV, xpv_cur), /* SVt_PVCV */
546 sizeof(XPVFM) - MAYBE_OFFSET(XPVFM, xpv_cur), /* SVt_PVFM */
547 sizeof(XPVIO) /* SVt_PVIO */
548 #elif PERL_VERSION < 13
552 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
553 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
554 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
555 sizeof(XPVNV), /* SVt_PVNV */
556 sizeof(XPVMG), /* SVt_PVMG */
557 sizeof(regexp) - MAYBE_OFFSET(regexp, xpv_cur), /* SVt_REGEXP */
558 sizeof(XPVGV), /* SVt_PVGV */
559 sizeof(XPVLV), /* SVt_PVLV */
560 sizeof(XPVAV) - MAYBE_OFFSET(XPVAV, xav_fill), /* SVt_PVAV */
561 sizeof(XPVHV) - MAYBE_OFFSET(XPVHV, xhv_fill), /* SVt_PVHV */
562 sizeof(XPVCV) - MAYBE_OFFSET(XPVCV, xpv_cur), /* SVt_PVCV */
563 sizeof(XPVFM) - MAYBE_OFFSET(XPVFM, xpv_cur), /* SVt_PVFM */
564 sizeof(XPVIO) /* SVt_PVIO */
569 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
570 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
571 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
572 sizeof(XPVNV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVNV */
573 sizeof(XPVMG), /* SVt_PVMG */
574 sizeof(regexp), /* SVt_REGEXP */
575 sizeof(XPVGV), /* SVt_PVGV */
576 sizeof(XPVLV), /* SVt_PVLV */
577 sizeof(XPVAV), /* SVt_PVAV */
578 sizeof(XPVHV), /* SVt_PVHV */
579 sizeof(XPVCV), /* SVt_PVCV */
580 sizeof(XPVFM), /* SVt_PVFM */
581 sizeof(XPVIO) /* SVt_PVIO */
586 sv_size(pTHX_ struct state *const st, const SV * const orig_thing,
588 const SV *thing = orig_thing;
591 if(!check_new(st, thing))
594 type = SvTYPE(thing);
595 if (type > SVt_LAST) {
596 warn("Devel::Size: Unknown variable type: %d encountered\n", type);
599 st->total_size += sizeof(SV) + body_sizes[type];
601 if (type >= SVt_PVMG) {
602 magic_size(aTHX_ thing, st);
606 #if (PERL_VERSION < 11)
607 /* Is it a reference? */
612 if(recurse && SvROK(thing))
613 sv_size(aTHX_ st, SvRV_const(thing), recurse);
617 /* Is there anything in the array? */
618 if (AvMAX(thing) != -1) {
619 /* an array with 10 slots has AvMax() set to 9 - te 2007-04-22 */
620 st->total_size += sizeof(SV *) * (AvMAX(thing) + 1);
621 dbg_printf(("total_size: %li AvMAX: %li av_len: $i\n", st->total_size, AvMAX(thing), av_len((AV*)thing)));
623 if (recurse >= TOTAL_SIZE_RECURSION) {
624 SSize_t i = AvFILLp(thing) + 1;
627 sv_size(aTHX_ st, AvARRAY(thing)[i], recurse);
630 /* Add in the bits on the other side of the beginning */
632 dbg_printf(("total_size %li, sizeof(SV *) %li, AvARRAY(thing) %li, AvALLOC(thing)%li , sizeof(ptr) %li \n",
633 st->total_size, sizeof(SV*), AvARRAY(thing), AvALLOC(thing), sizeof( thing )));
635 /* under Perl 5.8.8 64bit threading, AvARRAY(thing) was a pointer while AvALLOC was 0,
636 resulting in grossly overstated sized for arrays. Technically, this shouldn't happen... */
637 if (AvALLOC(thing) != 0) {
638 st->total_size += (sizeof(SV *) * (AvARRAY(thing) - AvALLOC(thing)));
640 #if (PERL_VERSION < 9)
641 /* Is there something hanging off the arylen element?
642 Post 5.9.something this is stored in magic, so will be found there,
643 and Perl_av_arylen_p() takes a non-const AV*, hence compilers rightly
644 complain about AvARYLEN() passing thing to it. */
645 sv_size(aTHX_ st, AvARYLEN(thing), recurse);
649 /* Now the array of buckets */
650 st->total_size += (sizeof(HE *) * (HvMAX(thing) + 1));
651 /* Now walk the bucket chain */
652 if (HvARRAY(thing)) {
655 for (cur_bucket = 0; cur_bucket <= HvMAX(thing); cur_bucket++) {
656 cur_entry = *(HvARRAY(thing) + cur_bucket);
658 st->total_size += sizeof(HE);
659 if (cur_entry->hent_hek) {
660 /* Hash keys can be shared. Have we seen this before? */
661 if (check_new(st, cur_entry->hent_hek)) {
662 st->total_size += HEK_BASESIZE + cur_entry->hent_hek->hek_len + 2;
665 if (recurse >= TOTAL_SIZE_RECURSION)
666 sv_size(aTHX_ st, HeVAL(cur_entry), recurse);
667 cur_entry = cur_entry->hent_next;
675 sv_size(aTHX_ st, (SV *)CvPADLIST(thing), SOME_RECURSION);
676 sv_size(aTHX_ st, (SV *)CvOUTSIDE(thing), recurse);
678 if (st->go_yell && !st->fm_whine) {
679 carp("Devel::Size: Calculated sizes for FMs are incomplete");
685 sv_size(aTHX_ st, (SV *)CvSTASH(thing), SOME_RECURSION);
686 sv_size(aTHX_ st, (SV *)SvSTASH(thing), SOME_RECURSION);
687 sv_size(aTHX_ st, (SV *)CvGV(thing), SOME_RECURSION);
688 sv_size(aTHX_ st, (SV *)CvPADLIST(thing), SOME_RECURSION);
689 sv_size(aTHX_ st, (SV *)CvOUTSIDE(thing), recurse);
690 if (CvISXSUB(thing)) {
691 sv_size(aTHX_ st, cv_const_sv((CV *)thing), recurse);
693 op_size(aTHX_ CvSTART(thing), st);
694 op_size(aTHX_ CvROOT(thing), st);
699 /* Some embedded char pointers */
700 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_top_name);
701 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_fmt_name);
702 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_bottom_name);
703 /* Throw the GVs on the list to be walked if they're not-null */
704 sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_top_gv, recurse);
705 sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_bottom_gv, recurse);
706 sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_fmt_gv, recurse);
708 /* Only go trotting through the IO structures if they're really
709 trottable. If USE_PERLIO is defined we can do this. If
710 not... we can't, so we don't even try */
712 /* Dig into xio_ifp and xio_ofp here */
713 warn("Devel::Size: Can't size up perlio layers yet\n");
718 #if (PERL_VERSION < 9)
723 if(isGV_with_GP(thing)) {
724 st->total_size += GvNAMELEN(thing);
726 # if !defined(USE_ITHREADS) || (PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 8))
727 /* With itreads, before 5.8.9, this can end up pointing to freed memory
728 if the GV was created in an eval, as GvFILE() points to CopFILE(),
729 and the relevant COP has been freed on scope cleanup after the eval.
730 5.8.9 adds a binary compatible fudge that catches the vast majority
731 of cases. 5.9.something added a proper fix, by converting the GP to
732 use a shared hash key (porperly reference counted), instead of a
733 char * (owned by who knows? possibly no-one now) */
734 check_new_and_strlen(st, GvFILE(thing));
737 /* Is there something hanging off the glob? */
738 if (check_new(st, GvGP(thing))) {
739 st->total_size += sizeof(GP);
740 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_sv), recurse);
741 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_form), recurse);
742 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_av), recurse);
743 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_hv), recurse);
744 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_egv), recurse);
745 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_cv), recurse);
747 #if (PERL_VERSION >= 9)
751 #if PERL_VERSION <= 8
759 if(recurse && SvROK(thing))
760 sv_size(aTHX_ st, SvRV_const(thing), recurse);
762 st->total_size += SvLEN(thing);
766 SvOOK_offset(thing, len);
767 st->total_size += len;
775 static struct state *
781 Newxz(st, 1, struct state);
783 if (NULL != (warn_flag = perl_get_sv("Devel::Size::warn", FALSE))) {
784 st->dangle_whine = st->go_yell = SvIV(warn_flag) ? TRUE : FALSE;
786 if (NULL != (warn_flag = perl_get_sv("Devel::Size::dangle", FALSE))) {
787 st->dangle_whine = SvIV(warn_flag) ? TRUE : FALSE;
789 check_new(st, &PL_sv_undef);
790 check_new(st, &PL_sv_no);
791 check_new(st, &PL_sv_yes);
795 MODULE = Devel::Size PACKAGE = Devel::Size
803 total_size = TOTAL_SIZE_RECURSION
806 SV *thing = orig_thing;
807 struct state *st = new_state(aTHX);
809 /* If they passed us a reference then dereference it. This is the
810 only way we can check the sizes of arrays and hashes */
815 sv_size(aTHX_ st, thing, ix);
816 RETVAL = st->total_size;