/* 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
+ * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
+ * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 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.
*/
/*
- * "It all comes from here, the stench and the peril." --Frodo
+ * 'It all comes from here, the stench and the peril.' --Frodo
+ *
+ * [p.719 of _The Lord of the Rings_, IV/ix: "Shelob's Lair"]
*/
/*
#define PERL_IN_TOKE_C
#include "perl.h"
-#define yychar (*PL_yycharp)
-#define yylval (*PL_yylvalp)
+#define new_constant(a,b,c,d,e,f,g) \
+ S_new_constant(aTHX_ a,b,STR_WITH_LEN(c),d,e,f, g)
+
+#define pl_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
+#ifdef PERL_MAD
+# define CURMAD(slot,sv) if (PL_madskills) { curmad(slot,sv); sv = 0; }
+# define NEXTVAL_NEXTTOKE PL_nexttoke[PL_curforce].next_val
+#else
+# define CURMAD(slot,sv)
+# define NEXTVAL_NEXTTOKE PL_nextval[PL_nexttoke]
+#endif
+
#define XFAKEBRACK 128
#define XENUMMASK 127
#endif
#define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
+#ifdef PERL_MAD
+# define SKIPSPACE0(s) skipspace0(s)
+# define SKIPSPACE1(s) skipspace1(s)
+# define SKIPSPACE2(s,tsv) skipspace2(s,&tsv)
+# define PEEKSPACE(s) skipspace2(s,0)
+#else
+# define SKIPSPACE0(s) skipspace(s)
+# define SKIPSPACE1(s) skipspace(s)
+# define SKIPSPACE2(s,tsv) skipspace(s)
+# define PEEKSPACE(s) skipspace(s)
+#endif
+
/*
* Convenience functions to return different tokens and prime the
* lexer for the next token. They all take an argument.
*/
#ifdef DEBUGGING /* Serve -DT. */
-# define REPORT(retval) tokereport((I32)retval)
+# define REPORT(retval) tokereport((I32)retval, &pl_yylval)
#else
# define REPORT(retval) (retval)
#endif
#define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval))
#define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval))
#define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval))
-#define LOOPX(f) return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)LOOPEX))
-#define FTST(f) return (yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
-#define FUN0(f) return (yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
-#define FUN1(f) return (yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1))
-#define BOop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITOROP)))
-#define BAop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITANDOP)))
-#define SHop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)SHIFTOP)))
-#define PWop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)POWOP)))
-#define PMop(f) return(yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP))
-#define Aop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)ADDOP)))
-#define Mop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MULOP)))
-#define Eop(f) return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP))
-#define Rop(f) return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP))
+#define LOOPX(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)LOOPEX))
+#define FTST(f) return (pl_yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
+#define FUN0(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
+#define FUN1(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1))
+#define BOop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITOROP)))
+#define BAop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITANDOP)))
+#define SHop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)SHIFTOP)))
+#define PWop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)POWOP)))
+#define PMop(f) return(pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP))
+#define Aop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)ADDOP)))
+#define Mop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MULOP)))
+#define Eop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP))
+#define Rop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP))
/* This bit of chicanery makes a unary function followed by
* a parenthesis into a function with one argument, highest precedence.
* operator (such as C<shift // 0>).
*/
#define UNI2(f,x) { \
- yylval.ival = f; \
+ pl_yylval.ival = f; \
PL_expect = x; \
PL_bufptr = s; \
PL_last_uni = PL_oldbufptr; \
PL_last_lop_op = f; \
if (*s == '(') \
return REPORT( (int)FUNC1 ); \
- s = skipspace(s); \
+ s = PEEKSPACE(s); \
return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \
}
#define UNI(f) UNI2(f,XTERM)
#define UNIDOR(f) UNI2(f,XTERMORDORDOR)
#define UNIBRACK(f) { \
- yylval.ival = f; \
+ pl_yylval.ival = f; \
PL_bufptr = s; \
PL_last_uni = PL_oldbufptr; \
if (*s == '(') \
return REPORT( (int)FUNC1 ); \
- s = skipspace(s); \
+ s = PEEKSPACE(s); \
return REPORT( (*s == '(') ? (int)FUNC1 : (int)UNIOP ); \
}
/* grandfather return to old style */
-#define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
+#define OLDLOP(f) return(pl_yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
#ifdef DEBUGGING
-/* how to interpret the yylval associated with the token */
+/* how to interpret the pl_yylval associated with the token */
enum token_type {
TOKENTYPE_NONE,
TOKENTYPE_IVAL,
- TOKENTYPE_OPNUM, /* yylval.ival contains an opcode number */
+ TOKENTYPE_OPNUM, /* pl_yylval.ival contains an opcode number */
TOKENTYPE_PVAL,
TOKENTYPE_OPVAL,
TOKENTYPE_GVVAL
{ WHEN, TOKENTYPE_IVAL, "WHEN" },
{ WHILE, TOKENTYPE_IVAL, "WHILE" },
{ WORD, TOKENTYPE_OPVAL, "WORD" },
- { 0, TOKENTYPE_NONE, 0 }
+ { YADAYADA, TOKENTYPE_IVAL, "YADAYADA" },
+ { 0, TOKENTYPE_NONE, NULL }
};
-/* dump the returned token in rv, plus any optional arg in yylval */
+/* dump the returned token in rv, plus any optional arg in pl_yylval */
STATIC int
-S_tokereport(pTHX_ I32 rv)
+S_tokereport(pTHX_ I32 rv, const YYSTYPE* lvalp)
{
dVAR;
+
+ PERL_ARGS_ASSERT_TOKEREPORT;
+
if (DEBUG_T_TEST) {
const char *name = NULL;
enum token_type type = TOKENTYPE_NONE;
case TOKENTYPE_GVVAL: /* doesn't appear to be used */
break;
case TOKENTYPE_IVAL:
- Perl_sv_catpvf(aTHX_ report, "(ival=%"IVdf")", (IV)yylval.ival);
+ Perl_sv_catpvf(aTHX_ report, "(ival=%"IVdf")", (IV)lvalp->ival);
break;
case TOKENTYPE_OPNUM:
Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)",
- PL_op_name[yylval.ival]);
+ PL_op_name[lvalp->ival]);
break;
case TOKENTYPE_PVAL:
- Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", yylval.pval);
+ Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", lvalp->pval);
break;
case TOKENTYPE_OPVAL:
- if (yylval.opval) {
+ if (lvalp->opval) {
Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)",
- PL_op_name[yylval.opval->op_type]);
- if (yylval.opval->op_type == OP_CONST) {
+ PL_op_name[lvalp->opval->op_type]);
+ if (lvalp->opval->op_type == OP_CONST) {
Perl_sv_catpvf(aTHX_ report, " %s",
- SvPEEK(cSVOPx_sv(yylval.opval)));
+ SvPEEK(cSVOPx_sv(lvalp->opval)));
}
}
/* print the buffer with suitable escapes */
STATIC void
-S_printbuf(pTHX_ const char* fmt, const char* s)
+S_printbuf(pTHX_ const char *const fmt, const char *const s)
{
SV* const tmp = newSVpvs("");
+
+ PERL_ARGS_ASSERT_PRINTBUF;
+
PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60));
SvREFCNT_dec(tmp);
}
if (*PL_bufptr == '=') {
PL_bufptr++;
if (toketype == ANDAND)
- yylval.ival = OP_ANDASSIGN;
+ pl_yylval.ival = OP_ANDASSIGN;
else if (toketype == OROR)
- yylval.ival = OP_ORASSIGN;
+ pl_yylval.ival = OP_ORASSIGN;
else if (toketype == DORDOR)
- yylval.ival = OP_DORASSIGN;
+ pl_yylval.ival = OP_DORASSIGN;
toketype = ASSIGNOP;
}
return toketype;
*/
STATIC void
-S_no_op(pTHX_ const char *what, char *s)
+S_no_op(pTHX_ const char *const what, char *s)
{
dVAR;
char * const oldbp = PL_bufptr;
const bool is_first = (PL_oldbufptr == PL_linestart);
+ PERL_ARGS_ASSERT_NO_OP;
+
if (!s)
s = oldbp;
else
"\t(Missing semicolon on previous line?)\n");
else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
const char *t;
- for (t = PL_oldoldbufptr; *t && (isALNUM_lazy_if(t,UTF) || *t == ':'); t++) ;
+ for (t = PL_oldoldbufptr; (isALNUM_lazy_if(t,UTF) || *t == ':'); t++)
+ NOOP;
if (t < PL_bufptr && isSPACE(*t))
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"\t(Do you need to predeclare %.*s?)\n",
/*
* S_missingterm
* Complain about missing quote/regexp/heredoc terminator.
- * If it's called with (char *)NULL then it cauterizes the line buffer.
+ * If it's called with NULL then it cauterizes the line buffer.
* If we're in a delimited string and the delimiter is a control
* character, it's reformatted into a two-char sequence like ^C.
* This is fatal.
if (nl)
*nl = '\0';
}
- else if (
-#ifdef EBCDIC
- iscntrl(PL_multi_close)
-#else
- PL_multi_close < 32 || PL_multi_close == 127
-#endif
- ) {
+ else if (isCNTRL(PL_multi_close)) {
*tmpbuf = '^';
tmpbuf[1] = (char)toCTRL(PL_multi_close);
tmpbuf[2] = '\0';
#define FEATURE_IS_ENABLED(name) \
((0 != (PL_hints & HINT_LOCALIZE_HH)) \
&& S_feature_is_enabled(aTHX_ STR_WITH_LEN(name)))
+/* The longest string we pass in. */
+#define MAX_FEATURE_LEN (sizeof("switch")-1)
+
/*
* S_feature_is_enabled
* Check whether the named feature is enabled.
*/
STATIC bool
-S_feature_is_enabled(pTHX_ char *name, STRLEN namelen)
+S_feature_is_enabled(pTHX_ const char *const name, STRLEN namelen)
{
dVAR;
HV * const hinthv = GvHV(PL_hintgv);
- char he_name[32] = "feature_";
- (void) strncpy(&he_name[8], name, 24);
-
+ char he_name[8 + MAX_FEATURE_LEN] = "feature_";
+
+ PERL_ARGS_ASSERT_FEATURE_IS_ENABLED;
+
+ assert(namelen <= MAX_FEATURE_LEN);
+ memcpy(&he_name[8], name, namelen);
+
return (hinthv && hv_exists(hinthv, he_name, 8 + namelen));
}
*/
void
-Perl_deprecate(pTHX_ const char *s)
+Perl_deprecate(pTHX_ const char *const s)
{
+ PERL_ARGS_ASSERT_DEPRECATE;
+
if (ckWARN(WARN_DEPRECATED))
Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "Use of %s is deprecated", s);
}
void
-Perl_deprecate_old(pTHX_ const char *s)
+Perl_deprecate_old(pTHX_ const char *const s)
{
/* This function should NOT be called for any new deprecated warnings */
/* Use Perl_deprecate instead */
/* live under the "syntax" category. It is now a top-level category */
/* in its own right. */
+ PERL_ARGS_ASSERT_DEPRECATE_OLD;
+
if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
"Use of %s is deprecated", s);
{
register const char *s = SvPVX_const(sv);
register const char * const e = s + SvCUR(sv);
+
+ PERL_ARGS_ASSERT_STRIP_RETURN;
+
/* outer loop optimized to do nothing if there are no CR-LFs */
while (s < e) {
if (*s++ == '\r' && *s == '\n') {
}
#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;
- 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);
- if (PL_lex_state == LEX_KNOWNEXT) {
- I32 toke = PL_nexttoke;
- while (--toke >= 0) {
- SAVEI32(PL_nexttype[toke]);
- SAVEVPTR(PL_nextval[toke]);
- }
- SAVEI32(PL_nexttoke);
+ /* 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 */
+
+#ifdef PERL_MAD
+ parser->curforce = -1;
+#else
+ parser->nexttoke = 0;
+#endif
+ parser->error_count = oparser ? oparser->error_count : 0;
+ parser->copline = NOLINE;
+ parser->lex_state = LEX_NORMAL;
+ parser->expect = XSTATE;
+ parser->rsfp = rsfp;
+ parser->rsfp_filters = (new_filter || !oparser) ? newAV()
+ : MUTABLE_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;
}
- 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;
- PL_nexttoke = 0;
- 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;
+
+ 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)
+{
+ PERL_ARGS_ASSERT_PARSER_FREE;
+
+ 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->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;
+
+ PERL_ARGS_ASSERT_INCLINE;
CopLINE_inc(PL_curcop);
if (*s++ != '#')
return;
- while (SPACE_OR_TAB(*s)) s++;
+ while (SPACE_OR_TAB(*s))
+ s++;
if (strnEQ(s, "line", 4))
s += 4;
else
s++;
else
return;
- while (SPACE_OR_TAB(*s)) s++;
+ while (SPACE_OR_TAB(*s))
+ s++;
if (!isDIGIT(*s))
return;
+
n = s;
while (isDIGIT(*s))
s++;
+ if (!SPACE_OR_TAB(*s) && *s != '\r' && *s != '\n' && *s != '\0')
+ return;
while (SPACE_OR_TAB(*s))
s++;
if (*s == '"' && (t = strchr(s+1, '"'))) {
e = t + 1;
}
else {
- for (t = s; !isSPACE(*t); t++) ;
+ t = s;
+ while (!isSPACE(*t))
+ t++;
e = t;
}
while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
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;
+ SV *const temp_sv = CopFILESV(PL_curcop);
+ const char *cf;
+ STRLEN tmplen;
+
+ if (temp_sv) {
+ cf = SvPVX(temp_sv);
+ tmplen = SvCUR(temp_sv);
+ } else {
+ cf = NULL;
+ tmplen = 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) = MUTABLE_HV(SvREFCNT_inc(GvHV(*gvp)));
+ GvAV(gv2) = MUTABLE_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);
}
+#ifdef PERL_MAD
+/* skip space before PL_thistoken */
+
+STATIC char *
+S_skipspace0(pTHX_ register char *s)
+{
+ PERL_ARGS_ASSERT_SKIPSPACE0;
+
+ s = skipspace(s);
+ if (!PL_madskills)
+ return s;
+ if (PL_skipwhite) {
+ if (!PL_thiswhite)
+ PL_thiswhite = newSVpvs("");
+ sv_catsv(PL_thiswhite, PL_skipwhite);
+ sv_free(PL_skipwhite);
+ PL_skipwhite = 0;
+ }
+ PL_realtokenstart = s - SvPVX(PL_linestr);
+ return s;
+}
+
+/* skip space after PL_thistoken */
+
+STATIC char *
+S_skipspace1(pTHX_ register char *s)
+{
+ const char *start = s;
+ I32 startoff = start - SvPVX(PL_linestr);
+
+ PERL_ARGS_ASSERT_SKIPSPACE1;
+
+ s = skipspace(s);
+ if (!PL_madskills)
+ return s;
+ start = SvPVX(PL_linestr) + startoff;
+ if (!PL_thistoken && PL_realtokenstart >= 0) {
+ const char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
+ PL_thistoken = newSVpvn(tstart, start - tstart);
+ }
+ PL_realtokenstart = -1;
+ if (PL_skipwhite) {
+ if (!PL_nextwhite)
+ PL_nextwhite = newSVpvs("");
+ sv_catsv(PL_nextwhite, PL_skipwhite);
+ sv_free(PL_skipwhite);
+ PL_skipwhite = 0;
+ }
+ return s;
+}
+
+STATIC char *
+S_skipspace2(pTHX_ register char *s, SV **svp)
+{
+ char *start;
+ const I32 bufptroff = PL_bufptr - SvPVX(PL_linestr);
+ const I32 startoff = s - SvPVX(PL_linestr);
+
+ PERL_ARGS_ASSERT_SKIPSPACE2;
+
+ s = skipspace(s);
+ PL_bufptr = SvPVX(PL_linestr) + bufptroff;
+ if (!PL_madskills || !svp)
+ return s;
+ start = SvPVX(PL_linestr) + startoff;
+ if (!PL_thistoken && PL_realtokenstart >= 0) {
+ char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
+ PL_thistoken = newSVpvn(tstart, start - tstart);
+ PL_realtokenstart = -1;
+ }
+ if (PL_skipwhite) {
+ if (!*svp)
+ *svp = newSVpvs("");
+ sv_setsv(*svp, PL_skipwhite);
+ sv_free(PL_skipwhite);
+ PL_skipwhite = 0;
+ }
+
+ return s;
+}
+#endif
+
+STATIC void
+S_update_debugger_info(pTHX_ SV *orig_sv, const char *const 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.
S_skipspace(pTHX_ register char *s)
{
dVAR;
+#ifdef PERL_MAD
+ int curoff;
+ int startoff = s - SvPVX(PL_linestr);
+
+ PERL_ARGS_ASSERT_SKIPSPACE;
+
+ if (PL_skipwhite) {
+ sv_free(PL_skipwhite);
+ PL_skipwhite = 0;
+ }
+#endif
+ PERL_ARGS_ASSERT_SKIPSPACE;
+
if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
while (s < PL_bufend && SPACE_OR_TAB(*s))
s++;
+#ifdef PERL_MAD
+ goto done;
+#else
return s;
+#endif
}
for (;;) {
STRLEN prevlen;
*/
if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat ||
PL_lex_state == LEX_FORMLINE)
+#ifdef PERL_MAD
+ goto done;
+#else
return s;
+#endif
/* try to recharge the buffer */
+#ifdef PERL_MAD
+ curoff = s - SvPVX(PL_linestr);
+#endif
+
if ((s = filter_gets(PL_linestr, PL_rsfp,
(prevlen = SvCUR(PL_linestr)))) == NULL)
{
+#ifdef PERL_MAD
+ if (PL_madskills && curoff != startoff) {
+ if (!PL_skipwhite)
+ PL_skipwhite = newSVpvs("");
+ sv_catpvn(PL_skipwhite, SvPVX(PL_linestr) + startoff,
+ curoff - startoff);
+ }
+
+ /* mustn't throw out old stuff yet if madpropping */
+ SvCUR(PL_linestr) = curoff;
+ s = SvPVX(PL_linestr) + curoff;
+ *s = 0;
+ if (curoff && s[-1] == '\n')
+ s[-1] = ' ';
+#endif
+
/* end of file. Add on the -p or -n magic */
+ /* XXX these shouldn't really be added here, can't set PL_faketokens */
if (PL_minus_p) {
- sv_setpv(PL_linestr,
+#ifdef PERL_MAD
+ sv_catpvs(PL_linestr,
";}continue{print or die qq(-p destination: $!\\n);}");
+#else
+ sv_setpvs(PL_linestr,
+ ";}continue{print or die qq(-p destination: $!\\n);}");
+#endif
PL_minus_n = PL_minus_p = 0;
}
else if (PL_minus_n) {
- sv_setpvn(PL_linestr, ";}", 2);
+#ifdef PERL_MAD
+ sv_catpvs(PL_linestr, ";}");
+#else
+ sv_setpvs(PL_linestr, ";}");
+#endif
PL_minus_n = 0;
}
else
- sv_setpvn(PL_linestr,";", 1);
+#ifdef PERL_MAD
+ sv_catpvs(PL_linestr,";");
+#else
+ sv_setpvs(PL_linestr,";");
+#endif
/* reset variables for next time we lex */
PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
- = SvPVX(PL_linestr);
+ = SvPVX(PL_linestr)
+#ifdef PERL_MAD
+ + curoff
+#endif
+ ;
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
PL_last_lop = PL_last_uni = NULL;
- /* Close the filehandle. Could be from -P preprocessor,
+ /* Close the filehandle. Could be from
* STDIN, or a regular file. If we were reading code from
* STDIN (because the commandline held no -e or filename)
* then we don't close it, we reset it so the code can
* read from STDIN too.
*/
- if (PL_preprocess && !PL_in_eval)
- (void)PerlProc_pclose(PL_rsfp);
- else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
+ if ((PerlIO*)PL_rsfp == PerlIO_stdin())
PerlIO_clearerr(PL_rsfp);
else
(void)PerlIO_close(PL_rsfp);
/* 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);
+ if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
+ update_debugger_info(NULL, PL_bufptr, PL_bufend - PL_bufptr);
+ }
- 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);
- }
+#ifdef PERL_MAD
+ done:
+ if (PL_madskills) {
+ if (!PL_skipwhite)
+ PL_skipwhite = newSVpvs("");
+ curoff = s - SvPVX(PL_linestr);
+ if (curoff - startoff)
+ sv_catpvn(PL_skipwhite, SvPVX(PL_linestr) + startoff,
+ curoff - startoff);
}
+ return s;
+#endif
}
/*
S_check_uni(pTHX)
{
dVAR;
- char *s;
- char *t;
+ const char *s;
+ const char *t;
if (PL_oldoldbufptr != PL_last_uni)
return;
while (isSPACE(*PL_last_uni))
PL_last_uni++;
- for (s = PL_last_uni; isALNUM_lazy_if(s,UTF) || *s == '-'; s++) ;
+ s = PL_last_uni;
+ while (isALNUM_lazy_if(s,UTF) || *s == '-')
+ s++;
if ((t = strchr(s, '(')) && t < PL_bufptr)
return;
- /* XXX Things like this are just so nasty. We shouldn't be modifying
- source code, even if we realquick set it back. */
if (ckWARN_d(WARN_AMBIGUOUS)){
- const char ch = *s;
- *s = '\0';
Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
- "Warning: Use of \"%s\" without parentheses is ambiguous",
- PL_last_uni);
- *s = ch;
+ "Warning: Use of \"%.*s\" without parentheses is ambiguous",
+ (int)(s - PL_last_uni), PL_last_uni);
}
}
S_lop(pTHX_ I32 f, int x, char *s)
{
dVAR;
- yylval.ival = f;
+
+ PERL_ARGS_ASSERT_LOP;
+
+ pl_yylval.ival = f;
CLINE;
PL_expect = x;
PL_bufptr = s;
PL_last_lop = PL_oldbufptr;
PL_last_lop_op = (OPCODE)f;
+#ifdef PERL_MAD
+ if (PL_lasttoke)
+ return REPORT(LSTOP);
+#else
if (PL_nexttoke)
return REPORT(LSTOP);
+#endif
if (*s == '(')
return REPORT(FUNC);
- s = skipspace(s);
+ s = PEEKSPACE(s);
if (*s == '(')
return REPORT(FUNC);
else
return REPORT(LSTOP);
}
+#ifdef PERL_MAD
+ /*
+ * S_start_force
+ * Sets up for an eventual force_next(). start_force(0) basically does
+ * an unshift, while start_force(-1) does a push. yylex removes items
+ * on the "pop" end.
+ */
+
+STATIC void
+S_start_force(pTHX_ int where)
+{
+ int i;
+
+ if (where < 0) /* so people can duplicate start_force(PL_curforce) */
+ where = PL_lasttoke;
+ assert(PL_curforce < 0 || PL_curforce == where);
+ if (PL_curforce != where) {
+ for (i = PL_lasttoke; i > where; --i) {
+ PL_nexttoke[i] = PL_nexttoke[i-1];
+ }
+ PL_lasttoke++;
+ }
+ if (PL_curforce < 0) /* in case of duplicate start_force() */
+ Zero(&PL_nexttoke[where], 1, NEXTTOKE);
+ PL_curforce = where;
+ if (PL_nextwhite) {
+ if (PL_madskills)
+ curmad('^', newSVpvs(""));
+ CURMAD('_', PL_nextwhite);
+ }
+}
+
+STATIC void
+S_curmad(pTHX_ char slot, SV *sv)
+{
+ MADPROP **where;
+
+ if (!sv)
+ return;
+ if (PL_curforce < 0)
+ where = &PL_thismad;
+ else
+ where = &PL_nexttoke[PL_curforce].next_mad;
+
+ if (PL_faketokens)
+ sv_setpvs(sv, "");
+ else {
+ if (!IN_BYTES) {
+ if (UTF && is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
+ SvUTF8_on(sv);
+ else if (PL_encoding) {
+ sv_recode_to_utf8(sv, PL_encoding);
+ }
+ }
+ }
+
+ /* keep a slot open for the head of the list? */
+ if (slot != '_' && *where && (*where)->mad_key == '^') {
+ (*where)->mad_key = slot;
+ sv_free(MUTABLE_SV(((*where)->mad_val)));
+ (*where)->mad_val = (void*)sv;
+ }
+ else
+ addmad(newMADsv(slot, sv), where, 0);
+}
+#else
+# define start_force(where) NOOP
+# define curmad(slot, sv) NOOP
+#endif
+
/*
* S_force_next
* When the lexer realizes it knows the next token (for instance,
* it is reordering tokens for the parser) then it can call S_force_next
* to know what token to return the next time the lexer is called. Caller
- * will need to set PL_nextval[], and possibly PL_expect to ensure the lexer
- * handles the token correctly.
+ * will need to set PL_nextval[] (or PL_nexttoke[].next_val with PERL_MAD),
+ * and possibly PL_expect to ensure the lexer handles the token correctly.
*/
STATIC void
S_force_next(pTHX_ I32 type)
{
dVAR;
+#ifdef DEBUGGING
+ if (DEBUG_T_TEST) {
+ PerlIO_printf(Perl_debug_log, "### forced token:\n");
+ tokereport(type, &NEXTVAL_NEXTTOKE);
+ }
+#endif
+#ifdef PERL_MAD
+ if (PL_curforce < 0)
+ start_force(PL_lasttoke);
+ PL_nexttoke[PL_curforce].next_type = type;
+ if (PL_lex_state != LEX_KNOWNEXT)
+ PL_lex_defer = PL_lex_state;
+ PL_lex_state = LEX_KNOWNEXT;
+ PL_lex_expect = PL_expect;
+ PL_curforce = -1;
+#else
PL_nexttype[PL_nexttoke] = type;
PL_nexttoke++;
if (PL_lex_state != LEX_KNOWNEXT) {
PL_lex_expect = PL_expect;
PL_lex_state = LEX_KNOWNEXT;
}
+#endif
}
STATIC SV *
-S_newSV_maybe_utf8(pTHX_ const char *start, STRLEN len)
+S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len)
{
dVAR;
- SV * const sv = newSVpvn(start,len);
- if (UTF && !IN_BYTES && is_utf8_string((const U8*)start, len))
- SvUTF8_on(sv);
+ SV * const sv = newSVpvn_utf8(start, len,
+ UTF && !IN_BYTES
+ && is_utf8_string((const U8*)start, len));
return sv;
}
* 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,
register char *s;
STRLEN len;
- start = skipspace(start);
+ PERL_ARGS_ASSERT_FORCE_WORD;
+
+ start = SKIPSPACE1(start);
s = start;
if (isIDFIRST_lazy_if(s,UTF) ||
(allow_pack && *s == ':') ||
(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)
+ curmad('X', newSVpvn(start,s-start));
if (token == METHOD) {
- s = skipspace(s);
+ s = SKIPSPACE1(s);
if (*s == '(')
PL_expect = XTERM;
else {
PL_expect = XOPERATOR;
}
}
- PL_nextval[PL_nexttoke].opval
+ if (PL_madskills)
+ curmad('g', newSVpvs( "forced" ));
+ NEXTVAL_NEXTTOKE.opval
= (OP*)newSVOP(OP_CONST,0,
S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
- PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
+ NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
force_next(token);
}
return s;
S_force_ident(pTHX_ register const char *s, int kind)
{
dVAR;
- if (s && *s) {
+
+ PERL_ARGS_ASSERT_FORCE_IDENT;
+
+ if (*s) {
const STRLEN len = strlen(s);
OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn(s, len));
- PL_nextval[PL_nexttoke].opval = o;
+ start_force(PL_curforce);
+ NEXTVAL_NEXTTOKE.opval = o;
force_next(WORD);
if (kind) {
o->op_private = OPpCONST_ENTERED;
const char *start = SvPV_const(sv,len);
const char * const end = start + len;
const bool utf = SvUTF8(sv) ? TRUE : FALSE;
+
+ PERL_ARGS_ASSERT_STR_TO_VERSION;
+
while (start < end) {
STRLEN skip;
UV n;
dVAR;
OP *version = NULL;
char *d;
+#ifdef PERL_MAD
+ I32 startoff = s - SvPVX(PL_linestr);
+#endif
- s = skipspace(s);
+ PERL_ARGS_ASSERT_FORCE_VERSION;
+
+ s = SKIPSPACE1(s);
d = s;
if (*d == 'v')
if (isDIGIT(*d)) {
while (isDIGIT(*d) || *d == '_' || *d == '.')
d++;
+#ifdef PERL_MAD
+ if (PL_madskills) {
+ start_force(PL_curforce);
+ curmad('X', newSVpvn(s,d-s));
+ }
+#endif
if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
SV *ver;
- s = scan_num(s, &yylval);
- version = yylval.opval;
+ s = scan_num(s, &pl_yylval);
+ version = pl_yylval.opval;
ver = cSVOPx(version)->op_sv;
if (SvPOK(ver) && !SvNIOK(ver)) {
SvUPGRADE(ver, SVt_PVNV);
SvNOK_on(ver); /* hint that it is a version */
}
}
- else if (guessing)
+ else if (guessing) {
+#ifdef PERL_MAD
+ if (PL_madskills) {
+ sv_free(PL_nextwhite); /* let next token collect whitespace */
+ PL_nextwhite = 0;
+ s = SvPVX(PL_linestr) + startoff;
+ }
+#endif
return s;
+ }
}
+#ifdef PERL_MAD
+ if (PL_madskills && !version) {
+ sv_free(PL_nextwhite); /* let next token collect whitespace */
+ PL_nextwhite = 0;
+ s = SvPVX(PL_linestr) + startoff;
+ }
+#endif
/* NOTE: The parser sees the package name and the VERSION swapped */
- PL_nextval[PL_nexttoke].opval = version;
+ start_force(PL_curforce);
+ NEXTVAL_NEXTTOKE.opval = version;
force_next(WORD);
return s;
STRLEN len = 0;
SV *pv = sv;
+ PERL_ARGS_ASSERT_TOKEQ;
+
if (!SvLEN(sv))
goto finish;
goto finish;
d = s;
if ( PL_hints & HINT_NEW_STRING ) {
- pv = sv_2mortal(newSVpvn(SvPVX_const(pv), len));
- if (SvUTF8(sv))
- SvUTF8_on(pv);
+ pv = newSVpvn_flags(SvPVX_const(pv), len, SVs_TEMP | SvUTF8(sv));
}
while (s < send) {
if (*s == '\\') {
SvCUR_set(sv, d - SvPVX_const(sv));
finish:
if ( PL_hints & HINT_NEW_STRING )
- return new_constant(NULL, 0, "q", sv, pv, "q");
+ return new_constant(NULL, 0, "q", sv, pv, "q", 1);
return sv;
}
/*
* S_sublex_start
- * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST).
+ * Assumes that pl_yylval.ival is the op we're creating (e.g. OP_LCFIRST).
*
* Pattern matching will set PL_lex_op to the pattern-matching op to
- * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise).
+ * make (we return THING if pl_yylval.ival is OP_NULL, PMFUNC otherwise).
*
* OP_CONST and OP_READLINE are easy--just make the new op and return.
*
S_sublex_start(pTHX)
{
dVAR;
- register const I32 op_type = yylval.ival;
+ register const I32 op_type = pl_yylval.ival;
if (op_type == OP_NULL) {
- yylval.opval = PL_lex_op;
+ pl_yylval.opval = PL_lex_op;
PL_lex_op = NULL;
return THING;
}
/* Overloaded constants, nothing fancy: Convert to SVt_PV: */
STRLEN len;
const char * const p = SvPV_const(sv, len);
- SV * const nsv = newSVpvn(p, len);
- if (SvUTF8(sv))
- SvUTF8_on(nsv);
+ SV * const nsv = newSVpvn_flags(p, len, SvUTF8(sv));
SvREFCNT_dec(sv);
sv = nsv;
}
- yylval.opval = (OP*)newSVOP(op_type, 0, sv);
+ pl_yylval.opval = (OP*)newSVOP(op_type, 0, sv);
PL_lex_stuff = NULL;
/* Allow <FH> // "foo" */
if (op_type == OP_READLINE)
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);
+ pl_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;
PL_expect = XTERM;
if (PL_lex_op) {
- yylval.opval = PL_lex_op;
+ pl_yylval.opval = PL_lex_op;
PL_lex_op = NULL;
return PMFUNC;
}
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 (SvUTF8(PL_linestr))
SvUTF8_on(sv);
PL_expect = XOPERATOR;
- yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
+ pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
return THING;
}
return ',';
}
else {
+#ifdef PERL_MAD
+ if (PL_madskills) {
+ if (PL_thiswhite) {
+ if (!PL_endwhite)
+ PL_endwhite = newSVpvs("");
+ sv_catsv(PL_endwhite, PL_thiswhite);
+ PL_thiswhite = 0;
+ }
+ if (PL_thistoken)
+ sv_setpvs(PL_thistoken,"");
+ else
+ PL_realtokenstart = -1;
+ }
+#endif
LEAVE;
PL_bufend = SvPVX(PL_linestr);
PL_bufend += SvCUR(PL_linestr);
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
+ in pl_yylval. Caller must intuit reason for not parsing further
by looking at the next characters herself.
In patterns:
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)
+ continue
} (end if backslash)
+ handle regular character
} (end while character to read)
*/
{
dVAR;
register char *send = PL_bufend; /* end of the constant */
- SV *sv = newSV(send - start); /* sv for the constant */
+ SV *sv = newSV(send - start); /* sv for the constant. See
+ note below on sizing. */
register char *s = start; /* start of the constant */
register char *d = SvPVX(sv); /* destination for copies */
bool dorange = FALSE; /* are we in a translit range? */
bool didrange = FALSE; /* did we just finish a range? */
I32 has_utf8 = FALSE; /* Output constant is UTF8 */
- I32 this_utf8 = UTF; /* The source string is assumed to be UTF8 */
+ I32 this_utf8 = UTF; /* Is the source string assumed
+ to be UTF8? But, this can
+ show as true when the source
+ isn't utf8, as for example
+ when it is entirely composed
+ of hex constants */
+
+ /* Note on sizing: The scanned constant is placed into sv, which is
+ * initialized by newSV() assuming one byte of output for every byte of
+ * input. This routine expects newSV() to allocate an extra byte for a
+ * trailing NUL, which this routine will append if it gets to the end of
+ * the input. There may be more bytes of input than output (eg., \N{LATIN
+ * CAPITAL LETTER A}), or more output than input if the constant ends up
+ * recoded to utf8, but each time a construct is found that might increase
+ * the needed size, SvGROW() is called. Its size parameter each time is
+ * based on the best guess estimate at the time, namely the length used so
+ * far, plus the length the current construct will occupy, plus room for
+ * the trailing NUL, plus one byte for every input byte still unscanned */
+
UV uv;
#ifdef EBCDIC
UV literal_endpoint = 0;
+ bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */
#endif
- const char *leaveit = /* set of acceptably-backslashed characters */
- PL_lex_inpat
- ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxz0123456789[{]} \t\n\r\f\v#"
- : "";
+ PERL_ARGS_ASSERT_SCAN_CONST;
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 */
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.
else if (*s == '$') {
if (!PL_lex_inpat) /* not a regexp, so $ must be var */
break;
- if (s + 1 < send && !strchr("()| \r\n\t", s[1]))
+ if (s + 1 < send && !strchr("()| \r\n\t", s[1])) {
+ if (s[1] == '\\' && ckWARN(WARN_AMBIGUOUS)) {
+ Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
+ "Possible unintended interpolation of $\\ in regex");
+ }
break; /* in regexp, $ might be tail anchor */
+ }
}
/* End of else if chain - OP_TRANS rejoin rest */
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) {
/* FALL THROUGH */
default:
{
- if (isALNUM(*s) &&
- *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;
}
- /* \132 indicates an octal constant */
+ /* eg. \132 indicates the octal constant 0x132 */
case '0': case '1': case '2': case '3':
case '4': case '5': case '6': case '7':
{
I32 flags = 0;
STRLEN len = 3;
- uv = grok_oct(s, &len, &flags, NULL);
+ uv = NATIVE_TO_UNI(grok_oct(s, &len, &flags, NULL));
s += len;
}
goto NUM_ESCAPE_INSERT;
- /* \x24 indicates a hex constant */
+ /* eg. \x24 indicates the hex constant 0x24 */
case 'x':
++s;
if (*s == '{') {
continue;
}
len = e - s;
- uv = grok_hex(s, &len, &flags, NULL);
+ uv = NATIVE_TO_UNI(grok_hex(s, &len, &flags, NULL));
s = e + 1;
}
else {
{
STRLEN len = 2;
I32 flags = PERL_SCAN_DISALLOW_PREFIX;
- uv = grok_hex(s, &len, &flags, NULL);
+ uv = NATIVE_TO_UNI(grok_hex(s, &len, &flags, NULL));
s += len;
}
}
NUM_ESCAPE_INSERT:
- /* Insert oct or hex escaped character.
- * There will always enough room in sv since such
- * escapes will be longer than any UTF-8 sequence
- * they can end up as. */
+ /* Insert oct, hex, or \N{U+...} escaped character. There will
+ * always be enough room in sv since such escapes will be
+ * longer than any UTF-8 sequence they can end up as, except if
+ * they force us to recode the rest of the string into utf8 */
- /* We need to map to chars to ASCII before doing the tests
- to cover EBCDIC
- */
- if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(uv))) {
+ /* Here uv is the ordinal of the next character being added in
+ * unicode (converted from native). (It has to be done before
+ * here because \N is interpreted as unicode, and oct and hex
+ * as native.) */
+ if (!UNI_IS_INVARIANT(uv)) {
if (!has_utf8 && uv > 255) {
- /* Might need to recode whatever we have
- * accumulated so far if it contains any
- * hibit chars.
- *
- * (Can't we keep track of that and avoid
- * this rescan? --jhi)
- */
- int hicount = 0;
- U8 *c;
- for (c = (U8 *) SvPVX(sv); c < (U8 *)d; c++) {
- if (!NATIVE_IS_INVARIANT(*c)) {
- hicount++;
- }
- }
- if (hicount) {
- const STRLEN offset = d - SvPVX_const(sv);
- U8 *src, *dst;
- d = SvGROW(sv, SvLEN(sv) + hicount + 1) + offset;
- src = (U8 *)d - 1;
- dst = src+hicount;
- d += hicount;
- while (src >= (const U8 *)SvPVX_const(sv)) {
- if (!NATIVE_IS_INVARIANT(*src)) {
- const U8 ch = NATIVE_TO_ASCII(*src);
- *dst-- = (U8)UTF8_EIGHT_BIT_LO(ch);
- *dst-- = (U8)UTF8_EIGHT_BIT_HI(ch);
- }
- else {
- *dst-- = *src;
- }
- src--;
- }
- }
+ /* Might need to recode whatever we have accumulated so
+ * far if it contains any chars variant in utf8 or
+ * utf-ebcdic. */
+
+ SvCUR_set(sv, d - SvPVX_const(sv));
+ SvPOK_on(sv);
+ *d = '\0';
+ /* See Note on sizing above. */
+ sv_utf8_upgrade_flags_grow(sv,
+ SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
+ UNISKIP(uv) + (STRLEN)(send - s) + 1);
+ d = SvPVX(sv) + SvCUR(sv);
+ has_utf8 = TRUE;
}
- if (has_utf8 || uv > 255) {
- d = (char*)uvchr_to_utf8((U8*)d, uv);
- has_utf8 = TRUE;
+ if (has_utf8) {
+ d = (char*)uvuni_to_utf8((U8*)d, uv);
if (PL_lex_inwhat == OP_TRANS &&
PL_sublex_info.sub_op) {
PL_sublex_info.sub_op->op_private |=
(PL_lex_repl ? OPpTRANS_FROM_UTF
: OPpTRANS_TO_UTF);
}
+#ifdef EBCDIC
+ if (uv > 255 && !dorange)
+ native_range = FALSE;
+#endif
}
else {
*d++ = (char)uv;
}
continue;
- /* \N{LATIN SMALL LETTER A} is a named character */
+ /* \N{LATIN SMALL LETTER A} is a named character, and so is
+ * \N{U+0041} */
case 'N':
++s;
if (*s == '{') {
goto cont_scan;
}
if (e > s + 2 && s[1] == 'U' && s[2] == '+') {
- /* \N{U+...} */
+ /* \N{U+...} The ... is a unicode value even on EBCDIC
+ * machines */
I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
PERL_SCAN_DISALLOW_PREFIX;
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);
res = new_constant( NULL, 0, "charnames",
- res, NULL, "\\N{...}" );
+ res, NULL, s - 2, e - s + 3 );
if (has_utf8)
sv_utf8_upgrade(res);
str = SvPV_const(res,len);
}
}
#endif
+ /* If destination is not in utf8 but this new character is,
+ * recode the dest to utf8 */
if (!has_utf8 && SvUTF8(res)) {
- const char * const ostart = SvPVX_const(sv);
- SvCUR_set(sv, d - ostart);
+ SvCUR_set(sv, d - SvPVX_const(sv));
SvPOK_on(sv);
*d = '\0';
- sv_utf8_upgrade(sv);
- /* this just broke our allocation above... */
- SvGROW(sv, (STRLEN)(send - start));
+ /* See Note on sizing above. */
+ sv_utf8_upgrade_flags_grow(sv,
+ SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
+ len + (STRLEN)(send - s) + 1);
d = SvPVX(sv) + SvCUR(sv);
has_utf8 = TRUE;
- }
- if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
- const char * const odest = SvPVX_const(sv);
+ } else if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
- SvGROW(sv, (SvLEN(sv) + len - (e - s + 4)));
- d = SvPVX(sv) + (d - odest);
+ /* See Note on sizing above. (NOTE: SvCUR() is not set
+ * correctly here). */
+ const STRLEN off = d - SvPVX_const(sv);
+ d = SvGROW(sv, off + len + (STRLEN)(send - s) + 1) + off;
}
+#ifdef EBCDIC
+ if (!dorange)
+ native_range = FALSE; /* \N{} is guessed to be Unicode */
+#endif
Copy(str, d, len, char);
d += len;
SvREFCNT_dec(res);
#endif
default_action:
- /* If we started with encoded form, or already know we want it
- and then encode the next character */
- if ((has_utf8 || this_utf8) && !NATIVE_IS_INVARIANT((U8)(*s))) {
+ /* If we started with encoded form, or already know we want it,
+ then encode the next character */
+ if (! NATIVE_IS_INVARIANT((U8)(*s)) && (this_utf8 || has_utf8)) {
STRLEN len = 1;
+
+
+ /* One might think that it is wasted effort in the case of the
+ * source being utf8 (this_utf8 == TRUE) to take the next character
+ * in the source, convert it to an unsigned value, and then convert
+ * it back again. But the source has not been validated here. The
+ * routine that does the conversion checks for errors like
+ * malformed utf8 */
+
const UV nextuv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
const STRLEN need = UNISKIP(NATIVE_TO_UNI(nextuv));
- s += len;
- if (need > len) {
- /* encoded value larger than old, need extra space (NOTE: SvCUR() not set here) */
+ if (!has_utf8) {
+ SvCUR_set(sv, d - SvPVX_const(sv));
+ SvPOK_on(sv);
+ *d = '\0';
+ /* See Note on sizing above. */
+ sv_utf8_upgrade_flags_grow(sv,
+ SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
+ need + (STRLEN)(send - s) + 1);
+ d = SvPVX(sv) + SvCUR(sv);
+ has_utf8 = TRUE;
+ } else if (need > len) {
+ /* encoded value larger than old, may need extra space (NOTE:
+ * SvCUR() is not set correctly here). See Note on sizing
+ * above. */
const STRLEN off = d - SvPVX_const(sv);
- d = SvGROW(sv, SvLEN(sv) + (need-len)) + off;
+ d = SvGROW(sv, off + need + (STRLEN)(send - s) + 1) + off;
}
+ s += len;
+
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++);
SvPV_shrink_to_cur(sv);
}
- /* return the substring (via yylval) only if we parsed anything */
+ /* return the substring (via pl_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, NULL,
- ( PL_lex_inwhat == OP_TRANS
- ? "tr"
- : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
- ? "s"
- : "qq")));
- yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
+ if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) ) {
+ const char *const key = PL_lex_inpat ? "qr" : "q";
+ const STRLEN keylen = PL_lex_inpat ? 2 : 1;
+ const char *type;
+ STRLEN typelen;
+
+ if (PL_lex_inwhat == OP_TRANS) {
+ type = "tr";
+ typelen = 2;
+ } else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) {
+ type = "s";
+ typelen = 1;
+ } else {
+ type = "qq";
+ typelen = 2;
+ }
+
+ sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL,
+ type, typelen);
+ }
+ pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
} else
SvREFCNT_dec(sv);
return s;
S_intuit_more(pTHX_ register char *s)
{
dVAR;
+
+ PERL_ARGS_ASSERT_INTUIT_MORE;
+
if (PL_lex_brackets)
return TRUE;
if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
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)
char tmpbuf[sizeof PL_tokenbuf];
STRLEN len;
GV* indirgv;
+#ifdef PERL_MAD
+ int soff;
+#endif
+
+ PERL_ARGS_ASSERT_INTUIT_METHOD;
if (gv) {
if (SvTYPE(gv) == SVt_PVGV && GvIO(gv))
}
}
} else
- gv = 0;
+ gv = NULL;
}
s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
/* start is the beginning of the possible filehandle/object,
*/
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;
- s = skipspace(s);
+#ifdef PERL_MAD
+ len = start - SvPVX(PL_linestr);
+#endif
+ s = PEEKSPACE(s);
+#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';
+#ifdef PERL_MAD
+ soff = s - SvPVX(PL_linestr);
+#endif
goto bare_package;
}
indirgv = gv_fetchpvn_flags(tmpbuf, len, 0, SVt_PVCV);
if (indirgv && GvCVu(indirgv))
return 0;
/* filehandle or package name makes it a method */
- if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
- s = skipspace(s);
+ if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, 0)) {
+#ifdef PERL_MAD
+ soff = s - SvPVX(PL_linestr);
+#endif
+ s = PEEKSPACE(s);
if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
return 0; /* no assumptions -- "=>" quotes bearword */
bare_package:
- PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
+ start_force(PL_curforce);
+ NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
newSVpvn(tmpbuf,len));
- PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
+ NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
+ if (PL_madskills)
+ curmad('X', newSVpvn(start,SvPVX(PL_linestr) + soff - start));
PL_expect = XTERM;
force_next(WORD);
PL_bufptr = s;
+#ifdef PERL_MAD
+ PL_bufptr = SvPVX(PL_linestr) + soff; /* restart before space */
+#endif
return *s == '(' ? FUNCMETH : METHOD;
}
}
return 0;
}
-/*
- * S_incl_perldb
- * Return a string of Perl code to load the debugger. If PERL5DB
- * is set, it will return the contents of that, otherwise a
- * compile-time require of perl5db.pl.
- */
-
-STATIC const char*
-S_incl_perldb(pTHX)
-{
- dVAR;
- if (PL_perldb) {
- const char * const pdb = PerlEnv_getenv("PERL5DB");
-
- if (pdb)
- return pdb;
- SETERRNO(0,SS_NORMAL);
- return "BEGIN { require 'perl5db.pl' }";
- }
- return "";
-}
-
-
/* Encoded script support. filter_add() effectively inserts a
* 'pre-processing' function into the current source input stream.
* Note that the filter function only applies to the current source file
if (!funcp)
return NULL;
+ if (!PL_parser)
+ return NULL;
+
if (!PL_rsfp_filters)
PL_rsfp_filters = newAV();
if (!datasv)
IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
IoFLAGS(datasv) |= IOf_FAKE_DIRP;
DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
- IoANY(datasv), SvPV_nolen(datasv)));
+ FPTR2DPTR(void *, IoANY(datasv)),
+ SvPV_nolen(datasv)));
av_unshift(PL_rsfp_filters, 1);
av_store(PL_rsfp_filters, 0, datasv) ;
return(datasv);
dVAR;
SV *datasv;
+ PERL_ARGS_ASSERT_FILTER_DEL;
+
#ifdef DEBUGGING
- DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", FPTR2DPTR(XPVIO *, funcp)));
+ 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));
dVAR;
filter_t funcp;
SV *datasv = NULL;
+ /* This API is bad. It should have been using unsigned int for maxlen.
+ Not sure if we want to change the API, but if not we should sanity
+ check the value here. */
+ const unsigned int correct_length
+ = maxlen < 0 ?
+#ifdef PERL_MICRO
+ 0x7FFFFFFF
+#else
+ INT_MAX
+#endif
+ : maxlen;
- if (!PL_rsfp_filters)
+ PERL_ARGS_ASSERT_FILTER_READ;
+
+ 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. */
/* Note that we append to the line. This is handy. */
DEBUG_P(PerlIO_printf(Perl_debug_log,
"filter_read %d: from rsfp\n", idx));
- if (maxlen) {
+ if (correct_length) {
/* Want a block */
int len ;
const int old_len = SvCUR(buf_sv);
/* ensure buf_sv is large enough */
- SvGROW(buf_sv, (STRLEN)(old_len + maxlen)) ;
- if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
+ SvGROW(buf_sv, (STRLEN)(old_len + correct_length)) ;
+ if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
+ correct_length)) <= 0) {
if (PerlIO_error(PL_rsfp))
return -1; /* error */
else
DEBUG_P(PerlIO_printf(Perl_debug_log,
"filter_read %d: skipped (filter deleted)\n",
idx));
- return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
+ return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
}
/* Get function pointer hidden within datasv */
funcp = DPTR2FPTR(filter_t, IoANY(datasv));
DEBUG_P(PerlIO_printf(Perl_debug_log,
"filter_read %d: via function %p (%s)\n",
- idx, datasv, SvPV_nolen_const(datasv)));
+ idx, (void*)datasv, SvPV_nolen_const(datasv)));
/* Call function. The function is expected to */
/* call "FILTER_READ(idx+1, buf_sv)" first. */
/* Return: <0:error, =0:eof, >0:not eof */
- return (*funcp)(aTHX_ idx, buf_sv, maxlen);
+ return (*funcp)(aTHX_ idx, buf_sv, correct_length);
}
STATIC char *
S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
{
dVAR;
+
+ PERL_ARGS_ASSERT_FILTER_GETS;
+
#ifdef PERL_CR_FILTER
if (!PL_rsfp_filters) {
filter_add(S_cr_textfilter,NULL);
}
STATIC HV *
-S_find_in_my_stash(pTHX_ const char *pkgname, I32 len)
+S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
{
dVAR;
GV *gv;
+ PERL_ARGS_ASSERT_FIND_IN_MY_STASH;
+
if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
return PL_curstash;
}
/* use constant CLASS => 'MyClass' */
- if ((gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVCV))) {
- SV *sv;
- if (GvCV(gv) && (sv = cv_const_sv(GvCV(gv)))) {
- pkgname = SvPV_nolen_const(sv);
- }
+ gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVCV);
+ if (gv && GvCV(gv)) {
+ SV * const sv = cv_const_sv(GvCV(gv));
+ if (sv)
+ pkgname = SvPV_const(sv, len);
+ }
+
+ return gv_stashpvn(pkgname, len, 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);
+ pl_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))));
+ }
+}
+
+#ifdef PERL_MAD
+ /*
+ * Perl_madlex
+ * The intent of this yylex wrapper is to minimize the changes to the
+ * tokener when we aren't interested in collecting madprops. It remains
+ * to be seen how successful this strategy will be...
+ */
+
+int
+Perl_madlex(pTHX)
+{
+ int optype;
+ char *s = PL_bufptr;
+
+ /* make sure PL_thiswhite is initialized */
+ PL_thiswhite = 0;
+ PL_thismad = 0;
+
+ /* just do what yylex would do on pending identifier; leave PL_thiswhite alone */
+ if (PL_pending_ident)
+ return S_pending_ident(aTHX);
+
+ /* previous token ate up our whitespace? */
+ if (!PL_lasttoke && PL_nextwhite) {
+ PL_thiswhite = PL_nextwhite;
+ PL_nextwhite = 0;
+ }
+
+ /* isolate the token, and figure out where it is without whitespace */
+ PL_realtokenstart = -1;
+ PL_thistoken = 0;
+ optype = yylex();
+ s = PL_bufptr;
+ assert(PL_curforce < 0);
+
+ if (!PL_thismad || PL_thismad->mad_key == '^') { /* not forced already? */
+ if (!PL_thistoken) {
+ if (PL_realtokenstart < 0 || !CopLINE(PL_curcop))
+ PL_thistoken = newSVpvs("");
+ else {
+ char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
+ PL_thistoken = newSVpvn(tstart, s - tstart);
+ }
+ }
+ if (PL_thismad) /* install head */
+ CURMAD('X', PL_thistoken);
+ }
+
+ /* last whitespace of a sublex? */
+ if (optype == ')' && PL_endwhite) {
+ CURMAD('X', PL_endwhite);
+ }
+
+ if (!PL_thismad) {
+
+ /* if no whitespace and we're at EOF, bail. Otherwise fake EOF below. */
+ if (!PL_thiswhite && !PL_endwhite && !optype) {
+ sv_free(PL_thistoken);
+ PL_thistoken = 0;
+ return 0;
+ }
+
+ /* put off final whitespace till peg */
+ if (optype == ';' && !PL_rsfp) {
+ PL_nextwhite = PL_thiswhite;
+ PL_thiswhite = 0;
+ }
+ else if (PL_thisopen) {
+ CURMAD('q', PL_thisopen);
+ if (PL_thistoken)
+ sv_free(PL_thistoken);
+ PL_thistoken = 0;
+ }
+ else {
+ /* Store actual token text as madprop X */
+ CURMAD('X', PL_thistoken);
+ }
+
+ if (PL_thiswhite) {
+ /* add preceding whitespace as madprop _ */
+ CURMAD('_', PL_thiswhite);
+ }
+
+ if (PL_thisstuff) {
+ /* add quoted material as madprop = */
+ CURMAD('=', PL_thisstuff);
+ }
+
+ if (PL_thisclose) {
+ /* add terminating quote as madprop Q */
+ CURMAD('Q', PL_thisclose);
+ }
+ }
+
+ /* special processing based on optype */
+
+ switch (optype) {
+
+ /* opval doesn't need a TOKEN since it can already store mp */
+ case WORD:
+ case METHOD:
+ case FUNCMETH:
+ case THING:
+ case PMFUNC:
+ case PRIVATEREF:
+ case FUNC0SUB:
+ case UNIOPSUB:
+ case LSTOPSUB:
+ if (pl_yylval.opval)
+ append_madprops(PL_thismad, pl_yylval.opval, 0);
+ PL_thismad = 0;
+ return optype;
+
+ /* fake EOF */
+ case 0:
+ optype = PEG;
+ if (PL_endwhite) {
+ addmad(newMADsv('p', PL_endwhite), &PL_thismad, 0);
+ PL_endwhite = 0;
+ }
+ break;
+
+ case ']':
+ case '}':
+ if (PL_faketokens)
+ break;
+ /* remember any fake bracket that lexer is about to discard */
+ if (PL_lex_brackets == 1 &&
+ ((expectation)PL_lex_brackstack[0] & XFAKEBRACK))
+ {
+ s = PL_bufptr;
+ while (s < PL_bufend && (*s == ' ' || *s == '\t'))
+ s++;
+ if (*s == '}') {
+ PL_thiswhite = newSVpvn(PL_bufptr, ++s - PL_bufptr);
+ addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
+ PL_thiswhite = 0;
+ PL_bufptr = s - 1;
+ break; /* don't bother looking for trailing comment */
+ }
+ else
+ s = PL_bufptr;
+ }
+ if (optype == ']')
+ break;
+ /* FALLTHROUGH */
+
+ /* attach a trailing comment to its statement instead of next token */
+ case ';':
+ if (PL_faketokens)
+ break;
+ if (PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == optype) {
+ s = PL_bufptr;
+ while (s < PL_bufend && (*s == ' ' || *s == '\t'))
+ s++;
+ if (*s == '\n' || *s == '#') {
+ while (s < PL_bufend && *s != '\n')
+ s++;
+ if (s < PL_bufend)
+ s++;
+ PL_thiswhite = newSVpvn(PL_bufptr, s - PL_bufptr);
+ addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
+ PL_thiswhite = 0;
+ PL_bufptr = s;
+ }
+ }
+ break;
+
+ /* pval */
+ case LABEL:
+ break;
+
+ /* ival */
+ default:
+ break;
+
}
- return gv_stashpv(pkgname, FALSE);
+ /* Create new token struct. Note: opvals return early above. */
+ pl_yylval.tkval = newTOKEN(optype, pl_yylval, PL_thismad);
+ PL_thismad = 0;
+ return optype;
}
+#endif
STATIC char *
S_tokenize_use(pTHX_ int is_use, char *s) {
dVAR;
+
+ PERL_ARGS_ASSERT_TOKENIZE_USE;
+
if (PL_expect != XSTATE)
yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
is_use ? "use" : "no"));
- s = skipspace(s);
+ s = SKIPSPACE1(s);
if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
s = force_version(s, TRUE);
- if (*s == ';' || (s = skipspace(s), *s == ';')) {
- PL_nextval[PL_nexttoke].opval = NULL;
+ if (*s == ';' || (s = SKIPSPACE1(s), *s == ';')) {
+ start_force(PL_curforce);
+ NEXTVAL_NEXTTOKE.opval = NULL;
force_next(WORD);
}
else if (*s == 'v') {
s = force_word(s,WORD,FALSE,TRUE,FALSE);
s = force_version(s, FALSE);
}
- yylval.ival = is_use;
+ pl_yylval.ival = is_use;
return s;
}
#ifdef DEBUGGING
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",
/* when we've already built the next token, just pull it out of the queue */
case LEX_KNOWNEXT:
+#ifdef PERL_MAD
+ PL_lasttoke--;
+ pl_yylval = PL_nexttoke[PL_lasttoke].next_val;
+ if (PL_madskills) {
+ PL_thismad = PL_nexttoke[PL_lasttoke].next_mad;
+ PL_nexttoke[PL_lasttoke].next_mad = 0;
+ if (PL_thismad && PL_thismad->mad_key == '_') {
+ PL_thiswhite = MUTABLE_SV(PL_thismad->mad_val);
+ PL_thismad->mad_val = 0;
+ mad_free(PL_thismad);
+ PL_thismad = 0;
+ }
+ }
+ if (!PL_lasttoke) {
+ PL_lex_state = PL_lex_defer;
+ PL_expect = PL_lex_expect;
+ PL_lex_defer = LEX_NORMAL;
+ if (!PL_nexttoke[PL_lasttoke].next_type)
+ return yylex();
+ }
+#else
PL_nexttoke--;
- yylval = PL_nextval[PL_nexttoke];
+ pl_yylval = PL_nextval[PL_nexttoke];
if (!PL_nexttoke) {
PL_lex_state = PL_lex_defer;
PL_expect = PL_lex_expect;
PL_lex_defer = LEX_NORMAL;
}
+#endif
+#ifdef PERL_MAD
+ /* FIXME - can these be merged? */
+ return(PL_nexttoke[PL_lasttoke].next_type);
+#else
return REPORT(PL_nexttype[PL_nexttoke]);
+#endif
/* interpolated case modifiers like \L \U, including \Q and \E.
when we get here, PL_bufptr is at the \
&& (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q')) {
PL_bufptr += 2;
PL_lex_state = LEX_INTERPCONCAT;
+#ifdef PERL_MAD
+ if (PL_madskills)
+ PL_thistoken = newSVpvs("\\E");
+#endif
}
return REPORT(')');
}
+#ifdef PERL_MAD
+ while (PL_bufptr != PL_bufend &&
+ PL_bufptr[0] == '\\' && PL_bufptr[1] == 'E') {
+ if (!PL_thiswhite)
+ PL_thiswhite = newSVpvs("");
+ sv_catpvn(PL_thiswhite, PL_bufptr, 2);
+ PL_bufptr += 2;
+ }
+#else
if (PL_bufptr != PL_bufend)
PL_bufptr += 2;
+#endif
PL_lex_state = LEX_INTERPCONCAT;
return yylex();
}
"### Saw case modifier\n"); });
s = PL_bufptr + 1;
if (s[1] == '\\' && s[2] == 'E') {
+#ifdef PERL_MAD
+ if (!PL_thiswhite)
+ PL_thiswhite = newSVpvs("");
+ sv_catpvn(PL_thiswhite, PL_bufptr, 4);
+#endif
PL_bufptr = s + 3;
PL_lex_state = LEX_INTERPCONCAT;
return yylex();
}
else {
I32 tmp;
- if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
- tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
+ if (!PL_madskills) /* when just compiling don't need correct */
+ if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
+ tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
if ((*s == 'L' || *s == 'U') &&
(strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) {
PL_lex_casestack[--PL_lex_casemods] = '\0';
PL_lex_casestack[PL_lex_casemods++] = *s;
PL_lex_casestack[PL_lex_casemods] = '\0';
PL_lex_state = LEX_INTERPCONCAT;
- PL_nextval[PL_nexttoke].ival = 0;
+ start_force(PL_curforce);
+ NEXTVAL_NEXTTOKE.ival = 0;
force_next('(');
+ start_force(PL_curforce);
if (*s == 'l')
- PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
+ NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
else if (*s == 'u')
- PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
+ NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
else if (*s == 'L')
- PL_nextval[PL_nexttoke].ival = OP_LC;
+ NEXTVAL_NEXTTOKE.ival = OP_LC;
else if (*s == 'U')
- PL_nextval[PL_nexttoke].ival = OP_UC;
+ NEXTVAL_NEXTTOKE.ival = OP_UC;
else if (*s == 'Q')
- PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
+ NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
else
Perl_croak(aTHX_ "panic: yylex");
+ if (PL_madskills) {
+ SV* const tmpsv = newSVpvs("\\ ");
+ /* replace the space with the character we want to escape
+ */
+ SvPVX(tmpsv)[1] = *s;
+ curmad('_', tmpsv);
+ }
PL_bufptr = s + 1;
}
force_next(FUNC);
if (PL_lex_starts) {
s = PL_bufptr;
PL_lex_starts = 0;
+#ifdef PERL_MAD
+ if (PL_madskills) {
+ if (PL_thistoken)
+ sv_free(PL_thistoken);
+ PL_thistoken = newSVpvs("");
+ }
+#endif
/* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
if (PL_lex_casemods == 1 && PL_lex_inpat)
OPERATOR(',');
PL_lex_dojoin = (*PL_bufptr == '@');
PL_lex_state = LEX_INTERPNORMAL;
if (PL_lex_dojoin) {
- PL_nextval[PL_nexttoke].ival = 0;
+ start_force(PL_curforce);
+ NEXTVAL_NEXTTOKE.ival = 0;
force_next(',');
+ start_force(PL_curforce);
force_ident("\"", '$');
- PL_nextval[PL_nexttoke].ival = 0;
+ start_force(PL_curforce);
+ NEXTVAL_NEXTTOKE.ival = 0;
force_next('$');
- PL_nextval[PL_nexttoke].ival = 0;
+ start_force(PL_curforce);
+ NEXTVAL_NEXTTOKE.ival = 0;
force_next('(');
- PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
+ start_force(PL_curforce);
+ NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
force_next(FUNC);
}
if (PL_lex_starts++) {
s = PL_bufptr;
+#ifdef PERL_MAD
+ if (PL_madskills) {
+ if (PL_thistoken)
+ sv_free(PL_thistoken);
+ PL_thistoken = newSVpvs("");
+ }
+#endif
/* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
if (!PL_lex_casemods && PL_lex_inpat)
OPERATOR(',');
if (PL_lex_dojoin) {
PL_lex_dojoin = FALSE;
PL_lex_state = LEX_INTERPCONCAT;
+#ifdef PERL_MAD
+ if (PL_madskills) {
+ if (PL_thistoken)
+ sv_free(PL_thistoken);
+ PL_thistoken = newSVpvs("");
+ }
+#endif
return REPORT(')');
}
if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
if (!PL_lex_inpat)
sv = tokeq(sv);
else if ( PL_hints & HINT_NEW_RE )
- sv = new_constant(NULL, 0, "qr", sv, sv, "q");
- yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
+ sv = new_constant(NULL, 0, "qr", sv, sv, "q", 1);
+ pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
s = PL_bufend;
}
else {
}
if (s != PL_bufptr) {
- PL_nextval[PL_nexttoke] = yylval;
+ start_force(PL_curforce);
+ if (PL_madskills) {
+ curmad('X', newSVpvn(PL_bufptr,s-PL_bufptr));
+ }
+ NEXTVAL_NEXTTOKE = pl_yylval;
PL_expect = XTERM;
force_next(THING);
if (PL_lex_starts++) {
+#ifdef PERL_MAD
+ if (PL_madskills) {
+ if (PL_thistoken)
+ sv_free(PL_thistoken);
+ PL_thistoken = newSVpvs("");
+ }
+#endif
/* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
if (!PL_lex_casemods && PL_lex_inpat)
OPERATOR(',');
PL_oldbufptr = s;
retry:
+#ifdef PERL_MAD
+ if (PL_thistoken) {
+ sv_free(PL_thistoken);
+ PL_thistoken = 0;
+ }
+ PL_realtokenstart = s - SvPVX(PL_linestr); /* assume but undo on ws */
+#endif
switch (*s) {
default:
if (isIDFIRST_lazy_if(s,UTF))
goto keylookup;
- Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
+ len = UTF ? Perl_utf8_length(aTHX_ (U8 *) PL_linestart, (U8 *) s) : (STRLEN) (s - PL_linestart);
+ Perl_croak(aTHX_ "Unrecognized character \\x%02X in column %d", *s & 255, (int) len + 1);
case 4:
case 26:
goto fake_eof; /* emulate EOF on ^D or ^Z */
case 0:
+#ifdef PERL_MAD
+ if (PL_madskills)
+ PL_faketokens = 0;
+#endif
if (!PL_rsfp) {
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_last_lop = 0;
if (!PL_in_eval && !PL_preambled) {
PL_preambled = TRUE;
- sv_setpv(PL_linestr,incl_perldb());
- if (SvCUR(PL_linestr))
- sv_catpvs(PL_linestr,";");
- if (PL_preambleav){
- while(AvFILLp(PL_preambleav) >= 0) {
- SV *tmpsv = av_shift(PL_preambleav);
- sv_catsv(PL_linestr, tmpsv);
+#ifdef PERL_MAD
+ if (PL_madskills)
+ PL_faketokens = 1;
+#endif
+ if (PL_perldb) {
+ /* Generate a string of Perl code to load the debugger.
+ * If PERL5DB is set, it will return the contents of that,
+ * otherwise a compile-time require of perl5db.pl. */
+
+ const char * const pdb = PerlEnv_getenv("PERL5DB");
+
+ if (pdb) {
+ sv_setpv(PL_linestr, pdb);
+ sv_catpvs(PL_linestr,";");
+ } else {
+ SETERRNO(0,SS_NORMAL);
+ sv_setpvs(PL_linestr, "BEGIN { require 'perl5db.pl' };");
+ }
+ } else
+ sv_setpvs(PL_linestr,"");
+ if (PL_preambleav) {
+ SV **svp = AvARRAY(PL_preambleav);
+ SV **const end = svp + AvFILLp(PL_preambleav);
+ while(svp <= end) {
+ sv_catsv(PL_linestr, *svp);
+ ++svp;
sv_catpvs(PL_linestr, ";");
- sv_free(tmpsv);
}
- sv_free((SV*)PL_preambleav);
+ sv_free(MUTABLE_SV(PL_preambleav));
PL_preambleav = NULL;
}
+ if (PL_minus_E)
+ sv_catpvs(PL_linestr,
+ "use feature ':5." STRINGIFY(PERL_VERSION) "';");
if (PL_minus_n || PL_minus_p) {
sv_catpvs(PL_linestr, "LINE: while (<>) {");
if (PL_minus_l)
sv_catpvs(PL_linestr,"our @F=split(' ');");
}
}
- if (PL_minus_E)
- sv_catpvs(PL_linestr,"use feature ':5.10';");
sv_catpvs(PL_linestr, "\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 || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
+ update_debugger_info(PL_linestr, NULL, 0);
goto retry;
}
do {
bof = PL_rsfp ? TRUE : FALSE;
if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == NULL) {
fake_eof:
+#ifdef PERL_MAD
+ PL_realtokenstart = -1;
+#endif
if (PL_rsfp) {
- if (PL_preprocess && !PL_in_eval)
- (void)PerlProc_pclose(PL_rsfp);
- else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
+ if ((PerlIO *)PL_rsfp == PerlIO_stdin())
PerlIO_clearerr(PL_rsfp);
else
(void)PerlIO_close(PL_rsfp);
PL_doextract = FALSE;
}
if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
- sv_setpv(PL_linestr,PL_minus_p
- ? ";}continue{print;}" : ";}");
+#ifdef PERL_MAD
+ if (PL_madskills)
+ PL_faketokens = 1;
+#endif
+ if (PL_minus_p)
+ sv_setpvs(PL_linestr, ";}continue{print;}");
+ else
+ sv_setpvs(PL_linestr, ";}");
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;
}
PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
PL_last_lop = PL_last_uni = NULL;
- sv_setpvn(PL_linestr,"",0);
+ sv_setpvs(PL_linestr,"");
TOKEN(';'); /* not infinite loop because rsfp is NULL now */
}
/* If it looks like the start of a BOM or raw UTF-16,
# endif
# endif
#endif
-#ifdef FTELL_FOR_PIPE_IS_BROKEN
- /* This loses the possibility to detect the bof
- * situation on perl -P when the libc5 is being used.
- * Workaround? Maybe attach some extra state to PL_rsfp?
- */
- if (!PL_preprocess)
- bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
-#else
bof = PerlIO_tell(PL_rsfp) == (Off_t)SvCUR(PL_linestr);
-#endif
if (bof) {
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
s = swallow_bom((U8*)s);
}
if (PL_doextract) {
/* Incest with pod. */
- if (*s == '=' && strnEQ(s, "=cut", 4)) {
- sv_setpvn(PL_linestr, "", 0);
+#ifdef PERL_MAD
+ if (PL_madskills)
+ sv_catsv(PL_thiswhite, PL_linestr);
+#endif
+ if (*s == '=' && strnEQ(s, "=cut", 4) && !isALPHA(s[4])) {
+ sv_setpvs(PL_linestr, "");
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;
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 || PERLDB_SAVESRC) && 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) {
s++;
if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
s++;
+#ifdef PERL_MAD
+ if (PL_madskills)
+ PL_thiswhite = newSVpvn(PL_linestart, s - PL_linestart);
+#endif
d = NULL;
if (!PL_in_eval) {
if (*s == '#' && *(s+1) == '!')
}
#endif
if (d) {
- while (*d && !isSPACE(*d)) d++;
- while (SPACE_OR_TAB(*d)) d++;
+ while (*d && !isSPACE(*d))
+ d++;
+ while (SPACE_OR_TAB(*d))
+ d++;
if (*d++ == '-') {
const bool switches_done = PL_doswitches;
const U32 oldpdb = PL_perldb;
const bool oldn = PL_minus_n;
const bool oldp = PL_minus_p;
+ const char *d1 = d;
do {
- if (*d == 'M' || *d == 'm' || *d == 'C') {
- const char * const m = d;
- while (*d && !isSPACE(*d)) d++;
+ if (*d1 == 'M' || *d1 == 'm' || *d1 == 'C') {
+ const char * const m = d1;
+ while (*d1 && !isSPACE(*d1))
+ d1++;
Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
- (int)(d - m), m);
+ (int)(d1 - m), m);
}
- d = moreswitches(d);
- } while (d);
+ d1 = moreswitches(d1);
+ } while (d1);
if (PL_doswitches && !switches_done) {
int argc = PL_origargc;
char **argv = PL_origargv;
} while (argc && argv[0][0] == '-' && argv[0][1]);
init_argv_symbols(argc,argv);
}
- if ((PERLDB_LINE && !oldpdb) ||
+ if (((PERLDB_LINE || PERLDB_SAVESRC) && !oldpdb) ||
((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
/* if we have already added "LINE: while (<>) {",
we must not do it again */
{
- sv_setpvn(PL_linestr, "", 0);
+ sv_setpvs(PL_linestr, "");
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;
PL_preambled = FALSE;
- if (PERLDB_LINE)
+ if (PERLDB_LINE || PERLDB_SAVESRC)
(void)gv_fetchfile(PL_origfilename);
goto retry;
}
#ifdef MACOS_TRADITIONAL
case '\312':
#endif
+#ifdef PERL_MAD
+ PL_realtokenstart = -1;
+ if (!PL_thiswhite)
+ PL_thiswhite = newSVpvs("");
+ sv_catpvn(PL_thiswhite, s, 1);
+#endif
s++;
goto retry;
case '#':
case '\n':
+#ifdef PERL_MAD
+ PL_realtokenstart = -1;
+ if (PL_madskills)
+ PL_faketokens = 0;
+#endif
if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
/* handle eval qq[#line 1 "foo"\n ...] */
CopLINE_dec(PL_curcop);
incline(s);
}
- d = PL_bufend;
- while (s < d && *s != '\n')
- s++;
- if (s < d)
- s++;
- else if (s > d) /* Found by Ilya: feed random input to Perl. */
- Perl_croak(aTHX_ "panic: input overflow");
- incline(s);
+ if (PL_madskills && !PL_lex_formbrack && !PL_in_eval) {
+ s = SKIPSPACE0(s);
+ if (!PL_in_eval || PL_rsfp)
+ incline(s);
+ }
+ else {
+ d = s;
+ while (d < PL_bufend && *d != '\n')
+ d++;
+ if (d < PL_bufend)
+ d++;
+ else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
+ Perl_croak(aTHX_ "panic: input overflow");
+#ifdef PERL_MAD
+ if (PL_madskills)
+ PL_thiswhite = newSVpvn(s, d - s);
+#endif
+ s = d;
+ incline(s);
+ }
if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
PL_bufptr = s;
PL_lex_state = LEX_FORMLINE;
}
}
else {
+#ifdef PERL_MAD
+ if (PL_madskills && CopLINE(PL_curcop) >= 1 && !PL_lex_formbrack) {
+ if (CopLINE(PL_curcop) == 1 && s[0] == '#' && s[1] == '!') {
+ PL_faketokens = 0;
+ s = SKIPSPACE0(s);
+ TOKEN(PEG); /* make sure any #! line is accessible */
+ }
+ s = SKIPSPACE0(s);
+ }
+ else {
+/* if (PL_madskills && PL_lex_formbrack) { */
+ d = s;
+ while (d < PL_bufend && *d != '\n')
+ d++;
+ if (d < PL_bufend)
+ d++;
+ else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
+ Perl_croak(aTHX_ "panic: input overflow");
+ if (PL_madskills && CopLINE(PL_curcop) >= 1) {
+ if (!PL_thiswhite)
+ PL_thiswhite = newSVpvs("");
+ if (CopLINE(PL_curcop) == 1) {
+ sv_setpvs(PL_thiswhite, "");
+ PL_faketokens = 0;
+ }
+ sv_catpvn(PL_thiswhite, s, d - s);
+ }
+ s = d;
+/* }
+ *s = '\0';
+ PL_bufend = s; */
+ }
+#else
*s = '\0';
PL_bufend = s;
+#endif
}
goto retry;
case '-':
if (strnEQ(s,"=>",2)) {
s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
- DEBUG_T( { S_printbuf(aTHX_
- "### Saw unary minus before =>, forcing word %s\n", s);
- } );
+ DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
OPERATOR('-'); /* unary minus */
}
PL_last_uni = PL_oldbufptr;
}
else if (*s == '>') {
s++;
- s = skipspace(s);
+ s = SKIPSPACE1(s);
if (isIDFIRST_lazy_if(s,UTF)) {
s = force_word(s,METHOD,FALSE,TRUE,FALSE);
TOKEN(ARROW);
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);
s++;
switch (PL_expect) {
OP *attrs;
+#ifdef PERL_MAD
+ I32 stuffstart;
+#endif
case XOPERATOR:
if (!PL_in_my || PL_lex_state != LEX_NORMAL)
break;
case XATTRTERM:
PL_expect = XTERMBLOCK;
grabattrs:
- s = skipspace(s);
+#ifdef PERL_MAD
+ stuffstart = s - SvPVX(PL_linestr) - 1;
+#endif
+ s = PEEKSPACE(s);
attrs = NULL;
while (isIDFIRST_lazy_if(s,UTF)) {
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:
case KEY_and:
- case KEY_err:
case KEY_for:
case KEY_unless:
case KEY_if:
break;
}
}
+ sv = newSVpvn(s, len);
if (*d == '(') {
d = scan_str(d,TRUE,TRUE);
if (!d) {
yyerror("Unterminated attribute parameter in attribute list");
if (attrs)
op_free(attrs);
+ sv_free(sv);
return REPORT(0); /* EOF indicator */
}
}
if (PL_lex_stuff) {
- SV *sv = newSVpvn(s, len);
sv_catsv(sv, PL_lex_stuff);
attrs = append_elem(OP_LIST, attrs,
newSVOP(OP_CONST, 0, sv));
PL_lex_stuff = NULL;
}
else {
- if (len == 6 && strnEQ(s, "unique", len)) {
- if (PL_in_my == KEY_our)
+ if (len == 6 && strnEQ(SvPVX(sv), "unique", len)) {
+ sv_free(sv);
+ if (PL_in_my == KEY_our) {
#ifdef USE_ITHREADS
- GvUNIQUE_on(cGVOPx_gv(yylval.opval));
+ GvUNIQUE_on(cGVOPx_gv(pl_yylval.opval));
#else
- /*EMPTY*/; /* skip to avoid loading attributes.pm */
+ /* skip to avoid loading attributes.pm */
#endif
+ deprecate(":unique");
+ }
else
Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
}
/* NOTE: any CV attrs applied here need to be part of
the CVf_BUILTIN_ATTRS define in cv.h! */
- else if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len))
+ else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "lvalue", len)) {
+ sv_free(sv);
CvLVALUE_on(PL_compcv);
- else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len))
+ }
+ else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "locked", len)) {
+ sv_free(sv);
CvLOCKED_on(PL_compcv);
- else if (!PL_in_my && len == 6 && strnEQ(s, "method", len))
+ }
+ else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "method", len)) {
+ sv_free(sv);
CvMETHOD_on(PL_compcv);
- else if (!PL_in_my && len == 9 && strnEQ(s, "assertion", len))
- 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
else
attrs = append_elem(OP_LIST, attrs,
newSVOP(OP_CONST, 0,
- newSVpvn(s, len)));
+ sv));
}
- s = skipspace(d);
+ s = PEEKSPACE(d);
if (*s == ':' && s[1] != ':')
- s = skipspace(s+1);
+ s = PEEKSPACE(s+1);
else if (s == d)
break; /* require real whitespace or :'s */
+ /* XXX losing whitespace on sequential attributes here */
}
{
const char tmp
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(':');
}
got_attrs:
if (attrs) {
- PL_nextval[PL_nexttoke].opval = attrs;
+ start_force(PL_curforce);
+ NEXTVAL_NEXTTOKE.opval = attrs;
+ CURMAD('_', PL_nextwhite);
force_next(THING);
}
+#ifdef PERL_MAD
+ if (PL_madskills) {
+ PL_thistoken = newSVpvn(SvPVX(PL_linestr) + stuffstart,
+ (s - SvPVX(PL_linestr)) - stuffstart);
+ }
+#endif
TOKEN(COLONATTR);
}
OPERATOR(':');
PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
else
PL_expect = XTERM;
- s = skipspace(s);
+ s = SKIPSPACE1(s);
TOKEN('(');
case ';':
CLINE;
case ')':
{
const char tmp = *s++;
- s = skipspace(s);
+ s = SKIPSPACE1(s);
if (*s == '{')
PREBLOCK(tmp);
TERM(tmp);
--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;
}
}
PL_lex_brackstack[PL_lex_brackets++] = XTERM;
else
PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
- s = skipspace(s);
+ s = SKIPSPACE1(s);
if (*s == '}') {
if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
PL_expect = XTERM;
}
break;
}
- yylval.ival = CopLINE(PL_curcop);
+ pl_yylval.ival = CopLINE(PL_curcop);
if (isSPACE(*s) || *s == '#')
PL_copline = NOLINE; /* invalidate current command line number */
TOKEN('{');
PL_expect &= XENUMMASK;
PL_lex_state = LEX_INTERPEND;
PL_bufptr = s;
+#if 0
+ if (PL_madskills) {
+ if (!PL_thiswhite)
+ PL_thiswhite = newSVpvs("");
+ sv_catpvs(PL_thiswhite,"}");
+ }
+#endif
return yylex(); /* ignore fake brackets */
}
if (*s == '-' && s[1] == '>')
PL_bufptr = s;
return yylex(); /* ignore fake brackets */
}
+ start_force(PL_curforce);
+ if (PL_madskills) {
+ curmad('X', newSVpvn(s-1,1));
+ CURMAD('_', PL_thiswhite);
+ }
force_next('}');
+#ifdef PERL_MAD
+ if (!PL_thistoken)
+ PL_thistoken = newSVpvs("");
+#endif
TOKEN(';');
case '&':
s++;
&& isIDFIRST_lazy_if(s,UTF))
{
CopLINE_dec(PL_curcop);
- Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
+ Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
CopLINE_inc(PL_curcop);
}
BAop(OP_BIT_AND);
}
else
PREREF('&');
- yylval.ival = (OPpENTERSUB_AMPER<<8);
+ pl_yylval.ival = (OPpENTERSUB_AMPER<<8);
TERM('&');
case '|':
}
goto retry;
}
+#ifdef PERL_MAD
+ if (PL_madskills) {
+ if (!PL_thiswhite)
+ PL_thiswhite = newSVpvs("");
+ sv_catpvn(PL_thiswhite, PL_linestart,
+ PL_bufend - PL_linestart);
+ }
+#endif
s = PL_bufend;
PL_doextract = TRUE;
goto retry;
}
}
if (PL_lex_brackets < PL_lex_formbrack) {
- const char *t;
+ const char *t = s;
#ifdef PERL_STRICT_CR
- for (t = s; SPACE_OR_TAB(*t); t++) ;
+ while (SPACE_OR_TAB(*t))
#else
- for (t = s; SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
+ while (SPACE_OR_TAB(*t) || *t == '\r')
#endif
+ t++;
if (*t == '\n' || *t == '#') {
s--;
PL_expect = XBLOCK;
goto leftbracket;
}
}
- yylval.ival = 0;
+ pl_yylval.ival = 0;
OPERATOR(ASSIGNOP);
case '!':
+ if (PL_expect == XSTATE && s[1] == '!' && s[2] == '!') {
+ s += 3;
+ LOP(OP_DIE,XTERM);
+ }
s++;
{
const char tmp = *s++;
const char tmp = *s++;
if (tmp == '>')
SHop(OP_RIGHT_SHIFT);
- if (tmp == '=')
+ else if (tmp == '=')
Rop(OP_GE);
}
s--;
/* This kludge not intended to be bulletproof. */
if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
- yylval.opval = newSVOP(OP_CONST, 0,
- newSViv(PL_compiling.cop_arybase));
- yylval.opval->op_private = OPpCONST_ARYBASE;
+ pl_yylval.opval = newSVOP(OP_CONST, 0,
+ newSViv(CopARYBASE_get(&PL_compiling)));
+ pl_yylval.opval->op_private = OPpCONST_ARYBASE;
TERM(THING);
}
{
const char tmp = *s;
if (PL_lex_state == LEX_NORMAL)
- s = skipspace(s);
+ s = SKIPSPACE1(s);
if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
&& intuit_more(s)) {
if (*s == '[') {
PL_tokenbuf[0] = '@';
if (ckWARN(WARN_SYNTAX)) {
- char *t;
- for(t = s + 1;
- isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$';
- t++) ;
+ char *t = s+1;
+
+ while (isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$')
+ t++;
if (*t++ == ',') {
- PL_bufptr = skipspace(PL_bufptr);
+ PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
while (t < PL_bufend && *t != ']')
t++;
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
&& (t = strchr(s, '}')) && (t = strchr(t, '=')))
{
char tmpbuf[sizeof PL_tokenbuf];
- for (t++; isSPACE(*t); t++) ;
+ do {
+ t++;
+ } while (isSPACE(*t));
if (isIDFIRST_lazy_if(t,UTF)) {
- STRLEN dummylen;
+ STRLEN len;
t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
- &dummylen);
- for (; isSPACE(*t); t++) ;
- if (*t == ';' && get_cv(tmpbuf, FALSE))
+ &len);
+ while (isSPACE(*t))
+ t++;
+ 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:
PREREF('@');
}
if (PL_lex_state == LEX_NORMAL)
- s = skipspace(s);
+ s = SKIPSPACE1(s);
if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
if (*s == '{')
PL_tokenbuf[0] = '%';
t++;
if (*t == '}' || *t == ']') {
t++;
- PL_bufptr = skipspace(PL_bufptr);
+ PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"Scalar value %.*s better written as $%.*s",
(int)(t-PL_bufptr), PL_bufptr,
AOPERATOR(DORDOR);
}
case '?': /* may either be conditional or pattern */
- if(PL_expect == XOPERATOR) {
+ if (PL_expect == XSTATE && s[1] == '?' && s[2] == '?') {
+ s += 3;
+ LOP(OP_WARN,XTERM);
+ }
+ if (PL_expect == XOPERATOR) {
char tmp = *s++;
if(tmp == '?') {
- OPERATOR('?');
+ OPERATOR('?');
}
else {
tmp = *s++;
PL_expect = XSTATE;
goto rightbracket;
}
+ if (PL_expect == XSTATE && s[1] == '.' && s[2] == '.') {
+ s += 3;
+ OPERATOR(YADAYADA);
+ }
if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
char tmp = *s++;
if (*s == tmp) {
s++;
if (*s == tmp) {
s++;
- yylval.ival = OPf_SPECIAL;
+ pl_yylval.ival = OPf_SPECIAL;
}
else
- yylval.ival = 0;
+ pl_yylval.ival = 0;
OPERATOR(DOTDOT);
}
if (PL_expect != XOPERATOR)
/* FALL THROUGH */
case '0': case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9':
- s = scan_num(s, &yylval);
- DEBUG_T( { S_printbuf(aTHX_ "### Saw number in %s\n", s); } );
+ s = scan_num(s, &pl_yylval);
+ DEBUG_T( { printbuf("### Saw number in %s\n", s); } );
if (PL_expect == XOPERATOR)
no_op("Number",s);
TERM(THING);
case '\'':
- s = scan_str(s,FALSE,FALSE);
- DEBUG_T( { S_printbuf(aTHX_ "### Saw string before %s\n", s); } );
+ s = scan_str(s,!!PL_madskills,FALSE);
+ DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
if (PL_expect == XOPERATOR) {
if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
PL_expect = XTERM;
no_op("String",s);
}
if (!s)
- missingterm((char*)0);
- yylval.ival = OP_CONST;
+ missingterm(NULL);
+ pl_yylval.ival = OP_CONST;
TERM(sublex_start());
case '"':
- s = scan_str(s,FALSE,FALSE);
- DEBUG_T( { S_printbuf(aTHX_ "### Saw string before %s\n", s); } );
+ s = scan_str(s,!!PL_madskills,FALSE);
+ DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
if (PL_expect == XOPERATOR) {
if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
PL_expect = XTERM;
no_op("String",s);
}
if (!s)
- missingterm((char*)0);
- yylval.ival = OP_CONST;
+ missingterm(NULL);
+ pl_yylval.ival = OP_CONST;
/* FIXME. I think that this can be const if char *d is replaced by
more localised variables. */
for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
- yylval.ival = OP_STRINGIFY;
+ pl_yylval.ival = OP_STRINGIFY;
break;
}
}
TERM(sublex_start());
case '`':
- s = scan_str(s,FALSE,FALSE);
- DEBUG_T( { S_printbuf(aTHX_ "### Saw backtick string before %s\n", s); } );
+ s = scan_str(s,!!PL_madskills,FALSE);
+ DEBUG_T( { printbuf("### Saw backtick string before %s\n", s); } );
if (PL_expect == XOPERATOR)
no_op("Backticks",s);
if (!s)
- missingterm((char*)0);
- yylval.ival = OP_BACKTICK;
- set_csh();
+ missingterm(NULL);
+ readpipe_override();
TERM(sublex_start());
case '\\':
while (isDIGIT(*start) || *start == '_')
start++;
if (*start == '.' && isDIGIT(start[1])) {
- s = scan_num(s, &yylval);
+ s = scan_num(s, &pl_yylval);
TERM(THING);
}
/* avoid v123abc() or $h{v1}, allow C<print v10;> */
else if (!isALPHA(*start) && (PL_expect == XTERM
|| PL_expect == XREF || PL_expect == XSTATE
|| PL_expect == XTERMORDORDOR)) {
- const char c = *start;
- GV *gv;
- *start = '\0';
- gv = gv_fetchpv(s, 0, SVt_PVCV);
- *start = c;
+ GV *const gv = gv_fetchpvn_flags(s, start - s, 0, SVt_PVCV);
if (!gv) {
- s = scan_num(s, &yylval);
+ s = scan_num(s, &pl_yylval);
TERM(THING);
}
}
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);
+ pl_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] == '>') {
CLINE;
- yylval.opval
+ pl_yylval.opval
= (OP*)newSVOP(OP_CONST, 0,
S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
- yylval.opval->op_private = OPpCONST_BARE;
+ pl_yylval.opval->op_private = OPpCONST_BARE;
TERM(WORD);
}
}
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 */
}
int pkgname = 0;
const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
CV *cv;
+#ifdef PERL_MAD
+ SV *nextPL_nextwhite = 0;
+#endif
+
/* Get the rest if it looks like a package qualifier */
if (PL_expect == XOPERATOR) {
if (PL_bufptr == PL_linestart) {
CopLINE_dec(PL_curcop);
- Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
+ Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
CopLINE_inc(PL_curcop);
}
else
unless name is "Foo::", in which case Foo is a bearword
(and a package name). */
- if (len > 2 &&
+ if (len > 2 && !PL_madskills &&
PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
{
if (ckWARN(WARN_BAREWORD)
and so the scalar will be created correctly. */
sv = newSVpv(PL_tokenbuf,len);
}
+#ifdef PERL_MAD
+ if (PL_madskills && !PL_thistoken) {
+ char *start = SvPVX(PL_linestr) + PL_realtokenstart;
+ PL_thistoken = newSVpvn(start,s - start);
+ PL_realtokenstart = s - SvPVX(PL_linestr);
+ }
+#endif
/* Presume this is going to be a bareword of some sort. */
CLINE;
- yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
- yylval.opval->op_private = OPpCONST_BARE;
+ pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
+ pl_yylval.opval->op_private = OPpCONST_BARE;
/* UTF-8 package name? */
if (UTF && !IN_BYTES &&
is_utf8_string((U8*)SvPVX_const(sv), SvCUR(sv)))
/* Real typeglob, so get the real subroutine: */
? GvCVu(gv)
/* A proxy for a subroutine in this package? */
- : SvOK(gv) ? (CV *) gv : NULL)
+ : SvOK(gv) ? MUTABLE_CV(gv) : NULL)
: NULL;
/* See if it's the indirect object for a list operator. */
bool immediate_paren = *s == '(';
/* (Now we can afford to cross potential line boundary.) */
- s = skipspace(s);
+ s = SKIPSPACE2(s,nextPL_nextwhite);
+#ifdef PERL_MAD
+ PL_nextwhite = nextPL_nextwhite; /* assume no & deception */
+#endif
/* Two barewords in a row may indicate method call. */
}
PL_expect = XOPERATOR;
+#ifdef PERL_MAD
+ if (isSPACE(*s))
+ s = SKIPSPACE2(s,nextPL_nextwhite);
+ PL_nextwhite = nextPL_nextwhite;
+#else
s = skipspace(s);
+#endif
/* Is this a word before a => operator? */
if (*s == '=' && s[1] == '>' && !pkgname) {
CLINE;
- sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
+ sv_setpv(((SVOP*)pl_yylval.opval)->op_sv, PL_tokenbuf);
if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
- SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
+ SvUTF8_on(((SVOP*)pl_yylval.opval)->op_sv);
TERM(WORD);
}
if (*s == '(') {
CLINE;
if (cv) {
- for (d = s + 1; SPACE_OR_TAB(*d); d++) ;
+ d = s + 1;
+ while (SPACE_OR_TAB(*d))
+ d++;
if (*d == ')' && (sv = gv_const_sv(gv))) {
s = d + 1;
goto its_constant;
}
}
- PL_nextval[PL_nexttoke].opval = yylval.opval;
+#ifdef PERL_MAD
+ if (PL_madskills) {
+ PL_nextwhite = PL_thiswhite;
+ PL_thiswhite = 0;
+ }
+ start_force(PL_curforce);
+#endif
+ NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
PL_expect = XOPERATOR;
+#ifdef PERL_MAD
+ if (PL_madskills) {
+ PL_nextwhite = nextPL_nextwhite;
+ curmad('X', PL_thistoken);
+ PL_thistoken = newSVpvs("");
+ }
+#endif
force_next(WORD);
- yylval.ival = 0;
+ pl_yylval.ival = 0;
TOKEN('&');
}
/* Check for a constant sub */
if ((sv = gv_const_sv(gv))) {
its_constant:
- SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
- ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
- yylval.opval->op_private = 0;
+ SvREFCNT_dec(((SVOP*)pl_yylval.opval)->op_sv);
+ ((SVOP*)pl_yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
+ pl_yylval.opval->op_private = 0;
TOKEN(WORD);
}
cv = GvCV(gv);
}
- op_free(yylval.opval);
- yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
- yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
+ op_free(pl_yylval.opval);
+ pl_yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
+ pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
PL_last_lop = PL_oldbufptr;
PL_last_lop_op = OP_ENTERSUB;
/* Is there a prototype? */
- if (SvPOK(cv)) {
+ if (
+#ifdef PERL_MAD
+ cv &&
+#endif
+ SvPOK(cv))
+ {
STRLEN protolen;
- const char *proto = SvPV_const((SV*)cv, protolen);
+ const char *proto = SvPV_const(MUTABLE_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__");
+ if (PL_curstash)
+ sv_setpvs(PL_subname, "__ANON__");
+ else
+ sv_setpvs(PL_subname, "__ANON__::__ANON__");
PREBLOCK(LSTOPSUB);
}
}
- PL_nextval[PL_nexttoke].opval = yylval.opval;
+#ifdef PERL_MAD
+ {
+ if (PL_madskills) {
+ PL_nextwhite = PL_thiswhite;
+ PL_thiswhite = 0;
+ }
+ start_force(PL_curforce);
+ NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
+ PL_expect = XTERM;
+ if (PL_madskills) {
+ PL_nextwhite = nextPL_nextwhite;
+ curmad('X', PL_thistoken);
+ PL_thistoken = newSVpvs("");
+ }
+ force_next(WORD);
+ TOKEN(NOAMP);
+ }
+ }
+
+ /* Guess harder when madskills require "best effort". */
+ if (PL_madskills && (!gv || !GvCVu(gv))) {
+ int probable_sub = 0;
+ if (strchr("\"'`$@%0123456789!*+{[<", *s))
+ probable_sub = 1;
+ else if (isALPHA(*s)) {
+ char tmpbuf[1024];
+ STRLEN tmplen;
+ d = s;
+ d = scan_word(d, tmpbuf, sizeof tmpbuf, TRUE, &tmplen);
+ if (!keyword(tmpbuf, tmplen, 0))
+ probable_sub = 1;
+ else {
+ while (d < PL_bufend && isSPACE(*d))
+ d++;
+ if (*d == '=' && d[1] == '>')
+ probable_sub = 1;
+ }
+ }
+ if (probable_sub) {
+ gv = gv_fetchpv(PL_tokenbuf, GV_ADD, SVt_PVCV);
+ op_free(pl_yylval.opval);
+ pl_yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
+ pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
+ PL_last_lop = PL_oldbufptr;
+ PL_last_lop_op = OP_ENTERSUB;
+ PL_nextwhite = PL_thiswhite;
+ PL_thiswhite = 0;
+ start_force(PL_curforce);
+ NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
+ PL_expect = XTERM;
+ PL_nextwhite = nextPL_nextwhite;
+ curmad('X', PL_thistoken);
+ PL_thistoken = newSVpvs("");
+ force_next(WORD);
+ TOKEN(NOAMP);
+ }
+#else
+ NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
PL_expect = XTERM;
force_next(WORD);
TOKEN(NOAMP);
+#endif
}
/* Call it a bare word */
+ bareword:
if (PL_hints & HINT_STRICT_SUBS)
- yylval.opval->op_private |= OPpCONST_STRICT;
+ pl_yylval.opval->op_private |= OPpCONST_STRICT;
else {
- bareword:
if (lastchar != '-') {
if (ckWARN(WARN_RESERVED)) {
- for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
- if (!*d && !gv_stashpv(PL_tokenbuf,FALSE))
+ d = PL_tokenbuf;
+ while (isLOWER(*d))
+ d++;
+ if (!*d && !gv_stashpv(PL_tokenbuf, 0))
Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
PL_tokenbuf);
}
}
case KEY___FILE__:
- yylval.opval = (OP*)newSVOP(OP_CONST, 0,
+ pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0,
newSVpv(CopFILE(PL_curcop),0));
TERM(THING);
case KEY___LINE__:
- yylval.opval = (OP*)newSVOP(OP_CONST, 0,
+ pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0,
Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
TERM(THING);
case KEY___PACKAGE__:
- yylval.opval = (OP*)newSVOP(OP_CONST, 0,
+ pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0,
(PL_curstash
? newSVhek(HvNAME_HEK(PL_curstash))
: &PL_sv_undef));
#endif
/* Mark this internal pseudo-handle as clean */
IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
- if (PL_preprocess)
- IoTYPE(GvIOp(gv)) = IoTYPE_PIPE;
- else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
+ if ((PerlIO*)PL_rsfp == PerlIO_stdin())
IoTYPE(GvIOp(gv)) = IoTYPE_STD;
else
IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
PUTBACK;
PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
Perl_form(aTHX_ ":encoding(%"SVf")",
- name));
+ SVfARG(name)));
FREETMPS;
LEAVE;
}
}
#endif
+#ifdef PERL_MAD
+ if (PL_madskills) {
+ if (PL_realtokenstart >= 0) {
+ char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
+ if (!PL_endwhite)
+ PL_endwhite = newSVpvs("");
+ sv_catsv(PL_endwhite, PL_thiswhite);
+ PL_thiswhite = 0;
+ sv_catpvn(PL_endwhite, tstart, PL_bufend - tstart);
+ PL_realtokenstart = -1;
+ }
+ while ((s = filter_gets(PL_endwhite, PL_rsfp,
+ SvCUR(PL_endwhite))) != NULL) ;
+ }
+#endif
PL_rsfp = NULL;
}
goto fake_eof;
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;
PREBLOCK(DEFAULT);
case KEY_do:
- s = skipspace(s);
+ s = SKIPSPACE1(s);
if (*s == '{')
PRETERMBLOCK(DO);
if (*s != '\'')
s = force_word(s,WORD,TRUE,TRUE,FALSE);
if (orig_keyword == KEY_do) {
orig_keyword = 0;
- yylval.ival = 1;
+ pl_yylval.ival = 1;
}
else
- yylval.ival = 0;
+ pl_yylval.ival = 0;
OPERATOR(DO);
case KEY_die:
PREBLOCK(ELSE);
case KEY_elsif:
- yylval.ival = CopLINE(PL_curcop);
+ pl_yylval.ival = CopLINE(PL_curcop);
OPERATOR(ELSIF);
case KEY_eq:
UNI(OP_EXISTS);
case KEY_exit:
+ if (PL_madskills)
+ UNI(OP_INT);
UNI(OP_EXIT);
case KEY_eval:
- s = skipspace(s);
+ s = SKIPSPACE1(s);
PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
UNIBRACK(OP_ENTEREVAL);
case KEY_eof:
UNI(OP_EOF);
- case KEY_err:
- OPERATOR(DOROP);
-
case KEY_exp:
UNI(OP_EXP);
UNI(OP_EACH);
case KEY_exec:
- set_csh();
LOP(OP_EXEC,XREF);
case KEY_endhostent:
case KEY_for:
case KEY_foreach:
- yylval.ival = CopLINE(PL_curcop);
- s = skipspace(s);
+ pl_yylval.ival = CopLINE(PL_curcop);
+ s = SKIPSPACE1(s);
if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
char *p = s;
+#ifdef PERL_MAD
+ int soff = s - SvPVX(PL_linestr); /* for skipspace realloc */
+#endif
+
if ((PL_bufend - p) >= 3 &&
strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
p += 2;
else if ((PL_bufend - p) >= 4 &&
strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
p += 3;
- p = skipspace(p);
+ p = PEEKSPACE(p);
if (isIDFIRST_lazy_if(p,UTF)) {
p = scan_ident(p, PL_bufend,
PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
- p = skipspace(p);
+ p = PEEKSPACE(p);
}
if (*p != '$')
Perl_croak(aTHX_ "Missing $ on loop variable");
+#ifdef PERL_MAD
+ s = SvPVX(PL_linestr) + soff;
+#endif
}
OPERATOR(FOR);
FUN0(OP_GETLOGIN);
case KEY_given:
- yylval.ival = CopLINE(PL_curcop);
+ pl_yylval.ival = CopLINE(PL_curcop);
OPERATOR(GIVEN);
case KEY_glob:
- set_csh();
LOP(OP_GLOB,XTERM);
case KEY_hex:
UNI(OP_HEX);
case KEY_if:
- yylval.ival = CopLINE(PL_curcop);
+ pl_yylval.ival = CopLINE(PL_curcop);
OPERATOR(IF);
case KEY_index:
UNI(OP_LCFIRST);
case KEY_local:
- yylval.ival = 0;
+ pl_yylval.ival = 0;
OPERATOR(LOCAL);
case KEY_length:
case KEY_our:
case KEY_my:
- PL_in_my = tmp;
- s = skipspace(s);
+ case KEY_state:
+ PL_in_my = (U16)tmp;
+ s = SKIPSPACE1(s);
if (isIDFIRST_lazy_if(s,UTF)) {
+#ifdef PERL_MAD
+ char* start = s;
+#endif
s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
goto really_sub;
if (!PL_in_my_stash) {
char tmpbuf[1024];
PL_bufptr = s;
- sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
+ my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
yyerror(tmpbuf);
}
+#ifdef PERL_MAD
+ if (PL_madskills) { /* just add type to declarator token */
+ sv_catsv(PL_thistoken, PL_nextwhite);
+ PL_nextwhite = 0;
+ sv_catpvn(PL_thistoken, start, s - start);
+ }
+#endif
}
- yylval.ival = 1;
+ pl_yylval.ival = 1;
OPERATOR(MY);
case KEY_next:
OPERATOR(USE);
case KEY_not:
- if (*s == '(' || (s = skipspace(s), *s == '('))
+ if (*s == '(' || (s = SKIPSPACE1(s), *s == '('))
FUN1(OP_NOT);
else
OPERATOR(NOTOP);
case KEY_open:
- s = skipspace(s);
+ s = SKIPSPACE1(s);
if (isIDFIRST_lazy_if(s,UTF)) {
const char *t;
- for (d = s; isALNUM_lazy_if(d,UTF); d++) ;
- for (t=d; *t && isSPACE(*t); t++) ;
+ for (d = s; isALNUM_lazy_if(d,UTF);)
+ d++;
+ for (t=d; isSPACE(*t);)
+ t++;
if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
/* [perl #16184] */
&& !(t[0] == '=' && t[1] == '>')
LOP(OP_OPEN,XTERM);
case KEY_or:
- yylval.ival = OP_OR;
+ pl_yylval.ival = OP_OR;
OPERATOR(OROP);
case KEY_ord:
LOP(OP_PIPE_OP,XTERM);
case KEY_q:
- s = scan_str(s,FALSE,FALSE);
+ s = scan_str(s,!!PL_madskills,FALSE);
if (!s)
- missingterm((char*)0);
- yylval.ival = OP_CONST;
+ missingterm(NULL);
+ pl_yylval.ival = OP_CONST;
TERM(sublex_start());
case KEY_quotemeta:
UNI(OP_QUOTEMETA);
case KEY_qw:
- s = scan_str(s,FALSE,FALSE);
+ s = scan_str(s,!!PL_madskills,FALSE);
if (!s)
- missingterm((char*)0);
+ missingterm(NULL);
PL_expect = XOPERATOR;
force_next(')');
if (SvCUR(PL_lex_stuff)) {
int warned = 0;
d = SvPV_force(PL_lex_stuff, len);
while (len) {
- SV *sv;
- for (; isSPACE(*d) && len; --len, ++d) ;
+ for (; isSPACE(*d) && len; --len, ++d)
+ /**/;
if (len) {
+ SV *sv;
const char *b = d;
if (!warned && ckWARN(WARN_QW)) {
for (; !isSPACE(*d) && len; --len, ++d) {
}
}
else {
- for (; !isSPACE(*d) && len; --len, ++d) ;
+ for (; !isSPACE(*d) && len; --len, ++d)
+ /**/;
}
- sv = newSVpvn(b, d-b);
- if (DO_UTF8(PL_lex_stuff))
- SvUTF8_on(sv);
+ sv = newSVpvn_utf8(b, d-b, DO_UTF8(PL_lex_stuff));
words = append_elem(OP_LIST, words,
newSVOP(OP_CONST, 0, tokeq(sv)));
}
}
if (words) {
- PL_nextval[PL_nexttoke].opval = words;
+ start_force(PL_curforce);
+ NEXTVAL_NEXTTOKE.opval = words;
force_next(THING);
}
}
TOKEN('(');
case KEY_qq:
- s = scan_str(s,FALSE,FALSE);
+ s = scan_str(s,!!PL_madskills,FALSE);
if (!s)
- missingterm((char*)0);
- yylval.ival = OP_STRINGIFY;
+ missingterm(NULL);
+ pl_yylval.ival = OP_STRINGIFY;
if (SvIVX(PL_lex_stuff) == '\'')
SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should intepolate */
TERM(sublex_start());
TERM(sublex_start());
case KEY_qx:
- s = scan_str(s,FALSE,FALSE);
+ s = scan_str(s,!!PL_madskills,FALSE);
if (!s)
- missingterm((char*)0);
- yylval.ival = OP_BACKTICK;
- set_csh();
+ missingterm(NULL);
+ readpipe_override();
TERM(sublex_start());
case KEY_return:
OLDLOP(OP_RETURN);
case KEY_require:
- s = skipspace(s);
+ s = SKIPSPACE1(s);
if (isDIGIT(*s)) {
s = force_version(s, FALSE);
}
*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");
}
if (orig_keyword == KEY_require) {
orig_keyword = 0;
- yylval.ival = 1;
+ pl_yylval.ival = 1;
}
else
- yylval.ival = 0;
+ pl_yylval.ival = 0;
PL_expect = XTERM;
PL_bufptr = s;
PL_last_uni = PL_oldbufptr;
UNI(OP_READDIR);
case KEY_readline:
- set_csh();
UNIDOR(OP_READLINE);
case KEY_readpipe:
- set_csh();
- UNI(OP_BACKTICK);
+ UNIDOR(OP_BACKTICK);
case KEY_rewinddir:
UNI(OP_REWINDDIR);
case KEY_s:
s = scan_subst(s);
- if (yylval.opval)
+ if (pl_yylval.opval)
TERM(sublex_start());
else
TOKEN(1); /* force error */
case KEY_sort:
checkcomma(s,PL_tokenbuf,"subroutine name");
- s = skipspace(s);
+ s = SKIPSPACE1(s);
if (*s == ';' || *s == ')') /* probably a close */
Perl_croak(aTHX_ "sort is now a reserved word");
PL_expect = XTERM;
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
+ SV *tmpwhite = 0;
+
+ char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
+ SV *subtoken = newSVpvn(tstart, s - tstart);
+ PL_thistoken = 0;
+
+ d = s;
+ s = SKIPSPACE2(s,tmpwhite);
+#else
s = skipspace(s);
+#endif
if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
(*s == ':' && s[1] == ':'))
{
+#ifdef PERL_MAD
+ SV *nametoke = NULL;
+#endif
+
PL_expect = XBLOCK;
attrful = XATTRBLOCK;
/* remember buffer pos'n for later force_word */
tboffset = s - PL_oldbufptr;
d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
- if (strchr(tmpbuf, ':'))
- sv_setpv(PL_subname, tmpbuf);
+#ifdef PERL_MAD
+ if (PL_madskills)
+ nametoke = newSVpvn(s, d - s);
+#endif
+ if (memchr(tmpbuf, ':', len))
+ sv_setpvn(PL_subname, tmpbuf, len);
else {
sv_setsv(PL_subname,PL_curstname);
sv_catpvs(PL_subname,"::");
sv_catpvn(PL_subname,tmpbuf,len);
}
+ have_name = TRUE;
+
+#ifdef PERL_MAD
+
+ start_force(0);
+ CURMAD('X', nametoke);
+ CURMAD('_', tmpwhite);
+ (void) force_word(PL_oldbufptr + tboffset, WORD,
+ FALSE, TRUE, TRUE);
+
+ s = SKIPSPACE2(d,tmpwhite);
+#else
s = skipspace(d);
- have_name = TRUE;
+#endif
}
else {
if (key == KEY_my)
Perl_croak(aTHX_ "Missing name in \"my sub\"");
PL_expect = XTERMBLOCK;
attrful = XATTRTERM;
- sv_setpvn(PL_subname,"?",1);
+ sv_setpvs(PL_subname,"?");
have_name = FALSE;
}
if (key == KEY_format) {
if (*s == '=')
PL_lex_formbrack = PL_lex_brackets + 1;
+#ifdef PERL_MAD
+ PL_thistoken = subtoken;
+ s = d;
+#else
if (have_name)
(void) force_word(PL_oldbufptr + tboffset, WORD,
FALSE, TRUE, TRUE);
+#endif
OPERATOR(FORMAT);
}
/* Look for a prototype */
if (*s == '(') {
char *p;
-
- s = scan_str(s,FALSE,FALSE);
+ bool bad_proto = FALSE;
+ bool in_brackets = FALSE;
+ char greedy_proto = ' ';
+ bool proto_after_greedy_proto = FALSE;
+ bool must_be_last = FALSE;
+ bool underscore = FALSE;
+ bool seen_underscore = FALSE;
+ const bool warnsyntax = ckWARN(WARN_SYNTAX);
+
+ s = scan_str(s,!!PL_madskills,FALSE);
if (!s)
Perl_croak(aTHX_ "Prototype not terminated");
/* 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))
- bad_proto = TRUE;
+
+ if (warnsyntax) {
+ if (must_be_last)
+ proto_after_greedy_proto = TRUE;
+ if (!strchr("$@%*;[]&\\_", *p)) {
+ bad_proto = TRUE;
+ }
+ else {
+ if ( underscore ) {
+ if ( *p != ';' )
+ bad_proto = TRUE;
+ underscore = FALSE;
+ }
+ if ( *p == '[' ) {
+ in_brackets = TRUE;
+ }
+ else if ( *p == ']' ) {
+ in_brackets = FALSE;
+ }
+ else if ( (*p == '@' || *p == '%') &&
+ ( tmp < 2 || d[tmp-2] != '\\' ) &&
+ !in_brackets ) {
+ must_be_last = TRUE;
+ greedy_proto = *p;
+ }
+ else if ( *p == '_' ) {
+ underscore = seen_underscore = TRUE;
+ }
+ }
+ }
}
}
d[tmp] = '\0';
- if (bad_proto && ckWARN(WARN_SYNTAX))
+ if (proto_after_greedy_proto)
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
- "Illegal character in prototype for %"SVf" : %s",
- PL_subname, d);
+ "Prototype after '%c' for %"SVf" : %s",
+ greedy_proto, SVfARG(PL_subname), d);
+ if (bad_proto)
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
+ "Illegal character %sin prototype for %"SVf" : %s",
+ seen_underscore ? "after '_' " : "",
+ SVfARG(PL_subname), d);
SvCUR_set(PL_lex_stuff, tmp);
have_proto = TRUE;
+#ifdef PERL_MAD
+ start_force(0);
+ CURMAD('q', PL_thisopen);
+ CURMAD('_', tmpwhite);
+ CURMAD('=', PL_thisstuff);
+ CURMAD('Q', PL_thisclose);
+ NEXTVAL_NEXTTOKE.opval =
+ (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
+ PL_lex_stuff = NULL;
+ force_next(THING);
+
+ s = SKIPSPACE2(s,tmpwhite);
+#else
s = skipspace(s);
+#endif
}
else
have_proto = FALSE;
if (!have_name)
Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
else if (*s != ';')
- Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, 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('^', newSVpvs(""));
+ CURMAD('_', tmpwhite);
}
+ force_next(0);
+ PL_thistoken = subtoken;
+#else
if (have_proto) {
- PL_nextval[PL_nexttoke].opval =
+ NEXTVAL_NEXTTOKE.opval =
(OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
PL_lex_stuff = NULL;
force_next(THING);
}
+#endif
if (!have_name) {
- sv_setpv(PL_subname,
- PL_curstash ? "__ANON__" : "__ANON__::__ANON__");
+ if (PL_curstash)
+ sv_setpvs(PL_subname, "__ANON__");
+ else
+ sv_setpvs(PL_subname, "__ANON__::__ANON__");
TOKEN(ANONSUB);
}
+#ifndef PERL_MAD
(void) force_word(PL_oldbufptr + tboffset, WORD,
FALSE, TRUE, TRUE);
+#endif
if (key == KEY_my)
TOKEN(MYSUB);
TOKEN(SUB);
}
case KEY_system:
- set_csh();
LOP(OP_SYSTEM,XREF);
case KEY_symlink:
UNI(OP_UNTIE);
case KEY_until:
- yylval.ival = CopLINE(PL_curcop);
+ pl_yylval.ival = CopLINE(PL_curcop);
OPERATOR(UNTIL);
case KEY_unless:
- yylval.ival = CopLINE(PL_curcop);
+ pl_yylval.ival = CopLINE(PL_curcop);
OPERATOR(UNLESS);
case KEY_unlink:
LOP(OP_VEC,XTERM);
case KEY_when:
- yylval.ival = CopLINE(PL_curcop);
+ pl_yylval.ival = CopLINE(PL_curcop);
OPERATOR(WHEN);
case KEY_while:
- yylval.ival = CopLINE(PL_curcop);
+ pl_yylval.ival = CopLINE(PL_curcop);
OPERATOR(WHILE);
case KEY_warn:
goto just_a_word;
case KEY_xor:
- yylval.ival = OP_XOR;
+ pl_yylval.ival = OP_XOR;
OPERATOR(OROP);
case KEY_y:
{
dVAR;
register char *d;
- register I32 tmp = 0;
+ PADOFFSET tmp = 0;
/* pit holds the identifier we read and pending_ident is reset */
char pit = PL_pending_ident;
+ const STRLEN tokenbuf_len = strlen(PL_tokenbuf);
+ /* All routes through this function want to know if there is a colon. */
+ const char *const has_colon = (const char*) memchr (PL_tokenbuf, ':', tokenbuf_len);
PL_pending_ident = 0;
+ /* PL_realtokenstart = realtokenend = PL_bufptr - SvPVX(PL_linestr); */
DEBUG_T({ PerlIO_printf(Perl_debug_log,
"### Pending identifier '%s'\n", PL_tokenbuf); });
*/
if (PL_in_my) {
if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
- if (strchr(PL_tokenbuf,':'))
+ if (has_colon)
yyerror(Perl_form(aTHX_ "No package name allowed for "
"variable %s in \"our\"",
PL_tokenbuf));
tmp = allocmy(PL_tokenbuf);
}
else {
- if (strchr(PL_tokenbuf,':'))
- yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
+ if (has_colon)
+ yyerror(Perl_form(aTHX_ PL_no_myglob,
+ PL_in_my == KEY_my ? "my" : "state", PL_tokenbuf));
- yylval.opval = newOP(OP_PADANY, 0);
- yylval.opval->op_targ = allocmy(PL_tokenbuf);
+ pl_yylval.opval = newOP(OP_PADANY, 0);
+ pl_yylval.opval->op_targ = allocmy(PL_tokenbuf);
return PRIVATEREF;
}
}
(although why you'd do that is anyone's guess).
*/
- if (!strchr(PL_tokenbuf,':')) {
+ if (!has_colon) {
if (!PL_in_my)
tmp = pad_findmy(PL_tokenbuf);
if (tmp != NOT_IN_PAD) {
HEK * const stashname = HvNAME_HEK(stash);
SV * const sym = newSVhek(stashname);
sv_catpvs(sym, "::");
- sv_catpv(sym, PL_tokenbuf+1);
- yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
- yylval.opval->op_private = OPpCONST_ENTERED;
+ sv_catpvn(sym, PL_tokenbuf+1, tokenbuf_len - 1);
+ pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
+ pl_yylval.opval->op_private = OPpCONST_ENTERED;
gv_fetchsv(sym,
(PL_in_eval
? (GV_ADDMULTI | GV_ADDINEVAL)
}
}
- yylval.opval = newOP(OP_PADANY, 0);
- yylval.opval->op_targ = tmp;
+ pl_yylval.opval = newOP(OP_PADANY, 0);
+ pl_yylval.opval->op_targ = tmp;
return PRIVATEREF;
}
}
table.
*/
if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
- GV *gv = gv_fetchpv(PL_tokenbuf+1, 0, SVt_PVAV);
+ GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len - 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),
}
/* build ops for a bareword */
- yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
- yylval.opval->op_private = OPpCONST_ENTERED;
- gv_fetchpv(
- PL_tokenbuf+1,
+ pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpvn(PL_tokenbuf + 1,
+ tokenbuf_len - 1));
+ pl_yylval.opval->op_private = OPpCONST_ENTERED;
+ gv_fetchpvn_flags(
+ PL_tokenbuf + 1, tokenbuf_len - 1,
/* If the identifier refers to a stash, don't autovivify it.
* Change 24660 had the side effect of causing symbol table
* hashes to always be defined, even if they were freshly
* tests still give the expected answers, even though what
* they're actually testing has now changed subtly.
*/
- (*PL_tokenbuf == '%' && *(d = PL_tokenbuf + strlen(PL_tokenbuf) - 1) == ':' && d[-1] == ':'
+ (*PL_tokenbuf == '%'
+ && *(d = PL_tokenbuf + tokenbuf_len - 1) == ':'
+ && d[-1] == ':'
? 0
: PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADD),
((PL_tokenbuf[0] == '$') ? SVt_PV
*/
I32
-Perl_keyword (pTHX_ const char *name, I32 len)
+Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords)
{
- dVAR;
+ dVAR;
+
+ PERL_ARGS_ASSERT_KEYWORD;
+
switch (len)
{
case 1: /* 5 tokens of length 1 */
goto unknown;
- case 'r':
- if (name[2] == 'r')
- { /* err */
- return (FEATURE_IS_ENABLED("err") ? -KEY_err : 0);
- }
-
- goto unknown;
-
case 'x':
if (name[2] == 'p')
{ /* exp */
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;
switch (name[1])
{
case 'a':
- switch (name[2])
- {
- case 'i':
- if (name[3] == 't')
- { /* wait */
- return -KEY_wait;
- }
+ switch (name[2])
+ {
+ case 'i':
+ if (name[3] == 't')
+ { /* wait */
+ return -KEY_wait;
+ }
- goto unknown;
+ goto unknown;
- case 'r':
- if (name[3] == 'n')
- { /* warn */
- return -KEY_warn;
- }
+ case 'r':
+ if (name[3] == 'n')
+ { /* warn */
+ return -KEY_warn;
+ }
- goto unknown;
+ goto unknown;
- default:
- goto unknown;
- }
+ default:
+ goto unknown;
+ }
case 'h':
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;
+ goto unknown;
- default:
- goto unknown;
- }
+ default:
+ goto unknown;
+ }
default:
goto unknown;
}
- case 5: /* 38 tokens of length 5 */
+ case 5: /* 39 tokens of length 5 */
switch (name[0])
{
case 'B':
{
case 'l':
if (name[2] == 'e' &&
- name[3] == 's' &&
- name[4] == 's')
- { /* bless */
- return -KEY_bless;
- }
+ name[3] == 's' &&
+ name[4] == 's')
+ { /* bless */
+ return -KEY_bless;
+ }
- goto unknown;
+ goto unknown;
case 'r':
if (name[2] == 'e' &&
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;
goto unknown;
case 't':
- if (name[2] == 'u' &&
- name[3] == 'd' &&
- name[4] == 'y')
- { /* study */
- return KEY_study;
- }
+ switch (name[2])
+ {
+ case 'a':
+ if (name[3] == 't' &&
+ name[4] == 'e')
+ { /* state */
+ return (all_keywords || FEATURE_IS_ENABLED("state") ? KEY_state : 0);
+ }
- goto unknown;
+ goto unknown;
+
+ case 'u':
+ if (name[3] == 'd' &&
+ name[4] == 'y')
+ { /* study */
+ return KEY_study;
+ }
+
+ goto unknown;
+
+ default:
+ goto unknown;
+ }
default:
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;
case 'i':
if (name[4] == 'n' &&
- name[5] == 'e' &&
- name[6] == 'd')
- { /* defined */
- return KEY_defined;
- }
+ name[5] == 'e' &&
+ name[6] == 'd')
+ { /* defined */
+ return KEY_defined;
+ }
- goto unknown;
+ goto unknown;
- default:
- goto unknown;
- }
+ default:
+ goto unknown;
+ }
}
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' &&
}
STATIC void
-S_checkcomma(pTHX_ register char *s, const char *name, const char *what)
+S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
{
dVAR;
- const char *w;
+
+ PERL_ARGS_ASSERT_CHECKCOMMA;
if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
if (ckWARN(WARN_SYNTAX)) {
int level = 1;
+ const char *w;
for (w = s+2; *w && level; w++) {
if (*w == '(')
++level;
else if (*w == ')')
--level;
}
- if (*w)
- for (; *w && isSPACE(*w); w++) ;
- if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
+ while (isSPACE(*w))
+ ++w;
+ /* 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);
}
while (s < PL_bufend && isSPACE(*s))
s++;
if (isIDFIRST_lazy_if(s,UTF)) {
- w = s++;
+ const char * const w = s++;
while (isALNUM_lazy_if(s,UTF))
s++;
while (s < PL_bufend && isSPACE(*s))
s++;
if (*s == ',') {
- I32 kw;
- *s = '\0'; /* XXX If we didn't do this, we could const a lot of toke.c */
- kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
- *s = ',';
- if (kw)
+ GV* gv;
+ if (keyword(w, s - w, 0))
+ return;
+
+ gv = gv_fetchpvn_flags(w, s - w, 0, SVt_PVCV);
+ if (gv && GvCVu(gv))
return;
Perl_croak(aTHX_ "No comma allowed after %s", what);
}
and type is used with error messages only. */
STATIC SV *
-S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, SV *sv, SV *pv,
- const char *type)
+S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen,
+ SV *sv, SV *pv, const char *type, STRLEN typelen)
{
dVAR; dSP;
HV * const table = GvHV(PL_hintgv); /* ^H */
SV *cv, *typesv;
const char *why1 = "", *why2 = "", *why3 = "";
+ PERL_ARGS_ASSERT_NEW_CONSTANT;
+
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);
SvREFCNT_dec(msg);
return sv;
}
- cvp = hv_fetch(table, key, strlen(key), FALSE);
+ cvp = hv_fetch(table, key, keylen, FALSE);
if (!cvp || !SvOK(*cvp)) {
why1 = "$^H{";
why2 = key;
sv_2mortal(sv); /* Parent created it permanently */
cv = *cvp;
if (!pv && s)
- pv = sv_2mortal(newSVpvn(s, len));
+ pv = newSVpvn_flags(s, len, SVs_TEMP);
if (type && pv)
- typesv = sv_2mortal(newSVpv(type, 0));
+ typesv = newSVpvn_flags(type, typelen, SVs_TEMP);
else
typesv = &PL_sv_undef;
dVAR;
register char *d = dest;
register char * const e = d + destlen - 3; /* two-character token, ending NUL */
+
+ PERL_ARGS_ASSERT_SCAN_WORD;
+
for (;;) {
if (d >= e)
Perl_croak(aTHX_ ident_too_long);
if (isALNUM(*s)) /* UTF handled below */
*d++ = *s++;
- else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) {
+ else if (allow_package && (*s == '\'') && isIDFIRST_lazy_if(s+1,UTF)) {
*d++ = ':';
*d++ = ':';
s++;
}
- else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
+ else if (allow_package && (s[0] == ':') && (s[1] == ':') && (s[2] != '$')) {
*d++ = *s++;
*d++ = *s++;
}
else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
char *t = s + UTF8SKIP(s);
+ size_t len;
while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
t += UTF8SKIP(t);
- if (d + (t - s) > e)
+ len = t - s;
+ if (d + len > e)
Perl_croak(aTHX_ ident_too_long);
- Copy(s, d, t - s, char);
- d += t - s;
+ Copy(s, d, len, char);
+ d += len;
s = t;
}
else {
register char *d = dest;
register char * const e = d + destlen + 3; /* two-character token, ending NUL */
+ PERL_ARGS_ASSERT_SCAN_IDENT;
+
if (isSPACE(*s))
- s = skipspace(s);
+ s = PEEKSPACE(s);
if (isDIGIT(*s)) {
while (isDIGIT(*s)) {
if (d >= e)
Perl_croak(aTHX_ ident_too_long);
}
*d = '\0';
- while (s < send && SPACE_OR_TAB(*s)) s++;
+ while (s < send && SPACE_OR_TAB(*s))
+ s++;
if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
- if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
- const char *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);
PL_lex_state = LEX_INTERPEND;
PL_expect = XREF;
}
- if (funny == '#')
- funny = '@';
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_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
"Ambiguous use of %c{%s} resolved to %c%s",
funny, dest, funny, dest);
void
Perl_pmflag(pTHX_ U32* pmfl, int ch)
{
+ PERL_ARGS_ASSERT_PMFLAG;
+
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) {
+ const 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,FALSE,FALSE);
- const char * const valid_flags = (type == OP_QR) ? "iomsx" : "iogcmsx";
+ char *s = scan_str(start,!!PL_madskills,FALSE);
+ const char * const valid_flags =
+ (const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS);
+#ifdef PERL_MAD
+ char *modstart;
+#endif
+
+ PERL_ARGS_ASSERT_SCAN_PAT;
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((const SV *)PL_curstash, PERL_MAGIC_symtab);
+ U32 elements;
+ if (!mg) {
+ mg = sv_magicext(MUTABLE_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
while (*s && strchr(valid_flags, *s))
pmflag(&pm->op_pmflags,*s++);
+#ifdef PERL_MAD
+ if (PL_madskills && modstart != s) {
+ SV* tmptoken = newSVpvn(modstart, s - modstart);
+ append_madprops(newMADPROP('m', MAD_SV, tmptoken, 0), (OP*)pm, 0);
+ }
+#endif
/* issue a warning if /c is specified,but /g is not */
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;
+ pl_yylval.ival = OP_MATCH;
return s;
}
register PMOP *pm;
I32 first_start;
I32 es = 0;
+#ifdef PERL_MAD
+ char *modstart;
+#endif
+
+ PERL_ARGS_ASSERT_SCAN_SUBST;
- yylval.ival = OP_NULL;
+ pl_yylval.ival = OP_NULL;
- s = scan_str(start,FALSE,FALSE);
+ s = scan_str(start,!!PL_madskills,FALSE);
if (!s)
Perl_croak(aTHX_ "Substitution pattern not terminated");
if (s[-1] == PL_multi_open)
s--;
+#ifdef PERL_MAD
+ if (PL_madskills) {
+ CURMAD('q', PL_thisopen);
+ CURMAD('_', PL_thiswhite);
+ CURMAD('E', PL_thisstuff);
+ CURMAD('Q', PL_thisclose);
+ PL_realtokenstart = s - SvPVX(PL_linestr);
+ }
+#endif
first_start = PL_multi_start;
- s = scan_str(s,FALSE,FALSE);
+ s = scan_str(s,!!PL_madskills,FALSE);
if (!s) {
if (PL_lex_stuff) {
SvREFCNT_dec(PL_lex_stuff);
PL_multi_start = first_start; /* so whole substitution is taken together */
pm = (PMOP*)newPMOP(OP_SUBST, 0);
+
+#ifdef PERL_MAD
+ if (PL_madskills) {
+ CURMAD('z', PL_thisopen);
+ CURMAD('R', PL_thisstuff);
+ CURMAD('Z', PL_thisclose);
+ }
+ modstart = 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;
}
+#ifdef PERL_MAD
+ if (PL_madskills) {
+ if (modstart != s)
+ curmad('m', newSVpvn(modstart, s - modstart));
+ append_madprops(PL_thismad, (OP*)pm, 0);
+ PL_thismad = 0;
+ }
+#endif
if ((pm->op_pmflags & PMf_CONTINUE) && ckWARN(WARN_REGEXP)) {
Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
}
PL_sublex_info.super_bufend = PL_bufend;
PL_multi_end = 0;
pm->op_pmflags |= PMf_EVAL;
- while (es-- > 0)
- sv_catpv(repl, es ? "eval " : "do ");
- sv_catpvs(repl, "{ ");
+ while (es-- > 0) {
+ if (es)
+ sv_catpvs(repl, "eval ");
+ else
+ sv_catpvs(repl, "do ");
+ }
+ sv_catpvs(repl, "{");
sv_catsv(repl, PL_lex_repl);
- sv_catpvs(repl, " }");
+ if (strchr(SvPVX(PL_lex_repl), '#'))
+ sv_catpvs(repl, "\n");
+ sv_catpvs(repl, "}");
SvEVALED_on(repl);
SvREFCNT_dec(PL_lex_repl);
PL_lex_repl = repl;
}
- pm->op_pmpermflags = pm->op_pmflags;
PL_lex_op = (OP*)pm;
- yylval.ival = OP_SUBST;
+ pl_yylval.ival = OP_SUBST;
return s;
}
register char* s;
OP *o;
short *tbl;
- I32 squash;
- I32 del;
- I32 complement;
+ U8 squash;
+ U8 del;
+ U8 complement;
+#ifdef PERL_MAD
+ char *modstart;
+#endif
+
+ PERL_ARGS_ASSERT_SCAN_TRANS;
- yylval.ival = OP_NULL;
+ pl_yylval.ival = OP_NULL;
- s = scan_str(start,FALSE,FALSE);
+ s = scan_str(start,!!PL_madskills,FALSE);
if (!s)
Perl_croak(aTHX_ "Transliteration pattern not terminated");
+
if (s[-1] == PL_multi_open)
s--;
+#ifdef PERL_MAD
+ if (PL_madskills) {
+ CURMAD('q', PL_thisopen);
+ CURMAD('_', PL_thiswhite);
+ CURMAD('E', PL_thisstuff);
+ CURMAD('Q', PL_thisclose);
+ PL_realtokenstart = s - SvPVX(PL_linestr);
+ }
+#endif
- s = scan_str(s,FALSE,FALSE);
+ s = scan_str(s,!!PL_madskills,FALSE);
if (!s) {
if (PL_lex_stuff) {
SvREFCNT_dec(PL_lex_stuff);
}
Perl_croak(aTHX_ "Transliteration replacement not terminated");
}
+ if (PL_madskills) {
+ CURMAD('z', PL_thisopen);
+ CURMAD('R', PL_thisstuff);
+ CURMAD('Z', PL_thisclose);
+ }
complement = del = squash = 0;
+#ifdef PERL_MAD
+ modstart = s;
+#endif
while (1) {
switch (*s) {
case 'c':
}
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|
(DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0);
PL_lex_op = o;
- yylval.ival = OP_TRANS;
+ pl_yylval.ival = OP_TRANS;
+
+#ifdef PERL_MAD
+ if (PL_madskills) {
+ if (modstart != s)
+ curmad('m', newSVpvn(modstart, s - modstart));
+ append_madprops(PL_thismad, o, 0);
+ PL_thismad = 0;
+ }
+#endif
+
return s;
}
register char *e;
char *peek;
const int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
+#ifdef PERL_MAD
+ I32 stuffstart = s - SvPVX(PL_linestr);
+ char *tstart;
+
+ PL_realtokenstart = -1;
+#endif
+
+ PERL_ARGS_ASSERT_SCAN_HEREDOC;
s += 2;
d = PL_tokenbuf;
e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
if (!outer)
*d++ = '\n';
- for (peek = s; SPACE_OR_TAB(*peek); peek++) ;
+ peek = s;
+ while (SPACE_OR_TAB(*peek))
+ peek++;
if (*peek == '`' || *peek == '\'' || *peek =='"') {
s = peek;
term = *s++;
*d++ = '\n';
*d = '\0';
len = d - PL_tokenbuf;
+
+#ifdef PERL_MAD
+ if (PL_madskills) {
+ tstart = PL_tokenbuf + !outer;
+ PL_thisclose = newSVpvn(tstart, len - !outer);
+ tstart = SvPVX(PL_linestr) + stuffstart;
+ PL_thisopen = newSVpvn(tstart, s - tstart);
+ stuffstart = s - SvPVX(PL_linestr);
+ }
+#endif
#ifndef PERL_STRICT_CR
d = strchr(s, '\r');
if (d) {
s = olds;
}
#endif
- if ( outer || !(found_newline = memchr(s, '\n', PL_bufend - s)) ) {
+#ifdef PERL_MAD
+ found_newline = 0;
+#endif
+ if ( outer || !(found_newline = (char*)memchr((void*)s, '\n', PL_bufend - s)) ) {
herewas = newSVpvn(s,PL_bufend-s);
}
else {
+#ifdef PERL_MAD
+ herewas = newSVpvn(s-1,found_newline-s+1);
+#else
s--;
herewas = newSVpvn(s,found_newline-s);
+#endif
+ }
+#ifdef PERL_MAD
+ if (PL_madskills) {
+ tstart = SvPVX(PL_linestr) + stuffstart;
+ if (PL_thisstuff)
+ sv_catpvn(PL_thisstuff, tstart, s - tstart);
+ else
+ PL_thisstuff = newSVpvn(tstart, s - tstart);
}
+#endif
s += SvCUR(herewas);
- tmpstr = newSV(79);
- sv_upgrade(tmpstr, SVt_PVIV);
+#ifdef PERL_MAD
+ stuffstart = s - SvPVX(PL_linestr);
+
+ if (found_newline)
+ s--;
+#endif
+
+ tmpstr = newSV_type(SVt_PVIV);
+ SvGROW(tmpstr, 80);
if (term == '\'') {
op_type = OP_CONST;
SvIV_set(tmpstr, -1);
missingterm(PL_tokenbuf);
}
sv_setpvn(tmpstr,d+1,s-d);
+#ifdef PERL_MAD
+ if (PL_madskills) {
+ if (PL_thisstuff)
+ sv_catpvn(PL_thisstuff, d + 1, s - d);
+ else
+ PL_thisstuff = newSVpvn(d + 1, s - d);
+ stuffstart = s - SvPVX(PL_linestr);
+ }
+#endif
s += len - 1;
CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
PL_last_lop = PL_last_uni = NULL;
}
else
- sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
+ sv_setpvs(tmpstr,""); /* avoid "uninitialized" warning */
while (s >= PL_bufend) { /* multiple line string? */
+#ifdef PERL_MAD
+ if (PL_madskills) {
+ tstart = SvPVX(PL_linestr) + stuffstart;
+ if (PL_thisstuff)
+ sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
+ else
+ PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
+ }
+#endif
if (!outer ||
!(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
CopLINE_set(PL_curcop, (line_t)PL_multi_start);
missingterm(PL_tokenbuf);
}
+#ifdef PERL_MAD
+ stuffstart = s - SvPVX(PL_linestr);
+#endif
CopLINE_inc(PL_curcop);
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
PL_last_lop = PL_last_uni = NULL;
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 || PERLDB_SAVESRC) && 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 ) = ' ';
sv_recode_to_utf8(tmpstr, PL_encoding);
}
PL_lex_stuff = tmpstr;
- yylval.ival = op_type;
+ pl_yylval.ival = op_type;
return s;
}
/* scan_inputsymbol
takes: current position in input buffer
returns: new position in input buffer
- side-effects: yylval and lex_op are set.
+ side-effects: pl_yylval and lex_op are set.
This code handles:
register char *s = start; /* current position in buffer */
char *end;
I32 len;
-
char *d = PL_tokenbuf; /* start of temp holding space */
const char * const e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
+ PERL_ARGS_ASSERT_SCAN_INPUTSYMBOL;
+
end = strchr(s, '\n');
if (!end)
end = PL_bufend;
or if it didn't end, or if we see a newline
*/
- if (len >= sizeof PL_tokenbuf)
+ if (len >= (I32)sizeof PL_tokenbuf)
Perl_croak(aTHX_ "Excessively long <> operator");
if (s >= end)
Perl_croak(aTHX_ "Unterminated <> operator");
*/
if (d - PL_tokenbuf != len) {
- yylval.ival = OP_GLOB;
- set_csh();
- s = scan_str(start,FALSE,FALSE);
+ pl_yylval.ival = OP_GLOB;
+ s = scan_str(start,!!PL_madskills,FALSE);
if (!s)
Perl_croak(aTHX_ "Glob not terminated");
return s;
&& 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;
filehandle
*/
if (*d == '$') {
- I32 tmp;
-
/* try to find it in the pad for this block, otherwise find
add symbol table ops
*/
- if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
+ const PADOFFSET tmp = pad_findmy(d);
+ if (tmp != NOT_IN_PAD) {
if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
HEK * const stashname = HvNAME_HEK(stash);
}
if (!readline_overriden)
PL_lex_op->op_flags |= OPf_SPECIAL;
- /* we created the ops in PL_lex_op, so make yylval.ival a null op */
- yylval.ival = OP_NULL;
+ /* we created the ops in PL_lex_op, so make pl_yylval.ival a null op */
+ pl_yylval.ival = OP_NULL;
}
/* If it's none of the above, it must be a literal filehandle
newGVOP(OP_GV, 0, gv),
newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
: (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
- yylval.ival = OP_NULL;
+ pl_yylval.ival = OP_NULL;
}
}
{
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;
+#endif
+
+ PERL_ARGS_ASSERT_SCAN_STR;
/* skip space before the delimiter */
- if (isSPACE(*s))
- s = skipspace(s);
+ if (isSPACE(*s)) {
+ s = PEEKSPACE(s);
+ }
+#ifdef PERL_MAD
+ if (PL_realtokenstart >= 0) {
+ stuffstart = PL_realtokenstart;
+ PL_realtokenstart = -1;
+ }
+ else
+ stuffstart = start - SvPVX(PL_linestr);
+#endif
/* mark where we are, in case we need to report errors */
CLINE;
/* 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 */
if (keep_delims)
sv_catpvn(sv, s, termlen);
s += termlen;
+#ifdef PERL_MAD
+ tstart = SvPVX(PL_linestr) + stuffstart;
+ if (!PL_thisopen && !keep_delims) {
+ PL_thisopen = newSVpvn(tstart, s - tstart);
+ stuffstart = s - SvPVX(PL_linestr);
+ }
+#endif
for (;;) {
if (PL_encoding && !UTF) {
bool cont = TRUE;
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;
}
/* if we're out of file, or a read fails, bail and reset the current
line marker so we can report where the unterminated string began
*/
+#ifdef PERL_MAD
+ if (PL_madskills) {
+ char * const tstart = SvPVX(PL_linestr) + stuffstart;
+ if (PL_thisstuff)
+ sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
+ else
+ PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
+ }
+#endif
if (!PL_rsfp ||
!(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
sv_free(sv);
CopLINE_set(PL_curcop, (line_t)PL_multi_start);
return NULL;
}
+#ifdef PERL_MAD
+ stuffstart = 0;
+#endif
/* we read a line, so increment our line counter */
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 || PERLDB_SAVESRC) && 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);
/* at this point, we have successfully read the delimited string */
if (!PL_encoding || UTF) {
+#ifdef PERL_MAD
+ if (PL_madskills) {
+ char * const tstart = SvPVX(PL_linestr) + stuffstart;
+ const int len = s - tstart;
+ if (PL_thisstuff)
+ sv_catpvn(PL_thisstuff, tstart, len);
+ else
+ PL_thisstuff = newSVpvn(tstart, len);
+ if (!PL_thisclose && !keep_delims)
+ PL_thisclose = newSVpvn(s,termlen);
+ }
+#endif
+
if (keep_delims)
sv_catpvn(sv, s, termlen);
s += termlen;
}
+#ifdef PERL_MAD
+ else {
+ if (PL_madskills) {
+ char * const tstart = SvPVX(PL_linestr) + stuffstart;
+ const int len = s - tstart - termlen;
+ if (PL_thisstuff)
+ sv_catpvn(PL_thisstuff, tstart, len);
+ else
+ PL_thisstuff = newSVpvn(tstart, len);
+ if (!PL_thisclose && !keep_delims)
+ PL_thisclose = newSVpvn(s - termlen,termlen);
+ }
+ }
+#endif
if (has_utf8 || PL_encoding)
SvUTF8_on(sv);
scan_num
takes: pointer to position in buffer
returns: pointer to new position in buffer
- side-effects: builds ops for the constant in yylval.op
+ side-effects: builds ops for the constant in pl_yylval.op
Read a number in any of the formats that Perl accepts:
const char *lastub = NULL; /* position of last underbar */
static char const number_too_long[] = "Number too long";
+ PERL_ARGS_ASSERT_SCAN_NUM;
+
/* We use the first character to decide what type of number this is */
switch (*s) {
}
if (just_zero && (PL_hints & HINT_NEW_INTEGER))
sv = new_constant(start, s - start, "integer",
- sv, NULL, NULL);
+ sv, NULL, NULL, 0);
else if (PL_hints & HINT_NEW_BINARY)
- sv = new_constant(start, s - start, "binary", sv, NULL, NULL);
+ sv = new_constant(start, s - start, "binary", sv, NULL, NULL, 0);
}
break;
sv_setnv(sv, nv);
}
- if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
- (PL_hints & HINT_NEW_INTEGER) )
- sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
- (floatit ? "float" : "integer"),
- sv, NULL, NULL);
+ if ( floatit
+ ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) ) {
+ const char *const key = floatit ? "float" : "integer";
+ const STRLEN keylen = floatit ? 5 : 7;
+ sv = S_new_constant(aTHX_ PL_tokenbuf, d - PL_tokenbuf,
+ key, keylen, sv, NULL, NULL, 0);
+ }
break;
/* if it starts with a v, it could be a v-string */
case 'v':
vstring:
sv = newSV(5); /* preallocate storage space */
- s = scan_vstring(s,sv);
+ s = scan_vstring(s, PL_bufend, sv);
break;
}
SV * const stuff = newSVpvs("");
bool needargs = FALSE;
bool eofmt = FALSE;
+#ifdef PERL_MAD
+ char *tokenstart = s;
+ SV* savewhite = NULL;
+
+ if (PL_madskills) {
+ savewhite = PL_thiswhite;
+ PL_thiswhite = 0;
+ }
+#endif
+
+ PERL_ARGS_ASSERT_SCAN_FORMLINE;
while (!needargs) {
if (*s == '.') {
+ t = s+1;
#ifdef PERL_STRICT_CR
- for (t = s+1;SPACE_OR_TAB(*t); t++) ;
+ while (SPACE_OR_TAB(*t))
+ t++;
#else
- for (t = s+1;SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
+ while (SPACE_OR_TAB(*t) || *t == '\r')
+ t++;
#endif
if (*t == '\n' || t == PL_bufend) {
eofmt = TRUE;
}
s = (char*)eol;
if (PL_rsfp) {
+#ifdef PERL_MAD
+ if (PL_madskills) {
+ if (PL_thistoken)
+ sv_catpvn(PL_thistoken, tokenstart, PL_bufend - tokenstart);
+ else
+ PL_thistoken = newSVpvn(tokenstart, PL_bufend - tokenstart);
+ }
+#endif
s = filter_gets(PL_linestr, PL_rsfp, 0);
+#ifdef PERL_MAD
+ tokenstart = PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
+#else
PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
+#endif
PL_bufend = PL_bufptr + SvCUR(PL_linestr);
PL_last_lop = PL_last_uni = NULL;
if (!s) {
PL_expect = XTERM;
if (needargs) {
PL_lex_state = LEX_NORMAL;
- PL_nextval[PL_nexttoke].ival = 0;
+ start_force(PL_curforce);
+ NEXTVAL_NEXTTOKE.ival = 0;
force_next(',');
}
else
else if (PL_encoding)
sv_recode_to_utf8(stuff, PL_encoding);
}
- PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
+ start_force(PL_curforce);
+ NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, stuff);
force_next(THING);
- PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
+ start_force(PL_curforce);
+ NEXTVAL_NEXTTOKE.ival = OP_FORMLINE;
force_next(LSTOP);
}
else {
PL_lex_formbrack = 0;
PL_bufptr = s;
}
- return s;
-}
-
-STATIC void
-S_set_csh(pTHX)
-{
-#ifdef CSH
- dVAR;
- if (!PL_cshlen)
- PL_cshlen = strlen(PL_cshname);
-#else
-#if defined(USE_ITHREADS)
- PERL_UNUSED_CONTEXT;
-#endif
+#ifdef PERL_MAD
+ if (PL_madskills) {
+ if (PL_thistoken)
+ sv_catpvn(PL_thistoken, tokenstart, s - tokenstart);
+ else
+ PL_thistoken = newSVpvn(tokenstart, s - tokenstart);
+ PL_thiswhite = savewhite;
+ }
#endif
+ return s;
}
I32
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 = MUTABLE_CV(newSV_type(is_format ? SVt_PVFM : SVt_PVCV));
CvFLAGS(PL_compcv) |= flags;
PL_subline = CopLINE(PL_curcop);
CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
- CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc_simple(outsidecv);
+ CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outsidecv));
CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
return oldsavestack_ix;
#ifdef __SC__
#pragma segment Perl_yylex
#endif
-int
-Perl_yywarn(pTHX_ const char *s)
+static int
+S_yywarn(pTHX_ const char *const s)
{
dVAR;
+
+ PERL_ARGS_ASSERT_YYWARN;
+
PL_in_eval |= EVAL_WARNONLY;
yyerror(s);
PL_in_eval &= ~EVAL_WARNONLY;
}
int
-Perl_yyerror(pTHX_ const char *s)
+Perl_yyerror(pTHX_ const char *const s)
{
dVAR;
const char *where = NULL;
const char *context = NULL;
int contlen = -1;
SV *msg;
+ int yychar = PL_parser->yychar;
+
+ PERL_ARGS_ASSERT_YYERROR;
if (!yychar || (yychar == ';' && !PL_rsfp))
where = "at EOF";
where = "within string";
}
else {
- SV * const where_sv = sv_2mortal(newSVpvs("next char "));
+ SV * const where_sv = newSVpvs_flags("next char ", SVs_TEMP);
if (yychar < 32)
Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
- else if (isPRINT_LC(yychar))
- Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
+ else if (isPRINT_LC(yychar)) {
+ const char string = yychar;
+ sv_catpvn(where_sv, &string, 1);
+ }
else
Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
where = SvPVX_const(where_sv);
(int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
PL_multi_end = 0;
}
- if (PL_in_eval & EVAL_WARNONLY && ckWARN_d(WARN_SYNTAX))
- Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, msg);
+ if (PL_in_eval & EVAL_WARNONLY) {
+ if (ckWARN_d(WARN_SYNTAX))
+ 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",
- ERRSV, OutCopFILE(PL_curcop));
+ SVfARG(ERRSV), OutCopFILE(PL_curcop));
else
Perl_croak(aTHX_ "%s has too many errors.\n",
OutCopFILE(PL_curcop));
{
dVAR;
const STRLEN slen = SvCUR(PL_linestr);
+
+ PERL_ARGS_ASSERT_SWALLOW_BOM;
+
switch (s[0]) {
case 0xFF:
if (s[1] == 0xFE) {
PL_bufend - (char*)s - 1,
&newlen);
sv_setpvn(PL_linestr, (const char*)news, newlen);
+#ifdef PERL_MAD
+ s = (U8*)SvPVX(PL_linestr);
+ Copy(news, s, newlen, U8);
+ s[newlen] = '\0';
+#endif
Safefree(news);
SvUTF8_on(PL_linestr);
s = (U8*)SvPVX(PL_linestr);
+#ifdef PERL_MAD
+ /* FIXME - is this a general bug fix? */
+ s[newlen] = '\0';
+#endif
PL_bufend = SvPVX(PL_linestr) + newlen;
}
#else
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
const I32 count = FILTER_READ(idx+1, sv, maxlen);
DEBUG_P(PerlIO_printf(Perl_debug_log,
"utf16_textfilter(%p): %d %d (%d)\n",
- utf16_textfilter, idx, maxlen, (int) count));
+ FPTR2DPTR(void *, utf16_textfilter),
+ idx, maxlen, (int) count));
if (count) {
U8* tmps;
I32 newlen;
const I32 count = FILTER_READ(idx+1, sv, maxlen);
DEBUG_P(PerlIO_printf(Perl_debug_log,
"utf16rev_textfilter(%p): %d %d (%d)\n",
- utf16rev_textfilter, idx, maxlen, (int) count));
+ FPTR2DPTR(void *, utf16rev_textfilter),
+ idx, maxlen, (int) count));
if (count) {
U8* tmps;
I32 newlen;
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 *const e, SV *sv)
{
dVAR;
const char *pos = s;
const char *start = s;
+
+ PERL_ARGS_ASSERT_SCAN_VSTRING;
+
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;
if (!isALPHA(*pos)) {
U8 tmpbuf[UTF8_MAXBYTES+1];
- if (*s == 'v') s++; /* get past 'v' */
+ if (*s == 'v')
+ s++; /* get past 'v' */
- sv_setpvn(sv, "", 0);
+ sv_setpvs(sv, "");
for (;;) {
+ /* this is atoi() that tolerates underscores */
U8 *tmpend;
UV rev = 0;
- {
- /* this is atoi() that tolerates underscores */
- const char *end = pos;
- UV mult = 1;
- while (--end >= s) {
- UV orev;
- if (*end == '_')
- continue;
- orev = rev;
+ const char *end = pos;
+ UV mult = 1;
+ while (--end >= s) {
+ if (*end != '_') {
+ const UV orev = rev;
rev += (*end - '0') * mult;
mult *= 10;
if (orev > rev && ckWARN_d(WARN_OVERFLOW))
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);
projects / p5sagit/p5-mst-13.2.git / blobdiff