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.2 by root, Thu Jan 11 23:05:52 2007 UTC vs.
Revision 1.16 by root, Fri Jun 26 14:47:03 2009 UTC

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

Diff Legend

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