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.1 by root, Thu Jan 11 22:30:34 2007 UTC vs.
Revision 1.12 by root, Sat Jul 19 01:17:12 2008 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
27SV * 46SV *
28ptr2ref (IV ptr) 47ptr2ref (UV ptr)
29 CODE: 48 CODE:
30 RETVAL = newRV_inc (INT2PTR (SV *, ptr)); 49 RETVAL = newRV_inc (INT2PTR (SV *, ptr));
50 OUTPUT:
51 RETVAL
52
53UV
54ref2ptr (SV *rv)
55 CODE:
56 RETVAL = PTR2UV (SvRV (rv));
31 OUTPUT: 57 OUTPUT:
32 RETVAL 58 RETVAL
33 59
34void 60void
35find_ (SV *target) 61find_ (SV *target)
36 PPCODE: 62 PPCODE:
37{ 63{
38 SV *arena, *targ; 64 SV *arena, *targ;
39 int rmagical, i; 65 U32 rmagical;
66 int i;
40 AV *about = newAV (); 67 AV *about = newAV ();
41 AV *excl = newAV (); 68 AV *excl = newAV ();
42 69
43 if (!SvROK (target)) 70 if (!SvROK (target))
44 croak ("about expects a reference to a perl value"); 71 croak ("find expects a reference to a perl value");
45 72
46 targ = SvRV (target); 73 targ = SvRV (target);
47 74
48 for (arena = PL_sv_arenaroot; arena; arena = SvANY (arena)) 75 for (arena = PL_sv_arenaroot; arena; arena = SvANY (arena))
49 { 76 {
… …
52 /* Remember that the zeroth slot is used as the pointer onwards, so don't 79 /* Remember that the zeroth slot is used as the pointer onwards, so don't
53 include it. */ 80 include it. */
54 while (--idx > 0) 81 while (--idx > 0)
55 { 82 {
56 SV *sv = &arena [idx]; 83 SV *sv = &arena [idx];
57 84
85 if (SvTYPE (sv) >= SVt_LAST)
86 continue;
87
88 /* temporarily disable RMAGICAL, it can easily interfere with us */
58 if ((rmagical = SvRMAGICAL (sv))) 89 if ((rmagical = SvRMAGICAL (sv)))
59 SvRMAGICAL_off (sv); 90 SvRMAGICAL_off (sv);
60 91
61 //TODO: magic
62
63 switch (SvTYPE (sv)) 92 if (SvTYPE (sv) >= SVt_PVMG)
64 { 93 {
65 case SVt_RV: 94 if (SvTYPE (sv) == SVt_PVMG && SvPAD_OUR (sv))
66 if (sv != target && SvRV (sv) == targ)
67 res_pair ("referenced by");
68 break;
69
70 case SVt_PVAV:
71 if (AvREAL (sv))
72 for (i = AvFILLp (sv) + 1; i--; )
73 if (AvARRAY (sv)[i] == targ)
74 res_pair (form ("in array element %d of", i));
75 break;
76
77 case SVt_PVHV:
78 if (hv_iterinit ((HV *)sv))
79 {
80 HE *he;
81 while ((he = hv_iternext ((HV *)sv)))
82 if (HeVAL (he) == targ)
83 res_pair (form ("in the member '%.*s' of", HeKLEN (he), HeKEY (he)));
84 }
85 break;
86
87 case SVt_PVGV:
88 if (GvGP (sv))
89 {
90 if (GvSV (sv) == targ)
91 res_gv ('$');
92 if (GvAV (sv) == (AV *)targ)
93 res_gv ('@');
94 if (GvHV (sv) == (HV *)targ)
95 res_gv ('%');
96 if (GvCV (sv) == (CV *)targ)
97 res_gv ('&');
98 }
99 break;
100
101 case SVt_PVCV:
102 { 95 {
103 int depth = CvDEPTH (sv); 96 /* I have no clue what this is */
97 /* maybe some placeholder for our variables for eval? */
98 /* it doesn't seem to reference anything, so we should be able to ignore it */
99 }
100 else
101 {
102 MAGIC *mg = SvMAGIC (sv);
103
104 if (depth) 104 while (mg)
105 { 105 {
106 AV *padlist = CvPADLIST (sv); 106 if (mg->mg_obj == targ)
107 while (depth) 107 res_pair (form ("referenced (in mg_obj) by '%c' type magic attached to", mg->mg_type));
108 {
109 AV *pad = (AV *)AvARRAY (padlist)[depth];
110 av_push (excl, newSVuv (PTR2UV (pad))); /* exclude pads from being found */
111 for (i = AvFILLp (pad); i--; )
112 if (AvARRAY (pad)[i] == targ)
113 res_pair (form ("in the lexical '%s' in", SvPVX (AvARRAY (AvARRAY (padlist)[0])[i])));
114 108
115 --depth; 109 if ((SV *)mg->mg_ptr == targ && mg->mg_flags & MGf_REFCOUNTED)
116 } 110 res_pair (form ("referenced (in mg_ptr) by '%c' type magic attached to", mg->mg_type));
111
112 mg = mg->mg_moremagic;
117 } 113 }
118 } 114 }
119 break;
120 } 115 }
121 116
117 if (SvROK (sv))
118 {
119 if (sv != target && SvRV (sv) == targ && !SvWEAKREF (sv))
120 res_pair ("referenced by");
121 }
122 else
123 switch (SvTYPE (sv))
124 {
125 case SVt_PVAV:
126 if (AvREAL (sv))
127 for (i = AvFILLp (sv) + 1; i--; )
128 if (AvARRAY (sv)[i] == targ)
129 res_pair (form ("in array element %d of", i));
130
131 break;
132
133 case SVt_PVHV:
134 if (hv_iterinit ((HV *)sv))
135 {
136 HE *he;
137
138 while ((he = hv_iternext ((HV *)sv)))
139 if (HeVAL (he) == targ)
140 res_pair (form ("in the member '%.*s' of", HeKLEN (he), HeKEY (he)));
141 }
142
143 break;
144
145 case SVt_PVCV:
146 {
147 int depth = CvDEPTH (sv);
148
149 /* Anonymous subs have a padlist but zero depth */
150 if (CvANON (sv) && !depth && CvPADLIST (sv))
151 depth = 1;
152
153 if (depth)
154 {
155 AV *padlist = CvPADLIST (sv);
156
157 while (depth)
158 {
159 AV *pad = (AV *)AvARRAY (padlist)[depth];
160
161 av_push (excl, newSVuv (PTR2UV (pad))); /* exclude pads themselves from being found */
162
163 for (i = AvFILLp (pad) + 1; i--; )
164 if (AvARRAY (pad)[i] == targ)
165 {
166 /* Values from constant functions are stored in the pad without any name */
167 SV *name_sv = AvARRAY (AvARRAY (padlist)[0])[i];
168
169 if (name_sv && SvPOK (name_sv))
170 res_pair (form ("in the lexical '%s' in", SvPVX (name_sv)));
171 else
172 res_pair ("in an unnamed lexical in");
173 }
174
175 --depth;
176 }
177 }
178
179 if (CvCONST (sv) && (SV*)CvXSUBANY (sv).any_ptr == targ)
180 res_pair ("the constant value of");
181
182 if (!CvWEAKOUTSIDE (sv) && (SV*)CvOUTSIDE (sv) == targ)
183 res_pair ("the containing scope for");
184
185 if (sv == targ && CvANON (sv))
186 if (CvSTART (sv)
187 && CvSTART (sv)->op_type == OP_NEXTSTATE
188 && CopLINE ((COP *)CvSTART (sv)))
189 res_text (form ("the closure created at %s:%d",
190 CopFILE ((COP *)CvSTART (sv)) ? CopFILE ((COP *)CvSTART (sv)) : "<unknown>",
191 CopLINE ((COP *)CvSTART (sv))));
192 else
193 res_text (form ("the closure created somewhere in file %s (PLEASE REPORT!)",
194 CvFILE (sv) ? CvFILE (sv) : "<unknown>"));
195 }
196
197 break;
198
199 case SVt_PVGV:
200 if (GvGP (sv))
201 {
202 if (GvSV (sv) == (SV *)targ) res_gv ('$');
203 if (GvAV (sv) == (AV *)targ) res_gv ('@');
204 if (GvHV (sv) == (HV *)targ) res_gv ('%');
205 if (GvCV (sv) == (CV *)targ) res_gv ('&');
206 }
207
208 break;
209 }
210
122 if (rmagical) 211 if (rmagical)
123 SvRMAGICAL_off (sv); 212 SvRMAGICAL_on (sv);
124 } 213 }
125 } 214 }
126 215
127 EXTEND (SP, 2); 216 EXTEND (SP, 2);
128 PUSHs (sv_2mortal (newRV_noinc ((SV *)about))); 217 PUSHs (sv_2mortal (newRV_noinc ((SV *)about)));

Diff Legend

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