Size.xs

   1 /* -*- mode: C -*- */
   2
   3 #define PERL_NO_GET_CONTEXT
   4
   5 #include "EXTERN.h"
   6 #include "perl.h"
   7 #include "XSUB.h"
   8 #include "ppport.h"
   9
  10 /* Not yet in ppport.h */
  11 #ifndef CvISXSUB
  12 #  define CvISXSUB(cv)  (CvXSUB(cv) ? TRUE : FALSE)
  13 #endif
  14 #ifndef SvRV_const
  15 #  define SvRV_const(rv) SvRV(rv)
  16 #endif
  17 #ifndef SvOOK_offset
  18 #  define SvOOK_offset(sv, len) STMT_START { len = SvIVX(sv); } STMT_END
  19 #endif
  20 #ifndef SvIsCOW
  21 #  define SvIsCOW(sv)           ((SvFLAGS(sv) & (SVf_FAKE | SVf_READONLY)) == \
  22                                     (SVf_FAKE | SVf_READONLY))
  23 #endif
  24 #ifndef SvIsCOW_shared_hash
  25 #  define SvIsCOW_shared_hash(sv)   (SvIsCOW(sv) && SvLEN(sv) == 0)
  26 #endif
  27 #ifndef SvSHARED_HEK_FROM_PV
  28 #  define SvSHARED_HEK_FROM_PV(pvx) \
  29         ((struct hek*)(pvx - STRUCT_OFFSET(struct hek, hek_key)))
  30 #endif
  31
  32 #if PERL_VERSION < 6
  33 #  define PL_opargs opargs
  34 #  define PL_op_name op_name
  35 #endif
  36
  37 #ifdef _MSC_VER
  38 /* "structured exception" handling is a Microsoft extension to C and C++.
  39    It's *not* C++ exception handling - C++ exception handling can't capture
  40    SEGVs and suchlike, whereas this can. There's no known analagous
  41     functionality on other platforms.  */
  42 #  include <excpt.h>
  43 #  define TRY_TO_CATCH_SEGV __try
  44 #  define CAUGHT_EXCEPTION __except(EXCEPTION_EXECUTE_HANDLER)
  45 #else
  46 #  define TRY_TO_CATCH_SEGV if(1)
  47 #  define CAUGHT_EXCEPTION else
  48 #endif
  49
  50 #ifdef __GNUC__
  51 # define __attribute__(x)
  52 #endif
  53
  54 #if 0 && defined(DEBUGGING)
  55 #define dbg_printf(x) printf x
  56 #else
  57 #define dbg_printf(x)
  58 #endif
  59
  60 #define TAG /* printf( "# %s(%d)\n", __FILE__, __LINE__ ) */
  61 #define carp puts
  62
  63 /* The idea is to have a tree structure to store 1 bit per possible pointer
  64    address. The lowest 16 bits are stored in a block of 8092 bytes.
  65    The blocks are in a 256-way tree, indexed by the reset of the pointer.
  66    This can cope with 32 and 64 bit pointers, and any address space layout,
  67    without excessive memory needs. The assumption is that your CPU cache
  68    works :-) (And that we're not going to bust it)  */
  69
  70 #define BYTE_BITS    3
  71 #define LEAF_BITS   (16 - BYTE_BITS)
  72 #define LEAF_MASK   0x1FFF
  73
  74 struct state {
  75     UV total_size;
  76     bool regex_whine;
  77     bool fm_whine;
  78     bool dangle_whine;
  79     bool go_yell;
  80     /* My hunch (not measured) is that for most architectures pointers will
  81        start with 0 bits, hence the start of this array will be hot, and the
  82        end unused. So put the flags next to the hot end.  */
  83     void *tracking[256];
  84 };
  85
  86 /*
  87     Checks to see if thing is in the bitstring.
  88     Returns true or false, and
  89     notes thing in the segmented bitstring.
  90  */
  91 static bool
  92 check_new(struct state *st, const void *const p) {
  93     unsigned int bits = 8 * sizeof(void*);
  94     const size_t raw_p = PTR2nat(p);
  95     /* This effectively rotates the value right by the number of low always-0
  96        bits in an aligned pointer. The assmption is that most (if not all)
  97        pointers are aligned, and these will be in the same chain of nodes
  98        (and hence hot in the cache) but we can still deal with any unaligned
  99        pointers.  */
 100     const size_t cooked_p
 101         = (raw_p >> ALIGN_BITS) | (raw_p << (bits - ALIGN_BITS));
 102     const U8 this_bit = 1 << (cooked_p & 0x7);
 103     U8 **leaf_p;
 104     U8 *leaf;
 105     unsigned int i;
 106     void **tv_p = (void **) (st->tracking);
 107
 108     if (NULL == p) return FALSE;
 109     TRY_TO_CATCH_SEGV {
 110         const char c = *(const char *)p;
 111     }
 112     CAUGHT_EXCEPTION {
 113         if (st->dangle_whine)
 114             warn( "Devel::Size: Encountered invalid pointer: %p\n", p );
 115         return FALSE;
 116     }
 117     TAG;
 118
 119     bits -= 8;
 120     /* bits now 24 (32 bit pointers) or 56 (64 bit pointers) */
 121
 122     /* First level is always present.  */
 123     do {
 124         i = (unsigned int)((cooked_p >> bits) & 0xFF);
 125         if (!tv_p[i])
 126             Newxz(tv_p[i], 256, void *);
 127         tv_p = (void **)(tv_p[i]);
 128         bits -= 8;
 129     } while (bits > LEAF_BITS + BYTE_BITS);
 130     /* bits now 16 always */
 131 #if !defined(MULTIPLICITY) || PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 8)
 132     /* 5.8.8 and early have an assert() macro that uses Perl_croak, hence needs
 133        a my_perl under multiplicity  */
 134     assert(bits == 16);
 135 #endif
 136     leaf_p = (U8 **)tv_p;
 137     i = (unsigned int)((cooked_p >> bits) & 0xFF);
 138     if (!leaf_p[i])
 139         Newxz(leaf_p[i], 1 << LEAF_BITS, U8);
 140     leaf = leaf_p[i];
 141
 142     TAG;
 143
 144     i = (unsigned int)((cooked_p >> BYTE_BITS) & LEAF_MASK);
 145
 146     if(leaf[i] & this_bit)
 147         return FALSE;
 148
 149     leaf[i] |= this_bit;
 150     return TRUE;
 151 }
 152
 153 static void
 154 free_tracking_at(void **tv, int level)
 155 {
 156     int i = 255;
 157
 158     if (--level) {
 159         /* Nodes */
 160         do {
 161             if (tv[i]) {
 162                 free_tracking_at((void **) tv[i], level);
 163                 Safefree(tv[i]);
 164             }
 165         } while (i--);
 166     } else {
 167         /* Leaves */
 168         do {
 169             if (tv[i])
 170                 Safefree(tv[i]);
 171         } while (i--);
 172     }
 173 }
 174
 175 static void
 176 free_state(struct state *st)
 177 {
 178     const int top_level = (sizeof(void *) * 8 - LEAF_BITS - BYTE_BITS) / 8;
 179     free_tracking_at((void **)st->tracking, top_level);
 180     Safefree(st);
 181 }
 182
 183 /* For now, this is somewhat a compatibility bodge until the plan comes
 184    together for fine grained recursion control. total_size() would recurse into
 185    hash and array members, whereas sv_size() would not. However, sv_size() is
 186    called with CvSTASH() of a CV, which means that if it (also) starts to
 187    recurse fully, then the size of any CV now becomes the size of the entire
 188    symbol table reachable from it, and potentially the entire symbol table, if
 189    any subroutine makes a reference to a global (such as %SIG). The historical
 190    implementation of total_size() didn't report "everything", and changing the
 191    only available size to "everything" doesn't feel at all useful.  */
 192
 193 #define NO_RECURSION 0
 194 #define SOME_RECURSION 1
 195 #define TOTAL_SIZE_RECURSION 2
 196
 197 static void sv_size(pTHX_ struct state *, const SV *const, const int recurse);
 198
 199 typedef enum {
 200     OPc_NULL,   /* 0 */
 201     OPc_BASEOP, /* 1 */
 202     OPc_UNOP,   /* 2 */
 203     OPc_BINOP,  /* 3 */
 204     OPc_LOGOP,  /* 4 */
 205     OPc_LISTOP, /* 5 */
 206     OPc_PMOP,   /* 6 */
 207     OPc_SVOP,   /* 7 */
 208     OPc_PADOP,  /* 8 */
 209     OPc_PVOP,   /* 9 */
 210     OPc_LOOP,   /* 10 */
 211     OPc_COP /* 11 */
 212 #ifdef OA_CONDOP
 213     , OPc_CONDOP /* 12 */
 214 #endif
 215 #ifdef OA_GVOP
 216     , OPc_GVOP /* 13 */
 217 #endif
 218 #ifdef OA_METHOP
 219     , OPc_METHOP
 220 #endif
 221 #ifdef OA_UNOP_AUX
 222     , OPc_UNAUXOP
 223 #endif
 224
 225 } opclass;
 226
 227 static opclass
 228 cc_opclass(const OP * const o)
 229 {
 230     if (!o)
 231     return OPc_NULL;
 232     TRY_TO_CATCH_SEGV {
 233         if (o->op_type == 0)
 234         return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
 235
 236         if (o->op_type == OP_SASSIGN)
 237         return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
 238
 239     #ifdef USE_ITHREADS
 240         if (o->op_type == OP_GV || o->op_type == OP_GVSV || o->op_type == OP_AELEMFAST)
 241         return OPc_PADOP;
 242     #endif
 243
 244         if ((o->op_type == OP_TRANS)) {
 245           return OPc_BASEOP;
 246         }
 247
 248         switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
 249         case OA_BASEOP: TAG;
 250         return OPc_BASEOP;
 251
 252         case OA_UNOP: TAG;
 253         return OPc_UNOP;
 254
 255         case OA_BINOP: TAG;
 256         return OPc_BINOP;
 257
 258         case OA_LOGOP: TAG;
 259         return OPc_LOGOP;
 260
 261         case OA_LISTOP: TAG;
 262         return OPc_LISTOP;
 263
 264         case OA_PMOP: TAG;
 265         return OPc_PMOP;
 266
 267         case OA_SVOP: TAG;
 268         return OPc_SVOP;
 269
 270 #ifdef OA_PADOP
 271         case OA_PADOP: TAG;
 272         return OPc_PADOP;
 273 #endif
 274
 275 #ifdef OA_GVOP
 276         case OA_GVOP: TAG;
 277         return OPc_GVOP;
 278 #endif
 279
 280 #ifdef OA_PVOP_OR_SVOP
 281         case OA_PVOP_OR_SVOP: TAG;
 282             /*
 283              * Character translations (tr///) are usually a PVOP, keeping a
 284              * pointer to a table of shorts used to look up translations.
 285              * Under utf8, however, a simple table isn't practical; instead,
 286              * the OP is an SVOP, and the SV is a reference to a swash
 287              * (i.e., an RV pointing to an HV).
 288              */
 289         return (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
 290             ? OPc_SVOP : OPc_PVOP;
 291 #endif
 292
 293         case OA_LOOP: TAG;
 294         return OPc_LOOP;
 295
 296         case OA_COP: TAG;
 297         return OPc_COP;
 298
 299         case OA_BASEOP_OR_UNOP: TAG;
 300         /*
 301          * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
 302          * whether parens were seen. perly.y uses OPf_SPECIAL to
 303          * signal whether a BASEOP had empty parens or none.
 304          * Some other UNOPs are created later, though, so the best
 305          * test is OPf_KIDS, which is set in newUNOP.
 306          */
 307         return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
 308
 309         case OA_FILESTATOP: TAG;
 310         /*
 311          * The file stat OPs are created via UNI(OP_foo) in toke.c but use
 312          * the OPf_REF flag to distinguish between OP types instead of the
 313          * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
 314          * return OPc_UNOP so that walkoptree can find our children. If
 315          * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
 316          * (no argument to the operator) it's an OP; with OPf_REF set it's
 317          * an SVOP (and op_sv is the GV for the filehandle argument).
 318          */
 319         return ((o->op_flags & OPf_KIDS) ? OPc_UNOP :
 320     #ifdef USE_ITHREADS
 321             (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP);
 322     #else
 323             (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP);
 324     #endif
 325         case OA_LOOPEXOP: TAG;
 326         /*
 327          * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
 328          * label was omitted (in which case it's a BASEOP) or else a term was
 329          * seen. In this last case, all except goto are definitely PVOP but
 330          * goto is either a PVOP (with an ordinary constant label), an UNOP
 331          * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
 332          * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
 333          * get set.
 334          */
 335         if (o->op_flags & OPf_STACKED)
 336             return OPc_UNOP;
 337         else if (o->op_flags & OPf_SPECIAL)
 338             return OPc_BASEOP;
 339         else
 340             return OPc_PVOP;
 341
 342 #ifdef OA_CONDOP
 343         case OA_CONDOP: TAG;
 344             return OPc_CONDOP;
 345 #endif
 346
 347 #ifdef OA_METHOP
 348         case OA_METHOP: TAG;
 349             return OPc_METHOP;
 350 #endif
 351 #ifdef OA_UNOP_AUX
 352         case OA_UNOP_AUX: TAG;
 353             return OPc_UNAUXOP;
 354 #endif
 355         }
 356         warn("Devel::Size: Can't determine class of operator %s, assuming BASEOP\n",
 357          PL_op_name[o->op_type]);
 358     }
 359     CAUGHT_EXCEPTION { }
 360     return OPc_BASEOP;
 361 }
 362
 363 /* Figure out how much magic is attached to the SV and return the
 364    size */
 365 static void
 366 magic_size(pTHX_ const SV * const thing, struct state *st) {
 367   MAGIC *magic_pointer = SvMAGIC(thing);
 368
 369   /* Have we seen the magic pointer?  (NULL has always been seen before)  */
 370   while (check_new(st, magic_pointer)) {
 371     st->total_size += sizeof(MAGIC);
 372     /* magic vtables aren't freed when magic is freed, so don't count them.
 373        (They are static structures. Anything that assumes otherwise is buggy.)
 374     */
 375
 376
 377     TRY_TO_CATCH_SEGV {
 378         sv_size(aTHX_ st, magic_pointer->mg_obj, TOTAL_SIZE_RECURSION);
 379         if (magic_pointer->mg_len == HEf_SVKEY) {
 380             sv_size(aTHX_ st, (SV *)magic_pointer->mg_ptr, TOTAL_SIZE_RECURSION);
 381         }
 382 #if defined(PERL_MAGIC_utf8) && defined (PERL_MAGIC_UTF8_CACHESIZE)
 383         else if (magic_pointer->mg_type == PERL_MAGIC_utf8) {
 384             if (check_new(st, magic_pointer->mg_ptr)) {
 385                 st->total_size += PERL_MAGIC_UTF8_CACHESIZE * 2 * sizeof(STRLEN);
 386             }
 387         }
 388 #endif
 389         else if (magic_pointer->mg_len > 0) {
 390             if (check_new(st, magic_pointer->mg_ptr)) {
 391                 st->total_size += magic_pointer->mg_len;
 392             }
 393         }
 394
 395         /* Get the next in the chain */
 396         magic_pointer = magic_pointer->mg_moremagic;
 397     }
 398     CAUGHT_EXCEPTION {
 399         if (st->dangle_whine)
 400             warn( "Devel::Size: Encountered bad magic at: %p\n", magic_pointer );
 401     }
 402   }
 403 }
 404
 405 static void
 406 check_new_and_strlen(struct state *st, const char *const p) {
 407     if(check_new(st, p))
 408         st->total_size += 1 + strlen(p);
 409 }
 410
 411 static void
 412 regex_size(const REGEXP * const baseregex, struct state *st) {
 413     if(!check_new(st, baseregex))
 414         return;
 415   st->total_size += sizeof(REGEXP);
 416 #if (PERL_VERSION < 11)
 417   /* Note the size of the paren offset thing */
 418   st->total_size += sizeof(I32) * baseregex->nparens * 2;
 419   st->total_size += strlen(baseregex->precomp);
 420 #else
 421   st->total_size += sizeof(struct regexp);
 422   st->total_size += sizeof(I32) * SvANY(baseregex)->nparens * 2;
 423   /*st->total_size += strlen(SvANY(baseregex)->subbeg);*/
 424 #endif
 425   if (st->go_yell && !st->regex_whine) {
 426     carp("Devel::Size: Calculated sizes for compiled regexes are incompatible, and probably always will be");
 427     st->regex_whine = 1;
 428   }
 429 }
 430
 431 static void
 432 op_size(pTHX_ const OP * const baseop, struct state *st)
 433 {
 434     TRY_TO_CATCH_SEGV {
 435         TAG;
 436         if(!check_new(st, baseop))
 437             return;
 438         TAG;
 439         op_size(aTHX_ baseop->op_next, st);
 440         TAG;
 441         switch (cc_opclass(baseop)) {
 442         case OPc_BASEOP: TAG;
 443             st->total_size += sizeof(struct op);
 444             TAG;break;
 445         case OPc_UNOP: TAG;
 446             st->total_size += sizeof(struct unop);
 447             op_size(aTHX_ ((UNOP *)baseop)->op_first, st);
 448             TAG;break;
 449         case OPc_BINOP: TAG;
 450             st->total_size += sizeof(struct binop);
 451             op_size(aTHX_ ((BINOP *)baseop)->op_first, st);
 452             op_size(aTHX_ ((BINOP *)baseop)->op_last, st);
 453             TAG;break;
 454         case OPc_LOGOP: TAG;
 455             st->total_size += sizeof(struct logop);
 456             op_size(aTHX_ ((BINOP *)baseop)->op_first, st);
 457             op_size(aTHX_ ((LOGOP *)baseop)->op_other, st);
 458             TAG;break;
 459 #ifdef OA_CONDOP
 460         case OPc_CONDOP: TAG;
 461             st->total_size += sizeof(struct condop);
 462             op_size(aTHX_ ((BINOP *)baseop)->op_first, st);
 463             op_size(aTHX_ ((CONDOP *)baseop)->op_true, st);
 464             op_size(aTHX_ ((CONDOP *)baseop)->op_false, st);
 465             TAG;break;
 466 #endif
 467         case OPc_LISTOP: TAG;
 468             st->total_size += sizeof(struct listop);
 469             op_size(aTHX_ ((LISTOP *)baseop)->op_first, st);
 470             op_size(aTHX_ ((LISTOP *)baseop)->op_last, st);
 471             TAG;break;
 472         case OPc_PMOP: TAG;
 473             st->total_size += sizeof(struct pmop);
 474             op_size(aTHX_ ((PMOP *)baseop)->op_first, st);
 475             op_size(aTHX_ ((PMOP *)baseop)->op_last, st);
 476 #if PERL_VERSION < 9 || (PERL_VERSION == 9 && PERL_SUBVERSION < 5)
 477             op_size(aTHX_ ((PMOP *)baseop)->op_pmreplroot, st);
 478             op_size(aTHX_ ((PMOP *)baseop)->op_pmreplstart, st);
 479 #endif
 480             /* This is defined away in perl 5.8.x, but it is in there for
 481                5.6.x */
 482 #ifdef PM_GETRE
 483             regex_size(PM_GETRE((PMOP *)baseop), st);
 484 #else
 485             regex_size(((PMOP *)baseop)->op_pmregexp, st);
 486 #endif
 487             TAG;break;
 488         case OPc_SVOP: TAG;
 489             st->total_size += sizeof(struct pmop);
 490             if (!(baseop->op_type == OP_AELEMFAST
 491                   && baseop->op_flags & OPf_SPECIAL)) {
 492                 /* not an OP_PADAV replacement */
 493                 sv_size(aTHX_ st, ((SVOP *)baseop)->op_sv, SOME_RECURSION);
 494             }
 495             TAG;break;
 496 #ifdef OA_PADOP
 497       case OPc_PADOP: TAG;
 498           st->total_size += sizeof(struct padop);
 499           TAG;break;
 500 #endif
 501 #ifdef OA_GVOP
 502       case OPc_GVOP: TAG;
 503           st->total_size += sizeof(struct gvop);
 504           sv_size(aTHX_ st, ((GVOP *)baseop)->op_gv, SOME_RECURSION);
 505           TAG;break;
 506 #endif
 507         case OPc_PVOP: TAG;
 508             check_new_and_strlen(st, ((PVOP *)baseop)->op_pv);
 509             TAG;break;
 510         case OPc_LOOP: TAG;
 511             st->total_size += sizeof(struct loop);
 512             op_size(aTHX_ ((LOOP *)baseop)->op_first, st);
 513             op_size(aTHX_ ((LOOP *)baseop)->op_last, st);
 514             op_size(aTHX_ ((LOOP *)baseop)->op_redoop, st);
 515             op_size(aTHX_ ((LOOP *)baseop)->op_nextop, st);
 516             op_size(aTHX_ ((LOOP *)baseop)->op_lastop, st);
 517             TAG;break;
 518         case OPc_COP: TAG;
 519         {
 520           COP *basecop;
 521           basecop = (COP *)baseop;
 522           st->total_size += sizeof(struct cop);
 523
 524           /* Change 33656 by nicholas@mouse-mill on 2008/04/07 11:29:51
 525           Eliminate cop_label from struct cop by storing a label as the first
 526           entry in the hints hash. Most statements don't have labels, so this
 527           will save memory. Not sure how much.
 528           The check below will be incorrect fail on bleadperls
 529           before 5.11 @33656, but later than 5.10, producing slightly too
 530           small memory sizes on these Perls. */
 531 #if (PERL_VERSION < 11)
 532           check_new_and_strlen(st, basecop->cop_label);
 533 #endif
 534 #ifdef USE_ITHREADS
 535           check_new_and_strlen(st, basecop->cop_file);
 536 #if PERL_VERSION < 17 || (PERL_VERSION == 17 && PERL_SUBVERSION == 0)
 537           /* This pointer is owned by the COP, and freed with it.  */
 538           check_new_and_strlen(st, basecop->cop_stashpv);
 539 #else
 540           /* A per-interpreter pointer for this stash is allocated in
 541              PL_stashpad. */
 542           if (check_new(st, PL_stashpad + basecop->cop_stashoff))
 543               st->total_size += sizeof(PL_stashpad[basecop->cop_stashoff]);
 544 #endif
 545 #else
 546           sv_size(aTHX_ st, (SV *)basecop->cop_filegv, SOME_RECURSION);
 547 #endif
 548
 549         }
 550         TAG;break;
 551 #ifdef OA_METHOP
 552         case OPc_METHOP: TAG;
 553             st->total_size += sizeof(struct methop);
 554             if (baseop->op_type == OP_METHOD)
 555                 op_size(aTHX_ ((UNOP *)baseop)->op_first, st);
 556             else
 557                 sv_size(aTHX_ st, cMETHOPx_meth(baseop), SOME_RECURSION);
 558 #if PERL_VERSION*1000+PERL_SUBVERSION >= 21007
 559             if (baseop->op_type == OP_METHOD_REDIR || baseop->op_type == OP_METHOD_REDIR_SUPER) {
 560                 SV *rclass = cMETHOPx_rclass(baseop);
 561                 if(SvTYPE(rclass) != SVt_PVHV)
 562                     sv_size(aTHX_ st, rclass, SOME_RECURSION);
 563             }
 564 #endif
 565             TAG;break;
 566 #endif
 567 #ifdef OA_UNOP_AUX
 568         case OPc_UNAUXOP: TAG;
 569             st->total_size += sizeof(struct unop_aux) + sizeof(UNOP_AUX_item) * (cUNOP_AUXx(baseop)->op_aux[-1].uv+1);
 570             op_size(aTHX_ ((UNOP *)baseop)->op_first, st);
 571             if (baseop->op_type == OP_MULTIDEREF) {
 572                 UNOP_AUX_item *items = cUNOP_AUXx(baseop)->op_aux;
 573                 UV actions = items->uv;
 574                 bool last = 0;
 575                 bool is_hash = 0;
 576                 while (!last) {
 577                     switch (actions & MDEREF_ACTION_MASK) {
 578                         case MDEREF_reload:
 579                             actions = (++items)->uv;
 580                             continue;
 581                         case MDEREF_HV_padhv_helem:
 582                         case MDEREF_HV_gvhv_helem:
 583                         case MDEREF_HV_gvsv_vivify_rv2hv_helem:
 584                         case MDEREF_HV_padsv_vivify_rv2hv_helem:
 585                             is_hash = 1;
 586                         case MDEREF_AV_padav_aelem:
 587                         case MDEREF_AV_gvav_aelem:
 588                         case MDEREF_AV_gvsv_vivify_rv2av_aelem:
 589                         case MDEREF_AV_padsv_vivify_rv2av_aelem:
 590                             ++items;
 591                             goto do_elem;
 592                         case MDEREF_HV_pop_rv2hv_helem:
 593                         case MDEREF_HV_vivify_rv2hv_helem:
 594                             is_hash = 1;
 595                         case MDEREF_AV_pop_rv2av_aelem:
 596                         case MDEREF_AV_vivify_rv2av_aelem:
 597                         do_elem:
 598                             switch (actions & MDEREF_INDEX_MASK) {
 599                                 case MDEREF_INDEX_none:
 600                                     last = 1;
 601                                     break;
 602                                 case MDEREF_INDEX_const:
 603                                     ++items;
 604                                     if (is_hash) {
 605 #ifdef USE_ITHREADS
 606                                         SV *key = PAD_SVl(items->pad_offset);
 607 #else
 608                                         SV *key = items->sv;
 609 #endif
 610                                         sv_size(aTHX_ st, key, SOME_RECURSION);
 611                                     }
 612                                     break;
 613                                 case MDEREF_INDEX_padsv:
 614                                 case MDEREF_INDEX_gvsv:
 615                                     ++items;
 616                                     break;
 617                             }
 618                             if (actions & MDEREF_FLAG_last)
 619                                 last = 1;
 620                             is_hash = 0;
 621                             break;
 622                         default:
 623                             last = 1;
 624                             break;
 625                     }
 626                     actions >>= MDEREF_SHIFT;
 627                 }
 628             }
 629             TAG;break;
 630 #endif
 631       default:
 632         TAG;break;
 633       }
 634   }
 635   CAUGHT_EXCEPTION {
 636       if (st->dangle_whine)
 637           warn( "Devel::Size: Encountered dangling pointer in opcode at: %p\n", baseop );
 638   }
 639 }
 640
 641 static void
 642 hek_size(pTHX_ struct state *st, HEK *hek, U32 shared)
 643 {
 644     /* Hash keys can be shared. Have we seen this before? */
 645     if (!check_new(st, hek))
 646         return;
 647     st->total_size += HEK_BASESIZE + hek->hek_len
 648 #if PERL_VERSION < 8
 649         + 1 /* No hash key flags prior to 5.8.0  */
 650 #else
 651         + 2
 652 #endif
 653         ;
 654     if (shared) {
 655 #if PERL_VERSION < 10
 656         st->total_size += sizeof(struct he);
 657 #else
 658         st->total_size += STRUCT_OFFSET(struct shared_he, shared_he_hek);
 659 #endif
 660     }
 661 }
 662
 663
 664 #if PERL_VERSION < 8 || PERL_SUBVERSION < 9
 665 #  define SVt_LAST 16
 666 #endif
 667
 668 #ifdef PURIFY
 669 #  define MAYBE_PURIFY(normal, pure) (pure)
 670 #  define MAYBE_OFFSET(struct_name, member) 0
 671 #else
 672 #  define MAYBE_PURIFY(normal, pure) (normal)
 673 #  define MAYBE_OFFSET(struct_name, member) STRUCT_OFFSET(struct_name, member)
 674 #endif
 675
 676 const U8 body_sizes[SVt_LAST] = {
 677 #if PERL_VERSION < 9
 678      0,                                                       /* SVt_NULL */
 679      MAYBE_PURIFY(sizeof(IV), sizeof(XPVIV)),                 /* SVt_IV */
 680      MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)),                 /* SVt_NV */
 681      sizeof(XRV),                                             /* SVt_RV */
 682      sizeof(XPV),                                             /* SVt_PV */
 683      sizeof(XPVIV),                                           /* SVt_PVIV */
 684      sizeof(XPVNV),                                           /* SVt_PVNV */
 685      sizeof(XPVMG),                                           /* SVt_PVMG */
 686      sizeof(XPVBM),                                           /* SVt_PVBM */
 687      sizeof(XPVLV),                                           /* SVt_PVLV */
 688      sizeof(XPVAV),                                           /* SVt_PVAV */
 689      sizeof(XPVHV),                                           /* SVt_PVHV */
 690      sizeof(XPVCV),                                           /* SVt_PVCV */
 691      sizeof(XPVGV),                                           /* SVt_PVGV */
 692      sizeof(XPVFM),                                           /* SVt_PVFM */
 693      sizeof(XPVIO)                                            /* SVt_PVIO */
 694 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 0
 695      0,                                                       /* SVt_NULL */
 696      0,                                                       /* SVt_BIND */
 697      0,                                                       /* SVt_IV */
 698      MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)),                 /* SVt_NV */
 699      0,                                                       /* SVt_RV */
 700      MAYBE_PURIFY(sizeof(xpv_allocated), sizeof(XPV)),        /* SVt_PV */
 701      MAYBE_PURIFY(sizeof(xpviv_allocated), sizeof(XPVIV)),/* SVt_PVIV */
 702      sizeof(XPVNV),                                           /* SVt_PVNV */
 703      sizeof(XPVMG),                                           /* SVt_PVMG */
 704      sizeof(XPVGV),                                           /* SVt_PVGV */
 705      sizeof(XPVLV),                                           /* SVt_PVLV */
 706      MAYBE_PURIFY(sizeof(xpvav_allocated), sizeof(XPVAV)),/* SVt_PVAV */
 707      MAYBE_PURIFY(sizeof(xpvhv_allocated), sizeof(XPVHV)),/* SVt_PVHV */
 708      MAYBE_PURIFY(sizeof(xpvcv_allocated), sizeof(XPVCV)),/* SVt_PVCV */
 709      MAYBE_PURIFY(sizeof(xpvfm_allocated), sizeof(XPVFM)),/* SVt_PVFM */
 710      sizeof(XPVIO),                                           /* SVt_PVIO */
 711 #elif PERL_VERSION == 10 && PERL_SUBVERSION == 1
 712      0,                                                       /* SVt_NULL */
 713      0,                                                       /* SVt_BIND */
 714      0,                                                       /* SVt_IV */
 715      MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)),                 /* SVt_NV */
 716      0,                                                       /* SVt_RV */
 717      sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur),                /* SVt_PV */
 718      sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur),              /* SVt_PVIV */
 719      sizeof(XPVNV),                                           /* SVt_PVNV */
 720      sizeof(XPVMG),                                           /* SVt_PVMG */
 721      sizeof(XPVGV),                                           /* SVt_PVGV */
 722      sizeof(XPVLV),                                           /* SVt_PVLV */
 723      sizeof(XPVAV) - MAYBE_OFFSET(XPVAV, xav_fill),           /* SVt_PVAV */
 724      sizeof(XPVHV) - MAYBE_OFFSET(XPVHV, xhv_fill),           /* SVt_PVHV */
 725      sizeof(XPVCV) - MAYBE_OFFSET(XPVCV, xpv_cur),            /* SVt_PVCV */
 726      sizeof(XPVFM) - MAYBE_OFFSET(XPVFM, xpv_cur),            /* SVt_PVFM */
 727      sizeof(XPVIO)                                            /* SVt_PVIO */
 728 #elif PERL_VERSION < 13
 729      0,                                                       /* SVt_NULL */
 730      0,                                                       /* SVt_BIND */
 731      0,                                                       /* SVt_IV */
 732      MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)),                 /* SVt_NV */
 733      sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur),                /* SVt_PV */
 734      sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur),              /* SVt_PVIV */
 735      sizeof(XPVNV),                                           /* SVt_PVNV */
 736      sizeof(XPVMG),                                           /* SVt_PVMG */
 737      sizeof(regexp) - MAYBE_OFFSET(regexp, xpv_cur),          /* SVt_REGEXP */
 738      sizeof(XPVGV),                                           /* SVt_PVGV */
 739      sizeof(XPVLV),                                           /* SVt_PVLV */
 740      sizeof(XPVAV) - MAYBE_OFFSET(XPVAV, xav_fill),           /* SVt_PVAV */
 741      sizeof(XPVHV) - MAYBE_OFFSET(XPVHV, xhv_fill),           /* SVt_PVHV */
 742      sizeof(XPVCV) - MAYBE_OFFSET(XPVCV, xpv_cur),            /* SVt_PVCV */
 743      sizeof(XPVFM) - MAYBE_OFFSET(XPVFM, xpv_cur),            /* SVt_PVFM */
 744      sizeof(XPVIO)                                            /* SVt_PVIO */
 745 #else
 746      0,                                                       /* SVt_NULL */
 747      0,                                                       /* SVt_BIND */
 748      0,                                                       /* SVt_IV */
 749      MAYBE_PURIFY(sizeof(NV), sizeof(XPVNV)),                 /* SVt_NV */
 750      sizeof(XPV) - MAYBE_OFFSET(XPV, xpv_cur),                /* SVt_PV */
 751      sizeof(XPVIV) - MAYBE_OFFSET(XPV, xpv_cur),              /* SVt_PVIV */
 752      sizeof(XPVNV) - MAYBE_OFFSET(XPV, xpv_cur),              /* SVt_PVNV */
 753      sizeof(XPVMG),                                           /* SVt_PVMG */
 754      sizeof(regexp),                                          /* SVt_REGEXP */
 755      sizeof(XPVGV),                                           /* SVt_PVGV */
 756      sizeof(XPVLV),                                           /* SVt_PVLV */
 757      sizeof(XPVAV),                                           /* SVt_PVAV */
 758      sizeof(XPVHV),                                           /* SVt_PVHV */
 759      sizeof(XPVCV),                                           /* SVt_PVCV */
 760      sizeof(XPVFM),                                           /* SVt_PVFM */
 761      sizeof(XPVIO)                                            /* SVt_PVIO */
 762 #endif
 763 };
 764
 765 #if PERL_VERSION*1000+PERL_SUBVERSION >= 21007
 766 /* This is, as ever, excessively nosey with the implementation, and hence
 767    fragile. */
 768 padlist_size(pTHX_ struct state *const st, const PADLIST * const padl,
 769         const int recurse) {
 770     SSize_t i;
 771     const PADNAMELIST *pnl;
 772
 773     if (!check_new(st, padl))
 774         return;
 775     st->total_size += sizeof(PADLIST);
 776
 777     st->total_size += sizeof(PADNAMELIST);
 778     pnl = PadlistNAMES(padl);
 779     st->total_size += pnl->xpadnl_max * sizeof(PADNAME *);
 780     i = PadnamelistMAX(pnl) + 1;
 781     while (--i) {
 782         const PADNAME *const pn =
 783                 PadnamelistARRAY(pnl)[i];
 784         if (!pn || pn == &PL_padname_undef || pn == &PL_padname_const)
 785             continue;
 786         if (!check_new(st, pn))
 787             continue;
 788         st->total_size += STRUCT_OFFSET(struct padname_with_str, xpadn_str[0])
 789             + PadnameLEN(pn) + 1;
 790     }
 791
 792     i = PadlistMAX(padl) + 1;
 793     st->total_size += sizeof(PAD*) * i;
 794     while (--i)
 795         sv_size(aTHX_ st, (SV*)PadlistARRAY(padl)[i], recurse);
 796 }
 797
 798 #elif defined PadlistNAMES
 799 static void
 800 padlist_size(pTHX_ struct state *const st, const PADLIST * const padl,
 801         const int recurse) {
 802     SSize_t i;
 803     if (!check_new(st, padl))
 804         return;
 805     st->total_size += sizeof(PADLIST);
 806     sv_size(aTHX_ st, (SV*)PadlistNAMES(padl), TOTAL_SIZE_RECURSION);
 807     i = PadlistMAX(padl) + 1;
 808     st->total_size += sizeof(PAD*) * i;
 809     while (--i)
 810         sv_size(aTHX_ st, (SV*)PadlistARRAY(padl)[i], recurse);
 811 }
 812 #else
 813 static void
 814 padlist_size(pTHX_ struct state *const st, const AV * const padl,
 815         const int recurse) {
 816     sv_size(aTHX_ st, (SV*)padl, recurse);
 817 }
 818 #endif
 819
 820 static void
 821 sv_size(pTHX_ struct state *const st, const SV * const orig_thing,
 822         const int recurse) {
 823   const SV *thing = orig_thing;
 824   U32 type;
 825
 826   if(!check_new(st, thing))
 827       return;
 828
 829   type = SvTYPE(thing);
 830   if (type > SVt_LAST) {
 831       warn("Devel::Size: Unknown variable type: %d encountered\n", type);
 832       return;
 833   }
 834   st->total_size += sizeof(SV) + body_sizes[type];
 835
 836   if (SvMAGICAL(thing)) {
 837       magic_size(aTHX_ thing, st);
 838   }
 839
 840   switch (type) {
 841 #if (PERL_VERSION < 11)
 842     /* Is it a reference? */
 843   case SVt_RV: TAG;
 844 #else
 845   case SVt_IV: TAG;
 846 #endif
 847     if(recurse && SvROK(thing))
 848         sv_size(aTHX_ st, SvRV_const(thing), recurse);
 849     TAG;break;
 850
 851   case SVt_PVAV: TAG;
 852     /* Is there anything in the array? */
 853     if (AvMAX(thing) != -1) {
 854       /* an array with 10 slots has AvMax() set to 9 - te 2007-04-22 */
 855       st->total_size += sizeof(SV *) * (AvMAX(thing) + 1);
 856       dbg_printf(("total_size: %li AvMAX: %li av_len: $i\n", st->total_size, AvMAX(thing), av_len((AV*)thing)));
 857
 858       if (recurse >= TOTAL_SIZE_RECURSION) {
 859           SSize_t i = AvFILLp(thing) + 1;
 860
 861           while (i--)
 862               sv_size(aTHX_ st, AvARRAY(thing)[i], recurse);
 863       }
 864     }
 865     /* Add in the bits on the other side of the beginning */
 866
 867     dbg_printf(("total_size %li, sizeof(SV *) %li, AvARRAY(thing) %li, AvALLOC(thing)%li , sizeof(ptr) %li \n",
 868     st->total_size, sizeof(SV*), AvARRAY(thing), AvALLOC(thing), sizeof( thing )));
 869
 870     /* under Perl 5.8.8 64bit threading, AvARRAY(thing) was a pointer while AvALLOC was 0,
 871        resulting in grossly overstated sized for arrays. Technically, this shouldn't happen... */
 872     if (AvALLOC(thing) != 0) {
 873       st->total_size += (sizeof(SV *) * (AvARRAY(thing) - AvALLOC(thing)));
 874       }
 875 #if (PERL_VERSION < 9)
 876     /* Is there something hanging off the arylen element?
 877        Post 5.9.something this is stored in magic, so will be found there,
 878        and Perl_av_arylen_p() takes a non-const AV*, hence compilers rightly
 879        complain about AvARYLEN() passing thing to it.  */
 880     sv_size(aTHX_ st, AvARYLEN(thing), recurse);
 881 #endif
 882     TAG;break;
 883   case SVt_PVHV: TAG;
 884     /* Now the array of buckets */
 885     st->total_size += (sizeof(HE *) * (HvMAX(thing) + 1));
 886     /* Now walk the bucket chain */
 887     if (HvARRAY(thing)) {
 888       HE *cur_entry;
 889       UV cur_bucket = 0;
 890       for (cur_bucket = 0; cur_bucket <= HvMAX(thing); cur_bucket++) {
 891         cur_entry = *(HvARRAY(thing) + cur_bucket);
 892         while (cur_entry) {
 893           st->total_size += sizeof(HE);
 894           hek_size(aTHX_ st, cur_entry->hent_hek, HvSHAREKEYS(thing));
 895           if (recurse >= TOTAL_SIZE_RECURSION)
 896               sv_size(aTHX_ st, HeVAL(cur_entry), recurse);
 897           cur_entry = cur_entry->hent_next;
 898         }
 899       }
 900     }
 901 #ifdef HvAUX
 902     if (SvOOK(thing)) {
 903         /* This direct access is arguably "naughty": */
 904         struct mro_meta *meta = HvAUX(thing)->xhv_mro_meta;
 905 #if PERL_VERSION > 13 || PERL_SUBVERSION > 8
 906         /* As is this: */
 907         I32 count = HvAUX(thing)->xhv_name_count;
 908
 909         if (count) {
 910             HEK **names = HvAUX(thing)->xhv_name_u.xhvnameu_names;
 911             if (count < 0)
 912                 count = -count;
 913             while (--count)
 914                 hek_size(aTHX_ st, names[count], 1);
 915         }
 916         else
 917 #endif
 918         {
 919             hek_size(aTHX_ st, HvNAME_HEK(thing), 1);
 920         }
 921
 922         st->total_size += sizeof(struct xpvhv_aux);
 923         if (meta) {
 924             st->total_size += sizeof(struct mro_meta);
 925             sv_size(aTHX_ st, (SV *)meta->mro_nextmethod, TOTAL_SIZE_RECURSION);
 926 #if PERL_VERSION > 10 || (PERL_VERSION == 10 && PERL_SUBVERSION > 0)
 927             sv_size(aTHX_ st, (SV *)meta->isa, TOTAL_SIZE_RECURSION);
 928 #endif
 929 #if PERL_VERSION > 10
 930             sv_size(aTHX_ st, (SV *)meta->mro_linear_all, TOTAL_SIZE_RECURSION);
 931             sv_size(aTHX_ st, meta->mro_linear_current, TOTAL_SIZE_RECURSION);
 932 #else
 933             sv_size(aTHX_ st, (SV *)meta->mro_linear_dfs, TOTAL_SIZE_RECURSION);
 934             sv_size(aTHX_ st, (SV *)meta->mro_linear_c3, TOTAL_SIZE_RECURSION);
 935 #endif
 936         }
 937     }
 938 #else
 939     check_new_and_strlen(st, HvNAME_get(thing));
 940 #endif
 941     TAG;break;
 942
 943
 944   case SVt_PVFM: TAG;
 945     if (PERL_VERSION*1000+PERL_SUBVERSION < 21006 || !CvISXSUB(thing))
 946         padlist_size(aTHX_ st, CvPADLIST(thing), SOME_RECURSION);
 947     sv_size(aTHX_ st, (SV *)CvOUTSIDE(thing), recurse);
 948
 949     if (st->go_yell && !st->fm_whine) {
 950       carp("Devel::Size: Calculated sizes for FMs are incomplete");
 951       st->fm_whine = 1;
 952     }
 953     goto freescalar;
 954
 955   case SVt_PVCV: TAG;
 956     sv_size(aTHX_ st, (SV *)CvSTASH(thing), SOME_RECURSION);
 957     sv_size(aTHX_ st, (SV *)SvSTASH(thing), SOME_RECURSION);
 958     sv_size(aTHX_ st, (SV *)CvGV(thing), SOME_RECURSION);
 959     if (PERL_VERSION*1000+PERL_SUBVERSION < 21006 || !CvISXSUB(thing))
 960         padlist_size(aTHX_ st, CvPADLIST(thing), SOME_RECURSION);
 961     sv_size(aTHX_ st, (SV *)CvOUTSIDE(thing), recurse);
 962     if (CvISXSUB(thing)) {
 963         sv_size(aTHX_ st, cv_const_sv((CV *)thing), recurse);
 964     } else if (CvROOT(thing)) {
 965         op_size(aTHX_ CvSTART(thing), st);
 966         op_size(aTHX_ CvROOT(thing), st);
 967     }
 968     goto freescalar;
 969
 970   case SVt_PVIO: TAG;
 971     /* Some embedded char pointers */
 972     check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_top_name);
 973     check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_fmt_name);
 974     check_new_and_strlen(st, ((XPVIO *) SvANY(thing))->xio_bottom_name);
 975     /* Throw the GVs on the list to be walked if they're not-null */
 976     sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_top_gv, recurse);
 977     sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_bottom_gv, recurse);
 978     sv_size(aTHX_ st, (SV *)((XPVIO *) SvANY(thing))->xio_fmt_gv, recurse);
 979
 980     /* Only go trotting through the IO structures if they're really
 981        trottable. If USE_PERLIO is defined we can do this. If
 982        not... we can't, so we don't even try */
 983 #ifdef USE_PERLIO
 984     /* Dig into xio_ifp and xio_ofp here */
 985     warn("Devel::Size: Can't size up perlio layers yet\n");
 986 #endif
 987     goto freescalar;
 988
 989   case SVt_PVLV: TAG;
 990 #if (PERL_VERSION < 9)
 991     goto freescalar;
 992 #endif
 993
 994   case SVt_PVGV: TAG;
 995     if(isGV_with_GP(thing)) {
 996 #ifdef GvNAME_HEK
 997         hek_size(aTHX_ st, GvNAME_HEK(thing), 1);
 998 #else
 999         st->total_size += GvNAMELEN(thing);
1000 #endif
1001 #ifdef GvFILE_HEK
1002         hek_size(aTHX_ st, GvFILE_HEK(thing), 1);
1003 #elif defined(GvFILE)
1004 #  if !defined(USE_ITHREADS) || (PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 8))
1005         /* With itreads, before 5.8.9, this can end up pointing to freed memory
1006            if the GV was created in an eval, as GvFILE() points to CopFILE(),
1007            and the relevant COP has been freed on scope cleanup after the eval.
1008            5.8.9 adds a binary compatible fudge that catches the vast majority
1009            of cases. 5.9.something added a proper fix, by converting the GP to
1010            use a shared hash key (porperly reference counted), instead of a
1011            char * (owned by who knows? possibly no-one now) */
1012         check_new_and_strlen(st, GvFILE(thing));
1013 #  endif
1014 #endif
1015         /* Is there something hanging off the glob? */
1016         if (check_new(st, GvGP(thing))) {
1017             st->total_size += sizeof(GP);
1018             sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_sv), recurse);
1019             sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_form), recurse);
1020             sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_av), recurse);
1021             sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_hv), recurse);
1022             sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_egv), recurse);
1023             sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_cv), recurse);
1024         }
1025 #if (PERL_VERSION >= 9)
1026         TAG; break;
1027 #endif
1028     }
1029 #if PERL_VERSION <= 8
1030   case SVt_PVBM: TAG;
1031 #endif
1032   case SVt_PVMG: TAG;
1033   case SVt_PVNV: TAG;
1034   case SVt_PVIV: TAG;
1035   case SVt_PV: TAG;
1036   freescalar:
1037     if(recurse && SvROK(thing))
1038         sv_size(aTHX_ st, SvRV_const(thing), recurse);
1039     else if (SvIsCOW_shared_hash(thing))
1040         hek_size(aTHX_ st, SvSHARED_HEK_FROM_PV(SvPVX(thing)), 1);
1041     else
1042         st->total_size += SvLEN(thing);
1043
1044     if(SvOOK(thing)) {
1045         STRLEN len;
1046         SvOOK_offset(thing, len);
1047         st->total_size += len;
1048     }
1049     TAG;break;
1050
1051   }
1052   return;
1053 }
1054
1055 static struct state *
1056 new_state(pTHX)
1057 {
1058     SV *warn_flag;
1059     struct state *st;
1060
1061     Newxz(st, 1, struct state);
1062     st->go_yell = TRUE;
1063     if (NULL != (warn_flag = perl_get_sv("Devel::Size::warn", FALSE))) {
1064         st->dangle_whine = st->go_yell = SvIV(warn_flag) ? TRUE : FALSE;
1065     }
1066     if (NULL != (warn_flag = perl_get_sv("Devel::Size::dangle", FALSE))) {
1067         st->dangle_whine = SvIV(warn_flag) ? TRUE : FALSE;
1068     }
1069     check_new(st, &PL_sv_undef);
1070     check_new(st, &PL_sv_no);
1071     check_new(st, &PL_sv_yes);
1072 #if PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 0)
1073     check_new(st, &PL_sv_placeholder);
1074 #endif
1075     return st;
1076 }
1077
1078 MODULE = Devel::Size        PACKAGE = Devel::Size
1079
1080 PROTOTYPES: DISABLE
1081
1082 UV
1083 size(orig_thing)
1084      SV *orig_thing
1085 ALIAS:
1086     total_size = TOTAL_SIZE_RECURSION
1087 CODE:
1088 {
1089   SV *thing = orig_thing;
1090   struct state *st = new_state(aTHX);
1091
1092   /* If they passed us a reference then dereference it. This is the
1093      only way we can check the sizes of arrays and hashes */
1094   if (SvROK(thing)) {
1095     thing = SvRV(thing);
1096   }
1097
1098   sv_size(aTHX_ st, thing, ix);
1099   RETVAL = st->total_size;
1100   free_state(st);
1101 }
1102 OUTPUT:
1103   RETVAL