Size.xs

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