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

Comparing Devel-FindRef/FindRef.xs (file contents):
Revision 1.9 by root, Fri Jul 11 15:29:48 2008 UTC vs.
Revision 1.26 by root, Fri Jun 23 14:40:34 2017 UTC

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

Diff Legend

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

Comparing Devel-FindRef/FindRef.xs (file contents): Revision 1.9 by root, Fri Jul 11 15:29:48 2008 UTC vs. Revision 1.26 by root, Fri Jun 23 14:40:34 2017 UTC

Diff Legend

Comparing Devel-FindRef/FindRef.xs (file contents):
Revision 1.9 by root, Fri Jul 11 15:29:48 2008 UTC vs.
Revision 1.26 by root, Fri Jun 23 14:40:34 2017 UTC