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