tags/v1_29/Symbol/Symbol.xs

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

#ifdef PERL_OBJECT
#define sv_name(svp) svp
#define undef(ref) 
#else
static void undef(SV *ref)
{
    GV *gv;
    SV *sv;
    CV *cv;
    I32 has_proto=FALSE;

    if(SvROK(ref))
        sv = SvRV(ref);
    else 
        croak("Apache::Symbol::undef called without a reference!");

    switch (SvTYPE(sv)) {
    case SVt_PVCV:
	cv = (CV*)sv;
	if (!CvXSUB(cv) && CvROOT(cv) && CvDEPTH(cv)) {
	    return; 	    /* subroutine is active */
	}

	gv = (GV*)SvREFCNT_inc(CvGV(cv));
        if(SvPOK(cv)) 
	    has_proto = TRUE;

	cv_undef(cv);
	CvGV(cv) = gv;   /* let user-undef'd sub keep its identity */
        if(has_proto) 
            SvPOK_on(cv); /* otherwise we get `Prototype mismatch:' */

        break;
 
    default:
        warn("Apache::Symbol::undef called without a CODE reference!\n");
    }
}

static SV *sv_name(SV *svp)
{
    SV *sv = Nullsv;
    SV *RETVAL = Nullsv;

    if(svp && SvROK(svp) && (sv = SvRV(svp))) {
	switch(SvTYPE(sv)) {
	case SVt_PVCV:
	    RETVAL = newSV(0);
	    gv_fullname(RETVAL, CvGV(sv));
	    break;

	default:
	    break;
	}
    }
    else if(svp && SvPOK(svp)) {
	RETVAL = newSVsv(svp);
    }

    return RETVAL;
}
#endif

MODULE = Apache::Symbol		PACKAGE = Apache::Symbol		

PROTOTYPES: DISABLE

void
undef(sv)
    SV *sv

SV *
sv_name(sv)
    SV *sv

SV *
cv_const_sv(sv)
    SV* sv
    
    PREINIT:
    CV *cv;
    GV *gv;
    HV *stash;

    CODE:
    
    switch (SvTYPE(sv)) {
    default:
	if (!SvROK(sv)) {
	    char *sym;

	    if (SvGMAGICAL(sv)) {
		mg_get(sv);
		sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
	    }
	    else {
                STRLEN n_a;
                sym = SvPV(sv, n_a);
            }
	    if(sym)
		cv = perl_get_cv(sym, TRUE);
	    break;
	}
	cv = (CV*)SvRV(sv);
	if (SvTYPE(cv) == SVt_PVCV)
	    break;

    case SVt_PVHV:
    case SVt_PVAV:
	croak("Not a CODE reference");
    case SVt_PVCV:
	cv = (CV*)sv;
	break;
    case SVt_PVGV:
	if (!(cv = GvCVu((GV*)sv)))
	    cv = sv_2cv(sv, &stash, &gv, TRUE);
	break;
    }

    if(!(RETVAL = cv_const_sv(cv)))
       XSRETURN_UNDEF;
    
    SvREADONLY_off(RETVAL);

    OUTPUT:
    RETVAL