static void
plperl_safe_init(void)
{
SV *res;
double safe_version;
res = eval_pv(SAFE_MODULE, FALSE); /* TRUE = croak if failure */
safe_version = SvNV(res);
/*
* We actually want to reject safe_version < 2.09, but it's risky to
* assume that floating-point comparisons are exact, so use a slightly
* smaller comparison value.
*/
if (safe_version < 2.0899)
{
/* not safe, so disallow all trusted funcs */
eval_pv(SAFE_BAD, FALSE);
}
else
{
eval_pv(SAFE_OK, FALSE);
}
plperl_safe_init_done = true;
}
static void
perl_init (void)
{
int warn;
int arg_count;
char *perl_args[] = { "", "-e", "0", "-w" };
char *env[] = { "" };
static const char xchat_definitions[] = {
/* Redefine the $SIG{__WARN__} handler to have XChat
printing warnings in the main window. (TheHobbit) */
#include "xchat.pm.h"
};
#ifdef OLD_PERL
static const char irc_definitions[] = {
#include "irc.pm.h"
};
#endif
#ifdef ENABLE_NLS
/* Problem is, dynamicaly loaded modules check out the $]
var. It appears that in the embedded interpreter we get
5,00503 as soon as the LC_NUMERIC locale calls for a comma
instead of a point in separating integer and decimal
parts. I realy can't understant why... The following
appears to be an awful workaround... But it'll do until I
(or someone else :)) found the "right way" to solve this
nasty problem. (TheHobbit <*****@*****.**>) */
setlocale (LC_NUMERIC, "C");
#endif
warn = 0;
xchat_get_prefs (ph, "perl_warnings", NULL, &warn);
arg_count = warn ? 4 : 3;
PERL_SYS_INIT3 (&arg_count, (char ***)&perl_args, (char ***)&env);
my_perl = perl_alloc ();
perl_construct (my_perl);
PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
perl_parse (my_perl, xs_init, arg_count, perl_args, (char **)NULL);
/*
Now initialising the perl interpreter by loading the
perl_definition array.
*/
eval_pv (xchat_definitions, TRUE);
#ifdef OLD_PERL
eval_pv (irc_definitions, TRUE);
#endif
}
/* eval "package Foo; \&init_handler" */
int modperl_filter_resolve_init_handler(pTHX_ modperl_handler_t *handler,
apr_pool_t *p)
{
char *init_handler_pv_code = NULL;
if (handler->mgv_cv) {
GV *gv = modperl_mgv_lookup(aTHX_ handler->mgv_cv);
if (gv) {
CV *cv = modperl_mgv_cv(gv);
if (cv && SvMAGICAL(cv)) {
MAGIC *mg = mg_find((SV*)(cv), PERL_MAGIC_ext);
init_handler_pv_code = mg ? mg->mg_ptr : NULL;
}
else {
/* XXX: should we complain in such a case? */
return 0;
}
}
}
if (init_handler_pv_code) {
char *package_name =
modperl_mgv_as_string(aTHX_ handler->mgv_cv, p, 1);
/* fprintf(stderr, "PACKAGE: %s\n", package_name ); */
/* eval the code in the parent handler's package's context */
char *code = apr_pstrcat(p, "package ", package_name, ";",
init_handler_pv_code, NULL);
SV *sv;
modperl_handler_t *init_handler;
ENTER;SAVETMPS;
sv = eval_pv(code, TRUE);
/* fprintf(stderr, "code: %s\n", code); */
init_handler = modperl_handler_new_from_sv(aTHX_ p, sv);
FREETMPS;LEAVE;
if (init_handler) {
modperl_mgv_resolve(aTHX_ init_handler, p, init_handler->name, 1);
MP_TRACE_h(MP_FUNC, "found init handler %s",
modperl_handler_name(init_handler));
if (!(init_handler->attrs & MP_FILTER_INIT_HANDLER)) {
Perl_croak(aTHX_ "handler %s doesn't have "
"the FilterInitHandler attribute set",
modperl_handler_name(init_handler));
}
handler->next = init_handler;
return 1;
}
else {
Perl_croak(aTHX_ "failed to eval code: %s", code);
}
}
return 1;
}
/* ---- special pearl parser ----- */
int perl_parse_buf (char *inBuf) {
STRLEN n_a;
char *embedding[] = { "", "-e", "" };
if (!my_perl) {
my_perl = perl_alloc();
perl_construct( my_perl );
perl_parse(my_perl, xs_init, 3, embedding, NULL);
/* PL_exit_flags |= PERL_EXIT_DESTRUCT_END; */
perl_run(my_perl);
}
/* sv_setpv(text,inBuf); */
/* eval_sv(text,G_SCALAR); */
perlBuf = eval_pv(inBuf, TRUE);
if (0) {
perl_destruct(my_perl);
perl_free(my_perl);
}
return 0;
}
void Embperl::init_eval_file(void)
{
eval_pv(
"our %Cache;"
"use Symbol qw(delete_package);"
"sub eval_file {"
"my($package, $filename) = @_;"
"$filename=~s/\'//g;"
"if(! -r $filename) { print \"Unable to read perl file '$filename'\\n\"; return; }"
"my $mtime = -M $filename;"
"if(defined $Cache{$package}{mtime}&&$Cache{$package}{mtime} <= $mtime && !($package eq 'plugin')){"
" return;"
"} else {"
//we 'my' $filename,$mtime,$package,$sub to prevent them from changing our state up here.
" eval(\"package $package; my(\\$filename,\\$mtime,\\$package,\\$sub); \\$isloaded = 1; require '$filename'; \");"
/* "local *FH;open FH, $filename or die \"open '$filename' $!\";"
"local($/) = undef;my $sub = <FH>;close FH;"
"my $eval = qq{package $package; sub handler { $sub; }};"
"{ my($filename,$mtime,$package,$sub); eval $eval; }"
"die $@ if $@;"
"$Cache{$package}{mtime} = $mtime; ${$package.'::isloaded'} = 1;}"
*/
"}"
"}"
,FALSE);
}
static SV* campher_eval_pv(PerlInterpreter* my_perl, char* code) {
PERL_SET_CONTEXT(my_perl);
SV* ret = eval_pv(code, TRUE);
// TODO: this might already be done and thus wrong + leaky:
SvREFCNT_inc(ret);
return ret;
}
void EQWParser::EQW_eval(const char *pkg, const char *code) {
char namebuf[64];
snprintf(namebuf, 64, "package %s;", pkg);
eval_pv(namebuf, FALSE);
//make sure the EQW pointer is set up
EQW *curc = EQW::Singleton();
snprintf(namebuf, 64, "EQW");
// snprintf(namebuf, 64, "%s::EQW", pkg);
SV *l = get_sv(namebuf, true);
if(curc != nullptr) {
sv_setref_pv(l, "EQW", curc);
} else {
//clear out the value, mainly to get rid of blessedness
sv_setsv(l, _empty_sv);
}
//make sure the EQDB pointer is set up
EQDB *curc_db = EQDB::Singleton();
snprintf(namebuf, 64, "EQDB");
// snprintf(namebuf, 64, "%s::EQW", pkg);
SV *l_db = get_sv(namebuf, true);
if(curc_db != nullptr) {
sv_setref_pv(l_db, "EQDB", curc_db);
} else {
//clear out the value, mainly to get rid of blessedness
sv_setsv(l_db, _empty_sv);
}
std::string err;
if(!eval(code, err)) {
EQW::Singleton()->AppendOutput(err.c_str());
}
}
void
do_something_perlish(char *something)
{
if (netsnmp_ds_get_boolean(NETSNMP_DS_APPLICATION_ID,
NETSNMP_DS_AGENT_DISABLE_PERL)) {
return;
}
maybe_source_perl_startup();
if (netsnmp_ds_get_boolean(NETSNMP_DS_APPLICATION_ID,
NETSNMP_DS_AGENT_DISABLE_PERL)) {
return;
}
DEBUGMSGTL(("perl", "calling perl\n"));
#if defined(HAVE_EVAL_PV) || defined(eval_pv)
/* newer perl */
eval_pv(something, TRUE);
#else
#if defined(HAVE_PERL_EVAL_PV_LC) || defined(perl_eval_pv)
/* older perl? */
perl_eval_pv(something, TRUE);
#else /* HAVE_PERL_EVAL_PV_LC */
#ifdef HAVE_PERL_EVAL_PV_UC
/* older perl? */
Perl_eval_pv(my_perl, something, TRUE);
#else /* !HAVE_PERL_EVAL_PV_UC */
#error embedded perl broken
#endif /* !HAVE_PERL_EVAL_PV_LC */
#endif /* !HAVE_PERL_EVAL_PV_UC */
#endif /* !HAVE_EVAL_PV */
DEBUGMSGTL(("perl", "finished calling perl\n"));
}
static int
set_record(struct _std_event *ev_ptr, char *response,struct _firewall_info *fw_info){
if(fw_info){
/* equals to NULL means its a key value firewall
* else a regular expression firewall
*/
if(fw_info->fw_regex == NULL) {
//printf(" key value type log \n");
if(parse_keyvalue(ev_ptr,response,fw_info->un.kv)<0){
//printf("Not able to parse kv_pair\n");
return -1;
}
}else{
#ifdef REGEX
if( regex_event_count++ < MAX_REGEX_EVENTS ){
char logid[50];
//int i_log_id;
struct _log_info *found_log_info=NULL;
//printf(" regex type log $log=%s\n",response);
sv_setpvf(sv , "$log='%s'" , response);
eval_sv(sv , G_SCALAR);
/* Apply fw_info->regex and get log id
* use that log id to get log_info struct from log_info_hash
*/
if(SvIV(eval_pv(fw_info->fw_regex,TRUE))){
strncpy(logid,SvPV(get_sv("logtype" , FALSE) , n_a), sizeof(logid)-1);
//printf(" logtype = -%s-\n" , logid);
//i_log_id=atoi(logid);
HASH_FIND_STR(fw_info->un.log_hash, logid , found_log_info);
if(found_log_info==NULL){
printf(" no log info found for logid %s\n",logid);
return -1;
}
if( parse_regex( ev_ptr, response, found_log_info )<0 ){
printf(" parsing regex error %s\n",logid);
return -1;
}
}else{
printf("fw_regex did not work \n");
}
}else{
regex_event_count=0;
perl_reset();
}
#endif
}
}else{
printf("fw_info for given ip address is blank.%s\n",response);
return -1;
}
return 1;
}
/* Make sure Math::BigInt is loaded
*/
static void
load_Math_BigInt(void)
{
static int loaded = 0;
if (loaded) return;
eval_pv("use Math::BigInt; use Amanda::BigIntCompat;", 1);
loaded = 1;
}
SV * my_eval_pv(char *pv) {
SV* result;
/*
* eval_pv(..., TRUE) means die if Perl traps an error
*/
result = eval_pv(pv, TRUE) ;
return result ;
}
/***********************************************************************************************************************************
Evaluate a perl statement
***********************************************************************************************************************************/
static void
perlEval(const String *statement)
{
FUNCTION_TEST_BEGIN();
FUNCTION_TEST_PARAM(STRING, statement);
FUNCTION_TEST_END();
eval_pv(strPtr(statement), TRUE);
FUNCTION_TEST_RETURN_VOID();
}
static char*
EvalPerl(char *src)
{
char* pv;
SV *val = eval_pv(src, TRUE);
if(SvOK(val)) {
pv = SvPV_nolen(val);
}
return pv;
}
Embperl::~Embperl()
{
in_use = true;
#ifdef EMBPERL_IO_CAPTURE
eval_pv(
"package quest;"
" if(tied *STDOUT) { untie(*STDOUT); }"
" if(tied *STDERR) { untie(*STDERR); }"
,FALSE);
#endif
perl_free(my_perl);
}
interp() : my_perl(NULL), stopping(false) {
my_perl = perl_alloc();
perl_construct(my_perl);
const char* embedding[] = {"", "-e", "0"};
perl_parse(my_perl, NULL, 3, (char**)embedding, NULL);
PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
perl_run(my_perl);
//eval_pv("sub test_method { my $a = @_[0]; $a = $a . \" and something else!\"; return $a; }", TRUE);
eval_pv("sub test_method { my $a = \"test string\"; return $a; }", TRUE);
};
/* parsing logs for regex type of firewalls
*/
static int
parse_regex(struct _std_event *ev_ptr,char *response, struct _log_info *l_info){
struct _kv_rel *kvrl=NULL;
struct _kv_rel *inner_kvrl=NULL;
SV *svp;
int i,j=0;
/*
* Execute the regex in perl interpreter
* It will extract values for all keys from the buffer
*/
if( SvIV( eval_pv( l_info->log_regex , FALSE ) ) ){
/* Iterate through each node of the kv_rel_hash
* and set its value in standard event
*/
for( kvrl=l_info->kv_rel_hash; ( kvrl != NULL ) ; kvrl=(struct _kv_rel *) (kvrl->hh.next) ) {
//printf("Key -%s-\n", kvrl->key);
inner_kvrl=kvrl;
while(inner_kvrl!=NULL){
strcpy( value_buffer, SvPV( get_sv(inner_kvrl->key,FALSE) , n_a) );
//printf("value -%s-\n", value_buffer);
i=0;
j=0;
while(inner_kvrl->conversion_fn[i]!=NULL && i<inner_kvrl->fn_index){
j=inner_kvrl->conversion_fn[i++] (ev_ptr,value_buffer);
switch(j){
case -3: //dont execute translation fn and exit while loop
case -1: //Exit from while loop
i=kvrl->fn_index;
break;
case -2: //Exit function (Drop event)
return -2;
break;
default: ;
}
}
//printf ("No. of conversions Done %d for key %s\n",i,kvrl->key);
if(j!=-3){
inner_kvrl->se_var->typecast_st(inner_kvrl->key,inner_kvrl->se_var,ev_ptr,value_buffer);
}
inner_kvrl=inner_kvrl->next;
}
}
return 1;
}else{
printf("Log Regex did not work\n");
return -1;
}
}
/* Evalute perl code */
VCSI_OBJECT perl_eval(VCSI_CONTEXT vc,
VCSI_OBJECT x) {
SV *val;
check_arg_type(vc,x,STRING,"perl-eval");
/*printf("Trying to eval:\n%s\n",STR(x));*/
val = eval_pv(STR(x),TRUE);
if(val)
return perl_return(vc,val);
return vc->false;
}
int main(int argc, char **argv){
struct stat sb;
char *buf,*last;
FILE *fp;
fp=fopen(argv[argc-1],"r");
if(!fp)return fprintf(stderr,"unable to open file `%s'\n",argv[argc-1]);
strcpy(argv[argc-1],"-e0");//filename should be long enough :P
fstat(fileno(fp),&sb);
last=buf=malloc(sb.st_size+1);
if(!buf)return fprintf(stderr,"unable to malloc %d bytes\n",sb.st_size+1);
fread(buf,1,sb.st_size,fp);
buf[sb.st_size]=0;
my_perl = perl_alloc();
perl_construct(my_perl);
perl_parse(my_perl, NULL, argc, argv, NULL);
perl_run(my_perl);
for(;*buf;buf++){
if(*buf=='<'&&buf[1]==TAG){
*buf=0;
fputs(last,stdout);
last=buf+=2;
for(;*buf;buf++){
if(*buf==TAG&&buf[1]=='>'){
*buf=0;
eval_pv(last,TRUE);
last=buf+=2;
break;
}
}
if(!buf){
eval_pv(last,TRUE);
break;
}
}
}
fputs(last,stdout);
perl_destruct(my_perl);
perl_free(my_perl);
}
/***********************************************************************************************************************************
Initialize Perl
***********************************************************************************************************************************/
static void
perlInit(void)
{
FUNCTION_TEST_VOID();
if (!my_perl)
{
// Initialize Perl with dummy args and environment
int argc = 1;
const char *argv[1] = {strPtr(cfgExe())};
const char *env[1] = {NULL};
PERL_SYS_INIT3(&argc, (char ***)&argv, (char ***)&env);
// Create the interpreter
const char *embedding[] = {"", "-e", "0"};
my_perl = perl_alloc();
perl_construct(my_perl);
// Don't let $0 assignment update the proctitle or embedding[0]
PL_origalen = 1;
// Start the interpreter
perl_parse(my_perl, xs_init, 3, (char **)embedding, NULL);
PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
perl_run(my_perl);
// Use customer loader to get all embedded modules
eval_pv("splice(@INC, 0, 0, " LOADER_SUB ");", true);
// Now that the custom loader is installed, load the main module;
eval_pv("use " PGBACKREST_MODULE ";", true);
// Set config data -- this is done separately to avoid it being included in stack traces
perlEval(strNewFmt(PGBACKREST_MAIN "ConfigSet('%s', '%s')", strPtr(cfgExe()), strPtr(perlOptionJson())));
}
FUNCTION_TEST_RETURN_VOID();
}
static void xs_init(pTHX)
{
dXSUB_SYS;
PERL_UNUSED_CONTEXT;
// Register the LibC functions by registering the boot function and calling it
newXS("pgBackRest::LibC::boot", boot_pgBackRest__LibC, __FILE__);
eval_pv("pgBackRest::LibC::boot()", TRUE);
// Register the embedded module getter
newXS("pgBackRest::LibC::embeddedModuleGet", embeddedModuleGet, __FILE__);
// DynaLoader is a special case
newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, __FILE__);
}
Embperl::~Embperl()
{
in_use = true;
#ifdef EMBPERL_IO_CAPTURE
eval_pv(
"package quest;"
" if(tied *STDOUT) { untie(*STDOUT); }"
" if(tied *STDERR) { untie(*STDERR); }"
,FALSE);
#endif
PL_perl_destruct_level = 1;
perl_destruct(my_perl);
perl_free(my_perl);
PERL_SYS_TERM();
my_perl = NULL;
}
int perl_content(char *ret_buf)
{
eval_pv(m_content_script, TRUE);
SV *tmp;
char *p;
STRLEN len;
tmp = get_sv("content", 0);
p = SvPV(tmp, len);
memcpy(ret_buf, p, len);
ret_buf[len] = 0;
FREETMPS; /* free vars */
return len;
}
void EQWParser::SetHTTPRequest(const char *pkg, HTTPRequest *it) {
char namebuf[64];
snprintf(namebuf, 64, "package %s;", pkg);
eval_pv(namebuf, FALSE);
snprintf(namebuf, 64, "request");
// snprintf(namebuf, 64, "%s::EQW", pkg);
SV *l = get_sv(namebuf, true);
if(it != nullptr) {
sv_setref_pv(l, "HTTPRequest", it);
} else {
//clear out the value, mainly to get rid of blessedness
sv_setsv(l, _empty_sv);
}
}
bool KviPerlInterpreter::init()
{
if(m_pInterpreter)done();
const char * daArgs[] = { "yo", "-e", "0", "-w" };
m_pInterpreter = perl_alloc();
if(!m_pInterpreter)return false;
PERL_SET_CONTEXT(m_pInterpreter);
PL_perl_destruct_level = 1;
perl_construct(m_pInterpreter);
perl_parse(m_pInterpreter,xs_init,4,(char **)daArgs,NULL);
QString szInitCode;
// this part of the code seems to be unnecessary
// even if it is created by the perl make process...
// "our %EXPORT_TAGS = ('all' => [qw(echo)]);\n"
// "our @EXPORT_OK = (qw(echo));\n"
// "our @EXPORT = qw();\n"
// This is probably needed only if perl has to load
// the XS through XSLoader ?
// Maybe also the remaining part of the package
// declaration could be dropped as well...
// I just haven't tried :D
szInitCode = QString(
"{\n" \
"package KVIrc;\n" \
"require Exporter;\n" \
"our @ISA = qw(Exporter);\n" \
"1;\n" \
"}\n" \
"$g_szContext = \"%1\";\n" \
"$g_bExecuteQuiet = 0;\n" \
"$SIG{__WARN__} = sub\n" \
"{\n" \
" my($p,$f,$l,$x);\n" \
" ($p,$f,$l) = caller;\n" \
" KVIrc::internalWarning(\"At line \".$l.\" of perl code: \");\n" \
" KVIrc::internalWarning(join(' ',@_));\n" \
"}\n").arg(m_szContextName);
eval_pv(szInitCode.toUtf8().data(),false);
return true;
}
SV *p5_eval_pv(PerlInterpreter *my_perl, const char* p, I32 croak_on_error) {
PERL_SET_CONTEXT(my_perl);
{
dSP;
SV * retval;
ENTER;
SAVETMPS;
PUSHMARK(SP);
retval = eval_pv(p, croak_on_error);
SvREFCNT_inc(retval);
SPAGAIN;
PUTBACK;
FREETMPS;
LEAVE;
return retval;
}
}
static void
ngx_http_perl_eval_anon_sub(pTHX_ ngx_str_t *handler, SV **sv)
{
u_char *p;
for (p = handler->data; *p; p++) {
if (*p != ' ' && *p != '\t' && *p != CR && *p != LF) {
break;
}
}
if (ngx_strncmp(p, "sub ", 4) == 0 || ngx_strncmp(p, "use ", 4) == 0) {
*sv = eval_pv((char *) p, FALSE);
/* eval_pv() does not set ERRSV on failure */
return;
}
*sv = NULL;
}
static SV *load_psgi(apr_pool_t *pool, const char *file)
{
dTHX;
SV *app;
char *code;
code = apr_psprintf(pool, "do q\"%s\" or die $@",
ap_escape_quotes(pool, file));
app = eval_pv(code, FALSE);
if (SvTRUE(ERRSV)) {
ap_log_error(APLOG_MARK, APLOG_NOERRNO|APLOG_ERR, 0, NULL, "%s", SvPV_nolen(ERRSV));
CLEAR_ERRSV();
return NULL;
}
if (!SvOK(app) || !SvROK(app) || SvTYPE(SvRV(app)) != SVt_PVCV) {
ap_log_error(APLOG_MARK, APLOG_NOERRNO|APLOG_ERR, 0, NULL,
"%s does not return an application code reference", file);
return NULL;
}
return app;
}
void
math_int64_boot(pTHX_ int version) {
dSP;
SV **svp;
eval_pv("require Math::Int64", TRUE);
if (SvTRUE(ERRSV))
Perl_croak(aTHX_ "Unable to load Math::Int64: %s", SvPV_nolen(ERRSV));
math_int64_capi_hash = get_hv("Math::Int64::C_API", 0);
if (!math_int64_capi_hash) Perl_croak(aTHX_ "Unable to load Math::Int64 C API");
math_int64_capi_version = SvIV(*hv_fetchs(math_int64_capi_hash, "version", 1));
if (math_int64_capi_version < version)
Perl_croak(aTHX_ "Math::Int64 C API version mismatch, expected %d, found %d",
version, math_int64_capi_version);
fetch_ptr(math_int64_capi_newSVi64, "newSVi64");
fetch_ptr(math_int64_capi_newSVu64, "newSVu64");
fetch_ptr(math_int64_capi_SvI64, "SvI64");
fetch_ptr(math_int64_capi_SvU64, "SvU64");
fetch_ptr(math_int64_capi_SvI64OK, "SvI64OK");
fetch_ptr(math_int64_capi_SvU64OK, "SvU64OK");
}
/* caller is responsible for freeing returned string */
CALLER_OWN char *owl_perlconfig_execute(const char *line)
{
STRLEN len;
SV *response;
char *out;
if (!owl_global_have_config(&g)) return NULL;
ENTER;
SAVETMPS;
/* execute the subroutine */
response = eval_pv(line, FALSE);
if (SvTRUE(ERRSV)) {
owl_function_error("Perl Error: '%s'", SvPV_nolen(ERRSV));
sv_setsv (ERRSV, &PL_sv_undef); /* and clear the error */
}
out = g_strdup(SvPV(response, len));
FREETMPS;
LEAVE;
return(out);
}
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;
}