Devel-FindRef/FindRef.xs

#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

#define PERL_VERSION_ATLEAST(a,b,c)                             \
  (PERL_REVISION > (a)                                          \
   || (PERL_REVISION == (a)                                     \
       && (PERL_VERSION > (b)                                   \
           || (PERL_VERSION == (b) && PERLSUBVERSION >= (c)))))

#if !PERL_VERSION_ATLEAST (5,8,9)
# define SVt_LAST 16
#endif

#if !PERL_VERSION_ATLEAST (5,10,0)
# define SvPAD_OUR(dummy) 0
#endif

#define res_pair(text)                                          \
  do {                                                          \
    AV *av = newAV ();                                          \
    av_push (av, newSVpv (text, 0));                            \
    if (rmagical) SvRMAGICAL_on (sv);                           \
    av_push (av, sv_rvweaken (newRV_inc (sv)));                 \
    if (rmagical) SvRMAGICAL_off (sv);                          \
    av_push (about, newRV_noinc ((SV *)av));                    \
  } while (0)

#define res_text(text)                                          \
  do {                                                          \
    AV *av = newAV ();                                          \
    av_push (av, newSVpv (text, 0));                            \
    av_push (about, newRV_noinc ((SV *)av));                    \
  } while (0)

#define res_gv(sigil)                                           \
  res_text (form ("in the global %c%s::%.*s", sigil,            \
                  HvNAME (GvSTASH (sv)),                        \
                  GvNAMELEN (sv),                               \
                  GvNAME (sv) ? GvNAME (sv) : "<anonymous>"))

MODULE = Devel::FindRef         PACKAGE = Devel::FindRef                

PROTOTYPES: ENABLE

void
find_ (SV *target)
        PPCODE:
{
        SV *arena, *targ;
        U32 rmagical;
        int i;
        AV *about = newAV ();
        AV *excl  = newAV ();

        if (!SvROK (target))
          croak ("find expects a reference to a perl value");

        targ = SvRV (target);

        for (arena = PL_sv_arenaroot; arena; arena = SvANY (arena))
          {
            UV idx = SvREFCNT (arena);

            /* Remember that the zeroth slot is used as the pointer onwards, so don't
               include it. */
            while (--idx > 0)
              {
                SV *sv = &arena [idx];

                if (SvTYPE (sv) >= SVt_LAST)
                  continue;

                /* temporarily disable RMAGICAL, it can easily interfere with us */
                if ((rmagical = SvRMAGICAL (sv)))
                  SvRMAGICAL_off (sv);

                if (SvTYPE (sv) >= SVt_PVMG)
                  {
                    if (SvTYPE (sv) == SVt_PVMG && SvPAD_OUR (sv))
                      {
                        /* I have no clue what this is */
                        /* maybe some placeholder for our variables for eval? */
                        /* it doesn't seem to reference anything, so we should be able to ignore it */
                      }
                    else
                      {
                        MAGIC *mg = SvMAGIC (sv);

                        while (mg)
                          {
                            if (mg->mg_obj == targ)
                              res_pair (form ("referenced (in mg_obj) by '%c' type magic attached to", mg->mg_type));

                            if ((SV *)mg->mg_ptr == targ && mg->mg_flags & MGf_REFCOUNTED)
                              res_pair (form ("referenced (in mg_ptr) by '%c' type magic attached to", mg->mg_type));

                            mg = mg->mg_moremagic;
                          }
                      }
                  }

                if (SvROK (sv) && !SvWEAKREF (sv))
                  {
                    if (sv != target && SvRV (sv) == targ && !SvWEAKREF (sv))
                      res_pair ("referenced by");
                  }
                else
                  switch (SvTYPE (sv))
                    {
                      case SVt_PVAV:
                        if (AvREAL (sv))
                          for (i = AvFILLp (sv) + 1; i--; )
                            if (AvARRAY (sv)[i] == targ)
                              res_pair (form ("in array element %d of", i));

                        break;

                      case SVt_PVHV:
                        if (hv_iterinit ((HV *)sv))
                          {
                            HE *he;

                            while ((he = hv_iternext ((HV *)sv)))
                              if (HeVAL (he) == targ)
                                res_pair (form ("in the member '%.*s' of", HeKLEN (he), HeKEY (he)));
                          }

                        break;

                      case SVt_PVCV:
                        {
                          int depth = CvDEPTH (sv);

                          /* Anonymous subs have a padlist but zero depth */
                          if (CvANON (sv) && !depth && CvPADLIST (sv))
                            depth = 1;

                          if (depth)
                            {
                              AV *padlist = CvPADLIST (sv);

                              while (depth)
                                {
                                  AV *pad = (AV *)AvARRAY (padlist)[depth];

                                  av_push (excl, newSVuv (PTR2UV (pad))); /* exclude pads themselves from being found */

                                  /* The 0th pad slot is @_ */
                                  if (AvARRAY (pad)[0] == targ)
                                    res_pair ("the argument array for");

                                  for (i = AvFILLp (pad) + 1; --i; )
                                    if (AvARRAY (pad)[i] == targ)
                                      {
                                        /* Values from constant functions are stored in the pad without any name */
                                        SV *name_sv = AvARRAY (AvARRAY (padlist)[0])[i];

                                        if (name_sv && SvPOK (name_sv))
                                          res_pair (form ("in the lexical '%s' in", SvPVX (name_sv)));
                                        else
                                          res_pair ("in an unnamed lexical in");
                                      }

                                  --depth;
                                }
                            }

                          if (CvCONST (sv) && (SV*)CvXSUBANY (sv).any_ptr == targ)
                            res_pair ("the constant value of");

                          if (!CvWEAKOUTSIDE (sv) && (SV*)CvOUTSIDE (sv) == targ)
                            res_pair ("the containing scope for");

                          if (sv == targ && CvANON (sv))
                            if (CvSTART (sv)
                                && CvSTART (sv)->op_type == OP_NEXTSTATE
                                && CopLINE ((COP *)CvSTART (sv)))
                              res_text (form ("the closure created at %s:%d",
                                              CopFILE ((COP *)CvSTART (sv)) ? CopFILE ((COP *)CvSTART (sv)) : "<unknown>",
                                              CopLINE ((COP *)CvSTART (sv))));
                            else
                              res_text (form ("the closure created somewhere in file %s (PLEASE REPORT!)",
                                              CvFILE (sv) ? CvFILE (sv) : "<unknown>"));
                        }

                        break;

                      case SVt_PVGV:
                        if (GvGP (sv))
                          {
                            if (GvSV (sv) == (SV *)targ) res_gv ('$');
                            if (GvAV (sv) == (AV *)targ) res_gv ('@');
                            if (GvHV (sv) == (HV *)targ) res_gv ('%');
                            if (GvCV (sv) == (CV *)targ) res_gv ('&');
                          }

                        break;
                    }

                if (rmagical)
                  SvRMAGICAL_on (sv);
              }
          }

        if (targ == (SV*)PL_main_cv)
          res_text ("the main body of the program");

        EXTEND (SP, 2);
        PUSHs (sv_2mortal (newRV_noinc ((SV *)about)));
        PUSHs (sv_2mortal (newRV_noinc ((SV *)excl)));
}

SV *
ptr2ref (UV ptr)
        CODE:
        RETVAL = newRV_inc (INT2PTR (SV *, ptr));
        OUTPUT:
        RETVAL

UV
ref2ptr (SV *rv)
        CODE:
        RETVAL = PTR2UV (SvRV (rv));
        OUTPUT:
        RETVAL

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