Size.xs

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