#define PERL_NO_GET_CONTEXT 1
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#define PERL_VERSION_DECIMAL(r,v,s) (r*1000000 + v*1000 + s)
#define PERL_DECIMAL_VERSION \
PERL_VERSION_DECIMAL(PERL_REVISION,PERL_VERSION,PERL_SUBVERSION)
#define PERL_VERSION_GE(r,v,s) \
(PERL_DECIMAL_VERSION >= PERL_VERSION_DECIMAL(r,v,s))
#ifndef newSVpvs_share
# ifdef newSVpvn_share
# define newSVpvs_share(STR) newSVpvn_share(""STR"", sizeof(STR)-1, 0)
# else /* !newSVpvn_share */
# define newSVpvs_share(STR) newSVpvn(""STR"", sizeof(STR)-1)
# define SvSHARED_HASH(SV) 0
# endif /* !newSVpvn_share */
#endif /* !newSVpvs_share */
#ifndef SvSHARED_HASH
# define SvSHARED_HASH(SV) SvUVX(SV)
#endif /* !SvSHARED_HASH */
#ifndef SVfARG
# define SVfARG(p) ((void*)(p))
#endif /* !SVfARG */
#if !PERL_VERSION_GE(5,9,3)
typedef OP *(*Perl_check_t)(pTHX_ OP *);
#endif /* <5.9.3 */
#if !PERL_VERSION_GE(5,10,1)
typedef unsigned Optype;
#endif /* <5.10.1 */
#ifndef wrap_op_checker
# define wrap_op_checker(c,n,o) THX_wrap_op_checker(aTHX_ c,n,o)
static void THX_wrap_op_checker(pTHX_ Optype opcode,
Perl_check_t new_checker, Perl_check_t *old_checker_p)
{
if(*old_checker_p) return;
OP_REFCNT_LOCK;
if(!*old_checker_p) {
*old_checker_p = PL_check[opcode];
PL_check[opcode] = new_checker;
}
OP_REFCNT_UNLOCK;
}
#endif /* !wrap_op_checker */
#ifndef qerror
# define qerror(m) Perl_qerror(aTHX_ m)
#endif /* !qerror */
#if PERL_VERSION_GE(5,9,5)
# define PL_parser_exists PL_parser
# define PL_expect (PL_parser->expect)
#else /* <5.9.5 */
# define PL_parser_exists 1
#endif /* <5.9.5 */
static SV *hint_key_sv;
static U32 hint_key_hash;
static OP *(*THX_nxck_rv2cv)(pTHX_ OP *o);
#define in_strictdecl() THX_in_strictdecl(aTHX)
static bool THX_in_strictdecl(pTHX)
{
HE *ent = hv_fetch_ent(GvHV(PL_hintgv), hint_key_sv, 0, hint_key_hash);
return ent && SvTRUE(HeVAL(ent));
}
static OP *THX_myck_rv2cv(pTHX_ OP *op)
{
OP *aop;
GV *gv;
op = THX_nxck_rv2cv(aTHX_ op);
if(op->op_type == OP_RV2CV && (op->op_flags & OPf_KIDS) &&
(aop = cUNOPx(op)->op_first) && aop->op_type == OP_GV &&
PL_parser_exists && PL_expect == XOPERATOR &&
in_strictdecl() && (gv = cGVOPx_gv(aop)) &&
(!PERL_VERSION_GE(5,21,4) || SvTYPE(gv) == SVt_PVGV) &&
!GvCVu(gv)) {
SV *name = sv_newmortal();
gv_efullname3(name, gv, NULL);
qerror(mess("Undeclared subroutine &%"SVf"", SVfARG(name)));
}
return op;
}
MODULE = Sub::StrictDecl PACKAGE = Sub::StrictDecl
PROTOTYPES: DISABLE
BOOT:
hint_key_sv = newSVpvs_share("Sub::StrictDecl/strict");
hint_key_hash = SvSHARED_HASH(hint_key_sv);
wrap_op_checker(OP_RV2CV, THX_myck_rv2cv, &THX_nxck_rv2cv);
void
import(SV *classname)
PREINIT:
SV *val;
HE *he;
CODE:
PERL_UNUSED_VAR(classname);
PL_hints |= HINT_LOCALIZE_HH;
gv_HVadd(PL_hintgv);
val = newSVsv(&PL_sv_yes);
he = hv_store_ent(GvHV(PL_hintgv), hint_key_sv, val, hint_key_hash);
if(he) {
val = HeVAL(he);
SvSETMAGIC(val);
} else {
SvREFCNT_dec(val);
}
void
unimport(SV *classname)
CODE:
PERL_UNUSED_VAR(classname);
PL_hints |= HINT_LOCALIZE_HH;
gv_HVadd(PL_hintgv);
(void) hv_delete_ent(GvHV(PL_hintgv), hint_key_sv, G_DISCARD,
hint_key_hash);