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