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