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)
17 /* "structured exception" handling is a Microsoft extension to C and C++.
18 It's *not* C++ exception handling - C++ exception handling can't capture
19 SEGVs and suchlike, whereas this can. There's no known analagous
20 functionality on other platforms. */
22 # define TRY_TO_CATCH_SEGV __try
23 # define CAUGHT_EXCEPTION __except(EXCEPTION EXCEPTION_EXECUTE_HANDLER)
25 # define TRY_TO_CATCH_SEGV if(1)
26 # define CAUGHT_EXCEPTION else
30 # define __attribute__(x)
33 #if 0 && defined(DEBUGGING)
34 #define dbg_printf(x) printf x
39 #define TAG /* printf( "# %s(%d)\n", __FILE__, __LINE__ ) */
42 /* The idea is to have a tree structure to store 1 bit per possible pointer
43 address. The lowest 16 bits are stored in a block of 8092 bytes.
44 The blocks are in a 256-way tree, indexed by the reset of the pointer.
45 This can cope with 32 and 64 bit pointers, and any address space layout,
46 without excessive memory needs. The assumption is that your CPU cache
47 works :-) (And that we're not going to bust it) */
50 #define LEAF_BITS (16 - BYTE_BITS)
51 #define LEAF_MASK 0x1FFF
59 /* My hunch (not measured) is that for most architectures pointers will
60 start with 0 bits, hence the start of this array will be hot, and the
61 end unused. So put the flags next to the hot end. */
66 Checks to see if thing is in the bitstring.
67 Returns true or false, and
68 notes thing in the segmented bitstring.
71 check_new(struct state *st, const void *const p) {
72 unsigned int bits = 8 * sizeof(void*);
73 const size_t raw_p = PTR2nat(p);
74 /* This effectively rotates the value right by the number of low always-0
75 bits in an aligned pointer. The assmption is that most (if not all)
76 pointers are aligned, and these will be in the same chain of nodes
77 (and hence hot in the cache) but we can still deal with any unaligned
80 = (raw_p >> ALIGN_BITS) | (raw_p << (bits - ALIGN_BITS));
81 const U8 this_bit = 1 << (cooked_p & 0x7);
85 void **tv_p = (void **) (st->tracking);
87 if (NULL == p) return FALSE;
89 const char c = *(const char *)p;
93 warn( "Devel::Size: Encountered invalid pointer: %p\n", p );
99 /* bits now 24 (32 bit pointers) or 56 (64 bit pointers) */
101 /* First level is always present. */
103 i = (unsigned int)((cooked_p >> bits) & 0xFF);
105 Newxz(tv_p[i], 256, void *);
106 tv_p = (void **)(tv_p[i]);
108 } while (bits > LEAF_BITS + BYTE_BITS);
109 /* bits now 16 always */
110 #if !defined(MULTIPLICITY) || PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 8)
111 /* 5.8.8 and early have an assert() macro that uses Perl_croak, hence needs
112 a my_perl under multiplicity */
115 leaf_p = (U8 **)tv_p;
116 i = (unsigned int)((cooked_p >> bits) & 0xFF);
118 Newxz(leaf_p[i], 1 << LEAF_BITS, U8);
123 i = (unsigned int)((cooked_p >> BYTE_BITS) & LEAF_MASK);
125 if(leaf[i] & this_bit)
133 free_tracking_at(void **tv, int level)
141 free_tracking_at(tv[i], level);
155 free_state(struct state *st)
157 const int top_level = (sizeof(void *) * 8 - LEAF_BITS - BYTE_BITS) / 8;
158 free_tracking_at((void **)st->tracking, top_level);
162 /* For now, this is somewhat a compatibility bodge until the plan comes
163 together for fine grained recursion control. total_size() would recurse into
164 hash and array members, whereas sv_size() would not. However, sv_size() is
165 called with CvSTASH() of a CV, which means that if it (also) starts to
166 recurse fully, then the size of any CV now becomes the size of the entire
167 symbol table reachable from it, and potentially the entire symbol table, if
168 any subroutine makes a reference to a global (such as %SIG). The historical
169 implementation of total_size() didn't report "everything", and changing the
170 only available size to "everything" doesn't feel at all useful. */
172 #define NO_RECURSION 0
173 #define SOME_RECURSION 1
174 #define TOTAL_SIZE_RECURSION 2
176 static bool sv_size(pTHX_ struct state *, const SV *const, const int recurse);
194 cc_opclass(const OP * const o)
200 return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
202 if (o->op_type == OP_SASSIGN)
203 return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
206 if (o->op_type == OP_GV || o->op_type == OP_GVSV || o->op_type == OP_AELEMFAST)
210 if ((o->op_type == OP_TRANS)) {
214 switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
239 case OA_PVOP_OR_SVOP: TAG;
241 * Character translations (tr///) are usually a PVOP, keeping a
242 * pointer to a table of shorts used to look up translations.
243 * Under utf8, however, a simple table isn't practical; instead,
244 * the OP is an SVOP, and the SV is a reference to a swash
245 * (i.e., an RV pointing to an HV).
247 return (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
248 ? OPc_SVOP : OPc_PVOP;
256 case OA_BASEOP_OR_UNOP: TAG;
258 * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
259 * whether parens were seen. perly.y uses OPf_SPECIAL to
260 * signal whether a BASEOP had empty parens or none.
261 * Some other UNOPs are created later, though, so the best
262 * test is OPf_KIDS, which is set in newUNOP.
264 return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
266 case OA_FILESTATOP: TAG;
268 * The file stat OPs are created via UNI(OP_foo) in toke.c but use
269 * the OPf_REF flag to distinguish between OP types instead of the
270 * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
271 * return OPc_UNOP so that walkoptree can find our children. If
272 * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
273 * (no argument to the operator) it's an OP; with OPf_REF set it's
274 * an SVOP (and op_sv is the GV for the filehandle argument).
276 return ((o->op_flags & OPf_KIDS) ? OPc_UNOP :
278 (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP);
280 (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP);
282 case OA_LOOPEXOP: TAG;
284 * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
285 * label was omitted (in which case it's a BASEOP) or else a term was
286 * seen. In this last case, all except goto are definitely PVOP but
287 * goto is either a PVOP (with an ordinary constant label), an UNOP
288 * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
289 * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
292 if (o->op_flags & OPf_STACKED)
294 else if (o->op_flags & OPf_SPECIAL)
299 warn("Devel::Size: Can't determine class of operator %s, assuming BASEOP\n",
300 PL_op_name[o->op_type]);
306 /* Figure out how much magic is attached to the SV and return the
309 magic_size(pTHX_ const SV * const thing, struct state *st) {
310 MAGIC *magic_pointer = SvMAGIC(thing);
312 /* Have we seen the magic pointer? (NULL has always been seen before) */
313 while (check_new(st, magic_pointer)) {
314 st->total_size += sizeof(MAGIC);
317 /* Have we seen the magic vtable? */
318 if (check_new(st, magic_pointer->mg_virtual)) {
319 st->total_size += sizeof(MGVTBL);
321 sv_size(aTHX_ st, magic_pointer->mg_obj, TOTAL_SIZE_RECURSION);
322 if (magic_pointer->mg_len == HEf_SVKEY) {
323 sv_size(aTHX_ st, (SV *)magic_pointer->mg_ptr, TOTAL_SIZE_RECURSION);
325 #if defined(PERL_MAGIC_utf8) && defined (PERL_MAGIC_UTF8_CACHESIZE)
326 else if (magic_pointer->mg_type == PERL_MAGIC_utf8) {
327 if (check_new(st, magic_pointer->mg_ptr)) {
328 st->total_size += PERL_MAGIC_UTF8_CACHESIZE * 2 * sizeof(STRLEN);
332 else if (magic_pointer->mg_len > 0) {
333 if (check_new(st, magic_pointer->mg_ptr)) {
334 st->total_size += magic_pointer->mg_len;
338 /* Get the next in the chain */
339 magic_pointer = magic_pointer->mg_moremagic;
342 if (st->dangle_whine)
343 warn( "Devel::Size: Encountered bad magic at: %p\n", magic_pointer );
349 check_new_and_strlen(struct state *st, const char *const p) {
351 st->total_size += 1 + strlen(p);
355 regex_size(const REGEXP * const baseregex, struct state *st) {
356 if(!check_new(st, baseregex))
358 st->total_size += sizeof(REGEXP);
359 #if (PERL_VERSION < 11)
360 /* Note the size of the paren offset thing */
361 st->total_size += sizeof(I32) * baseregex->nparens * 2;
362 st->total_size += strlen(baseregex->precomp);
364 st->total_size += sizeof(struct regexp);
365 st->total_size += sizeof(I32) * SvANY(baseregex)->nparens * 2;
366 /*st->total_size += strlen(SvANY(baseregex)->subbeg);*/
368 if (st->go_yell && !st->regex_whine) {
369 carp("Devel::Size: Calculated sizes for compiled regexes are incompatible, and probably always will be");
375 op_size(pTHX_ const OP * const baseop, struct state *st)
379 if(!check_new(st, baseop))
382 op_size(aTHX_ baseop->op_next, st);
384 switch (cc_opclass(baseop)) {
385 case OPc_BASEOP: TAG;
386 st->total_size += sizeof(struct op);
389 st->total_size += sizeof(struct unop);
390 op_size(aTHX_ cUNOPx(baseop)->op_first, st);
393 st->total_size += sizeof(struct binop);
394 op_size(aTHX_ cBINOPx(baseop)->op_first, st);
395 op_size(aTHX_ cBINOPx(baseop)->op_last, st);
398 st->total_size += sizeof(struct logop);
399 op_size(aTHX_ cBINOPx(baseop)->op_first, st);
400 op_size(aTHX_ cLOGOPx(baseop)->op_other, st);
402 case OPc_LISTOP: TAG;
403 st->total_size += sizeof(struct listop);
404 op_size(aTHX_ cLISTOPx(baseop)->op_first, st);
405 op_size(aTHX_ cLISTOPx(baseop)->op_last, st);
408 st->total_size += sizeof(struct pmop);
409 op_size(aTHX_ cPMOPx(baseop)->op_first, st);
410 op_size(aTHX_ cPMOPx(baseop)->op_last, st);
411 #if PERL_VERSION < 9 || (PERL_VERSION == 9 && PERL_SUBVERSION < 5)
412 op_size(aTHX_ cPMOPx(baseop)->op_pmreplroot, st);
413 op_size(aTHX_ cPMOPx(baseop)->op_pmreplstart, st);
414 op_size(aTHX_ (OP *)cPMOPx(baseop)->op_pmnext, st);
416 /* This is defined away in perl 5.8.x, but it is in there for
419 regex_size(PM_GETRE(cPMOPx(baseop)), st);
421 regex_size(cPMOPx(baseop)->op_pmregexp, st);
425 st->total_size += sizeof(struct pmop);
426 if (!(baseop->op_type == OP_AELEMFAST
427 && baseop->op_flags & OPf_SPECIAL)) {
428 /* not an OP_PADAV replacement */
429 sv_size(aTHX_ st, cSVOPx(baseop)->op_sv, SOME_RECURSION);
433 st->total_size += sizeof(struct padop);
436 check_new_and_strlen(st, cPVOPx(baseop)->op_pv);
439 st->total_size += sizeof(struct loop);
440 op_size(aTHX_ cLOOPx(baseop)->op_first, st);
441 op_size(aTHX_ cLOOPx(baseop)->op_last, st);
442 op_size(aTHX_ cLOOPx(baseop)->op_redoop, st);
443 op_size(aTHX_ cLOOPx(baseop)->op_nextop, st);
444 op_size(aTHX_ cLOOPx(baseop)->op_lastop, st);
449 basecop = (COP *)baseop;
450 st->total_size += sizeof(struct cop);
452 /* Change 33656 by nicholas@mouse-mill on 2008/04/07 11:29:51
453 Eliminate cop_label from struct cop by storing a label as the first
454 entry in the hints hash. Most statements don't have labels, so this
455 will save memory. Not sure how much.
456 The check below will be incorrect fail on bleadperls
457 before 5.11 @33656, but later than 5.10, producing slightly too
458 small memory sizes on these Perls. */
459 #if (PERL_VERSION < 11)
460 check_new_and_strlen(st, basecop->cop_label);
463 check_new_and_strlen(st, basecop->cop_file);
464 check_new_and_strlen(st, basecop->cop_stashpv);
466 sv_size(aTHX_ st, (SV *)basecop->cop_stash, SOME_RECURSION);
467 sv_size(aTHX_ st, (SV *)basecop->cop_filegv, SOME_RECURSION);
477 if (st->dangle_whine)
478 warn( "Devel::Size: Encountered dangling pointer in opcode at: %p\n", baseop );
482 #if PERL_VERSION < 8 || PERL_SUBVERSION < 9
487 # define MAYBE_PURIFY(normal, pure) (pure)
488 # define MAYBE_OFFSET(struct_name, member) 0
490 # define MAYBE_PURIFY(normal, pure) (normal)
491 # define MAYBE_OFFSET(struct_name, member) STRUCT_OFFSET(struct_name, member)
494 const U8 body_sizes[SVt_LAST] = {
497 MAYBE_PURIFY(sizeof(IV), sizeof(XPVIV)), /* SVt_IV */
498 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
499 sizeof(XRV), /* SVt_RV */
500 sizeof(XPV), /* SVt_PV */
501 sizeof(XPVIV), /* SVt_PVIV */
502 sizeof(XPVNV), /* SVt_PVNV */
503 sizeof(XPVMG), /* SVt_PVMG */
504 sizeof(XPVBM), /* SVt_PVBM */
505 sizeof(XPVLV), /* SVt_PVLV */
506 sizeof(XPVAV), /* SVt_PVAV */
507 sizeof(XPVHV), /* SVt_PVHV */
508 sizeof(XPVCV), /* SVt_PVCV */
509 sizeof(XPVGV), /* SVt_PVGV */
510 sizeof(XPVFM), /* SVt_PVFM */
511 sizeof(XPVIO) /* SVt_PVIO */
512 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 0
516 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
518 MAYBE_PURIFY(sizeof(xpv_allocated), sizeof(XPV)), /* SVt_PV */
519 MAYBE_PURIFY(sizeof(xpviv_allocated), sizeof(XPVIV)),/* SVt_PVIV */
520 sizeof(XPVNV), /* SVt_PVNV */
521 sizeof(XPVMG), /* SVt_PVMG */
522 sizeof(XPVGV), /* SVt_PVGV */
523 sizeof(XPVLV), /* SVt_PVLV */
524 MAYBE_PURIFY(sizeof(xpvav_allocated), sizeof(XPVAV)),/* SVt_PVAV */
525 MAYBE_PURIFY(sizeof(xpvhv_allocated), sizeof(XPVHV)),/* SVt_PVHV */
526 MAYBE_PURIFY(sizeof(xpvcv_allocated), sizeof(XPVCV)),/* SVt_PVCV */
527 MAYBE_PURIFY(sizeof(xpvfm_allocated), sizeof(XPVFM)),/* SVt_PVFM */
528 sizeof(XPVIO), /* SVt_PVIO */
529 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 1
533 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
535 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
536 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
537 sizeof(XPVNV), /* SVt_PVNV */
538 sizeof(XPVMG), /* SVt_PVMG */
539 sizeof(XPVGV), /* SVt_PVGV */
540 sizeof(XPVLV), /* SVt_PVLV */
541 sizeof(XPVAV) - MAYBE_OFFSET(XPVAV, xav_fill), /* SVt_PVAV */
542 sizeof(XPVHV) - MAYBE_OFFSET(XPVHV, xhv_fill), /* SVt_PVHV */
543 sizeof(XPVCV) - MAYBE_OFFSET(XPVCV, xpv_cur), /* SVt_PVCV */
544 sizeof(XPVFM) - MAYBE_OFFSET(XPVFM, xpv_cur), /* SVt_PVFM */
545 sizeof(XPVIO) /* SVt_PVIO */
546 #elif PERL_VERSION < 13
550 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
551 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
552 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
553 sizeof(XPVNV), /* SVt_PVNV */
554 sizeof(XPVMG), /* SVt_PVMG */
555 sizeof(regexp) - MAYBE_OFFSET(regexp, xpv_cur), /* SVt_REGEXP */
556 sizeof(XPVGV), /* SVt_PVGV */
557 sizeof(XPVLV), /* SVt_PVLV */
558 sizeof(XPVAV) - MAYBE_OFFSET(XPVAV, xav_fill), /* SVt_PVAV */
559 sizeof(XPVHV) - MAYBE_OFFSET(XPVHV, xhv_fill), /* SVt_PVHV */
560 sizeof(XPVCV) - MAYBE_OFFSET(XPVCV, xpv_cur), /* SVt_PVCV */
561 sizeof(XPVFM) - MAYBE_OFFSET(XPVFM, xpv_cur), /* SVt_PVFM */
562 sizeof(XPVIO) /* SVt_PVIO */
567 MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)), /* SVt_NV */
568 sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PV */
569 sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVIV */
570 sizeof(XPVNV) - MAYBE_OFFSET(XPV, xpv_cur), /* SVt_PVNV */
571 sizeof(XPVMG), /* SVt_PVMG */
572 sizeof(regexp), /* SVt_REGEXP */
573 sizeof(XPVGV), /* SVt_PVGV */
574 sizeof(XPVLV), /* SVt_PVLV */
575 sizeof(XPVAV), /* SVt_PVAV */
576 sizeof(XPVHV), /* SVt_PVHV */
577 sizeof(XPVCV), /* SVt_PVCV */
578 sizeof(XPVFM), /* SVt_PVFM */
579 sizeof(XPVIO) /* SVt_PVIO */
584 sv_size(pTHX_ struct state *const st, const SV * const orig_thing,
586 const SV *thing = orig_thing;
589 if(!check_new(st, thing))
592 type = SvTYPE(thing);
593 if (type > SVt_LAST) {
594 warn("Devel::Size: Unknown variable type: %d encountered\n", type);
597 st->total_size += sizeof(SV) + body_sizes[type];
599 if (type >= SVt_PVMG) {
600 magic_size(aTHX_ thing, st);
604 #if (PERL_VERSION < 11)
605 /* Is it a reference? */
610 if(recurse && SvROK(thing))
611 sv_size(aTHX_ st, SvRV_const(thing), recurse);
615 /* Is there anything in the array? */
616 if (AvMAX(thing) != -1) {
617 /* an array with 10 slots has AvMax() set to 9 - te 2007-04-22 */
618 st->total_size += sizeof(SV *) * (AvMAX(thing) + 1);
619 dbg_printf(("total_size: %li AvMAX: %li av_len: $i\n", st->total_size, AvMAX(thing), av_len((AV*)thing)));
621 if (recurse >= TOTAL_SIZE_RECURSION) {
622 SSize_t i = AvFILLp(thing) + 1;
625 sv_size(aTHX_ st, AvARRAY(thing)[i], recurse);
628 /* Add in the bits on the other side of the beginning */
630 dbg_printf(("total_size %li, sizeof(SV *) %li, AvARRAY(thing) %li, AvALLOC(thing)%li , sizeof(ptr) %li \n",
631 st->total_size, sizeof(SV*), AvARRAY(thing), AvALLOC(thing), sizeof( thing )));
633 /* under Perl 5.8.8 64bit threading, AvARRAY(thing) was a pointer while AvALLOC was 0,
634 resulting in grossly overstated sized for arrays. Technically, this shouldn't happen... */
635 if (AvALLOC(thing) != 0) {
636 st->total_size += (sizeof(SV *) * (AvARRAY(thing) - AvALLOC(thing)));
638 #if (PERL_VERSION < 9)
639 /* Is there something hanging off the arylen element?
640 Post 5.9.something this is stored in magic, so will be found there,
641 and Perl_av_arylen_p() takes a non-const AV*, hence compilers rightly
642 complain about AvARYLEN() passing thing to it. */
643 sv_size(aTHX_ st, AvARYLEN(thing), recurse);
647 /* Now the array of buckets */
648 st->total_size += (sizeof(HE *) * (HvMAX(thing) + 1));
649 /* Now walk the bucket chain */
650 if (HvARRAY(thing)) {
653 for (cur_bucket = 0; cur_bucket <= HvMAX(thing); cur_bucket++) {
654 cur_entry = *(HvARRAY(thing) + cur_bucket);
656 st->total_size += sizeof(HE);
657 if (cur_entry->hent_hek) {
658 /* Hash keys can be shared. Have we seen this before? */
659 if (check_new(st, cur_entry->hent_hek)) {
660 st->total_size += HEK_BASESIZE + cur_entry->hent_hek->hek_len + 2;
663 if (recurse >= TOTAL_SIZE_RECURSION)
664 sv_size(aTHX_ st, HeVAL(cur_entry), recurse);
665 cur_entry = cur_entry->hent_next;
673 sv_size(aTHX_ st, (SV *)CvPADLIST(thing), SOME_RECURSION);
674 sv_size(aTHX_ st, (SV *)CvOUTSIDE(thing), recurse);
676 if (st->go_yell && !st->fm_whine) {
677 carp("Devel::Size: Calculated sizes for FMs are incomplete");
683 sv_size(aTHX_ st, (SV *)CvSTASH(thing), SOME_RECURSION);
684 sv_size(aTHX_ st, (SV *)SvSTASH(thing), SOME_RECURSION);
685 sv_size(aTHX_ st, (SV *)CvGV(thing), SOME_RECURSION);
686 sv_size(aTHX_ st, (SV *)CvPADLIST(thing), SOME_RECURSION);
687 sv_size(aTHX_ st, (SV *)CvOUTSIDE(thing), recurse);
688 if (CvISXSUB(thing)) {
689 sv_size(aTHX_ st, cv_const_sv((CV *)thing), recurse);
691 op_size(aTHX_ CvSTART(thing), st);
692 op_size(aTHX_ CvROOT(thing), st);
697 /* Some embedded char pointers */
698 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_top_name);
699 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_fmt_name);
700 check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_bottom_name);
701 /* Throw the GVs on the list to be walked if they're not-null */
702 sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_top_gv, recurse);
703 sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_bottom_gv, recurse);
704 sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_fmt_gv, recurse);
706 /* Only go trotting through the IO structures if they're really
707 trottable. If USE_PERLIO is defined we can do this. If
708 not... we can't, so we don't even try */
710 /* Dig into xio_ifp and xio_ofp here */
711 warn("Devel::Size: Can't size up perlio layers yet\n");
716 #if (PERL_VERSION < 9)
721 if(isGV_with_GP(thing)) {
722 st->total_size += GvNAMELEN(thing);
724 # if !defined(USE_ITHREADS) || (PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 8))
725 /* With itreads, before 5.8.9, this can end up pointing to freed memory
726 if the GV was created in an eval, as GvFILE() points to CopFILE(),
727 and the relevant COP has been freed on scope cleanup after the eval.
728 5.8.9 adds a binary compatible fudge that catches the vast majority
729 of cases. 5.9.something added a proper fix, by converting the GP to
730 use a shared hash key (porperly reference counted), instead of a
731 char * (owned by who knows? possibly no-one now) */
732 check_new_and_strlen(st, GvFILE(thing));
735 /* Is there something hanging off the glob? */
736 if (check_new(st, GvGP(thing))) {
737 st->total_size += sizeof(GP);
738 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_sv), recurse);
739 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_form), recurse);
740 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_av), recurse);
741 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_hv), recurse);
742 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_egv), recurse);
743 sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_cv), recurse);
745 #if (PERL_VERSION >= 9)
749 #if PERL_VERSION <= 8
757 if(recurse && SvROK(thing))
758 sv_size(aTHX_ st, SvRV_const(thing), recurse);
760 st->total_size += SvLEN(thing);
763 st->total_size += SvIVX(thing);
771 /* Frustratingly, the vtables aren't const in perl.h
772 gcc is happy enough to have non-const initialisers in a static array.
773 VC seems not to be. (Is it actually treating the file as C++?)
774 So do the maximally portable thing, unless we know it's gcc, in which case
775 we can do the more space efficient version. */
779 #include "vtables.inc"
784 static struct state *
790 void **vt_p = vtables;
793 Newxz(st, 1, struct state);
795 if (NULL != (warn_flag = perl_get_sv("Devel::Size::warn", FALSE))) {
796 st->dangle_whine = st->go_yell = SvIV(warn_flag) ? TRUE : FALSE;
798 if (NULL != (warn_flag = perl_get_sv("Devel::Size::dangle", FALSE))) {
799 st->dangle_whine = SvIV(warn_flag) ? TRUE : FALSE;
801 check_new(st, &PL_sv_undef);
802 check_new(st, &PL_sv_no);
803 check_new(st, &PL_sv_yes);
806 check_new(st, *vt_p++);
808 #include "vtables.inc"
813 MODULE = Devel::Size PACKAGE = Devel::Size
821 total_size = TOTAL_SIZE_RECURSION
824 SV *thing = orig_thing;
825 struct state *st = new_state(aTHX);
827 /* If they passed us a reference then dereference it. This is the
828 only way we can check the sizes of arrays and hashes */
833 sv_size(aTHX_ st, thing, ix);
834 RETVAL = st->total_size;