import Devel-Size 0.64 from CPAN
[p5sagit/Devel-Size.git] / Size.xs
CommitLineData
e98cedbf 1#include "EXTERN.h"
2#include "perl.h"
3#include "XSUB.h"
4
98ecbbc6 5static int regex_whine;
6static int fm_whine;
7
8
6a9ad7ec 9#define carp puts
7ccc7d88 10UV thing_size(SV *, HV *);
11typedef 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 */
62691e7c 22 OPc_LOOP, /* 10 */
23 OPc_COP /* 11 */
7ccc7d88 24} opclass;
25
26static opclass
27cc_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
62691e7c 43 if (o->op_type = OP_TRANS) {
44 return OPc_BASEOP;
45 }
46
7ccc7d88 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
6a9ad7ec 137
a6ea0805 138#if !defined(NV)
139#define NV double
140#endif
141
ebb2c5b9 142static int go_yell = 1;
143
6a9ad7ec 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 */
24d37977 153IV check_new(HV *tracking_hash, const void *thing) {
7ccc7d88 154 if (NULL == thing) {
155 return FALSE;
156 }
6a9ad7ec 157 if (hv_exists(tracking_hash, (char *)&thing, sizeof(void *))) {
158 return FALSE;
159 }
78dfb4e7 160 hv_store(tracking_hash, (char *)&thing, sizeof(void *), &PL_sv_yes, 0);
6a9ad7ec 161 return TRUE;
162
163}
164
165/* Figure out how much magic is attached to the SV and return the
166 size */
167IV 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
7ccc7d88 197UV regex_size(REGEXP *baseregex, HV *tracking_hash) {
198 UV total_size = 0;
199
98ecbbc6 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
7ccc7d88 210 return total_size;
211}
212
213UV 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 }
98ecbbc6 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
7ccc7d88 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 }
98ecbbc6 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 */
62691e7c 322 break;
7ccc7d88 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}
6a9ad7ec 355
24d37977 356#if PERL_VERSION > 9 || (PERL_VERSION == 9 && PERL_SUBVERSION > 2)
357# define NEW_HEAD_LAYOUT
358#endif
359
6a9ad7ec 360UV thing_size(SV *orig_thing, HV *tracking_hash) {
e98cedbf 361 SV *thing = orig_thing;
362 UV total_size = sizeof(SV);
363
e98cedbf 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:
24d37977 371#ifndef NEW_HEAD_LAYOUT
372# ifdef PURIFY
e98cedbf 373 total_size += sizeof(sizeof(XPVIV));
24d37977 374# else
e98cedbf 375 total_size += sizeof(IV);
24d37977 376# endif
e98cedbf 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:
24d37977 389#ifndef NEW_HEAD_LAYOUT
e98cedbf 390 total_size += sizeof(XRV);
24d37977 391#endif
e98cedbf 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);
24d37977 403 total_size += SvIVX(thing);
e98cedbf 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:
4ab42718 411 total_size += sizeof(XPVMG);
412 total_size += SvLEN(thing);
6a9ad7ec 413 total_size += magic_size(thing, tracking_hash);
e98cedbf 414 break;
415 case SVt_PVBM:
6a9ad7ec 416 total_size += sizeof(XPVBM);
417 total_size += SvLEN(thing);
418 total_size += magic_size(thing, tracking_hash);
e98cedbf 419 break;
420 case SVt_PVLV:
6a9ad7ec 421 total_size += sizeof(XPVLV);
422 total_size += SvLEN(thing);
423 total_size += magic_size(thing, tracking_hash);
e98cedbf 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)) {
6a9ad7ec 437 if (check_new(tracking_hash, AvARYLEN(thing))) {
438 total_size += thing_size(AvARYLEN(thing), tracking_hash);
439 }
e98cedbf 440 }
6a9ad7ec 441 total_size += magic_size(thing, tracking_hash);
e98cedbf 442 break;
443 case SVt_PVHV:
a6ea0805 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 */
6a9ad7ec 449 if (HvARRAY(thing)) {
a6ea0805 450 HE *cur_entry;
451 IV cur_bucket = 0;
a6ea0805 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) {
6a9ad7ec 457 /* Hash keys can be shared. Have we seen this before? */
458 if (check_new(tracking_hash, cur_entry->hent_hek)) {
b98fcdb9 459 total_size += HEK_BASESIZE + cur_entry->hent_hek->hek_len + 2;
6a9ad7ec 460 }
a6ea0805 461 }
462 cur_entry = cur_entry->hent_next;
463 }
464 }
465 }
6a9ad7ec 466 total_size += magic_size(thing, tracking_hash);
e98cedbf 467 break;
468 case SVt_PVCV:
6a9ad7ec 469 total_size += sizeof(XPVCV);
5c2e1b12 470 total_size += magic_size(thing, tracking_hash);
7ccc7d88 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);
ebb2c5b9 481 }
7ccc7d88 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
e98cedbf 496 break;
497 case SVt_PVGV:
5c2e1b12 498 total_size += magic_size(thing, tracking_hash);
6a9ad7ec 499 total_size += sizeof(XPVGV);
5c2e1b12 500 total_size += GvNAMELEN(thing);
78dfb4e7 501#ifdef GvFILE
0bff12d8 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 }
78dfb4e7 508#endif
5c2e1b12 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);
5073b933 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 }
5c2e1b12 534 }
535 }
e98cedbf 536 break;
537 case SVt_PVFM:
6a9ad7ec 538 total_size += sizeof(XPVFM);
7ccc7d88 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
98ecbbc6 548 if (go_yell && !fm_whine) {
5073b933 549 carp("Devel::Size: Calculated sizes for FMs are incomplete");
98ecbbc6 550 fm_whine = 1;
ebb2c5b9 551 }
e98cedbf 552 break;
553 case SVt_PVIO:
6a9ad7ec 554 total_size += sizeof(XPVIO);
5073b933 555 total_size += magic_size(thing, tracking_hash);
24d37977 556 if (check_new(tracking_hash, (SvPVX(thing)))) {
5073b933 557 total_size += ((XPVIO *) SvANY(thing))->xpv_cur;
ebb2c5b9 558 }
5073b933 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
e98cedbf 590 break;
591 default:
5073b933 592 croak("Devel::Size: Unknown variable type");
e98cedbf 593 }
594 return total_size;
595}
596
e98cedbf 597MODULE = Devel::Size PACKAGE = Devel::Size
598
fea63ffa 599PROTOTYPES: DISABLE
600
a6ea0805 601IV
602size(orig_thing)
603 SV *orig_thing
e98cedbf 604CODE:
605{
6a9ad7ec 606 SV *thing = orig_thing;
607 /* Hash to track our seen pointers */
608 HV *tracking_hash = newHV();
ebb2c5b9 609 SV *warn_flag;
610
611 /* Check warning status */
612 go_yell = 0;
98ecbbc6 613 regex_whine = 0;
614 fm_whine = 0;
ebb2c5b9 615
78dfb4e7 616 if (NULL != (warn_flag = perl_get_sv("Devel::Size::warn", FALSE))) {
ebb2c5b9 617 go_yell = SvIV(warn_flag);
618 }
619
6a9ad7ec 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}
631OUTPUT:
632 RETVAL
633
634
635IV
636total_size(orig_thing)
637 SV *orig_thing
638CODE:
639{
640 SV *thing = orig_thing;
641 /* Hash to track our seen pointers */
642 HV *tracking_hash = newHV();
643 AV *pending_array = newAV();
b98fcdb9 644 IV size = 0;
ebb2c5b9 645 SV *warn_flag;
b98fcdb9 646
647 IV count = 0;
6a9ad7ec 648
649 /* Size starts at zero */
650 RETVAL = 0;
651
ebb2c5b9 652 /* Check warning status */
653 go_yell = 0;
98ecbbc6 654 regex_whine = 0;
655 fm_whine = 0;
ebb2c5b9 656
78dfb4e7 657 if (NULL != (warn_flag = perl_get_sv("Devel::Size::warn", FALSE))) {
ebb2c5b9 658 go_yell = SvIV(warn_flag);
659 }
660
661
6a9ad7ec 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 */
e96acca9 672 while (av_len(pending_array) >= 0) {
673 thing = av_pop(pending_array);
6a9ad7ec 674 /* Process it if we've not seen it */
675 if (check_new(tracking_hash, thing)) {
e96acca9 676 /* Is it valid? */
677 if (thing) {
6a9ad7ec 678 /* Yes, it is. So let's check the type */
6a9ad7ec 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:
e96acca9 709 /* Is there anything in here? */
710 if (hv_iterinit((HV *)thing)) {
5c2e1b12 711 HE *temp_he;
712 while (temp_he = hv_iternext((HV *)thing)) {
713 av_push(pending_array, hv_iterval((HV *)thing, temp_he));
e96acca9 714 }
715 }
6a9ad7ec 716 break;
717
5c2e1b12 718 case SVt_PVGV:
0bff12d8 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;
6a9ad7ec 736 default:
e96acca9 737 break;
6a9ad7ec 738 }
739 }
740
b98fcdb9 741
742 size = thing_size(thing, tracking_hash);
743 RETVAL += size;
6a9ad7ec 744 }
745 }
746
747 /* Clean up after ourselves */
748 SvREFCNT_dec(tracking_hash);
749 SvREFCNT_dec(pending_array);
e98cedbf 750}
751OUTPUT:
752 RETVAL
6a9ad7ec 753