view release on metacpan or  search on metacpan

FindRef.xs  view on Meta::CPAN

#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)