IV p5_unwrap_p6_object(PerlInterpreter *my_perl, SV *obj) {
PERL_SET_CONTEXT(my_perl);
{
SV * const obj_deref = SvRV(obj);
MAGIC * const mg = mg_find(obj_deref, '~');
return ((_perl6_magic*)(mg->mg_ptr))->index;
}
}
void p5_rebless_object(PerlInterpreter *my_perl, SV *obj) {
SV * const inst = SvRV(obj);
SV * const inst_ptr = newRV_noinc(inst);
HV *stash = gv_stashpv("Perl6::Object", 0);
if (stash == NULL)
croak("Perl6::Object not found!? Forgot to call init_callbacks?");
(void)sv_bless(inst_ptr, stash);
}
void
Surface::from_SV_check(SV* surface_sv)
{
if (!sv_isa(surface_sv, perl_class_name(this)) && !sv_isa(surface_sv, perl_class_name_ref(this)))
CONFESS("Not a valid %s object", perl_class_name(this));
// a XS Surface was supplied
*this = *(Surface *)SvIV((SV*)SvRV( surface_sv ));
}
/* Convenience function for checking whether pv is a reference, and dereference it if necessary */
static inline SV *
derefPV (SV *pv)
{
if (SvTYPE (pv) == SVt_RV) {
return SvRV (pv);
} else
return pv;
}
void parseApp(const char *func, const char *var, SV *arg, Autoref<App> &res)
{
if ( sv_isobject(arg) && (SvTYPE(SvRV(arg)) == SVt_PVMG) ) {
WrapApp *wa = (WrapApp *)SvIV((SV*)SvRV( arg ));
if (wa == 0 || wa->badMagic()) {
throw Exception::f("%s: %s has an incorrect magic for App", func, var);
}
res = wa->get();
} else if (SvPOK(arg)) {
STRLEN len;
char *s = SvPV(arg, len);
string appname(s, len);
res = App::find(appname); // will throw if can't find
} else {
throw Exception::f("%s: %s is not an App reference nor a string", func, var);
}
}
void HRXSATTR_ithread_predup(SV *self, SV *table, HV *ptr_map)
{
hrattr_simple *attr = attr_from_sv(SvRV(self));
/*Make sure our attribute hash is visible to perl space*/
SV *attrhash_ref;
RV_Newtmp(attrhash_ref, (SV*)attr->attrhash);
hr_dup_store_rv(ptr_map, attrhash_ref);
RV_Freetmp(attrhash_ref);
char *ktmp;
I32 tmplen;
SV *vtmp;
SV *rlookup;
get_hashes(REF2TABLE(table),
HR_HKEY_LOOKUP_REVERSE, &rlookup,
HR_HKEY_LOOKUP_NULL);
hv_iterinit(attr->attrhash);
while( (vtmp = hv_iternextsv(attr->attrhash, &ktmp, &tmplen))) {
HR_Dup_Vinfo *vi = hr_dup_get_vinfo(ptr_map, SvRV(vtmp), 1);
if(!vi->vhash) {
SV *vaddr = newSVuv((UV)SvRV(vtmp));
SV *vhash = get_vhash_from_rlookup(rlookup, vaddr, 0);
vi->vhash = vhash;
SvREFCNT_dec(vaddr);
}
}
if(attr->encap) {
hrattr_encap *aencap = attr_encap_cast(attr);
hr_dup_store_rv(ptr_map, aencap->obj_rv);
char *ai = (char*)hr_dup_store_kinfo(
ptr_map, HR_DUPKEY_AENCAP, aencap->obj_paddr, 1);
if(SvWEAKREF(aencap->obj_rv)) {
*ai = HRK_DUP_WEAK_ENCAP;
} else {
*ai = 0;
}
}
}
void THX_MopMmV_assign_to_stash(pTHX_ SV* metamethod, GV* gv, HV* stash) {
CV* cv = (CV*) SvRV(metamethod);
GvCVGEN(gv) = 0;
GvCV_set(gv, cv);
CvGV_set(cv, gv);
CvSTASH_set(cv, stash);
}
/*
* 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;
}
SV* PJS_GetPassport(
pTHX_
JSContext *cx,
JSObject *thing
) {
jsval temp;
SV *box;
SV *tref;
JSObject *inboxed;
if(!JS_LookupPropertyWithFlags(cx, thing, PJS_PASSPORT_PROP, 0, &temp)
|| JSVAL_IS_VOID(temp) || JSVAL_IS_NULL(temp))
croak("Can't get passport");
box = (SV *)JS_GetPrivate(cx, JSVAL_TO_OBJECT(temp));
tref = *av_fetch((AV *)SvRV(box), 0, 0);
inboxed = INT2PTR(JSObject *, SvIV((SV *)SvRV(tref)));
assert(inboxed == thing);
return box;
}
/* T_PTRREF */
void *
tm_input_ptrref(pTHX_ SV * const arg)
{
if (SvROK(arg)) {
IV tmp = SvIV((SV*)SvRV(arg));
return INT2PTR(void *, tmp);
}
else
return NULL;
SV* THX_MopMcV_construct_instance(pTHX_ SV* metaclass, SV* repr) {
// TODO:
// This should handle all the attributes
// and constructing things properly, which
// should also include running all BUILD
// methods.
// - SL
return sv_bless(repr, (HV*) SvRV(metaclass));
}
void
Point::from_SV(SV* point_sv)
{
AV* point_av = (AV*)SvRV(point_sv);
// get a double from Perl and round it, otherwise
// it would get truncated
this->x = lrint(SvNV(*av_fetch(point_av, 0, 0)));
this->y = lrint(SvNV(*av_fetch(point_av, 1, 0)));
}
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;
}
}
void PJS_finalize(JSContext *cx, JSObject *obj) {
void *ptr = JS_GetPrivate(cx, obj);
if(ptr != NULL) {
if (SvTYPE((SV *) ptr) == SVt_RV) {
SvREFCNT_dec(SvRV((SV *) ptr));
}
}
}
int p5_is_wrapped_p6_object(PerlInterpreter *my_perl, SV *obj) {
PERL_SET_CONTEXT(my_perl);
{
SV * const obj_deref = SvRV(obj);
/* check for magic! */
MAGIC * const mg = mg_find(obj_deref, '~');
return (mg && mg->mg_ptr && ((_perl6_magic*)(mg->mg_ptr))->key == PERL6_MAGIC_KEY);
}
}
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) {
bool THX_MopMcV_has_attribute(pTHX_ SV* metaclass, SV* name) {
SV* attributes = MopOV_get_at_slot(metaclass, CLASS_ATTRIBUTE_SLOT);
if (attributes == NULL) {
attributes = newRV_noinc((SV*) newHV());
MopOV_set_at_slot(metaclass, CLASS_ATTRIBUTE_SLOT, attributes);
// NOTE:
// I know I am not going to
// have the value since I
// only just now created the
// HV to store it.
return FALSE;
}
if (SvTYPE(attributes) != SVt_RV && SvTYPE(SvRV(attributes)) != SVt_PVHV) {
croak("attributes is not a HASH ref, this is wrong");
}
return hv_exists_ent((HV*) SvRV(attributes), name, 0);
}
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;
}
}
void HRA_unlink_a(SV *self, SV* attr, char *t)
{
HR_DEBUG("UNLINK_ATTR");
SV *aobj = attr_get(self, attr, t, 0);
if(!aobj) {
return;
}
attr_destroy_trigger(SvRV(aobj), NULL, NULL);
HR_DEBUG("UNLINK_ATTR DONE");
}
GV *p5_look_up_method(PerlInterpreter *my_perl, SV *obj, char *name) {
PERL_SET_CONTEXT(my_perl);
{
HV * const pkg = SvSTASH((SV*)SvRV(obj));
GV * const gv = Perl_gv_fetchmethod_autoload(aTHX_ pkg, name, TRUE);
if (gv && isGV(gv))
return gv;
return NULL;
}
}
void return_retval(const I32 ax, SV **sp, SV *retval) {
if (GIMME_V == G_VOID) {
XSRETURN_EMPTY;
}
if (GIMME_V == G_ARRAY) {
AV* const av = (AV*)SvRV(retval);
I32 const len = av_len(av) + 1;
I32 i;
for (i = 0; i < len; i++) {
XPUSHs(sv_2mortal(av_shift(av)));
}
XSRETURN(len);
}
else {
AV* const av = (AV*)SvRV(retval);
XPUSHs(sv_2mortal(av_shift(av)));
XSRETURN(1);
}
}
int is_scalar_ref (SV* arg) { /* Utility to determine if ref to scalar */
SV* foo;
if (!SvROK(arg))
return 0;
foo = SvRV(arg);
if (SvPOK(foo))
return 1;
else
return 0;
}
PSTR StrFromScalar(PERL_CALL SV *string, BOOL isRef)
{
if(!string)
return NULL;
if(isRef && !(string = SvROK(string) ? SvRV(string) : NULL))
return NULL;
return SvPV(string, PL_na);
}
int SLenFromScalar(PERL_CALL SV *string, BOOL isRef)
{
if(!string)
return NULL;
if(isRef && !(string = SvROK(string) ? SvRV(string) : NULL))
return NULL;
return SvLEN(string) - 1;
}
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;
}
}
int IntFromScalar(PERL_CALL SV *string, BOOL isRef)
{
if(!string)
return NULL;
if(isRef && !(string = SvROK(string) ? SvRV(string) : NULL))
return NULL;
return SvIV(string);
}
/* T_SVREF */
SV *
tm_input_svref(pTHX_ SV * const arg)
{
SV *var;
SvGETMAGIC(arg);
if ( !SvROK(arg) )
return NULL;
var = SvRV(arg);
return var;
}
inline void Zmqxs_msg_finish_allocate(pTHX_ SV *self, int status, zmq_msg_t *msg){
if(status < 0){
SET_BANG;
Safefree(msg);
if(_ERRNO == ENOMEM)
croak("Insufficient space memory available for message.");
croak("Unknown error initializing message!");
}
xs_object_magic_attach_struct(aTHX_ SvRV(self), msg);
}
IV
PerlIOScalar_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg,
PerlIO_funcs * tab)
{
IV code;
PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
/* If called (normally) via open() then arg is ref to scalar we are
* using, otherwise arg (from binmode presumably) is either NULL
* or the _name_ of the scalar
*/
if (arg) {
if (SvROK(arg)) {
if (SvREADONLY(SvRV(arg)) && mode && *mode != 'r') {
if (ckWARN(WARN_LAYER))
Perl_warner(aTHX_ packWARN(WARN_LAYER), "%s", PL_no_modify);
SETERRNO(EINVAL, SS_IVCHAN);
return -1;
}
s->var = SvREFCNT_inc(SvRV(arg));
SvGETMAGIC(s->var);
if (!SvPOK(s->var) && SvOK(s->var))
(void)SvPV_nomg_const_nolen(s->var);
}
else {
s->var =
SvREFCNT_inc(perl_get_sv
(SvPV_nolen(arg), GV_ADD | GV_ADDMULTI));
}
}
else {
s->var = newSVpvn("", 0);
}
SvUPGRADE(s->var, SVt_PV);
code = PerlIOBase_pushed(aTHX_ f, mode, Nullsv, tab);
if (!SvOK(s->var) || (PerlIOBase(f)->flags) & PERLIO_F_TRUNCATE)
SvCUR_set(s->var, 0);
if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND)
s->posn = SvCUR(s->var);
else
s->posn = 0;
return code;
}
/* from mod_perl 1.x */
apr_pool_t * perl_get_startup_pool (void)
{
SV *sv ;
dTHX ;
sv = perl_get_sv("Apache::__POOL", FALSE);
if(sv) {
IV tmp = SvIV((SV*)SvRV(sv));
return (pool *)tmp;
}
return NULL;
}
