3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * 'It all comes from here, the stench and the peril.' --Frodo
14 * [p.719 of _The Lord of the Rings_, IV/ix: "Shelob's Lair"]
18 * This file is the lexer for Perl. It's closely linked to the
21 * The main routine is yylex(), which returns the next token.
25 =head1 Lexer interface
27 This is the lower layer of the Perl parser, managing characters and tokens.
29 =for apidoc AmU|yy_parser *|PL_parser
31 Pointer to a structure encapsulating the state of the parsing operation
32 currently in progress. The pointer can be locally changed to perform
33 a nested parse without interfering with the state of an outer parse.
34 Individual members of C<PL_parser> have their own documentation.
40 #define PERL_IN_TOKE_C
42 #include "dquote_static.c"
44 #define new_constant(a,b,c,d,e,f,g) \
45 S_new_constant(aTHX_ a,b,STR_WITH_LEN(c),d,e,f, g)
47 #define pl_yylval (PL_parser->yylval)
49 /* XXX temporary backwards compatibility */
50 #define PL_lex_brackets (PL_parser->lex_brackets)
51 #define PL_lex_allbrackets (PL_parser->lex_allbrackets)
52 #define PL_lex_fakeeof (PL_parser->lex_fakeeof)
53 #define PL_lex_brackstack (PL_parser->lex_brackstack)
54 #define PL_lex_casemods (PL_parser->lex_casemods)
55 #define PL_lex_casestack (PL_parser->lex_casestack)
56 #define PL_lex_defer (PL_parser->lex_defer)
57 #define PL_lex_dojoin (PL_parser->lex_dojoin)
58 #define PL_lex_expect (PL_parser->lex_expect)
59 #define PL_lex_formbrack (PL_parser->lex_formbrack)
60 #define PL_lex_inpat (PL_parser->lex_inpat)
61 #define PL_lex_inwhat (PL_parser->lex_inwhat)
62 #define PL_lex_op (PL_parser->lex_op)
63 #define PL_lex_repl (PL_parser->lex_repl)
64 #define PL_lex_starts (PL_parser->lex_starts)
65 #define PL_lex_stuff (PL_parser->lex_stuff)
66 #define PL_multi_start (PL_parser->multi_start)
67 #define PL_multi_open (PL_parser->multi_open)
68 #define PL_multi_close (PL_parser->multi_close)
69 #define PL_pending_ident (PL_parser->pending_ident)
70 #define PL_preambled (PL_parser->preambled)
71 #define PL_sublex_info (PL_parser->sublex_info)
72 #define PL_linestr (PL_parser->linestr)
73 #define PL_expect (PL_parser->expect)
74 #define PL_copline (PL_parser->copline)
75 #define PL_bufptr (PL_parser->bufptr)
76 #define PL_oldbufptr (PL_parser->oldbufptr)
77 #define PL_oldoldbufptr (PL_parser->oldoldbufptr)
78 #define PL_linestart (PL_parser->linestart)
79 #define PL_bufend (PL_parser->bufend)
80 #define PL_last_uni (PL_parser->last_uni)
81 #define PL_last_lop (PL_parser->last_lop)
82 #define PL_last_lop_op (PL_parser->last_lop_op)
83 #define PL_lex_state (PL_parser->lex_state)
84 #define PL_rsfp (PL_parser->rsfp)
85 #define PL_rsfp_filters (PL_parser->rsfp_filters)
86 #define PL_in_my (PL_parser->in_my)
87 #define PL_in_my_stash (PL_parser->in_my_stash)
88 #define PL_tokenbuf (PL_parser->tokenbuf)
89 #define PL_multi_end (PL_parser->multi_end)
90 #define PL_error_count (PL_parser->error_count)
93 # define PL_endwhite (PL_parser->endwhite)
94 # define PL_faketokens (PL_parser->faketokens)
95 # define PL_lasttoke (PL_parser->lasttoke)
96 # define PL_nextwhite (PL_parser->nextwhite)
97 # define PL_realtokenstart (PL_parser->realtokenstart)
98 # define PL_skipwhite (PL_parser->skipwhite)
99 # define PL_thisclose (PL_parser->thisclose)
100 # define PL_thismad (PL_parser->thismad)
101 # define PL_thisopen (PL_parser->thisopen)
102 # define PL_thisstuff (PL_parser->thisstuff)
103 # define PL_thistoken (PL_parser->thistoken)
104 # define PL_thiswhite (PL_parser->thiswhite)
105 # define PL_thiswhite (PL_parser->thiswhite)
106 # define PL_nexttoke (PL_parser->nexttoke)
107 # define PL_curforce (PL_parser->curforce)
109 # define PL_nexttoke (PL_parser->nexttoke)
110 # define PL_nexttype (PL_parser->nexttype)
111 # define PL_nextval (PL_parser->nextval)
114 /* This can't be done with embed.fnc, because struct yy_parser contains a
115 member named pending_ident, which clashes with the generated #define */
117 S_pending_ident(pTHX);
119 static const char ident_too_long[] = "Identifier too long";
122 # define CURMAD(slot,sv) if (PL_madskills) { curmad(slot,sv); sv = 0; }
123 # define NEXTVAL_NEXTTOKE PL_nexttoke[PL_curforce].next_val
125 # define CURMAD(slot,sv)
126 # define NEXTVAL_NEXTTOKE PL_nextval[PL_nexttoke]
129 #define XENUMMASK 0x3f
130 #define XFAKEEOF 0x40
131 #define XFAKEBRACK 0x80
133 #ifdef USE_UTF8_SCRIPTS
134 # define UTF (!IN_BYTES)
136 # define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || (PL_hints & HINT_UTF8))
139 /* The maximum number of characters preceding the unrecognized one to display */
140 #define UNRECOGNIZED_PRECEDE_COUNT 10
142 /* In variables named $^X, these are the legal values for X.
143 * 1999-02-27 mjd-perl-patch@plover.com */
144 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
146 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\t')
148 /* LEX_* are values for PL_lex_state, the state of the lexer.
149 * They are arranged oddly so that the guard on the switch statement
150 * can get by with a single comparison (if the compiler is smart enough).
153 /* #define LEX_NOTPARSING 11 is done in perl.h. */
155 #define LEX_NORMAL 10 /* normal code (ie not within "...") */
156 #define LEX_INTERPNORMAL 9 /* code within a string, eg "$foo[$x+1]" */
157 #define LEX_INTERPCASEMOD 8 /* expecting a \U, \Q or \E etc */
158 #define LEX_INTERPPUSH 7 /* starting a new sublex parse level */
159 #define LEX_INTERPSTART 6 /* expecting the start of a $var */
161 /* at end of code, eg "$x" followed by: */
162 #define LEX_INTERPEND 5 /* ... eg not one of [, { or -> */
163 #define LEX_INTERPENDMAYBE 4 /* ... eg one of [, { or -> */
165 #define LEX_INTERPCONCAT 3 /* expecting anything, eg at start of
166 string or after \E, $foo, etc */
167 #define LEX_INTERPCONST 2 /* NOT USED */
168 #define LEX_FORMLINE 1 /* expecting a format line */
169 #define LEX_KNOWNEXT 0 /* next token known; just return it */
173 static const char* const lex_state_names[] = {
192 #include "keywords.h"
194 /* CLINE is a macro that ensures PL_copline has a sane value */
199 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
202 # define SKIPSPACE0(s) skipspace0(s)
203 # define SKIPSPACE1(s) skipspace1(s)
204 # define SKIPSPACE2(s,tsv) skipspace2(s,&tsv)
205 # define PEEKSPACE(s) skipspace2(s,0)
207 # define SKIPSPACE0(s) skipspace(s)
208 # define SKIPSPACE1(s) skipspace(s)
209 # define SKIPSPACE2(s,tsv) skipspace(s)
210 # define PEEKSPACE(s) skipspace(s)
214 * Convenience functions to return different tokens and prime the
215 * lexer for the next token. They all take an argument.
217 * TOKEN : generic token (used for '(', DOLSHARP, etc)
218 * OPERATOR : generic operator
219 * AOPERATOR : assignment operator
220 * PREBLOCK : beginning the block after an if, while, foreach, ...
221 * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
222 * PREREF : *EXPR where EXPR is not a simple identifier
223 * TERM : expression term
224 * LOOPX : loop exiting command (goto, last, dump, etc)
225 * FTST : file test operator
226 * FUN0 : zero-argument function
227 * FUN1 : not used, except for not, which isn't a UNIOP
228 * BOop : bitwise or or xor
230 * SHop : shift operator
231 * PWop : power operator
232 * PMop : pattern-matching operator
233 * Aop : addition-level operator
234 * Mop : multiplication-level operator
235 * Eop : equality-testing operator
236 * Rop : relational operator <= != gt
238 * Also see LOP and lop() below.
241 #ifdef DEBUGGING /* Serve -DT. */
242 # define REPORT(retval) tokereport((I32)retval, &pl_yylval)
244 # define REPORT(retval) (retval)
247 #define TOKEN(retval) return ( PL_bufptr = s, REPORT(retval))
248 #define OPERATOR(retval) return (PL_expect = XTERM, PL_bufptr = s, REPORT(retval))
249 #define AOPERATOR(retval) return ao((PL_expect = XTERM, PL_bufptr = s, REPORT(retval)))
250 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s, REPORT(retval))
251 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval))
252 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval))
253 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval))
254 #define LOOPX(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)LOOPEX))
255 #define FTST(f) return (pl_yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
256 #define FUN0(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
257 #define FUN1(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1))
258 #define BOop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITOROP)))
259 #define BAop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITANDOP)))
260 #define SHop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)SHIFTOP)))
261 #define PWop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)POWOP)))
262 #define PMop(f) return(pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP))
263 #define Aop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)ADDOP)))
264 #define Mop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MULOP)))
265 #define Eop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP))
266 #define Rop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP))
268 /* This bit of chicanery makes a unary function followed by
269 * a parenthesis into a function with one argument, highest precedence.
270 * The UNIDOR macro is for unary functions that can be followed by the //
271 * operator (such as C<shift // 0>).
273 #define UNI2(f,x) { \
274 pl_yylval.ival = f; \
277 PL_last_uni = PL_oldbufptr; \
278 PL_last_lop_op = f; \
280 return REPORT( (int)FUNC1 ); \
282 return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \
284 #define UNI(f) UNI2(f,XTERM)
285 #define UNIDOR(f) UNI2(f,XTERMORDORDOR)
287 #define UNIBRACK(f) { \
288 pl_yylval.ival = f; \
290 PL_last_uni = PL_oldbufptr; \
292 return REPORT( (int)FUNC1 ); \
294 return REPORT( (*s == '(') ? (int)FUNC1 : (int)UNIOP ); \
297 /* grandfather return to old style */
300 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC) \
301 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC; \
302 pl_yylval.ival = (f); \
310 /* how to interpret the pl_yylval associated with the token */
314 TOKENTYPE_OPNUM, /* pl_yylval.ival contains an opcode number */
320 static struct debug_tokens {
322 enum token_type type;
324 } const debug_tokens[] =
326 { ADDOP, TOKENTYPE_OPNUM, "ADDOP" },
327 { ANDAND, TOKENTYPE_NONE, "ANDAND" },
328 { ANDOP, TOKENTYPE_NONE, "ANDOP" },
329 { ANONSUB, TOKENTYPE_IVAL, "ANONSUB" },
330 { ARROW, TOKENTYPE_NONE, "ARROW" },
331 { ASSIGNOP, TOKENTYPE_OPNUM, "ASSIGNOP" },
332 { BITANDOP, TOKENTYPE_OPNUM, "BITANDOP" },
333 { BITOROP, TOKENTYPE_OPNUM, "BITOROP" },
334 { COLONATTR, TOKENTYPE_NONE, "COLONATTR" },
335 { CONTINUE, TOKENTYPE_NONE, "CONTINUE" },
336 { DEFAULT, TOKENTYPE_NONE, "DEFAULT" },
337 { DO, TOKENTYPE_NONE, "DO" },
338 { DOLSHARP, TOKENTYPE_NONE, "DOLSHARP" },
339 { DORDOR, TOKENTYPE_NONE, "DORDOR" },
340 { DOROP, TOKENTYPE_OPNUM, "DOROP" },
341 { DOTDOT, TOKENTYPE_IVAL, "DOTDOT" },
342 { ELSE, TOKENTYPE_NONE, "ELSE" },
343 { ELSIF, TOKENTYPE_IVAL, "ELSIF" },
344 { EQOP, TOKENTYPE_OPNUM, "EQOP" },
345 { FOR, TOKENTYPE_IVAL, "FOR" },
346 { FORMAT, TOKENTYPE_NONE, "FORMAT" },
347 { FUNC, TOKENTYPE_OPNUM, "FUNC" },
348 { FUNC0, TOKENTYPE_OPNUM, "FUNC0" },
349 { FUNC0SUB, TOKENTYPE_OPVAL, "FUNC0SUB" },
350 { FUNC1, TOKENTYPE_OPNUM, "FUNC1" },
351 { FUNCMETH, TOKENTYPE_OPVAL, "FUNCMETH" },
352 { GIVEN, TOKENTYPE_IVAL, "GIVEN" },
353 { HASHBRACK, TOKENTYPE_NONE, "HASHBRACK" },
354 { IF, TOKENTYPE_IVAL, "IF" },
355 { LABEL, TOKENTYPE_PVAL, "LABEL" },
356 { LOCAL, TOKENTYPE_IVAL, "LOCAL" },
357 { LOOPEX, TOKENTYPE_OPNUM, "LOOPEX" },
358 { LSTOP, TOKENTYPE_OPNUM, "LSTOP" },
359 { LSTOPSUB, TOKENTYPE_OPVAL, "LSTOPSUB" },
360 { MATCHOP, TOKENTYPE_OPNUM, "MATCHOP" },
361 { METHOD, TOKENTYPE_OPVAL, "METHOD" },
362 { MULOP, TOKENTYPE_OPNUM, "MULOP" },
363 { MY, TOKENTYPE_IVAL, "MY" },
364 { MYSUB, TOKENTYPE_NONE, "MYSUB" },
365 { NOAMP, TOKENTYPE_NONE, "NOAMP" },
366 { NOTOP, TOKENTYPE_NONE, "NOTOP" },
367 { OROP, TOKENTYPE_IVAL, "OROP" },
368 { OROR, TOKENTYPE_NONE, "OROR" },
369 { PACKAGE, TOKENTYPE_NONE, "PACKAGE" },
370 { PLUGEXPR, TOKENTYPE_OPVAL, "PLUGEXPR" },
371 { PLUGSTMT, TOKENTYPE_OPVAL, "PLUGSTMT" },
372 { PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" },
373 { POSTDEC, TOKENTYPE_NONE, "POSTDEC" },
374 { POSTINC, TOKENTYPE_NONE, "POSTINC" },
375 { POWOP, TOKENTYPE_OPNUM, "POWOP" },
376 { PREDEC, TOKENTYPE_NONE, "PREDEC" },
377 { PREINC, TOKENTYPE_NONE, "PREINC" },
378 { PRIVATEREF, TOKENTYPE_OPVAL, "PRIVATEREF" },
379 { REFGEN, TOKENTYPE_NONE, "REFGEN" },
380 { RELOP, TOKENTYPE_OPNUM, "RELOP" },
381 { SHIFTOP, TOKENTYPE_OPNUM, "SHIFTOP" },
382 { SUB, TOKENTYPE_NONE, "SUB" },
383 { THING, TOKENTYPE_OPVAL, "THING" },
384 { UMINUS, TOKENTYPE_NONE, "UMINUS" },
385 { UNIOP, TOKENTYPE_OPNUM, "UNIOP" },
386 { UNIOPSUB, TOKENTYPE_OPVAL, "UNIOPSUB" },
387 { UNLESS, TOKENTYPE_IVAL, "UNLESS" },
388 { UNTIL, TOKENTYPE_IVAL, "UNTIL" },
389 { USE, TOKENTYPE_IVAL, "USE" },
390 { WHEN, TOKENTYPE_IVAL, "WHEN" },
391 { WHILE, TOKENTYPE_IVAL, "WHILE" },
392 { WORD, TOKENTYPE_OPVAL, "WORD" },
393 { YADAYADA, TOKENTYPE_IVAL, "YADAYADA" },
394 { 0, TOKENTYPE_NONE, NULL }
397 /* dump the returned token in rv, plus any optional arg in pl_yylval */
400 S_tokereport(pTHX_ I32 rv, const YYSTYPE* lvalp)
404 PERL_ARGS_ASSERT_TOKEREPORT;
407 const char *name = NULL;
408 enum token_type type = TOKENTYPE_NONE;
409 const struct debug_tokens *p;
410 SV* const report = newSVpvs("<== ");
412 for (p = debug_tokens; p->token; p++) {
413 if (p->token == (int)rv) {
420 Perl_sv_catpv(aTHX_ report, name);
421 else if ((char)rv > ' ' && (char)rv < '~')
422 Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv);
424 sv_catpvs(report, "EOF");
426 Perl_sv_catpvf(aTHX_ report, "?? %"IVdf, (IV)rv);
429 case TOKENTYPE_GVVAL: /* doesn't appear to be used */
432 Perl_sv_catpvf(aTHX_ report, "(ival=%"IVdf")", (IV)lvalp->ival);
434 case TOKENTYPE_OPNUM:
435 Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)",
436 PL_op_name[lvalp->ival]);
439 Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", lvalp->pval);
441 case TOKENTYPE_OPVAL:
443 Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)",
444 PL_op_name[lvalp->opval->op_type]);
445 if (lvalp->opval->op_type == OP_CONST) {
446 Perl_sv_catpvf(aTHX_ report, " %s",
447 SvPEEK(cSVOPx_sv(lvalp->opval)));
452 sv_catpvs(report, "(opval=null)");
455 PerlIO_printf(Perl_debug_log, "### %s\n\n", SvPV_nolen_const(report));
461 /* print the buffer with suitable escapes */
464 S_printbuf(pTHX_ const char *const fmt, const char *const s)
466 SV* const tmp = newSVpvs("");
468 PERL_ARGS_ASSERT_PRINTBUF;
470 PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60));
477 S_deprecate_commaless_var_list(pTHX) {
479 deprecate("comma-less variable list");
480 return REPORT(','); /* grandfather non-comma-format format */
486 * This subroutine detects &&=, ||=, and //= and turns an ANDAND, OROR or DORDOR
487 * into an OP_ANDASSIGN, OP_ORASSIGN, or OP_DORASSIGN
491 S_ao(pTHX_ int toketype)
494 if (*PL_bufptr == '=') {
496 if (toketype == ANDAND)
497 pl_yylval.ival = OP_ANDASSIGN;
498 else if (toketype == OROR)
499 pl_yylval.ival = OP_ORASSIGN;
500 else if (toketype == DORDOR)
501 pl_yylval.ival = OP_DORASSIGN;
509 * When Perl expects an operator and finds something else, no_op
510 * prints the warning. It always prints "<something> found where
511 * operator expected. It prints "Missing semicolon on previous line?"
512 * if the surprise occurs at the start of the line. "do you need to
513 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
514 * where the compiler doesn't know if foo is a method call or a function.
515 * It prints "Missing operator before end of line" if there's nothing
516 * after the missing operator, or "... before <...>" if there is something
517 * after the missing operator.
521 S_no_op(pTHX_ const char *const what, char *s)
524 char * const oldbp = PL_bufptr;
525 const bool is_first = (PL_oldbufptr == PL_linestart);
527 PERL_ARGS_ASSERT_NO_OP;
533 yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
534 if (ckWARN_d(WARN_SYNTAX)) {
536 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
537 "\t(Missing semicolon on previous line?)\n");
538 else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
540 for (t = PL_oldoldbufptr; (isALNUM_lazy_if(t,UTF) || *t == ':'); t++)
542 if (t < PL_bufptr && isSPACE(*t))
543 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
544 "\t(Do you need to predeclare %.*s?)\n",
545 (int)(t - PL_oldoldbufptr), PL_oldoldbufptr);
549 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
550 "\t(Missing operator before %.*s?)\n", (int)(s - oldbp), oldbp);
558 * Complain about missing quote/regexp/heredoc terminator.
559 * If it's called with NULL then it cauterizes the line buffer.
560 * If we're in a delimited string and the delimiter is a control
561 * character, it's reformatted into a two-char sequence like ^C.
566 S_missingterm(pTHX_ char *s)
572 char * const nl = strrchr(s,'\n');
576 else if (isCNTRL(PL_multi_close)) {
578 tmpbuf[1] = (char)toCTRL(PL_multi_close);
583 *tmpbuf = (char)PL_multi_close;
587 q = strchr(s,'"') ? '\'' : '"';
588 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
592 * Check whether the named feature is enabled.
595 Perl_feature_is_enabled(pTHX_ const char *const name, STRLEN namelen)
598 HV * const hinthv = GvHV(PL_hintgv);
599 char he_name[8 + MAX_FEATURE_LEN] = "feature_";
601 PERL_ARGS_ASSERT_FEATURE_IS_ENABLED;
603 if (namelen > MAX_FEATURE_LEN)
605 memcpy(&he_name[8], name, namelen);
607 return (hinthv && hv_exists(hinthv, he_name, 8 + namelen));
611 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
612 * utf16-to-utf8-reversed.
615 #ifdef PERL_CR_FILTER
619 register const char *s = SvPVX_const(sv);
620 register const char * const e = s + SvCUR(sv);
622 PERL_ARGS_ASSERT_STRIP_RETURN;
624 /* outer loop optimized to do nothing if there are no CR-LFs */
626 if (*s++ == '\r' && *s == '\n') {
627 /* hit a CR-LF, need to copy the rest */
628 register char *d = s - 1;
631 if (*s == '\r' && s[1] == '\n')
642 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
644 const I32 count = FILTER_READ(idx+1, sv, maxlen);
645 if (count > 0 && !maxlen)
652 =for apidoc Amx|void|lex_start|SV *line|PerlIO *rsfp|U32 flags
654 Creates and initialises a new lexer/parser state object, supplying
655 a context in which to lex and parse from a new source of Perl code.
656 A pointer to the new state object is placed in L</PL_parser>. An entry
657 is made on the save stack so that upon unwinding the new state object
658 will be destroyed and the former value of L</PL_parser> will be restored.
659 Nothing else need be done to clean up the parsing context.
661 The code to be parsed comes from I<line> and I<rsfp>. I<line>, if
662 non-null, provides a string (in SV form) containing code to be parsed.
663 A copy of the string is made, so subsequent modification of I<line>
664 does not affect parsing. I<rsfp>, if non-null, provides an input stream
665 from which code will be read to be parsed. If both are non-null, the
666 code in I<line> comes first and must consist of complete lines of input,
667 and I<rsfp> supplies the remainder of the source.
669 The I<flags> parameter is reserved for future use, and must always
676 Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags)
679 const char *s = NULL;
681 yy_parser *parser, *oparser;
683 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_start");
685 /* create and initialise a parser */
687 Newxz(parser, 1, yy_parser);
688 parser->old_parser = oparser = PL_parser;
691 parser->stack = NULL;
693 parser->stack_size = 0;
695 /* on scope exit, free this parser and restore any outer one */
697 parser->saved_curcop = PL_curcop;
699 /* initialise lexer state */
702 parser->curforce = -1;
704 parser->nexttoke = 0;
706 parser->error_count = oparser ? oparser->error_count : 0;
707 parser->copline = NOLINE;
708 parser->lex_state = LEX_NORMAL;
709 parser->expect = XSTATE;
711 parser->rsfp_filters = newAV();
713 Newx(parser->lex_brackstack, 120, char);
714 Newx(parser->lex_casestack, 12, char);
715 *parser->lex_casestack = '\0';
718 s = SvPV_const(line, len);
724 parser->linestr = newSVpvs("\n;");
726 parser->linestr = newSVpvn_flags(s, len, SvUTF8(line));
728 sv_catpvs(parser->linestr, "\n;");
730 parser->oldoldbufptr =
733 parser->linestart = SvPVX(parser->linestr);
734 parser->bufend = parser->bufptr + SvCUR(parser->linestr);
735 parser->last_lop = parser->last_uni = NULL;
741 /* delete a parser object */
744 Perl_parser_free(pTHX_ const yy_parser *parser)
746 PERL_ARGS_ASSERT_PARSER_FREE;
748 PL_curcop = parser->saved_curcop;
749 SvREFCNT_dec(parser->linestr);
751 if (parser->rsfp == PerlIO_stdin())
752 PerlIO_clearerr(parser->rsfp);
753 else if (parser->rsfp && (!parser->old_parser ||
754 (parser->old_parser && parser->rsfp != parser->old_parser->rsfp)))
755 PerlIO_close(parser->rsfp);
756 SvREFCNT_dec(parser->rsfp_filters);
758 Safefree(parser->lex_brackstack);
759 Safefree(parser->lex_casestack);
760 PL_parser = parser->old_parser;
766 =for apidoc AmxU|SV *|PL_parser-E<gt>linestr
768 Buffer scalar containing the chunk currently under consideration of the
769 text currently being lexed. This is always a plain string scalar (for
770 which C<SvPOK> is true). It is not intended to be used as a scalar by
771 normal scalar means; instead refer to the buffer directly by the pointer
772 variables described below.
774 The lexer maintains various C<char*> pointers to things in the
775 C<PL_parser-E<gt>linestr> buffer. If C<PL_parser-E<gt>linestr> is ever
776 reallocated, all of these pointers must be updated. Don't attempt to
777 do this manually, but rather use L</lex_grow_linestr> if you need to
778 reallocate the buffer.
780 The content of the text chunk in the buffer is commonly exactly one
781 complete line of input, up to and including a newline terminator,
782 but there are situations where it is otherwise. The octets of the
783 buffer may be intended to be interpreted as either UTF-8 or Latin-1.
784 The function L</lex_bufutf8> tells you which. Do not use the C<SvUTF8>
785 flag on this scalar, which may disagree with it.
787 For direct examination of the buffer, the variable
788 L</PL_parser-E<gt>bufend> points to the end of the buffer. The current
789 lexing position is pointed to by L</PL_parser-E<gt>bufptr>. Direct use
790 of these pointers is usually preferable to examination of the scalar
791 through normal scalar means.
793 =for apidoc AmxU|char *|PL_parser-E<gt>bufend
795 Direct pointer to the end of the chunk of text currently being lexed, the
796 end of the lexer buffer. This is equal to C<SvPVX(PL_parser-E<gt>linestr)
797 + SvCUR(PL_parser-E<gt>linestr)>. A NUL character (zero octet) is
798 always located at the end of the buffer, and does not count as part of
799 the buffer's contents.
801 =for apidoc AmxU|char *|PL_parser-E<gt>bufptr
803 Points to the current position of lexing inside the lexer buffer.
804 Characters around this point may be freely examined, within
805 the range delimited by C<SvPVX(L</PL_parser-E<gt>linestr>)> and
806 L</PL_parser-E<gt>bufend>. The octets of the buffer may be intended to be
807 interpreted as either UTF-8 or Latin-1, as indicated by L</lex_bufutf8>.
809 Lexing code (whether in the Perl core or not) moves this pointer past
810 the characters that it consumes. It is also expected to perform some
811 bookkeeping whenever a newline character is consumed. This movement
812 can be more conveniently performed by the function L</lex_read_to>,
813 which handles newlines appropriately.
815 Interpretation of the buffer's octets can be abstracted out by
816 using the slightly higher-level functions L</lex_peek_unichar> and
817 L</lex_read_unichar>.
819 =for apidoc AmxU|char *|PL_parser-E<gt>linestart
821 Points to the start of the current line inside the lexer buffer.
822 This is useful for indicating at which column an error occurred, and
823 not much else. This must be updated by any lexing code that consumes
824 a newline; the function L</lex_read_to> handles this detail.
830 =for apidoc Amx|bool|lex_bufutf8
832 Indicates whether the octets in the lexer buffer
833 (L</PL_parser-E<gt>linestr>) should be interpreted as the UTF-8 encoding
834 of Unicode characters. If not, they should be interpreted as Latin-1
835 characters. This is analogous to the C<SvUTF8> flag for scalars.
837 In UTF-8 mode, it is not guaranteed that the lexer buffer actually
838 contains valid UTF-8. Lexing code must be robust in the face of invalid
841 The actual C<SvUTF8> flag of the L</PL_parser-E<gt>linestr> scalar
842 is significant, but not the whole story regarding the input character
843 encoding. Normally, when a file is being read, the scalar contains octets
844 and its C<SvUTF8> flag is off, but the octets should be interpreted as
845 UTF-8 if the C<use utf8> pragma is in effect. During a string eval,
846 however, the scalar may have the C<SvUTF8> flag on, and in this case its
847 octets should be interpreted as UTF-8 unless the C<use bytes> pragma
848 is in effect. This logic may change in the future; use this function
849 instead of implementing the logic yourself.
855 Perl_lex_bufutf8(pTHX)
861 =for apidoc Amx|char *|lex_grow_linestr|STRLEN len
863 Reallocates the lexer buffer (L</PL_parser-E<gt>linestr>) to accommodate
864 at least I<len> octets (including terminating NUL). Returns a
865 pointer to the reallocated buffer. This is necessary before making
866 any direct modification of the buffer that would increase its length.
867 L</lex_stuff_pvn> provides a more convenient way to insert text into
870 Do not use C<SvGROW> or C<sv_grow> directly on C<PL_parser-E<gt>linestr>;
871 this function updates all of the lexer's variables that point directly
878 Perl_lex_grow_linestr(pTHX_ STRLEN len)
882 STRLEN bufend_pos, bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
883 STRLEN linestart_pos, last_uni_pos, last_lop_pos;
884 linestr = PL_parser->linestr;
885 buf = SvPVX(linestr);
886 if (len <= SvLEN(linestr))
888 bufend_pos = PL_parser->bufend - buf;
889 bufptr_pos = PL_parser->bufptr - buf;
890 oldbufptr_pos = PL_parser->oldbufptr - buf;
891 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
892 linestart_pos = PL_parser->linestart - buf;
893 last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
894 last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
895 buf = sv_grow(linestr, len);
896 PL_parser->bufend = buf + bufend_pos;
897 PL_parser->bufptr = buf + bufptr_pos;
898 PL_parser->oldbufptr = buf + oldbufptr_pos;
899 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
900 PL_parser->linestart = buf + linestart_pos;
901 if (PL_parser->last_uni)
902 PL_parser->last_uni = buf + last_uni_pos;
903 if (PL_parser->last_lop)
904 PL_parser->last_lop = buf + last_lop_pos;
909 =for apidoc Amx|void|lex_stuff_pvn|const char *pv|STRLEN len|U32 flags
911 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
912 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
913 reallocating the buffer if necessary. This means that lexing code that
914 runs later will see the characters as if they had appeared in the input.
915 It is not recommended to do this as part of normal parsing, and most
916 uses of this facility run the risk of the inserted characters being
917 interpreted in an unintended manner.
919 The string to be inserted is represented by I<len> octets starting
920 at I<pv>. These octets are interpreted as either UTF-8 or Latin-1,
921 according to whether the C<LEX_STUFF_UTF8> flag is set in I<flags>.
922 The characters are recoded for the lexer buffer, according to how the
923 buffer is currently being interpreted (L</lex_bufutf8>). If a string
924 to be inserted is available as a Perl scalar, the L</lex_stuff_sv>
925 function is more convenient.
931 Perl_lex_stuff_pvn(pTHX_ const char *pv, STRLEN len, U32 flags)
935 PERL_ARGS_ASSERT_LEX_STUFF_PVN;
936 if (flags & ~(LEX_STUFF_UTF8))
937 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_pvn");
939 if (flags & LEX_STUFF_UTF8) {
943 const char *p, *e = pv+len;
944 for (p = pv; p != e; p++)
945 highhalf += !!(((U8)*p) & 0x80);
948 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len+highhalf);
949 bufptr = PL_parser->bufptr;
950 Move(bufptr, bufptr+len+highhalf, PL_parser->bufend+1-bufptr, char);
951 SvCUR_set(PL_parser->linestr,
952 SvCUR(PL_parser->linestr) + len+highhalf);
953 PL_parser->bufend += len+highhalf;
954 for (p = pv; p != e; p++) {
957 *bufptr++ = (char)(0xc0 | (c >> 6));
958 *bufptr++ = (char)(0x80 | (c & 0x3f));
965 if (flags & LEX_STUFF_UTF8) {
967 const char *p, *e = pv+len;
968 for (p = pv; p != e; p++) {
971 Perl_croak(aTHX_ "Lexing code attempted to stuff "
972 "non-Latin-1 character into Latin-1 input");
973 } else if (c >= 0xc2 && p+1 != e &&
974 (((U8)p[1]) & 0xc0) == 0x80) {
977 } else if (c >= 0x80) {
978 /* malformed UTF-8 */
980 SAVESPTR(PL_warnhook);
981 PL_warnhook = PERL_WARNHOOK_FATAL;
982 utf8n_to_uvuni((U8*)p, e-p, NULL, 0);
988 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len-highhalf);
989 bufptr = PL_parser->bufptr;
990 Move(bufptr, bufptr+len-highhalf, PL_parser->bufend+1-bufptr, char);
991 SvCUR_set(PL_parser->linestr,
992 SvCUR(PL_parser->linestr) + len-highhalf);
993 PL_parser->bufend += len-highhalf;
994 for (p = pv; p != e; p++) {
997 *bufptr++ = (char)(((c & 0x3) << 6) | (p[1] & 0x3f));
1000 *bufptr++ = (char)c;
1005 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len);
1006 bufptr = PL_parser->bufptr;
1007 Move(bufptr, bufptr+len, PL_parser->bufend+1-bufptr, char);
1008 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) + len);
1009 PL_parser->bufend += len;
1010 Copy(pv, bufptr, len, char);
1016 =for apidoc Amx|void|lex_stuff_pv|const char *pv|U32 flags
1018 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1019 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
1020 reallocating the buffer if necessary. This means that lexing code that
1021 runs later will see the characters as if they had appeared in the input.
1022 It is not recommended to do this as part of normal parsing, and most
1023 uses of this facility run the risk of the inserted characters being
1024 interpreted in an unintended manner.
1026 The string to be inserted is represented by octets starting at I<pv>
1027 and continuing to the first nul. These octets are interpreted as either
1028 UTF-8 or Latin-1, according to whether the C<LEX_STUFF_UTF8> flag is set
1029 in I<flags>. The characters are recoded for the lexer buffer, according
1030 to how the buffer is currently being interpreted (L</lex_bufutf8>).
1031 If it is not convenient to nul-terminate a string to be inserted, the
1032 L</lex_stuff_pvn> function is more appropriate.
1038 Perl_lex_stuff_pv(pTHX_ const char *pv, U32 flags)
1040 PERL_ARGS_ASSERT_LEX_STUFF_PV;
1041 lex_stuff_pvn(pv, strlen(pv), flags);
1045 =for apidoc Amx|void|lex_stuff_sv|SV *sv|U32 flags
1047 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1048 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
1049 reallocating the buffer if necessary. This means that lexing code that
1050 runs later will see the characters as if they had appeared in the input.
1051 It is not recommended to do this as part of normal parsing, and most
1052 uses of this facility run the risk of the inserted characters being
1053 interpreted in an unintended manner.
1055 The string to be inserted is the string value of I<sv>. The characters
1056 are recoded for the lexer buffer, according to how the buffer is currently
1057 being interpreted (L</lex_bufutf8>). If a string to be inserted is
1058 not already a Perl scalar, the L</lex_stuff_pvn> function avoids the
1059 need to construct a scalar.
1065 Perl_lex_stuff_sv(pTHX_ SV *sv, U32 flags)
1069 PERL_ARGS_ASSERT_LEX_STUFF_SV;
1071 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_sv");
1073 lex_stuff_pvn(pv, len, flags | (SvUTF8(sv) ? LEX_STUFF_UTF8 : 0));
1077 =for apidoc Amx|void|lex_unstuff|char *ptr
1079 Discards text about to be lexed, from L</PL_parser-E<gt>bufptr> up to
1080 I<ptr>. Text following I<ptr> will be moved, and the buffer shortened.
1081 This hides the discarded text from any lexing code that runs later,
1082 as if the text had never appeared.
1084 This is not the normal way to consume lexed text. For that, use
1091 Perl_lex_unstuff(pTHX_ char *ptr)
1095 PERL_ARGS_ASSERT_LEX_UNSTUFF;
1096 buf = PL_parser->bufptr;
1098 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1101 bufend = PL_parser->bufend;
1103 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1104 unstuff_len = ptr - buf;
1105 Move(ptr, buf, bufend+1-ptr, char);
1106 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - unstuff_len);
1107 PL_parser->bufend = bufend - unstuff_len;
1111 =for apidoc Amx|void|lex_read_to|char *ptr
1113 Consume text in the lexer buffer, from L</PL_parser-E<gt>bufptr> up
1114 to I<ptr>. This advances L</PL_parser-E<gt>bufptr> to match I<ptr>,
1115 performing the correct bookkeeping whenever a newline character is passed.
1116 This is the normal way to consume lexed text.
1118 Interpretation of the buffer's octets can be abstracted out by
1119 using the slightly higher-level functions L</lex_peek_unichar> and
1120 L</lex_read_unichar>.
1126 Perl_lex_read_to(pTHX_ char *ptr)
1129 PERL_ARGS_ASSERT_LEX_READ_TO;
1130 s = PL_parser->bufptr;
1131 if (ptr < s || ptr > PL_parser->bufend)
1132 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_to");
1133 for (; s != ptr; s++)
1135 CopLINE_inc(PL_curcop);
1136 PL_parser->linestart = s+1;
1138 PL_parser->bufptr = ptr;
1142 =for apidoc Amx|void|lex_discard_to|char *ptr
1144 Discards the first part of the L</PL_parser-E<gt>linestr> buffer,
1145 up to I<ptr>. The remaining content of the buffer will be moved, and
1146 all pointers into the buffer updated appropriately. I<ptr> must not
1147 be later in the buffer than the position of L</PL_parser-E<gt>bufptr>:
1148 it is not permitted to discard text that has yet to be lexed.
1150 Normally it is not necessarily to do this directly, because it suffices to
1151 use the implicit discarding behaviour of L</lex_next_chunk> and things
1152 based on it. However, if a token stretches across multiple lines,
1153 and the lexing code has kept multiple lines of text in the buffer for
1154 that purpose, then after completion of the token it would be wise to
1155 explicitly discard the now-unneeded earlier lines, to avoid future
1156 multi-line tokens growing the buffer without bound.
1162 Perl_lex_discard_to(pTHX_ char *ptr)
1166 PERL_ARGS_ASSERT_LEX_DISCARD_TO;
1167 buf = SvPVX(PL_parser->linestr);
1169 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1172 if (ptr > PL_parser->bufptr)
1173 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1174 discard_len = ptr - buf;
1175 if (PL_parser->oldbufptr < ptr)
1176 PL_parser->oldbufptr = ptr;
1177 if (PL_parser->oldoldbufptr < ptr)
1178 PL_parser->oldoldbufptr = ptr;
1179 if (PL_parser->last_uni && PL_parser->last_uni < ptr)
1180 PL_parser->last_uni = NULL;
1181 if (PL_parser->last_lop && PL_parser->last_lop < ptr)
1182 PL_parser->last_lop = NULL;
1183 Move(ptr, buf, PL_parser->bufend+1-ptr, char);
1184 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - discard_len);
1185 PL_parser->bufend -= discard_len;
1186 PL_parser->bufptr -= discard_len;
1187 PL_parser->oldbufptr -= discard_len;
1188 PL_parser->oldoldbufptr -= discard_len;
1189 if (PL_parser->last_uni)
1190 PL_parser->last_uni -= discard_len;
1191 if (PL_parser->last_lop)
1192 PL_parser->last_lop -= discard_len;
1196 =for apidoc Amx|bool|lex_next_chunk|U32 flags
1198 Reads in the next chunk of text to be lexed, appending it to
1199 L</PL_parser-E<gt>linestr>. This should be called when lexing code has
1200 looked to the end of the current chunk and wants to know more. It is
1201 usual, but not necessary, for lexing to have consumed the entirety of
1202 the current chunk at this time.
1204 If L</PL_parser-E<gt>bufptr> is pointing to the very end of the current
1205 chunk (i.e., the current chunk has been entirely consumed), normally the
1206 current chunk will be discarded at the same time that the new chunk is
1207 read in. If I<flags> includes C<LEX_KEEP_PREVIOUS>, the current chunk
1208 will not be discarded. If the current chunk has not been entirely
1209 consumed, then it will not be discarded regardless of the flag.
1211 Returns true if some new text was added to the buffer, or false if the
1212 buffer has reached the end of the input text.
1217 #define LEX_FAKE_EOF 0x80000000
1220 Perl_lex_next_chunk(pTHX_ U32 flags)
1224 STRLEN old_bufend_pos, new_bufend_pos;
1225 STRLEN bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
1226 STRLEN linestart_pos, last_uni_pos, last_lop_pos;
1227 bool got_some_for_debugger = 0;
1229 if (flags & ~(LEX_KEEP_PREVIOUS|LEX_FAKE_EOF))
1230 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_next_chunk");
1231 linestr = PL_parser->linestr;
1232 buf = SvPVX(linestr);
1233 if (!(flags & LEX_KEEP_PREVIOUS) &&
1234 PL_parser->bufptr == PL_parser->bufend) {
1235 old_bufend_pos = bufptr_pos = oldbufptr_pos = oldoldbufptr_pos = 0;
1237 if (PL_parser->last_uni != PL_parser->bufend)
1238 PL_parser->last_uni = NULL;
1239 if (PL_parser->last_lop != PL_parser->bufend)
1240 PL_parser->last_lop = NULL;
1241 last_uni_pos = last_lop_pos = 0;
1245 old_bufend_pos = PL_parser->bufend - buf;
1246 bufptr_pos = PL_parser->bufptr - buf;
1247 oldbufptr_pos = PL_parser->oldbufptr - buf;
1248 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
1249 linestart_pos = PL_parser->linestart - buf;
1250 last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
1251 last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
1253 if (flags & LEX_FAKE_EOF) {
1255 } else if (!PL_parser->rsfp) {
1257 } else if (filter_gets(linestr, old_bufend_pos)) {
1259 got_some_for_debugger = 1;
1261 if (!SvPOK(linestr)) /* can get undefined by filter_gets */
1262 sv_setpvs(linestr, "");
1264 /* End of real input. Close filehandle (unless it was STDIN),
1265 * then add implicit termination.
1267 if ((PerlIO*)PL_parser->rsfp == PerlIO_stdin())
1268 PerlIO_clearerr(PL_parser->rsfp);
1269 else if (PL_parser->rsfp)
1270 (void)PerlIO_close(PL_parser->rsfp);
1271 PL_parser->rsfp = NULL;
1272 PL_parser->in_pod = 0;
1274 if (PL_madskills && !PL_in_eval && (PL_minus_p || PL_minus_n))
1277 if (!PL_in_eval && PL_minus_p) {
1279 /*{*/";}continue{print or die qq(-p destination: $!\\n);}");
1280 PL_minus_n = PL_minus_p = 0;
1281 } else if (!PL_in_eval && PL_minus_n) {
1282 sv_catpvs(linestr, /*{*/";}");
1285 sv_catpvs(linestr, ";");
1288 buf = SvPVX(linestr);
1289 new_bufend_pos = SvCUR(linestr);
1290 PL_parser->bufend = buf + new_bufend_pos;
1291 PL_parser->bufptr = buf + bufptr_pos;
1292 PL_parser->oldbufptr = buf + oldbufptr_pos;
1293 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
1294 PL_parser->linestart = buf + linestart_pos;
1295 if (PL_parser->last_uni)
1296 PL_parser->last_uni = buf + last_uni_pos;
1297 if (PL_parser->last_lop)
1298 PL_parser->last_lop = buf + last_lop_pos;
1299 if (got_some_for_debugger && (PERLDB_LINE || PERLDB_SAVESRC) &&
1300 PL_curstash != PL_debstash) {
1301 /* debugger active and we're not compiling the debugger code,
1302 * so store the line into the debugger's array of lines
1304 update_debugger_info(NULL, buf+old_bufend_pos,
1305 new_bufend_pos-old_bufend_pos);
1311 =for apidoc Amx|I32|lex_peek_unichar|U32 flags
1313 Looks ahead one (Unicode) character in the text currently being lexed.
1314 Returns the codepoint (unsigned integer value) of the next character,
1315 or -1 if lexing has reached the end of the input text. To consume the
1316 peeked character, use L</lex_read_unichar>.
1318 If the next character is in (or extends into) the next chunk of input
1319 text, the next chunk will be read in. Normally the current chunk will be
1320 discarded at the same time, but if I<flags> includes C<LEX_KEEP_PREVIOUS>
1321 then the current chunk will not be discarded.
1323 If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1324 is encountered, an exception is generated.
1330 Perl_lex_peek_unichar(pTHX_ U32 flags)
1334 if (flags & ~(LEX_KEEP_PREVIOUS))
1335 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_peek_unichar");
1336 s = PL_parser->bufptr;
1337 bufend = PL_parser->bufend;
1343 if (!lex_next_chunk(flags))
1345 s = PL_parser->bufptr;
1346 bufend = PL_parser->bufend;
1352 len = PL_utf8skip[head];
1353 while ((STRLEN)(bufend-s) < len) {
1354 if (!lex_next_chunk(flags | LEX_KEEP_PREVIOUS))
1356 s = PL_parser->bufptr;
1357 bufend = PL_parser->bufend;
1360 unichar = utf8n_to_uvuni((U8*)s, bufend-s, &retlen, UTF8_CHECK_ONLY);
1361 if (retlen == (STRLEN)-1) {
1362 /* malformed UTF-8 */
1364 SAVESPTR(PL_warnhook);
1365 PL_warnhook = PERL_WARNHOOK_FATAL;
1366 utf8n_to_uvuni((U8*)s, bufend-s, NULL, 0);
1372 if (!lex_next_chunk(flags))
1374 s = PL_parser->bufptr;
1381 =for apidoc Amx|I32|lex_read_unichar|U32 flags
1383 Reads the next (Unicode) character in the text currently being lexed.
1384 Returns the codepoint (unsigned integer value) of the character read,
1385 and moves L</PL_parser-E<gt>bufptr> past the character, or returns -1
1386 if lexing has reached the end of the input text. To non-destructively
1387 examine the next character, use L</lex_peek_unichar> instead.
1389 If the next character is in (or extends into) the next chunk of input
1390 text, the next chunk will be read in. Normally the current chunk will be
1391 discarded at the same time, but if I<flags> includes C<LEX_KEEP_PREVIOUS>
1392 then the current chunk will not be discarded.
1394 If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1395 is encountered, an exception is generated.
1401 Perl_lex_read_unichar(pTHX_ U32 flags)
1404 if (flags & ~(LEX_KEEP_PREVIOUS))
1405 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_unichar");
1406 c = lex_peek_unichar(flags);
1409 CopLINE_inc(PL_curcop);
1410 PL_parser->bufptr += UTF8SKIP(PL_parser->bufptr);
1416 =for apidoc Amx|void|lex_read_space|U32 flags
1418 Reads optional spaces, in Perl style, in the text currently being
1419 lexed. The spaces may include ordinary whitespace characters and
1420 Perl-style comments. C<#line> directives are processed if encountered.
1421 L</PL_parser-E<gt>bufptr> is moved past the spaces, so that it points
1422 at a non-space character (or the end of the input text).
1424 If spaces extend into the next chunk of input text, the next chunk will
1425 be read in. Normally the current chunk will be discarded at the same
1426 time, but if I<flags> includes C<LEX_KEEP_PREVIOUS> then the current
1427 chunk will not be discarded.
1432 #define LEX_NO_NEXT_CHUNK 0x80000000
1435 Perl_lex_read_space(pTHX_ U32 flags)
1438 bool need_incline = 0;
1439 if (flags & ~(LEX_KEEP_PREVIOUS|LEX_NO_NEXT_CHUNK))
1440 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_space");
1443 sv_free(PL_skipwhite);
1444 PL_skipwhite = NULL;
1447 PL_skipwhite = newSVpvs("");
1448 #endif /* PERL_MAD */
1449 s = PL_parser->bufptr;
1450 bufend = PL_parser->bufend;
1456 } while (!(c == '\n' || (c == 0 && s == bufend)));
1457 } else if (c == '\n') {
1459 PL_parser->linestart = s;
1464 } else if (isSPACE(c)) {
1466 } else if (c == 0 && s == bufend) {
1470 sv_catpvn(PL_skipwhite, PL_parser->bufptr, s-PL_parser->bufptr);
1471 #endif /* PERL_MAD */
1472 if (flags & LEX_NO_NEXT_CHUNK)
1474 PL_parser->bufptr = s;
1475 CopLINE_inc(PL_curcop);
1476 got_more = lex_next_chunk(flags);
1477 CopLINE_dec(PL_curcop);
1478 s = PL_parser->bufptr;
1479 bufend = PL_parser->bufend;
1482 if (need_incline && PL_parser->rsfp) {
1492 sv_catpvn(PL_skipwhite, PL_parser->bufptr, s-PL_parser->bufptr);
1493 #endif /* PERL_MAD */
1494 PL_parser->bufptr = s;
1499 * This subroutine has nothing to do with tilting, whether at windmills
1500 * or pinball tables. Its name is short for "increment line". It
1501 * increments the current line number in CopLINE(PL_curcop) and checks
1502 * to see whether the line starts with a comment of the form
1503 * # line 500 "foo.pm"
1504 * If so, it sets the current line number and file to the values in the comment.
1508 S_incline(pTHX_ const char *s)
1515 PERL_ARGS_ASSERT_INCLINE;
1517 CopLINE_inc(PL_curcop);
1520 while (SPACE_OR_TAB(*s))
1522 if (strnEQ(s, "line", 4))
1526 if (SPACE_OR_TAB(*s))
1530 while (SPACE_OR_TAB(*s))
1538 if (!SPACE_OR_TAB(*s) && *s != '\r' && *s != '\n' && *s != '\0')
1540 while (SPACE_OR_TAB(*s))
1542 if (*s == '"' && (t = strchr(s+1, '"'))) {
1548 while (!isSPACE(*t))
1552 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
1554 if (*e != '\n' && *e != '\0')
1555 return; /* false alarm */
1558 const STRLEN len = t - s;
1559 #ifndef USE_ITHREADS
1560 SV *const temp_sv = CopFILESV(PL_curcop);
1565 cf = SvPVX(temp_sv);
1566 tmplen = SvCUR(temp_sv);
1572 if (tmplen > 7 && strnEQ(cf, "(eval ", 6)) {
1573 /* must copy *{"::_<(eval N)[oldfilename:L]"}
1574 * to *{"::_<newfilename"} */
1575 /* However, the long form of evals is only turned on by the
1576 debugger - usually they're "(eval %lu)" */
1580 STRLEN tmplen2 = len;
1581 if (tmplen + 2 <= sizeof smallbuf)
1584 Newx(tmpbuf, tmplen + 2, char);
1587 memcpy(tmpbuf + 2, cf, tmplen);
1589 gvp = (GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, FALSE);
1594 if (tmplen2 + 2 <= sizeof smallbuf)
1597 Newx(tmpbuf2, tmplen2 + 2, char);
1599 if (tmpbuf2 != smallbuf || tmpbuf != smallbuf) {
1600 /* Either they malloc'd it, or we malloc'd it,
1601 so no prefix is present in ours. */
1606 memcpy(tmpbuf2 + 2, s, tmplen2);
1609 gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
1611 gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
1612 /* adjust ${"::_<newfilename"} to store the new file name */
1613 GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
1614 GvHV(gv2) = MUTABLE_HV(SvREFCNT_inc(GvHV(*gvp)));
1615 GvAV(gv2) = MUTABLE_AV(SvREFCNT_inc(GvAV(*gvp)));
1618 if (tmpbuf2 != smallbuf) Safefree(tmpbuf2);
1620 if (tmpbuf != smallbuf) Safefree(tmpbuf);
1623 CopFILE_free(PL_curcop);
1624 CopFILE_setn(PL_curcop, s, len);
1626 CopLINE_set(PL_curcop, atoi(n)-1);
1630 /* skip space before PL_thistoken */
1633 S_skipspace0(pTHX_ register char *s)
1635 PERL_ARGS_ASSERT_SKIPSPACE0;
1642 PL_thiswhite = newSVpvs("");
1643 sv_catsv(PL_thiswhite, PL_skipwhite);
1644 sv_free(PL_skipwhite);
1647 PL_realtokenstart = s - SvPVX(PL_linestr);
1651 /* skip space after PL_thistoken */
1654 S_skipspace1(pTHX_ register char *s)
1656 const char *start = s;
1657 I32 startoff = start - SvPVX(PL_linestr);
1659 PERL_ARGS_ASSERT_SKIPSPACE1;
1664 start = SvPVX(PL_linestr) + startoff;
1665 if (!PL_thistoken && PL_realtokenstart >= 0) {
1666 const char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
1667 PL_thistoken = newSVpvn(tstart, start - tstart);
1669 PL_realtokenstart = -1;
1672 PL_nextwhite = newSVpvs("");
1673 sv_catsv(PL_nextwhite, PL_skipwhite);
1674 sv_free(PL_skipwhite);
1681 S_skipspace2(pTHX_ register char *s, SV **svp)
1684 const I32 bufptroff = PL_bufptr - SvPVX(PL_linestr);
1685 const I32 startoff = s - SvPVX(PL_linestr);
1687 PERL_ARGS_ASSERT_SKIPSPACE2;
1690 PL_bufptr = SvPVX(PL_linestr) + bufptroff;
1691 if (!PL_madskills || !svp)
1693 start = SvPVX(PL_linestr) + startoff;
1694 if (!PL_thistoken && PL_realtokenstart >= 0) {
1695 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
1696 PL_thistoken = newSVpvn(tstart, start - tstart);
1697 PL_realtokenstart = -1;
1701 *svp = newSVpvs("");
1702 sv_setsv(*svp, PL_skipwhite);
1703 sv_free(PL_skipwhite);
1712 S_update_debugger_info(pTHX_ SV *orig_sv, const char *const buf, STRLEN len)
1714 AV *av = CopFILEAVx(PL_curcop);
1716 SV * const sv = newSV_type(SVt_PVMG);
1718 sv_setsv(sv, orig_sv);
1720 sv_setpvn(sv, buf, len);
1723 av_store(av, (I32)CopLINE(PL_curcop), sv);
1729 * Called to gobble the appropriate amount and type of whitespace.
1730 * Skips comments as well.
1734 S_skipspace(pTHX_ register char *s)
1738 #endif /* PERL_MAD */
1739 PERL_ARGS_ASSERT_SKIPSPACE;
1742 sv_free(PL_skipwhite);
1743 PL_skipwhite = NULL;
1745 #endif /* PERL_MAD */
1746 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
1747 while (s < PL_bufend && SPACE_OR_TAB(*s))
1750 STRLEN bufptr_pos = PL_bufptr - SvPVX(PL_linestr);
1752 lex_read_space(LEX_KEEP_PREVIOUS |
1753 (PL_sublex_info.sub_inwhat || PL_lex_state == LEX_FORMLINE ?
1754 LEX_NO_NEXT_CHUNK : 0));
1756 PL_bufptr = SvPVX(PL_linestr) + bufptr_pos;
1757 if (PL_linestart > PL_bufptr)
1758 PL_bufptr = PL_linestart;
1763 PL_skipwhite = newSVpvn(start, s-start);
1764 #endif /* PERL_MAD */
1770 * Check the unary operators to ensure there's no ambiguity in how they're
1771 * used. An ambiguous piece of code would be:
1773 * This doesn't mean rand() + 5. Because rand() is a unary operator,
1774 * the +5 is its argument.
1784 if (PL_oldoldbufptr != PL_last_uni)
1786 while (isSPACE(*PL_last_uni))
1789 while (isALNUM_lazy_if(s,UTF) || *s == '-')
1791 if ((t = strchr(s, '(')) && t < PL_bufptr)
1794 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
1795 "Warning: Use of \"%.*s\" without parentheses is ambiguous",
1796 (int)(s - PL_last_uni), PL_last_uni);
1800 * LOP : macro to build a list operator. Its behaviour has been replaced
1801 * with a subroutine, S_lop() for which LOP is just another name.
1804 #define LOP(f,x) return lop(f,x,s)
1808 * Build a list operator (or something that might be one). The rules:
1809 * - if we have a next token, then it's a list operator [why?]
1810 * - if the next thing is an opening paren, then it's a function
1811 * - else it's a list operator
1815 S_lop(pTHX_ I32 f, int x, char *s)
1819 PERL_ARGS_ASSERT_LOP;
1825 PL_last_lop = PL_oldbufptr;
1826 PL_last_lop_op = (OPCODE)f;
1835 return REPORT(FUNC);
1838 return REPORT(FUNC);
1841 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
1842 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
1843 return REPORT(LSTOP);
1850 * Sets up for an eventual force_next(). start_force(0) basically does
1851 * an unshift, while start_force(-1) does a push. yylex removes items
1856 S_start_force(pTHX_ int where)
1860 if (where < 0) /* so people can duplicate start_force(PL_curforce) */
1861 where = PL_lasttoke;
1862 assert(PL_curforce < 0 || PL_curforce == where);
1863 if (PL_curforce != where) {
1864 for (i = PL_lasttoke; i > where; --i) {
1865 PL_nexttoke[i] = PL_nexttoke[i-1];
1869 if (PL_curforce < 0) /* in case of duplicate start_force() */
1870 Zero(&PL_nexttoke[where], 1, NEXTTOKE);
1871 PL_curforce = where;
1874 curmad('^', newSVpvs(""));
1875 CURMAD('_', PL_nextwhite);
1880 S_curmad(pTHX_ char slot, SV *sv)
1886 if (PL_curforce < 0)
1887 where = &PL_thismad;
1889 where = &PL_nexttoke[PL_curforce].next_mad;
1895 if (UTF && is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
1897 else if (PL_encoding) {
1898 sv_recode_to_utf8(sv, PL_encoding);
1903 /* keep a slot open for the head of the list? */
1904 if (slot != '_' && *where && (*where)->mad_key == '^') {
1905 (*where)->mad_key = slot;
1906 sv_free(MUTABLE_SV(((*where)->mad_val)));
1907 (*where)->mad_val = (void*)sv;
1910 addmad(newMADsv(slot, sv), where, 0);
1913 # define start_force(where) NOOP
1914 # define curmad(slot, sv) NOOP
1919 * When the lexer realizes it knows the next token (for instance,
1920 * it is reordering tokens for the parser) then it can call S_force_next
1921 * to know what token to return the next time the lexer is called. Caller
1922 * will need to set PL_nextval[] (or PL_nexttoke[].next_val with PERL_MAD),
1923 * and possibly PL_expect to ensure the lexer handles the token correctly.
1927 S_force_next(pTHX_ I32 type)
1932 PerlIO_printf(Perl_debug_log, "### forced token:\n");
1933 tokereport(type, &NEXTVAL_NEXTTOKE);
1937 if (PL_curforce < 0)
1938 start_force(PL_lasttoke);
1939 PL_nexttoke[PL_curforce].next_type = type;
1940 if (PL_lex_state != LEX_KNOWNEXT)
1941 PL_lex_defer = PL_lex_state;
1942 PL_lex_state = LEX_KNOWNEXT;
1943 PL_lex_expect = PL_expect;
1946 PL_nexttype[PL_nexttoke] = type;
1948 if (PL_lex_state != LEX_KNOWNEXT) {
1949 PL_lex_defer = PL_lex_state;
1950 PL_lex_expect = PL_expect;
1951 PL_lex_state = LEX_KNOWNEXT;
1959 int yyc = PL_parser->yychar;
1960 if (yyc != YYEMPTY) {
1963 NEXTVAL_NEXTTOKE = PL_parser->yylval;
1964 if (yyc == '{'/*}*/ || yyc == HASHBRACK || yyc == '['/*]*/) {
1965 PL_lex_allbrackets--;
1967 yyc |= (3<<24) | (PL_lex_brackstack[PL_lex_brackets] << 16);
1968 } else if (yyc == '('/*)*/) {
1969 PL_lex_allbrackets--;
1974 PL_parser->yychar = YYEMPTY;
1979 S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len)
1982 SV * const sv = newSVpvn_utf8(start, len,
1985 && !is_ascii_string((const U8*)start, len)
1986 && is_utf8_string((const U8*)start, len));
1992 * When the lexer knows the next thing is a word (for instance, it has
1993 * just seen -> and it knows that the next char is a word char, then
1994 * it calls S_force_word to stick the next word into the PL_nexttoke/val
1998 * char *start : buffer position (must be within PL_linestr)
1999 * int token : PL_next* will be this type of bare word (e.g., METHOD,WORD)
2000 * int check_keyword : if true, Perl checks to make sure the word isn't
2001 * a keyword (do this if the word is a label, e.g. goto FOO)
2002 * int allow_pack : if true, : characters will also be allowed (require,
2003 * use, etc. do this)
2004 * int allow_initial_tick : used by the "sub" lexer only.
2008 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
2014 PERL_ARGS_ASSERT_FORCE_WORD;
2016 start = SKIPSPACE1(start);
2018 if (isIDFIRST_lazy_if(s,UTF) ||
2019 (allow_pack && *s == ':') ||
2020 (allow_initial_tick && *s == '\'') )
2022 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
2023 if (check_keyword && keyword(PL_tokenbuf, len, 0))
2025 start_force(PL_curforce);
2027 curmad('X', newSVpvn(start,s-start));
2028 if (token == METHOD) {
2033 PL_expect = XOPERATOR;
2037 curmad('g', newSVpvs( "forced" ));
2038 NEXTVAL_NEXTTOKE.opval
2039 = (OP*)newSVOP(OP_CONST,0,
2040 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
2041 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
2049 * Called when the lexer wants $foo *foo &foo etc, but the program
2050 * text only contains the "foo" portion. The first argument is a pointer
2051 * to the "foo", and the second argument is the type symbol to prefix.
2052 * Forces the next token to be a "WORD".
2053 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
2057 S_force_ident(pTHX_ register const char *s, int kind)
2061 PERL_ARGS_ASSERT_FORCE_IDENT;
2064 const STRLEN len = strlen(s);
2065 OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn(s, len));
2066 start_force(PL_curforce);
2067 NEXTVAL_NEXTTOKE.opval = o;
2070 o->op_private = OPpCONST_ENTERED;
2071 /* XXX see note in pp_entereval() for why we forgo typo
2072 warnings if the symbol must be introduced in an eval.
2074 gv_fetchpvn_flags(s, len,
2075 PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL)
2077 kind == '$' ? SVt_PV :
2078 kind == '@' ? SVt_PVAV :
2079 kind == '%' ? SVt_PVHV :
2087 Perl_str_to_version(pTHX_ SV *sv)
2092 const char *start = SvPV_const(sv,len);
2093 const char * const end = start + len;
2094 const bool utf = SvUTF8(sv) ? TRUE : FALSE;
2096 PERL_ARGS_ASSERT_STR_TO_VERSION;
2098 while (start < end) {
2102 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
2107 retval += ((NV)n)/nshift;
2116 * Forces the next token to be a version number.
2117 * If the next token appears to be an invalid version number, (e.g. "v2b"),
2118 * and if "guessing" is TRUE, then no new token is created (and the caller
2119 * must use an alternative parsing method).
2123 S_force_version(pTHX_ char *s, int guessing)
2129 I32 startoff = s - SvPVX(PL_linestr);
2132 PERL_ARGS_ASSERT_FORCE_VERSION;
2140 while (isDIGIT(*d) || *d == '_' || *d == '.')
2144 start_force(PL_curforce);
2145 curmad('X', newSVpvn(s,d-s));
2148 if (*d == ';' || isSPACE(*d) || *d == '{' || *d == '}' || !*d) {
2150 #ifdef USE_LOCALE_NUMERIC
2151 char *loc = setlocale(LC_NUMERIC, "C");
2153 s = scan_num(s, &pl_yylval);
2154 #ifdef USE_LOCALE_NUMERIC
2155 setlocale(LC_NUMERIC, loc);
2157 version = pl_yylval.opval;
2158 ver = cSVOPx(version)->op_sv;
2159 if (SvPOK(ver) && !SvNIOK(ver)) {
2160 SvUPGRADE(ver, SVt_PVNV);
2161 SvNV_set(ver, str_to_version(ver));
2162 SvNOK_on(ver); /* hint that it is a version */
2165 else if (guessing) {
2168 sv_free(PL_nextwhite); /* let next token collect whitespace */
2170 s = SvPVX(PL_linestr) + startoff;
2178 if (PL_madskills && !version) {
2179 sv_free(PL_nextwhite); /* let next token collect whitespace */
2181 s = SvPVX(PL_linestr) + startoff;
2184 /* NOTE: The parser sees the package name and the VERSION swapped */
2185 start_force(PL_curforce);
2186 NEXTVAL_NEXTTOKE.opval = version;
2193 * S_force_strict_version
2194 * Forces the next token to be a version number using strict syntax rules.
2198 S_force_strict_version(pTHX_ char *s)
2203 I32 startoff = s - SvPVX(PL_linestr);
2205 const char *errstr = NULL;
2207 PERL_ARGS_ASSERT_FORCE_STRICT_VERSION;
2209 while (isSPACE(*s)) /* leading whitespace */
2212 if (is_STRICT_VERSION(s,&errstr)) {
2214 s = (char *)scan_version(s, ver, 0);
2215 version = newSVOP(OP_CONST, 0, ver);
2217 else if ( (*s != ';' && *s != '{' && *s != '}' ) &&
2218 (s = SKIPSPACE1(s), (*s != ';' && *s != '{' && *s != '}' )))
2222 yyerror(errstr); /* version required */
2227 if (PL_madskills && !version) {
2228 sv_free(PL_nextwhite); /* let next token collect whitespace */
2230 s = SvPVX(PL_linestr) + startoff;
2233 /* NOTE: The parser sees the package name and the VERSION swapped */
2234 start_force(PL_curforce);
2235 NEXTVAL_NEXTTOKE.opval = version;
2243 * Tokenize a quoted string passed in as an SV. It finds the next
2244 * chunk, up to end of string or a backslash. It may make a new
2245 * SV containing that chunk (if HINT_NEW_STRING is on). It also
2250 S_tokeq(pTHX_ SV *sv)
2254 register char *send;
2259 PERL_ARGS_ASSERT_TOKEQ;
2264 s = SvPV_force(sv, len);
2265 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
2268 /* This is relying on the SV being "well formed" with a trailing '\0' */
2269 while (s < send && !(*s == '\\' && s[1] == '\\'))
2274 if ( PL_hints & HINT_NEW_STRING ) {
2275 pv = newSVpvn_flags(SvPVX_const(pv), len, SVs_TEMP | SvUTF8(sv));
2279 if (s + 1 < send && (s[1] == '\\'))
2280 s++; /* all that, just for this */
2285 SvCUR_set(sv, d - SvPVX_const(sv));
2287 if ( PL_hints & HINT_NEW_STRING )
2288 return new_constant(NULL, 0, "q", sv, pv, "q", 1);
2293 * Now come three functions related to double-quote context,
2294 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
2295 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
2296 * interact with PL_lex_state, and create fake ( ... ) argument lists
2297 * to handle functions and concatenation.
2298 * They assume that whoever calls them will be setting up a fake
2299 * join call, because each subthing puts a ',' after it. This lets
2302 * join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
2304 * (I'm not sure whether the spurious commas at the end of lcfirst's
2305 * arguments and join's arguments are created or not).
2310 * Assumes that pl_yylval.ival is the op we're creating (e.g. OP_LCFIRST).
2312 * Pattern matching will set PL_lex_op to the pattern-matching op to
2313 * make (we return THING if pl_yylval.ival is OP_NULL, PMFUNC otherwise).
2315 * OP_CONST and OP_READLINE are easy--just make the new op and return.
2317 * Everything else becomes a FUNC.
2319 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
2320 * had an OP_CONST or OP_READLINE). This just sets us up for a
2321 * call to S_sublex_push().
2325 S_sublex_start(pTHX)
2328 register const I32 op_type = pl_yylval.ival;
2330 if (op_type == OP_NULL) {
2331 pl_yylval.opval = PL_lex_op;
2335 if (op_type == OP_CONST || op_type == OP_READLINE) {
2336 SV *sv = tokeq(PL_lex_stuff);
2338 if (SvTYPE(sv) == SVt_PVIV) {
2339 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
2341 const char * const p = SvPV_const(sv, len);
2342 SV * const nsv = newSVpvn_flags(p, len, SvUTF8(sv));
2346 pl_yylval.opval = (OP*)newSVOP(op_type, 0, sv);
2347 PL_lex_stuff = NULL;
2348 /* Allow <FH> // "foo" */
2349 if (op_type == OP_READLINE)
2350 PL_expect = XTERMORDORDOR;
2353 else if (op_type == OP_BACKTICK && PL_lex_op) {
2354 /* readpipe() vas overriden */
2355 cSVOPx(cLISTOPx(cUNOPx(PL_lex_op)->op_first)->op_first->op_sibling)->op_sv = tokeq(PL_lex_stuff);
2356 pl_yylval.opval = PL_lex_op;
2358 PL_lex_stuff = NULL;
2362 PL_sublex_info.super_state = PL_lex_state;
2363 PL_sublex_info.sub_inwhat = (U16)op_type;
2364 PL_sublex_info.sub_op = PL_lex_op;
2365 PL_lex_state = LEX_INTERPPUSH;
2369 pl_yylval.opval = PL_lex_op;
2379 * Create a new scope to save the lexing state. The scope will be
2380 * ended in S_sublex_done. Returns a '(', starting the function arguments
2381 * to the uc, lc, etc. found before.
2382 * Sets PL_lex_state to LEX_INTERPCONCAT.
2391 PL_lex_state = PL_sublex_info.super_state;
2392 SAVEBOOL(PL_lex_dojoin);
2393 SAVEI32(PL_lex_brackets);
2394 SAVEI32(PL_lex_allbrackets);
2395 SAVEI8(PL_lex_fakeeof);
2396 SAVEI32(PL_lex_casemods);
2397 SAVEI32(PL_lex_starts);
2398 SAVEI8(PL_lex_state);
2399 SAVEVPTR(PL_lex_inpat);
2400 SAVEI16(PL_lex_inwhat);
2401 SAVECOPLINE(PL_curcop);
2402 SAVEPPTR(PL_bufptr);
2403 SAVEPPTR(PL_bufend);
2404 SAVEPPTR(PL_oldbufptr);
2405 SAVEPPTR(PL_oldoldbufptr);
2406 SAVEPPTR(PL_last_lop);
2407 SAVEPPTR(PL_last_uni);
2408 SAVEPPTR(PL_linestart);
2409 SAVESPTR(PL_linestr);
2410 SAVEGENERICPV(PL_lex_brackstack);
2411 SAVEGENERICPV(PL_lex_casestack);
2413 PL_linestr = PL_lex_stuff;
2414 PL_lex_stuff = NULL;
2416 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
2417 = SvPVX(PL_linestr);
2418 PL_bufend += SvCUR(PL_linestr);
2419 PL_last_lop = PL_last_uni = NULL;
2420 SAVEFREESV(PL_linestr);
2422 PL_lex_dojoin = FALSE;
2423 PL_lex_brackets = 0;
2424 PL_lex_allbrackets = 0;
2425 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2426 Newx(PL_lex_brackstack, 120, char);
2427 Newx(PL_lex_casestack, 12, char);
2428 PL_lex_casemods = 0;
2429 *PL_lex_casestack = '\0';
2431 PL_lex_state = LEX_INTERPCONCAT;
2432 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
2434 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
2435 if (PL_lex_inwhat == OP_TRANSR) PL_lex_inwhat = OP_TRANS;
2436 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
2437 PL_lex_inpat = PL_sublex_info.sub_op;
2439 PL_lex_inpat = NULL;
2446 * Restores lexer state after a S_sublex_push.
2453 if (!PL_lex_starts++) {
2454 SV * const sv = newSVpvs("");
2455 if (SvUTF8(PL_linestr))
2457 PL_expect = XOPERATOR;
2458 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2462 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
2463 PL_lex_state = LEX_INTERPCASEMOD;
2467 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
2468 assert(PL_lex_inwhat != OP_TRANSR);
2469 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
2470 PL_linestr = PL_lex_repl;
2472 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
2473 PL_bufend += SvCUR(PL_linestr);
2474 PL_last_lop = PL_last_uni = NULL;
2475 SAVEFREESV(PL_linestr);
2476 PL_lex_dojoin = FALSE;
2477 PL_lex_brackets = 0;
2478 PL_lex_allbrackets = 0;
2479 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2480 PL_lex_casemods = 0;
2481 *PL_lex_casestack = '\0';
2483 if (SvEVALED(PL_lex_repl)) {
2484 PL_lex_state = LEX_INTERPNORMAL;
2486 /* we don't clear PL_lex_repl here, so that we can check later
2487 whether this is an evalled subst; that means we rely on the
2488 logic to ensure sublex_done() is called again only via the
2489 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
2492 PL_lex_state = LEX_INTERPCONCAT;
2502 PL_endwhite = newSVpvs("");
2503 sv_catsv(PL_endwhite, PL_thiswhite);
2507 sv_setpvs(PL_thistoken,"");
2509 PL_realtokenstart = -1;
2513 PL_bufend = SvPVX(PL_linestr);
2514 PL_bufend += SvCUR(PL_linestr);
2515 PL_expect = XOPERATOR;
2516 PL_sublex_info.sub_inwhat = 0;
2524 Extracts a pattern, double-quoted string, or transliteration. This
2527 It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
2528 processing a pattern (PL_lex_inpat is true), a transliteration
2529 (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
2531 Returns a pointer to the character scanned up to. If this is
2532 advanced from the start pointer supplied (i.e. if anything was
2533 successfully parsed), will leave an OP for the substring scanned
2534 in pl_yylval. Caller must intuit reason for not parsing further
2535 by looking at the next characters herself.
2539 constants: \N{NAME} only
2540 case and quoting: \U \Q \E
2541 stops on @ and $, but not for $ as tail anchor
2543 In transliterations:
2544 characters are VERY literal, except for - not at the start or end
2545 of the string, which indicates a range. If the range is in bytes,
2546 scan_const expands the range to the full set of intermediate
2547 characters. If the range is in utf8, the hyphen is replaced with
2548 a certain range mark which will be handled by pmtrans() in op.c.
2550 In double-quoted strings:
2552 double-quoted style: \r and \n
2553 constants: \x31, etc.
2554 deprecated backrefs: \1 (in substitution replacements)
2555 case and quoting: \U \Q \E
2558 scan_const does *not* construct ops to handle interpolated strings.
2559 It stops processing as soon as it finds an embedded $ or @ variable
2560 and leaves it to the caller to work out what's going on.
2562 embedded arrays (whether in pattern or not) could be:
2563 @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
2565 $ in double-quoted strings must be the symbol of an embedded scalar.
2567 $ in pattern could be $foo or could be tail anchor. Assumption:
2568 it's a tail anchor if $ is the last thing in the string, or if it's
2569 followed by one of "()| \r\n\t"
2571 \1 (backreferences) are turned into $1
2573 The structure of the code is
2574 while (there's a character to process) {
2575 handle transliteration ranges
2576 skip regexp comments /(?#comment)/ and codes /(?{code})/
2577 skip #-initiated comments in //x patterns
2578 check for embedded arrays
2579 check for embedded scalars
2581 deprecate \1 in substitution replacements
2582 handle string-changing backslashes \l \U \Q \E, etc.
2583 switch (what was escaped) {
2584 handle \- in a transliteration (becomes a literal -)
2585 if a pattern and not \N{, go treat as regular character
2586 handle \132 (octal characters)
2587 handle \x15 and \x{1234} (hex characters)
2588 handle \N{name} (named characters, also \N{3,5} in a pattern)
2589 handle \cV (control characters)
2590 handle printf-style backslashes (\f, \r, \n, etc)
2593 } (end if backslash)
2594 handle regular character
2595 } (end while character to read)
2600 S_scan_const(pTHX_ char *start)
2603 register char *send = PL_bufend; /* end of the constant */
2604 SV *sv = newSV(send - start); /* sv for the constant. See
2605 note below on sizing. */
2606 register char *s = start; /* start of the constant */
2607 register char *d = SvPVX(sv); /* destination for copies */
2608 bool dorange = FALSE; /* are we in a translit range? */
2609 bool didrange = FALSE; /* did we just finish a range? */
2610 bool has_utf8 = FALSE; /* Output constant is UTF8 */
2611 bool this_utf8 = cBOOL(UTF); /* Is the source string assumed
2612 to be UTF8? But, this can
2613 show as true when the source
2614 isn't utf8, as for example
2615 when it is entirely composed
2618 /* Note on sizing: The scanned constant is placed into sv, which is
2619 * initialized by newSV() assuming one byte of output for every byte of
2620 * input. This routine expects newSV() to allocate an extra byte for a
2621 * trailing NUL, which this routine will append if it gets to the end of
2622 * the input. There may be more bytes of input than output (eg., \N{LATIN
2623 * CAPITAL LETTER A}), or more output than input if the constant ends up
2624 * recoded to utf8, but each time a construct is found that might increase
2625 * the needed size, SvGROW() is called. Its size parameter each time is
2626 * based on the best guess estimate at the time, namely the length used so
2627 * far, plus the length the current construct will occupy, plus room for
2628 * the trailing NUL, plus one byte for every input byte still unscanned */
2632 UV literal_endpoint = 0;
2633 bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */
2636 PERL_ARGS_ASSERT_SCAN_CONST;
2638 assert(PL_lex_inwhat != OP_TRANSR);
2639 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
2640 /* If we are doing a trans and we know we want UTF8 set expectation */
2641 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
2642 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
2646 while (s < send || dorange) {
2648 /* get transliterations out of the way (they're most literal) */
2649 if (PL_lex_inwhat == OP_TRANS) {
2650 /* expand a range A-Z to the full set of characters. AIE! */
2652 I32 i; /* current expanded character */
2653 I32 min; /* first character in range */
2654 I32 max; /* last character in range */
2665 char * const c = (char*)utf8_hop((U8*)d, -1);
2669 *c = (char)UTF_TO_NATIVE(0xff);
2670 /* mark the range as done, and continue */
2676 i = d - SvPVX_const(sv); /* remember current offset */
2679 SvLEN(sv) + (has_utf8 ?
2680 (512 - UTF_CONTINUATION_MARK +
2683 /* How many two-byte within 0..255: 128 in UTF-8,
2684 * 96 in UTF-8-mod. */
2686 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
2688 d = SvPVX(sv) + i; /* refresh d after realloc */
2692 for (j = 0; j <= 1; j++) {
2693 char * const c = (char*)utf8_hop((U8*)d, -1);
2694 const UV uv = utf8n_to_uvchr((U8*)c, d - c, NULL, 0);
2700 max = (U8)0xff; /* only to \xff */
2701 uvmax = uv; /* \x{100} to uvmax */
2703 d = c; /* eat endpoint chars */
2708 d -= 2; /* eat the first char and the - */
2709 min = (U8)*d; /* first char in range */
2710 max = (U8)d[1]; /* last char in range */
2717 "Invalid range \"%c-%c\" in transliteration operator",
2718 (char)min, (char)max);
2722 if (literal_endpoint == 2 &&
2723 ((isLOWER(min) && isLOWER(max)) ||
2724 (isUPPER(min) && isUPPER(max)))) {
2726 for (i = min; i <= max; i++)
2728 *d++ = NATIVE_TO_NEED(has_utf8,i);
2730 for (i = min; i <= max; i++)
2732 *d++ = NATIVE_TO_NEED(has_utf8,i);
2737 for (i = min; i <= max; i++)
2740 const U8 ch = (U8)NATIVE_TO_UTF(i);
2741 if (UNI_IS_INVARIANT(ch))
2744 *d++ = (U8)UTF8_EIGHT_BIT_HI(ch);
2745 *d++ = (U8)UTF8_EIGHT_BIT_LO(ch);
2754 d = (char*)uvchr_to_utf8((U8*)d, 0x100);
2756 *d++ = (char)UTF_TO_NATIVE(0xff);
2758 d = (char*)uvchr_to_utf8((U8*)d, uvmax);
2762 /* mark the range as done, and continue */
2766 literal_endpoint = 0;
2771 /* range begins (ignore - as first or last char) */
2772 else if (*s == '-' && s+1 < send && s != start) {
2774 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
2781 *d++ = (char)UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */
2791 literal_endpoint = 0;
2792 native_range = TRUE;
2797 /* if we get here, we're not doing a transliteration */
2799 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
2800 except for the last char, which will be done separately. */
2801 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
2803 while (s+1 < send && *s != ')')
2804 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2806 else if (s[2] == '{' /* This should match regcomp.c */
2807 || (s[2] == '?' && s[3] == '{'))
2810 char *regparse = s + (s[2] == '{' ? 3 : 4);
2813 while (count && (c = *regparse)) {
2814 if (c == '\\' && regparse[1])
2822 if (*regparse != ')')
2823 regparse--; /* Leave one char for continuation. */
2824 while (s < regparse)
2825 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2829 /* likewise skip #-initiated comments in //x patterns */
2830 else if (*s == '#' && PL_lex_inpat &&
2831 ((PMOP*)PL_lex_inpat)->op_pmflags & RXf_PMf_EXTENDED) {
2832 while (s+1 < send && *s != '\n')
2833 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2836 /* check for embedded arrays
2837 (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
2839 else if (*s == '@' && s[1]) {
2840 if (isALNUM_lazy_if(s+1,UTF))
2842 if (strchr(":'{$", s[1]))
2844 if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
2845 break; /* in regexp, neither @+ nor @- are interpolated */
2848 /* check for embedded scalars. only stop if we're sure it's a
2851 else if (*s == '$') {
2852 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
2854 if (s + 1 < send && !strchr("()| \r\n\t", s[1])) {
2856 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
2857 "Possible unintended interpolation of $\\ in regex");
2859 break; /* in regexp, $ might be tail anchor */
2863 /* End of else if chain - OP_TRANS rejoin rest */
2866 if (*s == '\\' && s+1 < send) {
2867 char* e; /* Can be used for ending '}', etc. */
2871 /* warn on \1 - \9 in substitution replacements, but note that \11
2872 * is an octal; and \19 is \1 followed by '9' */
2873 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
2874 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
2876 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
2881 /* string-change backslash escapes */
2882 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
2886 /* In a pattern, process \N, but skip any other backslash escapes.
2887 * This is because we don't want to translate an escape sequence
2888 * into a meta symbol and have the regex compiler use the meta
2889 * symbol meaning, e.g. \x{2E} would be confused with a dot. But
2890 * in spite of this, we do have to process \N here while the proper
2891 * charnames handler is in scope. See bugs #56444 and #62056.
2892 * There is a complication because \N in a pattern may also stand
2893 * for 'match a non-nl', and not mean a charname, in which case its
2894 * processing should be deferred to the regex compiler. To be a
2895 * charname it must be followed immediately by a '{', and not look
2896 * like \N followed by a curly quantifier, i.e., not something like
2897 * \N{3,}. regcurly returns a boolean indicating if it is a legal
2899 else if (PL_lex_inpat
2902 || regcurly(s + 1)))
2904 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
2905 goto default_action;
2910 /* quoted - in transliterations */
2912 if (PL_lex_inwhat == OP_TRANS) {
2919 if ((isALPHA(*s) || isDIGIT(*s)))
2920 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
2921 "Unrecognized escape \\%c passed through",
2923 /* default action is to copy the quoted character */
2924 goto default_action;
2927 /* eg. \132 indicates the octal constant 0132 */
2928 case '0': case '1': case '2': case '3':
2929 case '4': case '5': case '6': case '7':
2933 uv = NATIVE_TO_UNI(grok_oct(s, &len, &flags, NULL));
2936 goto NUM_ESCAPE_INSERT;
2938 /* eg. \o{24} indicates the octal constant \024 */
2944 bool valid = grok_bslash_o(s, &uv, &len, &error, 1);
2950 goto NUM_ESCAPE_INSERT;
2953 /* eg. \x24 indicates the hex constant 0x24 */
2957 char* const e = strchr(s, '}');
2958 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
2959 PERL_SCAN_DISALLOW_PREFIX;
2964 yyerror("Missing right brace on \\x{}");
2968 uv = NATIVE_TO_UNI(grok_hex(s, &len, &flags, NULL));
2974 I32 flags = PERL_SCAN_DISALLOW_PREFIX;
2975 uv = NATIVE_TO_UNI(grok_hex(s, &len, &flags, NULL));
2981 /* Insert oct or hex escaped character. There will always be
2982 * enough room in sv since such escapes will be longer than any
2983 * UTF-8 sequence they can end up as, except if they force us
2984 * to recode the rest of the string into utf8 */
2986 /* Here uv is the ordinal of the next character being added in
2987 * unicode (converted from native). */
2988 if (!UNI_IS_INVARIANT(uv)) {
2989 if (!has_utf8 && uv > 255) {
2990 /* Might need to recode whatever we have accumulated so
2991 * far if it contains any chars variant in utf8 or
2994 SvCUR_set(sv, d - SvPVX_const(sv));
2997 /* See Note on sizing above. */
2998 sv_utf8_upgrade_flags_grow(sv,
2999 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3000 UNISKIP(uv) + (STRLEN)(send - s) + 1);
3001 d = SvPVX(sv) + SvCUR(sv);
3006 d = (char*)uvuni_to_utf8((U8*)d, uv);
3007 if (PL_lex_inwhat == OP_TRANS &&
3008 PL_sublex_info.sub_op) {
3009 PL_sublex_info.sub_op->op_private |=
3010 (PL_lex_repl ? OPpTRANS_FROM_UTF
3014 if (uv > 255 && !dorange)
3015 native_range = FALSE;
3028 /* In a non-pattern \N must be a named character, like \N{LATIN
3029 * SMALL LETTER A} or \N{U+0041}. For patterns, it also can
3030 * mean to match a non-newline. For non-patterns, named
3031 * characters are converted to their string equivalents. In
3032 * patterns, named characters are not converted to their
3033 * ultimate forms for the same reasons that other escapes
3034 * aren't. Instead, they are converted to the \N{U+...} form
3035 * to get the value from the charnames that is in effect right
3036 * now, while preserving the fact that it was a named character
3037 * so that the regex compiler knows this */
3039 /* This section of code doesn't generally use the
3040 * NATIVE_TO_NEED() macro to transform the input. I (khw) did
3041 * a close examination of this macro and determined it is a
3042 * no-op except on utfebcdic variant characters. Every
3043 * character generated by this that would normally need to be
3044 * enclosed by this macro is invariant, so the macro is not
3045 * needed, and would complicate use of copy(). XXX There are
3046 * other parts of this file where the macro is used
3047 * inconsistently, but are saved by it being a no-op */
3049 /* The structure of this section of code (besides checking for
3050 * errors and upgrading to utf8) is:
3051 * Further disambiguate between the two meanings of \N, and if
3052 * not a charname, go process it elsewhere
3053 * If of form \N{U+...}, pass it through if a pattern;
3054 * otherwise convert to utf8
3055 * Otherwise must be \N{NAME}: convert to \N{U+c1.c2...} if a
3056 * pattern; otherwise convert to utf8 */
3058 /* Here, s points to the 'N'; the test below is guaranteed to
3059 * succeed if we are being called on a pattern as we already
3060 * know from a test above that the next character is a '{'.
3061 * On a non-pattern \N must mean 'named sequence, which
3062 * requires braces */
3065 yyerror("Missing braces on \\N{}");
3070 /* If there is no matching '}', it is an error. */
3071 if (! (e = strchr(s, '}'))) {
3072 if (! PL_lex_inpat) {
3073 yyerror("Missing right brace on \\N{}");
3075 yyerror("Missing right brace on \\N{} or unescaped left brace after \\N.");
3080 /* Here it looks like a named character */
3084 /* XXX This block is temporary code. \N{} implies that the
3085 * pattern is to have Unicode semantics, and therefore
3086 * currently has to be encoded in utf8. By putting it in
3087 * utf8 now, we save a whole pass in the regular expression
3088 * compiler. Once that code is changed so Unicode
3089 * semantics doesn't necessarily have to be in utf8, this
3090 * block should be removed. However, the code that parses
3091 * the output of this would have to be changed to not
3092 * necessarily expect utf8 */
3094 SvCUR_set(sv, d - SvPVX_const(sv));
3097 /* See Note on sizing above. */
3098 sv_utf8_upgrade_flags_grow(sv,
3099 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3100 /* 5 = '\N{' + cur char + NUL */
3101 (STRLEN)(send - s) + 5);
3102 d = SvPVX(sv) + SvCUR(sv);
3107 if (*s == 'U' && s[1] == '+') { /* \N{U+...} */
3108 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
3109 | PERL_SCAN_DISALLOW_PREFIX;
3112 /* For \N{U+...}, the '...' is a unicode value even on
3113 * EBCDIC machines */
3114 s += 2; /* Skip to next char after the 'U+' */
3116 uv = grok_hex(s, &len, &flags, NULL);
3117 if (len == 0 || len != (STRLEN)(e - s)) {
3118 yyerror("Invalid hexadecimal number in \\N{U+...}");
3125 /* Pass through to the regex compiler unchanged. The
3126 * reason we evaluated the number above is to make sure
3127 * there wasn't a syntax error. */
3128 s -= 5; /* Include the '\N{U+' */
3129 Copy(s, d, e - s + 1, char); /* 1 = include the } */
3132 else { /* Not a pattern: convert the hex to string */
3134 /* If destination is not in utf8, unconditionally
3135 * recode it to be so. This is because \N{} implies
3136 * Unicode semantics, and scalars have to be in utf8
3137 * to guarantee those semantics */
3139 SvCUR_set(sv, d - SvPVX_const(sv));
3142 /* See Note on sizing above. */
3143 sv_utf8_upgrade_flags_grow(
3145 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3146 UNISKIP(uv) + (STRLEN)(send - e) + 1);
3147 d = SvPVX(sv) + SvCUR(sv);
3151 /* Add the string to the output */
3152 if (UNI_IS_INVARIANT(uv)) {
3155 else d = (char*)uvuni_to_utf8((U8*)d, uv);
3158 else { /* Here is \N{NAME} but not \N{U+...}. */
3160 SV *res; /* result from charnames */
3161 const char *str; /* the string in 'res' */
3162 STRLEN len; /* its length */
3164 /* Get the value for NAME */
3165 res = newSVpvn(s, e - s);
3166 res = new_constant( NULL, 0, "charnames",
3167 /* includes all of: \N{...} */
3168 res, NULL, s - 3, e - s + 4 );
3170 /* Most likely res will be in utf8 already since the
3171 * standard charnames uses pack U, but a custom translator
3172 * can leave it otherwise, so make sure. XXX This can be
3173 * revisited to not have charnames use utf8 for characters
3174 * that don't need it when regexes don't have to be in utf8
3175 * for Unicode semantics. If doing so, remember EBCDIC */
3176 sv_utf8_upgrade(res);
3177 str = SvPV_const(res, len);
3179 /* Don't accept malformed input */
3180 if (! is_utf8_string((U8 *) str, len)) {
3181 yyerror("Malformed UTF-8 returned by \\N");
3183 else if (PL_lex_inpat) {
3185 if (! len) { /* The name resolved to an empty string */
3186 Copy("\\N{}", d, 4, char);
3190 /* In order to not lose information for the regex
3191 * compiler, pass the result in the specially made
3192 * syntax: \N{U+c1.c2.c3...}, where c1 etc. are
3193 * the code points in hex of each character
3194 * returned by charnames */
3196 const char *str_end = str + len;
3197 STRLEN char_length; /* cur char's byte length */
3198 STRLEN output_length; /* and the number of bytes
3199 after this is translated
3201 const STRLEN off = d - SvPVX_const(sv);
3203 /* 2 hex per byte; 2 chars for '\N'; 2 chars for
3204 * max('U+', '.'); and 1 for NUL */
3205 char hex_string[2 * UTF8_MAXBYTES + 5];
3207 /* Get the first character of the result. */
3208 U32 uv = utf8n_to_uvuni((U8 *) str,
3213 /* The call to is_utf8_string() above hopefully
3214 * guarantees that there won't be an error. But
3215 * it's easy here to make sure. The function just
3216 * above warns and returns 0 if invalid utf8, but
3217 * it can also return 0 if the input is validly a
3218 * NUL. Disambiguate */
3219 if (uv == 0 && NATIVE_TO_ASCII(*str) != '\0') {
3220 uv = UNICODE_REPLACEMENT;
3223 /* Convert first code point to hex, including the
3224 * boiler plate before it */
3226 my_snprintf(hex_string, sizeof(hex_string),
3227 "\\N{U+%X", (unsigned int) uv);
3229 /* Make sure there is enough space to hold it */
3230 d = off + SvGROW(sv, off
3232 + (STRLEN)(send - e)
3233 + 2); /* '}' + NUL */
3235 Copy(hex_string, d, output_length, char);
3238 /* For each subsequent character, append dot and
3239 * its ordinal in hex */
3240 while ((str += char_length) < str_end) {
3241 const STRLEN off = d - SvPVX_const(sv);
3242 U32 uv = utf8n_to_uvuni((U8 *) str,
3246 if (uv == 0 && NATIVE_TO_ASCII(*str) != '\0') {
3247 uv = UNICODE_REPLACEMENT;
3251 my_snprintf(hex_string, sizeof(hex_string),
3252 ".%X", (unsigned int) uv);
3254 d = off + SvGROW(sv, off
3256 + (STRLEN)(send - e)
3257 + 2); /* '}' + NUL */
3258 Copy(hex_string, d, output_length, char);
3262 *d++ = '}'; /* Done. Add the trailing brace */
3265 else { /* Here, not in a pattern. Convert the name to a
3268 /* If destination is not in utf8, unconditionally
3269 * recode it to be so. This is because \N{} implies
3270 * Unicode semantics, and scalars have to be in utf8
3271 * to guarantee those semantics */
3273 SvCUR_set(sv, d - SvPVX_const(sv));
3276 /* See Note on sizing above. */
3277 sv_utf8_upgrade_flags_grow(sv,
3278 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3279 len + (STRLEN)(send - s) + 1);
3280 d = SvPVX(sv) + SvCUR(sv);
3282 } else if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
3284 /* See Note on sizing above. (NOTE: SvCUR() is not
3285 * set correctly here). */
3286 const STRLEN off = d - SvPVX_const(sv);
3287 d = off + SvGROW(sv, off + len + (STRLEN)(send - s) + 1);
3289 Copy(str, d, len, char);
3294 /* Deprecate non-approved name syntax */
3295 if (ckWARN_d(WARN_DEPRECATED)) {
3296 bool problematic = FALSE;
3299 /* For non-ut8 input, look to see that the first
3300 * character is an alpha, then loop through the rest
3301 * checking that each is a continuation */
3303 if (! isALPHAU(*i)) problematic = TRUE;
3304 else for (i = s + 1; i < e; i++) {
3305 if (isCHARNAME_CONT(*i)) continue;
3311 /* Similarly for utf8. For invariants can check
3312 * directly. We accept anything above the latin1
3313 * range because it is immaterial to Perl if it is
3314 * correct or not, and is expensive to check. But
3315 * it is fairly easy in the latin1 range to convert
3316 * the variants into a single character and check
3318 if (UTF8_IS_INVARIANT(*i)) {
3319 if (! isALPHAU(*i)) problematic = TRUE;
3320 } else if (UTF8_IS_DOWNGRADEABLE_START(*i)) {
3321 if (! isALPHAU(UNI_TO_NATIVE(TWO_BYTE_UTF8_TO_UNI(*i,
3327 if (! problematic) for (i = s + UTF8SKIP(s);
3331 if (UTF8_IS_INVARIANT(*i)) {
3332 if (isCHARNAME_CONT(*i)) continue;
3333 } else if (! UTF8_IS_DOWNGRADEABLE_START(*i)) {
3335 } else if (isCHARNAME_CONT(
3337 TWO_BYTE_UTF8_TO_UNI(*i, *(i+1)))))
3346 /* The e-i passed to the final %.*s makes sure that
3347 * should the trailing NUL be missing that this
3348 * print won't run off the end of the string */
3349 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3350 "Deprecated character in \\N{...}; marked by <-- HERE in \\N{%.*s<-- HERE %.*s",
3351 (int)(i - s + 1), s, (int)(e - i), i + 1);
3354 } /* End \N{NAME} */
3357 native_range = FALSE; /* \N{} is defined to be Unicode */
3359 s = e + 1; /* Point to just after the '}' */
3362 /* \c is a control character */
3366 *d++ = grok_bslash_c(*s++, has_utf8, 1);
3369 yyerror("Missing control char name in \\c");
3373 /* printf-style backslashes, formfeeds, newlines, etc */
3375 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
3378 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
3381 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
3384 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
3387 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
3390 *d++ = ASCII_TO_NEED(has_utf8,'\033');
3393 *d++ = ASCII_TO_NEED(has_utf8,'\007');
3399 } /* end if (backslash) */
3406 /* If we started with encoded form, or already know we want it,
3407 then encode the next character */
3408 if (! NATIVE_IS_INVARIANT((U8)(*s)) && (this_utf8 || has_utf8)) {
3412 /* One might think that it is wasted effort in the case of the
3413 * source being utf8 (this_utf8 == TRUE) to take the next character
3414 * in the source, convert it to an unsigned value, and then convert
3415 * it back again. But the source has not been validated here. The
3416 * routine that does the conversion checks for errors like
3419 const UV nextuv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
3420 const STRLEN need = UNISKIP(NATIVE_TO_UNI(nextuv));
3422 SvCUR_set(sv, d - SvPVX_const(sv));
3425 /* See Note on sizing above. */
3426 sv_utf8_upgrade_flags_grow(sv,
3427 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3428 need + (STRLEN)(send - s) + 1);
3429 d = SvPVX(sv) + SvCUR(sv);
3431 } else if (need > len) {
3432 /* encoded value larger than old, may need extra space (NOTE:
3433 * SvCUR() is not set correctly here). See Note on sizing
3435 const STRLEN off = d - SvPVX_const(sv);
3436 d = SvGROW(sv, off + need + (STRLEN)(send - s) + 1) + off;
3440 d = (char*)uvchr_to_utf8((U8*)d, nextuv);
3442 if (uv > 255 && !dorange)
3443 native_range = FALSE;
3447 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
3449 } /* while loop to process each character */
3451 /* terminate the string and set up the sv */
3453 SvCUR_set(sv, d - SvPVX_const(sv));
3454 if (SvCUR(sv) >= SvLEN(sv))
3455 Perl_croak(aTHX_ "panic: constant overflowed allocated space");
3458 if (PL_encoding && !has_utf8) {
3459 sv_recode_to_utf8(sv, PL_encoding);
3465 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
3466 PL_sublex_info.sub_op->op_private |=
3467 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
3471 /* shrink the sv if we allocated more than we used */
3472 if (SvCUR(sv) + 5 < SvLEN(sv)) {
3473 SvPV_shrink_to_cur(sv);
3476 /* return the substring (via pl_yylval) only if we parsed anything */
3477 if (s > PL_bufptr) {
3478 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) ) {
3479 const char *const key = PL_lex_inpat ? "qr" : "q";
3480 const STRLEN keylen = PL_lex_inpat ? 2 : 1;
3484 if (PL_lex_inwhat == OP_TRANS) {
3487 } else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) {
3495 sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL,
3498 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3505 * Returns TRUE if there's more to the expression (e.g., a subscript),
3508 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
3510 * ->[ and ->{ return TRUE
3511 * { and [ outside a pattern are always subscripts, so return TRUE
3512 * if we're outside a pattern and it's not { or [, then return FALSE
3513 * if we're in a pattern and the first char is a {
3514 * {4,5} (any digits around the comma) returns FALSE
3515 * if we're in a pattern and the first char is a [
3517 * [SOMETHING] has a funky algorithm to decide whether it's a
3518 * character class or not. It has to deal with things like
3519 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
3520 * anything else returns TRUE
3523 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
3526 S_intuit_more(pTHX_ register char *s)
3530 PERL_ARGS_ASSERT_INTUIT_MORE;
3532 if (PL_lex_brackets)
3534 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
3536 if (*s != '{' && *s != '[')
3541 /* In a pattern, so maybe we have {n,m}. */
3549 /* On the other hand, maybe we have a character class */
3552 if (*s == ']' || *s == '^')
3555 /* this is terrifying, and it works */
3556 int weight = 2; /* let's weigh the evidence */
3558 unsigned char un_char = 255, last_un_char;
3559 const char * const send = strchr(s,']');
3560 char tmpbuf[sizeof PL_tokenbuf * 4];
3562 if (!send) /* has to be an expression */
3565 Zero(seen,256,char);
3568 else if (isDIGIT(*s)) {
3570 if (isDIGIT(s[1]) && s[2] == ']')
3576 for (; s < send; s++) {
3577 last_un_char = un_char;
3578 un_char = (unsigned char)*s;
3583 weight -= seen[un_char] * 10;
3584 if (isALNUM_lazy_if(s+1,UTF)) {
3586 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
3587 len = (int)strlen(tmpbuf);
3588 if (len > 1 && gv_fetchpvn_flags(tmpbuf, len, 0, SVt_PV))
3593 else if (*s == '$' && s[1] &&
3594 strchr("[#!%*<>()-=",s[1])) {
3595 if (/*{*/ strchr("])} =",s[2]))
3604 if (strchr("wds]",s[1]))
3606 else if (seen[(U8)'\''] || seen[(U8)'"'])
3608 else if (strchr("rnftbxcav",s[1]))
3610 else if (isDIGIT(s[1])) {
3612 while (s[1] && isDIGIT(s[1]))
3622 if (strchr("aA01! ",last_un_char))
3624 if (strchr("zZ79~",s[1]))
3626 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
3627 weight -= 5; /* cope with negative subscript */
3630 if (!isALNUM(last_un_char)
3631 && !(last_un_char == '$' || last_un_char == '@'
3632 || last_un_char == '&')
3633 && isALPHA(*s) && s[1] && isALPHA(s[1])) {
3638 if (keyword(tmpbuf, d - tmpbuf, 0))
3641 if (un_char == last_un_char + 1)
3643 weight -= seen[un_char];
3648 if (weight >= 0) /* probably a character class */
3658 * Does all the checking to disambiguate
3660 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
3661 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
3663 * First argument is the stuff after the first token, e.g. "bar".
3665 * Not a method if bar is a filehandle.
3666 * Not a method if foo is a subroutine prototyped to take a filehandle.
3667 * Not a method if it's really "Foo $bar"
3668 * Method if it's "foo $bar"
3669 * Not a method if it's really "print foo $bar"
3670 * Method if it's really "foo package::" (interpreted as package->foo)
3671 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
3672 * Not a method if bar is a filehandle or package, but is quoted with
3677 S_intuit_method(pTHX_ char *start, GV *gv, CV *cv)
3680 char *s = start + (*start == '$');
3681 char tmpbuf[sizeof PL_tokenbuf];
3688 PERL_ARGS_ASSERT_INTUIT_METHOD;
3691 if (SvTYPE(gv) == SVt_PVGV && GvIO(gv))
3695 const char *proto = SvPVX_const(cv);
3706 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3707 /* start is the beginning of the possible filehandle/object,
3708 * and s is the end of it
3709 * tmpbuf is a copy of it
3712 if (*start == '$') {
3713 if (gv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY ||
3714 isUPPER(*PL_tokenbuf))
3717 len = start - SvPVX(PL_linestr);
3721 start = SvPVX(PL_linestr) + len;
3725 return *s == '(' ? FUNCMETH : METHOD;
3727 if (!keyword(tmpbuf, len, 0)) {
3728 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
3732 soff = s - SvPVX(PL_linestr);
3736 indirgv = gv_fetchpvn_flags(tmpbuf, len, 0, SVt_PVCV);
3737 if (indirgv && GvCVu(indirgv))
3739 /* filehandle or package name makes it a method */
3740 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, 0)) {
3742 soff = s - SvPVX(PL_linestr);
3745 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
3746 return 0; /* no assumptions -- "=>" quotes bareword */
3748 start_force(PL_curforce);
3749 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
3750 S_newSV_maybe_utf8(aTHX_ tmpbuf, len));
3751 NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
3753 curmad('X', newSVpvn(start,SvPVX(PL_linestr) + soff - start));
3758 PL_bufptr = SvPVX(PL_linestr) + soff; /* restart before space */
3760 return *s == '(' ? FUNCMETH : METHOD;
3766 /* Encoded script support. filter_add() effectively inserts a
3767 * 'pre-processing' function into the current source input stream.
3768 * Note that the filter function only applies to the current source file
3769 * (e.g., it will not affect files 'require'd or 'use'd by this one).
3771 * The datasv parameter (which may be NULL) can be used to pass
3772 * private data to this instance of the filter. The filter function
3773 * can recover the SV using the FILTER_DATA macro and use it to
3774 * store private buffers and state information.
3776 * The supplied datasv parameter is upgraded to a PVIO type
3777 * and the IoDIRP/IoANY field is used to store the function pointer,
3778 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
3779 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
3780 * private use must be set using malloc'd pointers.
3784 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
3793 if (!PL_rsfp_filters)
3794 PL_rsfp_filters = newAV();
3797 SvUPGRADE(datasv, SVt_PVIO);
3798 IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
3799 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
3800 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
3801 FPTR2DPTR(void *, IoANY(datasv)),
3802 SvPV_nolen(datasv)));
3803 av_unshift(PL_rsfp_filters, 1);
3804 av_store(PL_rsfp_filters, 0, datasv) ;
3809 /* Delete most recently added instance of this filter function. */
3811 Perl_filter_del(pTHX_ filter_t funcp)
3816 PERL_ARGS_ASSERT_FILTER_DEL;
3819 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
3820 FPTR2DPTR(void*, funcp)));
3822 if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
3824 /* if filter is on top of stack (usual case) just pop it off */
3825 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
3826 if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
3827 sv_free(av_pop(PL_rsfp_filters));
3831 /* we need to search for the correct entry and clear it */
3832 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
3836 /* Invoke the idxth filter function for the current rsfp. */
3837 /* maxlen 0 = read one text line */
3839 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
3844 /* This API is bad. It should have been using unsigned int for maxlen.
3845 Not sure if we want to change the API, but if not we should sanity
3846 check the value here. */
3847 const unsigned int correct_length
3856 PERL_ARGS_ASSERT_FILTER_READ;
3858 if (!PL_parser || !PL_rsfp_filters)
3860 if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
3861 /* Provide a default input filter to make life easy. */
3862 /* Note that we append to the line. This is handy. */
3863 DEBUG_P(PerlIO_printf(Perl_debug_log,
3864 "filter_read %d: from rsfp\n", idx));
3865 if (correct_length) {
3868 const int old_len = SvCUR(buf_sv);
3870 /* ensure buf_sv is large enough */
3871 SvGROW(buf_sv, (STRLEN)(old_len + correct_length + 1)) ;
3872 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
3873 correct_length)) <= 0) {
3874 if (PerlIO_error(PL_rsfp))
3875 return -1; /* error */
3877 return 0 ; /* end of file */
3879 SvCUR_set(buf_sv, old_len + len) ;
3880 SvPVX(buf_sv)[old_len + len] = '\0';
3883 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
3884 if (PerlIO_error(PL_rsfp))
3885 return -1; /* error */
3887 return 0 ; /* end of file */
3890 return SvCUR(buf_sv);
3892 /* Skip this filter slot if filter has been deleted */
3893 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
3894 DEBUG_P(PerlIO_printf(Perl_debug_log,
3895 "filter_read %d: skipped (filter deleted)\n",
3897 return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
3899 /* Get function pointer hidden within datasv */
3900 funcp = DPTR2FPTR(filter_t, IoANY(datasv));
3901 DEBUG_P(PerlIO_printf(Perl_debug_log,
3902 "filter_read %d: via function %p (%s)\n",
3903 idx, (void*)datasv, SvPV_nolen_const(datasv)));
3904 /* Call function. The function is expected to */
3905 /* call "FILTER_READ(idx+1, buf_sv)" first. */
3906 /* Return: <0:error, =0:eof, >0:not eof */
3907 return (*funcp)(aTHX_ idx, buf_sv, correct_length);
3911 S_filter_gets(pTHX_ register SV *sv, STRLEN append)
3915 PERL_ARGS_ASSERT_FILTER_GETS;
3917 #ifdef PERL_CR_FILTER
3918 if (!PL_rsfp_filters) {
3919 filter_add(S_cr_textfilter,NULL);
3922 if (PL_rsfp_filters) {
3924 SvCUR_set(sv, 0); /* start with empty line */
3925 if (FILTER_READ(0, sv, 0) > 0)
3926 return ( SvPVX(sv) ) ;
3931 return (sv_gets(sv, PL_rsfp, append));
3935 S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
3940 PERL_ARGS_ASSERT_FIND_IN_MY_STASH;
3942 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
3946 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
3947 (gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVHV)))
3949 return GvHV(gv); /* Foo:: */
3952 /* use constant CLASS => 'MyClass' */
3953 gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVCV);
3954 if (gv && GvCV(gv)) {
3955 SV * const sv = cv_const_sv(GvCV(gv));
3957 pkgname = SvPV_const(sv, len);
3960 return gv_stashpvn(pkgname, len, 0);
3964 * S_readpipe_override
3965 * Check whether readpipe() is overridden, and generates the appropriate
3966 * optree, provided sublex_start() is called afterwards.
3969 S_readpipe_override(pTHX)
3972 GV *gv_readpipe = gv_fetchpvs("readpipe", GV_NOTQUAL, SVt_PVCV);
3973 pl_yylval.ival = OP_BACKTICK;
3975 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe))
3977 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readpipe", FALSE))
3978 && (gv_readpipe = *gvp) && isGV_with_GP(gv_readpipe)
3979 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe)))
3981 PL_lex_op = (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
3982 op_append_elem(OP_LIST,
3983 newSVOP(OP_CONST, 0, &PL_sv_undef), /* value will be read later */
3984 newCVREF(0, newGVOP(OP_GV, 0, gv_readpipe))));
3991 * The intent of this yylex wrapper is to minimize the changes to the
3992 * tokener when we aren't interested in collecting madprops. It remains
3993 * to be seen how successful this strategy will be...
4000 char *s = PL_bufptr;
4002 /* make sure PL_thiswhite is initialized */
4006 /* just do what yylex would do on pending identifier; leave PL_thiswhite alone */
4007 if (PL_lex_state != LEX_KNOWNEXT && PL_pending_ident)
4008 return S_pending_ident(aTHX);
4010 /* previous token ate up our whitespace? */
4011 if (!PL_lasttoke && PL_nextwhite) {
4012 PL_thiswhite = PL_nextwhite;
4016 /* isolate the token, and figure out where it is without whitespace */
4017 PL_realtokenstart = -1;
4021 assert(PL_curforce < 0);
4023 if (!PL_thismad || PL_thismad->mad_key == '^') { /* not forced already? */
4024 if (!PL_thistoken) {
4025 if (PL_realtokenstart < 0 || !CopLINE(PL_curcop))
4026 PL_thistoken = newSVpvs("");
4028 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
4029 PL_thistoken = newSVpvn(tstart, s - tstart);
4032 if (PL_thismad) /* install head */
4033 CURMAD('X', PL_thistoken);
4036 /* last whitespace of a sublex? */
4037 if (optype == ')' && PL_endwhite) {
4038 CURMAD('X', PL_endwhite);
4043 /* if no whitespace and we're at EOF, bail. Otherwise fake EOF below. */
4044 if (!PL_thiswhite && !PL_endwhite && !optype) {
4045 sv_free(PL_thistoken);
4050 /* put off final whitespace till peg */
4051 if (optype == ';' && !PL_rsfp) {
4052 PL_nextwhite = PL_thiswhite;
4055 else if (PL_thisopen) {
4056 CURMAD('q', PL_thisopen);
4058 sv_free(PL_thistoken);
4062 /* Store actual token text as madprop X */
4063 CURMAD('X', PL_thistoken);
4067 /* add preceding whitespace as madprop _ */
4068 CURMAD('_', PL_thiswhite);
4072 /* add quoted material as madprop = */
4073 CURMAD('=', PL_thisstuff);
4077 /* add terminating quote as madprop Q */
4078 CURMAD('Q', PL_thisclose);
4082 /* special processing based on optype */
4086 /* opval doesn't need a TOKEN since it can already store mp */
4096 if (pl_yylval.opval)
4097 append_madprops(PL_thismad, pl_yylval.opval, 0);
4105 addmad(newMADsv('p', PL_endwhite), &PL_thismad, 0);
4114 /* remember any fake bracket that lexer is about to discard */
4115 if (PL_lex_brackets == 1 &&
4116 ((expectation)PL_lex_brackstack[0] & XFAKEBRACK))
4119 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
4122 PL_thiswhite = newSVpvn(PL_bufptr, ++s - PL_bufptr);
4123 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
4126 break; /* don't bother looking for trailing comment */
4135 /* attach a trailing comment to its statement instead of next token */
4139 if (PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == optype) {
4141 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
4143 if (*s == '\n' || *s == '#') {
4144 while (s < PL_bufend && *s != '\n')
4148 PL_thiswhite = newSVpvn(PL_bufptr, s - PL_bufptr);
4149 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
4166 /* Create new token struct. Note: opvals return early above. */
4167 pl_yylval.tkval = newTOKEN(optype, pl_yylval, PL_thismad);
4174 S_tokenize_use(pTHX_ int is_use, char *s) {
4177 PERL_ARGS_ASSERT_TOKENIZE_USE;
4179 if (PL_expect != XSTATE)
4180 yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
4181 is_use ? "use" : "no"));
4183 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4184 s = force_version(s, TRUE);
4185 if (*s == ';' || *s == '}'
4186 || (s = SKIPSPACE1(s), (*s == ';' || *s == '}'))) {
4187 start_force(PL_curforce);
4188 NEXTVAL_NEXTTOKE.opval = NULL;
4191 else if (*s == 'v') {
4192 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4193 s = force_version(s, FALSE);
4197 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4198 s = force_version(s, FALSE);
4200 pl_yylval.ival = is_use;
4204 static const char* const exp_name[] =
4205 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
4206 "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
4210 #define word_takes_any_delimeter(p,l) S_word_takes_any_delimeter(p,l)
4212 S_word_takes_any_delimeter(char *p, STRLEN len)
4214 return (len == 1 && strchr("msyq", p[0])) ||
4216 (p[0] == 't' && p[1] == 'r') ||
4217 (p[0] == 'q' && strchr("qwxr", p[1]))));
4223 Works out what to call the token just pulled out of the input
4224 stream. The yacc parser takes care of taking the ops we return and
4225 stitching them into a tree.
4231 if read an identifier
4232 if we're in a my declaration
4233 croak if they tried to say my($foo::bar)
4234 build the ops for a my() declaration
4235 if it's an access to a my() variable
4236 are we in a sort block?
4237 croak if my($a); $a <=> $b
4238 build ops for access to a my() variable
4239 if in a dq string, and they've said @foo and we can't find @foo
4241 build ops for a bareword
4242 if we already built the token before, use it.
4247 #pragma segment Perl_yylex
4253 register char *s = PL_bufptr;
4259 /* orig_keyword, gvp, and gv are initialized here because
4260 * jump to the label just_a_word_zero can bypass their
4261 * initialization later. */
4262 I32 orig_keyword = 0;
4267 SV* tmp = newSVpvs("");
4268 PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
4269 (IV)CopLINE(PL_curcop),
4270 lex_state_names[PL_lex_state],
4271 exp_name[PL_expect],
4272 pv_display(tmp, s, strlen(s), 0, 60));
4275 /* check if there's an identifier for us to look at */
4276 if (PL_lex_state != LEX_KNOWNEXT && PL_pending_ident)
4277 return REPORT(S_pending_ident(aTHX));
4279 /* no identifier pending identification */
4281 switch (PL_lex_state) {
4283 case LEX_NORMAL: /* Some compilers will produce faster */
4284 case LEX_INTERPNORMAL: /* code if we comment these out. */
4288 /* when we've already built the next token, just pull it out of the queue */
4292 pl_yylval = PL_nexttoke[PL_lasttoke].next_val;
4294 PL_thismad = PL_nexttoke[PL_lasttoke].next_mad;
4295 PL_nexttoke[PL_lasttoke].next_mad = 0;
4296 if (PL_thismad && PL_thismad->mad_key == '_') {
4297 PL_thiswhite = MUTABLE_SV(PL_thismad->mad_val);
4298 PL_thismad->mad_val = 0;
4299 mad_free(PL_thismad);
4304 PL_lex_state = PL_lex_defer;
4305 PL_expect = PL_lex_expect;
4306 PL_lex_defer = LEX_NORMAL;
4307 if (!PL_nexttoke[PL_lasttoke].next_type)
4312 pl_yylval = PL_nextval[PL_nexttoke];
4314 PL_lex_state = PL_lex_defer;
4315 PL_expect = PL_lex_expect;
4316 PL_lex_defer = LEX_NORMAL;
4322 next_type = PL_nexttoke[PL_lasttoke].next_type;
4324 next_type = PL_nexttype[PL_nexttoke];
4326 if (next_type & (7<<24)) {
4327 if (next_type & (1<<24)) {
4328 if (PL_lex_brackets > 100)
4329 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
4330 PL_lex_brackstack[PL_lex_brackets++] =
4331 (next_type >> 16) & 0xff;
4333 if (next_type & (2<<24))
4334 PL_lex_allbrackets++;
4335 if (next_type & (4<<24))
4336 PL_lex_allbrackets--;
4337 next_type &= 0xffff;
4340 /* FIXME - can these be merged? */
4343 return REPORT(next_type);
4347 /* interpolated case modifiers like \L \U, including \Q and \E.
4348 when we get here, PL_bufptr is at the \
4350 case LEX_INTERPCASEMOD:
4352 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
4353 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
4355 /* handle \E or end of string */
4356 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
4358 if (PL_lex_casemods) {
4359 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
4360 PL_lex_casestack[PL_lex_casemods] = '\0';
4362 if (PL_bufptr != PL_bufend
4363 && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q')) {
4365 PL_lex_state = LEX_INTERPCONCAT;
4368 PL_thistoken = newSVpvs("\\E");
4371 PL_lex_allbrackets--;
4375 while (PL_bufptr != PL_bufend &&
4376 PL_bufptr[0] == '\\' && PL_bufptr[1] == 'E') {
4378 PL_thiswhite = newSVpvs("");
4379 sv_catpvn(PL_thiswhite, PL_bufptr, 2);
4383 if (PL_bufptr != PL_bufend)
4386 PL_lex_state = LEX_INTERPCONCAT;
4390 DEBUG_T({ PerlIO_printf(Perl_debug_log,
4391 "### Saw case modifier\n"); });
4393 if (s[1] == '\\' && s[2] == 'E') {
4396 PL_thiswhite = newSVpvs("");
4397 sv_catpvn(PL_thiswhite, PL_bufptr, 4);
4400 PL_lex_state = LEX_INTERPCONCAT;
4405 if (!PL_madskills) /* when just compiling don't need correct */
4406 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
4407 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
4408 if ((*s == 'L' || *s == 'U') &&
4409 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) {
4410 PL_lex_casestack[--PL_lex_casemods] = '\0';
4411 PL_lex_allbrackets--;
4414 if (PL_lex_casemods > 10)
4415 Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
4416 PL_lex_casestack[PL_lex_casemods++] = *s;
4417 PL_lex_casestack[PL_lex_casemods] = '\0';
4418 PL_lex_state = LEX_INTERPCONCAT;
4419 start_force(PL_curforce);
4420 NEXTVAL_NEXTTOKE.ival = 0;
4421 force_next((2<<24)|'(');
4422 start_force(PL_curforce);
4424 NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
4426 NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
4428 NEXTVAL_NEXTTOKE.ival = OP_LC;
4430 NEXTVAL_NEXTTOKE.ival = OP_UC;
4432 NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
4434 Perl_croak(aTHX_ "panic: yylex");
4436 SV* const tmpsv = newSVpvs("\\ ");
4437 /* replace the space with the character we want to escape
4439 SvPVX(tmpsv)[1] = *s;
4445 if (PL_lex_starts) {
4451 sv_free(PL_thistoken);
4452 PL_thistoken = newSVpvs("");
4455 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4456 if (PL_lex_casemods == 1 && PL_lex_inpat)
4465 case LEX_INTERPPUSH:
4466 return REPORT(sublex_push());
4468 case LEX_INTERPSTART:
4469 if (PL_bufptr == PL_bufend)
4470 return REPORT(sublex_done());
4471 DEBUG_T({ PerlIO_printf(Perl_debug_log,
4472 "### Interpolated variable\n"); });
4474 PL_lex_dojoin = (*PL_bufptr == '@');
4475 PL_lex_state = LEX_INTERPNORMAL;
4476 if (PL_lex_dojoin) {
4477 start_force(PL_curforce);
4478 NEXTVAL_NEXTTOKE.ival = 0;
4480 start_force(PL_curforce);
4481 force_ident("\"", '$');
4482 start_force(PL_curforce);
4483 NEXTVAL_NEXTTOKE.ival = 0;
4485 start_force(PL_curforce);
https://perl5.git.perl.org / perl5.git / blob