/* eval "package Foo; \&init_handler" */
int modperl_filter_resolve_init_handler(pTHX_ modperl_handler_t *handler,
apr_pool_t *p)
{
char *init_handler_pv_code = NULL;
if (handler->mgv_cv) {
GV *gv = modperl_mgv_lookup(aTHX_ handler->mgv_cv);
if (gv) {
CV *cv = modperl_mgv_cv(gv);
if (cv && SvMAGICAL(cv)) {
MAGIC *mg = mg_find((SV*)(cv), PERL_MAGIC_ext);
init_handler_pv_code = mg ? mg->mg_ptr : NULL;
}
else {
/* XXX: should we complain in such a case? */
return 0;
}
}
}
if (init_handler_pv_code) {
char *package_name =
modperl_mgv_as_string(aTHX_ handler->mgv_cv, p, 1);
/* fprintf(stderr, "PACKAGE: %s\n", package_name ); */
/* eval the code in the parent handler's package's context */
char *code = apr_pstrcat(p, "package ", package_name, ";",
init_handler_pv_code, NULL);
SV *sv;
modperl_handler_t *init_handler;
ENTER;SAVETMPS;
sv = eval_pv(code, TRUE);
/* fprintf(stderr, "code: %s\n", code); */
init_handler = modperl_handler_new_from_sv(aTHX_ p, sv);
FREETMPS;LEAVE;
if (init_handler) {
modperl_mgv_resolve(aTHX_ init_handler, p, init_handler->name, 1);
MP_TRACE_h(MP_FUNC, "found init handler %s",
modperl_handler_name(init_handler));
if (!(init_handler->attrs & MP_FILTER_INIT_HANDLER)) {
Perl_croak(aTHX_ "handler %s doesn't have "
"the FilterInitHandler attribute set",
modperl_handler_name(init_handler));
}
handler->next = init_handler;
return 1;
}
else {
Perl_croak(aTHX_ "failed to eval code: %s", code);
}
}
return 1;
}
U16 *modperl_code_attrs(pTHX_ CV *cv) {
MAGIC *mg;
if (!SvMAGICAL(cv)) {
sv_magic((SV*)cv, (SV *)NULL, PERL_MAGIC_ext, NULL, -1);
}
mg = mg_find((SV*)cv, PERL_MAGIC_ext);
return &(mg->mg_private);
}
lucy_RegexTokenizer*
lucy_RegexTokenizer_init(lucy_RegexTokenizer *self,
cfish_String *pattern) {
lucy_Analyzer_init((lucy_Analyzer*)self);
lucy_RegexTokenizerIVARS *const ivars = lucy_RegexTokenizer_IVARS(self);
#define DEFAULT_PATTERN "\\w+(?:['\\x{2019}]\\w+)*"
if (pattern) {
if (CFISH_Str_Contains_Utf8(pattern, "\\p", 2)
|| CFISH_Str_Contains_Utf8(pattern, "\\P", 2)
) {
CFISH_DECREF(self);
THROW(CFISH_ERR, "\\p and \\P constructs forbidden");
}
ivars->pattern = CFISH_Str_Clone(pattern);
}
else {
ivars->pattern = cfish_Str_new_from_trusted_utf8(
DEFAULT_PATTERN, sizeof(DEFAULT_PATTERN) - 1);
}
// Acquire a compiled regex engine for matching one token.
dTHX;
SV *token_re = S_compile_token_re(aTHX_ ivars->pattern);
#if (PERL_VERSION > 10)
REGEXP *rx = SvRX((SV*)token_re);
#else
if (!SvROK(token_re)) {
THROW(CFISH_ERR, "token_re is not a qr// entity");
}
SV *inner = SvRV(token_re);
MAGIC *magic = NULL;
if (SvMAGICAL((SV*)inner)) {
magic = mg_find((SV*)inner, PERL_MAGIC_qr);
}
if (!magic) {
THROW(CFISH_ERR, "token_re is not a qr// entity");
}
REGEXP *rx = (REGEXP*)magic->mg_obj;
#endif
if (rx == NULL) {
THROW(CFISH_ERR, "Failed to extract REGEXP from token_re '%s'",
SvPV_nolen((SV*)token_re));
}
ivars->token_re = rx;
(void)ReREFCNT_inc(((REGEXP*)ivars->token_re));
SvREFCNT_dec(token_re);
return self;
}
MP_INLINE int modperl_io_handle_tied(pTHX_ GV *handle, char *classname)
{
MAGIC *mg;
SV *sv = TIEHANDLE_SV(handle);
if (SvMAGICAL(sv) && (mg = mg_find(sv, PERL_MAGIC_tiedscalar))) {
char *package = HvNAME(SvSTASH((SV*)SvRV(mg->mg_obj)));
if (!strEQ(package, classname)) {
MP_TRACE_r(MP_FUNC, "%s tied to %s", GvNAME(handle), package);
return TRUE;
}
}
return FALSE;
}
void
blizkost_get_bound_pmc(PerlInterpreter *my_perl,
blizkost_nexus **nexusr, SV *sv, PMC **targetr) {
MAGIC *mgp;
if (SvMAGICAL(sv))
for (mgp = SvMAGIC(sv); mgp; mgp = mgp->mg_moremagic)
if (mgp->mg_virtual == &blizkost_binder_vtbl)
goto gotmagic;
croak("blizkost: expected a bound PMC, got something else");
gotmagic:
*nexusr = (blizkost_nexus *)(mgp->mg_ptr);
*targetr = (PMC *)mgp->mg_obj;
}
static char *pe_var_start(pe_watcher *_ev, int repeat) {
STRLEN n_a;
struct ufuncs *ufp;
MAGIC **mgp;
MAGIC *mg;
pe_var *ev = (pe_var*) _ev;
SV *sv = ev->variable;
if (!_ev->callback)
return "without callback";
if (!sv || !SvOK(sv))
return "watching what?";
if (!ev->events)
return "without poll events specified";
sv = SvRV(sv);
if (SvREADONLY(sv))
return "cannot trace read-only variable";
(void)SvUPGRADE(sv, SVt_PVMG);
mgp = &SvMAGIC(sv);
while ((mg = *mgp)) {
mgp = &mg->mg_moremagic;
}
EvNew(11, mg, 1, MAGIC);
Zero(mg, 1, MAGIC);
mg->mg_type = 'U';
mg->mg_virtual = &PL_vtbl_uvar;
*mgp = mg;
EvNew(8, ufp, 1, struct ufuncs);
ufp->uf_val = ev->events & PE_R? tracevar_r : 0;
ufp->uf_set = ev->events & PE_W? tracevar_w : 0;
ufp->uf_index = PTR2IV(ev);
mg->mg_ptr = (char *) ufp;
mg->mg_obj = (SV*) ev;
mg_magical(sv);
if (!SvMAGICAL(sv))
return "mg_magical didn't";
return 0;
}
static void
S_set_token_re_but_not_pattern(lucy_RegexTokenizer *self, void *token_re) {
#if (PERL_VERSION > 10)
REGEXP *rx = SvRX((SV*)token_re);
#else
MAGIC *magic = NULL;
if (SvMAGICAL((SV*)token_re)) {
magic = mg_find((SV*)token_re, PERL_MAGIC_qr);
}
if (!magic) {
THROW(LUCY_ERR, "token_re is not a qr// entity");
}
REGEXP *rx = (REGEXP*)magic->mg_obj;
#endif
if (rx == NULL) {
THROW(LUCY_ERR, "Failed to extract REGEXP from token_re '%s'",
SvPV_nolen((SV*)token_re));
}
if (self->token_re) {
ReREFCNT_dec(((REGEXP*)self->token_re));
}
self->token_re = rx;
(void)ReREFCNT_inc(((REGEXP*)self->token_re));
}
/* Converts perl values to equivalent JS values */
JSBool
PJS_ReflectPerl2JS(
pTHX_
JSContext *cx,
JSObject *pobj,
SV *ref,
jsval *rval
) {
PJS_Context *pcx = PJS_GET_CONTEXT(cx);
JSObject *newobj = NULL;
if(++pcx->svconv % 2000 == 0) {
JSErrorReporter older;
ENTER; SAVETMPS; /* Scope for finalizers */
older = JS_SetErrorReporter(cx, NULL);
if(pcx->svconv > 10000) {
JS_GC(cx);
pcx->svconv = 0;
} else JS_MaybeGC(cx);
JS_SetErrorReporter(cx, older);
FREETMPS; LEAVE;
}
if(SvROK(ref)) {
MAGIC *mg;
/* First check old jsvisitors */
if((newobj = PJS_IsPerlVisitor(aTHX_ pcx, SvRV(ref)))) {
PJS_DEBUG("Old jsvisitor returns\n");
*rval = OBJECT_TO_JSVAL(newobj);
return JS_TRUE;
}
if(SvMAGICAL(SvRV(ref)) && (mg = mg_find(SvRV(ref), PERL_MAGIC_tied))
&& mg->mg_obj && sv_derived_from(mg->mg_obj, PJS_BOXED_PACKAGE)) {
PJS_DEBUG1("A magical ref %s, shortcircuit!\n", SvPV_nolen((SV*)mg->mg_obj));
ref = mg->mg_obj;
}
if(sv_derived_from(ref, PJS_BOXED_PACKAGE)) {
SV **fref = av_fetch((AV *)SvRV(SvRV(ref)), 2, 0);
assert(sv_derived_from(*fref, PJS_RAW_JSVAL));
*rval = (jsval)SvIV(SvRV(*fref));
return JS_TRUE;
}
if(sv_derived_from(ref, PJS_BOOLEAN)) {
*rval = SvTRUE(SvRV(ref)) ? JSVAL_TRUE : JSVAL_FALSE;
return JS_TRUE;
}
if(sv_isobject(ref)) {
newobj = PJS_NewPerlObject(aTHX_ cx, pobj, ref);
if(newobj) {
*rval = OBJECT_TO_JSVAL(newobj);
return JS_TRUE;
}
return JS_FALSE;
}
}
SvGETMAGIC(ref);
if(!SvOK(ref)) /* undef */
*rval = JSVAL_VOID;
else if(SvIOK(ref) || SvIOKp(ref)) {
if(SvIV(ref) <= JSVAL_INT_MAX)
*rval = INT_TO_JSVAL(SvIV(ref));
else JS_NewDoubleValue(cx, (double) SvIV(ref), rval);
}
else if(SvNOK(ref))
JS_NewDoubleValue(cx, SvNV(ref), rval);
else if(SvPOK(ref) || SvPOKp(ref)) {
STRLEN len;
char *str;
SV *temp=NULL;
if(SvREADONLY(ref)) {
temp = newSVsv(ref);
str = PJS_SvPV(temp, len);
} else str = PJS_SvPV(ref, len);
JSString *jstr = ((int)len >= 0)
? JS_NewStringCopyN(cx, str, len)
: JS_NewUCStringCopyN(cx, (jschar *)str, -(int)len);
sv_free(temp);
if(!jstr) return JS_FALSE;
*rval = STRING_TO_JSVAL(jstr);
}
else if(SvROK(ref)) { /* Plain reference */
I32 type = SvTYPE(SvRV(ref));
if(type == SVt_PVHV)
newobj = PJS_NewPerlHash(aTHX_ cx, pobj, ref);
else if(type == SVt_PVAV)
newobj = PJS_NewPerlArray(aTHX_ cx, pobj, ref);
else if(type == SVt_PVCV)
newobj = PJS_NewPerlSub(aTHX_ cx, pobj, ref);
else
newobj = PJS_NewPerlScalar(aTHX_ cx, pobj, ref);
if(!newobj) return JS_FALSE;
*rval = OBJECT_TO_JSVAL(newobj);
}
else {
warn("I have no idea what perl send us (it's of type %i), I'll pretend it's undef", SvTYPE(ref));
*rval = JSVAL_VOID;
}
return JS_TRUE;
}