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