static int perl_source_event(PERL_SOURCE_REC *rec) { dSP; int retcount; ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs(sv_mortalcopy(rec->data)); PUTBACK; perl_source_ref(rec); retcount = perl_call_sv(rec->func, G_EVAL|G_SCALAR); SPAGAIN; if (SvTRUE(ERRSV)) { char *error = g_strdup(SvPV(ERRSV, PL_na)); signal_emit("script error", 2, rec->script, error); g_free(error); } if (perl_source_unref(rec) && rec->once) perl_source_destroy(rec); PUTBACK; FREETMPS; LEAVE; return 1; }
static void cmd_perl(const char *data) { dSP; GString *code; char *uses; SV *sv; ENTER; SAVETMPS; PUSHMARK(SP); code = g_string_new(NULL); uses = perl_get_use_list(); g_string_sprintf(code, "sub { use Irssi;%s\n%s }", uses, data); sv = perl_eval_pv(code->str, TRUE); perl_call_sv(sv, G_VOID|G_NOARGS|G_EVAL|G_DISCARD); g_free(uses); g_string_free(code, TRUE); SPAGAIN; if (SvTRUE(ERRSV)) { STRLEN n_a; signal_emit("gui dialog", 2, "error", SvPV(ERRSV, n_a)); } PUTBACK; FREETMPS; LEAVE; }
void *svmagic_cast(pdl_magic *mag) { pdl_magic_perlfunc *magp = (pdl_magic_perlfunc *)mag; dSP; PUSHMARK(sp); perl_call_sv(magp->sv, G_DISCARD | G_NOARGS); return NULL; }
static SV * plperl_call_perl_trigger_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo, SV *td) { dSP; SV *retval; Trigger *tg_trigger; int i; int count; ENTER; SAVETMPS; PUSHMARK(sp); XPUSHs(td); tg_trigger = ((TriggerData *) fcinfo->context)->tg_trigger; for (i = 0; i < tg_trigger->tgnargs; i++) XPUSHs(sv_2mortal(newSVpv(tg_trigger->tgargs[i], 0))); PUTBACK; /* Do NOT use G_KEEPERR here */ count = perl_call_sv(desc->reference, G_SCALAR | G_EVAL); SPAGAIN; if (count != 1) { PUTBACK; FREETMPS; LEAVE; elog(ERROR, "didn't get a return item from trigger function"); } if (SvTRUE(ERRSV)) { (void) POPs; PUTBACK; FREETMPS; LEAVE; /* XXX need to find a way to assign an errcode here */ ereport(ERROR, (errmsg("error from Perl trigger function: %s", strip_trailing_ws(SvPV(ERRSV, PL_na))))); } retval = newSVsv(POPs); PUTBACK; FREETMPS; LEAVE; return retval; }
//***************************************************************************** // // SYNOPSIS // bool perl_visitor::operator()( HTML_Node *node, int depth, bool is_end_tag ) const // // DESCRIPTION // // This function serves as the "glue code" between the called visitor // function in C++ and the real visitor function in Perl. // // PARAMETERS // // node The HTML node we're currently visiting. // // depth How far down into the HTML tree we are (depth starts at // zero). // // is_end_tag This is set to true only after visiting all of an HTML // node's child nodes, if any. // // RETURN VALUE // // Returns the value of the Perl function. // // SEE ALSO // // Sriram Srinivasan. "Advanced Perl Programming," O'Reilly and // Associates, Inc., Sebastopol, CA, 1997, pp. 352-353. // //***************************************************************************** { dSP; ENTER; SAVETMPS; PUSHMARK( sp ); if ( hash_ref_ ) XPUSHs( sv_mortalcopy( hash_ref_ ) ); XPUSHs( blessed( "HTML_Node", node ) ); XPUSHs( sv_2mortal( newSViv( depth ) ) ); XPUSHs( sv_2mortal( newSViv( is_end_tag ) ) ); PUTBACK; int const result_count = perl_call_sv( func_ref_, G_SCALAR ); SPAGAIN; if ( result_count != 1 ) croak( "HTML::Tree: " "visitor function didn't return a single scalar value " "(it returned %d)", result_count ); bool const result = POPi; PUTBACK; FREETMPS; LEAVE; return result; }
/* Called by context when a branch occurs */ JSBool PJS_branch_handler(JSContext *cx, JSScript *script) { dSP; PJS_Context *pcx; SV *rv; I32 rc = 0; JSBool status = JS_TRUE; pcx = PJS_GET_CONTEXT(cx); if (pcx != NULL && pcx->branch_handler) { ENTER ; SAVETMPS ; PUSHMARK(SP); rc = perl_call_sv(SvRV(pcx->branch_handler), G_SCALAR | G_EVAL); SPAGAIN; rv = POPs; if (!SvTRUE(rv)) { status = JS_FALSE; } if (SvTRUE(ERRSV)) { sv_setsv(ERRSV, &PL_sv_undef); status = JS_FALSE; } PUTBACK; FREETMPS; LEAVE; } return status; }
static SV * plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo) { dSP; SV *retval; int i; int count; SV *sv; ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs(&PL_sv_undef); /* no trigger data */ for (i = 0; i < desc->nargs; i++) { if (fcinfo->argnull[i]) XPUSHs(&PL_sv_undef); else if (desc->arg_is_rowtype[i]) { HeapTupleHeader td; Oid tupType; int32 tupTypmod; TupleDesc tupdesc; HeapTupleData tmptup; SV *hashref; td = DatumGetHeapTupleHeader(fcinfo->arg[i]); /* Extract rowtype info and find a tupdesc */ tupType = HeapTupleHeaderGetTypeId(td); tupTypmod = HeapTupleHeaderGetTypMod(td); tupdesc = lookup_rowtype_tupdesc(tupType, tupTypmod); /* Build a temporary HeapTuple control structure */ tmptup.t_len = HeapTupleHeaderGetDatumLength(td); tmptup.t_data = td; hashref = plperl_hash_from_tuple(&tmptup, tupdesc); XPUSHs(sv_2mortal(hashref)); } else { char *tmp; tmp = DatumGetCString(FunctionCall1(&(desc->arg_out_func[i]), fcinfo->arg[i])); sv = newSVpv(tmp, 0); #if PERL_BCDVERSION >= 0x5006000L if (GetDatabaseEncoding() == PG_UTF8) SvUTF8_on(sv); #endif XPUSHs(sv_2mortal(sv)); pfree(tmp); } } PUTBACK; /* Do NOT use G_KEEPERR here */ count = perl_call_sv(desc->reference, G_SCALAR | G_EVAL); SPAGAIN; if (count != 1) { PUTBACK; FREETMPS; LEAVE; elog(ERROR, "didn't get a return item from function"); } if (SvTRUE(ERRSV)) { (void) POPs; PUTBACK; FREETMPS; LEAVE; /* XXX need to find a way to assign an errcode here */ ereport(ERROR, (errmsg("error from Perl function: %s", strip_trailing_ws(SvPV(ERRSV, PL_na))))); } retval = newSVsv(POPs); PUTBACK; FREETMPS; LEAVE; return retval; }
static void perl_call_signal(PERL_SCRIPT_REC *script, SV *func, int signal_id, gconstpointer *args) { dSP; PERL_SIGNAL_ARGS_REC *rec; SV *sv, *perlarg, *saved_args[SIGNAL_MAX_ARGUMENTS]; AV *av; void *arg; int n; ENTER; SAVETMPS; PUSHMARK(sp); /* push signal argument to perl stack */ rec = perl_signal_args_find(signal_id); memset(saved_args, 0, sizeof(saved_args)); for (n = 0; n < SIGNAL_MAX_ARGUMENTS && rec != NULL && rec->args[n] != NULL; n++) { arg = (void *) args[n]; if (strncmp(rec->args[n], "glistptr_", 9) == 0) { /* pointer to linked list - push as AV */ GList *tmp, **ptr; int is_iobject, is_str; is_iobject = strcmp(rec->args[n]+9, "iobject") == 0; is_str = strcmp(rec->args[n]+9, "char*") == 0; av = newAV(); ptr = arg; for (tmp = *ptr; tmp != NULL; tmp = tmp->next) { sv = is_iobject ? iobject_bless((SERVER_REC *) tmp->data) : is_str ? new_pv(tmp->data) : irssi_bless_plain(rec->args[n]+9, tmp->data); av_push(av, sv); } saved_args[n] = perlarg = newRV_noinc((SV *) av); } else if (strcmp(rec->args[n], "int") == 0) perlarg = newSViv((IV)arg); else if (arg == NULL) perlarg = &PL_sv_undef; else if (strcmp(rec->args[n], "string") == 0) perlarg = new_pv(arg); else if (strcmp(rec->args[n], "ulongptr") == 0) perlarg = newSViv(*(unsigned long *) arg); else if (strcmp(rec->args[n], "intptr") == 0) saved_args[n] = perlarg = newRV_noinc(newSViv(*(int *) arg)); else if (strncmp(rec->args[n], "gslist_", 7) == 0) { /* linked list - push as AV */ GSList *tmp; int is_iobject; is_iobject = strcmp(rec->args[n]+7, "iobject") == 0; av = newAV(); for (tmp = arg; tmp != NULL; tmp = tmp->next) { sv = is_iobject ? iobject_bless((SERVER_REC *) tmp->data) : irssi_bless_plain(rec->args[n]+7, tmp->data); av_push(av, sv); } perlarg = newRV_noinc((SV *) av); } else if (strcmp(rec->args[n], "iobject") == 0) { /* "irssi object" - any struct that has "int type; int chat_type" as it's first variables (server, channel, ..) */ perlarg = iobject_bless((SERVER_REC *) arg); } else if (strcmp(rec->args[n], "siobject") == 0) { /* "simple irssi object" - any struct that has int type; as it's first variable (dcc) */ perlarg = simple_iobject_bless((SERVER_REC *) arg); } else { /* blessed object */ perlarg = plain_bless(arg, rec->args[n]); } XPUSHs(sv_2mortal(perlarg)); } PUTBACK; perl_call_sv(func, G_EVAL|G_DISCARD); SPAGAIN; if (SvTRUE(ERRSV)) { char *error = g_strdup(SvPV_nolen(ERRSV)); signal_emit("script error", 2, script, error); g_free(error); rec = NULL; } /* restore arguments the perl script modified */ for (n = 0; n < SIGNAL_MAX_ARGUMENTS && rec != NULL && rec->args[n] != NULL; n++) { arg = (void *) args[n]; if (saved_args[n] == NULL) continue; if (strcmp(rec->args[n], "intptr") == 0) { int *val = arg; *val = SvIV(SvRV(saved_args[n])); } else if (strncmp(rec->args[n], "glistptr_", 9) == 0) { GList **ret = arg; GList *out = NULL; void *val; int count; av = (AV *) SvRV(saved_args[n]); count = av_len(av); while (count-- >= 0) { sv = av_shift(av); if (SvPOKp(sv)) val = g_strdup(SvPV_nolen(sv)); else val = GINT_TO_POINTER(SvIV(sv)); out = g_list_append(out, val); } if (strcmp(rec->args[n]+9, "char*") == 0) g_list_foreach(*ret, (GFunc) g_free, NULL); g_list_free(*ret); *ret = out; } } FREETMPS; LEAVE; }
int perl_trapd_handler( netsnmp_pdu *pdu, netsnmp_transport *transport, netsnmp_trapd_handler *handler) { trapd_cb_data *cb_data; SV *pcallback; netsnmp_variable_list *vb; netsnmp_oid *o; SV *arg; SV *rarg; SV **tmparray; int i, c = 0; u_char *outbuf; size_t ob_len = 0, oo_len = 0; AV *varbinds; HV *pduinfo; dSP; ENTER; SAVETMPS; if (!pdu || !handler) return 0; /* nuke v1 PDUs */ if (pdu->command == SNMP_MSG_TRAP) pdu = convert_v1pdu_to_v2(pdu); cb_data = handler->handler_data; if (!cb_data || !cb_data->perl_cb) return 0; pcallback = cb_data->perl_cb; /* get PDU related info */ pduinfo = newHV(); #define STOREPDU(n, v) hv_store(pduinfo, n, strlen(n), v, 0) #define STOREPDUi(n, v) STOREPDU(n, newSViv(v)) #define STOREPDUs(n, v) STOREPDU(n, newSVpv(v, 0)) STOREPDUi("version", pdu->version); STOREPDUs("notificationtype", ((pdu->command == SNMP_MSG_INFORM) ? "INFORM":"TRAP")); STOREPDUi("requestid", pdu->reqid); STOREPDUi("messageid", pdu->msgid); STOREPDUi("transactionid", pdu->transid); STOREPDUi("errorstatus", pdu->errstat); STOREPDUi("errorindex", pdu->errindex); if (pdu->version == 3) { STOREPDUi("securitymodel", pdu->securityModel); STOREPDUi("securitylevel", pdu->securityLevel); STOREPDU("contextName", newSVpv(pdu->contextName, pdu->contextNameLen)); STOREPDU("contextEngineID", newSVpv(pdu->contextEngineID, pdu->contextEngineIDLen)); STOREPDU("securityEngineID", newSVpv(pdu->securityEngineID, pdu->securityEngineIDLen)); STOREPDU("securityName", newSVpv(pdu->securityName, pdu->securityNameLen)); } else { STOREPDU("community", newSVpv(pdu->community, pdu->community_len)); } if (transport && transport->f_fmtaddr) { char *tstr = transport->f_fmtaddr(transport, pdu->transport_data, pdu->transport_data_length); STOREPDUs("receivedfrom", tstr); free(tstr); } /* * collect OID objects in a temp array first */ /* get VARBIND related info */ i = count_varbinds(pdu->variables); tmparray = malloc(sizeof(*tmparray) * i); for(vb = pdu->variables; vb; vb = vb->next_variable) { /* get the oid */ o = SNMP_MALLOC_TYPEDEF(netsnmp_oid); o->name = o->namebuf; o->len = vb->name_length; memcpy(o->name, vb->name, vb->name_length * sizeof(oid)); #undef CALL_EXTERNAL_OID_NEW #ifdef CALL_EXTERNAL_OID_NEW PUSHMARK(sp); rarg = sv_2mortal(newSViv((IV) 0)); arg = sv_2mortal(newSVrv(rarg, "netsnmp_oidPtr")); sv_setiv(arg, (IV) o); XPUSHs(rarg); PUTBACK; i = perl_call_pv("NetSNMP::OID::newwithptr", G_SCALAR); SPAGAIN; if (i != 1) { snmp_log(LOG_ERR, "unhandled OID error.\n"); /* ack XXX */ } /* get the value */ tmparray[c++] = POPs; SvREFCNT_inc(tmparray[c-1]); PUTBACK; #else /* build it and bless ourselves */ { HV *hv = newHV(); SV *rv = newRV_noinc((SV *) hv); SV *rvsub = newRV_noinc((SV *) newSViv((UV) o)); SV *sv; rvsub = sv_bless(rvsub, gv_stashpv("netsnmp_oidPtr", 1)); hv_store(hv, "oidptr", 6, rvsub, 0); rv = sv_bless(rv, gv_stashpv("NetSNMP::OID", 1)); tmparray[c++] = rv; } #endif /* build oid ourselves */ } /* * build the varbind lists */ varbinds = newAV(); for(vb = pdu->variables, i = 0; vb; vb = vb->next_variable, i++) { /* push the oid */ AV *vba; vba = newAV(); /* get the value */ outbuf = NULL; ob_len = 0; oo_len = 0; sprint_realloc_by_type(&outbuf, &ob_len, &oo_len, 1, vb, 0, 0, 0); av_push(vba,tmparray[i]); av_push(vba,newSVpvn(outbuf, oo_len)); free(outbuf); av_push(vba,newSViv(vb->type)); av_push(varbinds, (SV *) newRV_noinc((SV *) vba)); } PUSHMARK(sp); /* store the collected information on the stack */ XPUSHs(sv_2mortal(newRV_noinc((SV*) pduinfo))); XPUSHs(sv_2mortal(newRV_noinc((SV*) varbinds))); /* put the stack back in order */ PUTBACK; /* actually call the callback function */ if (SvTYPE(pcallback) == SVt_PVCV) { perl_call_sv(pcallback, G_DISCARD); /* XXX: it discards the results, which isn't right */ } else if (SvROK(pcallback) && SvTYPE(SvRV(pcallback)) == SVt_PVCV) { /* reference to code */ perl_call_sv(SvRV(pcallback), G_DISCARD); } else { snmp_log(LOG_ERR, " tried to call a perl function but failed to understand its type: (ref = %x, svrok: %lu, SVTYPE: %lu)\n", (uintptr_t)pcallback, SvROK(pcallback), SvTYPE(pcallback)); } #ifdef DUMPIT fprintf(stderr, "DUMPDUMPDUMPDUMPDUMPDUMP\n"); sv_dump(pduinfo); fprintf(stderr, "--------------------\n"); sv_dump(varbinds); #endif /* svREFCNT_dec((SV *) pduinfo); */ #ifdef NOT_THIS { SV *vba; while(vba = av_pop(varbinds)) { av_undef((AV *) vba); } } av_undef(varbinds); #endif free(tmparray); /* Not needed because of the G_DISCARD flag (I think) */ /* SPAGAIN; */ /* PUTBACK; */ #ifndef __x86_64__ FREETMPS; /* FIXME: known to cause a segfault on x86-64 */ #endif LEAVE; return NETSNMPTRAPD_HANDLER_OK; }
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; } } }
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; }