Size.xs

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