… | |
… | |
4 | |
4 | |
5 | #define PERL_VERSION_ATLEAST(a,b,c) \ |
5 | #define PERL_VERSION_ATLEAST(a,b,c) \ |
6 | (PERL_REVISION > (a) \ |
6 | (PERL_REVISION > (a) \ |
7 | || (PERL_REVISION == (a) \ |
7 | || (PERL_REVISION == (a) \ |
8 | && (PERL_VERSION > (b) \ |
8 | && (PERL_VERSION > (b) \ |
9 | || (PERL_VERSION == (b) && PERLSUBVERSION >= (c))))) |
9 | || (PERL_VERSION == (b) && PERL_SUBVERSION >= (c))))) |
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) |
15 | #ifndef SvPAD_OUR |
16 | # define SvPAD_OUR(dummy) 0 |
16 | # define SvPAD_OUR(dummy) 0 |
17 | #endif |
17 | #endif |
18 | |
18 | |
19 | /* pre-5.10 perls always succeed, with 5.10, we have to check first apparently */ |
19 | /* pre-5.10 perls always succeed, with 5.10, we have to check first apparently */ |
20 | #ifndef GvNAME_HEK |
20 | #ifndef GvNAME_HEK |
21 | # define GvNAME_HEK(sv) 1 |
21 | # define GvNAME_HEK(sv) 1 |
|
|
22 | #endif |
|
|
23 | |
|
|
24 | #ifndef PadARRAY |
|
|
25 | typedef AV PADNAMELIST; |
|
|
26 | typedef SV PADNAME; |
|
|
27 | # define PadnamePV(sv) SvPVX (sv) |
|
|
28 | # define PadnameLEN(sv) SvCUR (sv) |
|
|
29 | # define PadARRAY(pad) AvARRAY (pad) |
|
|
30 | # define PadlistARRAY(pl) ((PAD **)AvARRAY (pl)) |
|
|
31 | #endif |
|
|
32 | |
|
|
33 | #ifndef PadMAX |
|
|
34 | # define PadMAX(pad) AvFILLp (pad) |
|
|
35 | #endif |
|
|
36 | |
|
|
37 | #ifndef padnamelist_fetch |
|
|
38 | # define padnamelist_fetch(a,b) *av_fetch (a, b, FALSE) |
|
|
39 | #endif |
|
|
40 | |
|
|
41 | #ifndef PadlistNAMES |
|
|
42 | # define PadlistNAMES(padlist) *PadlistARRAY (padlist) |
22 | #endif |
43 | #endif |
23 | |
44 | |
24 | #define res_pair(text) \ |
45 | #define res_pair(text) \ |
25 | do { \ |
46 | do { \ |
26 | AV *av = newAV (); \ |
47 | AV *av = newAV (); \ |
… | |
… | |
37 | av_push (av, newSVpv (text, 0)); \ |
58 | av_push (av, newSVpv (text, 0)); \ |
38 | av_push (about, newRV_noinc ((SV *)av)); \ |
59 | av_push (about, newRV_noinc ((SV *)av)); \ |
39 | } while (0) |
60 | } while (0) |
40 | |
61 | |
41 | #define res_gv(sigil) \ |
62 | #define res_gv(sigil) \ |
42 | res_text (form ("in the global %c%s::%.*s", sigil, \ |
63 | res_text (form ("the global %c%s::%.*s", sigil, \ |
43 | HvNAME (GvSTASH (sv)), \ |
64 | HvNAME (GvSTASH (sv)), \ |
44 | GvNAME_HEK (sv) ? GvNAMELEN (sv) : 11, \ |
65 | GvNAME_HEK (sv) ? GvNAMELEN (sv) : 11, \ |
45 | GvNAME_HEK (sv) ? GvNAME (sv) : "<anonymous>")) |
66 | GvNAME_HEK (sv) ? GvNAME (sv) : "<anonymous>")) |
46 | |
67 | |
47 | MODULE = Devel::FindRef PACKAGE = Devel::FindRef |
68 | MODULE = Devel::FindRef PACKAGE = Devel::FindRef |
… | |
… | |
95 | if ((rmagical = SvRMAGICAL (sv))) |
116 | if ((rmagical = SvRMAGICAL (sv))) |
96 | SvRMAGICAL_off (sv); |
117 | SvRMAGICAL_off (sv); |
97 | |
118 | |
98 | if (SvTYPE (sv) >= SVt_PVMG) |
119 | if (SvTYPE (sv) >= SVt_PVMG) |
99 | { |
120 | { |
|
|
121 | #if !PERL_VERSION_ATLEAST (5,21,6) |
100 | if (SvTYPE (sv) == SVt_PVMG && SvPAD_OUR (sv)) |
122 | if (SvTYPE (sv) == SVt_PVMG && SvPAD_OUR (sv)) |
101 | { |
123 | { |
102 | /* I have no clue what this is */ |
124 | /* I have no clue what this is */ |
103 | /* maybe some placeholder for our variables for eval? */ |
125 | /* maybe some placeholder for our variables for eval? */ |
104 | /* it doesn't seem to reference anything, so we should be able to ignore it */ |
126 | /* it doesn't seem to reference anything, so we should be able to ignore it */ |
105 | } |
127 | } |
106 | else |
128 | else |
|
|
129 | #endif |
|
|
130 | if (SvMAGICAL (sv)) /* name-pads use SvMAGIC for other purposes */ |
107 | { |
131 | { |
108 | MAGIC *mg = SvMAGIC (sv); |
132 | MAGIC *mg = SvMAGIC (sv); |
109 | |
133 | |
110 | while (mg) |
134 | while (mg) |
111 | { |
135 | { |
… | |
… | |
132 | { |
156 | { |
133 | case SVt_PVAV: |
157 | case SVt_PVAV: |
134 | if (AvREAL (sv)) |
158 | if (AvREAL (sv)) |
135 | for (i = AvFILLp (sv) + 1; i--; ) |
159 | for (i = AvFILLp (sv) + 1; i--; ) |
136 | if (AvARRAY (sv)[i] == targ) |
160 | if (AvARRAY (sv)[i] == targ) |
137 | res_pair (form ("in array element %d of", i)); |
161 | res_pair (form ("the array element %d of", i)); |
138 | |
162 | |
139 | break; |
163 | break; |
140 | |
164 | |
141 | case SVt_PVHV: |
165 | case SVt_PVHV: |
142 | if (hv_iterinit ((HV *)sv)) |
166 | if (hv_iterinit ((HV *)sv)) |
143 | { |
167 | { |
144 | HE *he; |
168 | HE *he; |
145 | |
169 | |
146 | while ((he = hv_iternext ((HV *)sv))) |
170 | while ((he = hv_iternext ((HV *)sv))) |
147 | if (HeVAL (he) == targ) |
171 | if (HeVAL (he) == targ) |
148 | res_pair (form ("in the member '%.*s' of", HeKLEN (he), HeKEY (he))); |
172 | res_pair (form ("the hash member '%.*s' of", HeKLEN (he), HeKEY (he))); |
149 | } |
173 | } |
150 | |
174 | |
151 | break; |
175 | break; |
152 | |
176 | |
153 | case SVt_PVCV: |
177 | case SVt_PVCV: |
154 | { |
178 | { |
155 | int depth = CvDEPTH (sv); |
179 | PADLIST *padlist = CvISXSUB (cv) ? 0 : CvPADLIST (sv); |
156 | |
180 | |
157 | /* Anonymous subs have a padlist but zero depth */ |
|
|
158 | if (CvANON (sv) && !depth && CvPADLIST (sv)) |
|
|
159 | depth = 1; |
|
|
160 | |
|
|
161 | if (depth) |
181 | if (padlist) |
162 | { |
182 | { |
163 | AV *padlist = CvPADLIST (sv); |
183 | int depth = CvDEPTH (sv); |
|
|
184 | |
|
|
185 | /* Anonymous subs have a padlist but zero depth */ |
|
|
186 | /* some hacks switch CvANON off, so we just blindly assume a minimum of 1 */ |
|
|
187 | if (!depth && !PERL_VERSION_ATLEAST (5,21,6)) |
|
|
188 | depth = 1; |
164 | |
189 | |
165 | while (depth) |
190 | while (depth) |
166 | { |
191 | { |
167 | AV *pad = (AV *)AvARRAY (padlist)[depth]; |
192 | PAD *pad = PadlistARRAY (padlist)[depth]; |
168 | |
193 | |
169 | av_push (excl, newSVuv (PTR2UV (pad))); /* exclude pads themselves from being found */ |
194 | av_push (excl, newSVuv (PTR2UV (pad))); /* exclude pads themselves from being found */ |
170 | |
195 | |
171 | /* The 0th pad slot is @_ */ |
196 | /* The 0th pad slot is @_ */ |
172 | if (AvARRAY (pad)[0] == targ) |
197 | if (PadARRAY (pad)[0] == targ) |
173 | res_pair ("the argument array for"); |
198 | res_pair ("the argument array for"); |
174 | |
199 | |
175 | for (i = AvFILLp (pad) + 1; --i; ) |
200 | for (i = PadMAX (pad) + 1; --i; ) |
176 | if (AvARRAY (pad)[i] == targ) |
201 | if (PadARRAY (pad)[i] == targ) |
177 | { |
202 | { |
178 | /* Values from constant functions are stored in the pad without any name */ |
203 | /* Values from constant functions are stored in the pad without any name */ |
179 | SV *name_sv = AvARRAY (AvARRAY (padlist)[0])[i]; |
204 | PADNAME *name = padnamelist_fetch (PadlistNAMES (padlist), i); |
180 | |
205 | |
181 | if (name_sv && SvPOK (name_sv)) |
206 | if (name && PadnamePV (name) && *PadnamePV (name)) |
182 | res_pair (form ("the lexical '%s' in", SvPVX (name_sv))); |
207 | res_pair (form ("the lexical '%s' in", PadnamePV (name))); |
183 | else |
208 | else |
184 | res_pair ("an unnamed lexical in"); |
209 | res_pair ("an unnamed lexical in"); |
185 | } |
210 | } |
186 | |
211 | |
187 | --depth; |
212 | --depth; |
… | |
… | |
226 | { |
251 | { |
227 | MAGIC *mg = mg_find (sv, PERL_MAGIC_defelem); |
252 | MAGIC *mg = mg_find (sv, PERL_MAGIC_defelem); |
228 | |
253 | |
229 | if (mg && mg->mg_obj) |
254 | if (mg && mg->mg_obj) |
230 | res_pair (form ("the target for the lvalue hash element '%.*s',", |
255 | res_pair (form ("the target for the lvalue hash element '%.*s',", |
231 | SvCUR (mg->mg_obj), SvPV_nolen (mg->mg_obj))); |
256 | (int)SvCUR (mg->mg_obj), SvPV_nolen (mg->mg_obj))); |
232 | else |
257 | else |
233 | res_pair (form ("the target for the lvalue array element #%d,", LvTARGOFF (sv))); |
258 | res_pair (form ("the target for the lvalue array element #%d,", LvTARGOFF (sv))); |
234 | } |
259 | } |
235 | else |
260 | else |
236 | res_pair (form ("an lvalue reference target (type '%c', ofs %d, len %d),", |
261 | res_pair (form ("an lvalue reference target (type '%c', ofs %d, len %d),", |