Size.xs

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