void p5_av_unshift(PerlInterpreter *my_perl, AV *av, SV *sv) {
PERL_SET_CONTEXT(my_perl);
av_unshift(av, 1);
SvREFCNT_inc(sv);
if (av_store(av, 0, sv) == NULL)
SvREFCNT_dec(sv);
}
static JSBool
perlarray_unshift(
JSContext *cx,
JSObject *obj,
uintN argc,
jsval *argv,
jsval *rval
) {
dTHX;
SV *ref = (SV *)JS_GetPrivate(cx, obj);
AV *av = (AV *)SvRV(ref);
IV tmp;
PJS_ARRAY_CHECK
if(argc) {
av_unshift(av, argc);
for(tmp = 0; tmp < argc; tmp++) {
SV *sv;
if(!PJS_ReflectJS2Perl(aTHX_ cx, argv[tmp], &sv, 1)) {
JS_ReportError(cx, "Failed to convert argument %d to Perl", tmp);
return JS_FALSE;
}
if(!av_store(av, tmp, sv)) {
if(SvRMAGICAL(av)) mg_set(sv);
sv_free(sv);
}
}
}
return JS_TRUE;
}
/* XXX: There is no XS accessible splice() */
static void modperl_av_remove_entry(pTHX_ AV *av, I32 index)
{
I32 i;
AV *tmpav = newAV();
/* stash the entries _before_ the item to delete */
for (i=0; i<=index; i++) {
av_store(tmpav, i, SvREFCNT_inc(av_shift(av)));
}
/* make size at the beginning of the array */
av_unshift(av, index-1);
/* add stashed entries back */
for (i=0; i<index; i++) {
av_store(av, i, *av_fetch(tmpav, i, 0));
}
sv_free((SV *)tmpav);
}
bool KviPerlInterpreter::execute(
const QString &szCode,
QStringList &args,
QString &szRetVal,
QString &szError,
QStringList &lWarnings)
{
if(!m_pInterpreter)
{
szError = __tr2qs_ctx("Internal error: perl interpreter not initialized","perl");
return false;
}
g_lWarningList.clear();
QByteArray szUtf8 = szCode.toUtf8();
PERL_SET_CONTEXT(m_pInterpreter);
// clear the _ array
AV * pArgs = get_av("_",1);
SV * pArg = av_shift(pArgs);
while(SvOK(pArg))
{
SvREFCNT_dec(pArg);
pArg = av_shift(pArgs);
}
if(args.count() > 0)
{
// set the args in the _ arry
av_unshift(pArgs,(I32)args.count());
int idx = 0;
for(QStringList::Iterator it = args.begin();it != args.end();++it)
{
QString tmp = *it;
const char * val = tmp.toUtf8().data();
if(val)
{
pArg = newSVpv(val,tmp.length());
if(!av_store(pArgs,idx,pArg))
SvREFCNT_dec(pArg);
}
idx++;
}
}
// call the code
SV * pRet = eval_pv(szUtf8.data(),false);
// clear the _ array again
pArgs = get_av("_",1);
pArg = av_shift(pArgs);
while(SvOK(pArg))
{
SvREFCNT_dec(pArg);
pArg = av_shift(pArgs);
}
av_undef(pArgs);
// get the ret value
if(pRet)
{
if(SvOK(pRet))
szRetVal = svToQString(pRet);
}
if(!g_lWarningList.isEmpty())
lWarnings = g_lWarningList;
// and the eventual error string
pRet = get_sv("@",false);
if(pRet)
{
if(SvOK(pRet))
{
szError = svToQString(pRet);
if(!szError.isEmpty())return false;
}
}
return true;
}
void unshift(value_type val) {
av_unshift(impl(), 1);
av_store(impl(), 0, val);
}
/* caller must free result, if not NULL */
CALLER_OWN char *owl_perlconfig_initperl(const char *file, int *Pargc, char ***Pargv, char ***Penv)
{
int ret;
PerlInterpreter *p;
char *err;
const char *args[4] = {"", "-e", "0;", NULL};
AV *inc;
char *path;
/* create and initialize interpreter */
PERL_SYS_INIT3(Pargc, Pargv, Penv);
p=perl_alloc();
owl_global_set_perlinterp(&g, p);
perl_construct(p);
PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
owl_global_set_no_have_config(&g);
ret=perl_parse(p, owl_perl_xs_init, 2, (char **)args, NULL);
if (ret || SvTRUE(ERRSV)) {
err=g_strdup(SvPV_nolen(ERRSV));
sv_setsv(ERRSV, &PL_sv_undef); /* and clear the error */
return(err);
}
ret=perl_run(p);
if (ret || SvTRUE(ERRSV)) {
err=g_strdup(SvPV_nolen(ERRSV));
sv_setsv(ERRSV, &PL_sv_undef); /* and clear the error */
return(err);
}
owl_global_set_have_config(&g);
/* create legacy variables */
get_sv("BarnOwl::id", TRUE);
get_sv("BarnOwl::class", TRUE);
get_sv("BarnOwl::instance", TRUE);
get_sv("BarnOwl::recipient", TRUE);
get_sv("BarnOwl::sender", TRUE);
get_sv("BarnOwl::realm", TRUE);
get_sv("BarnOwl::opcode", TRUE);
get_sv("BarnOwl::zsig", TRUE);
get_sv("BarnOwl::msg", TRUE);
get_sv("BarnOwl::time", TRUE);
get_sv("BarnOwl::host", TRUE);
get_av("BarnOwl::fields", TRUE);
if(file) {
SV * cfg = get_sv("BarnOwl::configfile", TRUE);
sv_setpv(cfg, file);
}
sv_setpv(get_sv("BarnOwl::VERSION", TRUE), OWL_VERSION_STRING);
/* Add the system lib path to @INC */
inc = get_av("INC", 0);
path = g_build_filename(owl_get_datadir(), "lib", NULL);
av_unshift(inc, 1);
av_store(inc, 0, owl_new_sv(path));
g_free(path);
eval_pv("use BarnOwl;", FALSE);
if (SvTRUE(ERRSV)) {
err=g_strdup(SvPV_nolen(ERRSV));
sv_setsv (ERRSV, &PL_sv_undef); /* and clear the error */
return(err);
}
/* check if we have the formatting function */
if (owl_perlconfig_is_function("BarnOwl::format_msg")) {
owl_global_set_config_format(&g, 1);
}
return(NULL);
}
