static void
rowreq_init_common(PLCB_t *parent, AV *req)
{
SV *selfref;
av_fill(req, PLCB_VHIDX_MAX);
av_store(req, PLCB_VHIDX_ROWBUF, newRV_noinc((SV *)newAV()));
av_store(req, PLCB_VHIDX_RAWROWS, newRV_noinc((SV *)newAV()));
av_store(req, PLCB_VHIDX_PARENT, newRV_inc(parent->selfobj));
selfref = newRV_inc((SV*)req);
sv_rvweaken(selfref);
av_store(req, PLCB_VHIDX_SELFREF, selfref);
}
static SV *parser_fn(OP *(fn)(pTHX_ U32), bool named) {
I32 floor;
CV *code;
U8 errors;
ENTER;
PL_curcop = &PL_compiling;
SAVEVPTR(PL_op);
SAVEI8(PL_parser->error_count);
PL_parser->error_count = 0;
floor = start_subparse(0, named ? 0 : CVf_ANON);
code = newATTRSUB(floor, NULL, NULL, NULL, fn(aTHX_ 0));
errors = PL_parser->error_count;
LEAVE;
if (errors) {
++PL_parser->error_count;
return newSV(0);
}
else {
if (CvCLONE(code)) {
code = cv_clone(code);
}
return newRV_inc((SV*)code);
}
}
static void
call_async(plcb_OPCTX *ctx, AV *resobj)
{
SV *cv = ctx->u.callback;
dSP;
if (cv == NULL || SvOK(cv) == 0) {
warn("Context does not have a callback (%p)!", cv);
return;
}
if ((ctx->flags & PLCB_OPCTXf_IMPLICIT) == 0) {
if (ctx->nremaining && (ctx->flags & PLCB_OPCTXf_CALLEACH) == 0) {
return; /* Still have ops. Only call once they're all complete */
}
}
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(sv_2mortal(newRV_inc((SV*)resobj)));
PUTBACK;
call_sv(cv, G_DISCARD);
FREETMPS;
LEAVE;
if (ctx->nremaining == 0 && (ctx->flags & PLCB_OPCTXf_CALLDONE)) {
ENTER;
SAVETMPS;
PUSHMARK(SP);
call_sv(cv, G_DISCARD);
FREETMPS;
LEAVE;
}
}
static void
bootstrap_callback(lcb_t instance, lcb_error_t status)
{
dSP;
PLCB_t *obj = (PLCB_t*) lcb_get_cookie(instance);
if (!obj->async) {
return;
}
if (!obj->conncb) {
warn("Object %p does not have a connect callback!", obj);
return;
}
printf("Invoking callback for connect..!\n");
ENTER;SAVETMPS;PUSHMARK(SP);
XPUSHs(sv_2mortal(newRV_inc(obj->selfobj)));
XPUSHs(sv_2mortal(newSViv(status)));
PUTBACK;
call_sv(obj->conncb, G_DISCARD);
SPAGAIN;
FREETMPS;LEAVE;
SvREFCNT_dec(obj->conncb); obj->conncb = NULL;
}
SV *p5_get_global(PerlInterpreter *my_perl, const char* name) {
PERL_SET_CONTEXT(my_perl);
if (strlen(name) < 2)
return NULL;
if (name[0] == '$')
return get_sv(&name[1], 0);
if (name[0] == '@')
return sv_2mortal(newRV_inc((SV *)get_av(&name[1], 0)));
if (name[0] == '%')
return sv_2mortal(newRV_inc((SV *)get_hv(&name[1], 0)));
return NULL;
}
static html_valid_status_t
html_valid_tag_information (HV * hv)
{
int i;
// n_html_tags is defined in html-tidy5.h as part of the "extra"
// material.
html_valid_tag_t tags[n_html_tags];
TagInformation (tags);
for (i = 0; i < n_html_tags; i++) {
int name_len;
AV * constants;
SV * constants_ref;
constants = newAV ();
// Store the ID for reverse lookup of attributes.
av_push (constants, newSVuv (i));
av_push (constants, newSVuv (tags[i].versions));
av_push (constants, newSVuv (tags[i].model));
constants_ref = newRV_inc ((SV *) constants);
name_len = strlen (tags[i].name);
/*
fprintf (stderr, "Storing %s (%d) into hash.\n",
tags[i].name, name_len);
*/
(void) hv_store (hv, tags[i].name, name_len, constants_ref, 0 /* no hash value */);
}
return html_valid_ok;
}
SV *
PLCBA_construct(const char *pkg, AV *options)
{
PLCBA_t *async;
char *host, *username, *password, *bucket;
libcouchbase_t instance;
SV *blessed_obj;
Newxz(async, 1, PLCBA_t);
extract_async_options(async, options);
plcb_ctor_conversion_opts(&async->base, options);
plcb_ctor_cbc_opts(options, &host, &username, &password, &bucket);
instance = libcouchbase_create(host, username, password, bucket,
plcba_make_io_opts(async));
if(!instance) {
die("Couldn't create instance!");
}
plcb_ctor_init_common(&async->base, instance, options);
plcba_setup_callbacks(async);
async->base_rv = newRV_inc(newSViv(PTR2IV(&(async->base))));
blessed_obj = newSV(0);
sv_setiv(newSVrv(blessed_obj, pkg), PTR2IV(async));
return blessed_obj;
}
SV *modperl_pnotes(pTHX_ HV **pnotes, SV *key, SV *val,
request_rec *r, conn_rec *c) {
SV *retval = (SV *)NULL;
if (!*pnotes) {
apr_pool_t *pool = r ? r->pool : c->pool;
void *cleanup_data;
*pnotes = newHV();
cleanup_data = modperl_pnotes_cleanup_data(aTHX_ pnotes, pool);
apr_pool_cleanup_register(pool, cleanup_data,
modperl_cleanup_pnotes,
apr_pool_cleanup_null);
}
if (key) {
STRLEN len;
char *k = SvPV(key, len);
if (val) {
retval = *hv_store(*pnotes, k, len, SvREFCNT_inc(val), 0);
}
else if (hv_exists(*pnotes, k, len)) {
retval = *hv_fetch(*pnotes, k, len, FALSE);
}
return retval ? SvREFCNT_inc(retval) : &PL_sv_undef;
}
return newRV_inc((SV *)*pnotes);
}
static void modify_event_perl(PLCBA_t *async,
PLCBA_c_event *cevent,
PLCBA_evaction_t action,
short flags)
{
SV **tmpsv;
tmpsv = av_fetch(cevent->pl_event, PLCBA_EVIDX_FD, 1);
if (SvIOK(*tmpsv)) {
if (SvIV(*tmpsv) != cevent->fd) {
/*file descriptor mismatch!*/
av_delete(cevent->pl_event, PLCBA_EVIDX_DUPFH, G_DISCARD);
}
} else {
sv_setiv(*tmpsv, cevent->fd);
}
plcb_call_sv_with_args_noret(async->cv_evmod,
1,
3,
newRV_inc( (SV*)(cevent->pl_event)),
newSViv(action),
newSViv(flags));
/*set the current flags*/
if (action != PLCBA_EVACTION_SUSPEND && action != PLCBA_EVACTION_RESUME) {
sv_setiv( *(av_fetch(cevent->pl_event, PLCBA_EVIDX_WATCHFLAGS, 1)),
flags);
}
/*set the current state*/
sv_setiv( *(av_fetch(cevent->pl_event, PLCBA_EVIDX_STATEFLAGS, 1)),
cevent->state);
}
void h3(void *arg) {
int argc = 3;
char *argv[] = { "", "-e", "use Data::Dumper;"
"sub dump_perl { print STDERR Data::Dumper::Dumper([shift]); }",
NULL };
char *env[] = { NULL };
void *original_context = PERL_GET_CONTEXT;
SV *sv;
PERL_SYS_INIT3(&argc,&argv,&env);
my_perl = perl_alloc();
sv = newRV_inc(newSViv(5));
PERL_SET_CONTEXT(my_perl);
perl_construct(my_perl);
perl_parse(my_perl, mine_xs_init, argc, argv, NULL);
call_dump_perl(sv);
perl_destruct(my_perl);
perl_free(my_perl);
PERL_SET_CONTEXT(original_context);
}
static void ctor_extract_methpairs(AV *options,
int idx, SV **outmeth, SV **inmeth)
{
SV **tmpsv;
AV *methav;
int ii;
SV **assgn_array[] = { outmeth, inmeth };
*outmeth = *inmeth = NULL;
if ( (tmpsv = av_fetch(options, idx, 0)) == NULL ) {
return;
}
if (SvROK(*tmpsv) == 0 ||
((methav = (AV*)SvRV(*tmpsv)) && SvTYPE(methav) != SVt_PVAV) ||
av_len(methav) != 1) {
die("Expected an array reference with two elements");
}
for (ii = 0; ii < 2; ii++) {
tmpsv = av_fetch(methav, ii, 0);
if(SvROK(*tmpsv) == 0 || SvTYPE(SvRV(*tmpsv)) != SVt_PVCV) {
die("Expected code reference.");
}
*(assgn_array[ii]) = newRV_inc(SvRV(*tmpsv));
}
}
JSObject *
PJS_InitPerlArrayClass(
pTHX_
JSContext *cx,
JSObject *global
) {
JSObject *proto;
JSObject *stash = PJS_GetPackageObject(aTHX_ cx, PerlArrayPkg);
proto = JS_InitClass(
cx,
global,
stash,
&perlarray_class,
PerlArray, 0,
perlarray_props, perlarray_methods,
NULL, NULL
);
if(!proto ||
!JS_DefineProperty(cx, stash, PJS_PROXY_PROP,
OBJECT_TO_JSVAL(proto), NULL, NULL, 0))
return NULL;
return PJS_CreateJSVis(aTHX_ cx, proto,
newRV_inc((SV *)get_av(NAMESPACE"PerlArray::prototype",1)));
}
/*
* Parse a configuration section, and populate a HV.
* This function is recursively called (allows to have nested hashes.)
*/
static void perl_parse_config(CONF_SECTION *cs, int lvl, HV *rad_hv)
{
if (!cs || !rad_hv) return;
int indent_section = (lvl + 1) * 4;
int indent_item = (lvl + 2) * 4;
DEBUG("%*s%s {", indent_section, " ", cf_section_name1(cs));
CONF_ITEM *ci = NULL;
while ((ci = cf_item_next(cs, ci))) {
/*
* This is a section.
* Create a new HV, store it as a reference in current HV,
* Then recursively call perl_parse_config with this section and the new HV.
*/
if (cf_item_is_section(ci)) {
CONF_SECTION *sub_cs = cf_item_to_section(ci);
char const *key = cf_section_name1(sub_cs); /* hash key */
HV *sub_hv;
SV *ref;
if (!key) continue;
if (hv_exists(rad_hv, key, strlen(key))) {
WARN("Ignoring duplicate config section '%s'", key);
continue;
}
sub_hv = newHV();
ref = newRV_inc((SV*) sub_hv);
(void)hv_store(rad_hv, key, strlen(key), ref, 0);
perl_parse_config(sub_cs, lvl + 1, sub_hv);
} else if (cf_item_is_pair(ci)){
CONF_PAIR *cp = cf_item_to_pair(ci);
char const *key = cf_pair_attr(cp); /* hash key */
char const *value = cf_pair_value(cp); /* hash value */
if (!key || !value) continue;
/*
* This is an item.
* Store item attr / value in current HV.
*/
if (hv_exists(rad_hv, key, strlen(key))) {
WARN("Ignoring duplicate config item '%s'", key);
continue;
}
(void)hv_store(rad_hv, key, strlen(key), newSVpvn(value, strlen(value)), 0);
DEBUG("%*s%s = %s", indent_item, " ", key, value);
}
}
DEBUG("%*s}", indent_section, " ");
}
SV *HRXSATTR_get_hash(SV *self)
{
hrattr_simple *attr = attr_from_sv(SvRV(self));
if(attr->attrhash) {
return newRV_inc((SV*)attr->attrhash);
} else {
return &PL_sv_undef;
}
}
static SV *make_env(request_rec *r, psgi_dir_config *c)
{
dTHX;
HV *env;
AV *version;
char *url_scheme, *script_name, *vpath, *path_info;
SV *input, *errors;
env = newHV();
ap_add_cgi_vars(r);
ap_add_common_vars(r);
/* fix SCRIPT_NAME & PATH_INFO */
if (c->location == NULL || strcmp(c->location, "/") == 0) {
script_name = "";
} else {
script_name = c->location;
}
vpath = apr_pstrcat(r->pool,
apr_table_get(r->subprocess_env, "SCRIPT_NAME"),
apr_table_get(r->subprocess_env, "PATH_INFO"),
NULL);
path_info = &vpath[strlen(script_name)];
apr_table_set(r->subprocess_env, "PATH_INFO", path_info);
apr_table_set(r->subprocess_env, "SCRIPT_NAME", script_name);
apr_table_do(copy_env, env, r->subprocess_env, NULL);
version = newAV();
av_push(version, newSViv(1));
av_push(version, newSViv(0));
(void) hv_store(env, "psgi.version", 12, newRV_noinc((SV *) version), 0);
url_scheme = apr_table_get(r->subprocess_env, "HTTPS") == NULL ? "http" : "https";
(void) hv_store(env, "psgi.url_scheme", 15, newSVpv(url_scheme, 0), 0);
input = newRV_noinc(newSV(0));
sv_magic(SvRV(input), NULL, PERL_MAGIC_ext, NULL, 0);
mg_find(SvRV(input), PERL_MAGIC_ext)->mg_obj = (void *) r;
sv_bless(input, gv_stashpv("ModPSGI::Input", 1));
(void) hv_store(env, "psgi.input", 10, input, 0);
errors = newRV_noinc(newSV(0));
sv_magic(SvRV(errors), NULL, PERL_MAGIC_ext, NULL, 0);
mg_find(SvRV(errors), PERL_MAGIC_ext)->mg_obj = (void *) r;
sv_bless(errors, gv_stashpv("ModPSGI::Errors", 1));
(void) hv_store(env, "psgi.errors", 11, errors, 0);
(void) hv_store(env, "psgi.multithread", 16, newSViv(psgi_multithread), 0);
(void) hv_store(env, "psgi.multiprocess", 17, newSViv(psgi_multiprocess), 0);
(void) hv_store(env, "psgi.run_once", 13, newSViv(0), 0);
(void) hv_store(env, "psgi.nonblocking", 16, newSViv(0), 0);
return newRV_inc((SV *) env);
}
static bool
collect_all_symbols (const char *key, STRLEN keylen, SV *val, void *ud)
{
HV *hash = (HV *)ud;
if (!hv_store (hash, key, keylen, newRV_inc(val), 0)) {
croak("failed to store symbol ref");
}
return TRUE;
}
void VParserXs::call (
string* rtnStrp, /* If non-null, load return value here */
int params, /* Number of parameters */
const char* method, /* Name of method to call */
...) /* Arguments to pass to method's @_ */
{
// Call $perlself->method (passedparam1, parsedparam2)
if (debug()) cout << "CALLBACK "<<method<<endl;
va_list ap;
va_start(ap, method);
{
dSP; /* Initialize stack pointer */
ENTER; /* everything created after here */
SAVETMPS; /* ...is a temporary variable. */
PUSHMARK(SP); /* remember the stack pointer */
SV* selfsv = newRV_inc(m_self); /* $self-> */
XPUSHs(sv_2mortal(selfsv));
while (params--) {
char* text = va_arg(ap, char *);
SV* sv;
if (text) {
sv = sv_2mortal(newSVpv (text, 0));
} else {
sv = &PL_sv_undef;
}
XPUSHs(sv); /* token */
}
PUTBACK; /* make local stack pointer global */
if (rtnStrp) {
int rtnCount = perl_call_method ((char*)method, G_SCALAR);
SPAGAIN; /* refresh stack pointer */
if (rtnCount > 0) {
SV* sv = POPs;
//printf("RTN %ld %d %s\n", SvTYPE(sv),SvTRUE(sv),SvPV_nolen(sv));
#ifdef SvPV_nolen // Perl 5.6 and later
*rtnStrp = SvPV_nolen(sv);
#else
*rtnStrp = SvPV(sv,PL_na);
#endif
}
PUTBACK;
} else {
perl_call_method ((char*)method, G_DISCARD | G_VOID);
}
FREETMPS; /* free that return value */
LEAVE; /* ...and the XPUSHed "mortal" args.*/
}
va_end(ap);
}
static SV *
custom_convert(AV *docav, SV *meth, SV *input, uint32_t *flags, int direction)
{
dSP;
SV *ret;
SV *flags_rv;
SV *input_rv;
int callflags;
ENTER; SAVETMPS;
PUSHMARK(SP);
input_rv = sv_2mortal(newRV_inc(input));
flags_rv = sv_2mortal(newRV_noinc(newSVuv(*flags)));
XPUSHs(sv_2mortal(newRV_inc( (SV *)docav)));
XPUSHs(input_rv);
XPUSHs(flags_rv);
PUTBACK;
callflags = G_VOID|G_DISCARD;
if (direction == CONVERT_OUT) {
callflags |= G_EVAL;
}
call_sv(meth, callflags);
SPAGAIN;
if (SvTRUE(ERRSV)) {
ret = input;
} else {
warn("Conversion function failed");
ret = SvRV(input_rv);
*flags = SvUV(SvRV(flags_rv));
}
SvREFCNT_inc(ret);
return ret;
}
USER_OBJECT_
R_makePerlReference(USER_OBJECT_ s_obj)
{
SV *obj, *ref;
USER_OBJECT_ ans;
dTHX;
obj = toPerl(s_obj, TRUE);
/* SvREFCNT_inc(obj); not needed */
ref = newRV_inc(obj);
ans = createPerlReference((SV*) ref);
return(ans);
}
static void modify_timer_perl(PLCBA_t *async,
PLCBA_c_event *cevent,
uint32_t usecs,
PLCBA_evaction_t action)
{
//warn("Calling cv_timermod");
plcb_call_sv_with_args_noret(async->cv_timermod,
1,
3,
newRV_inc( (SV*)cevent->pl_event ),
newSViv(action),
newSVuv(usecs));
}
/* convert array header of modperl_handlers_t's to AV ref of CV refs */
SV *modperl_handler_perl_get_handlers(pTHX_ MpAV **handp, apr_pool_t *p)
{
AV *av = newAV();
int i;
modperl_handler_t **handlers;
if (!(handp && *handp)) {
return &PL_sv_undef;
}
av_extend(av, (*handp)->nelts - 1);
handlers = (modperl_handler_t **)(*handp)->elts;
for (i=0; i<(*handp)->nelts; i++) {
modperl_handler_t *handler = NULL;
GV *gv;
if (MpHandlerPARSED(handlers[i])) {
handler = handlers[i];
}
else {
#ifdef USE_ITHREADS
if (!MpHandlerDYNAMIC(handlers[i])) {
handler = modperl_handler_dup(p, handlers[i]);
}
#endif
if (!handler) {
handler = handlers[i];
}
if (!modperl_mgv_resolve(aTHX_ handler, p, handler->name, TRUE)) {
MP_TRACE_h(MP_FUNC, "failed to resolve handler %s",
handler->name);
}
}
if (handler->mgv_cv) {
if ((gv = modperl_mgv_lookup(aTHX_ handler->mgv_cv))) {
CV *cv = modperl_mgv_cv(gv);
av_push(av, newRV_inc((SV*)cv));
}
}
else {
av_push(av, newSVpv(handler->name, 0));
}
}
return newRV_noinc((SV*)av);
}
SV* THX_MopMcV_get_method(pTHX_ SV* metaclass, SV* name) {
HV* stash = (HV*) SvRV(metaclass);
HE* method_gv_he = hv_fetch_ent(stash, name, 0, 0);
if (method_gv_he != NULL) {
GV* method_gv = (GV*) HeVAL(method_gv_he);
CV* method = GvCV(method_gv);
if (method != NULL && GvSTASH(CvGV(method)) == stash) {
return newRV_inc((SV*) method);
}
}
return NULL;
}
cfish_Hash*
LUCY_Doc_Dump_IMP(lucy_Doc *self) {
dTHX;
lucy_DocIVARS *const ivars = lucy_Doc_IVARS(self);
cfish_Hash *dump = cfish_Hash_new(0);
CFISH_Hash_Store_Utf8(dump, "_class", 6,
(cfish_Obj*)CFISH_Str_Clone(lucy_Doc_get_class_name(self)));
CFISH_Hash_Store_Utf8(dump, "doc_id", 7,
(cfish_Obj*)cfish_Str_newf("%i32", ivars->doc_id));
SV *fields_sv = newRV_inc((SV*)ivars->fields);
CFISH_Hash_Store_Utf8(dump, "fields", 6,
XSBind_perl_to_cfish(aTHX_ fields_sv, CFISH_HASH));
SvREFCNT_dec(fields_sv);
return dump;
}
static int output_body_obj(request_rec *r, SV *obj, int type)
{
dTHX;
SV *buf_sv;
apr_off_t clen = 0;
STRLEN len;
dSP;
char *buf;
int count;
if (type == SVt_PVMG && !respond_to(obj, "getline")) {
server_error(r, "response body object must be able to getline");
return HTTP_INTERNAL_SERVER_ERROR;
}
ENTER;
SAVETMPS;
SAVESPTR(PL_rs);
PL_rs = newRV_inc(newSViv(AP_IOBUFSIZE));
while (1) {
PUSHMARK(SP);
XPUSHs(obj);
PUTBACK;
count = call_method("getline", G_SCALAR);
if (count != 1) croak("Big trouble\n");
SPAGAIN;
buf_sv = POPs;
if (SvOK(buf_sv)) {
buf = SvPV(buf_sv, len);
clen += len;
ap_rwrite(buf, len, r);
} else {
break;
}
}
if (clen > 0) {
ap_set_content_length(r, clen);
}
PUSHMARK(SP);
XPUSHs(obj);
PUTBACK;
call_method("close", G_DISCARD);
SPAGAIN;
PUTBACK;
FREETMPS;
LEAVE;
return OK;
}
static void
call_helper(AV *resobj, int cbtype, const lcb_RESPBASE *resp)
{
dSP;
const char *methname;
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(sv_2mortal(newRV_inc((SV*)resobj)));
if (cbtype == LCB_CALLBACK_STATS) {
const lcb_RESPSTATS *sresp = (const void *)resp;
/** Call as statshelper($doc,$server,$key,$value); */
XPUSHs(sv_2mortal(newSVpv(sresp->server, 0)));
XPUSHs(sv_2mortal(newSVpvn(sresp->key, sresp->nkey)));
if (sresp->value) {
XPUSHs(sv_2mortal(newSVpvn(sresp->value, sresp->nvalue)));
}
methname = PLCB_STATS_PLHELPER;
} else if (cbtype == LCB_CALLBACK_OBSERVE) {
const lcb_RESPOBSERVE *oresp = (const void *)resp;
/** Call as obshelper($doc,$status,$cas,$ismaster) */
XPUSHs(sv_2mortal(newSVuv(oresp->status)));
XPUSHs(sv_2mortal(plcb_sv_from_u64_new(&oresp->cas)));
XPUSHs(oresp->ismaster ? &PL_sv_yes : &PL_sv_no);
methname = PLCB_OBS_PLHELPER;
} else {
return;
}
PUTBACK;
call_pv(methname, G_DISCARD|G_EVAL);
SPAGAIN;
if (SvTRUE(ERRSV)) {
warn("Got error in %s: %s", methname, SvPV_nolen(ERRSV));
}
FREETMPS;
LEAVE;
}
static SV*
S_nfreeze_fields(lucy_Doc *self) {
lucy_DocIVARS *const ivars = lucy_Doc_IVARS(self);
dSP;
ENTER;
SAVETMPS;
EXTEND(SP, 1);
PUSHMARK(SP);
mPUSHs((SV*)newRV_inc((SV*)ivars->fields));
PUTBACK;
call_pv("Storable::nfreeze", G_SCALAR);
SPAGAIN;
SV *frozen = POPs;
(void)SvREFCNT_inc(frozen);
PUTBACK;
FREETMPS;
LEAVE;
return frozen;
}
SV *get_single_hook(pTHX_ const SingleHook *hook)
{
SV *sv;
assert(hook != NULL);
sv = hook->sub;
if (sv == NULL)
return NULL;
sv = newRV_inc(sv);
if (hook->arg)
{
AV *av = newAV();
int j, len = 1 + av_len(hook->arg);
av_extend(av, len);
if (av_store(av, 0, sv) == NULL)
fatal("av_store() failed in get_hooks()");
for (j = 0; j < len; j++)
{
SV **pSV = av_fetch(hook->arg, j, 0);
if (pSV == NULL)
fatal("NULL returned by av_fetch() in get_hooks()");
SvREFCNT_inc(*pSV);
if (av_store(av, j+1, *pSV) == NULL)
fatal("av_store() failed in get_hooks()");
}
sv = newRV_noinc((SV *) av);
}
return sv;
}
// create a new coro
SV * coroae_coro_new(CV *block) {
SV *newobj = NULL;
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(sv_2mortal(newSVpv( "Coro", 4)));
XPUSHs(newRV_inc((SV *)block));
PUTBACK;
call_method("new", G_SCALAR);
SPAGAIN;
if(SvTRUE(ERRSV)) {
uwsgi_log("[uwsgi-perl error] %s", SvPV_nolen(ERRSV));
}
else {
newobj = SvREFCNT_inc(POPs);
}
PUTBACK;
FREETMPS;
LEAVE;
return newobj;
}
static long dimension_from_hook(pTHX_ SingleHook *hook, SV *self, HV *parent)
{
dTHR;
dXCPT;
SV *sv, *in;
long rv;
assert(hook != NULL);
assert(self != NULL);
in = parent ? newRV_inc((SV *) parent) : NULL;
sv = NULL;
XCPT_TRY_START
{
sv = single_hook_call(aTHX_ self, "dimension", NULL, NULL, hook, in, 0);
}
XCPT_TRY_END
XCPT_CATCH
{
if (parent)
{
CT_DEBUG(MAIN, ("freeing sv @ %p in dimension_from_hook:%d", in, __LINE__));
SvREFCNT_dec(in);
}
XCPT_RETHROW;
}
assert(sv != NULL);
rv = sv_to_dimension(aTHX_ sv, NULL);
SvREFCNT_dec(sv);
return rv;
}
SV* THX_newMopMmV(pTHX_ SV* code, U32 flags) {
SV* method;
CV* cv = (CV*) newSV(0);
sv_upgrade((SV*) cv, SVt_PVCV);
CvISXSUB_on(cv);
CvXSUB(cv) = _MopMmV_wrapper;
CvXSUBANY(cv).any_uv = PTR2UV(code);
CvFILE(cv) = __FILE__;
CvANON_off(cv);
CvMETHOD_on(cv);
SvREFCNT_inc(code);
method = newMopOV(newRV_inc((SV*) cv));
if (flags & MopMmVf_STEAL_STASH) {
MopMmV_assign_to_stash(method, CvGV(SvRV(code)), CvSTASH(SvRV(code)));
}
return method;
}
