File Coverage

FindRef.xs

Criterion	Covered	Total	%
statement	59	103	57.2
branch	74	256	28.9
condition			n/a
subroutine			n/a
pod			n/a
total	133	359	37.0

line	stmt	bran	code
1			#include "EXTERN.h"
2			#include "perl.h"
3			#include "XSUB.h"
4
5			#define PERL_VERSION_ATLEAST(a,b,c) \
6			(PERL_REVISION > (a) \
7			\|\| (PERL_REVISION == (a) \
8			&& (PERL_VERSION > (b) \
9			\|\| (PERL_VERSION == (b) && PERL_SUBVERSION >= (c)))))
10
11			#if !PERL_VERSION_ATLEAST (5,8,9)
12			# define SVt_LAST 16
13			#endif
14
15			#ifndef SvPAD_OUR
16			# define SvPAD_OUR(dummy) 0
17			#endif
18
19			/* pre-5.10 perls always succeed, with 5.10, we have to check first apparently */
20			#ifndef GvNAME_HEK
21			# define GvNAME_HEK(sv) 1
22			#endif
23
24			#ifndef PadARRAY
25			typedef AV PADNAMELIST;
26			typedef SV PADNAME;
27			# define PadnamePV(sv) SvPVX (sv)
28			# define PadnameLEN(sv) SvCUR (sv)
29			# define PadARRAY(pad) AvARRAY (pad)
30			# define PadlistARRAY(pl) ((PAD **)AvARRAY (pl))
31			#endif
32
33			#ifndef PadMAX
34			# define PadMAX(pad) AvFILLp (pad)
35			#endif
36
37			#ifndef padnamelist_fetch
38			# define padnamelist_fetch(a,b) *av_fetch (a, b, FALSE)
39			#endif
40
41			#ifndef PadlistNAMES
42			# define PadlistNAMES(padlist) *PadlistARRAY (padlist)
43			#endif
44
45			#define res_pair(text) \
46			do { \
47			AV *av = newAV (); \
48			av_push (av, newSVpv (text, 0)); \
49			if (rmagical) SvRMAGICAL_on (sv); \
50			av_push (av, sv_rvweaken (newRV_inc (sv))); \
51			if (rmagical) SvRMAGICAL_off (sv); \
52			av_push (about, newRV_noinc ((SV *)av)); \
53			} while (0)
54
55			#define res_text(text) \
56			do { \
57			AV *av = newAV (); \
58			av_push (av, newSVpv (text, 0)); \
59			av_push (about, newRV_noinc ((SV *)av)); \
60			} while (0)
61
62			#define res_gv(sigil) \
63			res_text (form ("the global %c%s::%.*s", sigil, \
64			HvNAME (GvSTASH (sv)), \
65			GvNAME_HEK (sv) ? GvNAMELEN (sv) : 11, \
66			GvNAME_HEK (sv) ? GvNAME (sv) : ""))
67
68			MODULE = Devel::FindRef PACKAGE = Devel::FindRef
69
70			PROTOTYPES: ENABLE
71
72			void
73			find_ (SV *target_ref)
74			PPCODE:
75			{
76			SV arena, targ;
77			U32 rmagical;
78			int i;
79	30		AV *about = newAV ();
80	30		AV *excl = newAV ();
81
82	30	50	if (!SvROK (target_ref))
83	0		croak ("find expects a reference to a perl value");
84
85	30		targ = SvRV (target_ref);
86
87	30	100	if (SvIMMORTAL (targ))
		50
		50
		50
		50
88			{
89	0	0	if (targ == &PL_sv_undef)
90	0		res_text ("the immortal 'undef' value");
91	0	0	else if (targ == &PL_sv_yes)
92	0		res_text ("the immortal 'yes' value");
93	0	0	else if (targ == &PL_sv_no)
94	0		res_text ("the immortal 'no' value");
95	0	0	else if (targ == &PL_sv_placeholder)
96	0		res_text ("the immortal placeholder value");
97			else
98	0		res_text ("some unknown immortal");
99			}
100			else
101			{
102	7283	100	for (arena = PL_sv_arenaroot; arena; arena = SvANY (arena))
103			{
104	7253		UV idx = SvREFCNT (arena);
105
106			/* Remember that the zeroth slot is used as the pointer onwards, so don't
107			include it. */
108	1233010	100	while (--idx > 0)
109			{
110	1225757		SV *sv = &arena [idx];
111
112	1225757	100	if (SvTYPE (sv) >= SVt_LAST)
113	2209		continue;
114
115			/* temporarily disable RMAGICAL, it can easily interfere with us */
116	1223548	100	if ((rmagical = SvRMAGICAL (sv)))
117	76288		SvRMAGICAL_off (sv);
118
119	1223548	100	if (SvTYPE (sv) >= SVt_PVMG)
120			{
121			#if !PERL_VERSION_ATLEAST (5,21,6)
122			if (SvTYPE (sv) == SVt_PVMG && SvPAD_OUR (sv))
123			{
124			/* I have no clue what this is */
125			/* maybe some placeholder for our variables for eval? */
126			/* it doesn't seem to reference anything, so we should be able to ignore it */
127			}
128			else
129			#endif
130	343944	100	if (SvMAGICAL (sv)) /* name-pads use SvMAGIC for other purposes */
131			{
132	21720		MAGIC *mg = SvMAGIC (sv);
133
134	43440	100	while (mg)
135			{
136	21720	50	if (mg->mg_obj == targ && mg->mg_flags & MGf_REFCOUNTED)
		0
137	0	0	res_pair (form ("referenced (in mg_obj) by '%c' type magic attached to", mg->mg_type));
		0
138
139	21720	50	if ((SV *)mg->mg_ptr == targ)
140	0	0	res_pair (form ("%sreferenced (in mg_ptr) by '%c' type magic attached to",
		0
		0
141			mg->mg_len == HEf_SVKEY ? "" : "possibly ",
142			mg->mg_type));
143
144	21720		mg = mg->mg_moremagic;
145			}
146			}
147			}
148
149	1223548	100	if (SvROK (sv))
150			{
151	62136	100	if (SvRV (sv) == targ && !SvWEAKREF (sv) && sv != target_ref)
		100
		50
152	62136	50	res_pair ("referenced by");
		50
153			}
154			else
155	1161412		switch (SvTYPE (sv))
156			{
157			case SVt_PVAV:
158	97450	100	if (AvREAL (sv))
159	606394	100	for (i = AvFILLp (sv) + 1; i--; )
160	549756	100	if (AvARRAY (sv)[i] == targ)
161	13	100	res_pair (form ("the array element %d of", i));
		100
162
163	97450		break;
164
165			case SVt_PVHV:
166	27242	100	if (hv_iterinit ((HV *)sv))
167			{
168			HE *he;
169
170	400946	100	while ((he = hv_iternext ((HV *)sv)))
171	378122	100	if (HeVAL (he) == targ)
172	1	50	res_pair (form ("the hash member '%.*s' of", HeKLEN (he), HeKEY (he)));
		50
173			}
174
175	27242		break;
176
177			case SVt_PVCV:
178			{
179	73545	50	PADLIST *padlist = CvISXSUB (cv) ? 0 : CvPADLIST (sv);
180
181	73545	50	if (padlist)
182			{
183	0		int depth = CvDEPTH (sv);
184
185			/* Anonymous subs have a padlist but zero depth */
186			/* some hacks switch CvANON off, so we just blindly assume a minimum of 1 */
187			if (!depth && !PERL_VERSION_ATLEAST (5,21,6))
188			depth = 1;
189
190	0	0	while (depth)
191			{
192	0		PAD *pad = PadlistARRAY (padlist)[depth];
193
194	0		av_push (excl, newSVuv (PTR2UV (pad))); /* exclude pads themselves from being found */
195
196			/* The 0th pad slot is @_ */
197	0	0	if (PadARRAY (pad)[0] == targ)
198	0	0	res_pair ("the argument array for");
		0
199
200	0	0	for (i = PadMAX (pad) + 1; --i; )
201	0	0	if (PadARRAY (pad)[i] == targ)
202			{
203			/* Values from constant functions are stored in the pad without any name */
204	0		PADNAME *name = padnamelist_fetch (PadlistNAMES (padlist), i);
205
206	0	0	if (name && PadnamePV (name) && *PadnamePV (name))
		0
		0
207	0	0	res_pair (form ("the lexical '%s' in", PadnamePV (name)));
		0
208			else
209	0	0	res_pair ("an unnamed lexical in");
		0
210			}
211
212	0		--depth;
213			}
214			}
215
216	73545	100	if (CvCONST (sv) && (SV*)CvXSUBANY (sv).any_ptr == targ)
		50
217	0	0	res_pair ("the constant value of");
		0
218
219	73545	100	if (!CvWEAKOUTSIDE (sv) && (SV*)CvOUTSIDE (sv) == targ)
		50
220	0	0	res_pair ("the containing scope for");
		0
221
222	73545	50	if (sv == targ && CvANON (sv))
		0
223	0	0	if (CvSTART (sv)
224	0	0	&& CvSTART (sv)->op_type == OP_NEXTSTATE
225	0	0	&& CopLINE ((COP *)CvSTART (sv)))
226	0	0	res_text (form ("the closure created at %s:%d",
		0
		0
227			CopFILE ((COP )CvSTART (sv)) ? CopFILE ((COP )CvSTART (sv)) : "",
228			CopLINE ((COP *)CvSTART (sv))));
229			else
230	0	0	res_text (form ("the closure created somewhere in file %s (PLEASE REPORT!)",
231			CvFILE (sv) ? CvFILE (sv) : ""));
232			}
233
234	73545		break;
235
236			case SVt_PVGV:
237	97614	50	if (GvGP (sv))
238			{
239	97614	50	if (GvSV (sv) == (SV *)targ) res_gv ('$');
		0
		0
		0
		0
		0
		0
		0
		0
240	97614	50	if (GvAV (sv) == (AV *)targ) res_gv ('@');
		0
		0
		0
		0
		0
		0
		0
		0
241	97614	50	if (GvHV (sv) == (HV *)targ) res_gv ('%');
		0
		0
		0
		0
		0
		0
		0
		0
242	97614	50	if (GvCV (sv) == (CV *)targ) res_gv ('&');
		0
		0
		0
		0
		0
		0
		0
		0
243			}
244
245	97614		break;
246
247			case SVt_PVLV:
248	0	0	if (LvTARG (sv) == targ)
249			{
250	0	0	if (LvTYPE (sv) == 'y')
251			{
252	0		MAGIC *mg = mg_find (sv, PERL_MAGIC_defelem);
253
254	0	0	if (mg && mg->mg_obj)
		0
255	0	0	res_pair (form ("the target for the lvalue hash element '%.*s',",
		0
		0
256			(int)SvCUR (mg->mg_obj), SvPV_nolen (mg->mg_obj)));
257			else
258	0	0	res_pair (form ("the target for the lvalue array element #%d,", LvTARGOFF (sv)));
		0
259			}
260			else
261	0	0	res_pair (form ("an lvalue reference target (type '%c', ofs %d, len %d),",
		0
262			LvTYPE (sv), LvTARGOFF (sv), LvTARGLEN (sv)));
263			}
264
265	0		break;
266			}
267
268	1223548	100	if (rmagical)
269	76288		SvRMAGICAL_on (sv);
270			}
271			}
272
273			/* look at the mortalise stack of the current coroutine */
274	383	100	for (i = 0; i <= PL_tmps_ix; ++i)
275	353	100	if (PL_tmps_stack [i] == targ)
276	5		res_text ("a temporary on the stack");
277
278	30	50	if (targ == (SV*)PL_main_cv)
279	0		res_text ("the main body of the program");
280			}
281
282	30	50	EXTEND (SP, 2);
283	30		PUSHs (sv_2mortal (newRV_noinc ((SV *)about)));
284	30		PUSHs (sv_2mortal (newRV_noinc ((SV *)excl)));
285			}
286
287			SV *
288			ptr2ref (UV ptr)
289			CODE:
290	0		RETVAL = newRV_inc (INT2PTR (SV *, ptr));
291			OUTPUT:
292			RETVAL
293
294			UV
295			ref2ptr (SV *rv)
296			CODE:
297	58	50	if (!SvROK (rv))
298	0		croak ("argument to Devel::FindRef::ref2ptr must be a reference");
299	58		RETVAL = PTR2UV (SvRV (rv));
300			OUTPUT:
301			RETVAL
302
303			U32
304			_refcnt (SV *rv)
305			CODE:
306	34	50	if (!SvROK (rv))
307	0		croak ("argument to Devel::FindRef::_refcnt must be a reference");
308	34		RETVAL = SvREFCNT (SvRV (rv));
309			OUTPUT:
310			RETVAL