--- Devel-FindRef/FindRef.xs 2007/01/11 22:30:34 1.1 +++ Devel-FindRef/FindRef.xs 2008/12/01 13:22:43 1.14 @@ -2,46 +2,59 @@ #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) : ""), \ - 0)); \ - av_push (about, newRV_noinc ((SV *)av)); \ - } +#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) : "")) 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; + U32 rmagical; + int i; AV *about = newAV (); AV *excl = newAV (); if (!SvROK (target)) - croak ("about expects a reference to a perl value"); + croak ("find expects a reference to a perl value"); targ = SvRV (target); @@ -54,78 +67,167 @@ 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); - //TODO: magic + 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); - switch (SvTYPE (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)) { - 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; + 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)); - 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; + 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)) + case SVt_PVCV: { - 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 ('&'); + 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)) : "", + CopLINE ((COP *)CvSTART (sv)))); + else + res_text (form ("the closure created somewhere in file %s (PLEASE REPORT!)", + CvFILE (sv) ? CvFILE (sv) : "")); } - 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; + + 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; - } + + break; + } if (rmagical) - SvRMAGICAL_off (sv); + 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