static int output_headers(request_rec *r, AV *headers)
{
dTHX;
SV *key_sv, *val_sv;
char *key;
r->content_type = NULL;
while (av_len(headers) > -1) {
key_sv = av_shift(headers);
val_sv = av_shift(headers);
if (key_sv == NULL || val_sv == NULL) break;
key = SvPV_nolen(key_sv);
if (strcmp(key, "Content-Type") == 0) {
r->content_type = apr_pstrdup(r->pool, SvPV_nolen(val_sv));
} else if (strcmp(key, "Content-Length") == 0) {
ap_set_content_length(r, SvIV(val_sv));
} else if (strcmp(key, "Status") == 0) {
server_error(r, "headers must not contain a Status");
return HTTP_INTERNAL_SERVER_ERROR;
} else {
apr_table_add(r->headers_out, key, SvPV_nolen(val_sv));
}
SvREFCNT_dec(key_sv);
SvREFCNT_dec(val_sv);
}
return OK;
}
static JSBool
perlarray_shift(
JSContext *cx,
JSObject *obj,
uintN argc,
jsval *argv,
jsval *rval
) {
dTHX;
SV *ref = (SV *)JS_GetPrivate(cx, obj);
AV *av = (AV *)SvRV(ref);
SV *sv;
JSBool ok;
PJS_ARRAY_CHECK
sv = av_shift(av);
if(!sv || sv == &PL_sv_undef) {
*rval = JSVAL_VOID;
return JS_TRUE;
}
ENTER; SAVETMPS;
ok = PJS_ReflectPerl2JS(aTHX_ cx, obj, sv_mortalcopy(sv), rval);
FREETMPS; LEAVE;
return ok;
}
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);
}
}
/*----------------------------------------------------------------------------
do_bulk_match__()
The pattern match function which includes loading perl interpreter and
doing the global perl pattern match, and storing the results in the global
array of bulkMatchList.
argument:
input: char* string -- input text
char* pattern -- match pattern
output: int* num_match -- the number of the matches
----------------------------------------------------------------------------*/
int do_bulk_match__( void )
{
AV *match_list; /* AV storage of matches list*/
SV *text; /* storage for the embedded perl cmd */
SV *string_buff; /* storage for the embedded perl cmd */
int num_match; /* the number of the matches */
int i;
#ifdef MULTI_THREAD
if( NULL == th)
th = xsb_get_main_thread();
#endif
/* first load the perl interpreter, if unloaded */
if (perlObjectStatus == UNLOADED) load_perl__();
text = newSV(0);
string_buff = newSV(0);
sv_setpv(text, ptoc_string(CTXTc 1)); /*put the string into an SV */
/*------------------------------------------------------------------------
free the old match list space and allocate new space for current match list
-----------------------------------------------------------------------*/
for ( i=0; i<preBulkMatchNumber; i++ )
free(bulkMatchList[i]);
if (bulkMatchList != NULL ) free(bulkMatchList);
bulkMatchList = NULL;
/*------------------------------------------------------------------------
do bulk match
----------------------------------------------------------------------*/
num_match = all_matches(text, ptoc_string(CTXTc 2),&match_list);
/* allocate the space to store the matches */
if ( num_match != 0 ) {
preBulkMatchNumber = num_match; /* reset the pre bulk match number */
bulkMatchList = (char **)malloc(num_match*sizeof(char *));
if ( bulkMatchList == NULL )
xsb_abort("Cannot alocate memory to store the results for bulk match");
}
/*get the matches from the AV */
for ( i=0;i<num_match;i++ ) {
string_buff = av_shift(match_list);
bulkMatchList[i] = (char *)malloc( strlen(SvPV(string_buff,PL_na))+1 );
strcpy((char *)bulkMatchList[i], SvPV(string_buff,PL_na) );
}
SvREFCNT_dec(string_buff); /* release space*/
SvREFCNT_dec(text);
ctop_int(CTXTc 3, num_match); /*return the number of matches*/
return SUCCESS;
}
/* 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);
}
int matches(char *string, char *pattern, char **match_list[])
{
char *command;
SV *current_match;
AV *array;
I32 num_matches;
STRLEN length;
int i;
command = malloc(sizeof(char) * strlen(string) + strlen(pattern) + 38);
sprintf(command, "$string = '%s'; @array = ($string =~ %s)",
string, pattern);
perl_eval_pv(command, TRUE);
free(command);
array = perl_get_av("array", FALSE);
num_matches = av_len(array) + 1; /** assume $[ is 0 **/
*match_list = (char **) malloc(sizeof(char *) * num_matches);
for (i = 0; i <= num_matches; i++) {
current_match = av_shift(array);
(*match_list)[i] = SvPV(current_match, length);
}
return num_matches;
}
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;
}
static void perl_call_signal(PERL_SCRIPT_REC *script, SV *func,
int signal_id, gconstpointer *args)
{
dSP;
PERL_SIGNAL_ARGS_REC *rec;
SV *sv, *perlarg, *saved_args[SIGNAL_MAX_ARGUMENTS];
AV *av;
void *arg;
int n;
ENTER;
SAVETMPS;
PUSHMARK(sp);
/* push signal argument to perl stack */
rec = perl_signal_args_find(signal_id);
memset(saved_args, 0, sizeof(saved_args));
for (n = 0; n < SIGNAL_MAX_ARGUMENTS &&
rec != NULL && rec->args[n] != NULL; n++) {
arg = (void *) args[n];
if (strncmp(rec->args[n], "glistptr_", 9) == 0) {
/* pointer to linked list - push as AV */
GList *tmp, **ptr;
int is_iobject, is_str;
is_iobject = strcmp(rec->args[n]+9, "iobject") == 0;
is_str = strcmp(rec->args[n]+9, "char*") == 0;
av = newAV();
ptr = arg;
for (tmp = *ptr; tmp != NULL; tmp = tmp->next) {
sv = is_iobject ? iobject_bless((SERVER_REC *) tmp->data) :
is_str ? new_pv(tmp->data) :
irssi_bless_plain(rec->args[n]+9, tmp->data);
av_push(av, sv);
}
saved_args[n] = perlarg = newRV_noinc((SV *) av);
} else if (strcmp(rec->args[n], "int") == 0)
perlarg = newSViv((IV)arg);
else if (arg == NULL)
perlarg = &PL_sv_undef;
else if (strcmp(rec->args[n], "string") == 0)
perlarg = new_pv(arg);
else if (strcmp(rec->args[n], "ulongptr") == 0)
perlarg = newSViv(*(unsigned long *) arg);
else if (strcmp(rec->args[n], "intptr") == 0)
saved_args[n] = perlarg = newRV_noinc(newSViv(*(int *) arg));
else if (strncmp(rec->args[n], "gslist_", 7) == 0) {
/* linked list - push as AV */
GSList *tmp;
int is_iobject;
is_iobject = strcmp(rec->args[n]+7, "iobject") == 0;
av = newAV();
for (tmp = arg; tmp != NULL; tmp = tmp->next) {
sv = is_iobject ? iobject_bless((SERVER_REC *) tmp->data) :
irssi_bless_plain(rec->args[n]+7, tmp->data);
av_push(av, sv);
}
perlarg = newRV_noinc((SV *) av);
} else if (strcmp(rec->args[n], "iobject") == 0) {
/* "irssi object" - any struct that has
"int type; int chat_type" as it's first
variables (server, channel, ..) */
perlarg = iobject_bless((SERVER_REC *) arg);
} else if (strcmp(rec->args[n], "siobject") == 0) {
/* "simple irssi object" - any struct that has
int type; as it's first variable (dcc) */
perlarg = simple_iobject_bless((SERVER_REC *) arg);
} else {
/* blessed object */
perlarg = plain_bless(arg, rec->args[n]);
}
XPUSHs(sv_2mortal(perlarg));
}
PUTBACK;
perl_call_sv(func, G_EVAL|G_DISCARD);
SPAGAIN;
if (SvTRUE(ERRSV)) {
char *error = g_strdup(SvPV_nolen(ERRSV));
signal_emit("script error", 2, script, error);
g_free(error);
rec = NULL;
}
/* restore arguments the perl script modified */
for (n = 0; n < SIGNAL_MAX_ARGUMENTS &&
rec != NULL && rec->args[n] != NULL; n++) {
arg = (void *) args[n];
if (saved_args[n] == NULL)
continue;
if (strcmp(rec->args[n], "intptr") == 0) {
int *val = arg;
*val = SvIV(SvRV(saved_args[n]));
} else if (strncmp(rec->args[n], "glistptr_", 9) == 0) {
GList **ret = arg;
GList *out = NULL;
void *val;
int count;
av = (AV *) SvRV(saved_args[n]);
count = av_len(av);
while (count-- >= 0) {
sv = av_shift(av);
if (SvPOKp(sv))
val = g_strdup(SvPV_nolen(sv));
else
val = GINT_TO_POINTER(SvIV(sv));
out = g_list_append(out, val);
}
if (strcmp(rec->args[n]+9, "char*") == 0)
g_list_foreach(*ret, (GFunc) g_free, NULL);
g_list_free(*ret);
*ret = out;
}
}
FREETMPS;
LEAVE;
}
static FwRule *
fw_sv2c(SV *h, FwRule *ref)
{
if (ref && h && SvROK(h)) {
HV *hv = (HV *)SvRV(h);
memset(ref, 0, sizeof(FwRule));
if (hv_exists(hv, "fw_device", 9)) {
SV **r = hv_fetch(hv, "fw_device", 9, 0);
if (SvOK(*r)) {
memcpy(&(ref->fw_device), SvPV(*r, PL_na), sizeof(ref->fw_device));
}
}
if (hv_exists(hv, "fw_op", 5)) {
SV **r = hv_fetch(hv, "fw_op", 5, 0);
ref->fw_op = (SvOK(*r) ? SvIV(*r) : 0);
}
if (hv_exists(hv, "fw_dir", 6)) {
SV **r = hv_fetch(hv, "fw_dir", 6, 0);
ref->fw_dir = (SvOK(*r) ? SvIV(*r) : 0);
}
if (hv_exists(hv, "fw_proto", 8)) {
SV **r = hv_fetch(hv, "fw_proto", 8, 0);
ref->fw_proto = (SvOK(*r) ? SvIV(*r) : 0);
}
if (hv_exists(hv, "fw_src", 6)) {
SV **r = hv_fetch(hv, "fw_src", 6, 0);
if (SvOK(*r)) {
struct addr a;
if (addr_aton(SvPV(*r, PL_na), &a) == 0) {
memcpy(&(ref->fw_src), &a, sizeof(struct addr));
}
}
}
if (hv_exists(hv, "fw_dst", 6)) {
SV **r = hv_fetch(hv, "fw_dst", 6, 0);
if (SvOK(*r)) {
struct addr a;
if (addr_aton(SvPV(*r, PL_na), &a) == 0) {
memcpy(&(ref->fw_dst), &a, sizeof(struct addr));
}
}
}
if (hv_exists(hv, "fw_sport", 8)) {
SV **r = hv_fetch(hv, "fw_sport", 8, 0);
if (SvOK(*r)) {
AV *a = (AV *)SvRV(*r);
SV *p1 = av_shift(a);
SV *p2 = av_shift(a);
ref->fw_sport[0] = (SvOK(p1) ? SvIV(p1) : 0);
ref->fw_sport[1] = (SvOK(p2) ? SvIV(p2) : 0);
}
}
if (hv_exists(hv, "fw_dport", 8)) {
SV **r = hv_fetch(hv, "fw_dport", 8, 0);
if (SvOK(*r)) {
AV *a = (AV *)SvRV(*r);
SV *p1 = av_shift(a);
SV *p2 = av_shift(a);
ref->fw_dport[0] = (SvOK(p1) ? SvIV(p1) : 0);
ref->fw_dport[1] = (SvOK(p2) ? SvIV(p2) : 0);
}
}
}
else {
ref = NULL;
}
return ref;
}
THREAD_RET_TYPE
Perl_ithread_run(LPVOID arg) {
#else
void*
Perl_ithread_run(void * arg) {
#endif
ithread* thread = (ithread*) arg;
dTHXa(thread->interp);
PERL_SET_CONTEXT(thread->interp);
Perl_ithread_set(aTHX_ thread);
#if 0
/* Far from clear messing with ->thr child-side is a good idea */
MUTEX_LOCK(&thread->mutex);
#ifdef WIN32
thread->thr = GetCurrentThreadId();
#else
thread->thr = pthread_self();
#endif
MUTEX_UNLOCK(&thread->mutex);
#endif
PL_perl_destruct_level = 2;
{
AV* params = (AV*) SvRV(thread->params);
I32 len = av_len(params)+1;
int i;
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
for(i = 0; i < len; i++) {
XPUSHs(av_shift(params));
}
PUTBACK;
len = call_sv(thread->init_function, thread->gimme|G_EVAL);
SPAGAIN;
for (i=len-1; i >= 0; i--) {
SV *sv = POPs;
av_store(params, i, SvREFCNT_inc(sv));
}
if (SvTRUE(ERRSV)) {
Perl_warn(aTHX_ "thread failed to start: %" SVf, ERRSV);
}
FREETMPS;
LEAVE;
SvREFCNT_dec(thread->init_function);
}
PerlIO_flush((PerlIO*)NULL);
MUTEX_LOCK(&thread->mutex);
thread->state |= PERL_ITHR_FINISHED;
if (thread->state & PERL_ITHR_DETACHED) {
MUTEX_UNLOCK(&thread->mutex);
Perl_ithread_destruct(aTHX_ thread, "detached finish");
} else {
MUTEX_UNLOCK(&thread->mutex);
}
MUTEX_LOCK(&create_destruct_mutex);
active_threads--;
assert( active_threads >= 0 );
MUTEX_UNLOCK(&create_destruct_mutex);
#ifdef WIN32
return (DWORD)0;
#else
return 0;
#endif
}
value_type shift() {
return static_cast<value_type>(av_shift(impl()));
}
SV *p5_av_shift(PerlInterpreter *my_perl, AV *av) {
PERL_SET_CONTEXT(my_perl);
return av_shift(av);
}
