static PerlInterpreter *rlm_perl_clone(PerlInterpreter *perl)
{
PerlInterpreter *interp;
UV clone_flags = 0;
PERL_SET_CONTEXT(perl);
pthread_once(&rlm_perl_once, rlm_perl_make_key);
interp = pthread_getspecific(rlm_perl_key);
if (interp) return interp;
interp = perl_clone(perl, clone_flags);
{
dTHXa(interp);
}
#if PERL_REVISION >= 5 && PERL_VERSION <8
call_pv("CLONE",0);
#endif
ptr_table_free(PL_ptr_table);
PL_ptr_table = NULL;
PERL_SET_CONTEXT(aTHX);
rlm_perl_clear_handles(aTHX);
pthread_setspecific(rlm_perl_key, interp);
fprintf(stderr, "GOT CLONE %d %p\n", pthread_self(), interp);
return interp;
}
static PerlInterpreter *rlm_perl_clone(PerlInterpreter *perl, pthread_key_t *key)
{
PerlInterpreter *interp;
UV clone_flags = 0;
PERL_SET_CONTEXT(perl);
interp = pthread_getspecific(*key);
if (interp) return interp;
interp = perl_clone(perl, clone_flags);
{
dTHXa(interp);
}
#if PERL_REVISION >= 5 && PERL_VERSION <8
call_pv("CLONE",0);
#endif
ptr_table_free(PL_ptr_table);
PL_ptr_table = NULL;
PERL_SET_CONTEXT(aTHX);
rlm_perl_clear_handles(aTHX);
pthread_setspecific(*key, interp);
return interp;
}
static PerlInterpreter *rlm_perl_clone(PerlInterpreter *perl, pthread_key_t *key)
{
int ret;
PerlInterpreter *interp;
UV clone_flags = 0;
PERL_SET_CONTEXT(perl);
interp = pthread_getspecific(*key);
if (interp) return interp;
interp = perl_clone(perl, clone_flags);
{
dTHXa(interp);
}
# if PERL_REVISION >= 5 && PERL_VERSION <8
call_pv("CLONE",0);
# endif
ptr_table_free(PL_ptr_table);
PL_ptr_table = NULL;
PERL_SET_CONTEXT(aTHX);
rlm_perl_clear_handles(aTHX);
ret = pthread_setspecific(*key, interp);
if (ret != 0) {
DEBUG("Failed associating interpretor with thread %s", fr_syserror(ret));
rlm_perl_destruct(interp);
return NULL;
}
return interp;
}
/*
* The xlat function
*/
static ssize_t perl_xlat(void *instance, REQUEST *request, char const *fmt, char *out, size_t freespace)
{
rlm_perl_t *inst= (rlm_perl_t *) instance;
char *tmp;
char const *p, *q;
int count;
size_t ret = 0;
STRLEN n_a;
#ifdef USE_ITHREADS
PerlInterpreter *interp;
pthread_mutex_lock(&inst->clone_mutex);
interp = rlm_perl_clone(inst->perl, inst->thread_key);
{
dTHXa(interp);
PERL_SET_CONTEXT(interp);
}
pthread_mutex_unlock(&inst->clone_mutex);
#else
PERL_SET_CONTEXT(inst->perl);
#endif
{
dSP;
ENTER;SAVETMPS;
PUSHMARK(SP);
p = fmt;
while ((q = strchr(p, ' '))) {
XPUSHs(sv_2mortal(newSVpv(p, p - q)));
p = q + 1;
}
PUTBACK;
count = call_pv(inst->func_xlat, G_SCALAR | G_EVAL);
SPAGAIN;
if (SvTRUE(ERRSV)) {
REDEBUG("Exit %s", SvPV(ERRSV,n_a));
(void)POPs;
} else if (count > 0) {
tmp = POPp;
strlcpy(out, tmp, freespace);
ret = strlen(out);
RDEBUG("Len is %zu , out is %s freespace is %zu", ret, out, freespace);
}
PUTBACK ;
FREETMPS ;
LEAVE ;
}
return ret;
}
void h3(void *arg) {
int argc = 3;
char *argv[] = { "", "-e", "use Data::Dumper;"
"sub dump_perl { print STDERR Data::Dumper::Dumper([shift]); }",
NULL };
char *env[] = { NULL };
void *original_context = PERL_GET_CONTEXT;
SV *sv;
PERL_SYS_INIT3(&argc,&argv,&env);
my_perl = perl_alloc();
sv = newRV_inc(newSViv(5));
PERL_SET_CONTEXT(my_perl);
perl_construct(my_perl);
perl_parse(my_perl, mine_xs_init, argc, argv, NULL);
call_dump_perl(sv);
perl_destruct(my_perl);
perl_free(my_perl);
PERL_SET_CONTEXT(original_context);
}
void
weechat_perl_unload (struct t_plugin_script *script)
{
int *rc;
void *interpreter;
char *filename;
if ((weechat_perl_plugin->debug >= 2) || !perl_quiet)
{
weechat_printf (NULL,
weechat_gettext ("%s: unloading script \"%s\""),
PERL_PLUGIN_NAME, script->name);
}
#ifdef MULTIPLICITY
PERL_SET_CONTEXT (script->interpreter);
#endif /* MULTIPLICITY */
if (script->shutdown_func && script->shutdown_func[0])
{
rc = (int *)weechat_perl_exec (script,
WEECHAT_SCRIPT_EXEC_INT,
script->shutdown_func,
NULL, NULL);
if (rc)
free (rc);
}
filename = strdup (script->filename);
interpreter = script->interpreter;
if (perl_current_script == script)
{
perl_current_script = (perl_current_script->prev_script) ?
perl_current_script->prev_script : perl_current_script->next_script;
}
plugin_script_remove (weechat_perl_plugin, &perl_scripts, &last_perl_script,
script);
#ifdef MULTIPLICITY
if (interpreter)
{
perl_destruct (interpreter);
perl_free (interpreter);
}
if (perl_current_script)
{
PERL_SET_CONTEXT (perl_current_script->interpreter);
}
#else
if (interpreter)
free (interpreter);
#endif /* MULTIPLICITY */
(void) weechat_hook_signal_send ("perl_script_unloaded",
WEECHAT_HOOK_SIGNAL_STRING, filename);
if (filename)
free (filename);
}
int execute_perl( const char *function, char **args, char *data ) {
int count = 0, i, ret_value = 1;
STRLEN na;
SV *sv_args[0];
dSP;
PERL_SET_CONTEXT( my_perl );
/*
* Set up the perl environment, push arguments onto the perl stack, then
* call the given function
*/
SPAGAIN;
ENTER;
SAVETMPS;
PUSHMARK( sp );
for ( i = 0; i < ( int )sizeof( args ) - 1; i++ ) {
if ( args[i] != NULL ) {
sv_args[i] = sv_2mortal( newSVpv( args[i], 0 ) );
XPUSHs( sv_args[i] );
}
}
PUTBACK;
PERL_SET_CONTEXT( my_perl );
count = call_pv( function, G_EVAL | G_SCALAR );
SPAGAIN;
/*
* Check for "die," make sure we have 1 argument, and set our return value
*/
if ( SvTRUE( ERRSV ) ) {
sprintf( data,
"%sPerl function (%s) exited abnormally: %s",
( loaded ? "ERR " : "" ), function, SvPV( ERRSV, na ) );
( void )POPs;
}
else if ( count != 1 ) {
/*
* This should NEVER happen. G_SCALAR ensures that we WILL have 1
* parameter
*/
sprintf( data,
"%sPerl error executing '%s': expected 1 return value; received %s",
( loaded ? "ERR " : "" ), function, count );
}
else {
sprintf( data, "%s%s", ( loaded ? "OK " : "" ), POPpx );
}
/* Check for changed arguments */
for ( i = 0; i < ( int )sizeof( args ) - 1; i++ ) {
if ( args[i] && strcmp( args[i], SvPVX( sv_args[i] ) ) ) {
args[i] = strdup( SvPV( sv_args[i], na ) );
}
}
PUTBACK;
FREETMPS;
LEAVE;
return ret_value;
}
static int
check_perl_interpreter (char *err, int max_len)
{
int ret = 0;
PerlInterpreter *intrp;
char *embedding[] = { "CGI", "-e",
"use Config;\n"
"use DynaLoader;\n"
/* "print STDERR 'loading ['.$Config{archlibexp}.'/CORE/'.$Config{libperl}.']\n';\n"*/
#if !defined (__APPLE__)
"DynaLoader::dl_load_file ($Config{archlibexp}.'/CORE/'.$Config{libperl},0x01);\n"
#endif
};
#ifdef MY_ENV
char *envp[] = {
NULL
};
#else
char **envp = NULL;
#endif
if (NULL == (intrp = perl_alloc()))
{
SET_ERR ("Unable to allocate perl interpreter");
return ret;
}
{
dTHX;
perl_construct(intrp);
PERL_SET_CONTEXT(intrp);
if (0 == perl_parse(intrp, xs_init, 3, embedding, envp))
{
PERL_SET_CONTEXT(intrp);
if (0 == perl_run(intrp))
ret = 1;
else
{
SET_ERR ("Unable to run the perl interpreter");
ret = 0;
}
}
else
{
SET_ERR ("Unable to parse virt_handler.pl");
ret = 0;
}
#ifdef PERL_EXIT_DESTRUCT_END
PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
#endif
perl_destruct (intrp);
perl_free (intrp);
}
return ret;
}
static gboolean
load_perl_plugin(PurplePlugin *plugin)
{
PurplePerlScript *gps = (PurplePerlScript *)plugin->info->extra_info;
char *atmp[3] = { plugin->path, NULL, NULL };
if (gps == NULL || gps->load_sub == NULL)
return FALSE;
purple_debug(PURPLE_DEBUG_INFO, "perl", "Loading perl script\n");
if (my_perl == NULL)
perl_init();
plugin->handle = gps;
atmp[1] = gps->package;
PERL_SET_CONTEXT(my_perl);
execute_perl("Purple::PerlLoader::load_n_eval", 2, atmp);
{
dSP;
PERL_SET_CONTEXT(my_perl);
SPAGAIN;
ENTER;
SAVETMPS;
PUSHMARK(sp);
XPUSHs(sv_2mortal(purple_perl_bless_object(plugin,
"Purple::Plugin")));
PUTBACK;
perl_call_pv(gps->load_sub, G_EVAL | G_SCALAR);
SPAGAIN;
if (SvTRUE(ERRSV)) {
STRLEN len;
purple_debug(PURPLE_DEBUG_ERROR, "perl",
"Perl function %s exited abnormally: %s\n",
gps->load_sub, SvPV(ERRSV, len));
}
PUTBACK;
FREETMPS;
LEAVE;
}
return TRUE;
}
SV *p5_wrap_p6_handle(PerlInterpreter *my_perl, IV i, SV *p5obj) {
PERL_SET_CONTEXT(my_perl);
{
SV *handle = p5_wrap_p6_object(my_perl, i, p5obj);
int flags = G_SCALAR;
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(newSVpv("Perl6::Handle", 0));
XPUSHs(handle);
PUTBACK;
call_method("new", flags);
SPAGAIN;
SV *tied_handle = POPs;
SvREFCNT_inc(tied_handle);
PUTBACK;
FREETMPS;
LEAVE;
return tied_handle;
}
}
SV *p5_call_code_ref(PerlInterpreter *my_perl, SV *code_ref, int len, SV *args[], I32 *count, I32 *err, I32 *type) {
PERL_SET_CONTEXT(my_perl);
{
dSP;
SV * retval = NULL;
int flags = G_ARRAY | G_EVAL;
ENTER;
SAVETMPS;
PUSHMARK(SP);
push_arguments(sp, len, args);
*count = call_sv(code_ref, flags);
SPAGAIN;
handle_p5_error(err);
retval = pop_return_values(my_perl, sp, *count, type);
FREETMPS;
LEAVE;
return retval;
}
}
SV *p5_scalar_call_gv_two_args(PerlInterpreter *my_perl, GV *gv, SV *arg, SV *arg2, I32 *count, I32 *type, I32 *err) {
PERL_SET_CONTEXT(my_perl);
{
dSP;
SV * retval = NULL;
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs((SV*)arg);
XPUSHs((SV*)arg2);
PUTBACK;
SV * const rv = sv_2mortal(newRV((SV*)GvCV(gv)));
*count = call_sv(rv, G_SCALAR | G_EVAL);
SPAGAIN;
handle_p5_error(err);
if (*err)
fprintf(stderr, "err: %d\n", *err);
retval = pop_return_values(my_perl, sp, *count, type);
SPAGAIN;
PUTBACK;
FREETMPS;
LEAVE;
return retval;
}
}
SV *p5_call_package_method(PerlInterpreter *my_perl, char *package, char *name, int len, SV *args[], I32 *count, I32 *err, I32 *type) {
PERL_SET_CONTEXT(my_perl);
{
dSP;
SV * retval = NULL;
int flags = G_ARRAY | G_EVAL;
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(newSVpv(package, 0));
push_arguments(sp, len, args);
*count = call_method(name, flags);
SPAGAIN;
handle_p5_error(err);
retval = pop_return_values(my_perl, sp, *count, type);
FREETMPS;
LEAVE;
return retval;
}
}
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);
}
ngx_int_t
ngx_http_psgi_perl_init_worker(ngx_cycle_t *cycle)
{
ngx_http_psgi_main_conf_t *psgimcf =
ngx_http_cycle_get_module_main_conf(cycle, ngx_http_psgi_module);
ngx_log_debug1(NGX_LOG_DEBUG_HTTP, cycle->log, 0,
"Init Perl interpreter in worker %d", ngx_pid);
if (psgimcf) {
dTHXa(psgimcf->perl);
PERL_SET_CONTEXT(psgimcf->perl);
/* FIXME: It looks very wrong.
* Has new worker it's own Perl instance?
* I think I should perl_clone() or something like that
* Also $0 (script path) should be set somewhere.
* I don't think it's right place for it. It should be done somewhere in local conf init stuff
* Or, if many handlers share single Perl interpreter - before each handler call
*
* TODO
* Test PID and related stuff
* Test what happens if user try to change
* Test what happens if user does 'fork' inside PSGI app
*/
sv_setiv(GvSV(gv_fetchpv("$$", TRUE, SVt_PV)), (I32) ngx_pid);
} else {
ngx_log_error(NGX_LOG_ALERT, cycle->log, 0, "PSGI panic: no main configuration supplied for init worker %d", ngx_pid);
return NGX_ERROR;
}
return NGX_OK;
}
static char *
ngx_http_perl_set(ngx_conf_t *cf, ngx_command_t *cmd, void *conf)
{
ngx_int_t index;
ngx_str_t *value;
ngx_http_variable_t *v;
ngx_http_perl_variable_t *pv;
ngx_http_perl_main_conf_t *pmcf;
value = cf->args->elts;
if (value[1].data[0] != '$')
{
ngx_conf_log_error(NGX_LOG_EMERG, cf, 0,
"invalid variable name \"%V\"", &value[1]);
return NGX_CONF_ERROR;
}
value[1].len--;
value[1].data++;
v = ngx_http_add_variable(cf, &value[1], NGX_HTTP_VAR_CHANGEABLE);
if (v == NULL)
{
return NGX_CONF_ERROR;
}
pv = ngx_palloc(cf->pool, sizeof(ngx_http_perl_variable_t));
if (pv == NULL)
{
return NGX_CONF_ERROR;
}
index = ngx_http_get_variable_index(cf, &value[1]);
if (index == NGX_ERROR)
{
return NGX_CONF_ERROR;
}
pmcf = ngx_http_conf_get_module_main_conf(cf, ngx_http_perl_module);
if (pmcf->perl == NULL)
{
if (ngx_http_perl_init_interpreter(cf, pmcf) != NGX_CONF_OK)
{
return NGX_CONF_ERROR;
}
}
pv->handler = value[2];
{
dTHXa(pmcf->perl);
PERL_SET_CONTEXT(pmcf->perl);
ngx_http_perl_eval_anon_sub(aTHX_ & value[2], &pv->sub);
if (pv->sub == &PL_sv_undef)
{
ngx_conf_log_error(NGX_LOG_ERR, cf, 0,
"eval_pv(\"%V\") failed", &value[2]);
return NGX_CONF_ERROR;
}
if (pv->sub == NULL)
{
pv->sub = newSVpvn((char *) value[2].data, value[2].len);
}
}
v->get_handler = ngx_http_perl_variable;
v->data = (uintptr_t) pv;
return NGX_CONF_OK;
}
static void campher_get_sv_string(PerlInterpreter* my_perl, SV* sv, char** out_char, int* out_len) {
PERL_SET_CONTEXT(my_perl);
STRLEN len;
char* c = SvPVutf8x(sv, len);
*out_char = c;
*out_len = len;
}
// arg is NULL-terminated and caller must free.
static void campher_call_sv_void(PerlInterpreter* my_perl, SV* sv, SV** arg) {
PERL_SET_CONTEXT(my_perl);
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
if (arg != NULL) {
while (*arg != NULL) {
XPUSHs(*arg);
arg++;
}
}
PUTBACK;
I32 ret = call_sv(sv, G_VOID);
if (ret != 0) {
assert(false);
}
FREETMPS;
LEAVE;
}
void clear_perl(void *nothing) {
dTHX;
/* warn ("destroying perl engine %x", my_perl); */
perl_destruct(my_perl);
perl_free(my_perl);
PERL_SET_CONTEXT(NULL);
}
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;
}
// arg is NULL-terminated and caller must free.
static void campher_call_sv_scalar(PerlInterpreter* my_perl, SV* sv, SV** arg, SV** ret) {
PERL_SET_CONTEXT(my_perl);
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
if (arg != NULL) {
while (*arg != NULL) {
XPUSHs(*arg);
arg++;
}
}
PUTBACK;
I32 count = call_sv(sv, G_SCALAR);
// TOD: deal with error flag. will just crash process for now.
SPAGAIN;
if (count != 1) {
croak("expected 1 in campher_call_sv_scalar");
}
SV* result = POPs;
SvREFCNT_inc(result);
*ret = result;
PUTBACK;
FREETMPS;
LEAVE;
}
int main(int argc, char **argv, char **env)
{
//if (argc < 2) {
// fprintf(stderr, "you must specify at least one argument\n");
// exit(0);
//}
pthread_t threads[NUM_THREADS];
pthread_mutex_init(&mutex_perl, NULL);
PERL_SYS_INIT3(&argc,&argv,&env);
char *my_argv[] = { "", PERL_SCRIPT };
my_perl = perl_alloc();
PERL_SET_CONTEXT(my_perl);
perl_construct(my_perl);
perl_parse(my_perl, NULL, 2, my_argv, (char **)NULL);
PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
perl_run(my_perl);
int t;
for (t=0; t<NUM_THREADS; t++) {
printf("creating thread %d\n", t);
(void)pthread_create(&threads[t], NULL, thread_context, (void *)t);
}
for (t=0;t<NUM_THREADS;t++) {
(void)pthread_join(threads[t], NULL);
printf("joined thread %d\n", t);
}
perl_destruct(my_perl);
perl_free(my_perl);
pthread_exit(NULL);
pthread_mutex_destroy(&mutex_perl);
PERL_SYS_TERM();
}
PerlStack PerlInterface::sub(const char* functionName){
PERL_SET_CONTEXT(my_perl);
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);//remember the stack pointer
while(!isEmpty()){
XPUSHs(sv_2mortal(getSV()));
}
PUTBACK;
unsigned numberOfReturns = call_pv(functionName, G_ARRAY);
SPAGAIN;
PerlStack returnStack(perlManager);
for(unsigned i=0; i < numberOfReturns; ++i){
returnStack.pushFront(POPs);//get SV returned from the sub and push it to the stack
}
PUTBACK;
FREETMPS; //free the return values
LEAVE;
return returnStack;
}
void p5_av_store(PerlInterpreter *my_perl, AV *av, I32 key, SV *val) {
PERL_SET_CONTEXT(my_perl);
SvREFCNT_inc(val);
if (av_store(av, key, val) == NULL)
SvREFCNT_dec(val);
return;
}
/* lazily maintain 1:1 mapping between tcl and perl interpreters */
perl_context *nsperl2_get_assoc_perl_context (Tcl_Interp *interp)
{
extern perl_master_context *nsperl2_master_context;
assert (nsperl2_master_context);
perl_context *context = Tcl_GetAssocData (interp, "nsperl2:perl_context", NULL);
PerlInterpreter *perl_interp;
if(context)
return context;
Ns_Log (Notice, "cloning perl interpreter for tcl interp");
PERL_SET_CONTEXT (nsperl2_master_context->perl_master_interp);
if ((perl_interp = perl_clone (nsperl2_master_context->perl_master_interp, CLONEf_KEEP_PTR_TABLE)) == NULL) {
Ns_Log (Error, "Couldn't clone perl interp");
return NULL;
}
/* save the perl interp */
context = ns_malloc (sizeof(perl_context));
context->perl_interp = perl_interp;
Tcl_SetAssocData(interp, "nsperl2:perl_context", nsperl2_delete_assoc_perl, context);
return context;
}
static void rlm_perl_destruct(PerlInterpreter *perl)
{
dTHXa(perl);
PERL_SET_CONTEXT(perl);
PL_perl_destruct_level = 2;
PL_origenviron = environ;
{
dTHXa(perl);
}
/*
* FIXME: This shouldn't happen
*
*/
while (PL_scopestack_ix > 1) {
LEAVE;
}
perl_destruct(perl);
perl_free(perl);
}
thread_ctx*
get_thread_ctx(void)
{
thread_ctx* ctx;
#ifdef WIN32
ctx = (thread_ctx*)TlsGetValue(thrd_ctx_key);
#else
ctx = (thread_ctx*)pthread_getspecific(thrd_ctx_key);
#endif
if (!ctx) {
refcounted_perl* p = (refcounted_perl*)PyMem_Malloc(sizeof(refcounted_perl));
ctx = (thread_ctx*)PyMem_Malloc(sizeof(thread_ctx));
if (!p || !ctx) {
Py_FatalError("Can't allocate memory for thread context");
}
/* fprintf(stderr, "Allocated new thread context %p\n", ctx); */
memset(ctx, 0, sizeof(thread_ctx));
p->my_perl = new_perl();
p->refcnt = 0;
p->thread_done = 0;
PERL_SET_CONTEXT(p->my_perl);
ctx->perl = p;
#ifdef WIN32
TlsSetValue(thrd_ctx_key, (void*)ctx);
#else
pthread_setspecific(thrd_ctx_key, (void*)ctx);
#endif
}
return ctx;
}
isc_result_t
dlz_allowzonexfr(void *dbdata, const char *name, const char *client) {
config_data_t *cd = (config_data_t *) dbdata;
int r;
isc_result_t retval;
#ifdef MULTIPLICITY
PerlInterpreter *my_perl = cd->perl;
#endif
dSP;
PERL_SET_CONTEXT(cd->perl);
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(cd->perl_class);
XPUSHs(sv_2mortal(newSVpv(name, 0)));
XPUSHs(sv_2mortal(newSVpv(client, 0)));
PUTBACK;
r = call_method("allowzonexfr", G_SCALAR|G_EVAL);
SPAGAIN;
if (SvTRUE(ERRSV)) {
/*
* On error there's an undef at the top of the stack. Pop
* it away so we don't leave junk on the stack for the next
* caller.
*/
POPs;
cd->log(ISC_LOG_ERROR,
"DLZ Perl: allowzonexfr died in eval: %s",
SvPV_nolen(ERRSV));
retval = ISC_R_FAILURE;
} else if (r == 0) {
/* Client returned nothing -- zone not found. */
retval = ISC_R_NOTFOUND;
} else if (r > 1) {
/* Once again, clean out the stack when possible. */
while (r--) POPi;
cd->log(ISC_LOG_ERROR,
"DLZ Perl: allowzonexfr returned too many parameters!");
retval = ISC_R_FAILURE;
} else {
/*
* Client returned true/false -- we're authoritative for
* the zone.
*/
r = POPi;
if (r)
retval = ISC_R_SUCCESS;
else
retval = ISC_R_NOPERM;
}
PUTBACK;
FREETMPS;
LEAVE;
return (retval);
}
char *p5_sv_to_char_star(PerlInterpreter *my_perl, SV *sv) {
PERL_SET_CONTEXT(my_perl);
{
STRLEN len;
char * const pv = SvPV(sv, len);
return pv;
}
}
STRLEN p5_sv_to_buf(PerlInterpreter *my_perl, SV *sv, char **buf) {
PERL_SET_CONTEXT(my_perl);
{
STRLEN len;
*buf = SvPV(sv, len);
return len;
}
}