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) && PERL_SUBVERSION >= (c)))))

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

#ifndef SvPAD_OUR
# define SvPAD_OUR(dummy) 0
#endif

/* pre-5.10 perls always succeed, with 5.10, we have to check first apparently */
#ifndef GvNAME_HEK
# define GvNAME_HEK(sv) 1
#endif

#ifndef PadARRAY
typedef AV PADNAMELIST;
typedef SV PADNAME;
# define PadnamePV(sv) SvPVX (sv)
# define PadnameLEN(sv) SvCUR (sv)
# define PadARRAY(pad) AvARRAY (pad)
# define PadlistARRAY(pl) ((PAD **)AvARRAY (pl))
#endif

#ifndef PadMAX
# define PadMAX(pad) AvFILLp (pad)
#endif

#ifndef padnamelist_fetch
# define padnamelist_fetch(a,b) *av_fetch (a, b, FALSE)
#endif

#ifndef PadlistNAMES
# define PadlistNAMES(padlist) *PadlistARRAY (padlist)
#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 ("the global %c%s::%.*s", sigil,               \
                  HvNAME (GvSTASH (sv)),                        \
                  GvNAME_HEK (sv) ? GvNAMELEN (sv) : 11,        \
                  GvNAME_HEK (sv) ? GvNAME    (sv) : "<anonymous>"))

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

PROTOTYPES: ENABLE

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

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

        targ = SvRV (target_ref);

        if (SvIMMORTAL (targ))
          {
            if (targ == &PL_sv_undef)
              res_text ("the immortal 'undef' value");
            else if (targ == &PL_sv_yes)
              res_text ("the immortal 'yes' value");
            else if (targ == &PL_sv_no)
              res_text ("the immortal 'no' value");
            else if (targ == &PL_sv_placeholder)
              res_text ("the immortal placeholder value");
            else
              res_text ("some unknown immortal");
          }
        else
          {
            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 !PERL_VERSION_ATLEAST (5,21,6)
                        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
#endif
                        if (SvMAGICAL (sv)) /* name-pads use SvMAGIC for other purposes */
                          {
                            MAGIC *mg = SvMAGIC (sv);

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

                                if ((SV *)mg->mg_ptr == targ)
                                  res_pair (form ("%sreferenced (in mg_ptr) by '%c' type magic attached to",
                                                  mg->mg_len == HEf_SVKEY ? "" : "possibly ",
                                                  mg->mg_type));

                                mg = mg->mg_moremagic;
                              }
                          }
                      }

                    if (SvROK (sv))
                      {
                        if (SvRV (sv) == targ && !SvWEAKREF (sv) && sv != target_ref)
                          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 ("the 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 ("the hash member '%.*s' of", HeKLEN (he), HeKEY (he)));
                              }

                            break;

                          case SVt_PVCV:
                            {
                              PADLIST *padlist = CvPADLIST (sv);

                              if (padlist)
                                {
                                  int depth = CvDEPTH (sv);

                                /* Anonymous subs have a padlist but zero depth */
                                /* some hacks switch CvANON off, so we just blindly assume a minimum of 1 */
                                  if (!depth && !PERL_VERSION_ATLEAST (5,21,6))
                                    depth = 1;

                                  while (depth)
                                    {
                                      PAD *pad = PadlistARRAY (padlist)[depth];

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

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

                                      for (i = PadMAX (pad) + 1; --i; )
                                        if (PadARRAY (pad)[i] == targ)
                                          {
                                            /* Values from constant functions are stored in the pad without any name */
                                            PADNAME *name = padnamelist_fetch (PadlistNAMES (padlist), i);

                                            if (name && PadnamePV (name) && *PadnamePV (name))
                                              res_pair (form ("the lexical '%s' in", PadnamePV (name)));
                                            else
                                              res_pair ("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;

                          case SVt_PVLV:
                            if (LvTARG (sv) == targ)
                              {
                                if (LvTYPE (sv) == 'y')
                                  {
                                    MAGIC *mg = mg_find (sv, PERL_MAGIC_defelem);

                                    if (mg && mg->mg_obj)
                                      res_pair (form ("the target for the lvalue hash element '%.*s',",
                                                      (int)SvCUR (mg->mg_obj), SvPV_nolen (mg->mg_obj)));
                                    else
                                      res_pair (form ("the target for the lvalue array element #%d,", LvTARGOFF (sv)));
                                  }
                                else
                                  res_pair (form ("an lvalue reference target (type '%c', ofs %d, len %d),",
                                                  LvTYPE (sv), LvTARGOFF (sv), LvTARGLEN (sv)));
                              }

                            break;
                        }

                    if (rmagical)
                      SvRMAGICAL_on (sv);
                  }
              }

            /* look at the mortalise stack of the current coroutine */
            for (i = 0; i <= PL_tmps_ix; ++i)
              if (PL_tmps_stack [i] == targ)
                res_text ("a temporary on the stack");

            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:
        if (!SvROK (rv))
          croak ("argument to Devel::FindRef::ref2ptr must be a reference");
        RETVAL = PTR2UV (SvRV (rv));
        OUTPUT:
        RETVAL

U32
_refcnt (SV *rv)
        CODE:
        if (!SvROK (rv))
          croak ("argument to Devel::FindRef::_refcnt must be a reference");
        RETVAL = SvREFCNT (SvRV (rv));
        OUTPUT:
        RETVAL
Revision:	1.26
Committed:	Fri Jun 23 14:40:34 2017 UTC (6 years, 10 months ago) by root
Branch:	MAIN
CVS Tags:	rel-1_45
Changes since 1.25:	+28 -10 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	root	1.26	\|\| (PERL_VERSION == (b) && PERL_SUBVERSION >= (c)))))
10	root	1.4
11			#if !PERL_VERSION_ATLEAST (5,8,9)
12			# define SVt_LAST 16
13			#endif
14
15	root	1.26	#ifndef SvPAD_OUR
16	root	1.9	# define SvPAD_OUR(dummy) 0
17			#endif
18
19	root	1.17	/* pre-5.10 perls always succeed, with 5.10, we have to check first apparently */
20			#ifndef GvNAME_HEK
21			# define GvNAME_HEK(sv) 1
22			#endif
23
24	root	1.23	#ifndef PadARRAY
25	root	1.26	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	root	1.23	# define PadlistARRAY(pl) ((PAD **)AvARRAY (pl))
31			#endif
32
33	root	1.26	#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)
43			#endif
44	root	1.23
45	root	1.6	#define res_pair(text) \
46	root	1.8	do { \
47	root	1.6	AV *av = newAV (); \
48			av_push (av, newSVpv (text, 0)); \
49	root	1.7	if (rmagical) SvRMAGICAL_on (sv); \
50	root	1.6	av_push (av, sv_rvweaken (newRV_inc (sv))); \
51	root	1.7	if (rmagical) SvRMAGICAL_off (sv); \
52	root	1.6	av_push (about, newRV_noinc ((SV *)av)); \
53	root	1.8	} while (0)
54	root	1.1
55	root	1.11	#define res_text(text) \
56	root	1.8	do { \
57	root	1.6	AV *av = newAV (); \
58	root	1.11	av_push (av, newSVpv (text, 0)); \
59	root	1.6	av_push (about, newRV_noinc ((SV *)av)); \
60	root	1.8	} while (0)
61	root	1.1
62	root	1.11	#define res_gv(sigil) \
63	root	1.19	res_text (form ("the global %c%s::%.*s", sigil, \
64	root	1.11	HvNAME (GvSTASH (sv)), \
65	root	1.17	GvNAME_HEK (sv) ? GvNAMELEN (sv) : 11, \
66			GvNAME_HEK (sv) ? GvNAME (sv) : "<anonymous>"))
67	root	1.11
68	root	1.1	MODULE = Devel::FindRef PACKAGE = Devel::FindRef
69
70			PROTOTYPES: ENABLE
71
72			void
73	root	1.15	find_ (SV *target_ref)
74	root	1.1	PPCODE:
75			{
76			SV arena, targ;
77	root	1.9	U32 rmagical;
78			int i;
79	root	1.1	AV *about = newAV ();
80			AV *excl = newAV ();
81
82	root	1.15	if (!SvROK (target_ref))
83	root	1.3	croak ("find expects a reference to a perl value");
84	root	1.1
85	root	1.15	targ = SvRV (target_ref);
86	root	1.1
87	root	1.16	if (SvIMMORTAL (targ))
88	root	1.1	{
89	root	1.16	if (targ == &PL_sv_undef)
90			res_text ("the immortal 'undef' value");
91			else if (targ == &PL_sv_yes)
92			res_text ("the immortal 'yes' value");
93			else if (targ == &PL_sv_no)
94			res_text ("the immortal 'no' value");
95			else if (targ == &PL_sv_placeholder)
96			res_text ("the immortal placeholder value");
97			else
98			res_text ("some unknown immortal");
99			}
100			else
101			{
102			for (arena = PL_sv_arenaroot; arena; arena = SvANY (arena))
103			{
104			UV idx = SvREFCNT (arena);
105	root	1.1
106	root	1.16	/* Remember that the zeroth slot is used as the pointer onwards, so don't
107			include it. */
108			while (--idx > 0)
109			{
110			SV *sv = &arena [idx];
111	root	1.2
112	root	1.16	if (SvTYPE (sv) >= SVt_LAST)
113			continue;
114	root	1.2
115	root	1.16	/* temporarily disable RMAGICAL, it can easily interfere with us */
116			if ((rmagical = SvRMAGICAL (sv)))
117			SvRMAGICAL_off (sv);
118	root	1.1
119	root	1.16	if (SvTYPE (sv) >= SVt_PVMG)
120	root	1.10	{
121	root	1.26	#if !PERL_VERSION_ATLEAST (5,21,6)
122	root	1.16	if (SvTYPE (sv) == SVt_PVMG && SvPAD_OUR (sv))
123			{
124			/* I have no clue what this is */
125			/* maybe some placeholder for our variables for eval? */
126			/* it doesn't seem to reference anything, so we should be able to ignore it */
127			}
128	root	1.26	else
129			#endif
130			if (SvMAGICAL (sv)) /* name-pads use SvMAGIC for other purposes */
131	root	1.9	{
132	root	1.16	MAGIC *mg = SvMAGIC (sv);
133	root	1.2
134	root	1.16	while (mg)
135			{
136			if (mg->mg_obj == targ && mg->mg_flags & MGf_REFCOUNTED)
137			res_pair (form ("referenced (in mg_obj) by '%c' type magic attached to", mg->mg_type));
138
139			if ((SV *)mg->mg_ptr == targ)
140			res_pair (form ("%sreferenced (in mg_ptr) by '%c' type magic attached to",
141			mg->mg_len == HEf_SVKEY ? "" : "possibly ",
142			mg->mg_type));
143	root	1.9
144	root	1.16	mg = mg->mg_moremagic;
145			}
146	root	1.9	}
147	root	1.2	}
148	root	1.1
149	root	1.16	if (SvROK (sv))
150			{
151			if (SvRV (sv) == targ && !SvWEAKREF (sv) && sv != target_ref)
152			res_pair ("referenced by");
153			}
154			else
155			switch (SvTYPE (sv))
156	root	1.2	{
157	root	1.16	case SVt_PVAV:
158			if (AvREAL (sv))
159			for (i = AvFILLp (sv) + 1; i--; )
160			if (AvARRAY (sv)[i] == targ)
161	root	1.19	res_pair (form ("the array element %d of", i));
162	root	1.16
163			break;
164
165			case SVt_PVHV:
166			if (hv_iterinit ((HV *)sv))
167			{
168			HE *he;
169
170			while ((he = hv_iternext ((HV *)sv)))
171			if (HeVAL (he) == targ)
172	root	1.22	res_pair (form ("the hash member '%.*s' of", HeKLEN (he), HeKEY (he)));
173	root	1.16	}
174	root	1.6
175	root	1.16	break;
176	root	1.7
177	root	1.16	case SVt_PVCV:
178	root	1.6	{
179	root	1.24	PADLIST *padlist = CvPADLIST (sv);
180	root	1.6
181	root	1.24	if (padlist)
182			{
183			int depth = CvDEPTH (sv);
184	root	1.16
185	root	1.24	/* Anonymous subs have a padlist but zero depth */
186			/* some hacks switch CvANON off, so we just blindly assume a minimum of 1 */
187	root	1.26	if (!depth && !PERL_VERSION_ATLEAST (5,21,6))
188	root	1.24	depth = 1;
189	root	1.6
190	root	1.16	while (depth)
191			{
192	root	1.23	PAD *pad = PadlistARRAY (padlist)[depth];
193	root	1.16
194			av_push (excl, newSVuv (PTR2UV (pad))); /* exclude pads themselves from being found */
195
196			/* The 0th pad slot is @_ */
197	root	1.23	if (PadARRAY (pad)[0] == targ)
198	root	1.16	res_pair ("the argument array for");
199
200	root	1.26	for (i = PadMAX (pad) + 1; --i; )
201			if (PadARRAY (pad)[i] == targ)
202	root	1.16	{
203			/* Values from constant functions are stored in the pad without any name */
204	root	1.26	PADNAME *name = padnamelist_fetch (PadlistNAMES (padlist), i);
205	root	1.16
206	root	1.26	if (name && PadnamePV (name) && *PadnamePV (name))
207			res_pair (form ("the lexical '%s' in", PadnamePV (name)));
208	root	1.16	else
209	root	1.18	res_pair ("an unnamed lexical in");
210	root	1.16	}
211	root	1.6
212	root	1.16	--depth;
213			}
214	root	1.6	}
215	root	1.7
216	root	1.16	if (CvCONST (sv) && (SV*)CvXSUBANY (sv).any_ptr == targ)
217			res_pair ("the constant value of");
218	root	1.8
219	root	1.16	if (!CvWEAKOUTSIDE (sv) && (SV*)CvOUTSIDE (sv) == targ)
220			res_pair ("the containing scope for");
221	root	1.11
222	root	1.16	if (sv == targ && CvANON (sv))
223			if (CvSTART (sv)
224			&& CvSTART (sv)->op_type == OP_NEXTSTATE
225			&& CopLINE ((COP *)CvSTART (sv)))
226			res_text (form ("the closure created at %s:%d",
227			CopFILE ((COP )CvSTART (sv)) ? CopFILE ((COP )CvSTART (sv)) : "<unknown>",
228			CopLINE ((COP *)CvSTART (sv))));
229			else
230			res_text (form ("the closure created somewhere in file %s (PLEASE REPORT!)",
231			CvFILE (sv) ? CvFILE (sv) : "<unknown>"));
232			}
233	root	1.6
234	root	1.16	break;
235	root	1.6
236	root	1.16	case SVt_PVGV:
237			if (GvGP (sv))
238			{
239			if (GvSV (sv) == (SV *)targ) res_gv ('$');
240			if (GvAV (sv) == (AV *)targ) res_gv ('@');
241			if (GvHV (sv) == (HV *)targ) res_gv ('%');
242			if (GvCV (sv) == (CV *)targ) res_gv ('&');
243			}
244
245			break;
246
247			case SVt_PVLV:
248			if (LvTARG (sv) == targ)
249			{
250			if (LvTYPE (sv) == 'y')
251			{
252			MAGIC *mg = mg_find (sv, PERL_MAGIC_defelem);
253
254			if (mg && mg->mg_obj)
255			res_pair (form ("the target for the lvalue hash element '%.*s',",
256	root	1.20	(int)SvCUR (mg->mg_obj), SvPV_nolen (mg->mg_obj)));
257	root	1.16	else
258			res_pair (form ("the target for the lvalue array element #%d,", LvTARGOFF (sv)));
259			}
260			else
261			res_pair (form ("an lvalue reference target (type '%c', ofs %d, len %d),",
262			LvTYPE (sv), LvTARGOFF (sv), LvTARGLEN (sv)));
263			}
264	root	1.6
265	root	1.16	break;
266			}
267	root	1.1
268	root	1.16	if (rmagical)
269			SvRMAGICAL_on (sv);
270			}
271	root	1.1	}
272
273	root	1.16	/* look at the mortalise stack of the current coroutine */
274			for (i = 0; i <= PL_tmps_ix; ++i)
275			if (PL_tmps_stack [i] == targ)
276			res_text ("a temporary on the stack");
277	root	1.15
278	root	1.16	if (targ == (SV*)PL_main_cv)
279			res_text ("the main body of the program");
280			}
281	root	1.13
282	root	1.1	EXTEND (SP, 2);
283			PUSHs (sv_2mortal (newRV_noinc ((SV *)about)));
284			PUSHs (sv_2mortal (newRV_noinc ((SV *)excl)));
285			}
286
287	root	1.14	SV *
288			ptr2ref (UV ptr)
289			CODE:
290			RETVAL = newRV_inc (INT2PTR (SV *, ptr));
291			OUTPUT:
292			RETVAL
293
294			UV
295			ref2ptr (SV *rv)
296			CODE:
297	root	1.16	if (!SvROK (rv))
298			croak ("argument to Devel::FindRef::ref2ptr must be a reference");
299	root	1.14	RETVAL = PTR2UV (SvRV (rv));
300			OUTPUT:
301			RETVAL
302
303			U32
304			_refcnt (SV *rv)
305			CODE:
306	root	1.16	if (!SvROK (rv))
307			croak ("argument to Devel::FindRef::_refcnt must be a reference");
308	root	1.14	RETVAL = SvREFCNT (SvRV (rv));
309			OUTPUT:
310			RETVAL