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;
}
static SV*
check_handler(pTHX_ SV* h)
{
if (SvROK(h)) {
SV* myref = SvRV(h);
if (SvTYPE(myref) == SVt_PVCV)
return newSVsv(h);
if (SvTYPE(myref) == SVt_PVAV)
return SvREFCNT_inc(myref);
croak("Only code or array references allowed as handler");
}
return SvOK(h) ? newSVsv(h) : 0;
}
std::vector<T> toMsgVec(SV* sv)
{
std::vector<T> return_vec;
if (!SvROK(sv) || SvTYPE(SvRV(sv)) != SVt_PVAV)
Perl_croak(aTHX_ "Expected an array ref of messages");
AV* msg_av = (AV*) SvRV(sv);
int length = AvFILL(msg_av) + 1;
for (int i = 0; i < length; i++) {
SV* el = *(av_fetch(msg_av, i, 0));
return_vec.push_back(toMsg<T>(el));
}
return return_vec;
}
USER_OBJECT_
RS_PerlLength(USER_OBJECT_ obj)
{
SV *sv;
int n;
USER_OBJECT_ ans;
dTHX;
sv = RS_PerlGetSV(obj);
if(!sv) {
PROBLEM "Can't get Perl object from S object"
ERROR;
}
/*
Check for
a) objects,
b) references
here.
*/
#if 0
if(sv_isobject(sv)) {
/*XXX What are we warning here. Is it debugging? */
PROBLEM "Calling length on a Perl object"
WARN;
}
#endif
if(SvROK(sv)) {
sv = SvRV(sv);
}
switch(SvTYPE(sv)) {
case SVt_PVHV:
n = hv_iterinit((HV*) sv);
break;
case SVt_PVAV:
n = av_len((AV*) sv) + 1;
break;
default:
n = 0;
break;
}
ans = NEW_INTEGER(1);
INTEGER_DATA(ans)[0] = n;
return(ans);
}
/*
* convert perl HV to partition_info_t
*/
int
hv_to_partition_info(HV *hv, partition_info_t *part_info)
{
SV **svp;
AV *av;
int i, n;
memset(part_info, 0, sizeof(partition_info_t));
FETCH_FIELD(hv, part_info, allow_alloc_nodes, charp, FALSE);
FETCH_FIELD(hv, part_info, allow_accounts, charp, FALSE);
FETCH_FIELD(hv, part_info, allow_groups, charp, FALSE);
FETCH_FIELD(hv, part_info, allow_qos, charp, FALSE);
FETCH_FIELD(hv, part_info, alternate, charp, FALSE);
FETCH_FIELD(hv, part_info, cr_type, uint16_t, FALSE);
FETCH_FIELD(hv, part_info, def_mem_per_cpu, uint32_t, FALSE);
FETCH_FIELD(hv, part_info, default_time, uint32_t, TRUE);
FETCH_FIELD(hv, part_info, deny_accounts, charp, FALSE);
FETCH_FIELD(hv, part_info, deny_qos, charp, FALSE);
FETCH_FIELD(hv, part_info, flags, uint16_t, TRUE);
FETCH_FIELD(hv, part_info, grace_time, uint32_t, FALSE);
FETCH_FIELD(hv, part_info, max_cpus_per_node, uint32_t, FALSE);
FETCH_FIELD(hv, part_info, max_mem_per_cpu, uint32_t, FALSE);
FETCH_FIELD(hv, part_info, max_nodes, uint32_t, TRUE);
FETCH_FIELD(hv, part_info, max_share, uint16_t, TRUE);
FETCH_FIELD(hv, part_info, max_time, uint32_t, TRUE);
FETCH_FIELD(hv, part_info, min_nodes, uint32_t, TRUE);
FETCH_FIELD(hv, part_info, name, charp, 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 */
part_info->node_inx = xmalloc(n * sizeof(int));
for (i = 0 ; i < n-1; i += 2) {
part_info->node_inx[i] = (int)SvIV(*(av_fetch(av, i, FALSE)));
part_info->node_inx[i+1] = (int)SvIV(*(av_fetch(av, i+1 ,FALSE)));
}
part_info->node_inx[n-1] = -1;
} else {
/* nothing to do */
}
FETCH_FIELD(hv, part_info, nodes, charp, FALSE);
FETCH_FIELD(hv, part_info, preempt_mode, uint16_t, TRUE);
FETCH_FIELD(hv, part_info, priority, uint16_t, TRUE);
FETCH_FIELD(hv, part_info, qos_char, charp, TRUE);
FETCH_FIELD(hv, part_info, state_up, uint16_t, TRUE);
FETCH_FIELD(hv, part_info, total_cpus, uint32_t, TRUE);
FETCH_FIELD(hv, part_info, total_nodes, uint32_t, TRUE);
return 0;
}
request_rec *modperl_xs_sv2request_rec(pTHX_ SV *in, char *classname, CV *cv)
{
SV *sv = (SV *)NULL;
MAGIC *mg;
if (SvROK(in)) {
SV *rv = (SV*)SvRV(in);
switch (SvTYPE(rv)) {
case SVt_PVMG:
sv = rv;
break;
case SVt_PVHV:
sv = modperl_hv_request_find(aTHX_ in, classname, cv);
break;
default:
Perl_croak(aTHX_ "panic: unsupported request_rec type %d",
(int)SvTYPE(rv));
}
}
/* might be Apache2::ServerRec::warn method */
if (!sv && !(classname && SvPOK(in) && !strEQ(classname, SvPVX(in)))) {
request_rec *r = NULL;
(void)modperl_tls_get_request_rec(&r);
if (!r) {
Perl_croak(aTHX_
"Apache2->%s called without setting Apache2->request!",
cv ? GvNAME(CvGV(cv)) : "unknown");
}
return r;
}
/* there could be pool magic attached to custom $r object, so make
* sure that mg->mg_ptr is set */
if ((mg = mg_find(sv, PERL_MAGIC_ext)) && mg->mg_ptr) {
return (request_rec *)mg->mg_ptr;
}
else {
if (classname && !sv_derived_from(in, classname)) {
/* XXX: find something faster than sv_derived_from */
return NULL;
}
return INT2PTR(request_rec *, SvIV(sv));
}
return NULL;
}
static CORBA_boolean
put_union (GIOPSendBuffer *buf, CORBA_TypeCode tc, SV *sv)
{
SV **discriminator;
SV **value;
AV *av;
CORBA_long arm;
if (sv == &PL_sv_undef) {
if (PL_dowarn & G_WARN_ON)
warn ("Uninitialized union");
if (!porbit_put_sv (buf, tc->discriminator, &PL_sv_undef))
return CORBA_FALSE;
arm = porbit_union_find_arm (tc, &PL_sv_undef);
if (arm < 0) {
warn("union discriminator branch does not match any arm, and no default arm");
return CORBA_FALSE;
}
return porbit_put_sv (buf, tc->subtypes[arm], &PL_sv_undef);
}
if (!SvROK(sv) ||
(SvTYPE(SvRV(sv)) != SVt_PVAV)) {
warn("Union must be array reference");
return CORBA_FALSE;
}
av = (AV *)SvRV(sv);
discriminator = av_fetch(av, 0, 0);
if (!discriminator && (PL_dowarn & G_WARN_ON))
warn ("Uninitialized union discriminator");
if (!porbit_put_sv (buf, tc->discriminator,
discriminator ? *discriminator : &PL_sv_undef))
return CORBA_FALSE;
arm = porbit_union_find_arm (tc,
discriminator ? *discriminator : &PL_sv_undef);
if (arm < 0) {
warn("union discriminator branch does not match any arm, and no default arm");
return CORBA_FALSE;
}
value = av_fetch(av, 1, 0);
return porbit_put_sv (buf, tc->subtypes[arm],
value ? *value : &PL_sv_undef);
}
USER_OBJECT_
RS_PerlNames(USER_OBJECT_ obj)
{
HV* hv;
SV *el;
int n, i;
USER_OBJECT_ names;
char *key;
I32 len;
dTHX;
if(IS_CHARACTER(obj)) {
hv = get_hv(CHAR_DEREF(STRING_ELT(obj,0)), FALSE);
} else
hv = (HV *) RS_PerlGetSV(obj);
if(hv == NULL) {
PROBLEM "identifier does not refer to a Perl hashtable object"
ERROR;
}
if(SvTYPE(hv) != SVt_PVHV) {
if(SvROK(hv) && SvTYPE(SvRV(hv)) == SVt_PVHV) {
hv = (HV *) SvRV(hv);
} else {
PROBLEM "identifier is not a Perl hashtable object, but some other type %s", getPerlType((SV*)hv)
ERROR;
}
}
n = hv_iterinit(hv);
if(n == 0)
return(NULL_USER_OBJECT);
PROTECT(names = NEW_CHARACTER(n));
i = 0;
while(i < n) {
el = hv_iternextsv(hv, &key, &len);
if(key == NULL)
break;
SET_STRING_ELT(names, i, COPY_TO_USER_STRING(key));
i++;
}
UNPROTECT(1);
return(names);
}
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;
}
static JSBool
perlsub_construct(
JSContext *cx,
DEFJSFSARGS_
) {
dTHX;
DECJSFSARGS;
JSObject *func = JSVAL_TO_OBJECT(JS_ARGV_CALLEE(argv));
SV *callee = (SV *)JS_GetPrivate(cx, func);
SV *caller = NULL;
#if JS_VERSION < 185
JSObject *This = JSVAL_TO_OBJECT(argv[-1]);
#else
JSObject *This = JS_NewObjectForConstructor(cx, vp);
#endif
JSObject *proto = JS_GetPrototype(cx, This);
PJS_DEBUG1("Want construct, This is a %s", PJS_GET_CLASS(cx, This)->name);
if(PJS_GET_CLASS(cx, proto) == &perlpackage_class ||
( JS_LookupProperty(cx, func, "prototype", &argv[-1])
&& JSVAL_IS_OBJECT(argv[-1]) && !JSVAL_IS_NULL(argv[-1])
&& (proto = JS_GetPrototype(cx, JSVAL_TO_OBJECT(argv[-1])))
&& strEQ(PJS_GET_CLASS(cx, proto)->name, PJS_PACKAGE_CLASS_NAME))
) {
SV *rsv = NULL;
char *pkgname = PJS_GetPackageName(aTHX_ cx, proto);
#if JS_VERSION >= 185
JSAutoByteString bytes;
bytes.initBytes(pkgname);
#endif
caller = newSVpv(pkgname, 0);
argv[-1] = OBJECT_TO_JSVAL(This);
if(!PJS_Call_sv_with_jsvals_rsv(aTHX_ cx, obj, callee, caller,
argc, argv, &rsv, G_SCALAR))
return JS_FALSE;
if(SvROK(rsv) && sv_derived_from(rsv, pkgname)) {
JSObject *newobj = PJS_NewPerlObject(aTHX_ cx, JS_GetParent(cx, func), rsv);
*rval = OBJECT_TO_JSVAL(newobj);
return JS_TRUE;
}
JS_ReportError(cx, "%s's constructor don't return an object",
SvPV_nolen(caller));
}
else JS_ReportError(cx, "Can't use as a constructor"); // Yet! ;-)
return JS_FALSE;
}
/*
* convert perl HV to node_info_msg_t
*/
int
hv_to_node_info_msg(HV *hv, node_info_msg_t *node_info_msg)
{
SV **svp;
AV *av;
int i, n;
memset(node_info_msg, 0, sizeof(node_info_msg_t));
FETCH_FIELD(hv, node_info_msg, last_update, time_t, TRUE);
FETCH_FIELD(hv, node_info_msg, node_scaling, uint16_t, TRUE);
svp = hv_fetch(hv, "node_array", 10, FALSE);
if (! (svp && SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVAV)) {
Perl_warn (aTHX_ "node_array is not an array reference in HV for node_info_msg_t");
return -1;
}
av = (AV*)SvRV(*svp);
n = av_len(av) + 1;
node_info_msg->record_count = n;
node_info_msg->node_array = xmalloc(n * sizeof(node_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 node_array is not valid", i);
return -1;
}
if (hv_to_node_info((HV*)SvRV(*svp), &node_info_msg->node_array[i]) < 0) {
Perl_warn (aTHX_ "failed to convert element %d in node_array", i);
return -1;
}
}
return 0;
}
/*
* convert perl HV to job_step_info_response_msg_t
*/
int
hv_to_job_step_info_response_msg(HV *hv,
job_step_info_response_msg_t *step_info_msg)
{
int i, n;
SV **svp;
AV *av;
memset(step_info_msg, 0, sizeof(job_step_info_response_msg_t));
FETCH_FIELD(hv, step_info_msg, last_update, time_t, TRUE);
svp = hv_fetch(hv, "job_steps", 9, FALSE);
if (! (svp && SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVAV)) {
Perl_warn (aTHX_ "job_steps is not an array reference in HV for job_step_info_response_msg_t");
return -1;
}
av = (AV*)SvRV(*svp);
n = av_len(av) + 1;
step_info_msg->job_step_count = n;
step_info_msg->job_steps = xmalloc(n * sizeof(job_step_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_steps is not valid", i);
return -1;
}
if (hv_to_job_step_info((HV*)SvRV(*svp), &step_info_msg->job_steps[i]) < 0) {
Perl_warn (aTHX_ "failed to convert element %d in job_steps", i);
return -1;
}
}
return 0;
}
PWSTR NonEmptyWStrFromScalar(PERL_CALL SV *string, BOOL isRef)
{
if(!string)
return NULL;
if(isRef && !(string = SvROK(string) ? SvRV(string) : NULL))
return NULL;
PSTR str = SvPV(string, PL_na);
if(str && *str)
return S2W(str);
return NULL;
}
SV *ScalarFromArray(PERL_CALL AV *array, int idx, BOOL isRef)
{
if(isRef && array)
{
if(!(array = SvROK(array) ? (AV*)SvRV(array) : NULL))
return NULL;
if(SvTYPE(array) != SVt_PVAV)
return NULL;
}
SV **item = array ? av_fetch(array, idx, 0) : NULL;
return item ? *item : NULL;
}
SV* ScalarFromHash(PERL_CALL HV *hash, PSTR idx, BOOL isRef)
{
if(isRef && hash)
{
if(!(hash = SvROK(hash) ? (HV*)SvRV(hash) : NULL))
return NULL;
if(SvTYPE(hash) != SVt_PVHV)
return NULL;
}
SV **item = hash ? hv_fetch(hash, idx, strlen(idx), 0) : NULL;
return item ? *item : NULL;
}
PyObject*
PerlPyObject_pyo_or_null(SV* sv)
{
MAGIC *mg;
dCTXP;
ASSERT_LOCK_PERL;
if (SvROK(sv) && sv_derived_from(sv, "Python::Object")) {
sv = SvRV(sv);
mg = mg_find(sv, '~');
if (SvIOK(sv) && mg && mg->mg_virtual == &vtbl_free_pyo) {
IV ival = SvIV(sv);
return INT2PTR(PyObject *, ival);
}
void
plcb_convert_storage(PLCB_t *object, AV *docav, plcb_DOCVAL *vspec)
{
SV *pv = SvROK(vspec->value) ? SvRV(vspec->value) : vspec->value;
uint32_t fmt = vspec->spec;
if (object->cv_customenc) {
vspec->need_free = 1;
vspec->value = custom_convert(docav, object->cv_customenc, vspec->value, &vspec->flags, CONVERT_OUT);
} else if (fmt == PLCB_CF_JSON) {
vspec->flags = PLCB_LF_JSON|PLCB_CF_JSON;
vspec->need_free = 1;
vspec->value = serialize_convert(object->cv_jsonenc, vspec->value, CONVERT_OUT);
} else if (fmt == PLCB_CF_STORABLE) {
vspec->flags = PLCB_CF_STORABLE | PLCB_LF_STORABLE;
vspec->need_free = 1;
vspec->value = serialize_convert(object->cv_serialize, vspec->value, CONVERT_OUT);
} else if (fmt == PLCB_CF_RAW) {
vspec->flags = PLCB_CF_RAW | PLCB_LF_RAW;
vspec->need_free = 0;
if (!SvPOK(pv)) {
die("Raw conversion requires string value!");
}
} else if (vspec->spec == PLCB_CF_UTF8) {
vspec->flags = PLCB_CF_UTF8 | PLCB_LF_UTF8;
vspec->need_free = 0;
sv_utf8_upgrade(pv);
} else {
die("Unrecognized flags used (0x%x) but no custom converted installed!", vspec->spec);
}
if (!vspec->need_free) {
/* Use input as-is */
vspec->value = pv;
}
/* Assume the resultant value is an SV */
if (SvTYPE(vspec->value) == SVt_PV) {
vspec->encoded = SvPVX(vspec->value);
vspec->len = SvCUR(vspec->value);
} else {
vspec->encoded = SvPV(vspec->value, vspec->len);
}
}
void handle_string_list(pTHX_ const char *option, LinkedList list, SV *sv, SV **rval)
{
const char *str;
if (sv)
{
LL_flush(list, (LLDestroyFunc) string_delete);
if (SvROK(sv))
{
sv = SvRV(sv);
if (SvTYPE(sv) == SVt_PVAV)
{
AV *av = (AV *) sv;
SV **pSV;
int i, max = av_len(av);
for (i = 0; i <= max; i++)
{
if ((pSV = av_fetch(av, i, 0)) != NULL)
{
SvGETMAGIC(*pSV);
LL_push(list, string_new_fromSV(aTHX_ *pSV));
}
else
fatal("NULL returned by av_fetch() in handle_string_list()");
}
}
else
Perl_croak(aTHX_ "%s wants an array reference", option);
}
else
Perl_croak(aTHX_ "%s wants a reference to an array of strings", option);
}
if (rval)
{
ListIterator li;
AV *av = newAV();
LL_foreach(str, li, list)
av_push(av, newSVpv(CONST_CHAR(str), 0));
*rval = newRV_noinc((SV *) av);
}
}
USER_OBJECT_
RS_PerlHashElement(USER_OBJECT_ rs_table, USER_OBJECT_ elements, USER_OBJECT_ convert)
{
int i, n;
HV *table;
USER_OBJECT_ ans = NULL_USER_OBJECT;
SV *obj;
unsigned int depth;
dTHX;
obj = getForeignPerlReference(rs_table);
if(obj == NULL) {
PROBLEM "No such table reference %s", "?"
ERROR;
}
if(SvROK(obj))
obj = SvRV(obj);
if(SvTYPE(obj) != SVt_PVHV) {
PROBLEM "Perl object (%s) is not a hash, but of type %d", "?", (int) SvTYPE(obj)
ERROR;
}
table = (HV*) obj;
if(TYPEOF(convert) == LGLSXP || TYPEOF(convert) == INTSXP)
depth = (TYPEOF(convert) == LGLSXP ? LOGICAL(convert)[0] : INTEGER(convert)[0]);
n = GET_LENGTH(elements);
if(n > 0) {
SV **el;
const char *key;
PROTECT(ans = NEW_LIST(n));
/* */
for(i = 0; i < n ; i++) {
key = CHAR_DEREF(STRING_ELT(elements,i));
el = hv_fetch(table, key, strlen(key), 0);
if(el && *el)
SET_VECTOR_ELT(ans, i, fromPerl(*el, depth));
}
SET_NAMES(ans, elements);
UNPROTECT(1);
}
return(ans);
}
USER_OBJECT_
fromPerlHV_SV(SV *sv)
{
if(SvROK(sv)) {
sv = SvRV(sv);
}
if(SvTYPE(sv) != SVt_PVHV) {
PROBLEM "fromPerlHV_SV called with Perl object that is not a Hashtable."
ERROR;
}
if(!sv || SvTYPE(sv) == SVt_NULL)
return(NULL_USER_OBJECT);
return(fromPerlHV((HV *) sv, 1000));
}
static void
ldap_pack_modop(SV *dest, SV *change) {
if (change && SvOK(change)) {
HV *hv;
STRLEN offset1, offset2;
if (!SvROK(change) || !(hv = (HV*)SvRV(change)) || (SvTYPE(hv) != SVt_PVHV))
croak("bad change description");
offset1 = start_sequence(dest);
pack_enum(dest, SvIV(hv_fetchs_def_undef(hv, "operation")));
offset2 = start_sequence(dest);
pack_string_utf8(dest, hv_fetchs_def_undef(hv, "attribute"));
pack_set_of_string_utf8(dest, hv_fetchs_def_undef(hv, "values"));
end_sequence(dest, offset2);
end_sequence(dest, offset1);
}
}
/*
* convert perl HV to job_step_info_t
*/
int
hv_to_job_step_info(HV *hv, job_step_info_t *step_info)
{
SV **svp;
AV *av;
int i, n;
FETCH_FIELD(hv, step_info, array_job_id, uint32_t, TRUE);
FETCH_FIELD(hv, step_info, array_task_id, uint32_t, TRUE);
FETCH_FIELD(hv, step_info, ckpt_dir, charp, FALSE);
FETCH_FIELD(hv, step_info, ckpt_interval, uint16_t, TRUE);
FETCH_FIELD(hv, step_info, gres, charp, FALSE);
FETCH_FIELD(hv, step_info, job_id, uint16_t, TRUE);
FETCH_FIELD(hv, step_info, name, charp, FALSE);
FETCH_FIELD(hv, step_info, network, charp, FALSE);
FETCH_FIELD(hv, step_info, nodes, charp, FALSE);
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 */
step_info->node_inx = xmalloc(n * sizeof(int));
for (i = 0 ; i < n-1; i += 2) {
step_info->node_inx[i] = (int)SvIV(*(av_fetch(av, i ,FALSE)));
step_info->node_inx[i+1] = (int)SvIV(*(av_fetch(av, i+1 ,FALSE)));
}
step_info->node_inx[n-1] = -1;
} else {
/* nothing to do */
}
FETCH_FIELD(hv, step_info, num_cpus, uint32_t, TRUE);
FETCH_FIELD(hv, step_info, num_tasks, uint32_t, TRUE);
FETCH_FIELD(hv, step_info, partition, charp, FALSE);
FETCH_FIELD(hv, step_info, profile, uint32_t, TRUE);
FETCH_FIELD(hv, step_info, resv_ports, charp, FALSE);
FETCH_FIELD(hv, step_info, run_time, time_t, TRUE);
FETCH_FIELD(hv, step_info, start_time, time_t, TRUE);
FETCH_FIELD(hv, step_info, step_id, uint32_t, TRUE);
FETCH_FIELD(hv, step_info, time_limit, uint32_t, TRUE);
FETCH_FIELD(hv, step_info, user_id, uint32_t, TRUE);
FETCH_FIELD(hv, step_info, state, uint16_t, TRUE);
return 0;
}
PVOID PtrFromHash(PERL_CALL HV *hash, PSTR idx, unsigned *len, BOOL isRef)
{
if(isRef && hash)
{
if(!(hash = SvROK(hash) ? (HV*)SvRV(hash) : NULL))
return NULL;
if(SvTYPE(hash) != SVt_PVHV)
return NULL;
}
SV **item = hash ? hv_fetch(hash, idx, strlen(idx), 0) : NULL;
if(item && *item)
return len ? SvPV(*item, *len) : SvPV(*item, PL_na);
else
return NULL;
}
MP_INLINE server_rec *modperl_sv2server_rec(pTHX_ SV *sv)
{
if (SvOBJECT(sv) || (SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVMG))) {
return INT2PTR(server_rec *, SvObjIV(sv));
}
/* next see if we have Apache2->request available */
{
request_rec *r = NULL;
(void)modperl_tls_get_request_rec(&r);
if (r) {
return r->server;
}
}
/* modperl_global_get_server_rec is not thread safe w/o locking */
return modperl_global_get_server_rec();
}
PVOID PtrFromArray(PERL_CALL AV *array, int idx, unsigned *len, BOOL isRef)
{
if(isRef && array)
{
if(!(array = SvROK(array) ? (AV*)SvRV(array) : NULL))
return NULL;
if(SvTYPE(array) != SVt_PVAV)
return NULL;
}
SV **item = array ? av_fetch(array, idx, 0) : NULL;
if(item && *item)
return len ? SvPV(*item, *len) : SvPV(*item, PL_na);
else
return NULL;
}
int IntFromArray(PERL_CALL AV *array, int idx, BOOL isRef)
{
if(isRef && array)
{
if(!(array = SvROK(array) ? (AV*)SvRV(array) : NULL))
return NULL;
if(SvTYPE(array) != SVt_PVAV)
return NULL;
}
SV **item = array ? av_fetch(array, idx, 0) : NULL;
if(item && *item)
return SvIV(*item);
else
return NULL;
}
PWSTR WStrFromHash(PERL_CALL HV *hash, PSTR idx, BOOL isRef)
{
if(isRef && hash)
{
if(!(hash = SvROK(hash) ? (HV*)SvRV(hash) : NULL))
return NULL;
if(SvTYPE(hash) != SVt_PVHV)
return NULL;
}
SV **item = hash ? hv_fetch(hash, idx, strlen(idx), 0) : NULL;
if(item && *item)
return S2W(SvPV(*item, PL_na));
else
return NULL;
}
int SLenFromHash(PERL_CALL HV *hash, PSTR idx, BOOL isRef)
{
if(isRef && hash)
{
if(!(hash = SvROK(hash) ? (HV*)SvRV(hash) : NULL))
return NULL;
if(SvTYPE(hash) != SVt_PVHV)
return NULL;
}
SV **item = hash ? hv_fetch(hash, idx, strlen(idx), 0) : NULL;
if(item && *item)
return SvLEN(*item) - 1;
else
return NULL;
}
void
perl_mongo_sv_to_bson (bson_t * bson, SV *sv, HV *opts) {
if (!SvROK (sv)) {
croak ("not a reference");
}
if ( ! sv_isobject(sv) ) {
switch ( SvTYPE(SvRV(sv)) ) {
case SVt_PVHV:
hvdoc_to_bson (bson, sv, opts, EMPTY_STACK);
break;
case SVt_PVAV:
avdoc_to_bson(bson, sv, opts, EMPTY_STACK);
break;
default:
sv_dump(sv);
croak ("type unhandled");
}
}
else {
SV *obj;
char *class;
obj = SvRV(sv);
class = HvNAME(SvSTASH(obj));
if ( strEQ(class, "Tie::IxHash") ) {
ixhashdoc_to_bson(bson, sv, opts, EMPTY_STACK);
}
else if ( strEQ(class, "MongoDB::BSON::_EncodedDoc") ) {
STRLEN str_len;
SV **svp;
SV *encoded;
const char *bson_str;
bson_t *child;
encoded = _hv_fetchs_sv((HV *)obj, "bson");
bson_str = SvPV(encoded, str_len);
child = bson_new_from_data((uint8_t*) bson_str, str_len);
bson_concat(bson, child);
bson_destroy(child);
}
else if (SvTYPE(obj) == SVt_PVHV) {
static void
passport_finalize(
JSContext *cx,
JSObject *passport
) {
dTHX;
SV *box = (SV *)JS_GetPrivate(cx, passport);
if(box && SvOK(box) && SvROK(box)) {
AV *avbox = (AV *)SvRV(box);
#ifdef PJSDEBUG
JSObject *parent = JS_GetParent(cx, passport);
#endif
PJS_DEBUG3("About to free a %s rc:%d,%d\n", JS_GET_CLASS(cx, parent)->name,
SvREFCNT(box), SvREFCNT(avbox));
if(PL_dirty) return;
av_store(avbox, 0, &PL_sv_undef);
sv_free(box);
} else croak("PJS_Assert: Bad finalize for passport\n"); /* Assertion */
}
