/*
* returns a pointer to a temp stock item you can use until control returns
* to perl.
*/
static GtkStockItem *
SvGtkStockItem (SV * sv)
{
HV * hv;
SV ** svp;
GtkStockItem * item;
if (!gperl_sv_is_hash_ref (sv))
croak ("malformed stock item; use a reference to a hash as a stock item");
hv = (HV*) SvRV (sv);
item = gperl_alloc_temp (sizeof (GtkStockItem));
svp = hv_fetch (hv, "stock_id", 8, FALSE);
if (svp) item->stock_id = SvGChar (*svp);
svp = hv_fetch (hv, "label", 5, FALSE);
if (svp) item->label = SvGChar (*svp);
svp = hv_fetch (hv, "modifier", 8, FALSE);
if (svp) item->modifier = SvGdkModifierType (*svp);
svp = hv_fetch (hv, "keyval", 6, FALSE);
if (svp) item->keyval = SvUV (*svp);
svp = hv_fetch (hv, "translation_domain", 18, FALSE);
if (svp) item->translation_domain = SvGChar (*svp);
return item;
}
static RouteEntry *
route_sv2c(SV *h, RouteEntry *ref)
{
if (ref && h && SvROK(h)) {
HV *hv = (HV *)SvRV(h);
memset(ref, 0, sizeof(RouteEntry));
if (hv_exists(hv, "route_dst", 9)) {
SV **r = hv_fetch(hv, "route_dst", 9, 0);
if (SvOK(*r)) {
struct addr a;
if (addr_aton(SvPV(*r, PL_na), &a) == 0) {
memcpy(&(ref->route_dst), &a, sizeof(struct addr));
}
}
}
if (hv_exists(hv, "route_gw", 8)) {
SV **r = hv_fetch(hv, "route_gw", 8, 0);
if (SvOK(*r)) {
struct addr a;
if (addr_aton(SvPV(*r, PL_na), &a) == 0) {
memcpy(&(ref->route_gw), &a, sizeof(struct addr));
}
}
}
}
else {
ref = NULL;
}
return ref;
}
SV*
Application_fonts( Handle self, char * name, char * encoding)
{
int count, i;
AV * glo = newAV();
PFont fmtx = apc_fonts( self, name[0] ? name : nil,
encoding[0] ? encoding : nil, &count);
for ( i = 0; i < count; i++) {
SV * sv = sv_Font2HV( &fmtx[ i]);
HV * profile = ( HV*) SvRV( sv);
if ( fmtx[i]. utf8_flags & FONT_UTF8_NAME) {
SV ** entry = hv_fetch(( HV*) SvRV( sv), "name", 4, 0);
if ( entry && SvOK( *entry))
SvUTF8_on( *entry);
}
if ( fmtx[i]. utf8_flags & FONT_UTF8_FAMILY) {
SV ** entry = hv_fetch(( HV*) SvRV( sv), "family", 6, 0);
if ( name && SvOK( *entry))
SvUTF8_on( *entry);
}
if ( fmtx[i]. utf8_flags & FONT_UTF8_ENCODING) {
SV ** entry = hv_fetch(( HV*) SvRV( sv), "encoding", 8, 0);
if ( name && SvOK( *entry))
SvUTF8_on( *entry);
}
if ( name[0] == 0 && encoding[0] == 0) {
/* Read specially-coded (const char*) encodings[] vector,
stored in fmtx[i].encoding. First pointer is filled with 0s,
except the last byte which is a counter. Such scheme
allows max 31 encodings per entry to be coded with sizeof(char*)==8.
The interface must be re-implemented, but this requires
either change in gencls syntax so arrays can be members of hashes,
or passing of a dynamic-allocated pointer vector here.
*/
char ** enc = (char**) fmtx[i].encoding;
unsigned char * shift = (unsigned char*) enc + sizeof(char *) - 1, j = *shift;
AV * loc = newAV();
pset_sv_noinc( encoding, newSVpv(( j > 0) ? *(++enc) : "", 0));
while ( j--) av_push( loc, newSVpv(*(enc++),0));
pset_sv_noinc( encodings, newRV_noinc(( SV*) loc));
}
pdelete( resolution);
pdelete( codepage);
av_push( glo, sv);
}
free( fmtx);
return newRV_noinc(( SV *) glo);
}
/* Deletes name from all the isarev entries listed in isa */
STATIC void
S_mro_clean_isarev(pTHX_ HV * const isa, const char * const name,
const STRLEN len, HV * const exceptions, U32 hash,
U32 flags)
{
HE* iter;
PERL_ARGS_ASSERT_MRO_CLEAN_ISAREV;
/* Delete our name from our former parents' isarevs. */
if(HvARRAY(isa) && hv_iterinit(isa)) {
SV **svp;
while((iter = hv_iternext(isa))) {
I32 klen;
const char * const key = hv_iterkey(iter, &klen);
if(exceptions && hv_exists(exceptions, key, HeKUTF8(iter) ? -klen : klen))
continue;
svp = hv_fetch(PL_isarev, key, HeKUTF8(iter) ? -klen : klen, 0);
if(svp) {
HV * const isarev = (HV *)*svp;
(void)hv_common(isarev, NULL, name, len, flags,
G_DISCARD|HV_DELETE, NULL, hash);
if(!HvARRAY(isarev) || !HvUSEDKEYS(isarev))
(void)hv_delete(PL_isarev, key,
HeKUTF8(iter) ? -klen : klen, G_DISCARD);
}
}
}
}
/*
* convert perl HV to reserve_info_t
*/
int
hv_to_reserve_info(HV *hv, reserve_info_t *resv_info)
{
SV **svp;
AV *av;
int i, n;
memset(resv_info, 0, sizeof(reserve_info_t));
FETCH_FIELD(hv, resv_info, accounts, charp, FALSE);
FETCH_FIELD(hv, resv_info, end_time, time_t, TRUE);
FETCH_FIELD(hv, resv_info, features, charp, FALSE);
FETCH_FIELD(hv, resv_info, flags, uint16_t, TRUE);
FETCH_FIELD(hv, resv_info, licenses, charp, FALSE);
FETCH_FIELD(hv, resv_info, name, charp, TRUE);
FETCH_FIELD(hv, resv_info, node_cnt, uint32_t, TRUE);
svp = hv_fetch(hv, "node_inx", 8, FALSE);
if (svp && SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVAV) {
av = (AV*)SvRV(*svp);
n = av_len(av) + 2; /* for trailing -1 */
resv_info->node_inx = xmalloc(n * sizeof(int));
for (i = 0 ; i < n-1; i += 2) {
resv_info->node_inx[i] = (int)SvIV(*(av_fetch(av, i ,FALSE)));
resv_info->node_inx[i+1] = (int)SvIV(*(av_fetch(av, i+1 ,FALSE)));
}
resv_info->node_inx[n-1] = -1;
} else {
/* nothing to do */
}
FETCH_FIELD(hv, resv_info, node_list, charp, FALSE);
FETCH_FIELD(hv, resv_info, partition, charp, FALSE);
FETCH_FIELD(hv, resv_info, start_time, time_t, TRUE);
FETCH_FIELD(hv, resv_info, users, charp, FALSE);
return 0;
}
long SvFlagsHash(SV * name, char * optname, HV * o)
{
int i;
int val=0;
if (!name || !SvOK(name))
return 0;
if (SvRV(name) && (SvTYPE(SvRV(name)) == SVt_PVAV)) {
AV * r = (AV*)SvRV(name);
for(i=0;i<=av_len(r);i++)
val |= SvOptsHash(*av_fetch(r, i, 0), optname, o);
} else if (SvRV(name) && (SvTYPE(SvRV(name)) == SVt_PVHV)) {
HV * r = (HV*)SvRV(name);
HE * h;
hv_iterinit(r);
while((h = hv_iternext(r))) {
I32 len;
char * key = hv_iterkey(h, &len);
SV ** f;
if (*key == '-') {
key++;
len--;
}
f = hv_fetch(o, key, len, 0);
if (f)
val |= SvIV(hv_iterval(o, h));
else
CroakOptsHash(optname, key, o);
}
} else
val |= SvOptsHash(name, optname, o);
return val;
}
nv_item *perl_store_namedvars(nv_list *nv, HV *values) {
int i, j;
nv_item *item;
SV **value;
i = 0;
j = 0;
item = nv_new_item(nv);
while (nv->format[i].fldname != NULL) {
if (hv_exists(values, nv->format[i].fldname, strlen(nv->format[i].fldname))) {
value = hv_fetch(values, nv->format[i].fldname, strlen(nv->format[i].fldname), FALSE);
} else {
i++;
continue;
}
switch (nv->format[i].type) {
case NV_PSTR:
case NV_STR:
nv_sf_string(item, nv->format[i].fldname, SvPV_nolen(*value));
break;
case NV_INT:
nv_sf_int(item, nv->format[i].fldname, SvIV(*value));
break;
case NV_LONG:
nv_sf_long(item, nv->format[i].fldname, SvIV(*value));
break;
case NV_VOID:
default:
printf("Value: Unhandled!\n");
break;
}
i++;
}
return item;
}
/*
* convert perl HV to slurm_step_launch_params_t
*/
int
hv_to_slurm_step_launch_params(HV *hv, slurm_step_launch_params_t *params)
{
int i, num_keys;
STRLEN vlen;
I32 klen;
SV **svp;
HV *environ_hv, *local_fds_hv, *fd_hv;
AV *argv_av;
SV *val;
char *env_key, *env_val;
slurm_step_launch_params_t_init(params);
if((svp = hv_fetch(hv, "argv", 4, FALSE))) {
if(SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVAV) {
argv_av = (AV*)SvRV(*svp);
params->argc = av_len(argv_av) + 1;
if (params->argc > 0) {
/* memory of params MUST be free-ed by libslurm-perl */
Newz(0, params->argv, (int32_t)(params->argc + 1), char*);
for(i = 0; i < params->argc; i ++) {
if((svp = av_fetch(argv_av, i, FALSE)))
*(params->argv + i) = (char*) SvPV_nolen(*svp);
else {
Perl_warn(aTHX_ "error fetching `argv' of job descriptor");
free_slurm_step_launch_params_memory(params);
return -1;
}
}
}
} else {
static CORBA_boolean
put_struct (GIOPSendBuffer *buf, CORBA_TypeCode tc, SV *sv)
{
HV *hv;
CORBA_unsigned_long i;
if (!SvROK(sv) || (SvTYPE(SvRV(sv)) != SVt_PVHV)) {
warn ("Structure must be hash reference");
return CORBA_FALSE;
}
hv = (HV *)SvRV(sv);
for (i = 0; i<tc->sub_parts; i++) {
SV **valp = hv_fetch (hv, (char *)tc->subnames[i], strlen(tc->subnames[i]), 0);
if (!valp && (PL_dowarn & G_WARN_ON))
warn ("Uninitialized structure member '%s'", tc->subnames[i]);
if (!porbit_put_sv (buf, tc->subtypes[i], valp ? *valp : &PL_sv_undef))
return CORBA_FALSE;
}
return CORBA_TRUE;
}
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);
}
GV *
Perl_gv_fetchfile(pTHX_ const char *name)
{
char smallbuf[256];
char *tmpbuf;
STRLEN tmplen;
GV *gv;
if (!PL_defstash)
return Nullgv;
tmplen = strlen(name) + 2;
if (tmplen < sizeof smallbuf)
tmpbuf = smallbuf;
else
New(603, tmpbuf, tmplen + 1, char);
tmpbuf[0] = '_';
tmpbuf[1] = '<';
strcpy(tmpbuf + 2, name);
gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE);
if (!isGV(gv)) {
gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
sv_setpv(GvSV(gv), name);
if (PERLDB_LINE)
hv_magic(GvHVn(gv_AVadd(gv)), Nullgv, 'L');
}
if (tmpbuf != smallbuf)
Safefree(tmpbuf);
return gv;
}
static const message* save_modules(pTHX, HV* options) {
SV** modules_ptr = hv_fetch(options, "modules", 7, FALSE);
if (modules_ptr && SvROK(*modules_ptr) && SvTYPE(SvRV(*modules_ptr)) == SVt_PVAV)
return message_store_value(SvRV(*modules_ptr));
else
return message_store_value(&PL_sv_undef);
}
ithread* Perl_ithread_get (pTHX) {
SV** thread_sv = hv_fetch(PL_modglobal, "threads::self",12,0);
if(!thread_sv) {
croak("%s\n","Internal error, couldn't get TLS");
}
return INT2PTR(ithread*,SvIV(*thread_sv));
}
GV *
Perl_gv_fetchmeth_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
{
GV *gv = gv_fetchmeth(stash, name, len, level);
if (!gv) {
char autoload[] = "AUTOLOAD";
STRLEN autolen = sizeof(autoload)-1;
CV *cv;
GV **gvp;
if (!stash)
return Nullgv; /* UNIVERSAL::AUTOLOAD could cause trouble */
if (len == autolen && strnEQ(name, autoload, autolen))
return Nullgv;
if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE)))
return Nullgv;
cv = GvCV(gv);
if (!(CvROOT(cv) || CvXSUB(cv)))
return Nullgv;
/* Have an autoload */
if (level < 0) /* Cannot do without a stub */
gv_fetchmeth(stash, name, len, 0);
gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
if (!gvp)
return Nullgv;
return *gvp;
}
return gv;
}
/*
* convert perl HV to job_info_msg_t
*/
int
hv_to_job_info_msg(HV *hv, job_info_msg_t *job_info_msg)
{
SV **svp;
AV *av;
int i, n;
memset(job_info_msg, 0, sizeof(job_info_msg_t));
FETCH_FIELD(hv, job_info_msg, last_update, time_t, TRUE);
svp = hv_fetch(hv, "job_array", 9, FALSE);
if (! (svp && SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVAV)) {
Perl_warn (aTHX_ "job_array is not an arrary reference in HV for job_info_msg_t");
return -1;
}
av = (AV*)SvRV(*svp);
n = av_len(av) + 1;
job_info_msg->record_count = n;
job_info_msg->job_array = xmalloc(n * sizeof(job_info_t));
for(i = 0; i < n; i ++) {
svp = av_fetch(av, i, FALSE);
if (! (svp && SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVHV)) {
Perl_warn (aTHX_ "element %d in job_array is not valid", i);
return -1;
}
if (hv_to_job_info((HV*)SvRV(*svp), &job_info_msg->job_array[i]) < 0) {
Perl_warn(aTHX_ "failed to convert element %d in job_array", i);
return -1;
}
}
return 0;
}
static SV *modperl_hv_request_find(pTHX_ SV *in, char *classname, CV *cv)
{
static char *r_keys[] = { "r", "_r", NULL };
HV *hv = (HV *)SvRV(in);
SV *sv = (SV *)NULL;
int i;
for (i=0; r_keys[i]; i++) {
int klen = i + 1; /* assumes r_keys[] will never change */
SV **svp;
if ((svp = hv_fetch(hv, r_keys[i], klen, FALSE)) && (sv = *svp)) {
if (SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVHV)) {
/* dig deeper */
return modperl_hv_request_find(aTHX_ sv, classname, cv);
}
break;
}
}
if (!sv) {
Perl_croak(aTHX_
"method `%s' invoked by a `%s' object with no `r' key!",
cv ? GvNAME(CvGV(cv)) : "unknown",
(SvRV(in) && SvSTASH(SvRV(in)))
? HvNAME(SvSTASH(SvRV(in)))
: "unknown");
}
return SvROK(sv) ? SvRV(sv) : sv;
}
int
hv_to_user_cond(HV* hv, slurmdb_user_cond_t* user_cond)
{
AV* element_av;
SV** svp;
char* str = NULL;
int i, elements = 0;
user_cond->admin_level = 0;
user_cond->with_assocs = 1;
user_cond->with_coords = 0;
user_cond->with_deleted = 1;
user_cond->with_wckeys = 0;
FETCH_FIELD(hv, user_cond, admin_level, uint16_t, FALSE);
FETCH_FIELD(hv, user_cond, with_assocs, uint16_t, FALSE);
FETCH_FIELD(hv, user_cond, with_coords, uint16_t, FALSE);
FETCH_FIELD(hv, user_cond, with_deleted, uint16_t, FALSE);
FETCH_FIELD(hv, user_cond, with_wckeys, uint16_t, FALSE);
if ( (svp = hv_fetch (hv, "assoc_cond", strlen("assoc_cond"), FALSE)) ) {
if(SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVHV) {
HV* element_hv = (HV*)SvRV(*svp);
hv_to_assoc_cond(element_hv, user_cond->assoc_cond);
} else {
Perl_warn(aTHX_ "assoc_cond val is not an hash value reference");
return -1;
}
}
FETCH_LIST_FIELD(hv, user_cond, def_acct_list);
FETCH_LIST_FIELD(hv, user_cond, def_wckey_list);
return 0;
}
/*
* Return the string value of the id subfield of an ea_catalog_t.
*/
char *
catalog_id_str(ea_catalog_t catalog)
{
static ea_catalog_t cat_val = ~0U;
static HV *cat_hash = NULL;
ea_catalog_t cat;
ea_catalog_t id;
char key[12]; /* Room for dec(2^32) digits. */
SV **svp;
cat = catalog & EXC_CATALOG_MASK;
id = catalog & EXD_DATA_MASK;
/* Fetch the correct id subhash if the catalog has changed. */
if (cat_val != cat) {
snprintf(key, sizeof (key), "%d", cat);
PERL_ASSERT(IdValueHash != NULL);
svp = hv_fetch(IdValueHash, key, strlen(key), FALSE);
if (svp == NULL) {
cat_val = ~0U;
cat_hash = NULL;
} else {
HV *hv;
cat_val = cat;
hv = (HV *)SvRV(*svp);
PERL_ASSERT(hv != NULL);
svp = hv_fetch(hv, "value", 5, FALSE);
PERL_ASSERT(svp != NULL);
cat_hash = (HV *)SvRV(*svp);
PERL_ASSERT(cat_hash != NULL);
}
}
/* If we couldn't find the hash, it is a catalog we don't know about. */
if (cat_hash == NULL) {
return ("UNKNOWN_ID");
}
/* Fetch the value from the selected catalog and return it. */
snprintf(key, sizeof (key), "%d", id);
svp = hv_fetch(cat_hash, key, strlen(key), TRUE);
if (svp == NULL) {
return ("UNKNOWN_ID");
}
return (SvPVX(*svp));
}
int
hv_to_assoc_cond(HV* hv, slurmdb_assoc_cond_t* assoc_cond)
{
AV* element_av;
SV** svp;
char* str = NULL;
int i, elements = 0;
time_t start_time = 0;
time_t end_time = 0;
if ( (svp = hv_fetch (hv, "usage_start", strlen("usage_start"), FALSE)) ) {
start_time = (time_t) (SV2time_t(*svp));
}
if ( (svp = hv_fetch (hv, "usage_end", strlen("usage_end"), FALSE)) ) {
end_time = (time_t) (SV2time_t(*svp));
}
slurmdb_report_set_start_end_time(&start_time, &end_time);
assoc_cond->usage_start = start_time;
assoc_cond->usage_end = end_time;
assoc_cond->with_usage = 1;
assoc_cond->with_deleted = 0;
assoc_cond->with_raw_qos = 0;
assoc_cond->with_sub_accts = 0;
assoc_cond->without_parent_info = 0;
assoc_cond->without_parent_limits = 0;
FETCH_FIELD(hv, assoc_cond, with_usage, uint16_t, FALSE);
FETCH_FIELD(hv, assoc_cond, with_deleted, uint16_t, FALSE);
FETCH_FIELD(hv, assoc_cond, with_raw_qos, uint16_t, FALSE);
FETCH_FIELD(hv, assoc_cond, with_sub_accts, uint16_t, FALSE);
FETCH_FIELD(hv, assoc_cond, without_parent_info, uint16_t, FALSE);
FETCH_FIELD(hv, assoc_cond, without_parent_limits, uint16_t, FALSE);
FETCH_LIST_FIELD(hv, assoc_cond, acct_list);
FETCH_LIST_FIELD(hv, assoc_cond, cluster_list);
FETCH_LIST_FIELD(hv, assoc_cond, def_qos_id_list);
FETCH_LIST_FIELD(hv, assoc_cond, id_list);
FETCH_LIST_FIELD(hv, assoc_cond, parent_acct_list);
FETCH_LIST_FIELD(hv, assoc_cond, partition_list);
FETCH_LIST_FIELD(hv, assoc_cond, qos_list);
FETCH_LIST_FIELD(hv, assoc_cond, user_list);
return 0;
}
SV *p5_hv_fetch(PerlInterpreter *my_perl, HV *hv, STRLEN len, const char *key) {
PERL_SET_CONTEXT(my_perl);
{
SV ** const item = hv_fetch(hv, key, len, 0);
if (item)
return *item;
return NULL;
}
}
SV* THX_MopMcV_get_authority(pTHX_ SV* metaclass) {
HV* stash = (HV*) SvRV(metaclass);
SV** authority = hv_fetch(stash, "AUTHORITY", 9, 0);
if (authority != NULL) {
return GvSV((GV*) *authority);
} else {
return NULL;
}
}
SV* THX_MopMcV_get_version(pTHX_ SV* metaclass) {
HV* stash = (HV*) SvRV(metaclass);
SV** version = hv_fetch(stash, "VERSION", 7, 0);
if (version != NULL) {
return GvSV((GV*) *version);
} else {
return NULL;
}
}
PERL_STATIC_INLINE void
xs_incset(pTHX_ const char *const unixname, const STRLEN unixlen, SV* xsfile)
{
HV *inchv = GvHVn(PL_incgv);
#if 0
SV** const svp = hv_fetch(inchv, unixname, unixlen, 0);
if (!svp)
#endif
(void)hv_store(inchv, unixname, unixlen, SvREFCNT_inc_simple_NN(xsfile), 0);
}
MP_INLINE int modperl_perl_module_loaded(pTHX_ const char *name)
{
SV **svp;
int len;
char *filename = package2filename(name, &len);
svp = hv_fetch(GvHVn(PL_incgv), filename, len, 0);
free(filename);
return (svp && *svp != &PL_sv_undef) ? 1 : 0;
}
GV*
Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
{
char autoload[] = "AUTOLOAD";
STRLEN autolen = sizeof(autoload)-1;
GV* gv;
CV* cv;
HV* varstash;
GV* vargv;
SV* varsv;
if (len == autolen && strnEQ(name, autoload, autolen))
return Nullgv;
if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE)))
return Nullgv;
cv = GvCV(gv);
if (!CvROOT(cv))
return Nullgv;
/*
* Inheriting AUTOLOAD for non-methods works ... for now.
*/
if (ckWARN(WARN_DEPRECATED) && !method &&
(GvCVGEN(gv) || GvSTASH(gv) != stash))
Perl_warner(aTHX_ WARN_DEPRECATED,
"Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
HvNAME(stash), (int)len, name);
/*
* Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
* The subroutine's original name may not be "AUTOLOAD", so we don't
* use that, but for lack of anything better we will use the sub's
* original package to look up $AUTOLOAD.
*/
varstash = GvSTASH(CvGV(cv));
vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE);
ENTER;
#ifdef USE_THREADS
sv_lock((SV *)varstash);
#endif
if (!isGV(vargv))
gv_init(vargv, varstash, autoload, autolen, FALSE);
LEAVE;
varsv = GvSV(vargv);
#ifdef USE_THREADS
sv_lock(varsv);
#endif
sv_setpv(varsv, HvNAME(stash));
sv_catpvn(varsv, "::", 2);
sv_catpvn(varsv, name, len);
SvTAINTED_off(varsv);
return gv;
}
int psgi_response(struct wsgi_request *wsgi_req, AV *response) {
SV **status_code, **hitem ;
AV *headers, *body =NULL;
STRLEN hlen, hlen2;
int i;
char *chitem, *chitem2;
SV **harakiri;
if (wsgi_req->async_force_again) {
wsgi_req->async_force_again = 0;
wsgi_req->switches++;
SV *chunk = uwsgi_perl_obj_call(wsgi_req->async_placeholder, "getline");
if (!chunk) {
uwsgi_500(wsgi_req);
return UWSGI_OK;
}
if (wsgi_req->async_force_again) {
SvREFCNT_dec(chunk);
return UWSGI_AGAIN;
}
chitem = SvPV( chunk, hlen);
if (hlen <= 0) {
SvREFCNT_dec(chunk);
SV *closed = uwsgi_perl_obj_call(wsgi_req->async_placeholder, "close");
if (closed) {
SvREFCNT_dec(closed);
}
// check for psgix.harakiri
harakiri = hv_fetch((HV*)SvRV( (SV*)wsgi_req->async_environ), "psgix.harakiri.commit", 21, 0);
if (harakiri) {
if (SvTRUE(*harakiri)) wsgi_req->async_plagued = 1;
}
SvREFCNT_dec(wsgi_req->async_result);
return UWSGI_OK;
}
uwsgi_response_write_body_do(wsgi_req, chitem, hlen);
uwsgi_pl_check_write_errors {
SvREFCNT_dec(chunk);
return UWSGI_OK;
}
SvREFCNT_dec(chunk);
wsgi_req->async_force_again = 1;
return UWSGI_AGAIN;
}
void VAstEnt::replaceInsert(VAstEnt* newentp, const string& name) {
if (debug()) cout<<"VAstEnt::replaceInsert under="<<this<<" "<<newentp->ascii(name)<<"\"\n";
HV* hvp = subhash(); assert(hvp);
// $svpp = $table{$name}
SV** svpp = hv_fetch(hvp, name.c_str(), name.length(), 1/*create*/);
if (svpp) {} // unused
// $avp = $newentp (premade avp)
hv_store(hvp, name.c_str(), name.length(), newRV((SV*)newentp), 0);
}
static void
print_var(char *var_name, char *var)
{
HV *h_var;
h_var = get_hv(var_name, 0);
if(!h_var) error_tmpl("Vars hash not exist");
SV **sr_var = hv_fetch(h_var, var, (int)strlen(var), 0);
if(!sr_var){ error_tmpl("Var not exist");};
if(SvTYPE(*sr_var) == SVt_IV || SvTYPE(*sr_var) == SVt_PVIV){ printf( "%li", SvIV(*sr_var)); }
else if(SvTYPE(*sr_var) == SVt_NV || SvTYPE(*sr_var) == SVt_PVNV){ printf("%f", SvNV(*sr_var)); }
else if(SvTYPE(*sr_var) == SVt_PV){ printf("%s", SvPV_nolen(*sr_var)); }
else { error_tmpl("Incompatible type of var"); }
}
VAstEnt* VAstEnt::findSym (const string& name) {
HV* hvp = subhash(); assert(hvp);
// $svpp = $table{$name}
SV** svpp = hv_fetch(hvp, name.c_str(), name.length(), 0/*no-change*/);
if (!svpp) return NULL;
SV* svp = *svpp;
if (!svp || !SvROK(svp) || SvTYPE(SvRV(svp)) != SVt_PVAV) return NULL;
// $sub_avp = @{$table{$name}}
AV* sub_avp = (AV*)(SvRV(svp));
VAstEnt* entp = avToSymEnt(sub_avp);
if (debug()) cout<<"VAstEnt::find found under="<<this<<" "<<entp->ascii(name)<<"\n";
return entp;
}
lucy_Obj*
lucy_Doc_extract(lucy_Doc *self, lucy_CharBuf *field,
lucy_ViewCharBuf *target) {
lucy_Obj *retval = NULL;
SV **sv_ptr = hv_fetch((HV*)self->fields, (char*)Lucy_CB_Get_Ptr8(field),
Lucy_CB_Get_Size(field), 0);
if (sv_ptr && XSBind_sv_defined(*sv_ptr)) {
SV *const sv = *sv_ptr;
if (sv_isobject(sv) && sv_derived_from(sv, "Clownfish::Obj")) {
IV tmp = SvIV(SvRV(sv));
retval = INT2PTR(lucy_Obj*, tmp);
}