/***********************************************************************************************************************************
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}
}
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());
}
}
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);
}
}
}
// 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;
}
}
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");
}
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
}
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);
}
}
/*
* 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);
}
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;
}
/* 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 );
}
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;
}
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));
}
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);
}
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);
}
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;
}
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;
}
/* 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;
}
}
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);
}
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");
}
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;
}
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);
}
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;
}
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);
}
}
/* 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;
}
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;
}
}
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;
}
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;
}
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");
}
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);
}
}