ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/Devel-FindRef/FindRef.xs
Revision: 1.10
Committed: Fri Jul 11 15:33:48 2008 UTC (15 years, 10 months ago) by root
Branch: MAIN
Changes since 1.9: +7 -1 lines
Log Message: 
*** empty log message ***

File Contents

# User Rev Content
1 root 1.1 #include "EXTERN.h"
2     #include "perl.h"
3     #include "XSUB.h"
4    
5 root 1.4 #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 root 1.9 #if !PERL_VERSION_ATLEAST (5,10,0)
16     # define SvPAD_OUR(dummy) 0
17     #endif
18    
19 root 1.6 #define res_pair(text) \
20 root 1.8 do { \
21 root 1.6 AV *av = newAV (); \
22     av_push (av, newSVpv (text, 0)); \
23 root 1.7 if (rmagical) SvRMAGICAL_on (sv); \
24 root 1.6 av_push (av, sv_rvweaken (newRV_inc (sv))); \
25 root 1.7 if (rmagical) SvRMAGICAL_off (sv); \
26 root 1.6 av_push (about, newRV_noinc ((SV *)av)); \
27 root 1.8 } while (0)
28 root 1.1
29 root 1.6 #define res_gv(sigil) \
30 root 1.8 do { \
31 root 1.6 AV *av = newAV (); \
32 root 1.1 av_push (av, newSVpv (form ("in the global %c%s::%.*s", sigil, \
33 root 1.6 HvNAME (GvSTASH (sv)), \
34 root 1.1 GvNAMELEN (sv), GvNAME (sv) ? GvNAME (sv) : "<anonymous>"), \
35 root 1.6 0)); \
36     av_push (about, newRV_noinc ((SV *)av)); \
37 root 1.8 } while (0)
38 root 1.1
39     MODULE = Devel::FindRef PACKAGE = Devel::FindRef
40    
41     PROTOTYPES: ENABLE
42    
43     SV *
44     ptr2ref (IV ptr)
45     CODE:
46     RETVAL = newRV_inc (INT2PTR (SV *, ptr));
47     OUTPUT:
48     RETVAL
49    
50     void
51     find_ (SV *target)
52     PPCODE:
53     {
54     SV *arena, *targ;
55 root 1.9 U32 rmagical;
56     int i;
57 root 1.1 AV *about = newAV ();
58     AV *excl = newAV ();
59    
60     if (!SvROK (target))
61 root 1.3 croak ("find expects a reference to a perl value");
62 root 1.1
63     targ = SvRV (target);
64    
65     for (arena = PL_sv_arenaroot; arena; arena = SvANY (arena))
66     {
67     UV idx = SvREFCNT (arena);
68    
69     /* Remember that the zeroth slot is used as the pointer onwards, so don't
70     include it. */
71     while (--idx > 0)
72     {
73     SV *sv = &arena [idx];
74 root 1.2
75     if (SvTYPE (sv) >= SVt_LAST)
76     continue;
77    
78     /* temporarily disable RMAGICAL, it can easily interfere with us */
79 root 1.1 if ((rmagical = SvRMAGICAL (sv)))
80     SvRMAGICAL_off (sv);
81    
82 root 1.2 if (SvTYPE (sv) >= SVt_PVMG)
83     {
84 root 1.9
85 root 1.10 if (SvTYPE (sv) == SVt_PVMG && SvPAD_OUR (sv))
86     {
87     /* I have no clue what this is */
88     /* maybe some placeholder for our variables for eval? */
89     /* it doesn'T seem to reference anything, so we should be able to ignore it */
90     }
91     else
92 root 1.2 {
93 root 1.9 MAGIC *mg = SvMAGIC (sv);
94 root 1.6
95 root 1.9 while (mg)
96     {
97     if (mg->mg_obj == targ)
98     res_pair (form ("referenced (in mg_obj) by '%c' type magic attached to", mg->mg_type));
99 root 1.2
100 root 1.9 if ((SV *)mg->mg_ptr == targ && mg->mg_flags & MGf_REFCOUNTED)
101     res_pair (form ("referenced (in mg_ptr) by '%c' type magic attached to", mg->mg_type));
102    
103     mg = mg->mg_moremagic;
104     }
105 root 1.2 }
106     }
107 root 1.1
108 root 1.6 if (SvROK (sv))
109 root 1.1 {
110 root 1.6 if (sv != target && SvRV (sv) == targ && !SvWEAKREF (sv))
111     res_pair ("referenced by");
112     }
113     else
114     switch (SvTYPE (sv))
115     {
116     case SVt_PVAV:
117     if (AvREAL (sv))
118     for (i = AvFILLp (sv) + 1; i--; )
119     if (AvARRAY (sv)[i] == targ)
120     res_pair (form ("in array element %d of", i));
121 root 1.1
122 root 1.6 break;
123 root 1.1
124 root 1.6 case SVt_PVHV:
125     if (hv_iterinit ((HV *)sv))
126 root 1.1 {
127 root 1.6 HE *he;
128 root 1.1
129 root 1.6 while ((he = hv_iternext ((HV *)sv)))
130     if (HeVAL (he) == targ)
131     res_pair (form ("in the member '%.*s' of", HeKLEN (he), HeKEY (he)));
132 root 1.1 }
133 root 1.2
134 root 1.6 break;
135    
136     case SVt_PVCV:
137 root 1.2 {
138 root 1.6 int depth = CvDEPTH (sv);
139    
140 root 1.8 /* Anonymous subs have a padlist but zero depth */
141     if (!depth && CvPADLIST (sv))
142 root 1.7 depth = 1;
143    
144 root 1.6 if (depth)
145     {
146     AV *padlist = CvPADLIST (sv);
147    
148     while (depth)
149     {
150     AV *pad = (AV *)AvARRAY (padlist)[depth];
151    
152     av_push (excl, newSVuv (PTR2UV (pad))); /* exclude pads themselves from being found */
153    
154 root 1.7 for (i = AvFILLp (pad) + 1; i--; )
155 root 1.6 if (AvARRAY (pad)[i] == targ)
156 root 1.8 {
157     /* Values from constant functions are stored in the pad without any name */
158     SV *name_sv = AvARRAY (AvARRAY (padlist)[0])[i];
159    
160     if (name_sv && SvPOK (name_sv))
161     res_pair (form ("in the lexical '%s' in", SvPVX (name_sv)));
162     else
163     res_pair ("in an unnamed lexical in");
164     }
165 root 1.6
166     --depth;
167     }
168     }
169 root 1.7
170 root 1.8 if (CvCONST (sv) && (SV*)CvXSUBANY (sv).any_ptr == targ)
171     res_pair ("the constant value of");
172    
173     if (!CvWEAKOUTSIDE (sv) && (SV*)CvOUTSIDE (sv) == targ)
174 root 1.7 res_pair ("the containing scope for");
175 root 1.2 }
176 root 1.6
177     break;
178    
179     case SVt_PVGV:
180     if (GvGP (sv))
181     {
182     if (GvSV (sv) == (SV *)targ) res_gv ('$');
183     if (GvAV (sv) == (AV *)targ) res_gv ('@');
184     if (GvHV (sv) == (HV *)targ) res_gv ('%');
185     if (GvCV (sv) == (CV *)targ) res_gv ('&');
186     }
187    
188     break;
189     }
190 root 1.1
191     if (rmagical)
192 root 1.5 SvRMAGICAL_on (sv);
193 root 1.1 }
194     }
195    
196     EXTEND (SP, 2);
197     PUSHs (sv_2mortal (newRV_noinc ((SV *)about)));
198     PUSHs (sv_2mortal (newRV_noinc ((SV *)excl)));
199     }
200