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.6 by root, Sat Dec 29 21:04:46 2007 UTC vs.
Revision 1.20 by root, Tue Sep 8 18:12:07 2009 UTC

… …
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)
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
15#define res_pair(text) \ 24#define res_pair(text) \
16 { \ 25 do { \
17 AV *av = newAV (); \ 26 AV *av = newAV (); \
18 av_push (av, newSVpv (text, 0)); \ 27 av_push (av, newSVpv (text, 0)); \
28 if (rmagical) SvRMAGICAL_on (sv); \
19 av_push (av, sv_rvweaken (newRV_inc (sv))); \ 29 av_push (av, sv_rvweaken (newRV_inc (sv))); \
30 if (rmagical) SvRMAGICAL_off (sv); \
20 av_push (about, newRV_noinc ((SV *)av)); \ 31 av_push (about, newRV_noinc ((SV *)av)); \
21 } 32 } while (0)
33
34#define res_text(text) \
35 do { \
36 AV *av = newAV (); \
37 av_push (av, newSVpv (text, 0)); \
38 av_push (about, newRV_noinc ((SV *)av)); \
39 } while (0)
22 40
23#define res_gv(sigil) \ 41#define res_gv(sigil) \
24 { \ 42 res_text (form ("the global %c%s::%.*s", sigil, \
25 AV *av = newAV (); \
26 av_push (av, newSVpv (form ("in the global %c%s::%.*s", sigil, \
27 HvNAME (GvSTASH (sv)), \ 43 HvNAME (GvSTASH (sv)), \
28 GvNAMELEN (sv), GvNAME (sv) ? GvNAME (sv) : "<anonymous>"), \ 44 GvNAME_HEK (sv) ? GvNAMELEN (sv) : 11, \
29 0)); \ 45 GvNAME_HEK (sv) ? GvNAME (sv) : "<anonymous>"))
30 av_push (about, newRV_noinc ((SV *)av)); \
31 }
32 46
33MODULE = Devel::FindRef PACKAGE = Devel::FindRef 47MODULE = Devel::FindRef PACKAGE = Devel::FindRef
34 48
35PROTOTYPES: ENABLE 49PROTOTYPES: ENABLE
36 50
51void
52find_ (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 ("the 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 ("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 ("the lexical '%s' in", SvPVX (name_sv)));
183 else
184 res_pair ("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 (int)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
37SV * 262SV *
38ptr2ref (IV ptr) 263ptr2ref (UV ptr)
39 CODE: 264 CODE:
40 RETVAL = newRV_inc (INT2PTR (SV *, ptr)); 265 RETVAL = newRV_inc (INT2PTR (SV *, ptr));
41 OUTPUT: 266 OUTPUT:
42 RETVAL 267 RETVAL
43 268
44void 269UV
45find_ (SV *target) 270ref2ptr (SV *rv)
46 PPCODE: 271 CODE:
47{
48 SV *arena, *targ;
49 int rmagical, i;
50 AV *about = newAV ();
51 AV *excl = newAV ();
52
53 if (!SvROK (target))
54 croak ("find expects a reference to a perl value");
55
56 targ = SvRV (target);
57
58 for (arena = PL_sv_arenaroot; arena; arena = SvANY (arena))
59 {
60 UV idx = SvREFCNT (arena);
61
62 /* Remember that the zeroth slot is used as the pointer onwards, so don't
63 include it. */
64 while (--idx > 0)
65 {
66 SV *sv = &arena [idx];
67
68 if (SvTYPE (sv) >= SVt_LAST)
69 continue;
70
71 /* temporarily disable RMAGICAL, it can easily interfere with us */
72 if ((rmagical = SvRMAGICAL (sv)))
73 SvRMAGICAL_off (sv);
74
75 if (SvTYPE (sv) >= SVt_PVMG)
76 {
77 MAGIC *mg = SvMAGIC (sv);
78 while (mg)
79 {
80 if (mg->mg_obj == targ)
81 res_pair (form ("referenced (in mg_obj) by '%c' type magic attached to", mg->mg_type));
82
83 if ((SV *)mg->mg_ptr == targ && mg->mg_flags & MGf_REFCOUNTED)
84 res_pair (form ("referenced (in mg_ptr) by '%c' type magic attached to", mg->mg_type));
85
86 mg = mg->mg_moremagic;
87 }
88 }
89
90 if (SvROK (sv)) 272 if (!SvROK (rv))
91 { 273 croak ("argument to Devel::FindRef::ref2ptr must be a reference");
92 if (sv != target && SvRV (sv) == targ && !SvWEAKREF (sv)) 274 RETVAL = PTR2UV (SvRV (rv));
93 res_pair ("referenced by"); 275 OUTPUT:
94 } 276 RETVAL
95 else
96 switch (SvTYPE (sv))
97 {
98 case SVt_PVAV:
99 if (AvREAL (sv))
100 for (i = AvFILLp (sv) + 1; i--; )
101 if (AvARRAY (sv)[i] == targ)
102 res_pair (form ("in array element %d of", i));
103 277
104 break; 278U32
105 279_refcnt (SV *rv)
106 case SVt_PVHV: 280 CODE:
107 if (hv_iterinit ((HV *)sv)) 281 if (!SvROK (rv))
108 { 282 croak ("argument to Devel::FindRef::_refcnt must be a reference");
109 HE *he; 283 RETVAL = SvREFCNT (SvRV (rv));
110 284 OUTPUT:
111 while ((he = hv_iternext ((HV *)sv))) 285 RETVAL
112 if (HeVAL (he) == targ)
113 res_pair (form ("in the member '%.*s' of", HeKLEN (he), HeKEY (he)));
114 }
115
116 break;
117
118 case SVt_PVCV:
119 {
120 int depth = CvDEPTH (sv);
121
122 if (depth)
123 {
124 AV *padlist = CvPADLIST (sv);
125
126 while (depth)
127 {
128 AV *pad = (AV *)AvARRAY (padlist)[depth];
129
130 av_push (excl, newSVuv (PTR2UV (pad))); /* exclude pads themselves from being found */
131
132 for (i = AvFILLp (pad); i--; )
133 if (AvARRAY (pad)[i] == targ)
134 res_pair (form ("in the lexical '%s' in", SvPVX (AvARRAY (AvARRAY (padlist)[0])[i])));
135
136 --depth;
137 }
138 }
139 }
140
141 break;
142
143 case SVt_PVGV:
144 if (GvGP (sv))
145 {
146 if (GvSV (sv) == (SV *)targ) res_gv ('$');
147 if (GvAV (sv) == (AV *)targ) res_gv ('@');
148 if (GvHV (sv) == (HV *)targ) res_gv ('%');
149 if (GvCV (sv) == (CV *)targ) res_gv ('&');
150 }
151
152 break;
153 }
154
155 if (rmagical)
156 SvRMAGICAL_on (sv);
157 }
158 }
159
160 EXTEND (SP, 2);
161 PUSHs (sv_2mortal (newRV_noinc ((SV *)about)));
162 PUSHs (sv_2mortal (newRV_noinc ((SV *)excl)));
163}
164

Diff Legend

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