Size.xs

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