示例#1
1
/***********************************************************************************************************************************
Execute main function in Perl
***********************************************************************************************************************************/
int
perlExec(void)
{
    FUNCTION_LOG_VOID(logLevelDebug);

    // Initialize Perl
    perlInit();

    // Run perl main function
    perlEval(perlMain());

    // Return result code
    int code = (int)SvIV(get_sv("iResult", 0));
    bool errorC = (int)SvIV(get_sv("bErrorC", 0));
    char *message = SvPV_nolen(get_sv("strMessage", 0));                            // {uncovered - internal Perl macro branch}

    if (code >= errorTypeCode(&AssertError))                                        // {uncovered - success tested in integration}
    {
        if (errorC)                                                                 // {+uncovered}
            RETHROW();                                                              // {+uncovered}
        else
            THROW_CODE(code, strlen(message) == 0 ? PERL_EMBED_ERROR : message);    // {+uncovered}
    }

    FUNCTION_LOG_RETURN(INT, code);                                               // {+uncovered}
}
示例#2
0
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());
	}
}
示例#3
0
static perl_parse_and_execute(PerlInterpreter * my_perl, char *input_code, char *setup_code)
{
	int error = 0;

	if (*input_code == '~') {
		char *buff = input_code + 1;
		perl_parse(my_perl, xs_init, 3, embedding, NULL);
		if (setup_code)
			Perl_safe_eval(my_perl, setup_code);
		Perl_safe_eval(my_perl, buff);
	} else {
		int argc = 0;
		char *argv[128] = { 0 };
		char *err;
		argv[0] = "FreeSWITCH";
		argc++;

		argc += switch_separate_string(input_code, ' ', &argv[1], (sizeof(argv) / sizeof(argv[0])) - 1);
		if (!perl_parse(my_perl, xs_init, argc, argv, (char **) NULL)) {
			if (setup_code) {
				if (!Perl_safe_eval(my_perl, setup_code)) {
					perl_run(my_perl);
				}
			}
		}

		if ((err = SvPV(get_sv("@", TRUE), n_a)) && !zstr(err)) {
			switch_log_printf(SWITCH_CHANNEL_LOG, SWITCH_LOG_ERROR, "%s\n", err);
		}


	}
}
示例#4
0
// A helper routine to get default for APPNAME.
static BSTR get_scriptname () {
   // Get the name of the script, taken from Perl var $0. This is used as
   // the default application name in SQL Server.

   SV* sv;

   if (sv = get_sv("0", FALSE))
   {
      // Get script name into a BSTR.
      BSTR tmp = SV_to_BSTR(sv);
      BSTR scriptname;
      WCHAR *p;

      // But this name is full path, and we want only the trailing bit.
      if (p = wcsrchr(tmp, '/'))
         ++p;
      else if (p = wcsrchr(tmp, '\\'))
         ++p;
      else if (p = wcsrchr(tmp, ':'))
          ++p;
      else
          p = tmp;

      scriptname = SysAllocString(p);
      SysFreeString(tmp);
      return scriptname;
   }
   else {
      return NULL;
   }
}
示例#5
0
MP_INLINE static void
modperl_io_perlio_restore_stdhandle(pTHX_ int mode)
{
    GV *handle_orig = gv_fetchpv(mode == O_RDONLY ? "STDIN" : "STDOUT",
                                 FALSE, SVt_PVIO);

    MP_TRACE_o(MP_FUNC, "start STD%s", mode == O_RDONLY ? "IN" : "OUT");

    /* since closing unflushed STDOUT may trigger a subrequest
     * (e.g. via mod_include), resulting in potential another response
     * handler call, which may try to close STDOUT too. We will
     * segfault, if that subrequest doesn't return before the the top
     * level STDOUT is attempted to be closed. To prevent this
     * situation always explicitly flush STDOUT, before reopening it.
     */
    if (mode != O_RDONLY &&
        GvIOn(handle_orig) && IoOFP(GvIOn(handle_orig)) &&
        (PerlIO_flush(IoOFP(GvIOn(handle_orig))) == -1)) {
        Perl_croak(aTHX_ "Failed to flush STDOUT: %" SVf, get_sv("!", TRUE));
    }

    /* close the overriding filehandle */
    do_close(handle_orig, FALSE);

    MP_TRACE_o(MP_FUNC, "end STD%s", mode == O_RDONLY ? "IN" : "OUT");
}
示例#6
0
static void
dl_generic_private_init(pTHX)	/* called by dl_*.xs dl_private_init() */
{
    char *perl_dl_nonlazy;
    MY_CXT_INIT;

    MY_CXT.x_dl_last_error = newSVpvn("", 0);
    dl_nonlazy = 0;
#ifdef DL_LOADONCEONLY
    dl_loaded_files = Nullhv;
#endif
#ifdef DEBUGGING
    {
        SV *sv = get_sv("DynaLoader::dl_debug", 0);
        dl_debug = sv ? SvIV(sv) : 0;
    }
#endif
    if ( (perl_dl_nonlazy = getenv("PERL_DL_NONLAZY")) != NULL )
        dl_nonlazy = atoi(perl_dl_nonlazy);
    if (dl_nonlazy)
        DLDEBUG(1,PerlIO_printf(Perl_debug_log, "DynaLoader bind mode is 'non-lazy'\n"));
#ifdef DL_LOADONCEONLY
    if (!dl_loaded_files)
        dl_loaded_files = newHV(); /* provide cache for dl_*.xs if needed */
#endif
#ifdef DL_UNLOAD_ALL_AT_EXIT
    call_atexit(&dl_unload_all_files, (void*)0);
#endif
}
示例#7
0
static void
init_help_consts (void)
{
	/* Export our constants as global variables.  */
	const struct {
		const char *name;
		int value;
	} consts[] = {
		{ "GNM_FUNC_HELP_NAME", GNM_FUNC_HELP_NAME },
		{ "GNM_FUNC_HELP_ARG", GNM_FUNC_HELP_ARG },
		{ "GNM_FUNC_HELP_DESCRIPTION", GNM_FUNC_HELP_DESCRIPTION },
		{ "GNM_FUNC_HELP_NOTE", GNM_FUNC_HELP_NOTE },
		{ "GNM_FUNC_HELP_EXAMPLES", GNM_FUNC_HELP_EXAMPLES },
		{ "GNM_FUNC_HELP_SEEALSO", GNM_FUNC_HELP_SEEALSO },
		{ "GNM_FUNC_HELP_EXTREF", GNM_FUNC_HELP_EXTREF },
		{ "GNM_FUNC_HELP_EXCEL", GNM_FUNC_HELP_EXCEL },
		{ "GNM_FUNC_HELP_ODF", GNM_FUNC_HELP_ODF }
	};
	unsigned ui;

	for (ui = 0; ui < G_N_ELEMENTS (consts); ui++) {
		SV* x = get_sv (consts[ui].name, TRUE);
		sv_setiv (x, consts[ui].value);
	}
}
示例#8
0
/*
 *	This is a wraper for radius_axlat
 *	Now users are able to get data that is accessible only via xlat
 *	e.g. %{client:...}
 *	Call syntax is radiusd::xlat(string), string will be handled the
 *	same way it is described in EXPANSIONS section of man unlang
 */
static XS(XS_radiusd_xlat)
{
	dXSARGS;
	char *in_str;
	char *expanded;
	ssize_t slen;
	SV *rad_requestp_sv;
	REQUEST *request;

	if (items != 1) croak("Usage: radiusd::xlat(string)");

	rad_requestp_sv = get_sv("RAD___REQUESTP", 0);
	if (rad_requestp_sv == NULL) croak("Can not evalue xlat, RAD___REQUESTP is not set!");

	request = INT2PTR(REQUEST *, SvIV(rad_requestp_sv));

	in_str = (char *) SvPV(ST(0), PL_na);
	expanded = NULL;
	slen = radius_axlat(&expanded, request, in_str, NULL, NULL);

	if (slen < 0) {
		REDEBUG("Error parsing xlat '%s'", in_str);
		XSRETURN_UNDEF;
	}


	XST_mPV(0, expanded);
	talloc_free(expanded);
	XSRETURN(1);
}
示例#9
0
static JSBool
PerlArray(
    JSContext *cx,
    JSObject *obj,
    uintN argc,
    jsval *argv,
    jsval *rval
) {
    dTHX;
    AV *av = newAV();
    SV *ref = newRV_noinc((SV *)av);
    uintN arg;
    JSBool ok = JS_FALSE;
    SV *sv;

    /* If the path fails, the object will be finalized */
    JS_SetPrivate(cx, obj, (void *)newRV(&PL_sv_undef));

    av_extend(av, argc);
    for(arg = 0; arg < argc; arg++) {
	if(!PJS_ReflectJS2Perl(aTHX_ cx, argv[arg], &sv, 1) ||
	   !av_store(av, arg, sv)) goto fail;
    }

    if(SvTRUE(get_sv(NAMESPACE"PerlArray::construct_blessed", 0)))
	sv_bless(ref, gv_stashpv(PerlArrayPkg,0));

    ok = PJS_CreateJSVis(aTHX_ cx, obj, ref) != NULL;
    fail:
    sv_free(ref);
    return ok;
}
示例#10
0
/* xs_init is the second argument perl_parse. As the name hints, it
   initializes XS subroutines (see the perlembed manpage) */
static void
xs_init (pTHX)
{
	HV *stash;
	SV *version;
	/* This one allows dynamic loading of perl modules in perl
	   scripts by the 'use perlmod;' construction */
	newXS ("DynaLoader::boot_DynaLoader", boot_DynaLoader, __FILE__);
	/* load up all the custom IRC perl functions */
	newXS ("Xchat::Internal::register", XS_Xchat_register, __FILE__);
	newXS ("Xchat::Internal::hook_server", XS_Xchat_hook_server, __FILE__);
	newXS ("Xchat::Internal::hook_command", XS_Xchat_hook_command, __FILE__);
	newXS ("Xchat::Internal::hook_print", XS_Xchat_hook_print, __FILE__);
	newXS ("Xchat::Internal::hook_timer", XS_Xchat_hook_timer, __FILE__);
	newXS ("Xchat::Internal::hook_fd", XS_Xchat_hook_fd, __FILE__);
	newXS ("Xchat::Internal::unhook", XS_Xchat_unhook, __FILE__);
	newXS ("Xchat::Internal::print", XS_Xchat_print, __FILE__);
	newXS ("Xchat::Internal::command", XS_Xchat_command, __FILE__);
	newXS ("Xchat::Internal::set_context", XS_Xchat_set_context, __FILE__);
	newXS ("Xchat::Internal::get_info", XS_Xchat_get_info, __FILE__);
	newXS ("Xchat::Internal::context_info", XS_Xchat_context_info, __FILE__);
	newXS ("Xchat::Internal::get_list", XS_Xchat_get_list, __FILE__);
	
	newXS ("Xchat::find_context", XS_Xchat_find_context, __FILE__);
	newXS ("Xchat::get_context", XS_Xchat_get_context, __FILE__);
	newXS ("Xchat::get_prefs", XS_Xchat_get_prefs, __FILE__);
	newXS ("Xchat::emit_print", XS_Xchat_emit_print, __FILE__);
	newXS ("Xchat::send_modes", XS_Xchat_send_modes, __FILE__);
	newXS ("Xchat::nickcmp", XS_Xchat_nickcmp, __FILE__);

	newXS ("Xchat::Embed::plugingui_remove", XS_Xchat_Embed_plugingui_remove,
			 __FILE__);

	stash = get_hv ("Xchat::", TRUE);
	if (stash == NULL) {
		exit (1);
	}

	newCONSTSUB (stash, "PRI_HIGHEST", newSViv (XCHAT_PRI_HIGHEST));
	newCONSTSUB (stash, "PRI_HIGH", newSViv (XCHAT_PRI_HIGH));
	newCONSTSUB (stash, "PRI_NORM", newSViv (XCHAT_PRI_NORM));
	newCONSTSUB (stash, "PRI_LOW", newSViv (XCHAT_PRI_LOW));
	newCONSTSUB (stash, "PRI_LOWEST", newSViv (XCHAT_PRI_LOWEST));

	newCONSTSUB (stash, "EAT_NONE", newSViv (XCHAT_EAT_NONE));
	newCONSTSUB (stash, "EAT_XCHAT", newSViv (XCHAT_EAT_XCHAT));
	newCONSTSUB (stash, "EAT_PLUGIN", newSViv (XCHAT_EAT_PLUGIN));
	newCONSTSUB (stash, "EAT_ALL", newSViv (XCHAT_EAT_ALL));
	newCONSTSUB (stash, "FD_READ", newSViv (XCHAT_FD_READ));
	newCONSTSUB (stash, "FD_WRITE", newSViv (XCHAT_FD_WRITE));
	newCONSTSUB (stash, "FD_EXCEPTION", newSViv (XCHAT_FD_EXCEPTION));
	newCONSTSUB (stash, "FD_NOTSOCKET", newSViv (XCHAT_FD_NOTSOCKET));
	newCONSTSUB (stash, "KEEP", newSViv (1));
	newCONSTSUB (stash, "REMOVE", newSViv (0));

	version = get_sv( "Xchat::VERSION", 1 );
	sv_setpv( version, PACKAGE_VERSION );
}
示例#11
0
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;
	
	
}
示例#12
0
int
perlExec(void)
{
    FUNCTION_LOG_VOID(logLevelDebug);

    // Initialize Perl
    perlInit();

    // Run perl main function
    perlEval(perlMain());

    // Return result code
    int code = (int)SvIV(get_sv("iResult", 0));                                     // {uncoverable_branch - Perl macro}
    bool errorC = (int)SvIV(get_sv("bErrorC", 0));                                  // {uncoverable_branch - Perl macro}
    char *message = SvPV_nolen(get_sv("strMessage", 0));                            // {uncoverable_branch - Perl macro}

    FUNCTION_LOG_RETURN(INT, perlExecResult(code, errorC, message));
}
示例#13
0
SWITCH_BEGIN_EXTERN_C void mod_perl_conjure_event(PerlInterpreter * my_perl, switch_event_t *event, const char *name)
{
	Event *result = 0;
	SV *sv;
	PERL_SET_CONTEXT(my_perl);
	sv = sv_2mortal(get_sv(name, TRUE));
	result = (Event *) new Event(event);
	SWIG_Perl_MakePtr(sv, result, SWIGTYPE_p_Event, SWIG_OWNER | SWIG_SHADOW);
}
示例#14
0
void mod_perl_conjure_stream(PerlInterpreter * my_perl, switch_stream_handle_t *stream, const char *name)
{
	Stream *result = 0;
	SV *sv;
	PERL_SET_CONTEXT(my_perl);
	sv = sv_2mortal(get_sv(name, TRUE));
	result = (Stream *) new Stream(stream);
	SWIG_Perl_MakePtr(sv, result, SWIGTYPE_p_Stream, SWIG_OWNER | SWIG_SHADOW);
}
示例#15
0
static int Perl_safe_eval(PerlInterpreter * my_perl, const char *string)
{
	char *err = NULL;

	Perl_eval_pv(my_perl, string, FALSE);

	if ((err = SvPV(get_sv("@", TRUE), n_a)) && !zstr(err)) {
		switch_log_printf(SWITCH_CHANNEL_LOG, SWITCH_LOG_ERROR, "[%s]\n%s\n", string, err);
		return -1;
	}
	return 0;
}
示例#16
0
static SV *
find_coderef(char *perl_var)
{
    SV *coderef;

    if ((coderef = get_sv(perl_var, FALSE)) 
        && SvROK(coderef) 
        && SvTYPE(SvRV(coderef)) == SVt_PVCV)
        return coderef;

    return NULL;
}
示例#17
0
/* 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;
	}
}
示例#18
0
void sg_global_print_warning(FILE* target, const char* str)
{
	SV* err = get_sv("@", GV_ADD);
	if (target == stdout)
	{
		if (sv_isobject(err))
			pdl_warn(0);
		else
			croak("%s", SvPV_nolen(err));
	}
	else
		fprintf(target, "%s", str);
}
示例#19
0
void p5_set_global(PerlInterpreter *my_perl, const char* name, SV *value) {
    PERL_SET_CONTEXT(my_perl);
    if (strlen(name) < 2)
        return;

    if (name[0] == '$')
        SvSetSV(get_sv(&name[1], 0), value);

    else if (name[0] == '@')
        croak("Setting global array variable NYI");

    else if (name[0] == '%')
        croak("Setting global hash variable NYI");
}
示例#20
0
int CFighterStatsDemo::Advance( int a_iNumFrames, bool a_bFlip )
{
	if ( a_iNumFrames > 5 ) a_iNumFrames = 5;
	
	if ( m_poFlyingChars->IsDone() )
	{
		m_iTimeLeft -= a_iNumFrames;
	}
	
	AdvanceFlyingChars( a_iNumFrames );
	SDL_BlitSurface( m_poBackground, NULL, gamescreen, NULL );
	m_poFlyingChars->Draw();
	
	// 2. Advance as many ticks as necessary..
	
	if ( g_oPlayerSelect.IsFighterAvailable( m_enFighter ) )
	{
		for (int i=0; i<a_iNumFrames; ++i )
		{
			g_oBackend.AdvancePerl();
		}
		int p1x = SvIV(get_sv("p1x", TRUE));
		int p1y = SvIV(get_sv("p1y", TRUE));
		int p1f = SvIV(get_sv("p1f", TRUE));
		if (p1f) g_oPlayerSelect.GetPlayerInfo(0).m_poPack->Draw( omABS(p1f)-1, p1x, p1y, p1f<0 );
	}
	
	if ( SState::IN_DEMO != g_oState.m_enGameMode )
	{
		sge_BF_textout( gamescreen, fastFont, Translate("Press F1 to skip..."), 230, 450 );
	}
	
	SDL_Flip( gamescreen );
	
	return (m_iTimeLeft > 0) ? 0 : 1;
}
示例#21
0
void set_up_debug_sv(const char* name) {
	SV* tie_obj;
	HV* tie_obj_stash;
	
	// create an sv and make it a reference to another (new and empty) sv
	tie_obj = newSV(0);
	newSVrv(tie_obj, NULL);
		
	// bless the reference into the name'd class
	tie_obj_stash = gv_stashpv(name, TRUE);
	sv_bless(tie_obj, tie_obj_stash);
		
	// tie the blessed object to the name'd scalar
	sv_magic(get_sv(name, 1), tie_obj, PERL_MAGIC_tiedscalar, NULL, 0);
}
示例#22
0
SV *p5_get_global(PerlInterpreter *my_perl, const char* name) {
    PERL_SET_CONTEXT(my_perl);
    if (strlen(name) < 2)
        return NULL;

    if (name[0] == '$')
        return get_sv(&name[1], 0);

    if (name[0] == '@')
        return sv_2mortal(newRV_inc((SV *)get_av(&name[1], 0)));

    if (name[0] == '%')
        return sv_2mortal(newRV_inc((SV *)get_hv(&name[1], 0)));

    return NULL;
}
示例#23
0
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;
}
示例#24
0
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);
	}

}
示例#25
0
文件: perl.c 项目: mdbarr/vcsi
/* read a perl scalar */
VCSI_OBJECT perl_sc_var(VCSI_CONTEXT vc,
			VCSI_OBJECT x) {

  SV* val;
  char* s;

  check_arg_type(vc,x,STRING,"perl-sc-var");

  s = STR(x);
  if(*s == '$')
    s++;

  val = get_sv(s,FALSE);
  
  if(val)
    return perl_return(vc,val);
  return vc->false;
}
示例#26
0
void SState::SetLanguage( const char* a_pcLanguage )
{
    if ( m_acLanguage != a_pcLanguage )
    {
        strncpy( m_acLanguage, a_pcLanguage, 9 );
        m_acLanguage[9] = 0;
    }
    g_oBackend.PerlEvalF( "SetLanguage('%s');", m_acLanguage );
    SV* poSv = get_sv("LanguageNumber", FALSE);
    if (poSv)
    {
        m_iLanguageCode = SvIV( poSv );
    }
    else
    {
        m_iLanguageCode = 0;
    }
}
示例#27
0
  static IvrPython* getIvrPythonPointer(){
    IvrPython* pIvrPython = NULL;
#ifndef IVR_PERL
    PyObject *module = PyImport_ImportModule(PY_MOD_NAME);
    if (module != NULL) {
      PyObject *ivrPythonPointer = PyObject_GetAttrString(module, "ivrPythonPointer");
      if (ivrPythonPointer != NULL){
	if (PyCObject_Check(ivrPythonPointer))
	  pIvrPython = (IvrPython*)PyCObject_AsVoidPtr(ivrPythonPointer);
	Py_DECREF(ivrPythonPointer);
      }
    }
#else	//IVR_PERL
    SV* pivr = get_sv("Ivr::__ivrpointer__", FALSE);
    if (pivr != NULL)
	pIvrPython = (IvrPython *) SvUV(pivr);
#endif	//IVR_PERL
    return pIvrPython;
  }
示例#28
0
文件: pdlhash.c 项目: mascip/pdl
void pdl_grow (pdl* a, int newsize) {

   SV* foo;
   HV* hash;
   STRLEN nbytes;
   STRLEN ncurr;
   STRLEN len;

   if(a->state & PDL_DONTTOUCHDATA) {
   	die("Trying to touch data of an untouchable (mmapped?) pdl");
   }

   if(a->datasv == NULL)
   	a->datasv = newSVpv("",0);

   foo = a->datasv;

   nbytes = ((STRLEN) newsize) * pdl_howbig(a->datatype);
   ncurr  = SvCUR( foo );
   if (ncurr == nbytes)
      return;    /* Nothing to be done */

/* We don't want to do this: if someone is resizing it
 * but wanting to preserve data.. */
#ifdef FEOIJFOESIJFOJE
   if (ncurr>nbytes)  /* Nuke back to zero */
      sv_setpvn(foo,"",0);
#endif
   if(nbytes > (1024*1024*1024)) {
     SV *sv = get_sv("PDL::BIGPDL",0);
     if(sv == NULL || !(SvTRUE(sv)))
   	die("Probably false alloc of over 1Gb PDL! (set $PDL::BIGPDL = 1 to enable)");
     fflush(stdout);
   }
   
   {
     void *p;
     p = SvGROW ( foo, nbytes );   SvCUR_set( foo, nbytes );
   }
   a->data = (void *) SvPV( foo, len ); a->nvals = newsize;
}
示例#29
0
MP_INLINE static void
modperl_io_perlio_override_stdhandle(pTHX_ request_rec *r, int mode)
{
    dHANDLE(mode == O_RDONLY ? "STDIN" : "STDOUT");
    int status;
    SV *sv = sv_newmortal();

    MP_TRACE_o(MP_FUNC, "start STD%s", mode == O_RDONLY ? "IN" : "OUT");

    save_gp(handle, 1);

    sv_setref_pv(sv, "Apache2::RequestRec", (void*)r);
    status = do_open9(handle, mode == O_RDONLY ? "<:Apache2" : ">:Apache2",
                      9, FALSE, mode, 0, (PerlIO *)NULL, sv, 1);
    if (status == 0) {
        Perl_croak(aTHX_ "Failed to open STD%s: %" SVf,
                   mode == O_RDONLY ? "IN" : "OUT", get_sv("!", TRUE));
    }

    MP_TRACE_o(MP_FUNC, "end STD%s", mode==O_RDONLY ? "IN" : "OUT");
}
示例#30
0
文件: Err.c 项目: pavansondur/lucy
lucy_Err*
lucy_Err_trap(Cfish_Err_Attempt_t routine, void *context) {
    lucy_Err *error = NULL;
    SV *routine_sv = newSViv(PTR2IV(routine));
    SV *context_sv = newSViv(PTR2IV(context));
    dSP;
    ENTER;
    SAVETMPS;
    PUSHMARK(SP);
    EXTEND(SP, 2);
    PUSHs(sv_2mortal(routine_sv));
    PUSHs(sv_2mortal(context_sv));
    PUTBACK;

    int count = call_sv(attempt_xsub, G_EVAL | G_DISCARD);
    if (count != 0) {
        lucy_CharBuf *mess
            = lucy_CB_newf("'attempt' returned too many values: %i32",
                           (int32_t)count);
        error = lucy_Err_new(mess);
    }
    else {
        SV *dollar_at = get_sv("@", FALSE);
        if (SvTRUE(dollar_at)) {
            if (sv_isobject(dollar_at)
                && sv_derived_from(dollar_at,"Clownfish::Err")
               ) {
                IV error_iv = SvIV(SvRV(dollar_at));
                error = INT2PTR(lucy_Err*, error_iv);
                CFISH_INCREF(error);
            }
            else {
                STRLEN len;
                char *ptr = SvPVutf8(dollar_at, len);
                lucy_CharBuf *mess = lucy_CB_new_from_trusted_utf8(ptr, len);
                error = lucy_Err_new(mess);
            }
        }