view release on metacpan or  search on metacpan

FindRef.xs  view on Meta::CPAN

#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];