/* 
CHECK_IF_SUB_USED_ON_OBJECT(ITEM,SV_CV)
   utility define for checking to see if UNIVERSAL::DOES() has been
   called as a subroutine on a class or object that overrides DOES.
   If it does then we set SV_CV to hold the method which will 
   mean later on it will get called. 
   ITEM holds the code required to find the stash of the thing we are
   looking up.
*/   

#define CHECK_IF_SUB_USED_ON_OBJECT(ITEM,SV_CV) STMT_START { \
    HV *me = gv_stashpvs("UNIVERSAL", 0); \
    HV *them = ITEM; \
    if (me && them) { \
        const char *does="DOES"; \
        GV * const gv_me = gv_fetchmethod_autoload(me, does, FALSE); \
        GV * const gv_them = gv_fetchmethod_autoload(them, does, FALSE
+); \
        if (gv_me != gv_them && gv_me && isGV(gv_me) && gv_them && \
            isGV(gv_them) && GvCV(gv_me) != GvCV(gv_them)) \
                SV_CV = (SV*)GvCV(gv_them); \
    } \
} STMT_END

/*
=for apidoc sv_does

Returns a boolean indicating whether the SV performs a specific, named
+ role.
The SV can be a Perl object or the name of a Perl class.

=cut
*/

bool
Perl_sv_does(pTHX_ SV *sv, const char *name, STRLEN namelen)
{

    bool does_it = 0;  /* return value */
    SV *rv = NULL;     /* what thing does sv reference (if any) */
    bool is_obj = 0;   /* is rv an object? */
    
    SV *sv_name = NULL; /* the name but in sv form (why isnt this an a
+rgument?) */
    SV *sv_cv = NULL;   /* if we are going to execute a code ref this 
+is it */
    const char *subname = NULL; /* what subroutine/method do we execut
+e */
    int count;          /* how many items did the subroutine execute *
+/
    

    SvGETMAGIC(sv);  /* make sure we play nice with magic */

    /* base tests for non object/references */
    if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
                || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
        return FALSE;
    
    if (SvROK(sv)) { /* is it a reference ?*/
        rv = (SV*)SvRV(sv); /* to what? */
        if (rv && SvOBJECT(rv)) { /* is it an object? */
            is_obj = 1;
            /* check to see if we are in the wrong DOES code 
               such as if they say UNIVERSAL::DOES($x,$y) but $x 
               has a overridden DOES with something else. */
            CHECK_IF_SUB_USED_ON_OBJECT(SvSTASH(rv),sv_cv);
        }
    }

    if (!sv_cv) { /* no overriden method to be called */
        /* check if we are checking a special internal role */
        if (namelen == 4 && strEQ(name,"qr//")) { 
            /* does sv have regexp magic associated to it? */
            if (is_obj && SvTYPE(rv) == SVt_PVMG && mg_find(rv, PERL_M
+AGIC_qr))
                return 1;
            else
                return 0;
        } else if ( namelen == 3 && name[1]=='{' && name[2]=='}' ) {
            /* Check to see how things can be dereferenced */
            const svtype t = SvTYPE(rv);
            switch (t) {
            case SVt_NULL:
            case SVt_IV:
            case SVt_NV:
            case SVt_RV:
            case SVt_PV:
            case SVt_PVIV:
            case SVt_PVNV:
            case SVt_PVMG:
            case SVt_PVLV:
                if (name[0] == '$') return 1;
                break;
            case SVt_PVAV:  
                if (name[0] == '@') return 1;
                break;
            case SVt_PVHV:  if (name[0] == '%') return 1;
                break;
            case SVt_PVCV:  
                if (name[0] == '&') return 1;
                break;
            case SVt_PVGV:  
                if (name[0] == '*') return 1;
                break;
            case SVt_PVFM:
            case SVt_PVIO:
            case SVt_BIND:
            default:        
                break;
            }
            
            if (is_obj) {
                /* we need check to see if the object overloads derefe
+rencing 
                   but to do that we need to ensure overload has been 
+loaded 
                 */
                dSP;
                PUTBACK;
                ENTER;

                Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
                    newSVpvs("overload") , NULL);

                LEAVE;
                SPAGAIN;

                sv_name = sv_2mortal( newSVpv( name, namelen ) );
                subname = "overload::Method";
            } else
                return 0;
        } else {
            /* Check to see if the object supports a named role */
            const char *classname;
            if (is_obj) {
                classname = sv_reftype(rv,TRUE);
            } else {
                CHECK_IF_SUB_USED_ON_OBJECT(gv_stashsv(sv, 0),sv_cv);
                classname = SvPV(sv,PL_na);
            }
            if (!sv_cv) { 
                if ( strEQ( name, classname ))
                    return TRUE;
                
                sv_name = sv_2mortal( newSVpv( name, namelen ) );
                if (rv && !is_obj)
                    subname = "UNIVERSAL::isa";
                else
                    subname = "isa";
            }                    
        }
    }
    /* everything before this moment was in preparation for now */
    {
        /* call the final routine which will decide things */
        dSP;
        ENTER;
        SAVETMPS;
        PUSHMARK(SP);
        XPUSHs(sv);
        XPUSHs(sv_name);
        PUTBACK;

        if (sv_cv)
            count = call_sv(sv_cv,G_SCALAR);
        else if (subname[0]=='i') /* 'i' for "isa" */
            count = call_method(subname, G_SCALAR);
        else
            count = call_pv(subname,G_SCALAR);

        SPAGAIN;
        if (count != 1)
            Perl_croak(aTHX_ "panic: DOES helper method returned "
                " incorrect number of values\n") ;
        does_it = SvTRUE( TOPs );
        FREETMPS;
        LEAVE;
    }

    return does_it;
}
#undef CHECK_IF_SUB_USED_ON_OBJECT
[download]