#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
#include "perl.h"
#define NO_XSLOCKS /* trap exceptions in pp_require */
#include "XSUB.h"
#define NEED_sv_2pv_flags
#include "ppport.h"
#include "hook_op_check.h"
#include "hook_op_annotation.h"
#define DEVEL_PRAGMA_ON_REQUIRE_KEY "Devel::Pragma::on_require"
#define DEVEL_PRAGMA_ON_REQUIRE_ENABLED(table, svp) \
((PL_hints & 0x20000) && \
PL_hintgv && \
(table = GvHV(PL_hintgv)) && \
(svp = hv_fetch(table, DEVEL_PRAGMA_ON_REQUIRE_KEY, sizeof(DEVEL_PRAGMA_ON_REQUIRE_KEY) - 1, FALSE)) && \
*svp && \
SvOK(*svp))
STATIC OP * devel_pragma_check_require(pTHX_ OP * o, void *user_data);
STATIC OP * devel_pragma_require(pTHX);
STATIC void devel_pragma_call(pTHX_ const char * const callback, HV * const hv);
STATIC void devel_pragma_enable_check_hooks();
STATIC hook_op_check_id devel_pragma_check_do_file_id = 0;
STATIC hook_op_check_id devel_pragma_check_require_id = 0;
STATIC OPAnnotationGroup DEVEL_PRAGMA_ANNOTATIONS = NULL;
STATIC U32 DEVEL_PRAGMA_CHECK_HOOKS_ENABLED = 0;
STATIC void devel_pragma_call(pTHX_ const char * const callback, HV * const hv) {
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(sv_2mortal(newRV_inc((SV *)hv)));
PUTBACK;
call_pv(callback, G_DISCARD);
FREETMPS;
LEAVE;
}
STATIC OP * devel_pragma_check_require(pTHX_ OP * o, void *user_data) {
HV * table;
SV ** svp;
PERL_UNUSED_VAR(user_data);
if (!DEVEL_PRAGMA_ON_REQUIRE_ENABLED(table, svp)) {
goto done;
}
/* make sure it's still a require; the previous checker may have turned it into something else */
if (!((o->op_type == OP_REQUIRE) || (o->op_type == OP_DOFILE))) {
goto done;
}
/* <copypasta-ish> */
if (o->op_type != OP_DOFILE) {
if (o->op_flags & OPf_KIDS) {
SVOP * const kid = (SVOP*)cUNOPo->op_first;
if (kid->op_type == OP_CONST) { /* weed out use VERSION */
SV * const sv = kid->op_sv;
if (SvNIOKp(sv)) { /* exclude use 5 and use 5.008 &c. */
goto done;
}
#ifdef SvVOK
if (SvVOK(sv)) { /* exclude use v5.008 and use 5.6.1 &c. */
goto done;
}
#endif
if (!SvPOKp(sv)) { /* err on the side of caution */
goto done;
}
}
}
}
/* </copypasta-ish> */
op_annotate(DEVEL_PRAGMA_ANNOTATIONS, o, NULL, NULL);
o->op_ppaddr = devel_pragma_require;
done:
return o;
}
/* much of this is copypasta from pp_require in pp_ctl.c */
STATIC OP * devel_pragma_require(pTHX) {
/* <copypasta> */
dSP;
SV * sv;
HV *hh, *copy_of_hh;
const char *name;
STRLEN len;
char * unixname;
STRLEN unixlen;
#ifdef VMS
int vms_unixname = 0;
#endif
/* </copypasta> */
OP * o = NULL;
/* used as a boolean to determine whether any require callbacks are registered */
SV ** callbacks = NULL;
/* we always need this (to get the ppaddr to delegate to) so define it upfront */
OPAnnotation *annotation = op_annotation_get(DEVEL_PRAGMA_ANNOTATIONS, PL_op);
/* <copypasta> */
sv = TOPs;
if (PL_op->op_type != OP_DOFILE) {
if (SvNIOKp(sv)) { /* exclude use 5 and use 5.008 &c. */
goto done;
}
#ifdef SvVOK
if (SvVOK(sv)) { /* exclude use v5.008 and use 5.6.1 &c. */
goto done;
}
#endif
if (!SvPOKp(sv)) { /* err on the side of caution */
goto done;
}
}
name = SvPV_const(sv, len);
if (!(name && (len > 0) && *name)) {
goto done;
}
TAINT_PROPER("require");
#ifdef VMS
/* The key in the %ENV hash is in the syntax of file passed as the argument
* usually this is in UNIX format, but sometimes in VMS format, which
* can result in a module being pulled in more than once.
* To prevent this, the key must be stored in UNIX format if the VMS
* name can be translated to UNIX.
*/
if ((unixname = tounixspec(name, NULL)) != NULL) {
unixlen = strlen(unixname);
vms_unixname = 1;
}
else
#endif
{
/* if not VMS or VMS name can not be translated to UNIX, pass it
* through.
*/
unixname = (char *) name;
unixlen = len;
}
if (PL_op->op_type == OP_REQUIRE) {
SV * const * const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
if (svp) { /* already loaded: see pp_require */
goto done;
}
}
/* </copypasta> */
hh = GvHV(PL_hintgv); /* %^H */
copy_of_hh = newHVhv(hh); /* create a snapshot of %^H */
callbacks = hv_fetchs(copy_of_hh, "Devel::Pragma::on_require", FALSE);
/* make sure the on_require callbacks are still defined i.e. this is not being called at runtime */
if (!callbacks) {
hv_clear(copy_of_hh);
hv_undef(copy_of_hh);
goto done;
}
devel_pragma_call(aTHX_ "Devel::Pragma::_pre_require", copy_of_hh); /* invoke the pre-require callbacks */
{
dXCPT; /* set up variables for try/catch */
XCPT_TRY_START {
o = annotation->op_ppaddr(aTHX);
} XCPT_TRY_END
XCPT_CATCH {
devel_pragma_call(aTHX_ "Devel::Pragma::_post_require", copy_of_hh); /* invoke the post-require callbacks */
hv_clear(copy_of_hh);
hv_undef(copy_of_hh);
XCPT_RETHROW;
}
}
devel_pragma_call(aTHX_ "Devel::Pragma::_post_require", copy_of_hh); /* invoke the post-require callbacks */
hv_clear(copy_of_hh);
hv_undef(copy_of_hh);
return o;
done:
return annotation->op_ppaddr(aTHX);
}
STATIC void devel_pragma_enable_check_hooks() {
if (DEVEL_PRAGMA_CHECK_HOOKS_ENABLED != 1) {
devel_pragma_check_do_file_id = hook_op_check(OP_DOFILE, devel_pragma_check_require, NULL);
devel_pragma_check_require_id = hook_op_check(OP_REQUIRE, devel_pragma_check_require, NULL);
/* work around B::Hooks::OP::Check issue on 5.8.1 */
SvREFCNT_inc(devel_pragma_check_do_file_id);
SvREFCNT_inc(devel_pragma_check_require_id);
DEVEL_PRAGMA_CHECK_HOOKS_ENABLED = 1;
}
}
MODULE = Devel::Pragma PACKAGE = Devel::Pragma
BOOT:
DEVEL_PRAGMA_ANNOTATIONS = op_annotation_group_new();
devel_pragma_enable_check_hooks();
void
DESTROY(SV * sv)
PROTOTYPE:$
CODE:
PERL_UNUSED_VAR(sv); /* silence warning */
if (DEVEL_PRAGMA_ANNOTATIONS) { /* make sure it was initialised */
op_annotation_group_free(aTHX_ DEVEL_PRAGMA_ANNOTATIONS);
}
SV *
ccstash()
PROTOTYPE:
CODE:
/* FIXME: this should probably croak or return NULL at runtime */
RETVAL = newSVpv(HvNAME(PL_curstash ? PL_curstash : PL_defstash), 0);
OUTPUT:
RETVAL
void
xs_scope()
PROTOTYPE:
CODE:
XSRETURN_UV(PTR2UV(GvHV(PL_hintgv)));