/* Data-Util/DataUtil.xs */
#define NEED_mro_get_linear_isa
#include "data-util.h"
#define MY_CXT_KEY "Data::Util::_guts" XS_VERSION
#define NotReached assert(((void)"PANIC: NOT REACHED", 0))
#define is_special_nv(nv) (nv == NV_INF || nv == -NV_INF || Perl_isnan(nv))
typedef struct{
GV* universal_isa;
GV* croak;
} my_cxt_t;
START_MY_CXT;
/* null magic virtual table to identify magic functions */
extern MGVTBL curried_vtbl;
extern MGVTBL modified_vtbl;
MGVTBL subr_name_vtbl;
typedef enum{
T_NOT_REF,
T_SV,
T_AV,
T_HV,
T_CV,
T_GV,
T_IO,
T_FM,
T_RX,
T_OBJECT,
T_VALUE,
T_STR,
T_NUM,
T_INT
} my_type_t;
static const char* const ref_names[] = {
NULL, /* NOT_REF */
"a SCALAR reference",
"an ARRAY reference",
"a HASH reference",
"a CODE reference",
"a GLOB reference",
NULL, /* IO */
NULL, /* FM */
"a regular expression reference", /* RX */
NULL /* OBJECT */
};
static void
my_croak(pTHX_ const char* const fmt, ...)
__attribute__format__(__printf__, pTHX_1, pTHX_2);
static void
my_croak(pTHX_ const char* const fmt, ...){
dMY_CXT;
dSP;
SV* message;
va_list args;
ENTER;
SAVETMPS;
if(!MY_CXT.croak){
Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvs("Data::Util::Error"), NULL, NULL);
MY_CXT.croak = CvGV(get_cv("Data::Util::Error::croak", GV_ADD));
SvREFCNT_inc_simple_void_NN(MY_CXT.croak);
}
va_start(args, fmt);
message = vnewSVpvf(fmt, &args);
va_end(args);
PUSHMARK(SP);
mXPUSHs(message);
PUTBACK;
call_sv((SV*)MY_CXT.croak, G_VOID);
NotReached;
/*
FREETMPS;
LEAVE;
*/
}
static void
my_fail(pTHX_ const char* const name, SV* value){
my_croak(aTHX_ "Validation failed: you must supply %s, not %s", name, neat(value));
}
static int
S_nv_is_integer(pTHX_ NV const nv) {
if(nv == (NV)(IV)nv){
return TRUE;
}
else {
char buf[64]; /* Must fit sprintf/Gconvert of longest NV */
char* p;
(void)Gconvert(nv, NV_DIG, 0, buf);
p = &buf[0];
/* -?[0-9]+ */
if(*p == '-') p++;
while(*p){
if(!isDIGIT(*p)){
return FALSE;
}
p++;
}
return TRUE;
}
}
static int
my_check_type_primitive(pTHX_ SV* const sv, const my_type_t t){
if(!SvOK(sv) || SvROK(sv) || isGV(sv)){
return FALSE;
}
switch(t){
case T_INT:
/* check POK, NOK and IOK respectively */
if(SvPOKp(sv)){
int const num_type = grok_number(SvPVX(sv), SvCUR(sv), NULL);
if(num_type && !strEQ(SvPVX(sv), "0 but true")){
return !(num_type & IS_NUMBER_NOT_INT);
}
}
else if(SvNOKp(sv)){
NV const nv = SvNVX(sv);
return S_nv_is_integer(aTHX_ nv);
}
else if(SvIOKp(sv)){
return TRUE;
}
break;
case T_NUM:
if(SvPOKp(sv)){
int const num_type = grok_number(SvPVX(sv), SvCUR(sv), NULL);
if(num_type && !strEQ(SvPVX(sv), "0 but true")){
return !(num_type & (IS_NUMBER_INFINITY | IS_NUMBER_NAN));
}
}
else if(SvNOKp(sv)){
NV const nv = SvNVX(sv);
return !is_special_nv(nv);
}
else if(SvIOKp(sv)){
return TRUE;
}
break;
case T_STR:
if(SvPOKp(sv)){
return SvCUR(sv) > 0;
}
/* fall throught */
default:/* T_VALUE */
return TRUE;
}
return FALSE;
}
static bool
my_has_amagic_converter(pTHX_ SV* const sv, const my_type_t t){
const AMT* amt;
int o = 0;
if(!SvAMAGIC(sv)) return FALSE;
amt = (AMT*)mg_find((SV*)SvSTASH(SvRV(sv)), PERL_MAGIC_overload_table)->mg_ptr;
assert(amt);
assert(AMT_AMAGIC(amt));
switch(t){
case T_SV:
o = to_sv_amg;
break;
case T_AV:
o = to_av_amg;
break;
case T_HV:
o = to_hv_amg;
break;
case T_CV:
o = to_cv_amg;
break;
case T_GV:
o = to_gv_amg;
break;
default:
NotReached;
}
return amt->table[o] ? TRUE : FALSE;
}
#define check_type(sv, t) my_check_type(aTHX_ sv, t)
static int
my_check_type(pTHX_ SV* const sv, const my_type_t t){
if(!SvROK(sv)){
return FALSE;
}
if(SvOBJECT(SvRV(sv))){
if(t == T_RX){ /* regex? */
return SvRXOK(sv);
}
else{
return my_has_amagic_converter(aTHX_ sv, t);
}
}
switch(SvTYPE(SvRV(sv))){
case SVt_PVAV: return T_AV == t;
case SVt_PVHV: return T_HV == t;
case SVt_PVCV: return T_CV == t;
case SVt_PVGV: return T_GV == t;
case SVt_PVIO: return T_IO == t;
case SVt_PVFM: return T_FM == t;
default: NOOP;
}
return T_SV == t;
}
#define deref_av(sv) my_deref_av(aTHX_ sv)
#define deref_hv(sv) my_deref_hv(aTHX_ sv)
#define deref_cv(sv) my_deref_cv(aTHX_ sv)
static AV*
my_deref_av(pTHX_ SV* sv){
SvGETMAGIC(sv);
if(my_has_amagic_converter(aTHX_ sv, T_AV)){
SV* const* sp = &sv; /* used in tryAMAGICunDEREF macro */
tryAMAGICunDEREF(to_av);
}
if(!(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVAV)){
my_fail(aTHX_ ref_names[T_AV], sv);
}
return (AV*)SvRV(sv);
}
static HV*
my_deref_hv(pTHX_ SV* sv){
SvGETMAGIC(sv);
if(my_has_amagic_converter(aTHX_ sv, T_HV)){
SV* const* sp = &sv; /* used in tryAMAGICunDEREF macro */
tryAMAGICunDEREF(to_hv);
}
if(!(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVHV)){
my_fail(aTHX_ ref_names[T_HV], sv);
}
return (HV*)SvRV(sv);
}
static CV*
my_deref_cv(pTHX_ SV* sv){
SvGETMAGIC(sv);
if(my_has_amagic_converter(aTHX_ sv, T_CV)){
SV* const* sp = &sv; /* used in tryAMAGICunDEREF macro */
tryAMAGICunDEREF(to_cv);
}
if(!(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV)){
my_fail(aTHX_ ref_names[T_CV], sv);
}
return (CV*)SvRV(sv);
}
#define validate(sv, t) my_validate(aTHX_ sv, t)
static SV*
my_validate(pTHX_ SV* const sv, my_type_t const ref_type){
SvGETMAGIC(sv);
if(!check_type(sv, ref_type)){
my_fail(aTHX_ ref_names[ref_type], sv);
}
return sv;
}
static SV*
my_string(pTHX_ SV* const sv, const char* const name){
SvGETMAGIC(sv);
if(!is_string(sv)) my_fail(aTHX_ name, sv);
return sv;
}
static const char*
my_canon_pkg(pTHX_ const char* name){
/* "::Foo" -> "Foo" */
if(name[0] == ':' && name[1] == ':'){
name += 2;
}
/* "main::main::main::Foo" -> "Foo" */
while(strnEQ(name, "main::", sizeof("main::")-1)){
name += sizeof("main::")-1;
}
return name;
}
static int
my_isa_lookup(pTHX_ HV* const stash, const char* klass_name){
const char* const stash_name = my_canon_pkg(aTHX_ HvNAME_get(stash));
klass_name = my_canon_pkg(aTHX_ klass_name);
if(strEQ(stash_name, klass_name)){
return TRUE;
}
else if(strEQ(klass_name, "UNIVERSAL")){
return TRUE;
}
else{
AV* const linearized_isa = mro_get_linear_isa(stash);
SV** svp = AvARRAY(linearized_isa) + 1; /* skip this class */
SV** const end = svp + AvFILLp(linearized_isa); /* start + 1 + last index */
while(svp != end){
if(strEQ(klass_name, my_canon_pkg(aTHX_ SvPVX(*svp)))){
return TRUE;
}
svp++;
}
}
return FALSE;
}
static int
my_instance_of(pTHX_ SV* const x, SV* const klass){
if( !is_string(klass) ){
my_fail(aTHX_ "a class name", klass);
}
if( SvROK(x) && SvOBJECT(SvRV(x)) ){
dMY_CXT;
HV* const stash = SvSTASH(SvRV(x));
GV* const isa = gv_fetchmeth_autoload(stash, "isa", sizeof("isa")-1, 0 /* special zero, not flags nor bool */);
/* common cases */
if(isa == NULL || GvCV(isa) == GvCV(MY_CXT.universal_isa)){
return my_isa_lookup(aTHX_ stash, SvPV_nolen_const(klass));
}
/* special cases */
/* call their own ->isa() method */
{
int retval;
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
EXTEND(SP, 2);
PUSHs(x);
PUSHs(klass);
PUTBACK;
call_sv((SV*)isa, G_SCALAR | G_METHOD);
SPAGAIN;
retval = SvTRUE(TOPs);
(void)POPs;
PUTBACK;
FREETMPS;
LEAVE;
return retval;
}
}
return FALSE;
}
#define type_isa(sv, type) my_type_isa(aTHX_ sv, type)
static bool
my_type_isa(pTHX_ SV* const sv, SV* const type){
const char* const typestr = SvPV_nolen_const(type);
switch(typestr[0]){
case 'S':
if(strEQ(typestr, "SCALAR")){
return check_type(sv, T_SV);
}
break;
case 'A':
if(strEQ(typestr, "ARRAY")){
return check_type(sv, T_AV);
}
break;
case 'H':
if(strEQ(typestr, "HASH")){
return check_type(sv, T_HV);
}
break;
case 'C':
if(strEQ(typestr, "CODE")){
return check_type(sv, T_CV);
}
break;
case 'G':
if(strEQ(typestr, "GLOB")){
return check_type(sv, T_GV);
}
break;
}
return my_instance_of(aTHX_ sv, type);
}
static void
my_opt_add(pTHX_
AV* const result_av, HV* const result_hv, SV* const moniker,
SV* const name, SV* const value,
bool const with_validation,
SV* vsv,
AV* vav,
HV* const vhv ){
if(with_validation && SvOK(value)){
if(vhv){
HE* const he = hv_fetch_ent(vhv, name, FALSE, 0U);
vav = NULL;
if(he){
SV* const sv = hv_iterval(vhv, he);
if(check_type(sv, T_AV)){
vav = deref_av(sv);
}
else if(SvOK(sv)){
vsv = sv;
}
else{
goto store_pair;
}
}
else{
goto store_pair;
}
}
if(vav){
I32 const len = av_len(vav)+1;
I32 i;
for(i = 0; i < len; i++){
if(type_isa(value, *av_fetch(vav, i, TRUE))){
break;
}
}
if(i == len) goto validation_failed;
}
else{
if(!type_isa(value, vsv)){
validation_failed:
my_croak(aTHX_ "%s-ref values are not valid for %"SVf" in %"SVf" opt list",
sv_reftype(SvRV(value), TRUE), name, moniker);
}
}
}
store_pair:
if(result_av){ /* push @result, [$name => $value] */
SV* pair[2];
pair[0] = name;
pair[1] = value;
av_push(result_av, newRV_noinc((SV*) av_make(2, pair)));
}
else{ /* $result{$name} = $value */
(void)hv_store_ent(result_hv, name, newSVsv(value), 0U);
}
}
static SV*
my_mkopt(pTHX_ SV* const opt_list, SV* const moniker, const bool require_unique, SV* must_be, const my_type_t result_type){
SV* ret;
AV* result_av = NULL;
HV* result_hv = NULL;
HV* vhv = NULL; /* validator HV */
AV* vav = NULL; /* validator AV */
bool const with_validation = SvOK(must_be) ? TRUE : FALSE;
if(with_validation){
if(check_type(must_be, T_HV)){
vhv = deref_hv(must_be);
}
else if(check_type(must_be, T_AV)){
vav = deref_av(must_be);
}
else if(!is_string(must_be)){
my_fail(aTHX_ "type constraints", must_be);
}
}
if(result_type == T_AV){
result_av = newAV();
ret = (SV*)result_av;
}
else{
result_hv = newHV();
ret = (SV*)result_hv;
}
sv_2mortal(ret);
if(check_type(opt_list, T_AV)){
HV* seen = NULL;
AV* const opt_av = deref_av(opt_list);
I32 const len = av_len(opt_av) + 1;
I32 i;
if(require_unique){
seen = newHV();
sv_2mortal((SV*)seen);
}
for(i = 0; i < len; i++){
SV* const name = my_string(aTHX_ *av_fetch(opt_av, i, TRUE), "an option name");
SV* value;
if(require_unique){
HE* const he = hv_fetch_ent(seen, name, TRUE, 0U);
SV* const count = hv_iterval(seen, he);
if(SvTRUE(count)){
my_croak(aTHX_ "Multiple definitions provided for %"SVf" in %"SVf" opt list", name, moniker);
}
sv_inc(count); /* count++ */
}
if( (i+1) == len ){ /* last */
value = &PL_sv_undef;
}
else{
value = *av_fetch(opt_av, i+1, TRUE);
if(SvROK(value) || !SvOK(value)){
i++;
}
else{
value = &PL_sv_undef;
}
}
my_opt_add(aTHX_ result_av, result_hv, moniker, name, value,
with_validation, must_be, vav, vhv);
}
}
else if(check_type(opt_list, T_HV)){
HV* const opt_hv = deref_hv(opt_list);
I32 keylen;
char* key;
SV* value;
SV* const name = sv_newmortal();
hv_iterinit(opt_hv);
while((value = hv_iternextsv(opt_hv, &key, &keylen))){
sv_setpvn(name, key, keylen); /* copied in my_opt_add */
if(!SvROK(value) && SvOK(value)){
value = &PL_sv_undef;
}
my_opt_add(aTHX_ result_av, result_hv, moniker, name, value,
with_validation, must_be, vav, vhv);
}
}
else if(SvOK(opt_list)){
my_fail(aTHX_ "an ARRAY or HASH reference", opt_list);
}
return newRV_inc(ret);
}
/*
$code = curry($_, (my $tmp = $code_ref), *_) for @around;
*/
static SV*
my_build_around_code(pTHX_ SV* code_ref, AV* const around){
I32 i;
for(i = av_len(around); i >= 0; i--){
CV* current;
MAGIC* mg;
SV* const sv = validate(*av_fetch(around, i, TRUE), T_CV);
AV* const params = newAV();
AV* const placeholders = newAV();
av_store(params, 0, newSVsv(sv)); /* base proc */
av_store(params, 1, newSVsv(code_ref)); /* first argument (next proc) */
av_store(params, 2, &PL_sv_undef); /* placeholder hole */
av_store(placeholders, 2, (SV*)PL_defgv); // *_
SvREFCNT_inc_simple_void_NN(PL_defgv);
current = newXS(NULL /* anonymous */, XS_Data__Util_curried, __FILE__);
mg = sv_magicext((SV*)current, (SV*)params, PERL_MAGIC_ext, &curried_vtbl, (const char*)placeholders, HEf_SVKEY);
SvREFCNT_dec(params); /* because: refcnt++ in sv_magicext() */
SvREFCNT_dec(placeholders); /* because: refcnt++ in sv_magicext() */
CvXSUBANY(current).any_ptr = (void*)mg;
code_ref = newRV_noinc((SV*)current);
sv_2mortal(code_ref);
}
return newSVsv(code_ref);
}
static void
my_gv_setsv(pTHX_ GV* const gv, SV* const sv){
ENTER;
SAVETMPS;
sv_setsv_mg((SV*)gv, sv_2mortal(newRV_inc((sv))));
FREETMPS;
LEAVE;
}
static void
my_install_sub(pTHX_ HV* const stash, const char* const name, STRLEN const namelen, SV* code_ref){
CV* const code = deref_cv(code_ref);
GV* const gv = (GV*)*hv_fetch(stash, name, namelen, TRUE);
if(!isGV(gv)) gv_init(gv, stash, name, namelen, GV_ADDMULTI);
my_gv_setsv(aTHX_ gv, (SV*)code); /* *foo = \&bar */
if(CvANON(code)
&& CvGV(code) /* under construction? */
&& isGV(CvGV(code)) /* released? */){
/* rename cv with gv */
CvGV_set(code, gv);
CvANON_off(code);
}
}
static void
my_uninstall_sub(pTHX_ HV* const stash, const char* const name, STRLEN const namelen, SV* const specified_code_ref){
GV** const gvp = (GV**)hv_fetch(stash, name, namelen, FALSE);
if(gvp){
GV* const gv = *gvp;
CV* const specified_code = SvOK(specified_code_ref) ? deref_cv(specified_code_ref) : NULL;
GV* newgv;
CV* code;
if(!isGV(gv)){ /* a subroutine stub or special constant*/
if(SvROK((SV*)gv) && ckWARN(WARN_MISC)){
Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s uninstalled", name);
}
(void)hv_delete(stash, name, namelen, G_DISCARD);
return;
}
if(!(code = GvCVu(gv))){
return;
}
/* when an uninstalled subroutine is supplied ... */
if( specified_code && specified_code != code ){
return; /* skip */
}
if(CvCONST(code) && ckWARN(WARN_MISC)){
Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s uninstalled", name);
}
(void)hv_delete(stash, name, namelen, G_DISCARD);
if(SvREFCNT(gv) == 0 || !(
GvSV(gv)
|| GvAV(gv)
|| GvHV(gv)
|| GvIO(gv)
|| GvFORM(gv))){
return; /* no need to retrieve gv */
}
newgv = (GV*)*hv_fetch(stash, name, namelen, TRUE);
gv_init(newgv, stash, name, namelen, GV_ADDMULTI); /* vivify */
/* restore all slots other than GvCV */
if(GvSV(gv)) my_gv_setsv(aTHX_ newgv, GvSV(gv));
if(GvAV(gv)) my_gv_setsv(aTHX_ newgv, (SV*)GvAV(gv));
if(GvHV(gv)) my_gv_setsv(aTHX_ newgv, (SV*)GvHV(gv));
if(GvIO(gv)) my_gv_setsv(aTHX_ newgv, (SV*)GvIOp(gv));
if(GvFORM(gv)) my_gv_setsv(aTHX_ newgv, (SV*)GvFORM(gv));
}
}
static void
initialize_my_cxt(pTHX_ my_cxt_t* const cxt){
cxt->universal_isa = CvGV(get_cv("UNIVERSAL::isa", GV_ADD));
SvREFCNT_inc_simple_void_NN(cxt->universal_isa);
cxt->croak = NULL;
}
#define UNDEF &PL_sv_undef
MODULE = Data::Util PACKAGE = Data::Util
PROTOTYPES: DISABLE
BOOT:
{
MY_CXT_INIT;
initialize_my_cxt(aTHX_ &MY_CXT);
}
void
CLONE(...)
CODE:
MY_CXT_CLONE;
initialize_my_cxt(aTHX_ &MY_CXT);
PERL_UNUSED_VAR(items);
#define T_RX_deprecated T_RX
void
is_scalar_ref(x)
SV* x
ALIAS:
is_scalar_ref = T_SV
is_array_ref = T_AV
is_hash_ref = T_HV
is_code_ref = T_CV
is_glob_ref = T_GV
is_regex_ref = T_RX_deprecated
is_rx = T_RX
CODE:
SvGETMAGIC(x);
ST(0) = boolSV(check_type(x, (my_type_t)ix));
XSRETURN(1);
void
scalar_ref(x)
SV* x
ALIAS:
scalar_ref = T_SV
array_ref = T_AV
hash_ref = T_HV
code_ref = T_CV
glob_ref = T_GV
regex_ref = T_RX_deprecated
rx = T_RX
CODE:
SvGETMAGIC(x);
if(check_type(x, (my_type_t)ix)){
XSRETURN(1); /* return the first value */
}
my_fail(aTHX_ ref_names[ix], x);
void
is_instance(x, klass)
SV* x
SV* klass
CODE:
SvGETMAGIC(x);
SvGETMAGIC(klass);
ST(0) = boolSV(my_instance_of(aTHX_ x, klass));
XSRETURN(1);
void
instance(x, klass)
SV* x
SV* klass
CODE:
SvGETMAGIC(x);
SvGETMAGIC(klass);
if( my_instance_of(aTHX_ x, klass) ){
XSRETURN(1); /* return $_[0] */
}
my_croak(aTHX_ "Validation failed: you must supply an instance of %"SVf", not %s",
klass, neat(x));
void
invocant(x)
SV* x
ALIAS:
is_invocant = 0
invocant = 1
PREINIT:
bool result;
CODE:
SvGETMAGIC(x);
if(SvROK(x)){
result = SvOBJECT(SvRV(x)) ? TRUE : FALSE;
}
else if(is_string(x)){
result = gv_stashsv(x, FALSE) ? TRUE : FALSE;
}
else{
result = FALSE;
}
if(ix == 0){ /* is_invocant() */
ST(0) = boolSV(result);
XSRETURN(1);
}
else{ /* invocant() */
if(result){ /* XXX: do{ package ::Foo; ::Foo->something; } causes an fatal error */
if(!SvROK(x)){
dXSTARG;
sv_setsv(TARG, x); /* copy the pv and flags */
sv_setpv(TARG, my_canon_pkg(aTHX_ SvPV_nolen_const(x)));
ST(0) = TARG;
}
XSRETURN(1);
}
my_fail(aTHX_ "an invocant", x);
}
void
is_value(x)
SV* x
ALIAS:
is_value = T_VALUE
is_string = T_STR
is_number = T_NUM
is_integer = T_INT
CODE:
SvGETMAGIC(x);
ST(0) = boolSV(my_check_type_primitive(aTHX_ x, (my_type_t)ix));
XSRETURN(1);
HV*
get_stash(invocant)
SV* invocant
CODE:
SvGETMAGIC(invocant);
if(SvROK(invocant) && SvOBJECT(SvRV(invocant))){
RETVAL = SvSTASH(SvRV(invocant));
}
else if(is_string(invocant)){
RETVAL = gv_stashsv(invocant, FALSE);
}
else{
RETVAL = NULL;
}
if(!RETVAL){
XSRETURN_UNDEF;
}
OUTPUT:
RETVAL
SV*
anon_scalar(referent = undef)
CODE:
RETVAL = newRV_noinc(items == 0 ? newSV(0) : newSVsv(ST(0)));
OUTPUT:
RETVAL
const char*
neat(expr)
SV* expr
void
install_subroutine(into, ...)
SV* into
PREINIT:
HV* stash;
int i;
CODE:
stash = gv_stashsv(my_string(aTHX_ into, "a package name"), TRUE);
if(items == 2){
HV* const hv = deref_hv(ST(1));
I32 namelen;
char* name;
SV* code_ref;
hv_iterinit(hv);
while((code_ref = hv_iternextsv(hv, &name, &namelen))){
my_install_sub(aTHX_ stash, name, namelen, code_ref);
}
}
else{
if( ((items-1) % 2) != 0 ){
my_croak(aTHX_ "Odd number of arguments for %s", GvNAME(CvGV(cv)));
}
for(i = 1; i < items; i += 2){
SV* const as = my_string(aTHX_ ST(i), "a subroutine name");
STRLEN namelen;
const char* const name = SvPV_const(as, namelen);
SV* const code_ref = ST(i+1);
my_install_sub(aTHX_ stash, name, namelen, code_ref);
}
}
void
uninstall_subroutine(package, ...)
SV* package
PREINIT:
HV* stash;
int i;
CODE:
stash = gv_stashsv(my_string(aTHX_ package, "a package name"), FALSE);
if(!stash) XSRETURN_EMPTY;
if(items == 2 && SvROK(ST(1))){
HV* const hv = deref_hv(ST(1));
I32 namelen;
char* name;
SV* specified_code_ref;
hv_iterinit(hv);
while((specified_code_ref = hv_iternextsv(hv, &name, &namelen))){
my_uninstall_sub(aTHX_ stash, name, namelen, specified_code_ref);
}
}
else{
for(i = 1; i < items; i++){
SV* const namesv = my_string(aTHX_ ST(i), "a subroutine name");
STRLEN namelen;
const char* const name = SvPV_const(namesv, namelen);
SV* specified_code_ref;
if( (i+1) < items && SvROK(ST(i+1)) ){
i++;
specified_code_ref = ST(i);
}
else{
specified_code_ref = &PL_sv_undef;
}
my_uninstall_sub(aTHX_ stash, name, namelen, specified_code_ref);
}
}
mro_method_changed_in(stash);
void
get_code_info(code)
CV* code
PREINIT:
GV* gv;
HV* stash;
PPCODE:
if( (gv = CvGV(code)) && isGV_with_GP(gv)
&& (stash = (GvSTASH(gv))) && HvNAME_get(stash) ){
if(GIMME_V == G_ARRAY){
EXTEND(SP, 2);
mPUSHs(newSVpvn_share(HvNAME_get(stash), HvNAMELEN_get(stash), 0U));
mPUSHs(newSVpvn_share(GvNAME(gv), GvNAMELEN(gv), 0U));
}
else{
SV* const sv = newSVpvf("%s::%s", HvNAME_get(stash), GvNAME(gv));
mXPUSHs(sv);
}
}
SV*
get_code_ref(package, name, ...)
SV* package
SV* name
INIT:
I32 flags = 0;
RETVAL = &PL_sv_undef;
CODE:
(void)my_string(aTHX_ package, "a package name");
(void)my_string(aTHX_ name, "a subroutine name");
if(items > 2){ /* with flags */
I32 i;
for(i = 2; i < items; i++){
SV* const sv = my_string(aTHX_ ST(i), "a flag");
if(strEQ(SvPV_nolen_const(sv), "-create")){
flags |= GV_ADD;
}
else{
my_fail(aTHX_ "a flag", sv);
}
}
}
{
HV* const stash = gv_stashsv(package, flags);
if(stash){
STRLEN len;
const char* const pv = SvPV_const(name, len);
GV** const gvp = (GV**)hv_fetch(stash, pv, len, flags);
GV* const gv = gvp ? *gvp : NULL;
if(gv){
if(!isGV(gv)) gv_init(gv, stash, pv, len, GV_ADDMULTI);
if(GvCVu(gv)){
RETVAL = newRV_inc((SV*)GvCV(gv));
}
else if(flags & GV_ADD){
SV* const sv = Perl_newSVpvf(aTHX_ "%"SVf"::%"SVf, package, name);
/* from Perl_get_cvn_flags() in perl.c */
CV* const cv = newSUB(
start_subparse(FALSE, 0),
newSVOP(OP_CONST, 0, sv),
NULL, NULL);
RETVAL = newRV_inc((SV*)cv);
}
}
}
}
OUTPUT:
RETVAL
SV*
curry(code, ...)
SV* code
PREINIT:
CV* curried;
AV* params;
AV* placeholders;
U16 is_method;
I32 i;
MAGIC* mg;
CODE:
SvGETMAGIC(code);
is_method = check_type(code, T_CV) ? 0 : G_METHOD;
params = newAV();
placeholders = newAV();
av_extend(params, items-1);
av_extend(placeholders, items-1);
for(i = 0; i < items; i++){
SV* const sv = ST(i);
SvGETMAGIC(sv);
if(SvROK(sv) && SvIOKp(SvRV(sv)) && !SvOBJECT(SvRV(sv))){ // \0, \1, ...
av_store(params, i, &PL_sv_undef);
av_store(placeholders, i, newSVsv(SvRV(sv)));
}
else if(sv == (SV*)PL_defgv){ // *_ (always *main::_)
av_store(params, i, &PL_sv_undef);
av_store(placeholders, i, sv); /* not copy */
SvREFCNT_inc_simple_void_NN(sv);
}
else{
av_store(params, i, sv); /* not copy */
av_store(placeholders, i, &PL_sv_undef);
SvREFCNT_inc_simple_void_NN(sv);
}
}
curried = newXS(NULL /* anonymous */, XS_Data__Util_curried, __FILE__);
mg = sv_magicext((SV*)curried, (SV*)params, PERL_MAGIC_ext, &curried_vtbl, (const char*)placeholders, HEf_SVKEY);
SvREFCNT_dec((SV*)params); /* refcnt++ in sv_magicext() */
SvREFCNT_dec((SV*)placeholders); /* refcnt++ in sv_magicext() */
mg->mg_private = is_method;
CvXSUBANY(curried).any_ptr = mg;
RETVAL = newRV_noinc((SV*)curried);
OUTPUT:
RETVAL
SV*
modify_subroutine(code, ...)
SV* code
PREINIT:
CV* modified;
AV* before;
AV* around;
AV* after;
AV* modifiers; /* (before, around, after, original, current) */
I32 i;
MAGIC* mg;
CODE:
validate(code, T_CV);
if( ((items - 1) % 2) != 0 ){
my_croak(aTHX_ "Odd number of arguments for %s", GvNAME(CvGV(cv)));
}
before = newAV(); sv_2mortal((SV*)before);
around = newAV(); sv_2mortal((SV*)around);
after = newAV(); sv_2mortal((SV*)after );
for(i = 1; i < items; i += 2){ /* modifier_type => [subroutine(s)] */
SV* const mtsv = my_string(aTHX_ ST(i), "a modifier type");
const char* const modifier_type = SvPV_nolen_const(mtsv);
AV* const subs = deref_av(ST(i+1));
I32 const subs_len = av_len(subs) + 1;
AV* av = NULL;
I32 j;
if(strEQ(modifier_type, "before")){
av = before;
}
else if(strEQ(modifier_type, "around")){
av = around;
}
else if(strEQ(modifier_type, "after")){
av = after;
}
else{
my_fail(aTHX_ "a modifier type", mtsv);
}
av_extend(av, AvFILLp(av) + subs_len - 1);
for(j = 0; j < subs_len; j++){
SV* const code_ref = newSVsv(validate(*av_fetch(subs, j, TRUE), T_CV));
av_push(av, code_ref);
}
}
modifiers = newAV();
av_extend(modifiers, 3);
av_store(modifiers, M_CURRENT, my_build_around_code(aTHX_ code, around));
av_store(modifiers, M_BEFORE, SvREFCNT_inc_simple_NN(before));
av_store(modifiers, M_AROUND, SvREFCNT_inc_simple_NN(around));
av_store(modifiers, M_AFTER, SvREFCNT_inc_simple_NN(after));
modified = newXS(NULL /* anonymous */, XS_Data__Util_modified, __FILE__);
mg = sv_magicext((SV*)modified, (SV*)modifiers, PERL_MAGIC_ext, &modified_vtbl, NULL, 0);
SvREFCNT_dec((SV*)modifiers); /* refcnt++ in sv_magicext() */
CvXSUBANY(modified).any_ptr = (void*)mg;
RETVAL = newRV_noinc((SV*)modified);
OUTPUT:
RETVAL
void
subroutine_modifier(code, ...)
CV* code
PREINIT:
/* Usage:
subroutine_modifier(code) # check
subroutine_modifier(code, property) # get
subroutine_modifier(code, property, subs) # set
*/
MAGIC* mg;
AV* modifiers; /* (before, around, after, original, current) */
SV* property;
const char* property_pv;
PPCODE:
mg = mg_find_by_vtbl((SV*)code, &modified_vtbl);
if(items == 1){ /* check only */
ST(0) = boolSV(mg);
XSRETURN(1);
}
if(!mg){
my_fail(aTHX_ "a modified subroutine", ST(0) /* ref to code */);
}
modifiers = (AV*)mg->mg_obj;
assert(modifiers);
property = my_string(aTHX_ ST(1), "a modifier property");
property_pv = SvPV_nolen_const(property);
if(strEQ(property_pv, "before") || strEQ(property_pv, "around") || strEQ(property_pv, "after")){
I32 const idx =
strEQ(property_pv, "before") ? M_BEFORE
: strEQ(property_pv, "around") ? M_AROUND
: M_AFTER;
AV* const av = (AV*)*av_fetch(modifiers, idx, FALSE);
if(items != 2){ /* add */
I32 i;
for(i = 2; i < items; i++){
SV* const code_ref = newSVsv(validate(ST(i), T_CV));
if(idx == M_AFTER){
av_push(av, code_ref);
}
else{
av_unshift(av, 1);
av_store(av, 0, code_ref);
}
}
if(idx == M_AROUND){
AV* const around = (AV*)sv_2mortal((SV*)av_make(items-2, &ST(2)));
SV* const current = my_build_around_code(aTHX_
*av_fetch(modifiers, M_CURRENT, FALSE),
around
);
av_store(modifiers, M_CURRENT, current);
}
}
XPUSHary(AvARRAY(av), 0, AvFILLp(av)+1);
}
else{
my_fail(aTHX_ "a modifier property", property);
}
#define mkopt(opt_list, moniker, require_unique, must_be) \
my_mkopt(aTHX_ opt_list, moniker, require_unique, must_be, T_AV)
#define mkopt_hash(opt_list, moniker, must_be) \
my_mkopt(aTHX_ opt_list, moniker, TRUE, must_be, T_HV)
SV*
mkopt(opt_list = UNDEF, moniker = UNDEF, require_unique = FALSE, must_be = UNDEF)
SV* opt_list
SV* moniker
bool require_unique
SV* must_be
SV*
mkopt_hash(opt_list = UNDEF, moniker = UNDEF, must_be = UNDEF)
SV* opt_list
SV* moniker
SV* must_be