SRL_STATIC_INLINE void srl_begin_decoding(pTHX_ srl_decoder_t *dec, SV *src, UV start_offset) { STRLEN len; unsigned char *tmp; /* Assert that we did not push a destructor before */ assert(!SRL_DEC_HAVE_OPTION(dec, SRL_F_DECODER_DESTRUCTOR_OK)); /* Push destructor, set destructor-is-pushed flag */ SRL_DEC_SET_OPTION(dec, SRL_F_DECODER_DESTRUCTOR_OK); /* Register our structure for destruction on scope exit */ SAVEDESTRUCTOR_X(&srl_decoder_destructor_hook, (void *)dec); SRL_DEC_RESET_VOLATILE_FLAGS(dec); tmp = (unsigned char*)SvPV(src, len); if (expect_false( start_offset > len )) { SRL_ERROR("Start offset is beyond input string length"); } dec->buf_start= dec->pos= tmp + start_offset; dec->buf_end= dec->buf_start + len - start_offset; dec->buf_len= len - start_offset; dec->bytes_consumed = 0; }
Perl_yyparse (pTHX_ int gramtype) #endif { dVAR; int yystate; int yyn; int yyresult; /* Lookahead token as an internal (translated) token number. */ int yytoken = 0; yy_parser *parser; /* the parser object */ yy_stack_frame *ps; /* current parser stack frame */ #define YYPOPSTACK parser->ps = --ps #define YYPUSHSTACK parser->ps = ++ps /* The variable used to return semantic value and location from the action routines: ie $$. */ YYSTYPE yyval; #ifndef PERL_IN_MADLY_C # ifdef PERL_MAD if (PL_madskills) return madparse(gramtype); # endif #endif YYDPRINTF ((Perl_debug_log, "Starting parse\n")); parser = PL_parser; ENTER; /* force parser state cleanup/restoration before we return */ SAVEPPTR(parser->yylval.pval); SAVEINT(parser->yychar); SAVEINT(parser->yyerrstatus); SAVEINT(parser->stack_size); SAVEINT(parser->yylen); SAVEVPTR(parser->stack); SAVEVPTR(parser->ps); /* initialise state for this parse */ parser->yychar = gramtype; parser->yyerrstatus = 0; parser->stack_size = YYINITDEPTH; parser->yylen = 0; Newx(parser->stack, YYINITDEPTH, yy_stack_frame); ps = parser->ps = parser->stack; ps->state = 0; SAVEDESTRUCTOR_X(S_clear_yystack, parser); /*------------------------------------------------------------. | yynewstate -- Push a new state, which is found in yystate. | `------------------------------------------------------------*/ yynewstate: yystate = ps->state; YYDPRINTF ((Perl_debug_log, "Entering state %d\n", yystate)); parser->yylen = 0; { size_t size = ps - parser->stack + 1; /* grow the stack? We always leave 1 spare slot, * in case of a '' -> 'foo' reduction */ if (size >= (size_t)parser->stack_size - 1) { /* this will croak on insufficient memory */ parser->stack_size *= 2; Renew(parser->stack, parser->stack_size, yy_stack_frame); ps = parser->ps = parser->stack + size -1; YYDPRINTF((Perl_debug_log, "parser stack size increased to %lu frames\n", (unsigned long int)parser->stack_size)); } } /* Do appropriate processing given the current state. */ /* Read a lookahead token if we need one and don't already have one. */ /* First try to decide what to do without reference to lookahead token. */ yyn = yypact[yystate]; if (yyn == YYPACT_NINF) goto yydefault; /* Not known => get a lookahead token if don't already have one. */ /* YYCHAR is either YYEMPTY or YYEOF or a valid lookahead symbol. */ if (parser->yychar == YYEMPTY) { YYDPRINTF ((Perl_debug_log, "Reading a token: ")); #ifdef PERL_IN_MADLY_C parser->yychar = PL_madskills ? madlex() : yylex(); #else parser->yychar = yylex(); #endif # ifdef EBCDIC if (parser->yychar >= 0 && parser->yychar < 255) { parser->yychar = NATIVE_TO_ASCII(parser->yychar); } # endif } if (parser->yychar <= YYEOF) { parser->yychar = yytoken = YYEOF; YYDPRINTF ((Perl_debug_log, "Now at end of input.\n")); } else { yytoken = YYTRANSLATE (parser->yychar); YYDSYMPRINTF ("Next token is", yytoken, &parser->yylval); } /* If the proper action on seeing token YYTOKEN is to reduce or to detect an error, take that action. */ yyn += yytoken; if (yyn < 0 || YYLAST < yyn || yycheck[yyn] != yytoken) goto yydefault; yyn = yytable[yyn]; if (yyn <= 0) { if (yyn == 0 || yyn == YYTABLE_NINF) goto yyerrlab; yyn = -yyn; goto yyreduce; } if (yyn == YYFINAL) YYACCEPT; /* Shift the lookahead token. */ YYDPRINTF ((Perl_debug_log, "Shifting token %s, ", yytname[yytoken])); /* Discard the token being shifted unless it is eof. */ if (parser->yychar != YYEOF) parser->yychar = YYEMPTY; YYPUSHSTACK; ps->state = yyn; ps->val = parser->yylval; ps->compcv = (CV*)SvREFCNT_inc(PL_compcv); ps->savestack_ix = PL_savestack_ix; #ifdef DEBUGGING ps->name = (const char *)(yytname[yytoken]); #endif /* Count tokens shifted since error; after three, turn off error status. */ if (parser->yyerrstatus) parser->yyerrstatus--; goto yynewstate; /*-----------------------------------------------------------. | yydefault -- do the default action for the current state. | `-----------------------------------------------------------*/ yydefault: yyn = yydefact[yystate]; if (yyn == 0) goto yyerrlab; goto yyreduce; /*-----------------------------. | yyreduce -- Do a reduction. | `-----------------------------*/ yyreduce: /* yyn is the number of a rule to reduce with. */ parser->yylen = yyr2[yyn]; /* If YYLEN is nonzero, implement the default value of the action: "$$ = $1". Otherwise, the following line sets YYVAL to garbage. This behavior is undocumented and Bison users should not rely upon it. Assigning to YYVAL unconditionally makes the parser a bit smaller, and it avoids a GCC warning that YYVAL may be used uninitialized. */ yyval = ps[1-parser->yylen].val; YY_STACK_PRINT(parser); YY_REDUCE_PRINT (yyn); switch (yyn) { #define dep() deprecate("\"do\" to call subroutines") #ifdef PERL_IN_MADLY_C # define IVAL(i) (i)->tk_lval.ival # define PVAL(p) (p)->tk_lval.pval # define TOKEN_GETMAD(a,b,c) token_getmad((a),(b),(c)) # define TOKEN_FREE(a) token_free(a) # define OP_GETMAD(a,b,c) op_getmad((a),(b),(c)) # define IF_MAD(a,b) (a) # define DO_MAD(a) a # define MAD #else # define IVAL(i) (i) # define PVAL(p) (p) # define TOKEN_GETMAD(a,b,c) # define TOKEN_FREE(a) # define OP_GETMAD(a,b,c) # define IF_MAD(a,b) (b) # define DO_MAD(a) # undef MAD #endif /* contains all the rule actions; auto-generated from perly.y */ #include "perly.act" } { int i; for (i=0; i< parser->yylen; i++) { SvREFCNT_dec(ps[-i].compcv); } } parser->ps = ps -= (parser->yylen-1); /* Now shift the result of the reduction. Determine what state that goes to, based on the state we popped back to and the rule number reduced by. */ ps->val = yyval; ps->compcv = (CV*)SvREFCNT_inc(PL_compcv); ps->savestack_ix = PL_savestack_ix; #ifdef DEBUGGING ps->name = (const char *)(yytname [yyr1[yyn]]); #endif yyn = yyr1[yyn]; yystate = yypgoto[yyn - YYNTOKENS] + ps[-1].state; if (0 <= yystate && yystate <= YYLAST && yycheck[yystate] == ps[-1].state) yystate = yytable[yystate]; else yystate = yydefgoto[yyn - YYNTOKENS]; ps->state = yystate; goto yynewstate; /*------------------------------------. | yyerrlab -- here on detecting error | `------------------------------------*/ yyerrlab: /* If not already recovering from an error, report this error. */ if (!parser->yyerrstatus) { yyerror ("syntax error"); } if (parser->yyerrstatus == 3) { /* If just tried and failed to reuse lookahead token after an error, discard it. */ /* Return failure if at end of input. */ if (parser->yychar == YYEOF) { /* Pop the error token. */ SvREFCNT_dec(ps->compcv); YYPOPSTACK; /* Pop the rest of the stack. */ while (ps > parser->stack) { YYDSYMPRINTF ("Error: popping", yystos[ps->state], &ps->val); LEAVE_SCOPE(ps->savestack_ix); if (yy_type_tab[yystos[ps->state]] == toketype_opval && ps->val.opval) { YYDPRINTF ((Perl_debug_log, "(freeing op)\n")); if (ps->compcv != PL_compcv) { PL_compcv = ps->compcv; PAD_SET_CUR_NOSAVE(CvPADLIST(PL_compcv), 1); } op_free(ps->val.opval); } SvREFCNT_dec(ps->compcv); YYPOPSTACK; } YYABORT; } YYDSYMPRINTF ("Error: discarding", yytoken, &parser->yylval); parser->yychar = YYEMPTY; } /* Else will try to reuse lookahead token after shifting the error token. */ goto yyerrlab1; /*----------------------------------------------------. | yyerrlab1 -- error raised explicitly by an action. | `----------------------------------------------------*/ yyerrlab1: parser->yyerrstatus = 3; /* Each real token shifted decrements this. */ for (;;) { yyn = yypact[yystate]; if (yyn != YYPACT_NINF) { yyn += YYTERROR; if (0 <= yyn && yyn <= YYLAST && yycheck[yyn] == YYTERROR) { yyn = yytable[yyn]; if (0 < yyn) break; } } /* Pop the current state because it cannot handle the error token. */ if (ps == parser->stack) YYABORT; YYDSYMPRINTF ("Error: popping", yystos[ps->state], &ps->val); LEAVE_SCOPE(ps->savestack_ix); if (yy_type_tab[yystos[ps->state]] == toketype_opval && ps->val.opval) { YYDPRINTF ((Perl_debug_log, "(freeing op)\n")); if (ps->compcv != PL_compcv) { PL_compcv = ps->compcv; PAD_SET_CUR_NOSAVE(CvPADLIST(PL_compcv), 1); } op_free(ps->val.opval); } SvREFCNT_dec(ps->compcv); YYPOPSTACK; yystate = ps->state; YY_STACK_PRINT(parser); } if (yyn == YYFINAL) YYACCEPT; YYDPRINTF ((Perl_debug_log, "Shifting error token, ")); YYPUSHSTACK; ps->state = yyn; ps->val = parser->yylval; ps->compcv = (CV*)SvREFCNT_inc(PL_compcv); ps->savestack_ix = PL_savestack_ix; #ifdef DEBUGGING ps->name ="<err>"; #endif goto yynewstate; /*-------------------------------------. | yyacceptlab -- YYACCEPT comes here. | `-------------------------------------*/ yyacceptlab: yyresult = 0; for (ps=parser->ps; ps > parser->stack; ps--) { SvREFCNT_dec(ps->compcv); } parser->ps = parser->stack; /* disable cleanup */ goto yyreturn; /*-----------------------------------. | yyabortlab -- YYABORT comes here. | `-----------------------------------*/ yyabortlab: yyresult = 1; goto yyreturn; yyreturn: LEAVE; /* force parser stack cleanup before we return */ return yyresult; }
void S_signals_set_handler(SV* handlersv, SV* namesv) { I32 i; /* Need to be careful with SvREFCNT_dec(), because that can have side * effects (due to closures). We must make sure that the new disposition * is in place before it is called. */ SV* to_dec = NULL; STRLEN len; const char *s; bool set_to_ignore = FALSE; bool set_to_default = FALSE; #ifdef HAS_SIGPROCMASK sigset_t set, save; SV* save_sv; #endif if ( SvROK(handlersv) ) { if ( SvTYPE(SvRV(handlersv)) != SVt_PVCV ) Perl_croak(aTHX_ "signal handler should be a code refernce, 'DEFAULT' or 'IGNORE'"); } else { const char *s = SvOK(handlersv) ? SvPV_const(handlersv, len) : "DEFAULT"; if ( strEQ(s,"IGNORE") ) set_to_ignore = TRUE; else if (strEQ(s,"DEFAULT")) set_to_default = TRUE; else Perl_croak(aTHX_ "signal handler should be a code reference or 'DEFAULT or 'IGNORE'"); } if (!PL_psig_ptr) { Newxz(PL_psig_ptr, SIG_SIZE, SV*); Newxz(PL_psig_name, SIG_SIZE, SV*); Newxz(PL_psig_pend, SIG_SIZE, int); } s = SvPV_const(namesv,len); i = whichsig(s); /* ...no, a brick */ if (i <= 0) { Perl_croak(aTHX_ "No such signal: SIG%s", s); } #ifdef HAS_SIGPROCMASK /* Avoid having the signal arrive at a bad time, if possible. */ sigemptyset(&set); sigaddset(&set,i); sigprocmask(SIG_BLOCK, &set, &save); ENTER; save_sv = newSVpvn((char *)(&save), sizeof(sigset_t)); SAVEFREESV(save_sv); SAVEDESTRUCTOR_X(restore_sigmask, save_sv); #endif PERL_ASYNC_CHECK(); #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS) if (!PL_sig_handlers_initted) Perl_csighandler_init(); #endif #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS PL_sig_ignoring[i] = 0; #endif #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS PL_sig_defaulting[i] = 0; #endif SvREFCNT_dec(PL_psig_name[i]); to_dec = PL_psig_ptr[i]; PL_psig_ptr[i] = NULL; PL_psig_name[i] = newSVpvn(s, len); SvREADONLY_on(PL_psig_name[i]); if (SvROK(handlersv)) { PL_psig_ptr[i] = SvREFCNT_inc(SvRV(handlersv)); (void)rsignal(i, PL_csighandlerp); #ifdef HAS_SIGPROCMASK LEAVE; #endif if(to_dec) SvREFCNT_dec(to_dec); return; } if (set_to_ignore) { #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS PL_sig_ignoring[i] = 1; (void)rsignal(i, PL_csighandlerp); #else (void)rsignal(i, (Sighandler_t) SIG_IGN); #endif } else { #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS PL_sig_defaulting[i] = 1; (void)rsignal(i, PL_csighandlerp); #else (void)rsignal(i, (Sighandler_t) SIG_DFL); #endif } #ifdef HAS_SIGPROCMASK if(i) LEAVE; #endif if(to_dec) SvREFCNT_dec(to_dec); }