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 PERL_VERSION < 9 || (PERL_VERSION == 9 && PERL_SUBVERSION < 5)
 266     if (check_new(tracking_hash, cPMOPx(baseop)->op_pmreplroot)) {
 267       total_size += op_size(cPMOPx(baseop)->op_pmreplroot, tracking_hash);
 268     }
 269     if (check_new(tracking_hash, cPMOPx(baseop)->op_pmreplstart)) {
 270       total_size += op_size(cPMOPx(baseop)->op_pmreplstart, tracking_hash);
 271     }
 272     if (check_new(tracking_hash, cPMOPx(baseop)->op_pmnext)) {
 273       total_size += op_size((OP *)cPMOPx(baseop)->op_pmnext, tracking_hash);
 274     }
 275 #endif
 276     /* This is defined away in perl 5.8.x, but it is in there for
 277        5.6.x */
 278 #ifdef PM_GETRE
 279     if (check_new(tracking_hash, PM_GETRE((cPMOPx(baseop))))) {
 280       total_size += regex_size(PM_GETRE(cPMOPx(baseop)), tracking_hash);
 281     }
 282 #else
 283     if (check_new(tracking_hash, cPMOPx(baseop)->op_pmregexp)) {
 284       total_size += regex_size(cPMOPx(baseop)->op_pmregexp, tracking_hash);
 285     }
 286 #endif
 287     break;
 288   case OPc_SVOP:
 289     total_size += sizeof(struct pmop);
 290     if (check_new(tracking_hash, cSVOPx(baseop)->op_sv)) {
 291       total_size += thing_size(cSVOPx(baseop)->op_sv, tracking_hash);
 292     }
 293     break;
 294   case OPc_PADOP:
 295     total_size += sizeof(struct padop);
 296     break;
 297   case OPc_PVOP:
 298     if (check_new(tracking_hash, cPVOPx(baseop)->op_pv)) {
 299       total_size += strlen(cPVOPx(baseop)->op_pv);
 300     }
 301   case OPc_LOOP:
 302     total_size += sizeof(struct loop);
 303     if (check_new(tracking_hash, cLOOPx(baseop)->op_first)) {
 304       total_size += op_size(cLOOPx(baseop)->op_first, tracking_hash);
 305     }
 306     if (check_new(tracking_hash, cLOOPx(baseop)->op_last)) {
 307       total_size += op_size(cLOOPx(baseop)->op_last, tracking_hash);
 308     }
 309     if (check_new(tracking_hash, cLOOPx(baseop)->op_redoop)) {
 310       total_size += op_size(cLOOPx(baseop)->op_redoop, tracking_hash);
 311     }
 312     if (check_new(tracking_hash, cLOOPx(baseop)->op_nextop)) {
 313       total_size += op_size(cLOOPx(baseop)->op_nextop, tracking_hash);
 314     }
 315     /* Not working for some reason, but the code's here for later
 316        fixing
 317     if (check_new(tracking_hash, cLOOPx(baseop)->op_lastop)) {
 318       total_size += op_size(cLOOPx(baseop)->op_lastop, tracking_hash);
 319     }
 320     */
 321     break;
 322   case OPc_COP:
 323     {
 324       COP *basecop;
 325       basecop = (COP *)baseop;
 326       total_size += sizeof(struct cop);
 327
 328       if (check_new(tracking_hash, basecop->cop_label)) {
 329         total_size += strlen(basecop->cop_label);
 330       }
 331 #ifdef USE_ITHREADS
 332       if (check_new(tracking_hash, basecop->cop_file)) {
 333         total_size += strlen(basecop->cop_file);
 334       }
 335       if (check_new(tracking_hash, basecop->cop_stashpv)) {
 336         total_size += strlen(basecop->cop_stashpv);
 337       }
 338 #else
 339       if (check_new(tracking_hash, basecop->cop_stash)) {
 340         total_size += thing_size((SV *)basecop->cop_stash, tracking_hash);
 341       }
 342       if (check_new(tracking_hash, basecop->cop_filegv)) {
 343         total_size += thing_size((SV *)basecop->cop_filegv, tracking_hash);
 344       }
 345 #endif
 346
 347     }
 348     break;
 349   default:
 350     break;
 351   }
 352   return total_size;
 353 }
 354
 355 #if PERL_VERSION > 9 || (PERL_VERSION == 9 && PERL_SUBVERSION > 2)
 356 #  define NEW_HEAD_LAYOUT
 357 #endif
 358
 359 UV thing_size(SV *orig_thing, HV *tracking_hash) {
 360   SV *thing = orig_thing;
 361   UV total_size = sizeof(SV);
 362
 363   switch (SvTYPE(thing)) {
 364     /* Is it undef? */
 365   case SVt_NULL:
 366     break;
 367     /* Just a plain integer. This will be differently sized depending
 368        on whether purify's been compiled in */
 369   case SVt_IV:
 370 #ifndef NEW_HEAD_LAYOUT
 371 #  ifdef PURIFY
 372     total_size += sizeof(sizeof(XPVIV));
 373 #  else
 374     total_size += sizeof(IV);
 375 #  endif
 376 #endif
 377     break;
 378     /* Is it a float? Like the int, it depends on purify */
 379   case SVt_NV:
 380 #ifdef PURIFY
 381     total_size += sizeof(sizeof(XPVNV));
 382 #else
 383     total_size += sizeof(NV);
 384 #endif
 385     break;
 386     /* Is it a reference? */
 387   case SVt_RV:
 388 #ifndef NEW_HEAD_LAYOUT
 389     total_size += sizeof(XRV);
 390 #endif
 391     break;
 392     /* How about a plain string? In which case we need to add in how
 393        much has been allocated */
 394   case SVt_PV:
 395     total_size += sizeof(XPV);
 396     total_size += SvROK(thing) ? thing_size( SvRV(thing), tracking_hash) : SvLEN(thing);
 397     break;
 398     /* A string with an integer part? */
 399   case SVt_PVIV:
 400     total_size += sizeof(XPVIV);
 401     total_size += SvROK(thing) ? thing_size( SvRV(thing), tracking_hash) : SvLEN(thing);
 402     if(SvOOK(thing)) {
 403         total_size += SvIVX(thing);
 404         }
 405     break;
 406     /* A scalar/string/reference with a float part? */
 407   case SVt_PVNV:
 408     total_size += sizeof(XPVNV);
 409     total_size += SvROK(thing) ? thing_size( SvRV(thing), tracking_hash) : SvLEN(thing);
 410     break;
 411   case SVt_PVMG:
 412     total_size += sizeof(XPVMG);
 413     total_size += SvROK(thing) ? thing_size( SvRV(thing), tracking_hash) : SvLEN(thing);
 414     total_size += magic_size(thing, tracking_hash);
 415     break;
 416 #if PERL_VERSION <= 8
 417   case SVt_PVBM:
 418     total_size += sizeof(XPVBM);
 419     total_size += SvROK(thing) ? thing_size( SvRV(thing), tracking_hash) : SvLEN(thing);
 420     total_size += magic_size(thing, tracking_hash);
 421     break;
 422 #endif
 423   case SVt_PVLV:
 424     total_size += sizeof(XPVLV);
 425     total_size += SvROK(thing) ? thing_size( SvRV(thing), tracking_hash) : SvLEN(thing);
 426     total_size += magic_size(thing, tracking_hash);
 427     break;
 428     /* How much space is dedicated to the array? Not counting the
 429        elements in the array, mind, just the array itself */
 430   case SVt_PVAV:
 431     total_size += sizeof(XPVAV);
 432     /* Is there anything in the array? */
 433     if (AvMAX(thing) != -1) {
 434       /* an array with 10 slots has AvMax() set to 9 - te 2007-04-22 */
 435       total_size += sizeof(SV *) * (AvMAX(thing) + 1);
 436       /* printf ("total_size: %li AvMAX: %li av_len: %i\n", total_size, AvMAX(thing), av_len(thing)); */
 437     }
 438     /* Add in the bits on the other side of the beginning */
 439
 440       /* printf ("total_size %li, sizeof(SV *) %li, AvARRAY(thing) %li, AvALLOC(thing)%li , sizeof(ptr) %li \n",
 441         total_size, sizeof(SV*), AvARRAY(thing), AvALLOC(thing), sizeof( thing )); */
 442
 443     /* under Perl 5.8.8 64bit threading, AvARRAY(thing) was a pointer while AvALLOC was 0,
 444        resulting in grossly overstated sized for arrays. Technically, this shouldn't happen... */
 445     if (AvALLOC(thing) != 0) {
 446       total_size += (sizeof(SV *) * (AvARRAY(thing) - AvALLOC(thing)));
 447       }
 448     /* Is there something hanging off the arylen element? */
 449     if (AvARYLEN(thing)) {
 450       if (check_new(tracking_hash, AvARYLEN(thing))) {
 451         total_size += thing_size(AvARYLEN(thing), tracking_hash);
 452       }
 453     }
 454     total_size += magic_size(thing, tracking_hash);
 455     break;
 456   case SVt_PVHV:
 457     /* First the base struct */
 458     total_size += sizeof(XPVHV);
 459     /* Now the array of buckets */
 460     total_size += (sizeof(HE *) * (HvMAX(thing) + 1));
 461     /* Now walk the bucket chain */
 462     if (HvARRAY(thing)) {
 463       HE *cur_entry;
 464       IV cur_bucket = 0;
 465       for (cur_bucket = 0; cur_bucket <= HvMAX(thing); cur_bucket++) {
 466         cur_entry = *(HvARRAY(thing) + cur_bucket);
 467         while (cur_entry) {
 468           total_size += sizeof(HE);
 469           if (cur_entry->hent_hek) {
 470             /* Hash keys can be shared. Have we seen this before? */
 471             if (check_new(tracking_hash, cur_entry->hent_hek)) {
 472               total_size += HEK_BASESIZE + cur_entry->hent_hek->hek_len + 2;
 473             }
 474           }
 475           cur_entry = cur_entry->hent_next;
 476         }
 477       }
 478     }
 479     total_size += magic_size(thing, tracking_hash);
 480     break;
 481   case SVt_PVCV:
 482     total_size += sizeof(XPVCV);
 483     total_size += magic_size(thing, tracking_hash);
 484
 485     total_size += ((XPVIO *) SvANY(thing))->xpv_len;
 486     if (check_new(tracking_hash, CvSTASH(thing))) {
 487       total_size += thing_size((SV *)CvSTASH(thing), tracking_hash);
 488     }
 489     if (check_new(tracking_hash, SvSTASH(thing))) {
 490       total_size += thing_size((SV *)SvSTASH(thing), tracking_hash);
 491     }
 492     if (check_new(tracking_hash, CvGV(thing))) {
 493       total_size += thing_size((SV *)CvGV(thing), tracking_hash);
 494     }
 495     if (check_new(tracking_hash, CvPADLIST(thing))) {
 496       total_size += thing_size((SV *)CvPADLIST(thing), tracking_hash);
 497     }
 498     if (check_new(tracking_hash, CvOUTSIDE(thing))) {
 499       total_size += thing_size((SV *)CvOUTSIDE(thing), tracking_hash);
 500     }
 501
 502     if (check_new(tracking_hash, CvSTART(thing))) {
 503       total_size += op_size(CvSTART(thing), tracking_hash);
 504     }
 505     if (check_new(tracking_hash, CvROOT(thing))) {
 506       total_size += op_size(CvROOT(thing), tracking_hash);
 507     }
 508
 509     break;
 510   case SVt_PVGV:
 511     total_size += magic_size(thing, tracking_hash);
 512     total_size += sizeof(XPVGV);
 513     total_size += GvNAMELEN(thing);
 514 #ifdef GvFILE
 515     /* Is there a file? */
 516     if (GvFILE(thing)) {
 517       if (check_new(tracking_hash, GvFILE(thing))) {
 518         total_size += strlen(GvFILE(thing));
 519       }
 520     }
 521 #endif
 522     /* Is there something hanging off the glob? */
 523     if (GvGP(thing)) {
 524       if (check_new(tracking_hash, GvGP(thing))) {
 525         total_size += sizeof(GP);
 526         {
 527           SV *generic_thing;
 528           if ((generic_thing = (SV *)(GvGP(thing)->gp_sv))) {
 529             total_size += thing_size(generic_thing, tracking_hash);
 530           }
 531           if ((generic_thing = (SV *)(GvGP(thing)->gp_form))) {
 532             total_size += thing_size(generic_thing, tracking_hash);
 533           }
 534           if ((generic_thing = (SV *)(GvGP(thing)->gp_av))) {
 535             total_size += thing_size(generic_thing, tracking_hash);
 536           }
 537           if ((generic_thing = (SV *)(GvGP(thing)->gp_hv))) {
 538             total_size += thing_size(generic_thing, tracking_hash);
 539           }
 540           if ((generic_thing = (SV *)(GvGP(thing)->gp_egv))) {
 541             total_size += thing_size(generic_thing, tracking_hash);
 542           }
 543           if ((generic_thing = (SV *)(GvGP(thing)->gp_cv))) {
 544             total_size += thing_size(generic_thing, tracking_hash);
 545           }
 546         }
 547       }
 548     }
 549     break;
 550   case SVt_PVFM:
 551     total_size += sizeof(XPVFM);
 552     total_size += magic_size(thing, tracking_hash);
 553     total_size += ((XPVIO *) SvANY(thing))->xpv_len;
 554     if (check_new(tracking_hash, CvPADLIST(thing))) {
 555       total_size += thing_size((SV *)CvPADLIST(thing), tracking_hash);
 556     }
 557     if (check_new(tracking_hash, CvOUTSIDE(thing))) {
 558       total_size += thing_size((SV *)CvOUTSIDE(thing), tracking_hash);
 559     }
 560
 561     if (go_yell && !fm_whine) {
 562       carp("Devel::Size: Calculated sizes for FMs are incomplete");
 563       fm_whine = 1;
 564     }
 565     break;
 566   case SVt_PVIO:
 567     total_size += sizeof(XPVIO);
 568     total_size += magic_size(thing, tracking_hash);
 569     if (check_new(tracking_hash, (SvPVX(thing)))) {
 570       total_size += ((XPVIO *) SvANY(thing))->xpv_cur;
 571     }
 572     /* Some embedded char pointers */
 573     if (check_new(tracking_hash, ((XPVIO *) SvANY(thing))->xio_top_name)) {
 574       total_size += strlen(((XPVIO *) SvANY(thing))->xio_top_name);
 575     }
 576     if (check_new(tracking_hash, ((XPVIO *) SvANY(thing))->xio_fmt_name)) {
 577       total_size += strlen(((XPVIO *) SvANY(thing))->xio_fmt_name);
 578     }
 579     if (check_new(tracking_hash, ((XPVIO *) SvANY(thing))->xio_bottom_name)) {
 580       total_size += strlen(((XPVIO *) SvANY(thing))->xio_bottom_name);
 581     }
 582     /* Throw the GVs on the list to be walked if they're not-null */
 583     if (((XPVIO *) SvANY(thing))->xio_top_gv) {
 584       total_size += thing_size((SV *)((XPVIO *) SvANY(thing))->xio_top_gv,
 585                                tracking_hash);
 586     }
 587     if (((XPVIO *) SvANY(thing))->xio_bottom_gv) {
 588       total_size += thing_size((SV *)((XPVIO *) SvANY(thing))->xio_bottom_gv,
 589                                tracking_hash);
 590     }
 591     if (((XPVIO *) SvANY(thing))->xio_fmt_gv) {
 592       total_size += thing_size((SV *)((XPVIO *) SvANY(thing))->xio_fmt_gv,
 593                                tracking_hash);
 594     }
 595
 596     /* Only go trotting through the IO structures if they're really
 597        trottable. If USE_PERLIO is defined we can do this. If
 598        not... we can't, so we don't even try */
 599 #ifdef USE_PERLIO
 600     /* Dig into xio_ifp and xio_ofp here */
 601     croak("Devel::Size: Can't size up perlio layers yet");
 602 #endif
 603     break;
 604   default:
 605     croak("Devel::Size: Unknown variable type");
 606   }
 607   return total_size;
 608 }
 609
 610 MODULE = Devel::Size            PACKAGE = Devel::Size
 611
 612 PROTOTYPES: DISABLE
 613
 614 IV
 615 size(orig_thing)
 616      SV *orig_thing
 617 CODE:
 618 {
 619   SV *thing = orig_thing;
 620   /* Hash to track our seen pointers */
 621   HV *tracking_hash = newHV();
 622   SV *warn_flag;
 623
 624   /* Check warning status */
 625   go_yell = 0;
 626   regex_whine = 0;
 627   fm_whine = 0;
 628
 629   if (NULL != (warn_flag = perl_get_sv("Devel::Size::warn", FALSE))) {
 630     go_yell = SvIV(warn_flag);
 631   }
 632
 633
 634   /* If they passed us a reference then dereference it. This is the
 635      only way we can check the sizes of arrays and hashes */
 636   if (SvOK(thing) && SvROK(thing)) {
 637     thing = SvRV(thing);
 638   }
 639
 640   RETVAL = thing_size(thing, tracking_hash);
 641   /* Clean up after ourselves */
 642   SvREFCNT_dec(tracking_hash);
 643 }
 644 OUTPUT:
 645   RETVAL
 646
 647
 648 IV
 649 total_size(orig_thing)
 650        SV *orig_thing
 651 CODE:
 652 {
 653   SV *thing = orig_thing;
 654   /* Hash to track our seen pointers */
 655   HV *tracking_hash = newHV();
 656   AV *pending_array = newAV();
 657   IV size = 0;
 658   SV *warn_flag;
 659
 660   /* Size starts at zero */
 661   RETVAL = 0;
 662
 663   /* Check warning status */
 664   go_yell = 0;
 665   regex_whine = 0;
 666   fm_whine = 0;
 667
 668   if (NULL != (warn_flag = perl_get_sv("Devel::Size::warn", FALSE))) {
 669     go_yell = SvIV(warn_flag);
 670   }
 671
 672
 673   /* If they passed us a reference then dereference it. This is the
 674      only way we can check the sizes of arrays and hashes */
 675   if (SvOK(thing) && SvROK(thing)) {
 676     thing = SvRV(thing);
 677   }
 678
 679   /* Put it on the pending array */
 680   av_push(pending_array, thing);
 681
 682   /* Now just yank things off the end of the array until it's done */
 683   while (av_len(pending_array) >= 0) {
 684     thing = av_pop(pending_array);
 685     /* Process it if we've not seen it */
 686     if (check_new(tracking_hash, thing)) {
 687       /* Is it valid? */
 688       if (thing) {
 689         /* printf ("Found type %i at %p\n", SvTYPE(thing), thing); */
 690
 691         /* Yes, it is. So let's check the type */
 692         switch (SvTYPE(thing)) {
 693         case SVt_RV:
 694           av_push(pending_array, SvRV(thing));
 695           break;
 696
 697         /* fix for bug #24846 (Does not correctly recurse into references in a PVNV-type scalar) */
 698         case SVt_PVNV:
 699           if (SvROK(thing))
 700             {
 701             av_push(pending_array, SvRV(thing));
 702             }
 703           break;
 704
 705         case SVt_PVAV:
 706           {
 707             /* Quick alias to cut down on casting */
 708             AV *tempAV = (AV *)thing;
 709             SV **tempSV;
 710
 711             /* Any elements? */
 712             if (av_len(tempAV) != -1) {
 713               IV index;
 714               /* Run through them all */
 715               for (index = 0; index <= av_len(tempAV); index++) {
 716                 /* Did we get something? */
 717                 if ((tempSV = av_fetch(tempAV, index, 0))) {
 718                   /* Was it undef? */
 719                   if (*tempSV != &PL_sv_undef) {
 720                     /* Apparently not. Save it for later */
 721                     av_push(pending_array, *tempSV);
 722                   }
 723                 }
 724               }
 725             }
 726           }
 727           break;
 728
 729         case SVt_PVHV:
 730           /* Is there anything in here? */
 731           if (hv_iterinit((HV *)thing)) {
 732             HE *temp_he;
 733             while ((temp_he = hv_iternext((HV *)thing))) {
 734               av_push(pending_array, hv_iterval((HV *)thing, temp_he));
 735             }
 736           }
 737           break;
 738
 739         case SVt_PVGV:
 740           /* Run through all the pieces and push the ones with bits */
 741           if (GvSV(thing)) {
 742             av_push(pending_array, (SV *)GvSV(thing));
 743           }
 744           if (GvFORM(thing)) {
 745             av_push(pending_array, (SV *)GvFORM(thing));
 746           }
 747           if (GvAV(thing)) {
 748             av_push(pending_array, (SV *)GvAV(thing));
 749           }
 750           if (GvHV(thing)) {
 751             av_push(pending_array, (SV *)GvHV(thing));
 752           }
 753           if (GvCV(thing)) {
 754             av_push(pending_array, (SV *)GvCV(thing));
 755           }
 756           break;
 757         default:
 758           break;
 759         }
 760       }
 761
 762
 763       size = thing_size(thing, tracking_hash);
 764       RETVAL += size;
 765     }
 766   }
 767
 768   /* Clean up after ourselves */
 769   SvREFCNT_dec(tracking_hash);
 770   SvREFCNT_dec(pending_array);
 771 }
 772 OUTPUT:
 773   RETVAL
 774