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);
}
int
SennaPerl_Global_bootstrap()
{
HV *stash;
sen_rc rc;
rc = sen_init();
if (rc != sen_success) {
croak("Failed to call sen_init(). sen_init() returned %d", rc);
}
stash = gv_stashpv("Senna::Constants", 1);
newCONSTSUB(stash, "LIBSENNA_VERSION",
newSVpvf("%d.%d.%d",
SENNA_MAJOR_VERSION,
SENNA_MINOR_VERSION,
SENNA_MICRO_VERSION
)
);
newCONSTSUB(stash, "LIBSENNA_MAJOR_VERSION", newSViv(SENNA_MAJOR_VERSION));
newCONSTSUB(stash, "LIBSENNA_MINOR_VERSION", newSViv(SENNA_MINOR_VERSION));
newCONSTSUB(stash, "LIBSENNA_MICRO_VERSION", newSViv(SENNA_MICRO_VERSION));
SennaPerl_Index_bootstrap();
SennaPerl_Encoding_bootstrap();
SennaPerl_RC_bootstrap();
SennaPerl_Records_bootstrap();
SennaPerl_Symbol_bootstrap();
SennaPerl_Ctx_bootstrap();
return 1;
}
/*
* This function populates the various stash pointers used by the ::Exacct
* module. It is called from each of the module BOOT sections to ensure the
* stash pointers are initialised on startup.
*/
void
init_stashes(void)
{
if (Sun_Solaris_Exacct_Catalog_stash == NULL) {
Sun_Solaris_Exacct_Catalog_stash =
gv_stashpv(PKGBASE "::Catalog", TRUE);
Sun_Solaris_Exacct_File_stash =
gv_stashpv(PKGBASE "::File", TRUE);
Sun_Solaris_Exacct_Object_Item_stash =
gv_stashpv(PKGBASE "::Object::Item", TRUE);
Sun_Solaris_Exacct_Object_Group_stash =
gv_stashpv(PKGBASE "::Object::Group", TRUE);
Sun_Solaris_Exacct_Object__Array_stash =
gv_stashpv(PKGBASE "::Object::_Array", TRUE);
}
}
/**
* NI_aggregate(): aggregate two IP address ranges into new object.
* @ipo1: first Net::IP::XS object.
* @ipo2: second Net::IP::XS object.
*/
SV *
NI_aggregate(SV *ipo1, SV *ipo2)
{
int version;
int res;
char buf[90];
HV *stash;
HV *hash;
SV *ref;
switch ((version = NI_hv_get_iv(ipo1, "ipversion", 9))) {
case 4: res = NI_aggregate_ipv4(ipo1, ipo2, buf); break;
case 6: res = NI_aggregate_ipv6(ipo1, ipo2, buf); break;
default: res = 0;
}
if (!res) {
return NULL;
}
hash = newHV();
ref = newRV_noinc((SV*) hash);
stash = gv_stashpv("Net::IP::XS", 1);
sv_bless(ref, stash);
res = NI_set(ref, buf, version);
if (!res) {
return NULL;
}
return ref;
}
static inline void
extract_async_options(PLCBA_t *async, AV *options)
{
#define _assert_get_cv(idxbase, target, diemsg) \
if( (tmpsv = av_fetch(options, PLCBA_CTORIDX_ ## idxbase, 0)) == NULL \
|| SvTYPE(*tmpsv) == SVt_NULL) { \
die("Must have '%s' callback", diemsg); \
} \
SvREFCNT_inc(*tmpsv); \
async->target = *tmpsv;
SV **tmpsv;
_assert_get_cv(CBEVMOD, cv_evmod, "update_event");
_assert_get_cv(CBERR, cv_err, "error");
_assert_get_cv(CBWAITDONE, cv_waitdone, "waitdone");
_assert_get_cv(CBTIMERMOD, cv_timermod, "update_timer");
if( (tmpsv = av_fetch(options, PLCBA_CTORIDX_BLESS_EVENT, 0)) ) {
if(SvTRUE(*tmpsv)) {
async->event_stash = gv_stashpv(PLCBA_EVENT_CLASS, 0);
}
}
#undef _assert_get_cv
}
bool Embperl::SubExists(const char *package, const char *sub) {
HV *stash = gv_stashpv(package, false);
if(!stash)
return(false);
int len = strlen(sub);
return(hv_exists(stash, sub, len));
}
void plcb_ctor_init_common(PLCB_t *object, libcouchbase_t instance,
AV *options)
{
NV timeout_value;
SV **tmpsv;
object->instance = instance;
object->errors = newAV();
if(! (object->ret_stash = gv_stashpv(PLCB_RET_CLASSNAME, 0)) ) {
die("Could not load '%s'", PLCB_RET_CLASSNAME);
}
/*gather instance-related options from the constructor*/
if( (tmpsv = av_fetch(options, PLCB_CTORIDX_TIMEOUT, 0)) &&
(SvIOK(*tmpsv) || SvNOK(*tmpsv))) {
timeout_value = SvNV(*tmpsv);
if(!timeout_value) {
warn("Cannot use 0 for timeout");
} else {
libcouchbase_set_timeout(instance,
timeout_value * (1000*1000));
}
}
if((tmpsv = av_fetch(options, PLCB_CTORIDX_NO_CONNECT, 0)) &&
SvTRUE(*tmpsv)) {
object->my_flags |= PLCBf_NO_CONNECT;
}
/*maybe more stuff here?*/
}
static void
ngx_http_perl_xs_init(pTHX)
{
newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, __FILE__);
nginx_stash = gv_stashpv("nginx", TRUE);
}
bool Embperl::VarExists(const char *package, const char *var) {
HV *stash = gv_stashpv(package, false);
if(!stash)
return(false);
int len = strlen(var);
return(hv_exists(stash, var, len));
}
SV* create_perl_object(void* cpp_obj, const char* perl_class_name, bool must_not_delete) {
HV* underlying_hash;
SV* perl_obj;
HV* perl_obj_stash;
object_link_data* link = new object_link_data;
if (cpp_obj == NULL)
return &PL_sv_undef;
// create the underlying hash and make a ref to it
underlying_hash = newHV();
perl_obj = newRV_noinc((SV*)underlying_hash);
//sv_2mortal(perl_obj);
// get the stash and bless the ref (to the underlying hash) into it
perl_obj_stash = gv_stashpv(perl_class_name, TRUE);
sv_bless(perl_obj, perl_obj_stash);
// fill in the data fields
link->cpp_object = cpp_obj;
link->perl_object = (SV*)underlying_hash;
link->can_delete_cpp_object = must_not_delete ? false : true;
link->perl_class_name = perl_class_name;
// link the data via '~' magic
// (we link to the underlying hash and not to the reference itself)
sv_magic((SV*)underlying_hash, NULL, PERL_MAGIC_ext, (const char*)link, 0); // cheat by storing data instead of a string
// check this object
DUMPME(1,perl_obj);
return perl_obj;
}
static JSBool
PerlArray(
JSContext *cx,
JSObject *obj,
uintN argc,
jsval *argv,
jsval *rval
) {
dTHX;
AV *av = newAV();
SV *ref = newRV_noinc((SV *)av);
uintN arg;
JSBool ok = JS_FALSE;
SV *sv;
/* If the path fails, the object will be finalized */
JS_SetPrivate(cx, obj, (void *)newRV(&PL_sv_undef));
av_extend(av, argc);
for(arg = 0; arg < argc; arg++) {
if(!PJS_ReflectJS2Perl(aTHX_ cx, argv[arg], &sv, 1) ||
!av_store(av, arg, sv)) goto fail;
}
if(SvTRUE(get_sv(NAMESPACE"PerlArray::construct_blessed", 0)))
sv_bless(ref, gv_stashpv(PerlArrayPkg,0));
ok = PJS_CreateJSVis(aTHX_ cx, obj, ref) != NULL;
fail:
sv_free(ref);
return ok;
}
SV * newSVMiscRef(void * object, char * classname, int * newref)
{
HV * previous;
SV * result;
if (!object)
return newSVsv(&PL_sv_undef);
previous = RetrieveMisc(object);
if (previous) {
/*printf("Retriveing object %d as HV %d\n", object, previous);*/
result = newRV((SV*)previous);
if (newref)
*newref = 0;
} else {
HV * h = newHV();
hv_store(h, "_gtk", 4, newSViv((long)object), 0);
result = newRV((SV*)h);
RegisterMisc(h, object);
sv_bless(result, gv_stashpv(classname, FALSE));
SvREFCNT_dec(h);
if (newref)
*newref = 1;
/*printf("Storing object %p (%s) as HV %p (refcount: %d, %d)\n", object, classname, h, SvREFCNT(h), SvREFCNT(result));*/
}
return result;
}
static SV *
new_gdk_bitmap (GdkBitmap * bitmap, gboolean noinc)
{
if (!bitmap)
return &PL_sv_undef;
return sv_bless (gperl_new_object (G_OBJECT (bitmap), noinc),
gv_stashpv ("Gtk2::Gdk::Bitmap", TRUE));
}
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);
}
static void boot_var() {
pe_watcher_vtbl *vt = &pe_var_vtbl;
memcpy(vt, &pe_watcher_base_vtbl, sizeof(pe_watcher_base_vtbl));
vt->dtor = pe_var_dtor;
vt->start = pe_var_start;
vt->stop = pe_var_stop;
pe_register_vtbl(vt, gv_stashpv("Event::var",1), &ioevent_vtbl);
}
static void push_thread(pTHX, mthread* thread) {
{
dSP;
SV* to_push = newRV_noinc(newSVuv(thread->id));
sv_bless(to_push, gv_stashpv("threads::lite::tid", FALSE));
XPUSHs(to_push);
PUTBACK;
}
}
/*
**
** sets a Perl scalar variable
**
*/
void Perl5_SetScalar(pTHX_ char *pname, char *vname, char *vvalue)
{
dTHR;
ENTER;
save_hptr(&PL_curstash);
PL_curstash = gv_stashpv(pname, TRUE);
sv_setpv(perl_get_sv(vname, TRUE), vvalue);
LEAVE;
return;
}
void
SennaPerl_Query_bootstrap()
{
HV *stash;
stash = gv_stashpv("Senna::Constants", 1);
newCONSTSUB(stash, "SEN_SEL_OR", newSViv(sen_sel_or));
newCONSTSUB(stash, "SEN_SEL_AND", newSViv(sen_sel_and));
newCONSTSUB(stash, "SEN_SEL_BUT", newSViv(sen_sel_but));
newCONSTSUB(stash, "SEN_SEL_ADJUST", newSViv(sen_sel_adjust));
}
/**
* NI_ip_add_num(): add integer to object and get new object.
* @ipo: Net::IP::XS object.
* @num: integer to add to object (as a string).
*/
SV *
NI_ip_add_num(SV *ipo, const char *num)
{
int version;
unsigned long num_ulong;
char *endptr;
n128_t num_n128;
char buf[(2 * (MAX_IPV6_STR_LEN - 1)) + 4];
int res;
HV *stash;
HV *hash;
SV *ref;
int size;
version = NI_hv_get_iv(ipo, "ipversion", 9);
if (version == 4) {
endptr = NULL;
num_ulong = strtoul(num, &endptr, 10);
if (STRTOUL_FAILED(num_ulong, num, endptr)) {
return 0;
}
if (num_ulong > 0xFFFFFFFF) {
return 0;
}
res = NI_ip_add_num_ipv4(ipo, num_ulong, buf);
if (!res) {
return 0;
}
} else if (version == 6) {
res = n128_set_str_decimal(&num_n128, num, strlen(num));
if (!res) {
return 0;
}
res = NI_ip_add_num_ipv6(ipo, &num_n128, buf);
if (!res) {
return 0;
}
} else {
return 0;
}
hash = newHV();
ref = newRV_noinc((SV*) hash);
stash = gv_stashpv("Net::IP::XS", 1);
sv_bless(ref, stash);
res = NI_set(ref, buf, version);
if (!res) {
return NULL;
}
return ref;
}
static SV *new_Token(pTHX_ Token *token)
{
HV *hash = (HV*)new_Hash();
(void)hv_stores(hash, "stype", set(new_Int(token->stype)));
(void)hv_stores(hash, "type", set(new_Int(token->info.type)));
(void)hv_stores(hash, "kind", set(new_Int(token->info.kind)));
(void)hv_stores(hash, "line", set(new_Int(token->finfo.start_line_num)));
(void)hv_stores(hash, "has_warnings", set(new_Int(token->info.has_warnings)));
(void)hv_stores(hash, "name", set(new_String(token->info.name, strlen(token->info.name))));
(void)hv_stores(hash, "data", set(new_String(token->data.c_str(), strlen(token->data.c_str()))));
HV *stash = (HV *)gv_stashpv("Compiler::Lexer::Token", sizeof("Compiler::Lexer::Token") + 1);
return sv_bless(new_Ref(hash), stash);
}
/**
* NI_binadd(): get new object from the sum of two IP addresses.
* @ipo1: first Net::IP::XS object.
* @ipo2: second Net::IP::XS object.
*/
SV *
NI_binadd(SV *ipo1, SV *ipo2)
{
const char *binip1;
const char *binip2;
int version;
char binbuf[130];
char buf[45];
int res;
HV *stash;
HV *hash;
SV *ref;
int iplen;
binip1 = NI_hv_get_pv(ipo1, "binip", 5);
if (!binip1) {
binip1 = "";
}
binip2 = NI_hv_get_pv(ipo2, "binip", 5);
if (!binip2) {
binip2 = "";
}
res = NI_ip_binadd(binip1, binip2, binbuf, IPV6_BITSTR_LEN);
if (!res) {
NI_copy_Error_Errno(ipo1);
return NULL;
}
version = NI_hv_get_iv(ipo1, "ipversion", 9);
iplen = NI_iplengths(version);
binbuf[iplen] = '\0';
buf[0] = '\0';
res = NI_ip_bintoip(binbuf, version, buf);
if (!res) {
return NULL;
}
hash = newHV();
ref = newRV_noinc((SV*) hash);
stash = gv_stashpv("Net::IP::XS", 1);
sv_bless(ref, stash);
res = NI_set(ref, buf, version);
if (!res) {
return NULL;
}
return ref;
}
EXTERN_C void
xs_init(pTHX)
{
char *file = __FILE__;
dXSUB_SYS;
/* DynaLoader is a special case */
newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
if (!uperl.tmp_input_stash) goto nonworker;
newXS("uwsgi::input::new", XS_input, "uwsgi::input");
newXS("uwsgi::input::read", XS_input_read, "uwsgi::input");
newXS("uwsgi::input::seek", XS_input_seek, "uwsgi::input");
uperl.tmp_input_stash[uperl.tmp_current_i] = gv_stashpv("uwsgi::input", 0);
newXS("uwsgi::error::new", XS_error, "uwsgi::error");
newXS("uwsgi::error::print", XS_error_print, "uwsgi::print");
uperl.tmp_error_stash[uperl.tmp_current_i] = gv_stashpv("uwsgi::error", 0);
uperl.tmp_psgix_logger[uperl.tmp_current_i] = newXS("uwsgi::psgix_logger", XS_psgix_logger, "uwsgi");
uperl.tmp_stream_responder[uperl.tmp_current_i] = newXS("uwsgi::stream", XS_stream, "uwsgi");
newXS("uwsgi::streaming::write", XS_streaming_write, "uwsgi::streaming");
newXS("uwsgi::streaming::close", XS_streaming_close, "uwsgi::streaming");
newXS("uwsgi::stacktrace", XS_uwsgi_stacktrace, "uwsgi");
uperl.tmp_streaming_stash[uperl.tmp_current_i] = gv_stashpv("uwsgi::streaming", 0);
nonworker:
#ifdef UWSGI_EMBEDDED
init_perl_embedded_module();
#endif
}
SV *p5_call_parent_method(PerlInterpreter *my_perl, char *package, SV *obj, I32 context, char *name, int len, SV *args[], I32 *count, I32 *err, I32 *type) {
PERL_SET_CONTEXT(my_perl);
{
dSP;
int i;
SV * retval = NULL;
int flags = (context ? G_SCALAR : G_ARRAY) | G_EVAL;
ENTER;
SAVETMPS;
HV * const pkg = package != NULL ? gv_stashpv(package, 0) : SvSTASH((SV*)SvRV(obj));
GV * const gv = Perl_gv_fetchmethod_autoload(aTHX_ pkg, name, TRUE);
if (gv && isGV(gv)) {
PUSHMARK(SP);
if (len > 1) {
XPUSHs(package != NULL ? sv_2mortal(args[0]) : args[0]);
for (i = 1; i < len; i++) {
if (args[i] != NULL) /* skip Nil which gets turned into NULL */
XPUSHs(sv_2mortal(args[i]));
}
}
else if (len > 0)
if (args != NULL) /* skip Nil which gets turned into NULL */
XPUSHs(package != NULL ? sv_2mortal((SV*)args) : (SV*)args);
PUTBACK;
SV * const rv = sv_2mortal(newRV((SV*)GvCV(gv)));
*count = call_sv(rv, flags);
SPAGAIN;
handle_p5_error(err);
retval = pop_return_values(my_perl, sp, *count, type);
SPAGAIN;
}
else {
ERRSV = newSVpvf("Could not find method \"%s\" of \"%s\" object", name, HvNAME(pkg));
}
PUTBACK;
FREETMPS;
LEAVE;
return retval;
}
}
void set_up_debug_sv(const char* name) {
SV* tie_obj;
HV* tie_obj_stash;
// create an sv and make it a reference to another (new and empty) sv
tie_obj = newSV(0);
newSVrv(tie_obj, NULL);
// bless the reference into the name'd class
tie_obj_stash = gv_stashpv(name, TRUE);
sv_bless(tie_obj, tie_obj_stash);
// tie the blessed object to the name'd scalar
sv_magic(get_sv(name, 1), tie_obj, PERL_MAGIC_tiedscalar, NULL, 0);
}
static void *
create_event_common(lcb_io_opt_t cbcio, int type)
{
plcb_EVENT *cevent;
plcb_IOPROCS *async;
SV *initproc = NULL, *tmprv = NULL;
async = (plcb_IOPROCS*) cbcio->v.v0.cookie;
Newxz(cevent, 1, plcb_EVENT);
cevent->pl_event = newAV();
cevent->rv_event = newRV_noinc((SV*)cevent->pl_event);
cevent->evtype = type;
cevent->fd = -1;
sv_bless(cevent->rv_event, gv_stashpv(PLCB_EVENT_CLASS, GV_ADD));
av_store(cevent->pl_event, PLCB_EVIDX_OPAQUE, newSViv(PTR2IV(cevent)));
av_store(cevent->pl_event, PLCB_EVIDX_FD, newSViv(-1));
av_store(cevent->pl_event, PLCB_EVIDX_TYPE, newSViv(type));
av_store(cevent->pl_event, PLCB_EVIDX_WATCHFLAGS, newSViv(0));
tmprv = newRV_inc(*av_fetch(cevent->pl_event, PLCB_EVIDX_OPAQUE, 0));
sv_bless(tmprv, gv_stashpv("Couchbase::IO::_CEvent", GV_ADD));
SvREFCNT_dec(tmprv);
if (type == PLCB_EVTYPE_IO) {
initproc = async->cv_evinit;
} else {
initproc = async->cv_tminit;
}
if (initproc) {
cb_args_noret(initproc, 0, 2, async->userdata, cevent->rv_event);
}
return cevent;
}
AV *p5_call_method(PerlInterpreter *my_perl, char *package, SV *obj, char *name, int len, SV *args[]) {
dSP;
int i;
AV * const retval = newAV();
int flags = G_ARRAY | G_EVAL;
PERL_SET_CONTEXT(my_perl);
ENTER;
SAVETMPS;
HV * const pkg = package != NULL ? gv_stashpv(package, 0) : SvSTASH((SV*)SvRV(obj));
GV * const gv = Perl_gv_fetchmethod_autoload(aTHX_ pkg, name, TRUE);
if (gv && isGV(gv)) {
I32 count;
PUSHMARK(SP);
for (i = 0; i < len; i++) {
XPUSHs(sv_2mortal(args[i]));
}
PUTBACK;
SV * const rv = sv_2mortal(newRV((SV*)GvCV(gv)));
count = call_sv(rv, flags);
SPAGAIN;
if (count > 0)
av_extend(retval, count - 1);
for (i = count - 1; i >= 0; i--) {
SV * const next = POPs;
SvREFCNT_inc(next);
if (av_store(retval, i, next) == NULL)
SvREFCNT_dec(next); /* see perlguts Working with AVs */
}
}
else {
ERRSV = newSVpvf("Could not find method \"%s\" of \"%s\" object", name, HvNAME(pkg));
}
PUTBACK;
FREETMPS;
LEAVE;
return retval;
}
void p5_rebless_object(PerlInterpreter *my_perl, SV *obj, char *package, IV i) {
PERL_SET_CONTEXT(my_perl);
{
SV * const inst = SvRV(obj);
HV *stash = gv_stashpv(package, GV_ADD);
if (stash == NULL)
croak("Perl6::Object not found!? Forgot to call init_callbacks?");
(void)sv_bless(obj, stash);
_perl6_magic priv;
/* set up magic */
priv.key = PERL6_MAGIC_KEY;
priv.index = i;
sv_magicext(inst, inst, PERL_MAGIC_ext, &p5_inline_mg_vtbl, (char *) &priv, sizeof(priv));
}
}
static void
Encode_XSEncoding(pTHX_ encode_t *enc)
{
dSP;
HV *stash = gv_stashpv("Encode::XS", TRUE);
SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(enc))),stash);
int i = 0;
PUSHMARK(sp);
XPUSHs(sv);
while (enc->name[i])
{
const char *name = enc->name[i++];
XPUSHs(sv_2mortal(newSVpvn(name,strlen(name))));
}
PUTBACK;
call_pv("Encode::define_encoding",G_DISCARD);
SvREFCNT_dec(sv);
}
SV *
g_hash_table_to_hashref_property(GHashTable *hash)
{
HV *hv;
HV *stash;
SV *tie;
hv = newHV();
tie = newRV_noinc((SV*)newHV());
stash = gv_stashpv("Amanda::Config::FoldingHash", GV_ADD);
sv_bless(tie, stash);
hv_magic(hv, (GV*)tie, PERL_MAGIC_tied);
hv = (HV *)sv_2mortal((SV *)hv);
g_hash_table_foreach(hash, foreach_fn_property, hv);
return newRV((SV *)hv);
}
void store_self(pTHX, mthread* thread) {
SV *thread_sv, *self;
AV* message_cache;
thread_sv = newSV_type(SVt_PV);
SvPVX(thread_sv) = (char*) thread;
SvCUR(thread_sv) = sizeof(mthread);
SvLEN(thread_sv) = 0;
SvPOK_only(thread_sv);
SvREADONLY_on(thread_sv);
hv_store(PL_modglobal, "threads::lite::thread", 21, thread_sv, 0);
self = newRV_noinc(newSVuv(thread->id));
sv_bless(self, gv_stashpv("threads::lite::tid", TRUE));
hv_store(PL_modglobal, "threads::lite::self", 19, self, 0);
message_cache = newAV();
hv_store(PL_modglobal, "threads::lite::message_cache", 28, (SV*)message_cache, 0);
thread->cache = message_cache;
}
