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

Diff Legend

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