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

Comparing Devel-FindRef/FindRef.xs (file contents):
Revision 1.8 by root, Sun Apr 27 05:59:06 2008 UTC vs.
Revision 1.17 by root, Wed Jul 1 08:25:04 2009 UTC

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

Diff Legend

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

Comparing Devel-FindRef/FindRef.xs (file contents): Revision 1.8 by root, Sun Apr 27 05:59:06 2008 UTC vs. Revision 1.17 by root, Wed Jul 1 08:25:04 2009 UTC

Diff Legend

Comparing Devel-FindRef/FindRef.xs (file contents):
Revision 1.8 by root, Sun Apr 27 05:59:06 2008 UTC vs.
Revision 1.17 by root, Wed Jul 1 08:25:04 2009 UTC