view release on metacpan or  search on metacpan

Var.xs  view on Meta::CPAN

		case SVt_PVMG: case SVt_PVLV: case SVt_PVGV:
#if PERL_VERSION_GE(5,11,0)
                case SVt_REGEXP:
#endif /* >=5.11.0 */
			return 1;
		default:
			return 0;
	}
}

#define import(base_sigil, vari_word) THX_import(aTHX_ base_sigil, vari_word)
static void THX_import(pTHX_ char base_sigil, char const *vari_word)
{
	dXSARGS;
	CV *compcv;
	int i;
	SP -= items;
	if(items < 1)
		croak("too few arguments for import");
	if(items == 1)
		croak("%"SVf" does no default importation", SVfARG(ST(0)));
	if(!(items & 1))
		croak("import list for %"SVf
			" must alternate name and reference", SVfARG(ST(0)));
	compcv = find_compcv(vari_word);
	PL_hints |= HINT_LOCALIZE_HH;
	gv_HVadd(PL_hintgv);
	for(i = 1; i != items; i += 2) {
		SV *name = ST(i), *ref = ST(i+1), *key, *val;
		svtype rt;
		bool rok;
		char const *vt;
		char sigil;
		HE *he;
		if(!sv_is_string(name))
			croak("%s name is not a string", vari_word);
		key = name_key(base_sigil, name);
		if(!key) croak("malformed %s name", vari_word);
		sigil = SvPVX(key)[KEYPREFIXLEN];
		rt = SvROK(ref) ? SvTYPE(SvRV(ref)) : SVt_LAST;
		switch(sigil) {
			case '$': rok = svt_scalar(rt); vt="scalar"; break;
			case '@': rok = rt == SVt_PVAV; vt="array";  break;
			case '%': rok = rt == SVt_PVHV; vt="hash";   break;
			case '&': rok = rt == SVt_PVCV; vt="code";   break;
			case '*': rok = rt == SVt_PVGV; vt="glob";   break;
			default:  rok = 0; vt = "wibble"; break;
		}
		if(!rok) croak("%s is not %s reference", vari_word, vt);
		val = newRV_inc(SvRV(ref));
		he = hv_store_ent(GvHV(PL_hintgv), key, val, 0);
		if(he) {
			val = HeVAL(he);
			SvSETMAGIC(val);
		} else {
			SvREFCNT_dec(val);
		}
		if(char_attr[(U8)sigil] & CHAR_USEPAD)
			setup_pad(compcv, SvPVX(key)+KEYPREFIXLEN);
	}
	PUTBACK;
}

#define unimport(base_sigil, vari_word) \
	THX_unimport(aTHX_ base_sigil, vari_word)
static void THX_unimport(pTHX_ char base_sigil, char const *vari_word)
{
	dXSARGS;
	CV *compcv;
	int i;
	SP -= items;
	if(items < 1)
		croak("too few arguments for unimport");
	if(items == 1)
		croak("%"SVf" does no default unimportation", SVfARG(ST(0)));
	compcv = find_compcv(vari_word);
	PL_hints |= HINT_LOCALIZE_HH;
	gv_HVadd(PL_hintgv);
	for(i = 1; i != items; i++) {
		SV *name = ST(i), *ref, *key;
		char sigil;
		if(!sv_is_string(name))
			croak("%s name is not a string", vari_word);
		key = name_key(base_sigil, name);
		if(!key) croak("malformed %s name", vari_word);
		sigil = SvPVX(key)[KEYPREFIXLEN];
		if(i != items && (ref = ST(i+1), SvROK(ref))) {
			HE *he;
			SV *cref;
			i++;
			he = hv_fetch_ent(GvHV(PL_hintgv), key, 0, 0);
			cref = he ? HeVAL(he) : &PL_sv_undef;
			if(SvROK(cref) && SvRV(cref) != SvRV(ref))
				continue;
		}
		(void) hv_delete_ent(GvHV(PL_hintgv), key, G_DISCARD, 0);
		if(char_attr[(U8)sigil] & CHAR_USEPAD)
			setup_pad(compcv, SvPVX(key)+KEYPREFIXLEN);
	}
}

MODULE = Lexical::Var PACKAGE = Lexical::Var

PROTOTYPES: DISABLE

BOOT:
	fake_sv = &PL_sv_undef;
	fake_av = (SV*)newAV();
	fake_hv = (SV*)newHV();
	stash_lex_sv = gv_stashpvs(LEXPADPREFIX"$", 1);
	stash_lex_av = gv_stashpvs(LEXPADPREFIX"@", 1);
	stash_lex_hv = gv_stashpvs(LEXPADPREFIX"%", 1);
	nxck_rv2sv = PL_check[OP_RV2SV]; PL_check[OP_RV2SV] = ck_rv2sv;
	nxck_rv2av = PL_check[OP_RV2AV]; PL_check[OP_RV2AV] = ck_rv2av;
	nxck_rv2hv = PL_check[OP_RV2HV]; PL_check[OP_RV2HV] = ck_rv2hv;
	nxck_rv2cv = PL_check[OP_RV2CV]; PL_check[OP_RV2CV] = ck_rv2cv;
	nxck_rv2gv = PL_check[OP_RV2GV]; PL_check[OP_RV2GV] = ck_rv2gv;

SV *
_variable_for_compilation(SV *classname, SV *name)
CODE:
	PERL_UNUSED_VAR(classname);
	RETVAL = lookup_for_compilation('N', "variable", name);
OUTPUT:
	RETVAL

void
import(SV *classname, ...)
PPCODE:
	PERL_UNUSED_VAR(classname);
	PUSHMARK(SP);
	/* the modified SP is intentionally lost here */
	import('N', "variable");
	SPAGAIN;

void
unimport(SV *classname, ...)
PPCODE:
	PERL_UNUSED_VAR(classname);
	PUSHMARK(SP);
	/* the modified SP is intentionally lost here */
	unimport('N', "variable");
	SPAGAIN;

MODULE = Lexical::Var PACKAGE = Lexical::Sub

SV *
_sub_for_compilation(SV *classname, SV *name)
CODE:
	PERL_UNUSED_VAR(classname);
	RETVAL = lookup_for_compilation('&', "subroutine", name);
OUTPUT:
	RETVAL

void
import(SV *classname, ...)
PPCODE:
	PERL_UNUSED_VAR(classname);
	PUSHMARK(SP);
	/* the modified SP is intentionally lost here */
	import('&', "subroutine");
	SPAGAIN;

void
unimport(SV *classname, ...)
PPCODE:
	PERL_UNUSED_VAR(classname);
	PUSHMARK(SP);
	/* the modified SP is intentionally lost here */
	unimport('&', "subroutine");
	SPAGAIN;