ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/Devel-FindRef/FindRef.xs
Revision: 1.9
Committed: Fri Jul 11 15:29:48 2008 UTC (15 years, 10 months ago) by root
Branch: MAIN
Changes since 1.8: +18 -8 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     if (SvTYPE (sv) != SVt_PVMG || SvPAD_OUR (sv))
86 root 1.2 {
87 root 1.9 MAGIC *mg = SvMAGIC (sv);
88 root 1.6
89 root 1.9 while (mg)
90     {
91     if (mg->mg_obj == targ)
92     res_pair (form ("referenced (in mg_obj) by '%c' type magic attached to", mg->mg_type));
93 root 1.2
94 root 1.9 if ((SV *)mg->mg_ptr == targ && mg->mg_flags & MGf_REFCOUNTED)
95     res_pair (form ("referenced (in mg_ptr) by '%c' type magic attached to", mg->mg_type));
96    
97     mg = mg->mg_moremagic;
98     }
99 root 1.2 }
100     }
101 root 1.1
102 root 1.6 if (SvROK (sv))
103 root 1.1 {
104 root 1.6 if (sv != target && SvRV (sv) == targ && !SvWEAKREF (sv))
105     res_pair ("referenced by");
106     }
107     else
108     switch (SvTYPE (sv))
109     {
110     case SVt_PVAV:
111     if (AvREAL (sv))
112     for (i = AvFILLp (sv) + 1; i--; )
113     if (AvARRAY (sv)[i] == targ)
114     res_pair (form ("in array element %d of", i));
115 root 1.1
116 root 1.6 break;
117 root 1.1
118 root 1.6 case SVt_PVHV:
119     if (hv_iterinit ((HV *)sv))
120 root 1.1 {
121 root 1.6 HE *he;
122 root 1.1
123 root 1.6 while ((he = hv_iternext ((HV *)sv)))
124     if (HeVAL (he) == targ)
125     res_pair (form ("in the member '%.*s' of", HeKLEN (he), HeKEY (he)));
126 root 1.1 }
127 root 1.2
128 root 1.6 break;
129    
130     case SVt_PVCV:
131 root 1.2 {
132 root 1.6 int depth = CvDEPTH (sv);
133    
134 root 1.8 /* Anonymous subs have a padlist but zero depth */
135     if (!depth && CvPADLIST (sv))
136 root 1.7 depth = 1;
137    
138 root 1.6 if (depth)
139     {
140     AV *padlist = CvPADLIST (sv);
141    
142     while (depth)
143     {
144     AV *pad = (AV *)AvARRAY (padlist)[depth];
145    
146     av_push (excl, newSVuv (PTR2UV (pad))); /* exclude pads themselves from being found */
147    
148 root 1.7 for (i = AvFILLp (pad) + 1; i--; )
149 root 1.6 if (AvARRAY (pad)[i] == targ)
150 root 1.8 {
151     /* Values from constant functions are stored in the pad without any name */
152     SV *name_sv = AvARRAY (AvARRAY (padlist)[0])[i];
153    
154     if (name_sv && SvPOK (name_sv))
155     res_pair (form ("in the lexical '%s' in", SvPVX (name_sv)));
156     else
157     res_pair ("in an unnamed lexical in");
158     }
159 root 1.6
160     --depth;
161     }
162     }
163 root 1.7
164 root 1.8 if (CvCONST (sv) && (SV*)CvXSUBANY (sv).any_ptr == targ)
165     res_pair ("the constant value of");
166    
167     if (!CvWEAKOUTSIDE (sv) && (SV*)CvOUTSIDE (sv) == targ)
168 root 1.7 res_pair ("the containing scope for");
169 root 1.2 }
170 root 1.6
171     break;
172    
173     case SVt_PVGV:
174     if (GvGP (sv))
175     {
176     if (GvSV (sv) == (SV *)targ) res_gv ('$');
177     if (GvAV (sv) == (AV *)targ) res_gv ('@');
178     if (GvHV (sv) == (HV *)targ) res_gv ('%');
179     if (GvCV (sv) == (CV *)targ) res_gv ('&');
180     }
181    
182     break;
183     }
184 root 1.1
185     if (rmagical)
186 root 1.5 SvRMAGICAL_on (sv);
187 root 1.1 }
188     }
189    
190     EXTEND (SP, 2);
191     PUSHs (sv_2mortal (newRV_noinc ((SV *)about)));
192     PUSHs (sv_2mortal (newRV_noinc ((SV *)excl)));
193     }
194