Size.xs

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