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.7 by root, Sat Apr 26 03:15:28 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
5#define res_pair(text) \ 15#define res_pair(text) \
6 { \ 16 { \
7 AV *av = newAV (); \ 17 AV *av = newAV (); \
8 av_push (av, newSVpv (text, 0)); \ 18 av_push (av, newSVpv (text, 0)); \
19 if (rmagical) SvRMAGICAL_on (sv); \
9 av_push (av, newRV_inc (sv)); \ 20 av_push (av, sv_rvweaken (newRV_inc (sv))); \
21 if (rmagical) SvRMAGICAL_off (sv); \
10 av_push (about, newRV_noinc ((SV *)av)); \ 22 av_push (about, newRV_noinc ((SV *)av)); \
11 } 23 }
12 24
13#define res_gv(sigil) \ 25#define res_gv(sigil) \
14 { \ 26 { \
15 AV *av = newAV (); \ 27 AV *av = newAV (); \
16 av_push (av, newSVpv (form ("in the global %c%s::%.*s", sigil, \ 28 av_push (av, newSVpv (form ("in the global %c%s::%.*s", sigil, \
17 HvNAME (GvSTASH (sv)), \ 29 HvNAME (GvSTASH (sv)), \
18 GvNAMELEN (sv), GvNAME (sv) ? GvNAME (sv) : "<anonymous>"), \ 30 GvNAMELEN (sv), GvNAME (sv) ? GvNAME (sv) : "<anonymous>"), \
19 0)); \ 31 0)); \
20 av_push (about, newRV_noinc ((SV *)av)); \ 32 av_push (about, newRV_noinc ((SV *)av)); \
21 } 33 }
22 34
23MODULE = Devel::FindRef PACKAGE = Devel::FindRef 35MODULE = Devel::FindRef PACKAGE = Devel::FindRef
24 36
25PROTOTYPES: ENABLE 37PROTOTYPES: ENABLE
… …
39 int rmagical, i; 51 int rmagical, i;
40 AV *about = newAV (); 52 AV *about = newAV ();
41 AV *excl = newAV (); 53 AV *excl = newAV ();
42 54
43 if (!SvROK (target)) 55 if (!SvROK (target))
44 croak ("about expects a reference to a perl value"); 56 croak ("find expects a reference to a perl value");
45 57
46 targ = SvRV (target); 58 targ = SvRV (target);
47 59
48 for (arena = PL_sv_arenaroot; arena; arena = SvANY (arena)) 60 for (arena = PL_sv_arenaroot; arena; arena = SvANY (arena))
49 { 61 {
… …
52 /* Remember that the zeroth slot is used as the pointer onwards, so don't 64 /* Remember that the zeroth slot is used as the pointer onwards, so don't
53 include it. */ 65 include it. */
54 while (--idx > 0) 66 while (--idx > 0)
55 { 67 {
56 SV *sv = &arena [idx]; 68 SV *sv = &arena [idx];
57 69
70 if (SvTYPE (sv) >= SVt_LAST)
71 continue;
72
73 /* temporarily disable RMAGICAL, it can easily interfere with us */
58 if ((rmagical = SvRMAGICAL (sv))) 74 if ((rmagical = SvRMAGICAL (sv)))
59 SvRMAGICAL_off (sv); 75 SvRMAGICAL_off (sv);
60 76
61 //TODO: magic 77 if (SvTYPE (sv) >= SVt_PVMG)
78 {
79 MAGIC *mg = SvMAGIC (sv);
80 while (mg)
81 {
82 if (mg->mg_obj == targ)
83 res_pair (form ("referenced (in mg_obj) by '%c' type magic attached to", mg->mg_type));
62 84
63 switch (SvTYPE (sv)) 85 if ((SV *)mg->mg_ptr == targ && mg->mg_flags & MGf_REFCOUNTED)
64 { 86 res_pair (form ("referenced (in mg_ptr) by '%c' type magic attached to", mg->mg_type));
65 case SVt_RV:
66 if (sv != target && SvRV (sv) == targ)
67 res_pair ("referenced by");
68 break;
69 87
70 case SVt_PVAV: 88 mg = mg->mg_moremagic;
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 {
103 int depth = CvDEPTH (sv);
104 if (depth)
105 {
106 AV *padlist = CvPADLIST (sv);
107 while (depth)
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
115 --depth;
116 }
117 }
118 } 89 }
119 break;
120 } 90 }
121 91
92 if (SvROK (sv))
93 {
94 if (sv != target && SvRV (sv) == targ && !SvWEAKREF (sv))
95 res_pair ("referenced by");
96 }
97 else
98 switch (SvTYPE (sv))
99 {
100 case SVt_PVAV:
101 if (AvREAL (sv))
102 for (i = AvFILLp (sv) + 1; i--; )
103 if (AvARRAY (sv)[i] == targ)
104 res_pair (form ("in array element %d of", i));
105
106 break;
107
108 case SVt_PVHV:
109 if (hv_iterinit ((HV *)sv))
110 {
111 HE *he;
112
113 while ((he = hv_iternext ((HV *)sv)))
114 if (HeVAL (he) == targ)
115 res_pair (form ("in the member '%.*s' of", HeKLEN (he), HeKEY (he)));
116 }
117
118 break;
119
120 case SVt_PVCV:
121 {
122 int depth = CvDEPTH (sv);
123
124 if (!depth && CvPADLIST(sv))
125 depth = 1;
126
127 if (depth)
128 {
129 AV *padlist = CvPADLIST (sv);
130
131 while (depth)
132 {
133 AV *pad = (AV *)AvARRAY (padlist)[depth];
134
135 av_push (excl, newSVuv (PTR2UV (pad))); /* exclude pads themselves from being found */
136
137 for (i = AvFILLp (pad) + 1; i--; )
138 if (AvARRAY (pad)[i] == targ)
139 res_pair (form ("in the lexical '%s' in", SvPVX (AvARRAY (AvARRAY (padlist)[0])[i])));
140
141 --depth;
142 }
143 }
144
145 if ((SV*)CvOUTSIDE(sv) == targ)
146 res_pair ("the containing scope for");
147 }
148
149 break;
150
151 case SVt_PVGV:
152 if (GvGP (sv))
153 {
154 if (GvSV (sv) == (SV *)targ) res_gv ('$');
155 if (GvAV (sv) == (AV *)targ) res_gv ('@');
156 if (GvHV (sv) == (HV *)targ) res_gv ('%');
157 if (GvCV (sv) == (CV *)targ) res_gv ('&');
158 }
159
160 break;
161 }
162
122 if (rmagical) 163 if (rmagical)
123 SvRMAGICAL_off (sv); 164 SvRMAGICAL_on (sv);
124 } 165 }
125 } 166 }
126 167
127 EXTEND (SP, 2); 168 EXTEND (SP, 2);
128 PUSHs (sv_2mortal (newRV_noinc ((SV *)about))); 169 PUSHs (sv_2mortal (newRV_noinc ((SV *)about)));

Diff Legend

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