Size.xs

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