c533942aaa87be31bb2efb060a651dcbc495e947
[p5sagit/Devel-Size.git] / Size.xs
1 #define PERL_NO_GET_CONTEXT
2
3 #include "EXTERN.h"
4 #include "perl.h"
5 #include "XSUB.h"
6 #include "ppport.h"
7
8 /* Not yet in ppport.h */
9 #ifndef CvISXSUB
10 #  define CvISXSUB(cv)  (CvXSUB(cv) ? TRUE : FALSE)
11 #endif
12 #ifndef SvRV_const
13 #  define SvRV_const(rv) SvRV(rv)
14 #endif
15
16 #ifdef _MSC_VER 
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.  */
21 #  include <excpt.h>
22 #  define TRY_TO_CATCH_SEGV __try
23 #  define CAUGHT_EXCEPTION __except(EXCEPTION EXCEPTION_EXECUTE_HANDLER)
24 #else
25 #  define TRY_TO_CATCH_SEGV if(1)
26 #  define CAUGHT_EXCEPTION else
27 #endif
28
29 #ifdef __GNUC__
30 # define __attribute__(x)
31 #endif
32
33 #if 0 && defined(DEBUGGING)
34 #define dbg_printf(x) printf x
35 #else
36 #define dbg_printf(x)
37 #endif
38
39 #define TAG /* printf( "# %s(%d)\n", __FILE__, __LINE__ ) */
40 #define carp puts
41
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)  */
48
49 #define ALIGN_BITS  ( sizeof(void*) >> 1 )
50 #define BYTE_BITS    3
51 #define LEAF_BITS   (16 - BYTE_BITS)
52 #define LEAF_MASK   0x1FFF
53
54 struct state {
55     UV total_size;
56     bool regex_whine;
57     bool fm_whine;
58     bool dangle_whine;
59     bool go_yell;
60     /* My hunch (not measured) is that for most architectures pointers will
61        start with 0 bits, hence the start of this array will be hot, and the
62        end unused. So put the flags next to the hot end.  */
63     void *tracking[256];
64 };
65
66 /* 
67     Checks to see if thing is in the bitstring. 
68     Returns true or false, and
69     notes thing in the segmented bitstring.
70  */
71 static bool
72 check_new(struct state *st, const void *const p) {
73     unsigned int bits = 8 * sizeof(void*);
74     const size_t raw_p = PTR2nat(p);
75     /* This effectively rotates the value right by the number of low always-0
76        bits in an aligned pointer. The assmption is that most (if not all)
77        pointers are aligned, and these will be in the same chain of nodes
78        (and hence hot in the cache) but we can still deal with any unaligned
79        pointers.  */
80     const size_t cooked_p
81         = (raw_p >> ALIGN_BITS) | (raw_p << (bits - BYTE_BITS));
82     const U8 this_bit = 1 << (cooked_p & 0x7);
83     U8 **leaf_p;
84     U8 *leaf;
85     unsigned int i;
86     void **tv_p = (void **) (st->tracking);
87
88     if (NULL == p) return FALSE;
89     TRY_TO_CATCH_SEGV { 
90         const char c = *(const char *)p;
91     }
92     CAUGHT_EXCEPTION {
93         if (st->dangle_whine) 
94             warn( "Devel::Size: Encountered invalid pointer: %p\n", p );
95         return FALSE;
96     }
97     TAG;    
98
99     bits -= 8;
100     /* bits now 24 (32 bit pointers) or 56 (64 bit pointers) */
101
102     /* First level is always present.  */
103     do {
104         i = (unsigned int)((cooked_p >> bits) & 0xFF);
105         if (!tv_p[i])
106             Newxz(tv_p[i], 256, void *);
107         tv_p = (void **)(tv_p[i]);
108         bits -= 8;
109     } while (bits > LEAF_BITS + BYTE_BITS);
110     /* bits now 16 always */
111 #if !defined(MULTIPLICITY) || PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 8)
112     /* 5.8.8 and early have an assert() macro that uses Perl_croak, hence needs
113        a my_perl under multiplicity  */
114     assert(bits == 16);
115 #endif
116     leaf_p = (U8 **)tv_p;
117     i = (unsigned int)((cooked_p >> bits) & 0xFF);
118     if (!leaf_p[i])
119         Newxz(leaf_p[i], 1 << LEAF_BITS, U8);
120     leaf = leaf_p[i];
121
122     TAG;    
123
124     i = (unsigned int)((cooked_p >> BYTE_BITS) & LEAF_MASK);
125
126     if(leaf[i] & this_bit)
127         return FALSE;
128
129     leaf[i] |= this_bit;
130     return TRUE;
131 }
132
133 static void
134 free_tracking_at(void **tv, int level)
135 {
136     int i = 255;
137
138     if (--level) {
139         /* Nodes */
140         do {
141             if (tv[i]) {
142                 free_tracking_at(tv[i], level);
143                 Safefree(tv[i]);
144             }
145         } while (i--);
146     } else {
147         /* Leaves */
148         do {
149             if (tv[i])
150                 Safefree(tv[i]);
151         } while (i--);
152     }
153 }
154
155 static void
156 free_state(struct state *st)
157 {
158     const int top_level = (sizeof(void *) * 8 - LEAF_BITS - BYTE_BITS) / 8;
159     free_tracking_at((void **)st->tracking, top_level);
160     Safefree(st);
161 }
162
163 static void sv_size(pTHX_ struct state *, const SV *const, bool recurse);
164
165 typedef enum {
166     OPc_NULL,   /* 0 */
167     OPc_BASEOP, /* 1 */
168     OPc_UNOP,   /* 2 */
169     OPc_BINOP,  /* 3 */
170     OPc_LOGOP,  /* 4 */
171     OPc_LISTOP, /* 5 */
172     OPc_PMOP,   /* 6 */
173     OPc_SVOP,   /* 7 */
174     OPc_PADOP,  /* 8 */
175     OPc_PVOP,   /* 9 */
176     OPc_LOOP,   /* 10 */
177     OPc_COP /* 11 */
178 } opclass;
179
180 static opclass
181 cc_opclass(const OP * const o)
182 {
183     if (!o)
184     return OPc_NULL;
185     TRY_TO_CATCH_SEGV {
186         if (o->op_type == 0)
187         return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
188
189         if (o->op_type == OP_SASSIGN)
190         return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
191
192     #ifdef USE_ITHREADS
193         if (o->op_type == OP_GV || o->op_type == OP_GVSV || o->op_type == OP_AELEMFAST)
194         return OPc_PADOP;
195     #endif
196
197         if ((o->op_type == OP_TRANS)) {
198           return OPc_BASEOP;
199         }
200
201         switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
202         case OA_BASEOP: TAG;
203         return OPc_BASEOP;
204
205         case OA_UNOP: TAG;
206         return OPc_UNOP;
207
208         case OA_BINOP: TAG;
209         return OPc_BINOP;
210
211         case OA_LOGOP: TAG;
212         return OPc_LOGOP;
213
214         case OA_LISTOP: TAG;
215         return OPc_LISTOP;
216
217         case OA_PMOP: TAG;
218         return OPc_PMOP;
219
220         case OA_SVOP: TAG;
221         return OPc_SVOP;
222
223         case OA_PADOP: TAG;
224         return OPc_PADOP;
225
226         case OA_PVOP_OR_SVOP: TAG;
227             /*
228              * Character translations (tr///) are usually a PVOP, keeping a 
229              * pointer to a table of shorts used to look up translations.
230              * Under utf8, however, a simple table isn't practical; instead,
231              * the OP is an SVOP, and the SV is a reference to a swash
232              * (i.e., an RV pointing to an HV).
233              */
234         return (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
235             ? OPc_SVOP : OPc_PVOP;
236
237         case OA_LOOP: TAG;
238         return OPc_LOOP;
239
240         case OA_COP: TAG;
241         return OPc_COP;
242
243         case OA_BASEOP_OR_UNOP: TAG;
244         /*
245          * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
246          * whether parens were seen. perly.y uses OPf_SPECIAL to
247          * signal whether a BASEOP had empty parens or none.
248          * Some other UNOPs are created later, though, so the best
249          * test is OPf_KIDS, which is set in newUNOP.
250          */
251         return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
252
253         case OA_FILESTATOP: TAG;
254         /*
255          * The file stat OPs are created via UNI(OP_foo) in toke.c but use
256          * the OPf_REF flag to distinguish between OP types instead of the
257          * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
258          * return OPc_UNOP so that walkoptree can find our children. If
259          * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
260          * (no argument to the operator) it's an OP; with OPf_REF set it's
261          * an SVOP (and op_sv is the GV for the filehandle argument).
262          */
263         return ((o->op_flags & OPf_KIDS) ? OPc_UNOP :
264     #ifdef USE_ITHREADS
265             (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP);
266     #else
267             (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP);
268     #endif
269         case OA_LOOPEXOP: TAG;
270         /*
271          * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
272          * label was omitted (in which case it's a BASEOP) or else a term was
273          * seen. In this last case, all except goto are definitely PVOP but
274          * goto is either a PVOP (with an ordinary constant label), an UNOP
275          * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
276          * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
277          * get set.
278          */
279         if (o->op_flags & OPf_STACKED)
280             return OPc_UNOP;
281         else if (o->op_flags & OPf_SPECIAL)
282             return OPc_BASEOP;
283         else
284             return OPc_PVOP;
285         }
286         warn("Devel::Size: Can't determine class of operator %s, assuming BASEOP\n",
287          PL_op_name[o->op_type]);
288     }
289     CAUGHT_EXCEPTION { }
290     return OPc_BASEOP;
291 }
292
293
294 #if !defined(NV)
295 #define NV double
296 #endif
297
298 /* Figure out how much magic is attached to the SV and return the
299    size */
300 static void
301 magic_size(const SV * const thing, struct state *st) {
302   MAGIC *magic_pointer;
303
304   /* Is there any? */
305   if (!SvMAGIC(thing)) {
306     /* No, bail */
307     return;
308   }
309
310   /* Get the base magic pointer */
311   magic_pointer = SvMAGIC(thing);
312
313   /* Have we seen the magic pointer? */
314   while (check_new(st, magic_pointer)) {
315     st->total_size += sizeof(MAGIC);
316
317     TRY_TO_CATCH_SEGV {
318         /* Have we seen the magic vtable? */
319         if (check_new(st, magic_pointer->mg_virtual)) {
320           st->total_size += sizeof(MGVTBL);
321         }
322
323         /* Get the next in the chain */
324         magic_pointer = magic_pointer->mg_moremagic;
325     }
326     CAUGHT_EXCEPTION { 
327         if (st->dangle_whine) 
328             warn( "Devel::Size: Encountered bad magic at: %p\n", magic_pointer );
329     }
330   }
331 }
332
333 static void
334 check_new_and_strlen(struct state *st, const char *const p) {
335     if(check_new(st, p))
336         st->total_size += strlen(p);
337 }
338
339 static void
340 regex_size(const REGEXP * const baseregex, struct state *st) {
341     if(!check_new(st, baseregex))
342         return;
343   st->total_size += sizeof(REGEXP);
344 #if (PERL_VERSION < 11)     
345   /* Note the size of the paren offset thing */
346   st->total_size += sizeof(I32) * baseregex->nparens * 2;
347   st->total_size += strlen(baseregex->precomp);
348 #else
349   st->total_size += sizeof(struct regexp);
350   st->total_size += sizeof(I32) * SvANY(baseregex)->nparens * 2;
351   /*st->total_size += strlen(SvANY(baseregex)->subbeg);*/
352 #endif
353   if (st->go_yell && !st->regex_whine) {
354     carp("Devel::Size: Calculated sizes for compiled regexes are incompatible, and probably always will be");
355     st->regex_whine = 1;
356   }
357 }
358
359 static void
360 op_size(pTHX_ const OP * const baseop, struct state *st)
361 {
362     TRY_TO_CATCH_SEGV {
363         TAG;
364         if(!check_new(st, baseop))
365             return;
366         TAG;
367         op_size(aTHX_ baseop->op_next, st);
368         TAG;
369         switch (cc_opclass(baseop)) {
370         case OPc_BASEOP: TAG;
371             st->total_size += sizeof(struct op);
372             TAG;break;
373         case OPc_UNOP: TAG;
374             st->total_size += sizeof(struct unop);
375             op_size(aTHX_ cUNOPx(baseop)->op_first, st);
376             TAG;break;
377         case OPc_BINOP: TAG;
378             st->total_size += sizeof(struct binop);
379             op_size(aTHX_ cBINOPx(baseop)->op_first, st);
380             op_size(aTHX_ cBINOPx(baseop)->op_last, st);
381             TAG;break;
382         case OPc_LOGOP: TAG;
383             st->total_size += sizeof(struct logop);
384             op_size(aTHX_ cBINOPx(baseop)->op_first, st);
385             op_size(aTHX_ cLOGOPx(baseop)->op_other, st);
386             TAG;break;
387         case OPc_LISTOP: TAG;
388             st->total_size += sizeof(struct listop);
389             op_size(aTHX_ cLISTOPx(baseop)->op_first, st);
390             op_size(aTHX_ cLISTOPx(baseop)->op_last, st);
391             TAG;break;
392         case OPc_PMOP: TAG;
393             st->total_size += sizeof(struct pmop);
394             op_size(aTHX_ cPMOPx(baseop)->op_first, st);
395             op_size(aTHX_ cPMOPx(baseop)->op_last, st);
396 #if PERL_VERSION < 9 || (PERL_VERSION == 9 && PERL_SUBVERSION < 5)
397             op_size(aTHX_ cPMOPx(baseop)->op_pmreplroot, st);
398             op_size(aTHX_ cPMOPx(baseop)->op_pmreplstart, st);
399             op_size(aTHX_ (OP *)cPMOPx(baseop)->op_pmnext, st);
400 #endif
401             /* This is defined away in perl 5.8.x, but it is in there for
402                5.6.x */
403 #ifdef PM_GETRE
404             regex_size(PM_GETRE(cPMOPx(baseop)), st);
405 #else
406             regex_size(cPMOPx(baseop)->op_pmregexp, st);
407 #endif
408             TAG;break;
409       case OPc_SVOP: TAG;
410         st->total_size += sizeof(struct pmop);
411         if (check_new(st, cSVOPx(baseop)->op_sv)) {
412             sv_size(aTHX_ st, cSVOPx(baseop)->op_sv, TRUE);
413         }
414         TAG;break;
415       case OPc_PADOP: TAG;
416           st->total_size += sizeof(struct padop);
417           TAG;break;
418         case OPc_PVOP: TAG;
419             check_new_and_strlen(st, cPVOPx(baseop)->op_pv);
420         case OPc_LOOP: TAG;
421             st->total_size += sizeof(struct loop);
422             op_size(aTHX_ cLOOPx(baseop)->op_first, st);
423             op_size(aTHX_ cLOOPx(baseop)->op_last, st);
424             op_size(aTHX_ cLOOPx(baseop)->op_redoop, st);
425             op_size(aTHX_ cLOOPx(baseop)->op_nextop, st);
426             op_size(aTHX_ cLOOPx(baseop)->op_lastop, st);
427             TAG;break;
428         case OPc_COP: TAG;
429         {
430           COP *basecop;
431           basecop = (COP *)baseop;
432           st->total_size += sizeof(struct cop);
433
434           /* Change 33656 by nicholas@mouse-mill on 2008/04/07 11:29:51
435           Eliminate cop_label from struct cop by storing a label as the first
436           entry in the hints hash. Most statements don't have labels, so this
437           will save memory. Not sure how much. 
438           The check below will be incorrect fail on bleadperls
439           before 5.11 @33656, but later than 5.10, producing slightly too
440           small memory sizes on these Perls. */
441 #if (PERL_VERSION < 11)
442           check_new_and_strlen(st, basecop->cop_label);
443 #endif
444 #ifdef USE_ITHREADS
445           check_new_and_strlen(st, basecop->cop_file);
446           check_new_and_strlen(st, basecop->cop_stashpv);
447 #else
448           if (check_new(st, basecop->cop_stash)) {
449               sv_size(aTHX_ st, (SV *)basecop->cop_stash, TRUE);
450           }
451           if (check_new(st, basecop->cop_filegv)) {
452               sv_size(aTHX_ st, (SV *)basecop->cop_filegv, TRUE);
453           }
454 #endif
455
456         }
457         TAG;break;
458       default:
459         TAG;break;
460       }
461   }
462   CAUGHT_EXCEPTION {
463       if (st->dangle_whine) 
464           warn( "Devel::Size: Encountered dangling pointer in opcode at: %p\n", baseop );
465   }
466 }
467
468 #if PERL_VERSION > 9 || (PERL_VERSION == 9 && PERL_SUBVERSION > 2)
469 #  define NEW_HEAD_LAYOUT
470 #endif
471
472 static void
473 sv_size(pTHX_ struct state *const st, const SV * const orig_thing,
474         const bool recurse) {
475   const SV *thing = orig_thing;
476
477   st->total_size += sizeof(SV);
478
479   switch (SvTYPE(thing)) {
480     /* Is it undef? */
481   case SVt_NULL: TAG;
482     TAG;break;
483     /* Just a plain integer. This will be differently sized depending
484        on whether purify's been compiled in */
485   case SVt_IV: TAG;
486 #ifndef NEW_HEAD_LAYOUT
487 #  ifdef PURIFY
488     st->total_size += sizeof(sizeof(XPVIV));
489 #  else
490     st->total_size += sizeof(IV);
491 #  endif
492 #endif
493     TAG;break;
494     /* Is it a float? Like the int, it depends on purify */
495   case SVt_NV: TAG;
496 #ifdef PURIFY
497     st->total_size += sizeof(sizeof(XPVNV));
498 #else
499     st->total_size += sizeof(NV);
500 #endif
501     TAG;break;
502 #if (PERL_VERSION < 11)     
503     /* Is it a reference? */
504   case SVt_RV: TAG;
505 #ifndef NEW_HEAD_LAYOUT
506     st->total_size += sizeof(XRV);
507 #endif
508     TAG;break;
509 #endif
510     /* How about a plain string? In which case we need to add in how
511        much has been allocated */
512   case SVt_PV: TAG;
513     st->total_size += sizeof(XPV);
514     if(recurse && SvROK(thing))
515         sv_size(aTHX_ st, SvRV_const(thing), TRUE);
516     else
517         st->total_size += SvLEN(thing);
518     TAG;break;
519     /* A string with an integer part? */
520   case SVt_PVIV: TAG;
521     st->total_size += sizeof(XPVIV);
522     if(recurse && SvROK(thing))
523         sv_size(aTHX_ st, SvRV_const(thing), TRUE);
524     else
525         st->total_size += SvLEN(thing);
526     if(SvOOK(thing)) {
527         st->total_size += SvIVX(thing);
528     }
529     TAG;break;
530     /* A scalar/string/reference with a float part? */
531   case SVt_PVNV: TAG;
532     st->total_size += sizeof(XPVNV);
533     if(recurse && SvROK(thing))
534         sv_size(aTHX_ st, SvRV_const(thing), TRUE);
535     else
536         st->total_size += SvLEN(thing);
537     TAG;break;
538   case SVt_PVMG: TAG;
539     st->total_size += sizeof(XPVMG);
540     if(recurse && SvROK(thing))
541         sv_size(aTHX_ st, SvRV_const(thing), TRUE);
542     else
543         st->total_size += SvLEN(thing);
544     magic_size(thing, st);
545     TAG;break;
546 #if PERL_VERSION <= 8
547   case SVt_PVBM: TAG;
548     st->total_size += sizeof(XPVBM);
549     if(recurse && SvROK(thing))
550         sv_size(aTHX_ st, SvRV_const(thing), TRUE);
551     else
552         st->total_size += SvLEN(thing);
553     magic_size(thing, st);
554     TAG;break;
555 #endif
556   case SVt_PVLV: TAG;
557     st->total_size += sizeof(XPVLV);
558     if(recurse && SvROK(thing))
559         sv_size(aTHX_ st, SvRV_const(thing), TRUE);
560     else
561         st->total_size += SvLEN(thing);
562     magic_size(thing, st);
563     TAG;break;
564     /* How much space is dedicated to the array? Not counting the
565        elements in the array, mind, just the array itself */
566   case SVt_PVAV: TAG;
567     st->total_size += sizeof(XPVAV);
568     /* Is there anything in the array? */
569     if (AvMAX(thing) != -1) {
570       /* an array with 10 slots has AvMax() set to 9 - te 2007-04-22 */
571       st->total_size += sizeof(SV *) * (AvMAX(thing) + 1);
572       dbg_printf(("total_size: %li AvMAX: %li av_len: $i\n", st->total_size, AvMAX(thing), av_len((AV*)thing)));
573     }
574     /* Add in the bits on the other side of the beginning */
575
576     dbg_printf(("total_size %li, sizeof(SV *) %li, AvARRAY(thing) %li, AvALLOC(thing)%li , sizeof(ptr) %li \n", 
577     st->total_size, sizeof(SV*), AvARRAY(thing), AvALLOC(thing), sizeof( thing )));
578
579     /* under Perl 5.8.8 64bit threading, AvARRAY(thing) was a pointer while AvALLOC was 0,
580        resulting in grossly overstated sized for arrays. Technically, this shouldn't happen... */
581     if (AvALLOC(thing) != 0) {
582       st->total_size += (sizeof(SV *) * (AvARRAY(thing) - AvALLOC(thing)));
583       }
584 #if (PERL_VERSION < 9)
585     /* Is there something hanging off the arylen element?
586        Post 5.9.something this is stored in magic, so will be found there,
587        and Perl_av_arylen_p() takes a non-const AV*, hence compilers rightly
588        complain about AvARYLEN() passing thing to it.  */
589     if (AvARYLEN(thing)) {
590       if (check_new(st, AvARYLEN(thing))) {
591           sv_size(aTHX_ st, AvARYLEN(thing), TRUE);
592       }
593     }
594 #endif
595     magic_size(thing, st);
596     TAG;break;
597   case SVt_PVHV: TAG;
598     /* First the base struct */
599     st->total_size += sizeof(XPVHV);
600     /* Now the array of buckets */
601     st->total_size += (sizeof(HE *) * (HvMAX(thing) + 1));
602     /* Now walk the bucket chain */
603     if (HvARRAY(thing)) {
604       HE *cur_entry;
605       UV cur_bucket = 0;
606       for (cur_bucket = 0; cur_bucket <= HvMAX(thing); cur_bucket++) {
607         cur_entry = *(HvARRAY(thing) + cur_bucket);
608         while (cur_entry) {
609           st->total_size += sizeof(HE);
610           if (cur_entry->hent_hek) {
611             /* Hash keys can be shared. Have we seen this before? */
612             if (check_new(st, cur_entry->hent_hek)) {
613               st->total_size += HEK_BASESIZE + cur_entry->hent_hek->hek_len + 2;
614             }
615           }
616           cur_entry = cur_entry->hent_next;
617         }
618       }
619     }
620     magic_size(thing, st);
621     TAG;break;
622   case SVt_PVCV: TAG;
623     st->total_size += sizeof(XPVCV);
624     magic_size(thing, st);
625
626     st->total_size += ((XPVIO *) SvANY(thing))->xpv_len;
627     if (check_new(st, CvSTASH(thing))) {
628         sv_size(aTHX_ st, (SV *)CvSTASH(thing), TRUE);
629     }
630     if (check_new(st, SvSTASH(thing))) {
631         sv_size(aTHX_ st, (SV *)SvSTASH(thing), TRUE);
632     }
633     if (check_new(st, CvGV(thing))) {
634         sv_size(aTHX_ st, (SV *)CvGV(thing), TRUE);
635     }
636     if (check_new(st, CvPADLIST(thing))) {
637         sv_size(aTHX_ st, (SV *)CvPADLIST(thing), TRUE);
638     }
639     if (check_new(st, CvOUTSIDE(thing))) {
640         sv_size(aTHX_ st, (SV *)CvOUTSIDE(thing), TRUE);
641     }
642     if (CvISXSUB(thing)) {
643         SV *sv = cv_const_sv((CV *)thing);
644         if (sv) {
645             sv_size(aTHX_ st, sv, TRUE);
646         }
647     } else {
648         op_size(aTHX_ CvSTART(thing), st);
649         op_size(aTHX_ CvROOT(thing), st);
650     }
651
652     TAG;break;
653   case SVt_PVGV: TAG;
654     magic_size(thing, st);
655     st->total_size += sizeof(XPVGV);
656     st->total_size += GvNAMELEN(thing);
657 #ifdef GvFILE
658     /* Is there a file? */
659     check_new_and_strlen(st, GvFILE(thing));
660 #endif
661     /* Is there something hanging off the glob? */
662     if (GvGP(thing)) {
663       if (check_new(st, GvGP(thing))) {
664     st->total_size += sizeof(GP);
665     {
666       SV *generic_thing;
667       if ((generic_thing = (SV *)(GvGP(thing)->gp_sv))) {
668           sv_size(aTHX_ st, generic_thing, TRUE);
669       }
670       if ((generic_thing = (SV *)(GvGP(thing)->gp_form))) {
671           sv_size(aTHX_ st, generic_thing, TRUE);
672       }
673       if ((generic_thing = (SV *)(GvGP(thing)->gp_av))) {
674           sv_size(aTHX_ st, generic_thing, TRUE);
675       }
676       if ((generic_thing = (SV *)(GvGP(thing)->gp_hv))) {
677           sv_size(aTHX_ st, generic_thing, TRUE);
678       }
679       if ((generic_thing = (SV *)(GvGP(thing)->gp_egv))) {
680           sv_size(aTHX_ st, generic_thing, TRUE);
681       }
682       if ((generic_thing = (SV *)(GvGP(thing)->gp_cv))) {
683           sv_size(aTHX_ st, generic_thing, TRUE);
684       }
685     }
686       }
687     }
688     TAG;break;
689   case SVt_PVFM: TAG;
690     st->total_size += sizeof(XPVFM);
691     magic_size(thing, st);
692     st->total_size += ((XPVIO *) SvANY(thing))->xpv_len;
693     if (check_new(st, CvPADLIST(thing))) {
694         sv_size(aTHX_ st, (SV *)CvPADLIST(thing), TRUE);
695     }
696     if (check_new(st, CvOUTSIDE(thing))) {
697         sv_size(aTHX_ st, (SV *)CvOUTSIDE(thing), TRUE);
698     }
699
700     if (st->go_yell && !st->fm_whine) {
701       carp("Devel::Size: Calculated sizes for FMs are incomplete");
702       st->fm_whine = 1;
703     }
704     TAG;break;
705   case SVt_PVIO: TAG;
706     st->total_size += sizeof(XPVIO);
707     magic_size(thing, st);
708     if (check_new(st, (SvPVX_const(thing)))) {
709       st->total_size += ((XPVIO *) SvANY(thing))->xpv_cur;
710     }
711     /* Some embedded char pointers */
712     check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_top_name);
713     check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_fmt_name);
714     check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_bottom_name);
715     /* Throw the GVs on the list to be walked if they're not-null */
716     if (((XPVIO *) SvANY(thing))->xio_top_gv) {
717         sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_top_gv, TRUE);
718     }
719     if (((XPVIO *) SvANY(thing))->xio_bottom_gv) {
720         sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_bottom_gv, TRUE);
721     }
722     if (((XPVIO *) SvANY(thing))->xio_fmt_gv) {
723         sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_fmt_gv, TRUE);
724     }
725
726     /* Only go trotting through the IO structures if they're really
727        trottable. If USE_PERLIO is defined we can do this. If
728        not... we can't, so we don't even try */
729 #ifdef USE_PERLIO
730     /* Dig into xio_ifp and xio_ofp here */
731     warn("Devel::Size: Can't size up perlio layers yet\n");
732 #endif
733     TAG;break;
734   default:
735     warn("Devel::Size: Unknown variable type: %d encountered\n", SvTYPE(thing) );
736   }
737 }
738
739 static struct state *
740 new_state(pTHX)
741 {
742     SV *warn_flag;
743     struct state *st;
744     Newxz(st, 1, struct state);
745     st->go_yell = TRUE;
746     if (NULL != (warn_flag = perl_get_sv("Devel::Size::warn", FALSE))) {
747         st->dangle_whine = st->go_yell = SvIV(warn_flag) ? TRUE : FALSE;
748     }
749     if (NULL != (warn_flag = perl_get_sv("Devel::Size::dangle", FALSE))) {
750         st->dangle_whine = SvIV(warn_flag) ? TRUE : FALSE;
751     }
752     check_new(st, &PL_sv_undef);
753     check_new(st, &PL_sv_no);
754     check_new(st, &PL_sv_yes);
755     return st;
756 }
757
758 MODULE = Devel::Size        PACKAGE = Devel::Size       
759
760 PROTOTYPES: DISABLE
761
762 UV
763 size(orig_thing)
764      SV *orig_thing
765 CODE:
766 {
767   SV *thing = orig_thing;
768   struct state *st = new_state(aTHX);
769   
770   /* If they passed us a reference then dereference it. This is the
771      only way we can check the sizes of arrays and hashes */
772 #if (PERL_VERSION < 11)
773   if (SvOK(thing) && SvROK(thing)) {
774     thing = SvRV(thing);
775   }
776 #else
777   if (SvROK(thing)) {
778     thing = SvRV(thing);
779   }
780 #endif
781
782   sv_size(aTHX_ st, thing, FALSE);
783   RETVAL = st->total_size;
784   free_state(st);
785 }
786 OUTPUT:
787   RETVAL
788
789
790 UV
791 total_size(orig_thing)
792        SV *orig_thing
793 CODE:
794 {
795   SV *thing = orig_thing;
796   /* Array with things we still need to do */
797   AV *pending_array;
798   IV size = 0;
799   struct state *st = new_state(aTHX);
800
801   /* Size starts at zero */
802   RETVAL = 0;
803
804   pending_array = newAV();
805
806   /* If they passed us a reference then dereference it.
807      This is the only way we can check the sizes of arrays and hashes. */
808   if (SvROK(thing)) {
809       thing = SvRV(thing);
810   } 
811
812   /* Put it on the pending array */
813   av_push(pending_array, thing);
814
815   /* Now just yank things off the end of the array until it's done */
816   while (av_len(pending_array) >= 0) {
817     thing = av_pop(pending_array);
818     /* Process it if we've not seen it */
819     if (check_new(st, thing)) {
820       dbg_printf(("# Found type %i at %p\n", SvTYPE(thing), thing));
821       /* Is it valid? */
822       if (thing) {
823     /* Yes, it is. So let's check the type */
824     switch (SvTYPE(thing)) {
825     /* fix for bug #24846 (Does not correctly recurse into references in a PVNV-type scalar) */
826     case SVt_PVNV: TAG;
827       if (SvROK(thing))
828         {
829         av_push(pending_array, SvRV(thing));
830         } 
831       TAG;break;
832 #if (PERL_VERSION < 11)
833         case SVt_RV: TAG;
834 #else
835         case SVt_IV: TAG;
836 #endif
837              dbg_printf(("# Found RV\n"));
838           if (SvROK(thing)) {
839              dbg_printf(("# Found RV\n"));
840              av_push(pending_array, SvRV(thing));
841           }
842           TAG;break;
843
844     case SVt_PVAV: TAG;
845       {
846         AV *tempAV = (AV *)thing;
847         SV **tempSV;
848
849         dbg_printf(("# Found type AV\n"));
850         /* Quick alias to cut down on casting */
851         
852         /* Any elements? */
853         if (av_len(tempAV) != -1) {
854           IV index;
855           /* Run through them all */
856           for (index = 0; index <= av_len(tempAV); index++) {
857         /* Did we get something? */
858         if ((tempSV = av_fetch(tempAV, index, 0))) {
859           /* Was it undef? */
860           if (*tempSV != &PL_sv_undef) {
861             /* Apparently not. Save it for later */
862             av_push(pending_array, *tempSV);
863           }
864         }
865           }
866         }
867       }
868       TAG;break;
869
870     case SVt_PVHV: TAG;
871       dbg_printf(("# Found type HV\n"));
872       /* Is there anything in here? */
873       if (hv_iterinit((HV *)thing)) {
874         HE *temp_he;
875         while ((temp_he = hv_iternext((HV *)thing))) {
876           av_push(pending_array, hv_iterval((HV *)thing, temp_he));
877         }
878       }
879       TAG;break;
880      
881     case SVt_PVGV: TAG;
882       dbg_printf(("# Found type GV\n"));
883       /* Run through all the pieces and push the ones with bits */
884       if (GvSV(thing)) {
885         av_push(pending_array, (SV *)GvSV(thing));
886       }
887       if (GvFORM(thing)) {
888         av_push(pending_array, (SV *)GvFORM(thing));
889       }
890       if (GvAV(thing)) {
891         av_push(pending_array, (SV *)GvAV(thing));
892       }
893       if (GvHV(thing)) {
894         av_push(pending_array, (SV *)GvHV(thing));
895       }
896       if (GvCV(thing)) {
897         av_push(pending_array, (SV *)GvCV(thing));
898       }
899       TAG;break;
900     default:
901       TAG;break;
902     }
903       }
904       
905       sv_size(aTHX_ st, thing, TRUE);
906     } else {
907     /* check_new() returned false: */
908 #ifdef DEVEL_SIZE_DEBUGGING
909        if (SvOK(sv)) printf("# Ignore ref copy 0x%x\n", sv);
910        else printf("# Ignore non-sv 0x%x\n", sv);
911 #endif
912     }
913   } /* end while */
914
915   RETVAL = st->total_size;
916   free_state(st);
917   SvREFCNT_dec(pending_array);
918 }
919 OUTPUT:
920   RETVAL
921