[ViewVC] Diff of: cvs/Devel-FindRef/FindRef.xs

Comparing Devel-FindRef/FindRef.xs (file contents):
Revision 1.2 by root, Thu Jan 11 23:05:52 2007 UTC vs.
Revision 1.25 by root, Sun May 18 18:44:08 2014 UTC

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

Diff Legend

-–
+Removed lines
-+
+Added lines
-<
+Changed lines
->
+Changed lines

Comparing Devel-FindRef/FindRef.xs (file contents): Revision 1.2 by root, Thu Jan 11 23:05:52 2007 UTC vs. Revision 1.25 by root, Sun May 18 18:44:08 2014 UTC

Diff Legend

Comparing Devel-FindRef/FindRef.xs (file contents):
Revision 1.2 by root, Thu Jan 11 23:05:52 2007 UTC vs.
Revision 1.25 by root, Sun May 18 18:44:08 2014 UTC