/* BLECH!!!! needed for HvMROMETA */
#define PERL_CORE
#include "EXTERN.h"
#include "perl.h"
#undef PERL_CORE
#include "XSUB.h"
#define NEED_sv_2pv_flags
#include "ppport.h"
#ifdef HvMROMETA
#define HvCURGEN(stash) ( HvMROMETA(stash)->cache_gen + PL_sub_generation )
#else
#define HvCURGEN(stash) PL_sub_generation
#endif
#ifndef GvCV_set
# define GvCV_set(gv, cv) GvCV(gv) = cv
#endif
STATIC GV *sv_gv(SV *sv) {
if ( sv ) {
if ( SvROK(sv) )
sv = SvRV(sv);
if ( SvTYPE(sv) == SVt_PVGV ) {
return (GV *)sv;
} else if ( SvPOK(sv) ) {
/* fully qualified name case */
/* OMIGAWD XMATH UR TEH GREATES KTHX FR RITING THIS!!! COPYRAIT */
GV** gvp;
char *s, *end = NULL, saved;
char *name = SvPV_nolen(sv);
HV *stash = CopSTASH(PL_curcop);
for (s = name; *s++; ) {
if (*s == ':' && s[-1] == ':')
end = ++s;
else if (*s && s[-1] == '\'')
end = s;
}
s--;
if (end) {
saved = *end;
*end = 0;
stash = GvHV(gv_fetchpv(name, TRUE, SVt_PVHV));
*end = saved;
name = end;
}
gvp = (GV**)hv_fetch(stash, name, s - name, 1);
if(gvp) {
GV *gv = *gvp;
if (SvTYPE(gv) != SVt_PVGV)
gv_init(gv, stash, name, s - name, TRUE);
return gv;
}
}
}
Perl_croak(aTHX_ "Must provide a glob ref");
}
STATIC HV *sv_stash (SV *sv) {
HV *hv;
if ( SvROK(sv) ) {
SV *rv = SvRV(sv);
if ( sv_isobject(rv) ) {
return SvSTASH(rv);
} else {
if ( SvTYPE(rv) == SVt_PVHV ) {
hv = (HV *)rv;
if ( HvNAME(hv) )
return hv;
}
/* if SVt_PVGV maybe try e.g. *Foo for "Foo" ? */
}
} else if ( SvOK(sv) ) {
return gv_stashsv(sv, 0);
}
Perl_croak(aTHX_ "Must provide a class name");
}
MODULE = Class::MethodCache PACKAGE = Class::MethodCache
U32
get_class_gen (sv)
INPUT:
SV *sv
PREINIT:
HV *stash = sv_stash(sv);
CODE:
RETVAL = HvCURGEN(stash);
OUTPUT: RETVAL
void
update_cvgen (sv)
INPUT:
SV *sv
PREINIT:
GV *gv = sv_gv(sv);
CODE:
if ( GvCVGEN(gv) )
GvCVGEN(gv) = HvCURGEN(GvSTASH(gv));
else
Perl_croak(aTHX_ "Won't update cvgen for real method.");
void
delete_cv (sv)
INPUT:
SV *sv
PREINIT:
GV *gv = sv_gv(sv);
CODE:
if ( GvCV(gv) )
SvREFCNT_dec(GvCV(gv));
GvCV_set(gv, NULL);
GvCVGEN(gv) = 0;
SV *
get_cached_method (sv)
INPUT:
SV *sv
PREINIT:
GV *gv = sv_gv(sv);
PPCODE:
if ( GvCV(gv) && GvCVGEN(gv) == HvCURGEN(GvSTASH(gv)) )
XPUSHs(sv_2mortal(newRV_inc((SV *)GvCV(gv))));
else
XPUSHs(&PL_sv_undef);
void
set_cached_method (sv, cv_sv)
INPUT:
SV *sv
SV *cv_sv
PREINIT:
GV *gv = sv_gv(sv);
CV *cv = SvROK(cv_sv) ? (CV *)SvRV(cv_sv) : NULL;
CODE:
if ( !cv || SvTYPE(cv) != SVt_PVCV )
Perl_croak(aTHX_ "cv is not a code reference");
if ( GvREFCNT(gv) == 1 ) {
if ( GvCV(gv) ) {
if ( GvCVGEN(gv) == 0 )
Perl_croak(aTHX_ "Won't overwrite real method.");
SvREFCNT_dec(GvCV(gv));
}
SvREFCNT_inc(cv);
GvCV_set(gv, cv);
GvCVGEN(gv) = HvCURGEN(GvSTASH(gv));
} else {
Perl_croak(aTHX_ "Setting a cached method in a cached GV might cause strange things to happen.");
}
SV *
get_cv (sv)
INPUT:
SV *sv
PREINIT:
GV *gv = sv_gv(sv);
PPCODE:
if ( GvCV(gv) )
XPUSHs(sv_2mortal(newRV_inc((SV *)GvCV(gv))));
else
XPUSHs(&PL_sv_undef);
SV *
set_cv (sv, cv_sv)
INPUT:
SV *sv
SV *cv_sv
PREINIT:
CV *cv;
GV *gv = sv_gv(sv);
PPCODE:
if ( !SvOK(cv_sv) ) {
cv = NULL;
} else if ( SvROK(cv_sv) && SvTYPE(SvRV(cv_sv)) == SVt_PVCV ) {
cv = (CV *)SvRV(cv_sv);
SvREFCNT_inc(cv);
} else {
Perl_croak(aTHX_ "set_cv accepts either a code reference or undef");
}
if ( GvCV(gv) )
SvREFCNT_dec(GvCV(gv));
GvCV_set(gv, cv);
U32
get_gv_refcount (sv)
INPUT:
SV *sv
PREINIT:
GV *gv = sv_gv(sv);
CODE:
RETVAL = GvREFCNT(gv); /* refcount of the GP, not the GV */
OUTPUT: RETVAL
void
set_cvgen (sv, gen)
INPUT:
SV *sv
U32 gen
PREINIT:
GV *gv = sv_gv(sv);
CODE:
GvCVGEN(gv) = gen;
U32
get_cvgen (sv)
INPUT:
SV *sv
PREINIT:
GV *gv = sv_gv(sv);
CODE:
RETVAL = GvCVGEN(gv);
OUTPUT: RETVAL
void
mro_isa_changed_in (sv)
INPUT:
SV *sv
PREINIT:
HV *stash = sv_stash(sv);
CODE:
#ifdef mro_isa_changed_in
mro_isa_changed_in(stash);
#else
PL_sub_generation++;
#endif