/* toke.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
#define PERL_IN_TOKE_C
#include "perl.h"
-#define yychar (*PL_yycharp)
-#define yylval (*PL_yylvalp)
+#define yylval (PL_parser->yylval)
+
+/* YYINITDEPTH -- initial size of the parser's stacks. */
+#define YYINITDEPTH 200
+
+/* XXX temporary backwards compatibility */
+#define PL_lex_brackets (PL_parser->lex_brackets)
+#define PL_lex_brackstack (PL_parser->lex_brackstack)
+#define PL_lex_casemods (PL_parser->lex_casemods)
+#define PL_lex_casestack (PL_parser->lex_casestack)
+#define PL_lex_defer (PL_parser->lex_defer)
+#define PL_lex_dojoin (PL_parser->lex_dojoin)
+#define PL_lex_expect (PL_parser->lex_expect)
+#define PL_lex_formbrack (PL_parser->lex_formbrack)
+#define PL_lex_inpat (PL_parser->lex_inpat)
+#define PL_lex_inwhat (PL_parser->lex_inwhat)
+#define PL_lex_op (PL_parser->lex_op)
+#define PL_lex_repl (PL_parser->lex_repl)
+#define PL_lex_starts (PL_parser->lex_starts)
+#define PL_lex_stuff (PL_parser->lex_stuff)
+#define PL_multi_start (PL_parser->multi_start)
+#define PL_multi_open (PL_parser->multi_open)
+#define PL_multi_close (PL_parser->multi_close)
+#define PL_pending_ident (PL_parser->pending_ident)
+#define PL_preambled (PL_parser->preambled)
+#define PL_sublex_info (PL_parser->sublex_info)
+#define PL_linestr (PL_parser->linestr)
+#define PL_expect (PL_parser->expect)
+#define PL_copline (PL_parser->copline)
+#define PL_bufptr (PL_parser->bufptr)
+#define PL_oldbufptr (PL_parser->oldbufptr)
+#define PL_oldoldbufptr (PL_parser->oldoldbufptr)
+#define PL_linestart (PL_parser->linestart)
+#define PL_bufend (PL_parser->bufend)
+#define PL_last_uni (PL_parser->last_uni)
+#define PL_last_lop (PL_parser->last_lop)
+#define PL_last_lop_op (PL_parser->last_lop_op)
+#define PL_lex_state (PL_parser->lex_state)
+#define PL_rsfp (PL_parser->rsfp)
+#define PL_rsfp_filters (PL_parser->rsfp_filters)
+#define PL_in_my (PL_parser->in_my)
+#define PL_in_my_stash (PL_parser->in_my_stash)
+#define PL_tokenbuf (PL_parser->tokenbuf)
+#define PL_multi_end (PL_parser->multi_end)
+#define PL_error_count (PL_parser->error_count)
+
+#ifdef PERL_MAD
+# define PL_endwhite (PL_parser->endwhite)
+# define PL_faketokens (PL_parser->faketokens)
+# define PL_lasttoke (PL_parser->lasttoke)
+# define PL_nextwhite (PL_parser->nextwhite)
+# define PL_realtokenstart (PL_parser->realtokenstart)
+# define PL_skipwhite (PL_parser->skipwhite)
+# define PL_thisclose (PL_parser->thisclose)
+# define PL_thismad (PL_parser->thismad)
+# define PL_thisopen (PL_parser->thisopen)
+# define PL_thisstuff (PL_parser->thisstuff)
+# define PL_thistoken (PL_parser->thistoken)
+# define PL_thiswhite (PL_parser->thiswhite)
+# define PL_thiswhite (PL_parser->thiswhite)
+# define PL_nexttoke (PL_parser->nexttoke)
+# define PL_curforce (PL_parser->curforce)
+#else
+# define PL_nexttoke (PL_parser->nexttoke)
+# define PL_nexttype (PL_parser->nexttype)
+# define PL_nextval (PL_parser->nextval)
+#endif
+
+static int
+S_pending_ident(pTHX);
static const char ident_too_long[] = "Identifier too long";
static const char commaless_variable_list[] = "comma-less variable list";
-static void restore_rsfp(pTHX_ void *f);
#ifndef PERL_NO_UTF16_FILTER
static I32 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen);
static I32 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen);
}
#endif
+
+
/*
* Perl_lex_start
- * Initialize variables. Uses the Perl save_stack to save its state (for
- * recursive calls to the parser).
+ *
+ * Create a parser object and initialise its parser and lexer fields
+ *
+ * rsfp is the opened file handle to read from (if any),
+ *
+ * line holds any initial content already read from the file (or in
+ * the case of no file, such as an eval, the whole contents);
+ *
+ * new_filter indicates that this is a new file and it shouldn't inherit
+ * the filters from the current parser (ie require).
*/
void
-Perl_lex_start(pTHX_ SV *line)
+Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, bool new_filter)
{
dVAR;
- const char *s;
+ const char *s = NULL;
STRLEN len;
+ yy_parser *parser, *oparser;
+
+ /* create and initialise a parser */
+
+ Newxz(parser, 1, yy_parser);
+ parser->old_parser = oparser = PL_parser;
+ PL_parser = parser;
+
+ Newx(parser->stack, YYINITDEPTH, yy_stack_frame);
+ parser->ps = parser->stack;
+ parser->stack_size = YYINITDEPTH;
+
+ parser->stack->state = 0;
+ parser->yyerrstatus = 0;
+ parser->yychar = YYEMPTY; /* Cause a token to be read. */
+
+ /* on scope exit, free this parser and restore any outer one */
+ SAVEPARSER(parser);
+ parser->saved_curcop = PL_curcop;
+
+ /* initialise lexer state */
- SAVEI32(PL_lex_dojoin);
- SAVEI32(PL_lex_brackets);
- SAVEI32(PL_lex_casemods);
- SAVEI32(PL_lex_starts);
- SAVEI32(PL_lex_state);
- SAVEVPTR(PL_lex_inpat);
- SAVEI32(PL_lex_inwhat);
-#ifdef PERL_MAD
- if (PL_lex_state == LEX_KNOWNEXT) {
- I32 toke = PL_lasttoke;
- while (--toke >= 0) {
- SAVEI32(PL_nexttoke[toke].next_type);
- SAVEVPTR(PL_nexttoke[toke].next_val);
- if (PL_madskills)
- SAVEVPTR(PL_nexttoke[toke].next_mad);
- }
- SAVEI32(PL_lasttoke);
- }
- if (PL_madskills) {
- SAVESPTR(PL_thistoken);
- SAVESPTR(PL_thiswhite);
- SAVESPTR(PL_nextwhite);
- SAVESPTR(PL_thisopen);
- SAVESPTR(PL_thisclose);
- SAVESPTR(PL_thisstuff);
- SAVEVPTR(PL_thismad);
- SAVEI32(PL_realtokenstart);
- SAVEI32(PL_faketokens);
- }
- SAVEI32(PL_curforce);
-#else
- if (PL_lex_state == LEX_KNOWNEXT) {
- I32 toke = PL_nexttoke;
- while (--toke >= 0) {
- SAVEI32(PL_nexttype[toke]);
- SAVEVPTR(PL_nextval[toke]);
- }
- SAVEI32(PL_nexttoke);
- }
-#endif
- SAVECOPLINE(PL_curcop);
- SAVEPPTR(PL_bufptr);
- SAVEPPTR(PL_bufend);
- SAVEPPTR(PL_oldbufptr);
- SAVEPPTR(PL_oldoldbufptr);
- SAVEPPTR(PL_last_lop);
- SAVEPPTR(PL_last_uni);
- SAVEPPTR(PL_linestart);
- SAVESPTR(PL_linestr);
- SAVEGENERICPV(PL_lex_brackstack);
- SAVEGENERICPV(PL_lex_casestack);
- SAVEDESTRUCTOR_X(restore_rsfp, PL_rsfp);
- SAVESPTR(PL_lex_stuff);
- SAVEI32(PL_lex_defer);
- SAVEI32(PL_sublex_info.sub_inwhat);
- SAVESPTR(PL_lex_repl);
- SAVEINT(PL_expect);
- SAVEINT(PL_lex_expect);
-
- PL_lex_state = LEX_NORMAL;
- PL_lex_defer = 0;
- PL_expect = XSTATE;
- PL_lex_brackets = 0;
- Newx(PL_lex_brackstack, 120, char);
- Newx(PL_lex_casestack, 12, char);
- PL_lex_casemods = 0;
- *PL_lex_casestack = '\0';
- PL_lex_dojoin = 0;
- PL_lex_starts = 0;
- PL_lex_stuff = NULL;
- PL_lex_repl = NULL;
- PL_lex_inpat = 0;
#ifdef PERL_MAD
- PL_lasttoke = 0;
+ parser->curforce = -1;
#else
- PL_nexttoke = 0;
-#endif
- PL_lex_inwhat = 0;
- PL_sublex_info.sub_inwhat = 0;
- PL_linestr = line;
- if (SvREADONLY(PL_linestr))
- PL_linestr = sv_2mortal(newSVsv(PL_linestr));
- s = SvPV_const(PL_linestr, len);
- if (!len || s[len-1] != ';') {
- if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
- PL_linestr = sv_2mortal(newSVsv(PL_linestr));
- sv_catpvs(PL_linestr, "\n;");
- }
- SvTEMP_off(PL_linestr);
- PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
- PL_bufend = PL_bufptr + SvCUR(PL_linestr);
- PL_last_lop = PL_last_uni = NULL;
- PL_rsfp = 0;
+ parser->nexttoke = 0;
+#endif
+ parser->copline = NOLINE;
+ parser->lex_state = LEX_NORMAL;
+ parser->expect = XSTATE;
+ parser->rsfp = rsfp;
+ parser->rsfp_filters = (new_filter || !oparser) ? newAV()
+ : (AV*)SvREFCNT_inc(oparser->rsfp_filters);
+
+ Newx(parser->lex_brackstack, 120, char);
+ Newx(parser->lex_casestack, 12, char);
+ *parser->lex_casestack = '\0';
+
+ if (line) {
+ s = SvPV_const(line, len);
+ } else {
+ len = 0;
+ }
+
+ if (!len) {
+ parser->linestr = newSVpvs("\n;");
+ } else if (SvREADONLY(line) || s[len-1] != ';') {
+ parser->linestr = newSVsv(line);
+ if (s[len-1] != ';')
+ sv_catpvs(parser->linestr, "\n;");
+ } else {
+ SvTEMP_off(line);
+ SvREFCNT_inc_simple_void_NN(line);
+ parser->linestr = line;
+ }
+ parser->oldoldbufptr =
+ parser->oldbufptr =
+ parser->bufptr =
+ parser->linestart = SvPVX(parser->linestr);
+ parser->bufend = parser->bufptr + SvCUR(parser->linestr);
+ parser->last_lop = parser->last_uni = NULL;
+}
+
+
+/* delete a parser object */
+
+void
+Perl_parser_free(pTHX_ const yy_parser *parser)
+{
+ PL_curcop = parser->saved_curcop;
+ SvREFCNT_dec(parser->linestr);
+
+ if (parser->rsfp == PerlIO_stdin())
+ PerlIO_clearerr(parser->rsfp);
+ else if (parser->rsfp && parser->old_parser
+ && parser->rsfp != parser->old_parser->rsfp)
+ PerlIO_close(parser->rsfp);
+ SvREFCNT_dec(parser->rsfp_filters);
+
+ Safefree(parser->stack);
+ Safefree(parser->lex_brackstack);
+ Safefree(parser->lex_casestack);
+ PL_parser = parser->old_parser;
+ Safefree(parser);
}
+
/*
* Perl_lex_end
* Finalizer for lexing operations. Must be called when the parser is
*/
STATIC void
-S_incline(pTHX_ char *s)
+S_incline(pTHX_ const char *s)
{
dVAR;
- char *t;
- char *n;
- char *e;
- char ch;
+ const char *t;
+ const char *n;
+ const char *e;
CopLINE_inc(PL_curcop);
if (*s++ != '#')
if (*e != '\n' && *e != '\0')
return; /* false alarm */
- ch = *t;
- *t = '\0';
if (t - s > 0) {
+ const STRLEN len = t - s;
#ifndef USE_ITHREADS
const char * const cf = CopFILE(PL_curcop);
STRLEN tmplen = cf ? strlen(cf) : 0;
if (tmplen > 7 && strnEQ(cf, "(eval ", 6)) {
/* must copy *{"::_<(eval N)[oldfilename:L]"}
* to *{"::_<newfilename"} */
- char smallbuf[256], smallbuf2[256];
- char *tmpbuf, *tmpbuf2;
- GV **gvp, *gv2;
- STRLEN tmplen2 = strlen(s);
- if (tmplen + 3 < sizeof smallbuf)
+ /* However, the long form of evals is only turned on by the
+ debugger - usually they're "(eval %lu)" */
+ char smallbuf[128];
+ char *tmpbuf;
+ GV **gvp;
+ STRLEN tmplen2 = len;
+ if (tmplen + 2 <= sizeof smallbuf)
tmpbuf = smallbuf;
else
- Newx(tmpbuf, tmplen + 3, char);
- if (tmplen2 + 3 < sizeof smallbuf2)
- tmpbuf2 = smallbuf2;
- else
- Newx(tmpbuf2, tmplen2 + 3, char);
- tmpbuf[0] = tmpbuf2[0] = '_';
- tmpbuf[1] = tmpbuf2[1] = '<';
- memcpy(tmpbuf + 2, cf, ++tmplen);
- memcpy(tmpbuf2 + 2, s, ++tmplen2);
- ++tmplen; ++tmplen2;
+ Newx(tmpbuf, tmplen + 2, char);
+ tmpbuf[0] = '_';
+ tmpbuf[1] = '<';
+ memcpy(tmpbuf + 2, cf, tmplen);
+ tmplen += 2;
gvp = (GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, FALSE);
if (gvp) {
+ char *tmpbuf2;
+ GV *gv2;
+
+ if (tmplen2 + 2 <= sizeof smallbuf)
+ tmpbuf2 = smallbuf;
+ else
+ Newx(tmpbuf2, tmplen2 + 2, char);
+
+ if (tmpbuf2 != smallbuf || tmpbuf != smallbuf) {
+ /* Either they malloc'd it, or we malloc'd it,
+ so no prefix is present in ours. */
+ tmpbuf2[0] = '_';
+ tmpbuf2[1] = '<';
+ }
+
+ memcpy(tmpbuf2 + 2, s, tmplen2);
+ tmplen2 += 2;
+
gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
- if (!isGV(gv2))
+ if (!isGV(gv2)) {
gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
- /* adjust ${"::_<newfilename"} to store the new file name */
- GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
- GvHV(gv2) = (HV*)SvREFCNT_inc(GvHV(*gvp));
- GvAV(gv2) = (AV*)SvREFCNT_inc(GvAV(*gvp));
+ /* adjust ${"::_<newfilename"} to store the new file name */
+ GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
+ GvHV(gv2) = (HV*)SvREFCNT_inc(GvHV(*gvp));
+ GvAV(gv2) = (AV*)SvREFCNT_inc(GvAV(*gvp));
+ }
+
+ if (tmpbuf2 != smallbuf) Safefree(tmpbuf2);
}
if (tmpbuf != smallbuf) Safefree(tmpbuf);
- if (tmpbuf2 != smallbuf2) Safefree(tmpbuf2);
}
#endif
CopFILE_free(PL_curcop);
- CopFILE_set(PL_curcop, s);
+ CopFILE_setn(PL_curcop, s, len);
}
- *t = ch;
CopLINE_set(PL_curcop, atoi(n)-1);
}
return s;
if (PL_skipwhite) {
if (!PL_thiswhite)
- PL_thiswhite = newSVpvn("",0);
+ PL_thiswhite = newSVpvs("");
sv_catsv(PL_thiswhite, PL_skipwhite);
sv_free(PL_skipwhite);
PL_skipwhite = 0;
PL_realtokenstart = -1;
if (PL_skipwhite) {
if (!PL_nextwhite)
- PL_nextwhite = newSVpvn("",0);
+ PL_nextwhite = newSVpvs("");
sv_catsv(PL_nextwhite, PL_skipwhite);
sv_free(PL_skipwhite);
PL_skipwhite = 0;
}
if (PL_skipwhite) {
if (!*svp)
- *svp = newSVpvn("",0);
+ *svp = newSVpvs("");
sv_setsv(*svp, PL_skipwhite);
sv_free(PL_skipwhite);
PL_skipwhite = 0;
}
#endif
+STATIC void
+S_update_debugger_info(pTHX_ SV *orig_sv, const char *buf, STRLEN len)
+{
+ AV *av = CopFILEAVx(PL_curcop);
+ if (av) {
+ SV * const sv = newSV_type(SVt_PVMG);
+ if (orig_sv)
+ sv_setsv(sv, orig_sv);
+ else
+ sv_setpvn(sv, buf, len);
+ (void)SvIOK_on(sv);
+ SvIV_set(sv, 0);
+ av_store(av, (I32)CopLINE(PL_curcop), sv);
+ }
+}
+
/*
* S_skipspace
* Called to gobble the appropriate amount and type of whitespace.
#ifdef PERL_MAD
if (PL_madskills && curoff != startoff) {
if (!PL_skipwhite)
- PL_skipwhite = newSVpvn("",0);
+ PL_skipwhite = newSVpvs("");
sv_catpvn(PL_skipwhite, SvPVX(PL_linestr) + startoff,
curoff - startoff);
}
/* XXX these shouldn't really be added here, can't set PL_faketokens */
if (PL_minus_p) {
#ifdef PERL_MAD
- sv_catpv(PL_linestr,
+ sv_catpvs(PL_linestr,
";}continue{print or die qq(-p destination: $!\\n);}");
#else
- sv_setpv(PL_linestr,
+ sv_setpvs(PL_linestr,
";}continue{print or die qq(-p destination: $!\\n);}");
#endif
PL_minus_n = PL_minus_p = 0;
/* debugger active and we're not compiling the debugger code,
* so store the line into the debugger's array of lines
*/
- if (PERLDB_LINE && PL_curstash != PL_debstash) {
- SV * const sv = newSV(0);
-
- sv_upgrade(sv, SVt_PVMG);
- sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
- (void)SvIOK_on(sv);
- SvIV_set(sv, 0);
- av_store(CopFILEAVx(PL_curcop),(I32)CopLINE(PL_curcop),sv);
- }
+ if (PERLDB_LINE && PL_curstash != PL_debstash)
+ update_debugger_info(NULL, PL_bufptr, PL_bufend - PL_bufptr);
}
#ifdef PERL_MAD
done:
if (PL_madskills) {
if (!PL_skipwhite)
- PL_skipwhite = newSVpvn("",0);
+ PL_skipwhite = newSVpvs("");
curoff = s - SvPVX(PL_linestr);
if (curoff - startoff)
sv_catpvn(PL_skipwhite, SvPVX(PL_linestr) + startoff,
PL_curforce = where;
if (PL_nextwhite) {
if (PL_madskills)
- curmad('^', newSVpvn("",0));
+ curmad('^', newSVpvs(""));
CURMAD('_', PL_nextwhite);
}
}
/* keep a slot open for the head of the list? */
if (slot != '_' && *where && (*where)->mad_key == '^') {
(*where)->mad_key = slot;
- sv_free((*where)->mad_val);
+ sv_free((SV*)((*where)->mad_val));
(*where)->mad_val = (void*)sv;
}
else
* S_force_word
* When the lexer knows the next thing is a word (for instance, it has
* just seen -> and it knows that the next char is a word char, then
- * it calls S_force_word to stick the next word into the PL_next lookahead.
+ * it calls S_force_word to stick the next word into the PL_nexttoke/val
+ * lookahead.
*
* Arguments:
* char *start : buffer position (must be within PL_linestr)
- * int token : PL_next will be this type of bare word (e.g., METHOD,WORD)
+ * int token : PL_next* will be this type of bare word (e.g., METHOD,WORD)
* int check_keyword : if true, Perl checks to make sure the word isn't
* a keyword (do this if the word is a label, e.g. goto FOO)
* int allow_pack : if true, : characters will also be allowed (require,
(allow_initial_tick && *s == '\'') )
{
s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
- if (check_keyword && keyword(PL_tokenbuf, len))
+ if (check_keyword && keyword(PL_tokenbuf, len, 0))
return start;
start_force(PL_curforce);
if (PL_madskills)
PL_expect = XOPERATOR;
}
}
+ if (PL_madskills)
+ curmad('g', newSVpvs( "forced" ));
NEXTVAL_NEXTTOKE.opval
= (OP*)newSVOP(OP_CONST,0,
S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
PL_expect = XTERMORDORDOR;
return THING;
}
+ else if (op_type == OP_BACKTICK && PL_lex_op) {
+ /* readpipe() vas overriden */
+ cSVOPx(cLISTOPx(cUNOPx(PL_lex_op)->op_first)->op_first->op_sibling)->op_sv = tokeq(PL_lex_stuff);
+ yylval.opval = PL_lex_op;
+ PL_lex_op = NULL;
+ PL_lex_stuff = NULL;
+ return THING;
+ }
PL_sublex_info.super_state = PL_lex_state;
- PL_sublex_info.sub_inwhat = op_type;
+ PL_sublex_info.sub_inwhat = (U16)op_type;
PL_sublex_info.sub_op = PL_lex_op;
PL_lex_state = LEX_INTERPPUSH;
ENTER;
PL_lex_state = PL_sublex_info.super_state;
- SAVEI32(PL_lex_dojoin);
+ SAVEBOOL(PL_lex_dojoin);
SAVEI32(PL_lex_brackets);
SAVEI32(PL_lex_casemods);
SAVEI32(PL_lex_starts);
- SAVEI32(PL_lex_state);
+ SAVEI8(PL_lex_state);
SAVEVPTR(PL_lex_inpat);
- SAVEI32(PL_lex_inwhat);
+ SAVEI16(PL_lex_inwhat);
SAVECOPLINE(PL_curcop);
SAVEPPTR(PL_bufptr);
SAVEPPTR(PL_bufend);
if (PL_madskills) {
if (PL_thiswhite) {
if (!PL_endwhite)
- PL_endwhite = newSVpvn("",0);
+ PL_endwhite = newSVpvs("");
sv_catsv(PL_endwhite, PL_thiswhite);
PL_thiswhite = 0;
}
Extracts a pattern, double-quoted string, or transliteration. This
is terrifying code.
- It looks at lex_inwhat and PL_lex_inpat to find out whether it's
+ It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
processing a pattern (PL_lex_inpat is true), a transliteration
- (lex_inwhat & OP_TRANS is true), or a double-quoted string.
+ (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
- Returns a pointer to the character scanned up to. Iff this is
- advanced from the start pointer supplied (ie if anything was
+ Returns a pointer to the character scanned up to. If this is
+ advanced from the start pointer supplied (i.e. if anything was
successfully parsed), will leave an OP for the substring scanned
in yylval. Caller must intuit reason for not parsing further
by looking at the next characters herself.
backslashes:
double-quoted style: \r and \n
regexp special ones: \D \s
- constants: \x3
- backrefs: \1 (deprecated in substitution replacements)
+ constants: \x31
+ backrefs: \1
case and quoting: \U \Q \E
stops on @ and $, but not for $ as tail anchor
In transliterations:
characters are VERY literal, except for - not at the start or end
- of the string, which indicates a range. scan_const expands the
- range to the full set of intermediate characters.
+ of the string, which indicates a range. If the range is in bytes,
+ scan_const expands the range to the full set of intermediate
+ characters. If the range is in utf8, the hyphen is replaced with
+ a certain range mark which will be handled by pmtrans() in op.c.
In double-quoted strings:
backslashes:
double-quoted style: \r and \n
- constants: \x3
- backrefs: \1 (deprecated)
+ constants: \x31
+ deprecated backrefs: \1 (in substitution replacements)
case and quoting: \U \Q \E
stops on @ and $
It stops processing as soon as it finds an embedded $ or @ variable
and leaves it to the caller to work out what's going on.
- @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @::foo.
+ embedded arrays (whether in pattern or not) could be:
+ @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
+
+ $ in double-quoted strings must be the symbol of an embedded scalar.
$ in pattern could be $foo or could be tail anchor. Assumption:
it's a tail anchor if $ is the last thing in the string, or if it's
- followed by one of ")| \n\t"
+ followed by one of "()| \r\n\t"
\1 (backreferences) are turned into $1
The structure of the code is
while (there's a character to process) {
- handle transliteration ranges
- skip regexp comments
- skip # initiated comments in //x patterns
- check for embedded @foo
+ handle transliteration ranges
+ skip regexp comments /(?#comment)/ and codes /(?{code})/
+ skip #-initiated comments in //x patterns
+ check for embedded arrays
check for embedded scalars
if (backslash) {
- leave intact backslashes from leave (below)
- deprecate \1 in strings and sub replacements
+ leave intact backslashes from leaveit (below)
+ deprecate \1 in substitution replacements
handle string-changing backslashes \l \U \Q \E, etc.
switch (what was escaped) {
- handle - in a transliteration (becomes a literal -)
- handle \132 octal characters
- handle 0x15 hex characters
- handle \cV (control V)
- handle printf backslashes (\f, \r, \n, etc)
+ handle \- in a transliteration (becomes a literal -)
+ handle \132 (octal characters)
+ handle \x15 and \x{1234} (hex characters)
+ handle \N{name} (named characters)
+ handle \cV (control characters)
+ handle printf-style backslashes (\f, \r, \n, etc)
} (end switch)
} (end if backslash)
} (end while character to read)
UV uv;
#ifdef EBCDIC
UV literal_endpoint = 0;
+ bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */
#endif
- const char * const leaveit = /* set of acceptably-backslashed characters */
- PL_lex_inpat
- ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
- : "";
-
if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
/* If we are doing a trans and we know we want UTF8 set expectation */
has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
I32 min; /* first character in range */
I32 max; /* last character in range */
- if (has_utf8) {
+#ifdef EBCDIC
+ UV uvmax = 0;
+#endif
+
+ if (has_utf8
+#ifdef EBCDIC
+ && !native_range
+#endif
+ ) {
char * const c = (char*)utf8_hop((U8*)d, -1);
char *e = d++;
while (e-- > c)
}
i = d - SvPVX_const(sv); /* remember current offset */
+#ifdef EBCDIC
+ SvGROW(sv,
+ SvLEN(sv) + (has_utf8 ?
+ (512 - UTF_CONTINUATION_MARK +
+ UNISKIP(0x100))
+ : 256));
+ /* How many two-byte within 0..255: 128 in UTF-8,
+ * 96 in UTF-8-mod. */
+#else
SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
+#endif
d = SvPVX(sv) + i; /* refresh d after realloc */
- d -= 2; /* eat the first char and the - */
-
- min = (U8)*d; /* first char in range */
- max = (U8)d[1]; /* last char in range */
+#ifdef EBCDIC
+ if (has_utf8) {
+ int j;
+ for (j = 0; j <= 1; j++) {
+ char * const c = (char*)utf8_hop((U8*)d, -1);
+ const UV uv = utf8n_to_uvchr((U8*)c, d - c, NULL, 0);
+ if (j)
+ min = (U8)uv;
+ else if (uv < 256)
+ max = (U8)uv;
+ else {
+ max = (U8)0xff; /* only to \xff */
+ uvmax = uv; /* \x{100} to uvmax */
+ }
+ d = c; /* eat endpoint chars */
+ }
+ }
+ else {
+#endif
+ d -= 2; /* eat the first char and the - */
+ min = (U8)*d; /* first char in range */
+ max = (U8)d[1]; /* last char in range */
+#ifdef EBCDIC
+ }
+#endif
if (min > max) {
Perl_croak(aTHX_
else
#endif
for (i = min; i <= max; i++)
- *d++ = (char)i;
+#ifdef EBCDIC
+ if (has_utf8) {
+ const U8 ch = (U8)NATIVE_TO_UTF(i);
+ if (UNI_IS_INVARIANT(ch))
+ *d++ = (U8)i;
+ else {
+ *d++ = (U8)UTF8_EIGHT_BIT_HI(ch);
+ *d++ = (U8)UTF8_EIGHT_BIT_LO(ch);
+ }
+ }
+ else
+#endif
+ *d++ = (char)i;
+
+#ifdef EBCDIC
+ if (uvmax) {
+ d = (char*)uvchr_to_utf8((U8*)d, 0x100);
+ if (uvmax > 0x101)
+ *d++ = (char)UTF_TO_NATIVE(0xff);
+ if (uvmax > 0x100)
+ d = (char*)uvchr_to_utf8((U8*)d, uvmax);
+ }
+#endif
/* mark the range as done, and continue */
dorange = FALSE;
if (didrange) {
Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
}
- if (has_utf8) {
+ if (has_utf8
+#ifdef EBCDIC
+ && !native_range
+#endif
+ ) {
*d++ = (char)UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */
s++;
continue;
didrange = FALSE;
#ifdef EBCDIC
literal_endpoint = 0;
+ native_range = TRUE;
#endif
}
}
*d++ = NATIVE_TO_NEED(has_utf8,*s++);
}
else if (s[2] == '{' /* This should match regcomp.c */
- || ((s[2] == 'p' || s[2] == '?') && s[3] == '{'))
+ || (s[2] == '?' && s[3] == '{'))
{
I32 count = 1;
char *regparse = s + (s[2] == '{' ? 3 : 4);
/* check for embedded arrays
(@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
*/
- else if (*s == '@' && s[1]
- && (isALNUM_lazy_if(s+1,UTF) || strchr(":'{$+-", s[1])))
- break;
+ else if (*s == '@' && s[1]) {
+ if (isALNUM_lazy_if(s+1,UTF))
+ break;
+ if (strchr(":'{$", s[1]))
+ break;
+ if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
+ break; /* in regexp, neither @+ nor @- are interpolated */
+ }
/* check for embedded scalars. only stop if we're sure it's a
variable.
if (*s == '\\' && s+1 < send) {
s++;
- /* some backslashes we leave behind */
- if (*leaveit && *s && strchr(leaveit, *s)) {
- *d++ = NATIVE_TO_NEED(has_utf8,'\\');
- *d++ = NATIVE_TO_NEED(has_utf8,*s++);
- continue;
- }
-
/* deprecate \1 in strings and substitution replacements */
if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
--s;
break;
}
+ /* skip any other backslash escapes in a pattern */
+ else if (PL_lex_inpat) {
+ *d++ = NATIVE_TO_NEED(has_utf8,'\\');
+ goto default_action;
+ }
/* if we get here, it's either a quoted -, or a digit */
switch (*s) {
if ((isALPHA(*s) || isDIGIT(*s)) &&
ckWARN(WARN_MISC))
Perl_warner(aTHX_ packWARN(WARN_MISC),
- "Unrecognized escape \\%c passed through",
- *s);
+ "Unrecognized escape \\%c passed through",
+ *s);
/* default action is to copy the quoted character */
goto default_action;
}
(PL_lex_repl ? OPpTRANS_FROM_UTF
: OPpTRANS_TO_UTF);
}
+#ifdef EBCDIC
+ if (uv > 255 && !dorange)
+ native_range = FALSE;
+#endif
}
else {
*d++ = (char)uv;
SV *res;
STRLEN len;
const char *str;
+ SV *type;
if (!e) {
yyerror("Missing right brace on \\N{}");
s += 3;
len = e - s;
uv = grok_hex(s, &len, &flags, NULL);
+ if ( e > s && len != (STRLEN)(e - s) ) {
+ uv = 0xFFFD;
+ }
s = e + 1;
goto NUM_ESCAPE_INSERT;
}
res = newSVpvn(s + 1, e - s - 1);
+ type = newSVpvn(s - 2,e - s + 3);
res = new_constant( NULL, 0, "charnames",
- res, NULL, "\\N{...}" );
+ res, NULL, SvPVX(type) );
+ SvREFCNT_dec(type);
if (has_utf8)
sv_utf8_upgrade(res);
str = SvPV_const(res,len);
SvGROW(sv, (SvLEN(sv) + len - (e - s + 4)));
d = SvPVX(sv) + (d - odest);
}
+#ifdef EBCDIC
+ if (!dorange)
+ native_range = FALSE; /* \N{} is guessed to be Unicode */
+#endif
Copy(str, d, len, char);
d += len;
SvREFCNT_dec(res);
}
d = (char*)uvchr_to_utf8((U8*)d, nextuv);
has_utf8 = TRUE;
+#ifdef EBCDIC
+ if (uv > 255 && !dorange)
+ native_range = FALSE;
+#endif
}
else {
*d++ = NATIVE_TO_NEED(has_utf8,*s++);
/* return the substring (via yylval) only if we parsed anything */
if (s > PL_bufptr) {
if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
- sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
+ sv = new_constant(start, s - start,
+ (const char *)(PL_lex_inpat ? "qr" : "q"),
sv, NULL,
- ( PL_lex_inwhat == OP_TRANS
- ? "tr"
- : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
- ? "s"
- : "qq")));
+ (const char *)
+ (( PL_lex_inwhat == OP_TRANS
+ ? "tr"
+ : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
+ ? "s"
+ : "qq"))));
yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
} else
SvREFCNT_dec(sv);
if (s[1]) {
if (strchr("wds]",s[1]))
weight += 100;
- else if (seen['\''] || seen['"'])
+ else if (seen[(U8)'\''] || seen[(U8)'"'])
weight += 1;
else if (strchr("rnftbxcav",s[1]))
weight += 40;
while (isALPHA(*s))
*d++ = *s++;
*d = '\0';
- if (keyword(tmpbuf, d - tmpbuf))
+ if (keyword(tmpbuf, d - tmpbuf, 0))
weight -= 150;
}
if (un_char == last_un_char + 1)
*/
if (*start == '$') {
- if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
+ if (gv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY ||
+ isUPPER(*PL_tokenbuf))
return 0;
#ifdef PERL_MAD
len = start - SvPVX(PL_linestr);
#endif
s = PEEKSPACE(s);
-#ifdef PERLMAD
+#ifdef PERL_MAD
start = SvPVX(PL_linestr) + len;
#endif
PL_bufptr = start;
PL_expect = XREF;
return *s == '(' ? FUNCMETH : METHOD;
}
- if (!keyword(tmpbuf, len)) {
+ if (!keyword(tmpbuf, len, 0)) {
if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
len -= 2;
tmpbuf[len] = '\0';
if (indirgv && GvCVu(indirgv))
return 0;
/* filehandle or package name makes it a method */
- if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
+ if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, 0)) {
#ifdef PERL_MAD
soff = s - SvPVX(PL_linestr);
#endif
if (!funcp)
return NULL;
+ if (!PL_parser)
+ return NULL;
+
if (!PL_rsfp_filters)
PL_rsfp_filters = newAV();
if (!datasv)
DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
FPTR2DPTR(void*, funcp)));
#endif
- if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
+ if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
return;
/* if filter is on top of stack (usual case) just pop it off */
datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
#endif
: maxlen;
- if (!PL_rsfp_filters)
+ if (!PL_parser || !PL_rsfp_filters)
return -1;
if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
/* Provide a default input filter to make life easy. */
pkgname = SvPV_nolen_const(sv);
}
- return gv_stashpv(pkgname, FALSE);
+ return gv_stashpv(pkgname, 0);
+}
+
+/*
+ * S_readpipe_override
+ * Check whether readpipe() is overriden, and generates the appropriate
+ * optree, provided sublex_start() is called afterwards.
+ */
+STATIC void
+S_readpipe_override(pTHX)
+{
+ GV **gvp;
+ GV *gv_readpipe = gv_fetchpvs("readpipe", GV_NOTQUAL, SVt_PVCV);
+ yylval.ival = OP_BACKTICK;
+ if ((gv_readpipe
+ && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe))
+ ||
+ ((gvp = (GV**)hv_fetchs(PL_globalstash, "readpipe", FALSE))
+ && (gv_readpipe = *gvp) && isGV_with_GP(gv_readpipe)
+ && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe)))
+ {
+ PL_lex_op = (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
+ append_elem(OP_LIST,
+ newSVOP(OP_CONST, 0, &PL_sv_undef), /* value will be read later */
+ newCVREF(0, newGVOP(OP_GV, 0, gv_readpipe))));
+ }
+ else {
+ set_csh();
+ }
}
#ifdef PERL_MAD
if (!PL_thismad || PL_thismad->mad_key == '^') { /* not forced already? */
if (!PL_thistoken) {
if (PL_realtokenstart < 0 || !CopLINE(PL_curcop))
- PL_thistoken = newSVpvn("",0);
+ PL_thistoken = newSVpvs("");
else {
char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
PL_thistoken = newSVpvn(tstart, s - tstart);
STRLEN len;
bool bof = FALSE;
+ /* orig_keyword, gvp, and gv are initialized here because
+ * jump to the label just_a_word_zero can bypass their
+ * initialization later. */
+ I32 orig_keyword = 0;
+ GV *gv = NULL;
+ GV **gvp = NULL;
+
DEBUG_T( {
SV* tmp = newSVpvs("");
PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
PL_lex_state = LEX_INTERPCONCAT;
#ifdef PERL_MAD
if (PL_madskills)
- PL_thistoken = newSVpvn("\\E",2);
+ PL_thistoken = newSVpvs("\\E");
#endif
}
return REPORT(')');
while (PL_bufptr != PL_bufend &&
PL_bufptr[0] == '\\' && PL_bufptr[1] == 'E') {
if (!PL_thiswhite)
- PL_thiswhite = newSVpvn("",0);
+ PL_thiswhite = newSVpvs("");
sv_catpvn(PL_thiswhite, PL_bufptr, 2);
PL_bufptr += 2;
}
if (s[1] == '\\' && s[2] == 'E') {
#ifdef PERL_MAD
if (!PL_thiswhite)
- PL_thiswhite = newSVpvn("",0);
+ PL_thiswhite = newSVpvs("");
sv_catpvn(PL_thiswhite, PL_bufptr, 4);
#endif
PL_bufptr = s + 3;
else
Perl_croak(aTHX_ "panic: yylex");
if (PL_madskills) {
- SV* const tmpsv = newSVpvn("",0);
+ SV* const tmpsv = newSVpvs("");
Perl_sv_catpvf(aTHX_ tmpsv, "\\%c", *s);
curmad('_', tmpsv);
}
if (PL_madskills) {
if (PL_thistoken)
sv_free(PL_thistoken);
- PL_thistoken = newSVpvn("",0);
+ PL_thistoken = newSVpvs("");
}
#endif
/* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
if (PL_madskills) {
if (PL_thistoken)
sv_free(PL_thistoken);
- PL_thistoken = newSVpvn("",0);
+ PL_thistoken = newSVpvs("");
}
#endif
/* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
if (PL_madskills) {
if (PL_thistoken)
sv_free(PL_thistoken);
- PL_thistoken = newSVpvn("",0);
+ PL_thistoken = newSVpvs("");
}
#endif
return REPORT(')');
if (PL_madskills) {
if (PL_thistoken)
sv_free(PL_thistoken);
- PL_thistoken = newSVpvn("",0);
+ PL_thistoken = newSVpvs("");
}
#endif
/* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
PL_last_uni = 0;
PL_last_lop = 0;
if (PL_lex_brackets) {
- yyerror(PL_lex_formbrack
- ? "Format not terminated"
- : "Missing right curly or square bracket");
+ yyerror((const char *)
+ (PL_lex_formbrack
+ ? "Format not terminated"
+ : "Missing right curly or square bracket"));
}
DEBUG_T( { PerlIO_printf(Perl_debug_log,
"### Tokener got EOF\n");
PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
PL_last_lop = PL_last_uni = NULL;
- if (PERLDB_LINE && PL_curstash != PL_debstash) {
- SV * const sv = newSV(0);
-
- sv_upgrade(sv, SVt_PVMG);
- sv_setsv(sv,PL_linestr);
- (void)SvIOK_on(sv);
- SvIV_set(sv, 0);
- av_store(CopFILEAVx(PL_curcop),(I32)CopLINE(PL_curcop),sv);
- }
+ if (PERLDB_LINE && PL_curstash != PL_debstash)
+ update_debugger_info(PL_linestr, NULL, 0);
goto retry;
}
do {
if (PL_madskills)
PL_faketokens = 1;
#endif
- sv_setpv(PL_linestr,PL_minus_p
- ? ";}continue{print;}" : ";}");
+ sv_setpv(PL_linestr,
+ (const char *)
+ (PL_minus_p
+ ? ";}continue{print;}" : ";}"));
PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
PL_last_lop = PL_last_uni = NULL;
if (PL_madskills)
sv_catsv(PL_thiswhite, PL_linestr);
#endif
- if (*s == '=' && strnEQ(s, "=cut", 4)) {
+ if (*s == '=' && strnEQ(s, "=cut", 4) && !isALPHA(s[4])) {
sv_setpvn(PL_linestr, "", 0);
PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
incline(s);
} while (PL_doextract);
PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
- if (PERLDB_LINE && PL_curstash != PL_debstash) {
- SV * const sv = newSV(0);
-
- sv_upgrade(sv, SVt_PVMG);
- sv_setsv(sv,PL_linestr);
- (void)SvIOK_on(sv);
- SvIV_set(sv, 0);
- av_store(CopFILEAVx(PL_curcop),(I32)CopLINE(PL_curcop),sv);
- }
+ if (PERLDB_LINE && PL_curstash != PL_debstash)
+ update_debugger_info(PL_linestr, NULL, 0);
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
PL_last_lop = PL_last_uni = NULL;
if (CopLINE(PL_curcop) == 1) {
#endif
#ifdef PERL_MAD
PL_realtokenstart = -1;
- s = SKIPSPACE0(s);
-#else
- s++;
+ if (!PL_thiswhite)
+ PL_thiswhite = newSVpvs("");
+ sv_catpvn(PL_thiswhite, s, 1);
#endif
+ s++;
goto retry;
case '#':
case '\n':
Perl_croak(aTHX_ "panic: input overflow");
if (PL_madskills && CopLINE(PL_curcop) >= 1) {
if (!PL_thiswhite)
- PL_thiswhite = newSVpvn("",0);
+ PL_thiswhite = newSVpvs("");
if (CopLINE(PL_curcop) == 1) {
sv_setpvn(PL_thiswhite, "", 0);
PL_faketokens = 0;
Mop(OP_MODULO);
}
PL_tokenbuf[0] = '%';
- s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
+ s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
+ sizeof PL_tokenbuf - 1, FALSE);
if (!PL_tokenbuf[1]) {
PREREF('%');
}
/* FALL THROUGH */
case '~':
if (s[1] == '~'
- && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR)
- && FEATURE_IS_ENABLED("~~"))
+ && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR))
{
s += 2;
Eop(OP_SMARTMATCH);
I32 tmp;
SV *sv;
d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
- if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
+ if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) {
if (tmp < 0) tmp = -tmp;
switch (tmp) {
case KEY_or:
sv_free(sv);
CvMETHOD_on(PL_compcv);
}
- else if (!PL_in_my && len == 9 && strnEQ(SvPVX(sv), "assertion", len)) {
- sv_free(sv);
- CvASSERTION_on(PL_compcv);
- }
/* After we've set the flags, it could be argued that
we don't need to do the attributes.pm-based setting
process, and shouldn't bother appending recognized
context messages from yyerror().
*/
PL_bufptr = s;
- yyerror( *s
- ? Perl_form(aTHX_ "Invalid separator character "
- "%c%c%c in attribute list", q, *s, q)
- : "Unterminated attribute list" );
+ yyerror( (const char *)
+ (*s
+ ? Perl_form(aTHX_ "Invalid separator character "
+ "%c%c%c in attribute list", q, *s, q)
+ : "Unterminated attribute list" ) );
if (attrs)
op_free(attrs);
OPERATOR(':');
--PL_lex_brackets;
if (PL_lex_state == LEX_INTERPNORMAL) {
if (PL_lex_brackets == 0) {
- if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
+ if (*s == '-' && s[1] == '>')
+ PL_lex_state = LEX_INTERPENDMAYBE;
+ else if (*s != '[' && *s != '{')
PL_lex_state = LEX_INTERPEND;
}
}
#if 0
if (PL_madskills) {
if (!PL_thiswhite)
- PL_thiswhite = newSVpvn("",0);
+ PL_thiswhite = newSVpvs("");
sv_catpvn(PL_thiswhite,"}",1);
}
#endif
force_next('}');
#ifdef PERL_MAD
if (!PL_thistoken)
- PL_thistoken = newSVpvn("",0);
+ PL_thistoken = newSVpvs("");
#endif
TOKEN(';');
case '&':
#ifdef PERL_MAD
if (PL_madskills) {
if (!PL_thiswhite)
- PL_thiswhite = newSVpvn("",0);
+ PL_thiswhite = newSVpvs("");
sv_catpvn(PL_thiswhite, PL_linestart,
PL_bufend - PL_linestart);
}
t++;
} while (isSPACE(*t));
if (isIDFIRST_lazy_if(t,UTF)) {
- STRLEN dummylen;
+ STRLEN len;
t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
- &dummylen);
+ &len);
while (isSPACE(*t))
t++;
- if (*t == ';' && get_cv(tmpbuf, FALSE))
+ if (*t == ';' && get_cvn_flags(tmpbuf, len, 0))
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"You need to quote \"%s\"",
tmpbuf);
char tmpbuf[sizeof PL_tokenbuf];
int t2;
scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
- if ((t2 = keyword(tmpbuf, len))) {
+ if ((t2 = keyword(tmpbuf, len, 0))) {
/* binary operators exclude handle interpretations */
switch (t2) {
case -KEY_x:
no_op("Backticks",s);
if (!s)
missingterm(NULL);
- yylval.ival = OP_BACKTICK;
- set_csh();
+ readpipe_override();
TERM(sublex_start());
case '\\':
keylookup: {
I32 tmp;
- I32 orig_keyword = 0;
- GV *gv = NULL;
- GV **gvp = NULL;
+
+ orig_keyword = 0;
+ gv = NULL;
+ gvp = NULL;
PL_bufptr = s;
s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
if (!tmp && PL_expect == XSTATE
&& d < PL_bufend && *d == ':' && *(d + 1) != ':') {
s = d + 1;
- yylval.pval = savepv(PL_tokenbuf);
+ yylval.pval = CopLABEL_alloc(PL_tokenbuf);
CLINE;
TOKEN(LABEL);
}
/* Check for keywords */
- tmp = keyword(PL_tokenbuf, len);
+ tmp = keyword(PL_tokenbuf, len, 0);
/* Is this a word before a => operator? */
if (*d == '=' && d[1] == '>') {
}
if (!ogv &&
(gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
- (gv = *gvp) != (GV*)&PL_sv_undef &&
+ (gv = *gvp) && isGV_with_GP(gv) &&
GvCVu(gv) && GvIMPORTED_CV(gv))
{
ogv = gv;
}
else if (gv && !gvp
&& -tmp==KEY_lock /* XXX generalizable kludge */
- && GvCVu(gv)
- && !hv_fetchs(GvHVn(PL_incgv), "Thread.pm", FALSE))
+ && GvCVu(gv))
{
tmp = 0; /* any sub overrides "weak" keyword */
}
PL_nextwhite = 0;
}
}
+ else
#endif
- goto its_constant;
+ goto its_constant;
}
}
#ifdef PERL_MAD
if (PL_madskills) {
PL_nextwhite = nextPL_nextwhite;
curmad('X', PL_thistoken);
- PL_thistoken = newSVpvn("",0);
+ PL_thistoken = newSVpvs("");
}
#endif
force_next(WORD);
"Ambiguous use of -%s resolved as -&%s()",
PL_tokenbuf, PL_tokenbuf);
/* Check for a constant sub */
- if ((sv = gv_const_sv(gv))) {
+ if ((sv = gv_const_sv(gv)) && !PL_madskills) {
its_constant:
SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
#ifdef PERL_MAD
cv &&
#endif
- SvPOK(cv)) {
+ SvPOK(cv))
+ {
STRLEN protolen;
const char *proto = SvPV_const((SV*)cv, protolen);
if (!protolen)
TERM(FUNC0SUB);
- if (*proto == '$' && proto[1] == '\0')
+ if ((*proto == '$' || *proto == '_') && proto[1] == '\0')
OPERATOR(UNIOPSUB);
while (*proto == ';')
proto++;
if (*proto == '&' && *s == '{') {
- sv_setpv(PL_subname, PL_curstash ?
- "__ANON__" : "__ANON__::__ANON__");
+ sv_setpv(PL_subname,
+ (const char *)
+ (PL_curstash ?
+ "__ANON__" : "__ANON__::__ANON__"));
PREBLOCK(LSTOPSUB);
}
}
if (PL_madskills) {
PL_nextwhite = nextPL_nextwhite;
curmad('X', PL_thistoken);
- PL_thistoken = newSVpvn("",0);
+ PL_thistoken = newSVpvs("");
}
force_next(WORD);
TOKEN(NOAMP);
STRLEN tmplen;
d = s;
d = scan_word(d, tmpbuf, sizeof tmpbuf, TRUE, &tmplen);
- if (!keyword(tmpbuf,tmplen))
+ if (!keyword(tmpbuf, tmplen, 0))
probable_sub = 1;
else {
while (d < PL_bufend && isSPACE(*d))
}
}
if (probable_sub) {
- gv = gv_fetchpv(PL_tokenbuf, TRUE, SVt_PVCV);
+ gv = gv_fetchpv(PL_tokenbuf, GV_ADD, SVt_PVCV);
op_free(yylval.opval);
yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
PL_expect = XTERM;
PL_nextwhite = nextPL_nextwhite;
curmad('X', PL_thistoken);
- PL_thistoken = newSVpvn("",0);
+ PL_thistoken = newSVpvs("");
force_next(WORD);
TOKEN(NOAMP);
}
d = PL_tokenbuf;
while (isLOWER(*d))
d++;
- if (!*d && !gv_stashpv(PL_tokenbuf,FALSE))
+ if (!*d && !gv_stashpv(PL_tokenbuf, 0))
Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
PL_tokenbuf);
}
PUTBACK;
PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
Perl_form(aTHX_ ":encoding(%"SVf")",
- (void*)name));
+ SVfARG(name)));
FREETMPS;
LEAVE;
}
if (PL_realtokenstart >= 0) {
char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
if (!PL_endwhite)
- PL_endwhite = newSVpvn("",0);
+ PL_endwhite = newSVpvs("");
sv_catsv(PL_endwhite, PL_thiswhite);
PL_thiswhite = 0;
sv_catpvn(PL_endwhite, tstart, PL_bufend - tstart);
case KEY_AUTOLOAD:
case KEY_DESTROY:
case KEY_BEGIN:
+ case KEY_UNITCHECK:
case KEY_CHECK:
case KEY_INIT:
case KEY_END:
s += 2;
d = s;
s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
- if (!(tmp = keyword(PL_tokenbuf, len)))
+ if (!(tmp = keyword(PL_tokenbuf, len, 0)))
Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
if (tmp < 0)
tmp = -tmp;
case KEY_our:
case KEY_my:
case KEY_state:
- PL_in_my = tmp;
+ PL_in_my = (U16)tmp;
s = SKIPSPACE1(s);
if (isIDFIRST_lazy_if(s,UTF)) {
#ifdef PERL_MAD
s = scan_str(s,!!PL_madskills,FALSE);
if (!s)
missingterm(NULL);
- yylval.ival = OP_BACKTICK;
- set_csh();
+ readpipe_override();
TERM(sublex_start());
case KEY_return:
*PL_tokenbuf = '\0';
s = force_word(s,WORD,TRUE,TRUE,FALSE);
if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
- gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
+ gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), GV_ADD);
else if (*s == '<')
yyerror("<> should be quotes");
}
case KEY_readpipe:
set_csh();
- UNI(OP_BACKTICK);
+ UNIDOR(OP_BACKTICK);
case KEY_rewinddir:
UNI(OP_REWINDDIR);
char tmpbuf[sizeof PL_tokenbuf];
SSize_t tboffset = 0;
expectation attrful;
- bool have_name, have_proto, bad_proto;
+ bool have_name, have_proto;
const int key = tmp;
#ifdef PERL_MAD
if (PL_madskills)
nametoke = newSVpvn(s, d - s);
#endif
- if (strchr(tmpbuf, ':'))
- sv_setpv(PL_subname, tmpbuf);
+ if (memchr(tmpbuf, ':', len))
+ sv_setpvn(PL_subname, tmpbuf, len);
else {
sv_setsv(PL_subname,PL_curstname);
sv_catpvs(PL_subname,"::");
/* Look for a prototype */
if (*s == '(') {
char *p;
+ bool bad_proto = FALSE;
+ const bool warnsyntax = ckWARN(WARN_SYNTAX);
s = scan_str(s,!!PL_madskills,FALSE);
if (!s)
/* strip spaces and check for bad characters */
d = SvPVX(PL_lex_stuff);
tmp = 0;
- bad_proto = FALSE;
for (p = d; *p; ++p) {
if (!isSPACE(*p)) {
d[tmp++] = *p;
- if (!strchr("$@%*;[]&\\", *p))
+ if (warnsyntax && !strchr("$@%*;[]&\\_", *p))
bad_proto = TRUE;
}
}
d[tmp] = '\0';
- if (bad_proto && ckWARN(WARN_SYNTAX))
+ if (bad_proto)
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"Illegal character in prototype for %"SVf" : %s",
- (void*)PL_subname, d);
+ SVfARG(PL_subname), d);
SvCUR_set(PL_lex_stuff, tmp);
have_proto = TRUE;
if (!have_name)
Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
else if (*s != ';')
- Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, (void*)PL_subname);
+ Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, SVfARG(PL_subname));
}
#ifdef PERL_MAD
start_force(0);
if (tmpwhite) {
if (PL_madskills)
- curmad('^', newSVpvn("",0));
+ curmad('^', newSVpvs(""));
CURMAD('_', tmpwhite);
}
force_next(0);
#endif
if (!have_name) {
sv_setpv(PL_subname,
- PL_curstash ? "__ANON__" : "__ANON__::__ANON__");
+ (const char *)
+ (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"));
TOKEN(ANONSUB);
}
#ifndef PERL_MAD
if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
GV *gv = gv_fetchpv(PL_tokenbuf+1, 0, SVt_PVAV);
if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
- && ckWARN(WARN_AMBIGUOUS))
+ && ckWARN(WARN_AMBIGUOUS)
+ /* DO NOT warn for @- and @+ */
+ && !( PL_tokenbuf[2] == '\0' &&
+ ( PL_tokenbuf[1] == '-' || PL_tokenbuf[1] == '+' ))
+ )
{
/* Downgraded from fatal to warning 20000522 mjd */
Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
*/
I32
-Perl_keyword (pTHX_ const char *name, I32 len)
+Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords)
{
dVAR;
switch (len)
case 'r':
if (name[2] == 'r')
{ /* err */
- return (FEATURE_IS_ENABLED("err") ? -KEY_err : 0);
+ return (all_keywords || FEATURE_IS_ENABLED("err") ? -KEY_err : 0);
}
goto unknown;
case 'a':
if (name[2] == 'y')
{ /* say */
- return (FEATURE_IS_ENABLED("say") ? -KEY_say : 0);
+ return (all_keywords || FEATURE_IS_ENABLED("say") ? KEY_say : 0);
}
goto unknown;
if (name[2] == 'e' &&
name[3] == 'n')
{ /* when */
- return (FEATURE_IS_ENABLED("switch") ? KEY_when : 0);
+ return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_when : 0);
}
goto unknown;
name[3] == 'a' &&
name[4] == 'k')
{ /* break */
- return (FEATURE_IS_ENABLED("switch") ? -KEY_break : 0);
+ return (all_keywords || FEATURE_IS_ENABLED("switch") ? -KEY_break : 0);
}
goto unknown;
name[3] == 'e' &&
name[4] == 'n')
{ /* given */
- return (FEATURE_IS_ENABLED("switch") ? KEY_given : 0);
+ return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_given : 0);
}
goto unknown;
if (name[3] == 't' &&
name[4] == 'e')
{ /* state */
- return (FEATURE_IS_ENABLED("state") ? KEY_state : 0);
+ return (all_keywords || FEATURE_IS_ENABLED("state") ? KEY_state : 0);
}
goto unknown;
name[5] == 'l' &&
name[6] == 't')
{ /* default */
- return (FEATURE_IS_ENABLED("switch") ? KEY_default : 0);
+ return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_default : 0);
}
goto unknown;
goto unknown;
}
- case 9: /* 8 tokens of length 9 */
+ case 9: /* 9 tokens of length 9 */
switch (name[0])
{
+ case 'U':
+ if (name[1] == 'N' &&
+ name[2] == 'I' &&
+ name[3] == 'T' &&
+ name[4] == 'C' &&
+ name[5] == 'H' &&
+ name[6] == 'E' &&
+ name[7] == 'C' &&
+ name[8] == 'K')
+ { /* UNITCHECK */
+ return KEY_UNITCHECK;
+ }
+
+ goto unknown;
+
case 'e':
if (name[1] == 'n' &&
name[2] == 'd' &&
}
while (isSPACE(*w))
++w;
- if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
+ /* the list of chars below is for end of statements or
+ * block / parens, boolean operators (&&, ||, //) and branch
+ * constructs (or, and, if, until, unless, while, err, for).
+ * Not a very solid hack... */
+ if (!*w || !strchr(";&/|})]oaiuwef!=", *w))
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"%s (...) interpreted as function",name);
}
s++;
if (*s == ',') {
GV* gv;
- if (keyword(w, s - w))
+ if (keyword(w, s - w, 0))
return;
gv = gv_fetchpvn_flags(w, s - w, 0, SVt_PVCV);
if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
SV *msg;
- why2 = strEQ(key,"charnames")
- ? "(possibly a missing \"use charnames ...\")"
- : "";
+ why2 = (const char *)
+ (strEQ(key,"charnames")
+ ? "(possibly a missing \"use charnames ...\")"
+ : "");
msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
(type ? type: "undef"), why2);
while (s < send && SPACE_OR_TAB(*s))
s++;
if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
- if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
- const char * const brack = (*s == '[') ? "[...]" : "{...}";
+ if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
+ const char * const brack =
+ (const char *)
+ ((*s == '[') ? "[...]" : "{...}");
Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
"Ambiguous use of %c{%s%s} resolved to %c%s%s",
funny, dest, brack, funny, dest, brack);
}
if (PL_lex_state == LEX_NORMAL) {
if (ckWARN(WARN_AMBIGUOUS) &&
- (keyword(dest, d - dest) || get_cv(dest, FALSE)))
+ (keyword(dest, d - dest, 0)
+ || get_cvn_flags(dest, d - dest, 0)))
{
if (funny == '#')
funny = '@';
Perl_pmflag(pTHX_ U32* pmfl, int ch)
{
PERL_UNUSED_CONTEXT;
- if (ch == 'i')
- *pmfl |= PMf_FOLD;
- else if (ch == 'g')
- *pmfl |= PMf_GLOBAL;
- else if (ch == 'c')
- *pmfl |= PMf_CONTINUE;
- else if (ch == 'o')
- *pmfl |= PMf_KEEP;
- else if (ch == 'm')
- *pmfl |= PMf_MULTILINE;
- else if (ch == 's')
- *pmfl |= PMf_SINGLELINE;
- else if (ch == 'x')
- *pmfl |= PMf_EXTENDED;
+ if (ch<256) {
+ char c = (char)ch;
+ switch (c) {
+ CASE_STD_PMMOD_FLAGS_PARSE_SET(pmfl);
+ case GLOBAL_PAT_MOD: *pmfl |= PMf_GLOBAL; break;
+ case CONTINUE_PAT_MOD: *pmfl |= PMf_CONTINUE; break;
+ case ONCE_PAT_MOD: *pmfl |= PMf_KEEP; break;
+ case KEEPCOPY_PAT_MOD: *pmfl |= PMf_KEEPCOPY; break;
+ }
+ }
}
STATIC char *
dVAR;
PMOP *pm;
char *s = scan_str(start,!!PL_madskills,FALSE);
- const char * const valid_flags = (type == OP_QR) ? "iomsx" : "iogcmsx";
+ const char * const valid_flags =
+ (const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS);
#ifdef PERL_MAD
char *modstart;
#endif
if (!s) {
const char * const delimiter = skipspace(start);
- Perl_croak(aTHX_ *delimiter == '?'
- ? "Search pattern not terminated or ternary operator parsed as search pattern"
- : "Search pattern not terminated" );
+ Perl_croak(aTHX_
+ (const char *)
+ (*delimiter == '?'
+ ? "Search pattern not terminated or ternary operator parsed as search pattern"
+ : "Search pattern not terminated" ));
}
pm = (PMOP*)newPMOP(type, 0);
- if (PL_multi_open == '?')
+ if (PL_multi_open == '?') {
+ /* This is the only point in the code that sets PMf_ONCE: */
pm->op_pmflags |= PMf_ONCE;
+
+ /* Hence it's safe to do this bit of PMOP book-keeping here, which
+ allows us to restrict the list needed by reset to just the ??
+ matches. */
+ assert(type != OP_TRANS);
+ if (PL_curstash) {
+ MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
+ U32 elements;
+ if (!mg) {
+ mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0,
+ 0);
+ }
+ elements = mg->mg_len / sizeof(PMOP**);
+ Renewc(mg->mg_ptr, elements + 1, PMOP*, char);
+ ((PMOP**)mg->mg_ptr) [elements++] = pm;
+ mg->mg_len = elements * sizeof(PMOP**);
+ PmopSTASH_set(pm,PL_curstash);
+ }
+ }
#ifdef PERL_MAD
modstart = s;
#endif
if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL)
&& ckWARN(WARN_REGEXP))
{
- Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless without /g" );
+ Perl_warner(aTHX_ packWARN(WARN_REGEXP),
+ "Use of /c modifier is meaningless without /g" );
}
- pm->op_pmpermflags = pm->op_pmflags;
-
PL_lex_op = (OP*)pm;
yylval.ival = OP_MATCH;
return s;
#endif
while (*s) {
- if (*s == 'e') {
+ if (*s == EXEC_PAT_MOD) {
s++;
es++;
}
- else if (strchr("iogcmsx", *s))
+ else if (strchr(S_PAT_MODS, *s))
pmflag(&pm->op_pmflags,*s++);
else
break;
PL_multi_end = 0;
pm->op_pmflags |= PMf_EVAL;
while (es-- > 0)
- sv_catpv(repl, es ? "eval " : "do ");
+ sv_catpv(repl, (const char *)(es ? "eval " : "do "));
sv_catpvs(repl, "{");
sv_catsv(repl, PL_lex_repl);
if (strchr(SvPVX(PL_lex_repl), '#'))
PL_lex_repl = repl;
}
- pm->op_pmpermflags = pm->op_pmflags;
PL_lex_op = (OP*)pm;
yylval.ival = OP_SUBST;
return s;
}
no_more:
- Newx(tbl, complement&&!del?258:256, short);
+ tbl = (short *)PerlMemShared_calloc(complement&&!del?258:256, sizeof(short));
o = newPVOP(OP_TRANS, 0, (char*)tbl);
o->op_private &= ~OPpTRANS_ALL;
o->op_private |= del|squash|complement|
#ifdef PERL_MAD
found_newline = 0;
#endif
- if ( outer || !(found_newline = memchr(s, '\n', PL_bufend - s)) ) {
+ if ( outer || !(found_newline = (char*)memchr((void*)s, '\n', PL_bufend - s)) ) {
herewas = newSVpvn(s,PL_bufend-s);
}
else {
s--;
#endif
- tmpstr = newSV(79);
- sv_upgrade(tmpstr, SVt_PVIV);
+ tmpstr = newSV_type(SVt_PVIV);
+ SvGROW(tmpstr, 80);
if (term == '\'') {
op_type = OP_CONST;
SvIV_set(tmpstr, -1);
else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
PL_bufend[-1] = '\n';
#endif
- if (PERLDB_LINE && PL_curstash != PL_debstash) {
- SV * const sv = newSV(0);
-
- sv_upgrade(sv, SVt_PVMG);
- sv_setsv(sv,PL_linestr);
- (void)SvIOK_on(sv);
- SvIV_set(sv, 0);
- av_store(CopFILEAVx(PL_curcop), (I32)CopLINE(PL_curcop),sv);
- }
+ if (PERLDB_LINE && PL_curstash != PL_debstash)
+ update_debugger_info(PL_linestr, NULL, 0);
if (*s == term && memEQ(s,PL_tokenbuf,len)) {
STRLEN off = PL_bufend - 1 - SvPVX_const(PL_linestr);
*(SvPVX(PL_linestr) + off ) = ' ';
&& GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
||
((gvp = (GV**)hv_fetchs(PL_globalstash, "readline", FALSE))
- && (gv_readline = *gvp) != (GV*)&PL_sv_undef
+ && (gv_readline = *gvp) && isGV_with_GP(gv_readline)
&& GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
readline_overriden = TRUE;
{
dVAR;
SV *sv; /* scalar value: string */
- char *tmps; /* temp string, used for delimiter matching */
+ const char *tmps; /* temp string, used for delimiter matching */
register char *s = start; /* current position in the buffer */
register char term; /* terminating character */
register char *to; /* current position in the sv's data */
I32 termcode; /* terminating char. code */
U8 termstr[UTF8_MAXBYTES]; /* terminating string */
STRLEN termlen; /* length of terminating string */
- char *last = NULL; /* last position for nesting bracket */
+ int last_off = 0; /* last position for nesting bracket */
#ifdef PERL_MAD
int stuffstart;
char *tstart;
/* create a new SV to hold the contents. 79 is the SV's initial length.
What a random number. */
- sv = newSV(79);
- sv_upgrade(sv, SVt_PVIV);
+ sv = newSV_type(SVt_PVIV);
+ SvGROW(sv, 80);
SvIV_set(sv, termcode);
(void)SvPOK_only(sv); /* validate pointer */
else {
const char *t;
char *w;
- if (!last)
- last = SvPVX(sv);
- for (t = w = last; t < svlast; w++, t++) {
+ for (t = w = SvPVX(sv)+last_off; t < svlast; w++, t++) {
/* At here, all closes are "was quoted" one,
so we don't check PL_multi_close. */
if (*t == '\\') {
*w = '\0';
SvCUR_set(sv, w - SvPVX_const(sv));
}
- last = w;
+ last_off = w - SvPVX(sv);
if (--brackets <= 0)
cont = FALSE;
}
CopLINE_inc(PL_curcop);
/* update debugger info */
- if (PERLDB_LINE && PL_curstash != PL_debstash) {
- SV * const line_sv = newSV(0);
-
- sv_upgrade(line_sv, SVt_PVMG);
- sv_setsv(line_sv,PL_linestr);
- (void)SvIOK_on(line_sv);
- SvIV_set(line_sv, 0);
- av_store(CopFILEAVx(PL_curcop), (I32)CopLINE(PL_curcop), line_sv);
- }
+ if (PERLDB_LINE && PL_curstash != PL_debstash)
+ update_debugger_info(PL_linestr, NULL, 0);
/* having changed the buffer, we must update PL_bufend */
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
#ifdef PERL_MAD
if (PL_madskills) {
char * const tstart = SvPVX(PL_linestr) + stuffstart;
- const int len = s - start;
+ const int len = s - tstart;
if (PL_thisstuff)
sv_catpvn(PL_thisstuff, tstart, len);
else
if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
(PL_hints & HINT_NEW_INTEGER) )
- sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
+ sv = new_constant(PL_tokenbuf,
+ d - PL_tokenbuf,
+ (const char *)
(floatit ? "float" : "integer"),
sv, NULL, NULL);
break;
case 'v':
vstring:
sv = newSV(5); /* preallocate storage space */
- s = scan_vstring(s,sv);
+ s = scan_vstring(s, PL_bufend, sv);
break;
}
save_item(PL_subname);
SAVESPTR(PL_compcv);
- PL_compcv = (CV*)newSV(0);
- sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
+ PL_compcv = (CV*)newSV_type(is_format ? SVt_PVFM : SVt_PVCV);
CvFLAGS(PL_compcv) |= flags;
PL_subline = CopLINE(PL_curcop);
const char *context = NULL;
int contlen = -1;
SV *msg;
+ int yychar = PL_parser->yychar;
if (!yychar || (yychar == ';' && !PL_rsfp))
where = "at EOF";
PL_multi_end = 0;
}
if (PL_in_eval & EVAL_WARNONLY && ckWARN_d(WARN_SYNTAX))
- Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, (void*)msg);
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, SVfARG(msg));
else
qerror(msg);
if (PL_error_count >= 10) {
if (PL_in_eval && SvCUR(ERRSV))
Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
- (void*)ERRSV, OutCopFILE(PL_curcop));
+ SVfARG(ERRSV), OutCopFILE(PL_curcop));
else
Perl_croak(aTHX_ "%s has too many errors.\n",
OutCopFILE(PL_curcop));
goto utf16be;
}
}
+#ifdef EBCDIC
+ case 0xDD:
+ if (slen > 3 && s[1] == 0x73 && s[2] == 0x66 && s[3] == 0x73) {
+ if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
+ s += 4; /* UTF-8 */
+ }
+ break;
+#endif
+
default:
if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
/* Leading bytes
return (char*)s;
}
-/*
- * restore_rsfp
- * Restore a source filter.
- */
-
-static void
-restore_rsfp(pTHX_ void *f)
-{
- dVAR;
- PerlIO * const fp = (PerlIO*)f;
-
- if (PL_rsfp == PerlIO_stdin())
- PerlIO_clearerr(PL_rsfp);
- else if (PL_rsfp && (PL_rsfp != fp))
- PerlIO_close(PL_rsfp);
- PL_rsfp = fp;
-}
#ifndef PERL_NO_UTF16_FILTER
static I32
Function must be called like
sv = newSV(5);
- s = scan_vstring(s,sv);
+ s = scan_vstring(s,e,sv);
+where s and e are the start and end of the string.
The sv should already be large enough to store the vstring
passed in, for performance reasons.
*/
char *
-Perl_scan_vstring(pTHX_ const char *s, SV *sv)
+Perl_scan_vstring(pTHX_ const char *s, const char *e, SV *sv)
{
dVAR;
const char *pos = s;
const char *start = s;
if (*pos == 'v') pos++; /* get past 'v' */
- while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
+ while (pos < e && (isDIGIT(*pos) || *pos == '_'))
pos++;
if ( *pos != '.') {
/* this may not be a v-string if followed by => */
const char *next = pos;
- while (next < PL_bufend && isSPACE(*next))
+ while (next < e && isSPACE(*next))
++next;
- if ((PL_bufend - next) >= 2 && *next == '=' && next[1] == '>' ) {
+ if ((e - next) >= 2 && *next == '=' && next[1] == '>' ) {
/* return string not v-string */
sv_setpvn(sv,(char *)s,pos-s);
return (char *)pos;
sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
SvUTF8_on(sv);
- if (pos + 1 < PL_bufend && *pos == '.' && isDIGIT(pos[1]))
+ if (pos + 1 < e && *pos == '.' && isDIGIT(pos[1]))
s = ++pos;
else {
s = pos;
break;
}
- while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
+ while (pos < e && (isDIGIT(*pos) || *pos == '_'))
pos++;
}
SvPOK_on(sv);
https://perl5.git.perl.org / perl5.git / blobdiff