ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/Devel-FindRef/FindRef.xs
(Generate patch)

Comparing Devel-FindRef/FindRef.xs (file contents):
Revision 1.7 by root, Sat Apr 26 03:15:28 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#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
25typedef AV PADNAMELIST;
26typedef 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
15#define res_pair(text) \ 45#define res_pair(text) \
16 { \ 46 do { \
17 AV *av = newAV (); \ 47 AV *av = newAV (); \
18 av_push (av, newSVpv (text, 0)); \ 48 av_push (av, newSVpv (text, 0)); \
19 if (rmagical) SvRMAGICAL_on (sv); \ 49 if (rmagical) SvRMAGICAL_on (sv); \
20 av_push (av, sv_rvweaken (newRV_inc (sv))); \ 50 av_push (av, sv_rvweaken (newRV_inc (sv))); \
21 if (rmagical) SvRMAGICAL_off (sv); \ 51 if (rmagical) SvRMAGICAL_off (sv); \
22 av_push (about, newRV_noinc ((SV *)av)); \ 52 av_push (about, newRV_noinc ((SV *)av)); \
23 } 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)
24 61
25#define res_gv(sigil) \ 62#define res_gv(sigil) \
26 { \ 63 res_text (form ("the global %c%s::%.*s", sigil, \
27 AV *av = newAV (); \
28 av_push (av, newSVpv (form ("in the global %c%s::%.*s", sigil, \
29 HvNAME (GvSTASH (sv)), \ 64 HvNAME (GvSTASH (sv)), \
30 GvNAMELEN (sv), GvNAME (sv) ? GvNAME (sv) : "<anonymous>"), \ 65 GvNAME_HEK (sv) ? GvNAMELEN (sv) : 11, \
31 0)); \ 66 GvNAME_HEK (sv) ? GvNAME (sv) : "<anonymous>"))
32 av_push (about, newRV_noinc ((SV *)av)); \
33 }
34 67
35MODULE = Devel::FindRef PACKAGE = Devel::FindRef 68MODULE = Devel::FindRef PACKAGE = Devel::FindRef
36 69
37PROTOTYPES: ENABLE 70PROTOTYPES: ENABLE
38 71
72void
73find_ (SV *target_ref)
74 PPCODE:
75{
76 SV *arena, *targ;
77 U32 rmagical;
78 int i;
79 AV *about = newAV ();
80 AV *excl = newAV ();
81
82 if (!SvROK (target_ref))
83 croak ("find expects a reference to a perl value");
84
85 targ = SvRV (target_ref);
86
87 if (SvIMMORTAL (targ))
88 {
89 if (targ == &PL_sv_undef)
90 res_text ("the immortal 'undef' value");
91 else if (targ == &PL_sv_yes)
92 res_text ("the immortal 'yes' value");
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))
103 {
104 UV idx = SvREFCNT (arena);
105
106 /* Remember that the zeroth slot is used as the pointer onwards, so don't
107 include it. */
108 while (--idx > 0)
109 {
110 SV *sv = &arena [idx];
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
119 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 if (SvMAGICAL (sv)) /* name-pads use SvMAGIC for other purposes */
131 {
132 MAGIC *mg = SvMAGIC (sv);
133
134 while (mg)
135 {
136 if (mg->mg_obj == targ && mg->mg_flags & MGf_REFCOUNTED)
137 res_pair (form ("referenced (in mg_obj) by '%c' type magic attached to", mg->mg_type));
138
139 if ((SV *)mg->mg_ptr == targ)
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));
143
144 mg = mg->mg_moremagic;
145 }
146 }
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);
270 }
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");
280 }
281
282 EXTEND (SP, 2);
283 PUSHs (sv_2mortal (newRV_noinc ((SV *)about)));
284 PUSHs (sv_2mortal (newRV_noinc ((SV *)excl)));
285}
286
39SV * 287SV *
40ptr2ref (IV ptr) 288ptr2ref (UV ptr)
41 CODE: 289 CODE:
42 RETVAL = newRV_inc (INT2PTR (SV *, ptr)); 290 RETVAL = newRV_inc (INT2PTR (SV *, ptr));
43 OUTPUT: 291 OUTPUT:
44 RETVAL 292 RETVAL
45 293
46void 294UV
47find_ (SV *target) 295ref2ptr (SV *rv)
48 PPCODE: 296 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)) 297 if (!SvROK (rv))
93 { 298 croak ("argument to Devel::FindRef::ref2ptr must be a reference");
94 if (sv != target && SvRV (sv) == targ && !SvWEAKREF (sv)) 299 RETVAL = PTR2UV (SvRV (rv));
95 res_pair ("referenced by"); 300 OUTPUT:
96 } 301 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 302
106 break; 303U32
107 304_refcnt (SV *rv)
108 case SVt_PVHV: 305 CODE:
109 if (hv_iterinit ((HV *)sv)) 306 if (!SvROK (rv))
110 { 307 croak ("argument to Devel::FindRef::_refcnt must be a reference");
111 HE *he; 308 RETVAL = SvREFCNT (SvRV (rv));
112 309 OUTPUT:
113 while ((he = hv_iternext ((HV *)sv))) 310 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 if (!depth && CvPADLIST(sv))
125 depth = 1;
126
127 if (depth)
128 {
129 AV *padlist = CvPADLIST (sv);
130
131 while (depth)
132 {
133 AV *pad = (AV *)AvARRAY (padlist)[depth];
134
135 av_push (excl, newSVuv (PTR2UV (pad))); /* exclude pads themselves from being found */
136
137 for (i = AvFILLp (pad) + 1; i--; )
138 if (AvARRAY (pad)[i] == targ)
139 res_pair (form ("in the lexical '%s' in", SvPVX (AvARRAY (AvARRAY (padlist)[0])[i])));
140
141 --depth;
142 }
143 }
144
145 if ((SV*)CvOUTSIDE(sv) == targ)
146 res_pair ("the containing scope for");
147 }
148
149 break;
150
151 case SVt_PVGV:
152 if (GvGP (sv))
153 {
154 if (GvSV (sv) == (SV *)targ) res_gv ('$');
155 if (GvAV (sv) == (AV *)targ) res_gv ('@');
156 if (GvHV (sv) == (HV *)targ) res_gv ('%');
157 if (GvCV (sv) == (CV *)targ) res_gv ('&');
158 }
159
160 break;
161 }
162
163 if (rmagical)
164 SvRMAGICAL_on (sv);
165 }
166 }
167
168 EXTEND (SP, 2);
169 PUSHs (sv_2mortal (newRV_noinc ((SV *)about)));
170 PUSHs (sv_2mortal (newRV_noinc ((SV *)excl)));
171}
172

Diff Legend

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