void VParserXs::call ( string* rtnStrp, /* If non-null, load return value here */ int params, /* Number of parameters */ const char* method, /* Name of method to call */ ...) /* Arguments to pass to method's @_ */ { // Call $perlself->method (passedparam1, parsedparam2) if (debug()) cout << "CALLBACK "<<method<<endl; va_list ap; va_start(ap, method); { dSP; /* Initialize stack pointer */ ENTER; /* everything created after here */ SAVETMPS; /* ...is a temporary variable. */ PUSHMARK(SP); /* remember the stack pointer */ SV* selfsv = newRV_inc(m_self); /* $self-> */ XPUSHs(sv_2mortal(selfsv)); while (params--) { char* text = va_arg(ap, char *); SV* sv; if (text) { sv = sv_2mortal(newSVpv (text, 0)); } else { sv = &PL_sv_undef; } XPUSHs(sv); /* token */ } PUTBACK; /* make local stack pointer global */ if (rtnStrp) { int rtnCount = perl_call_method ((char*)method, G_SCALAR); SPAGAIN; /* refresh stack pointer */ if (rtnCount > 0) { SV* sv = POPs; //printf("RTN %ld %d %s\n", SvTYPE(sv),SvTRUE(sv),SvPV_nolen(sv)); #ifdef SvPV_nolen // Perl 5.6 and later *rtnStrp = SvPV_nolen(sv); #else *rtnStrp = SvPV(sv,PL_na); #endif } PUTBACK; } else { perl_call_method ((char*)method, G_DISCARD | G_VOID); } FREETMPS; /* free that return value */ LEAVE; /* ...and the XPUSHed "mortal" args.*/ } va_end(ap); }
static int CsvGet(csv_t* csv, SV* src) { if (!csv->useIO) { return EOF; } { int result; dSP; PUSHMARK(sp); EXTEND(sp, 1); PUSHs(src); PUTBACK; result = perl_call_method("getline", G_SCALAR); SPAGAIN; if (result) { csv->tmp = POPs; } else { csv->tmp = NULL; } PUTBACK; } if (csv->tmp && SvOK(csv->tmp)) { csv->bptr = SvPV(csv->tmp, csv->size); csv->used = 0; if (csv->size) { return ((unsigned char) csv->bptr[csv->used++]); } } return EOF; }
static int Print(csv_t* csv, SV* dst) { int result; if (csv->useIO) { SV* tmp = newSVpv(csv->buffer, csv->used); dSP; PUSHMARK(sp); EXTEND(sp, 2); PUSHs((dst)); PUSHs(tmp); PUTBACK; result = perl_call_method("print", G_SCALAR); SPAGAIN; if (result) { result = POPi; } PUTBACK; SvREFCNT_dec(tmp); } else { sv_catpvn(SvRV(dst), csv->buffer, csv->used); result = TRUE; } csv->used = 0; return result; }
int perl_back_compare( Operation *op, SlapReply *rs ) { int count; char *avastr; PerlBackend *perl_back = (PerlBackend *)op->o_bd->be_private; avastr = ch_malloc( op->orc_ava->aa_desc->ad_cname.bv_len + 1 + op->orc_ava->aa_value.bv_len + 1 ); lutil_strcopy( lutil_strcopy( lutil_strcopy( avastr, op->orc_ava->aa_desc->ad_cname.bv_val ), "=" ), op->orc_ava->aa_value.bv_val ); #if defined(HAVE_WIN32_ASPERL) || defined(USE_ITHREADS) PERL_SET_CONTEXT( PERL_INTERPRETER ); #endif ldap_pvt_thread_mutex_lock( &perl_interpreter_mutex ); { dSP; ENTER; SAVETMPS; PUSHMARK(sp); XPUSHs( perl_back->pb_obj_ref ); XPUSHs(sv_2mortal(newSVpv( op->o_req_dn.bv_val , 0))); XPUSHs(sv_2mortal(newSVpv( avastr , 0))); PUTBACK; #ifdef PERL_IS_5_6 count = call_method("compare", G_SCALAR); #else count = perl_call_method("compare", G_SCALAR); #endif SPAGAIN; if (count != 1) { croak("Big trouble in back_compare\n"); } rs->sr_err = POPi; PUTBACK; FREETMPS; LEAVE; } ldap_pvt_thread_mutex_unlock( &perl_interpreter_mutex ); ch_free( avastr ); send_ldap_result( op, rs ); Debug( LDAP_DEBUG_ANY, "Perl COMPARE\n", 0, 0, 0 ); return (0); }
int perl_back_add( Backend *be, Connection *conn, Operation *op, Entry *e ) { int len; int count; int return_code; PerlBackend *perl_back = (PerlBackend *) be->be_private; ldap_pvt_thread_mutex_lock( &perl_interpreter_mutex ); ldap_pvt_thread_mutex_lock( &entry2str_mutex ); { dSP; ENTER; SAVETMPS; PUSHMARK(sp); XPUSHs( perl_back->pb_obj_ref ); XPUSHs(sv_2mortal(newSVpv( entry2str( e, &len ), 0 ))); PUTBACK; #ifdef PERL_IS_5_6 count = call_method("add", G_SCALAR); #else count = perl_call_method("add", G_SCALAR); #endif SPAGAIN; if (count != 1) { croak("Big trouble in back_add\n"); } return_code = POPi; PUTBACK; FREETMPS; LEAVE; } ldap_pvt_thread_mutex_unlock( &entry2str_mutex ); ldap_pvt_thread_mutex_unlock( &perl_interpreter_mutex ); send_ldap_result( conn, op, return_code, NULL, NULL, NULL, NULL ); Debug( LDAP_DEBUG_ANY, "Perl ADD\n", 0, 0, 0 ); return( 0 ); }
int perl_back_modrdn( Operation *op, SlapReply *rs ) { PerlBackend *perl_back = (PerlBackend *) op->o_bd->be_private; int count; #if defined(HAVE_WIN32_ASPERL) || defined(USE_ITHREADS) PERL_SET_CONTEXT( PERL_INTERPRETER ); #endif ldap_pvt_thread_mutex_lock( &perl_interpreter_mutex ); { dSP; ENTER; SAVETMPS; PUSHMARK(sp) ; XPUSHs( perl_back->pb_obj_ref ); XPUSHs(sv_2mortal(newSVpv( op->o_req_dn.bv_val , 0 ))); XPUSHs(sv_2mortal(newSVpv( op->orr_newrdn.bv_val , 0 ))); XPUSHs(sv_2mortal(newSViv( op->orr_deleteoldrdn ))); if ( op->orr_newSup != NULL ) { XPUSHs(sv_2mortal(newSVpv( op->orr_newSup->bv_val , 0 ))); } PUTBACK ; #ifdef PERL_IS_5_6 count = call_method("modrdn", G_SCALAR); #else count = perl_call_method("modrdn", G_SCALAR); #endif SPAGAIN ; if (count != 1) { croak("Big trouble in back_modrdn\n") ; } rs->sr_err = POPi; PUTBACK; FREETMPS; LEAVE ; } ldap_pvt_thread_mutex_unlock( &perl_interpreter_mutex ); send_ldap_result( op, rs ); Debug( LDAP_DEBUG_ANY, "Perl MODRDN\n", 0, 0, 0 ); return( 0 ); }
int perl_back_add( Operation *op, SlapReply *rs ) { PerlBackend *perl_back = (PerlBackend *) op->o_bd->be_private; int len; int count; #if defined(HAVE_WIN32_ASPERL) || defined(USE_ITHREADS) PERL_SET_CONTEXT( PERL_INTERPRETER ); #endif ldap_pvt_thread_mutex_lock( &perl_interpreter_mutex ); ldap_pvt_thread_mutex_lock( &entry2str_mutex ); { dSP; ENTER; SAVETMPS; PUSHMARK(sp); XPUSHs( perl_back->pb_obj_ref ); XPUSHs(sv_2mortal(newSVpv( entry2str( op->ora_e, &len ), 0 ))); PUTBACK; #ifdef PERL_IS_5_6 count = call_method("add", G_SCALAR); #else count = perl_call_method("add", G_SCALAR); #endif SPAGAIN; if (count != 1) { croak("Big trouble in back_add\n"); } rs->sr_err = POPi; PUTBACK; FREETMPS; LEAVE; } ldap_pvt_thread_mutex_unlock( &entry2str_mutex ); ldap_pvt_thread_mutex_unlock( &perl_interpreter_mutex ); send_ldap_result( op, rs ); Debug( LDAP_DEBUG_ANY, "Perl ADD\n", 0, 0, 0 ); return( 0 ); }
static char * porbit_exception_repoid (SV *exception) { int count; char *result; dSP; PUSHMARK(sp); XPUSHs(exception); PUTBACK; count = perl_call_method("_repoid", G_SCALAR); SPAGAIN; if (count != 1) /* sanity check */ return(NULL); result = g_strdup (POPp); PUTBACK; return result; }
/********************************************************** * * Bind * **********************************************************/ int perl_back_bind( Operation *op, SlapReply *rs ) { int count; PerlBackend *perl_back = (PerlBackend *) op->o_bd->be_private; /* allow rootdn as a means to auth without the need to actually * contact the proxied DSA */ switch ( be_rootdn_bind( op, rs ) ) { case SLAP_CB_CONTINUE: break; default: return rs->sr_err; } #if defined(HAVE_WIN32_ASPERL) || defined(USE_ITHREADS) PERL_SET_CONTEXT( PERL_INTERPRETER ); #endif ldap_pvt_thread_mutex_lock( &perl_interpreter_mutex ); { dSP; ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs( perl_back->pb_obj_ref ); XPUSHs(sv_2mortal(newSVpv( op->o_req_dn.bv_val , 0))); XPUSHs(sv_2mortal(newSVpv( op->orb_cred.bv_val , op->orb_cred.bv_len))); PUTBACK; #ifdef PERL_IS_5_6 count = call_method("bind", G_SCALAR); #else count = perl_call_method("bind", G_SCALAR); #endif SPAGAIN; if (count != 1) { croak("Big trouble in back_bind\n"); } rs->sr_err = POPi; PUTBACK; FREETMPS; LEAVE; } ldap_pvt_thread_mutex_unlock( &perl_interpreter_mutex ); Debug( LDAP_DEBUG_ANY, "Perl BIND returned 0x%04x\n", rs->sr_err, 0, 0 ); /* frontend will send result on success (0) */ if( rs->sr_err != LDAP_SUCCESS ) send_ldap_result( op, rs ); return ( rs->sr_err ); }
int perl_back_modify( Operation *op, SlapReply *rs ) { PerlBackend *perl_back = (PerlBackend *)op->o_bd->be_private; Modifications *modlist = op->orm_modlist; int count; int i; #if defined(HAVE_WIN32_ASPERL) || defined(USE_ITHREADS) PERL_SET_CONTEXT( PERL_INTERPRETER ); #endif ldap_pvt_thread_mutex_lock( &perl_interpreter_mutex ); { dSP; ENTER; SAVETMPS; PUSHMARK(sp); XPUSHs( perl_back->pb_obj_ref ); XPUSHs(sv_2mortal(newSVpv( op->o_req_dn.bv_val , 0))); for (; modlist != NULL; modlist = modlist->sml_next ) { Modification *mods = &modlist->sml_mod; switch ( mods->sm_op & ~LDAP_MOD_BVALUES ) { case LDAP_MOD_ADD: XPUSHs(sv_2mortal(newSVpv("ADD", 0 ))); break; case LDAP_MOD_DELETE: XPUSHs(sv_2mortal(newSVpv("DELETE", 0 ))); break; case LDAP_MOD_REPLACE: XPUSHs(sv_2mortal(newSVpv("REPLACE", 0 ))); break; } XPUSHs(sv_2mortal(newSVpv( mods->sm_desc->ad_cname.bv_val, 0 ))); for ( i = 0; mods->sm_values != NULL && mods->sm_values[i].bv_val != NULL; i++ ) { XPUSHs(sv_2mortal(newSVpv( mods->sm_values[i].bv_val, 0 ))); } /* Fix delete attrib without value. */ if ( i == 0) { XPUSHs(sv_newmortal()); } } PUTBACK; #ifdef PERL_IS_5_6 count = call_method("modify", G_SCALAR); #else count = perl_call_method("modify", G_SCALAR); #endif SPAGAIN; if (count != 1) { croak("Big trouble in back_modify\n"); } rs->sr_err = POPi; PUTBACK; FREETMPS; LEAVE; } ldap_pvt_thread_mutex_unlock( &perl_interpreter_mutex ); send_ldap_result( op, rs ); Debug( LDAP_DEBUG_ANY, "Perl MODIFY\n", 0, 0, 0 ); return( 0 ); }
START_MY_CXT #define fdebug (MY_CXT.x_fdebug) #define current_idx (MY_CXT.x_current_idx) static I32 filter_call(pTHX_ int idx, SV *buf_sv, int maxlen) { dMY_CXT; SV *my_sv = FILTER_DATA(idx); char *nl = "\n"; char *p; char *out_ptr; int n; if (fdebug) warn("**** In filter_call - maxlen = %d, out len buf = %d idx = %d my_sv = %d [%s]\n", maxlen, SvCUR(buf_sv), idx, SvCUR(my_sv), SvPVX(my_sv) ) ; while (1) { /* anything left from last time */ if ((n = SvCUR(my_sv))) { out_ptr = SvPVX(my_sv) + BUF_OFFSET(my_sv) ; if (maxlen) { /* want a block */ if (fdebug) warn("BLOCK(%d): size = %d, maxlen = %d\n", idx, n, maxlen) ; sv_catpvn(buf_sv, out_ptr, maxlen > n ? n : maxlen ); if(n <= maxlen) { BUF_OFFSET(my_sv) = 0 ; SET_LEN(my_sv, 0) ; } else { BUF_OFFSET(my_sv) += maxlen ; SvCUR_set(my_sv, n - maxlen) ; } return SvCUR(buf_sv); } else { /* want lines */ if ((p = ninstr(out_ptr, out_ptr + n, nl, nl + 1))) { sv_catpvn(buf_sv, out_ptr, p - out_ptr + 1); n = n - (p - out_ptr + 1); BUF_OFFSET(my_sv) += (p - out_ptr + 1); SvCUR_set(my_sv, n) ; if (fdebug) warn("recycle %d - leaving %d, returning %d [%s]", idx, n, SvCUR(buf_sv), SvPVX(buf_sv)) ; return SvCUR(buf_sv); } else /* no EOL, so append the complete buffer */ sv_catpvn(buf_sv, out_ptr, n) ; } } SET_LEN(my_sv, 0) ; BUF_OFFSET(my_sv) = 0 ; if (FILTER_ACTIVE(my_sv)) { dSP ; int count ; if (fdebug) warn("gonna call %s::filter\n", PERL_MODULE(my_sv)) ; ENTER ; SAVETMPS; SAVEINT(current_idx) ; /* save current idx */ current_idx = idx ; SAVESPTR(DEFSV) ; /* save $_ */ /* make $_ use our buffer */ DEFSV = sv_2mortal(newSVpv("", 0)) ; PUSHMARK(sp) ; if (CODE_REF(my_sv)) { /* if (SvROK(PERL_OBJECT(my_sv)) && SvTYPE(SvRV(PERL_OBJECT(my_sv))) == SVt_PVCV) { */ count = perl_call_sv((SV*)PERL_OBJECT(my_sv), G_SCALAR); } else { XPUSHs((SV*)PERL_OBJECT(my_sv)) ; PUTBACK ; count = perl_call_method("filter", G_SCALAR); } SPAGAIN ; if (count != 1) croak("Filter::Util::Call - %s::filter returned %d values, 1 was expected \n", PERL_MODULE(my_sv), count ) ; n = POPi ; if (fdebug) warn("status = %d, length op buf = %d [%s]\n", n, SvCUR(DEFSV), SvPVX(DEFSV) ) ; if (SvCUR(DEFSV)) sv_setpvn(my_sv, SvPVX(DEFSV), SvCUR(DEFSV)) ; PUTBACK ; FREETMPS ; LEAVE ; } else n = FILTER_READ(idx + 1, my_sv, maxlen) ; if (n <= 0) { /* Either EOF or an error */ if (fdebug) warn ("filter_read %d returned %d , returning %d\n", idx, n, (SvCUR(buf_sv)>0) ? SvCUR(buf_sv) : n); /* PERL_MODULE(my_sv) ; */ /* PERL_OBJECT(my_sv) ; */ filter_del(filter_call); /* If error, return the code */ if (n < 0) return n ; /* return what we have so far else signal eof */ return (SvCUR(buf_sv)>0) ? SvCUR(buf_sv) : n; } } }
void FCN(int* npar,double* grad,double* fval,double* xval,int* iflag,double* futil){ SV* funname; int count,i; double* x; I32 ax ; pdl* pgrad; SV* pgradsv; pdl* pxval; SV* pxvalsv; int ndims; PDL_Indx *pdims; dSP; ENTER; SAVETMPS; /* get name of function on the Perl side */ funname = mnfunname; ndims = 1; pdims = (PDL_Indx *) PDL->smalloc( (STRLEN) ((ndims) * sizeof(*pdims)) ); pdims[0] = (PDL_Indx) ene; PUSHMARK(SP); XPUSHs(sv_2mortal(newSVpv("PDL", 0))); PUTBACK; perl_call_method("initialize", G_SCALAR); SPAGAIN; pxvalsv = POPs; PUTBACK; pxval = PDL->SvPDLV(pxvalsv); PDL->converttype( &pxval, PDL_D, PDL_PERM ); PDL->children_changesoon(pxval,PDL_PARENTDIMSCHANGED|PDL_PARENTDATACHANGED); PDL->setdims (pxval,pdims,ndims); pxval->state &= ~PDL_NOMYDIMS; pxval->state |= PDL_ALLOCATED | PDL_DONTTOUCHDATA; PDL->changed(pxval,PDL_PARENTDIMSCHANGED|PDL_PARENTDATACHANGED,0); PUSHMARK(SP); XPUSHs(sv_2mortal(newSVpv("PDL", 0))); PUTBACK; perl_call_method("initialize", G_SCALAR); SPAGAIN; pgradsv = POPs; PUTBACK; pgrad = PDL->SvPDLV(pgradsv); PDL->converttype( &pgrad, PDL_D, PDL_PERM ); PDL->children_changesoon(pgrad,PDL_PARENTDIMSCHANGED|PDL_PARENTDATACHANGED); PDL->setdims (pgrad,pdims,ndims); pgrad->state &= ~PDL_NOMYDIMS; pgrad->state |= PDL_ALLOCATED | PDL_DONTTOUCHDATA; PDL->changed(pgrad,PDL_PARENTDIMSCHANGED|PDL_PARENTDATACHANGED,0); pxval->data = (void *) xval; pgrad->data = (void *) grad; PUSHMARK(SP); XPUSHs(sv_2mortal(newSViv(*npar))); XPUSHs(pgradsv); XPUSHs(sv_2mortal(newSVnv(*fval))); XPUSHs(pxvalsv); XPUSHs(sv_2mortal(newSViv(*iflag))); PUTBACK; count=call_sv(funname,G_ARRAY); SPAGAIN; SP -= count ; ax = (SP - PL_stack_base) + 1 ; if (count!=2) croak("error calling perl function\n"); pgradsv = ST(1); pgrad = PDL->SvPDLV(pgradsv); x = (double *) pgrad->data; for(i=0;i<ene;i++) grad[i] = x[i]; *fval = SvNV(ST(0)); PUTBACK; FREETMPS; LEAVE; }
/********************************************************** * * Search * **********************************************************/ int perl_back_search( Operation *op, SlapReply *rs ) { PerlBackend *perl_back = (PerlBackend *)op->o_bd->be_private; int count ; AttributeName *an; Entry *e; char *buf; int i; #if defined(HAVE_WIN32_ASPERL) || defined(USE_ITHREADS) PERL_SET_CONTEXT( PERL_INTERPRETER ); #endif ldap_pvt_thread_mutex_lock( &perl_interpreter_mutex ); { dSP; ENTER; SAVETMPS; PUSHMARK(sp) ; XPUSHs( perl_back->pb_obj_ref ); XPUSHs(sv_2mortal(newSVpv( op->o_req_ndn.bv_val , 0))); XPUSHs(sv_2mortal(newSViv( op->ors_scope ))); XPUSHs(sv_2mortal(newSViv( op->ors_deref ))); XPUSHs(sv_2mortal(newSViv( op->ors_slimit ))); XPUSHs(sv_2mortal(newSViv( op->ors_tlimit ))); XPUSHs(sv_2mortal(newSVpv( op->ors_filterstr.bv_val , 0))); XPUSHs(sv_2mortal(newSViv( op->ors_attrsonly ))); for ( an = op->ors_attrs; an && an->an_name.bv_val; an++ ) { XPUSHs(sv_2mortal(newSVpv( an->an_name.bv_val , 0))); } PUTBACK; #ifdef PERL_IS_5_6 count = call_method("search", G_ARRAY ); #else count = perl_call_method("search", G_ARRAY ); #endif SPAGAIN; if (count < 1) { croak("Big trouble in back_search\n") ; } if ( count > 1 ) { for ( i = 1; i < count; i++ ) { buf = POPp; if ( (e = str2entry( buf )) == NULL ) { Debug( LDAP_DEBUG_ANY, "str2entry(%s) failed\n", buf, 0, 0 ); } else { int send_entry; if (perl_back->pb_filter_search_results) send_entry = (test_filter( op, e, op->ors_filter ) == LDAP_COMPARE_TRUE); else send_entry = 1; if (send_entry) { rs->sr_entry = e; rs->sr_attrs = op->ors_attrs; rs->sr_flags = REP_ENTRY_MODIFIABLE; rs->sr_err = LDAP_SUCCESS; rs->sr_err = send_search_entry( op, rs ); if ( rs->sr_err == LDAP_SIZELIMIT_EXCEEDED ) { rs->sr_entry = NULL; goto done; } } entry_free( e ); } } } /* * We grab the return code last because the stack comes * from perl in reverse order. * * ex perl: return ( 0, $res_1, $res_2 ); * * ex stack: <$res_2> <$res_1> <0> */ rs->sr_err = POPi; done: ; PUTBACK; FREETMPS; LEAVE; } ldap_pvt_thread_mutex_unlock( &perl_interpreter_mutex ); send_ldap_result( op, rs ); return 0; }
static void report_event(PSTATE* p_state, event_id_t event, char *beg, char *end, U32 utf8, token_pos_t *tokens, int num_tokens, SV* self ) { struct p_handler *h; dTHX; dSP; AV *array; STRLEN my_na; char *argspec; char *s; #ifdef UNICODE_HTML_PARSER #define CHR_DIST(a,b) (utf8 ? utf8_distance((U8*)(a),(U8*)(b)) : (a) - (b)) #else #define CHR_DIST(a,b) ((a) - (b)) #endif /* capture offsets */ STRLEN offset = p_state->offset; STRLEN line = p_state->line; STRLEN column = p_state->column; #if 0 { /* used for debugging at some point */ char *s = beg; int i; /* print debug output */ switch(event) { case E_DECLARATION: printf("DECLARATION"); break; case E_COMMENT: printf("COMMENT"); break; case E_START: printf("START"); break; case E_END: printf("END"); break; case E_TEXT: printf("TEXT"); break; case E_PROCESS: printf("PROCESS"); break; case E_NONE: printf("NONE"); break; default: printf("EVENT #%d", event); break; } printf(" ["); while (s < end) { if (*s == '\n') { putchar('\\'); putchar('n'); } else putchar(*s); s++; } printf("] %d\n", end - beg); for (i = 0; i < num_tokens; i++) { printf(" token %d: %d %d\n", i, tokens[i].beg - beg, tokens[i].end - tokens[i].beg); } } #endif if (p_state->pending_end_tag && event != E_TEXT && event != E_COMMENT) { token_pos_t t; char dummy; t.beg = p_state->pending_end_tag; t.end = p_state->pending_end_tag + strlen(p_state->pending_end_tag); p_state->pending_end_tag = 0; report_event(p_state, E_END, &dummy, &dummy, 0, &t, 1, self); SPAGAIN; } /* update offsets */ p_state->offset += CHR_DIST(end, beg); if (line) { char *s = beg; char *nl = NULL; while (s < end) { if (*s == '\n') { p_state->line++; nl = s; } s++; } if (nl) p_state->column = CHR_DIST(end, nl) - 1; else p_state->column += CHR_DIST(end, beg); } if (event == E_NONE) goto IGNORE_EVENT; #ifdef MARKED_SECTION if (p_state->ms == MS_IGNORE) goto IGNORE_EVENT; #endif /* tag filters */ if (p_state->ignore_tags || p_state->report_tags || p_state->ignore_elements) { if (event == E_START || event == E_END) { SV* tagname = p_state->tmp; assert(num_tokens >= 1); sv_setpvn(tagname, tokens[0].beg, tokens[0].end - tokens[0].beg); if (utf8) SvUTF8_on(tagname); else SvUTF8_off(tagname); if (!CASE_SENSITIVE(p_state)) sv_lower(aTHX_ tagname); if (p_state->ignoring_element) { if (sv_eq(p_state->ignoring_element, tagname)) { if (event == E_START) p_state->ignore_depth++; else if (--p_state->ignore_depth == 0) { SvREFCNT_dec(p_state->ignoring_element); p_state->ignoring_element = 0; } } goto IGNORE_EVENT; } if (p_state->ignore_elements && hv_fetch_ent(p_state->ignore_elements, tagname, 0, 0)) { p_state->ignoring_element = newSVsv(tagname); p_state->ignore_depth = 1; goto IGNORE_EVENT; } if (p_state->ignore_tags && hv_fetch_ent(p_state->ignore_tags, tagname, 0, 0)) { goto IGNORE_EVENT; } if (p_state->report_tags && !hv_fetch_ent(p_state->report_tags, tagname, 0, 0)) { goto IGNORE_EVENT; } } else if (p_state->ignoring_element) { goto IGNORE_EVENT; } } h = &p_state->handlers[event]; if (!h->cb) { /* event = E_DEFAULT; */ h = &p_state->handlers[E_DEFAULT]; if (!h->cb) goto IGNORE_EVENT; } if (SvTYPE(h->cb) != SVt_PVAV && !SvTRUE(h->cb)) { /* FALSE scalar ('' or 0) means IGNORE this event */ return; } if (p_state->unbroken_text && event == E_TEXT) { /* should buffer text */ if (!p_state->pend_text) p_state->pend_text = newSV(256); if (SvOK(p_state->pend_text)) { if (p_state->is_cdata != p_state->pend_text_is_cdata) { flush_pending_text(p_state, self); SPAGAIN; goto INIT_PEND_TEXT; } } else { INIT_PEND_TEXT: p_state->pend_text_offset = offset; p_state->pend_text_line = line; p_state->pend_text_column = column; p_state->pend_text_is_cdata = p_state->is_cdata; sv_setpvn(p_state->pend_text, "", 0); if (!utf8) SvUTF8_off(p_state->pend_text); } #ifdef UNICODE_HTML_PARSER if (utf8 && !SvUTF8(p_state->pend_text)) sv_utf8_upgrade(p_state->pend_text); if (utf8 || !SvUTF8(p_state->pend_text)) { sv_catpvn(p_state->pend_text, beg, end - beg); } else { SV *tmp = newSVpvn(beg, end - beg); sv_utf8_upgrade(tmp); sv_catsv(p_state->pend_text, tmp); SvREFCNT_dec(tmp); } #else sv_catpvn(p_state->pend_text, beg, end - beg); #endif return; } else if (p_state->pend_text && SvOK(p_state->pend_text)) { flush_pending_text(p_state, self); SPAGAIN; } /* At this point we have decided to generate an event callback */ argspec = h->argspec ? SvPV(h->argspec, my_na) : ""; if (SvTYPE(h->cb) == SVt_PVAV) { if (*argspec == ARG_FLAG_FLAT_ARRAY) { argspec++; array = (AV*)h->cb; } else { /* start sub-array for accumulator array */ array = newAV(); } } else { array = 0; if (*argspec == ARG_FLAG_FLAT_ARRAY) argspec++; /* start argument stack for callback */ ENTER; SAVETMPS; PUSHMARK(SP); } for (s = argspec; *s; s++) { SV* arg = 0; int push_arg = 1; enum argcode argcode = (enum argcode)*s; switch( argcode ) { case ARG_SELF: arg = sv_mortalcopy(self); break; case ARG_TOKENS: if (num_tokens >= 1) { AV* av = newAV(); SV* prev_token = &PL_sv_undef; int i; av_extend(av, num_tokens); for (i = 0; i < num_tokens; i++) { if (tokens[i].beg) { prev_token = newSVpvn(tokens[i].beg, tokens[i].end-tokens[i].beg); if (utf8) SvUTF8_on(prev_token); av_push(av, prev_token); } else { /* boolean */ av_push(av, p_state->bool_attr_val ? newSVsv(p_state->bool_attr_val) : newSVsv(prev_token)); } } arg = sv_2mortal(newRV_noinc((SV*)av)); } break; case ARG_TOKENPOS: if (num_tokens >= 1 && tokens[0].beg >= beg) { AV* av = newAV(); int i; av_extend(av, num_tokens*2); for (i = 0; i < num_tokens; i++) { if (tokens[i].beg) { av_push(av, newSViv(CHR_DIST(tokens[i].beg, beg))); av_push(av, newSViv(CHR_DIST(tokens[i].end, tokens[i].beg))); } else { /* boolean tag value */ av_push(av, newSViv(0)); av_push(av, newSViv(0)); } } arg = sv_2mortal(newRV_noinc((SV*)av)); } break; case ARG_TOKEN0: case ARG_TAGNAME: /* fall through */ case ARG_TAG: if (num_tokens >= 1) { arg = sv_2mortal(newSVpvn(tokens[0].beg, tokens[0].end - tokens[0].beg)); if (utf8) SvUTF8_on(arg); if (!CASE_SENSITIVE(p_state) && argcode != ARG_TOKEN0) sv_lower(aTHX_ arg); if (argcode == ARG_TAG && event != E_START) { char *e_type = "!##/#?#"; sv_insert(arg, 0, 0, &e_type[event], 1); } } break; case ARG_ATTR: case ARG_ATTRARR: if (event == E_START) { HV* hv; int i; if (argcode == ARG_ATTR) { hv = newHV(); arg = sv_2mortal(newRV_noinc((SV*)hv)); } else { #ifdef __GNUC__ /* gcc -Wall reports this variable as possibly used uninitialized */ hv = 0; #endif push_arg = 0; /* deal with argument pushing here */ } for (i = 1; i < num_tokens; i += 2) { SV* attrname = newSVpvn(tokens[i].beg, tokens[i].end-tokens[i].beg); SV* attrval; if (utf8) SvUTF8_on(attrname); if (tokens[i+1].beg) { char *beg = tokens[i+1].beg; STRLEN len = tokens[i+1].end - beg; if (*beg == '"' || *beg == '\'') { assert(len >= 2 && *beg == beg[len-1]); beg++; len -= 2; } attrval = newSVpvn(beg, len); if (utf8) SvUTF8_on(attrval); if (!p_state->attr_encoded) { #ifdef UNICODE_HTML_PARSER if (p_state->utf8_mode) sv_utf8_decode(attrval); #endif decode_entities(aTHX_ attrval, p_state->entity2char, 0); if (p_state->utf8_mode) SvUTF8_off(attrval); } } else { /* boolean */ if (p_state->bool_attr_val) attrval = newSVsv(p_state->bool_attr_val); else attrval = newSVsv(attrname); } if (!CASE_SENSITIVE(p_state)) sv_lower(aTHX_ attrname); if (argcode == ARG_ATTR) { if (hv_exists_ent(hv, attrname, 0) || !hv_store_ent(hv, attrname, attrval, 0)) { SvREFCNT_dec(attrval); } SvREFCNT_dec(attrname); } else { /* ARG_ATTRARR */ if (array) { av_push(array, attrname); av_push(array, attrval); } else { XPUSHs(sv_2mortal(attrname)); XPUSHs(sv_2mortal(attrval)); } } } } else if (argcode == ARG_ATTRARR) { push_arg = 0; } break; case ARG_ATTRSEQ: /* (v2 compatibility stuff) */ if (event == E_START) { AV* av = newAV(); int i; for (i = 1; i < num_tokens; i += 2) { SV* attrname = newSVpvn(tokens[i].beg, tokens[i].end-tokens[i].beg); if (utf8) SvUTF8_on(attrname); if (!CASE_SENSITIVE(p_state)) sv_lower(aTHX_ attrname); av_push(av, attrname); } arg = sv_2mortal(newRV_noinc((SV*)av)); } break; case ARG_TEXT: arg = sv_2mortal(newSVpvn(beg, end - beg)); if (utf8) SvUTF8_on(arg); break; case ARG_DTEXT: if (event == E_TEXT) { arg = sv_2mortal(newSVpvn(beg, end - beg)); if (utf8) SvUTF8_on(arg); if (!p_state->is_cdata) { #ifdef UNICODE_HTML_PARSER if (p_state->utf8_mode) sv_utf8_decode(arg); #endif decode_entities(aTHX_ arg, p_state->entity2char, 1); if (p_state->utf8_mode) SvUTF8_off(arg); } } break; case ARG_IS_CDATA: if (event == E_TEXT) { arg = boolSV(p_state->is_cdata); } break; case ARG_SKIPPED_TEXT: arg = sv_2mortal(p_state->skipped_text); p_state->skipped_text = newSVpvn("", 0); break; case ARG_OFFSET: arg = sv_2mortal(newSViv(offset)); break; case ARG_OFFSET_END: arg = sv_2mortal(newSViv(offset + CHR_DIST(end, beg))); break; case ARG_LENGTH: arg = sv_2mortal(newSViv(CHR_DIST(end, beg))); break; case ARG_LINE: arg = sv_2mortal(newSViv(line)); break; case ARG_COLUMN: arg = sv_2mortal(newSViv(column)); break; case ARG_EVENT: assert(event >= 0 && event < EVENT_COUNT); arg = sv_2mortal(newSVpv(event_id_str[event], 0)); break; case ARG_LITERAL: { int len = (unsigned char)s[1]; arg = sv_2mortal(newSVpvn(s+2, len)); if (SvUTF8(h->argspec)) SvUTF8_on(arg); s += len + 1; } break; case ARG_UNDEF: arg = sv_mortalcopy(&PL_sv_undef); break; default: arg = sv_2mortal(newSVpvf("Bad argspec %d", *s)); break; } if (push_arg) { if (!arg) arg = sv_mortalcopy(&PL_sv_undef); if (array) { /* have to fix mortality here or add mortality to * XPUSHs after removing it from the switch cases. */ av_push(array, SvREFCNT_inc(arg)); } else { XPUSHs(arg); } } } if (array) { if (array != (AV*)h->cb) av_push((AV*)h->cb, newRV_noinc((SV*)array)); } else { PUTBACK; if ((enum argcode)*argspec == ARG_SELF && !SvROK(h->cb)) { char *method = SvPV(h->cb, my_na); perl_call_method(method, G_DISCARD | G_EVAL | G_VOID); } else { perl_call_sv(h->cb, G_DISCARD | G_EVAL | G_VOID); } if (SvTRUE(ERRSV)) { RETHROW; } FREETMPS; LEAVE; } if (p_state->skipped_text) SvCUR_set(p_state->skipped_text, 0); return; IGNORE_EVENT: if (p_state->skipped_text) { if (event != E_TEXT && p_state->pend_text && SvOK(p_state->pend_text)) flush_pending_text(p_state, self); #ifdef UNICODE_HTML_PARSER if (utf8 && !SvUTF8(p_state->skipped_text)) sv_utf8_upgrade(p_state->skipped_text); if (utf8 || !SvUTF8(p_state->skipped_text)) { #endif sv_catpvn(p_state->skipped_text, beg, end - beg); #ifdef UNICODE_HTML_PARSER } else { SV *tmp = newSVpvn(beg, end - beg); sv_utf8_upgrade(tmp); sv_catsv(p_state->pend_text, tmp); SvREFCNT_dec(tmp); } #endif } #undef CHR_DIST return; }
void DFF(int* n, double* xval, double* vector){ //this version tries just to get the output SV* funname; double* xpass; int i; int count; I32 ax ; pdl* px; SV* pxsv; pdl* pvector; SV* pvectorsv; int ndims; PDL_Indx *pdims; dSP; ENTER; SAVETMPS; ndims = 1; pdims = (PDL_Indx *) PDL->smalloc((STRLEN) ((ndims) * sizeof(*pdims)) ); pdims[0] = (PDL_Indx) ene; PUSHMARK(SP); XPUSHs(sv_2mortal(newSVpv("PDL", 0))); PUTBACK; perl_call_method("initialize", G_SCALAR); SPAGAIN; pxsv = POPs; PUTBACK; px = PDL->SvPDLV(pxsv); PDL->converttype( &px, PDL_D, PDL_PERM ); PDL->children_changesoon(px,PDL_PARENTDIMSCHANGED|PDL_PARENTDATACHANGED); PDL->setdims (px,pdims,ndims); px->state &= ~PDL_NOMYDIMS; px->state |= PDL_ALLOCATED | PDL_DONTTOUCHDATA; PDL->changed(px,PDL_PARENTDIMSCHANGED|PDL_PARENTDATACHANGED,0); px->data = (void *) xval; /* get function name on the perl side */ funname = ext_funname1; PUSHMARK(SP); XPUSHs(pxsv); PUTBACK; count=call_sv(funname,G_SCALAR); SPAGAIN; SP -= count ; ax = (SP - PL_stack_base) + 1 ; if (count!=1) croak("error calling perl function\n"); /* recover output value */ pvectorsv = ST(0); pvector = PDL->SvPDLV(pvectorsv); PDL->make_physical(pvector); xpass = (double *) pvector->data; for(i=0;i<ene;i++) { vector[i] = xpass[i]; } PUTBACK; FREETMPS; LEAVE; }
static CORBA_boolean put_fixed (GIOPSendBuffer *buf, CORBA_TypeCode tc, SV *sv) { CORBA_octet *outbuf; int count; STRLEN len; char *str; int index, i; int wire_length = (tc->digits + 2) / 2; /* If we have an even number of digits, first half-octet is 0 */ gboolean offset = (tc->digits % 2 == 0); dSP; ENTER; SAVETMPS; if (!sv_isa (sv, "CORBA::Fixed")) { PUSHMARK(sp); XPUSHs(sv_2mortal (newSVpv ("CORBA::Fixed", 0))); XPUSHs(sv); PUTBACK; count = perl_call_method("from_string", G_SCALAR); SPAGAIN; if (count != 1) { warn ("CORBA::Fixed::from_string returned %d items", count); while (count--) (void)POPs; PUTBACK; return CORBA_FALSE; } sv = POPs; PUTBACK; } PUSHMARK(sp); XPUSHs(sv); XPUSHs(sv_2mortal (newSViv (tc->digits))); XPUSHs(sv_2mortal (newSViv (tc->scale))); PUTBACK; count = perl_call_method("to_digits", G_SCALAR); SPAGAIN; if (count != 1) { warn ("CORBA::Fixed::to_digits returned %d items", count); while (count--) (void)POPs; PUTBACK; return CORBA_FALSE; } sv = POPs; str = SvPV(sv,len); if (len != (STRLEN)(tc->digits + 1)) { warn ("CORBA::Fixed::to_digits return wrong number of digits!\n"); return CORBA_FALSE; } outbuf = g_malloc ((tc->digits + 2) / 2); index = 1; for (i = 0; i < wire_length; i++) { CORBA_octet c; if (i == 0 && offset) c = 0; else c = (str[index++] - '0') << 4; if (i == wire_length - 1) c |= (str[0] == '-') ? 0xd : 0xc; else c |= str[index++] - '0'; outbuf[i] = c; } giop_send_buffer_append_mem_indirect (buf, outbuf, wire_length); g_free (outbuf); return CORBA_TRUE; }