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);
}
