本文整理汇总了C++中PERL_SET_CONTEXT函数的典型用法代码示例。如果您正苦于以下问题:C++ PERL_SET_CONTEXT函数的具体用法?C++ PERL_SET_CONTEXT怎么用?C++ PERL_SET_CONTEXT使用的例子?那么, 这里精选的函数代码示例或许可以为您提供帮助。
在下文中一共展示了PERL_SET_CONTEXT函数的15个代码示例,这些例子默认根据受欢迎程度排序。您可以为喜欢或者感觉有用的代码点赞,您的评价将有助于系统推荐出更棒的C++代码示例。
示例1: PERL_SET_CONTEXT
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;
}
示例2: PERL_SET_CONTEXT
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;
}
示例3: PERL_SET_CONTEXT
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;
}
示例4: perl_xlat
/*
* 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;
}
示例5: h3
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);
}
示例6: weechat_perl_unload
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);
}
示例7: execute_perl
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;
}
示例8: check_perl_interpreter
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;
}
示例9: load_perl_plugin
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;
}
示例10: PERL_SET_CONTEXT
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;
}
}
示例11: p5_av_unshift
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);
}
示例12: ngx_http_psgi_perl_init_worker
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;
}
示例13: ngx_http_perl_set
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;
}
示例14: campher_get_sv_string
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;
}
示例15: campher_call_sv_void
// 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;
}