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.10 by root, Fri Jul 11 15:33:48 2008 UTC vs.
Revision 1.24 by root, Fri May 16 07:43:52 2014 UTC

… …
13#endif 13#endif
14 14
15#if !PERL_VERSION_ATLEAST (5,10,0) 15#if !PERL_VERSION_ATLEAST (5,10,0)
16# define SvPAD_OUR(dummy) 0 16# define SvPAD_OUR(dummy) 0
17#endif 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
18 29
19#define res_pair(text) \ 30#define res_pair(text) \
20 do { \ 31 do { \
21 AV *av = newAV (); \ 32 AV *av = newAV (); \
22 av_push (av, newSVpv (text, 0)); \ 33 av_push (av, newSVpv (text, 0)); \
… …
24 av_push (av, sv_rvweaken (newRV_inc (sv))); \ 35 av_push (av, sv_rvweaken (newRV_inc (sv))); \
25 if (rmagical) SvRMAGICAL_off (sv); \ 36 if (rmagical) SvRMAGICAL_off (sv); \
26 av_push (about, newRV_noinc ((SV *)av)); \ 37 av_push (about, newRV_noinc ((SV *)av)); \
27 } while (0) 38 } while (0)
28 39
29#define res_gv(sigil) \ 40#define res_text(text) \
30 do { \ 41 do { \
31 AV *av = newAV (); \ 42 AV *av = newAV (); \
32 av_push (av, newSVpv (form ("in the global %c%s::%.*s", sigil, \ 43 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)); \ 44 av_push (about, newRV_noinc ((SV *)av)); \
37 } while (0) 45 } while (0)
38 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>"))
52
39MODULE = Devel::FindRef PACKAGE = Devel::FindRef 53MODULE = Devel::FindRef PACKAGE = Devel::FindRef
40 54
41PROTOTYPES: ENABLE 55PROTOTYPES: ENABLE
42 56
43SV *
44ptr2ref (IV ptr)
45 CODE:
46 RETVAL = newRV_inc (INT2PTR (SV *, ptr));
47 OUTPUT:
48 RETVAL
49
50void 57void
51find_ (SV *target) 58find_ (SV *target_ref)
52 PPCODE: 59 PPCODE:
53{ 60{
54 SV *arena, *targ; 61 SV *arena, *targ;
55 U32 rmagical; 62 U32 rmagical;
56 int i; 63 int i;
57 AV *about = newAV (); 64 AV *about = newAV ();
58 AV *excl = newAV (); 65 AV *excl = newAV ();
59 66
60 if (!SvROK (target)) 67 if (!SvROK (target_ref))
61 croak ("find expects a reference to a perl value"); 68 croak ("find expects a reference to a perl value");
62 69
63 targ = SvRV (target); 70 targ = SvRV (target_ref);
64 71
65 for (arena = PL_sv_arenaroot; arena; arena = SvANY (arena)) 72 if (SvIMMORTAL (targ))
66 { 73 {
67 UV idx = SvREFCNT (arena); 74 if (targ == &PL_sv_undef)
68 75 res_text ("the immortal 'undef' value");
69 /* Remember that the zeroth slot is used as the pointer onwards, so don't 76 else if (targ == &PL_sv_yes)
70 include it. */ 77 res_text ("the immortal 'yes' value");
71 while (--idx > 0) 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))
72 { 88 {
73 SV *sv = &arena [idx]; 89 UV idx = SvREFCNT (arena);
74 90
75 if (SvTYPE (sv) >= SVt_LAST) 91 /* Remember that the zeroth slot is used as the pointer onwards, so don't
76 continue; 92 include it. */
77 93 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 { 94 {
95 SV *sv = &arena [idx];
84 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
85 if (SvTYPE (sv) == SVt_PVMG && SvPAD_OUR (sv)) 104 if (SvTYPE (sv) >= SVt_PVMG)
86 { 105 {
106 if (SvTYPE (sv) == SVt_PVMG && SvPAD_OUR (sv))
107 {
87 /* I have no clue what this is */ 108 /* I have no clue what this is */
88 /* maybe some placeholder for our variables for eval? */ 109 /* maybe some placeholder for our variables for eval? */
89 /* it doesn'T seem to reference anything, so we should be able to ignore it */ 110 /* it doesn't seem to reference anything, so we should be able to ignore it */
111 }
112 else
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");
90 } 135 }
91 else 136 else
137 switch (SvTYPE (sv))
92 { 138 {
93 MAGIC *mg = SvMAGIC (sv); 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));
94 144
95 while (mg) 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:
96 { 160 {
97 if (mg->mg_obj == targ) 161 PADLIST *padlist = CvPADLIST (sv);
98 res_pair (form ("referenced (in mg_obj) by '%c' type magic attached to", mg->mg_type));
99 162
100 if ((SV *)mg->mg_ptr == targ && mg->mg_flags & MGf_REFCOUNTED) 163 if (padlist)
101 res_pair (form ("referenced (in mg_ptr) by '%c' type magic attached to", mg->mg_type)); 164 {
165 int depth = CvDEPTH (sv);
102 166
103 mg = mg->mg_moremagic; 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>"));
104 } 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;
105 } 248 }
249
250 if (rmagical)
251 SvRMAGICAL_on (sv);
106 } 252 }
107
108 if (SvROK (sv))
109 {
110 if (sv != target && SvRV (sv) == targ && !SvWEAKREF (sv))
111 res_pair ("referenced by");
112 }
113 else
114 switch (SvTYPE (sv))
115 {
116 case SVt_PVAV:
117 if (AvREAL (sv))
118 for (i = AvFILLp (sv) + 1; i--; )
119 if (AvARRAY (sv)[i] == targ)
120 res_pair (form ("in array element %d of", i));
121
122 break;
123
124 case SVt_PVHV:
125 if (hv_iterinit ((HV *)sv))
126 {
127 HE *he;
128
129 while ((he = hv_iternext ((HV *)sv)))
130 if (HeVAL (he) == targ)
131 res_pair (form ("in the member '%.*s' of", HeKLEN (he), HeKEY (he)));
132 }
133
134 break;
135
136 case SVt_PVCV:
137 {
138 int depth = CvDEPTH (sv);
139
140 /* Anonymous subs have a padlist but zero depth */
141 if (!depth && CvPADLIST (sv))
142 depth = 1;
143
144 if (depth)
145 {
146 AV *padlist = CvPADLIST (sv);
147
148 while (depth)
149 {
150 AV *pad = (AV *)AvARRAY (padlist)[depth];
151
152 av_push (excl, newSVuv (PTR2UV (pad))); /* exclude pads themselves from being found */
153
154 for (i = AvFILLp (pad) + 1; i--; )
155 if (AvARRAY (pad)[i] == targ)
156 {
157 /* Values from constant functions are stored in the pad without any name */
158 SV *name_sv = AvARRAY (AvARRAY (padlist)[0])[i];
159
160 if (name_sv && SvPOK (name_sv))
161 res_pair (form ("in the lexical '%s' in", SvPVX (name_sv)));
162 else
163 res_pair ("in an unnamed lexical in");
164 }
165
166 --depth;
167 }
168 }
169
170 if (CvCONST (sv) && (SV*)CvXSUBANY (sv).any_ptr == targ)
171 res_pair ("the constant value of");
172
173 if (!CvWEAKOUTSIDE (sv) && (SV*)CvOUTSIDE (sv) == targ)
174 res_pair ("the containing scope for");
175 }
176
177 break;
178
179 case SVt_PVGV:
180 if (GvGP (sv))
181 {
182 if (GvSV (sv) == (SV *)targ) res_gv ('$');
183 if (GvAV (sv) == (AV *)targ) res_gv ('@');
184 if (GvHV (sv) == (HV *)targ) res_gv ('%');
185 if (GvCV (sv) == (CV *)targ) res_gv ('&');
186 }
187
188 break;
189 }
190
191 if (rmagical)
192 SvRMAGICAL_on (sv);
193 } 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");
194 } 262 }
195 263
196 EXTEND (SP, 2); 264 EXTEND (SP, 2);
197 PUSHs (sv_2mortal (newRV_noinc ((SV *)about))); 265 PUSHs (sv_2mortal (newRV_noinc ((SV *)about)));
198 PUSHs (sv_2mortal (newRV_noinc ((SV *)excl))); 266 PUSHs (sv_2mortal (newRV_noinc ((SV *)excl)));
199} 267}
200 268
269SV *
270ptr2ref (UV ptr)
271 CODE:
272 RETVAL = newRV_inc (INT2PTR (SV *, ptr));
273 OUTPUT:
274 RETVAL
275
276UV
277ref2ptr (SV *rv)
278 CODE:
279 if (!SvROK (rv))
280 croak ("argument to Devel::FindRef::ref2ptr must be a reference");
281 RETVAL = PTR2UV (SvRV (rv));
282 OUTPUT:
283 RETVAL
284
285U32
286_refcnt (SV *rv)
287 CODE:
288 if (!SvROK (rv))
289 croak ("argument to Devel::FindRef::_refcnt must be a reference");
290 RETVAL = SvREFCNT (SvRV (rv));
291 OUTPUT:
292 RETVAL

Diff Legend

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