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