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

#define res_pair(text)					\
  {							\
    AV *av = newAV ();					\
    av_push (av, newSVpv (text, 0));			\
    av_push (av, newRV_inc (sv));			\
    av_push (about, newRV_noinc ((SV *)av));		\
  }

#define res_gv(sigil)					\
  {							\
    AV *av = newAV ();					\
    av_push (av, newSVpv (form ("in the global %c%s::%.*s", sigil, \
                                HvNAME (GvSTASH (sv)), \
                                GvNAMELEN (sv), GvNAME (sv) ? GvNAME (sv) : "<anonymous>"), \
                          0));				\
    av_push (about, newRV_noinc ((SV *)av));		\
  }

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

PROTOTYPES: ENABLE

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

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

  	if (!SvROK (target))
          croak ("about 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 ((rmagical = SvRMAGICAL (sv)))
                  SvRMAGICAL_off (sv);

                //TODO: magic

                switch (SvTYPE (sv))
                  {
                    case SVt_RV:
                      if (sv != target && SvRV (sv) == targ)
                        res_pair ("referenced by");
                      break;

                    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_PVGV:
                      if (GvGP (sv))
                        {
                          if (GvSV (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_PVCV:
                      {
                        int depth = CvDEPTH (sv);
                        if (depth)
                          {
                            AV *padlist = CvPADLIST (sv);
                            while (depth)
                              {
                                AV *pad = (AV *)AvARRAY (padlist)[depth];
                                av_push (excl, newSVuv (PTR2UV (pad))); /* exclude pads from being found */
                                for (i = AvFILLp (pad); i--; )
                                  if (AvARRAY (pad)[i] == targ)
                                    res_pair (form ("in the lexical '%s' in", SvPVX (AvARRAY (AvARRAY (padlist)[0])[i])));

                                --depth;
                              }
                          }
                      }
                      break;
                  }

                if (rmagical)
                  SvRMAGICAL_off (sv);
              }
          }

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