This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
fixes for bugs in C<use warnings qw(FATAL all)> (from Paul Marquess)
[perl5.git] / toke.c
CommitLineData
a0d0e21e 1/* toke.c
a687059c 2 *
3818b22b 3 * Copyright (c) 1991-2000, Larry Wall
a687059c 4 *
d48672a2
LW
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
378cc40b 7 *
a0d0e21e
LW
8 */
9
10/*
11 * "It all comes from here, the stench and the peril." --Frodo
378cc40b
LW
12 */
13
9cbb5ea2
GS
14/*
15 * This file is the lexer for Perl. It's closely linked to the
ffb4593c
NT
16 * parser, perly.y.
17 *
18 * The main routine is yylex(), which returns the next token.
19 */
20
378cc40b 21#include "EXTERN.h"
864dbfa3 22#define PERL_IN_TOKE_C
378cc40b 23#include "perl.h"
378cc40b 24
d3b6f988
GS
25#define yychar PL_yychar
26#define yylval PL_yylval
27
fc36a67e 28static char ident_too_long[] = "Identifier too long";
8903cb82 29
51371543 30static void restore_rsfp(pTHXo_ void *f);
51371543 31
9059aa12
LW
32#define XFAKEBRACK 128
33#define XENUMMASK 127
34
7e2040f0 35/*#define UTF (SvUTF8(PL_linestr) && !(PL_hints & HINT_BYTE))*/
a0ed51b3
LW
36#define UTF (PL_hints & HINT_UTF8)
37
2b92dfce
GS
38/* In variables name $^X, these are the legal values for X.
39 * 1999-02-27 mjd-perl-patch@plover.com */
40#define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
41
ffb4593c
NT
42/* LEX_* are values for PL_lex_state, the state of the lexer.
43 * They are arranged oddly so that the guard on the switch statement
79072805
LW
44 * can get by with a single comparison (if the compiler is smart enough).
45 */
46
fb73857a
PP
47/* #define LEX_NOTPARSING 11 is done in perl.h. */
48
55497cff
PP
49#define LEX_NORMAL 10
50#define LEX_INTERPNORMAL 9
51#define LEX_INTERPCASEMOD 8
52#define LEX_INTERPPUSH 7
53#define LEX_INTERPSTART 6
54#define LEX_INTERPEND 5
55#define LEX_INTERPENDMAYBE 4
56#define LEX_INTERPCONCAT 3
57#define LEX_INTERPCONST 2
58#define LEX_FORMLINE 1
59#define LEX_KNOWNEXT 0
79072805 60
a790bc05
PP
61/* XXX If this causes problems, set i_unistd=undef in the hint file. */
62#ifdef I_UNISTD
63# include <unistd.h> /* Needed for execv() */
64#endif
65
66
79072805
LW
67#ifdef ff_next
68#undef ff_next
d48672a2
LW
69#endif
70
a1a0e61e
TD
71#ifdef USE_PURE_BISON
72YYSTYPE* yylval_pointer = NULL;
73int* yychar_pointer = NULL;
22c35a8c
GS
74# undef yylval
75# undef yychar
e4bfbdd4
JH
76# define yylval (*yylval_pointer)
77# define yychar (*yychar_pointer)
78# define PERL_YYLEX_PARAM yylval_pointer,yychar_pointer
cea2e8a9
GS
79# undef yylex
80# define yylex() Perl_yylex(aTHX_ yylval_pointer, yychar_pointer)
a1a0e61e
TD
81#endif
82
79072805 83#include "keywords.h"
fe14fcc3 84
ffb4593c
NT
85/* CLINE is a macro that ensures PL_copline has a sane value */
86
ae986130
LW
87#ifdef CLINE
88#undef CLINE
89#endif
57843af0 90#define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
3280af22 91
ffb4593c
NT
92/*
93 * Convenience functions to return different tokens and prime the
9cbb5ea2 94 * lexer for the next token. They all take an argument.
ffb4593c
NT
95 *
96 * TOKEN : generic token (used for '(', DOLSHARP, etc)
97 * OPERATOR : generic operator
98 * AOPERATOR : assignment operator
99 * PREBLOCK : beginning the block after an if, while, foreach, ...
100 * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
101 * PREREF : *EXPR where EXPR is not a simple identifier
102 * TERM : expression term
103 * LOOPX : loop exiting command (goto, last, dump, etc)
104 * FTST : file test operator
105 * FUN0 : zero-argument function
2d2e263d 106 * FUN1 : not used, except for not, which isn't a UNIOP
ffb4593c
NT
107 * BOop : bitwise or or xor
108 * BAop : bitwise and
109 * SHop : shift operator
110 * PWop : power operator
9cbb5ea2 111 * PMop : pattern-matching operator
ffb4593c
NT
112 * Aop : addition-level operator
113 * Mop : multiplication-level operator
114 * Eop : equality-testing operator
115 * Rop : relational operator <= != gt
116 *
117 * Also see LOP and lop() below.
118 */
119
3280af22
NIS
120#define TOKEN(retval) return (PL_bufptr = s,(int)retval)
121#define OPERATOR(retval) return (PL_expect = XTERM,PL_bufptr = s,(int)retval)
122#define AOPERATOR(retval) return ao((PL_expect = XTERM,PL_bufptr = s,(int)retval))
123#define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s,(int)retval)
124#define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval)
125#define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s,(int)retval)
126#define TERM(retval) return (CLINE, PL_expect = XOPERATOR,PL_bufptr = s,(int)retval)
127#define LOOPX(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX)
128#define FTST(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)UNIOP)
129#define FUN0(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0)
130#define FUN1(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1)
131#define BOop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITOROP))
132#define BAop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP))
133#define SHop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP))
134#define PWop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)POWOP))
135#define PMop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP)
136#define Aop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)ADDOP))
137#define Mop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MULOP))
138#define Eop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)EQOP)
139#define Rop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)RELOP)
2f3197b3 140
a687059c
LW
141/* This bit of chicanery makes a unary function followed by
142 * a parenthesis into a function with one argument, highest precedence.
143 */
2f3197b3 144#define UNI(f) return(yylval.ival = f, \
3280af22
NIS
145 PL_expect = XTERM, \
146 PL_bufptr = s, \
147 PL_last_uni = PL_oldbufptr, \
148 PL_last_lop_op = f, \
a687059c
LW
149 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
150
79072805 151#define UNIBRACK(f) return(yylval.ival = f, \
3280af22
NIS
152 PL_bufptr = s, \
153 PL_last_uni = PL_oldbufptr, \
79072805
LW
154 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
155
9f68db38 156/* grandfather return to old style */
3280af22 157#define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
79072805 158
ffb4593c
NT
159/*
160 * S_ao
161 *
162 * This subroutine detects &&= and ||= and turns an ANDAND or OROR
163 * into an OP_ANDASSIGN or OP_ORASSIGN
164 */
165
76e3520e 166STATIC int
cea2e8a9 167S_ao(pTHX_ int toketype)
a0d0e21e 168{
3280af22
NIS
169 if (*PL_bufptr == '=') {
170 PL_bufptr++;
a0d0e21e
LW
171 if (toketype == ANDAND)
172 yylval.ival = OP_ANDASSIGN;
173 else if (toketype == OROR)
174 yylval.ival = OP_ORASSIGN;
175 toketype = ASSIGNOP;
176 }
177 return toketype;
178}
179
ffb4593c
NT
180/*
181 * S_no_op
182 * When Perl expects an operator and finds something else, no_op
183 * prints the warning. It always prints "<something> found where
184 * operator expected. It prints "Missing semicolon on previous line?"
185 * if the surprise occurs at the start of the line. "do you need to
186 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
187 * where the compiler doesn't know if foo is a method call or a function.
188 * It prints "Missing operator before end of line" if there's nothing
189 * after the missing operator, or "... before <...>" if there is something
190 * after the missing operator.
191 */
192
76e3520e 193STATIC void
cea2e8a9 194S_no_op(pTHX_ char *what, char *s)
463ee0b2 195{
3280af22
NIS
196 char *oldbp = PL_bufptr;
197 bool is_first = (PL_oldbufptr == PL_linestart);
68dc0745 198
1189a94a
GS
199 if (!s)
200 s = oldbp;
201 else {
202 assert(s >= oldbp);
203 PL_bufptr = s;
204 }
cea2e8a9 205 yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
748a9306 206 if (is_first)
cea2e8a9 207 Perl_warn(aTHX_ "\t(Missing semicolon on previous line?)\n");
7e2040f0 208 else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
748a9306 209 char *t;
7e2040f0 210 for (t = PL_oldoldbufptr; *t && (isALNUM_lazy_if(t,UTF) || *t == ':'); t++) ;
3280af22 211 if (t < PL_bufptr && isSPACE(*t))
cea2e8a9 212 Perl_warn(aTHX_ "\t(Do you need to predeclare %.*s?)\n",
3280af22 213 t - PL_oldoldbufptr, PL_oldoldbufptr);
748a9306
LW
214 }
215 else
cea2e8a9 216 Perl_warn(aTHX_ "\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
3280af22 217 PL_bufptr = oldbp;
8990e307
LW
218}
219
ffb4593c
NT
220/*
221 * S_missingterm
222 * Complain about missing quote/regexp/heredoc terminator.
223 * If it's called with (char *)NULL then it cauterizes the line buffer.
224 * If we're in a delimited string and the delimiter is a control
225 * character, it's reformatted into a two-char sequence like ^C.
226 * This is fatal.
227 */
228
76e3520e 229STATIC void
cea2e8a9 230S_missingterm(pTHX_ char *s)
8990e307
LW
231{
232 char tmpbuf[3];
233 char q;
234 if (s) {
235 char *nl = strrchr(s,'\n');
d2719217 236 if (nl)
8990e307
LW
237 *nl = '\0';
238 }
9d116dd7
JH
239 else if (
240#ifdef EBCDIC
241 iscntrl(PL_multi_close)
242#else
243 PL_multi_close < 32 || PL_multi_close == 127
244#endif
245 ) {
8990e307 246 *tmpbuf = '^';
3280af22 247 tmpbuf[1] = toCTRL(PL_multi_close);
8990e307
LW
248 s = "\\n";
249 tmpbuf[2] = '\0';
250 s = tmpbuf;
251 }
252 else {
3280af22 253 *tmpbuf = PL_multi_close;
8990e307
LW
254 tmpbuf[1] = '\0';
255 s = tmpbuf;
256 }
257 q = strchr(s,'"') ? '\'' : '"';
cea2e8a9 258 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
463ee0b2 259}
79072805 260
ffb4593c
NT
261/*
262 * Perl_deprecate
ffb4593c
NT
263 */
264
79072805 265void
864dbfa3 266Perl_deprecate(pTHX_ char *s)
a0d0e21e 267{
d008e5eb 268 dTHR;
599cee73 269 if (ckWARN(WARN_DEPRECATED))
cea2e8a9 270 Perl_warner(aTHX_ WARN_DEPRECATED, "Use of %s is deprecated", s);
a0d0e21e
LW
271}
272
ffb4593c
NT
273/*
274 * depcom
9cbb5ea2 275 * Deprecate a comma-less variable list.
ffb4593c
NT
276 */
277
76e3520e 278STATIC void
cea2e8a9 279S_depcom(pTHX)
a0d0e21e
LW
280{
281 deprecate("comma-less variable list");
282}
283
ffb4593c 284/*
9cbb5ea2
GS
285 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
286 * utf16-to-utf8-reversed.
ffb4593c
NT
287 */
288
c39cd008
GS
289#ifdef PERL_CR_FILTER
290static void
291strip_return(SV *sv)
292{
293 register char *s = SvPVX(sv);
294 register char *e = s + SvCUR(sv);
295 /* outer loop optimized to do nothing if there are no CR-LFs */
296 while (s < e) {
297 if (*s++ == '\r' && *s == '\n') {
298 /* hit a CR-LF, need to copy the rest */
299 register char *d = s - 1;
300 *d++ = *s++;
301 while (s < e) {
302 if (*s == '\r' && s[1] == '\n')
303 s++;
304 *d++ = *s++;
305 }
306 SvCUR(sv) -= s - d;
307 return;
308 }
309 }
310}
a868473f 311
76e3520e 312STATIC I32
c39cd008 313S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
a868473f 314{
c39cd008
GS
315 I32 count = FILTER_READ(idx+1, sv, maxlen);
316 if (count > 0 && !maxlen)
317 strip_return(sv);
318 return count;
a868473f
NIS
319}
320#endif
321
155aba94 322#if 0
a0ed51b3 323STATIC I32
cea2e8a9 324S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
a0ed51b3
LW
325{
326 I32 count = FILTER_READ(idx+1, sv, maxlen);
327 if (count) {
dfe13c55
GS
328 U8* tmps;
329 U8* tend;
330 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
a0ed51b3 331 tend = utf16_to_utf8((U16*)SvPVX(sv), tmps, SvCUR(sv));
dfe13c55 332 sv_usepvn(sv, (char*)tmps, tend - tmps);
a0ed51b3
LW
333 }
334 return count;
335}
336
337STATIC I32
cea2e8a9 338S_utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
a0ed51b3
LW
339{
340 I32 count = FILTER_READ(idx+1, sv, maxlen);
341 if (count) {
dfe13c55
GS
342 U8* tmps;
343 U8* tend;
344 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
a0ed51b3 345 tend = utf16_to_utf8_reversed((U16*)SvPVX(sv), tmps, SvCUR(sv));
dfe13c55 346 sv_usepvn(sv, (char*)tmps, tend - tmps);
a0ed51b3
LW
347 }
348 return count;
349}
155aba94 350#endif
a868473f 351
ffb4593c
NT
352/*
353 * Perl_lex_start
9cbb5ea2
GS
354 * Initialize variables. Uses the Perl save_stack to save its state (for
355 * recursive calls to the parser).
ffb4593c
NT
356 */
357
a0d0e21e 358void
864dbfa3 359Perl_lex_start(pTHX_ SV *line)
79072805 360{
0f15f207 361 dTHR;
8990e307
LW
362 char *s;
363 STRLEN len;
364
3280af22
NIS
365 SAVEI32(PL_lex_dojoin);
366 SAVEI32(PL_lex_brackets);
3280af22
NIS
367 SAVEI32(PL_lex_casemods);
368 SAVEI32(PL_lex_starts);
369 SAVEI32(PL_lex_state);
7766f137 370 SAVEVPTR(PL_lex_inpat);
3280af22 371 SAVEI32(PL_lex_inwhat);
18b09519
GS
372 if (PL_lex_state == LEX_KNOWNEXT) {
373 I32 toke = PL_nexttoke;
374 while (--toke >= 0) {
375 SAVEI32(PL_nexttype[toke]);
376 SAVEVPTR(PL_nextval[toke]);
377 }
378 SAVEI32(PL_nexttoke);
379 PL_nexttoke = 0;
380 }
57843af0 381 SAVECOPLINE(PL_curcop);
3280af22
NIS
382 SAVEPPTR(PL_bufptr);
383 SAVEPPTR(PL_bufend);
384 SAVEPPTR(PL_oldbufptr);
385 SAVEPPTR(PL_oldoldbufptr);
386 SAVEPPTR(PL_linestart);
387 SAVESPTR(PL_linestr);
388 SAVEPPTR(PL_lex_brackstack);
389 SAVEPPTR(PL_lex_casestack);
c76ac1ee 390 SAVEDESTRUCTOR_X(restore_rsfp, PL_rsfp);
3280af22
NIS
391 SAVESPTR(PL_lex_stuff);
392 SAVEI32(PL_lex_defer);
09bef843 393 SAVEI32(PL_sublex_info.sub_inwhat);
3280af22 394 SAVESPTR(PL_lex_repl);
bebdddfc
GS
395 SAVEINT(PL_expect);
396 SAVEINT(PL_lex_expect);
3280af22
NIS
397
398 PL_lex_state = LEX_NORMAL;
399 PL_lex_defer = 0;
400 PL_expect = XSTATE;
401 PL_lex_brackets = 0;
3280af22
NIS
402 New(899, PL_lex_brackstack, 120, char);
403 New(899, PL_lex_casestack, 12, char);
404 SAVEFREEPV(PL_lex_brackstack);
405 SAVEFREEPV(PL_lex_casestack);
406 PL_lex_casemods = 0;
407 *PL_lex_casestack = '\0';
408 PL_lex_dojoin = 0;
409 PL_lex_starts = 0;
410 PL_lex_stuff = Nullsv;
411 PL_lex_repl = Nullsv;
412 PL_lex_inpat = 0;
413 PL_lex_inwhat = 0;
09bef843 414 PL_sublex_info.sub_inwhat = 0;
3280af22
NIS
415 PL_linestr = line;
416 if (SvREADONLY(PL_linestr))
417 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
418 s = SvPV(PL_linestr, len);
8990e307 419 if (len && s[len-1] != ';') {
3280af22
NIS
420 if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
421 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
422 sv_catpvn(PL_linestr, "\n;", 2);
8990e307 423 }
3280af22
NIS
424 SvTEMP_off(PL_linestr);
425 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
426 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
427 SvREFCNT_dec(PL_rs);
79cb57f6 428 PL_rs = newSVpvn("\n", 1);
3280af22 429 PL_rsfp = 0;
79072805 430}
a687059c 431
ffb4593c
NT
432/*
433 * Perl_lex_end
9cbb5ea2
GS
434 * Finalizer for lexing operations. Must be called when the parser is
435 * done with the lexer.
ffb4593c
NT
436 */
437
463ee0b2 438void
864dbfa3 439Perl_lex_end(pTHX)
463ee0b2 440{
3280af22 441 PL_doextract = FALSE;
463ee0b2
LW
442}
443
ffb4593c
NT
444/*
445 * S_incline
446 * This subroutine has nothing to do with tilting, whether at windmills
447 * or pinball tables. Its name is short for "increment line". It
57843af0 448 * increments the current line number in CopLINE(PL_curcop) and checks
ffb4593c 449 * to see whether the line starts with a comment of the form
9cbb5ea2
GS
450 * # line 500 "foo.pm"
451 * If so, it sets the current line number and file to the values in the comment.
ffb4593c
NT
452 */
453
76e3520e 454STATIC void
cea2e8a9 455S_incline(pTHX_ char *s)
463ee0b2 456{
0f15f207 457 dTHR;
463ee0b2
LW
458 char *t;
459 char *n;
73659bf1 460 char *e;
463ee0b2 461 char ch;
463ee0b2 462
57843af0 463 CopLINE_inc(PL_curcop);
463ee0b2
LW
464 if (*s++ != '#')
465 return;
466 while (*s == ' ' || *s == '\t') s++;
73659bf1
GS
467 if (strnEQ(s, "line", 4))
468 s += 4;
469 else
470 return;
471 if (*s == ' ' || *s == '\t')
472 s++;
473 else
474 return;
475 while (*s == ' ' || *s == '\t') s++;
463ee0b2
LW
476 if (!isDIGIT(*s))
477 return;
478 n = s;
479 while (isDIGIT(*s))
480 s++;
481 while (*s == ' ' || *s == '\t')
482 s++;
73659bf1 483 if (*s == '"' && (t = strchr(s+1, '"'))) {
463ee0b2 484 s++;
73659bf1
GS
485 e = t + 1;
486 }
463ee0b2 487 else {
463ee0b2 488 for (t = s; !isSPACE(*t); t++) ;
73659bf1 489 e = t;
463ee0b2 490 }
73659bf1
GS
491 while (*e == ' ' || *e == '\t' || *e == '\r' || *e == '\f')
492 e++;
493 if (*e != '\n' && *e != '\0')
494 return; /* false alarm */
495
463ee0b2
LW
496 ch = *t;
497 *t = '\0';
498 if (t - s > 0)
57843af0 499 CopFILE_set(PL_curcop, s);
463ee0b2 500 *t = ch;
57843af0 501 CopLINE_set(PL_curcop, atoi(n)-1);
463ee0b2
LW
502}
503
ffb4593c
NT
504/*
505 * S_skipspace
506 * Called to gobble the appropriate amount and type of whitespace.
507 * Skips comments as well.
508 */
509
76e3520e 510STATIC char *
cea2e8a9 511S_skipspace(pTHX_ register char *s)
a687059c 512{
11343788 513 dTHR;
3280af22
NIS
514 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
515 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
463ee0b2
LW
516 s++;
517 return s;
518 }
519 for (;;) {
fd049845 520 STRLEN prevlen;
09bef843
SB
521 SSize_t oldprevlen, oldoldprevlen;
522 SSize_t oldloplen, oldunilen;
60e6418e
GS
523 while (s < PL_bufend && isSPACE(*s)) {
524 if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
525 incline(s);
526 }
ffb4593c
NT
527
528 /* comment */
3280af22
NIS
529 if (s < PL_bufend && *s == '#') {
530 while (s < PL_bufend && *s != '\n')
463ee0b2 531 s++;
60e6418e 532 if (s < PL_bufend) {
463ee0b2 533 s++;
60e6418e
GS
534 if (PL_in_eval && !PL_rsfp) {
535 incline(s);
536 continue;
537 }
538 }
463ee0b2 539 }
ffb4593c
NT
540
541 /* only continue to recharge the buffer if we're at the end
542 * of the buffer, we're not reading from a source filter, and
543 * we're in normal lexing mode
544 */
09bef843
SB
545 if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat ||
546 PL_lex_state == LEX_FORMLINE)
463ee0b2 547 return s;
ffb4593c
NT
548
549 /* try to recharge the buffer */
9cbb5ea2
GS
550 if ((s = filter_gets(PL_linestr, PL_rsfp,
551 (prevlen = SvCUR(PL_linestr)))) == Nullch)
552 {
553 /* end of file. Add on the -p or -n magic */
3280af22
NIS
554 if (PL_minus_n || PL_minus_p) {
555 sv_setpv(PL_linestr,PL_minus_p ?
08e9d68e
DD
556 ";}continue{print or die qq(-p destination: $!\\n)" :
557 "");
3280af22
NIS
558 sv_catpv(PL_linestr,";}");
559 PL_minus_n = PL_minus_p = 0;
a0d0e21e
LW
560 }
561 else
3280af22 562 sv_setpv(PL_linestr,";");
ffb4593c
NT
563
564 /* reset variables for next time we lex */
9cbb5ea2
GS
565 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
566 = SvPVX(PL_linestr);
3280af22 567 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
ffb4593c
NT
568
569 /* Close the filehandle. Could be from -P preprocessor,
570 * STDIN, or a regular file. If we were reading code from
571 * STDIN (because the commandline held no -e or filename)
572 * then we don't close it, we reset it so the code can
573 * read from STDIN too.
574 */
575
3280af22
NIS
576 if (PL_preprocess && !PL_in_eval)
577 (void)PerlProc_pclose(PL_rsfp);
578 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
579 PerlIO_clearerr(PL_rsfp);
8990e307 580 else
3280af22
NIS
581 (void)PerlIO_close(PL_rsfp);
582 PL_rsfp = Nullfp;
463ee0b2
LW
583 return s;
584 }
ffb4593c
NT
585
586 /* not at end of file, so we only read another line */
09bef843
SB
587 /* make corresponding updates to old pointers, for yyerror() */
588 oldprevlen = PL_oldbufptr - PL_bufend;
589 oldoldprevlen = PL_oldoldbufptr - PL_bufend;
590 if (PL_last_uni)
591 oldunilen = PL_last_uni - PL_bufend;
592 if (PL_last_lop)
593 oldloplen = PL_last_lop - PL_bufend;
3280af22
NIS
594 PL_linestart = PL_bufptr = s + prevlen;
595 PL_bufend = s + SvCUR(PL_linestr);
596 s = PL_bufptr;
09bef843
SB
597 PL_oldbufptr = s + oldprevlen;
598 PL_oldoldbufptr = s + oldoldprevlen;
599 if (PL_last_uni)
600 PL_last_uni = s + oldunilen;
601 if (PL_last_lop)
602 PL_last_lop = s + oldloplen;
a0d0e21e 603 incline(s);
ffb4593c
NT
604
605 /* debugger active and we're not compiling the debugger code,
606 * so store the line into the debugger's array of lines
607 */
3280af22 608 if (PERLDB_LINE && PL_curstash != PL_debstash) {
8990e307
LW
609 SV *sv = NEWSV(85,0);
610
611 sv_upgrade(sv, SVt_PVMG);
3280af22 612 sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
57843af0 613 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
8990e307 614 }
463ee0b2 615 }
a687059c 616}
378cc40b 617
ffb4593c
NT
618/*
619 * S_check_uni
620 * Check the unary operators to ensure there's no ambiguity in how they're
621 * used. An ambiguous piece of code would be:
622 * rand + 5
623 * This doesn't mean rand() + 5. Because rand() is a unary operator,
624 * the +5 is its argument.
625 */
626
76e3520e 627STATIC void
cea2e8a9 628S_check_uni(pTHX)
ba106d47 629{
2f3197b3 630 char *s;
a0d0e21e 631 char *t;
0453d815 632 dTHR;
2f3197b3 633
3280af22 634 if (PL_oldoldbufptr != PL_last_uni)
2f3197b3 635 return;
3280af22
NIS
636 while (isSPACE(*PL_last_uni))
637 PL_last_uni++;
7e2040f0 638 for (s = PL_last_uni; isALNUM_lazy_if(s,UTF) || *s == '-'; s++) ;
3280af22 639 if ((t = strchr(s, '(')) && t < PL_bufptr)
a0d0e21e 640 return;
0453d815 641 if (ckWARN_d(WARN_AMBIGUOUS)){
f248d071 642 char ch = *s;
0453d815
PM
643 *s = '\0';
644 Perl_warner(aTHX_ WARN_AMBIGUOUS,
645 "Warning: Use of \"%s\" without parens is ambiguous",
646 PL_last_uni);
647 *s = ch;
648 }
2f3197b3
LW
649}
650
ffb4593c
NT
651/* workaround to replace the UNI() macro with a function. Only the
652 * hints/uts.sh file mentions this. Other comments elsewhere in the
653 * source indicate Microport Unix might need it too.
654 */
655
ffed7fef
LW
656#ifdef CRIPPLED_CC
657
658#undef UNI
ffed7fef 659#define UNI(f) return uni(f,s)
ffed7fef 660
76e3520e 661STATIC int
cea2e8a9 662S_uni(pTHX_ I32 f, char *s)
ffed7fef
LW
663{
664 yylval.ival = f;
3280af22
NIS
665 PL_expect = XTERM;
666 PL_bufptr = s;
8f872242
NIS
667 PL_last_uni = PL_oldbufptr;
668 PL_last_lop_op = f;
ffed7fef
LW
669 if (*s == '(')
670 return FUNC1;
671 s = skipspace(s);
672 if (*s == '(')
673 return FUNC1;
674 else
675 return UNIOP;
676}
677
a0d0e21e
LW
678#endif /* CRIPPLED_CC */
679
ffb4593c
NT
680/*
681 * LOP : macro to build a list operator. Its behaviour has been replaced
682 * with a subroutine, S_lop() for which LOP is just another name.
683 */
684
a0d0e21e
LW
685#define LOP(f,x) return lop(f,x,s)
686
ffb4593c
NT
687/*
688 * S_lop
689 * Build a list operator (or something that might be one). The rules:
690 * - if we have a next token, then it's a list operator [why?]
691 * - if the next thing is an opening paren, then it's a function
692 * - else it's a list operator
693 */
694
76e3520e 695STATIC I32
a0be28da 696S_lop(pTHX_ I32 f, int x, char *s)
ffed7fef 697{
0f15f207 698 dTHR;
79072805 699 yylval.ival = f;
35c8bce7 700 CLINE;
3280af22
NIS
701 PL_expect = x;
702 PL_bufptr = s;
703 PL_last_lop = PL_oldbufptr;
704 PL_last_lop_op = f;
705 if (PL_nexttoke)
a0d0e21e 706 return LSTOP;
79072805
LW
707 if (*s == '(')
708 return FUNC;
709 s = skipspace(s);
710 if (*s == '(')
711 return FUNC;
712 else
713 return LSTOP;
714}
715
ffb4593c
NT
716/*
717 * S_force_next
9cbb5ea2 718 * When the lexer realizes it knows the next token (for instance,
ffb4593c 719 * it is reordering tokens for the parser) then it can call S_force_next
9cbb5ea2
GS
720 * to know what token to return the next time the lexer is called. Caller
721 * will need to set PL_nextval[], and possibly PL_expect to ensure the lexer
722 * handles the token correctly.
ffb4593c
NT
723 */
724
76e3520e 725STATIC void
cea2e8a9 726S_force_next(pTHX_ I32 type)
79072805 727{
3280af22
NIS
728 PL_nexttype[PL_nexttoke] = type;
729 PL_nexttoke++;
730 if (PL_lex_state != LEX_KNOWNEXT) {
731 PL_lex_defer = PL_lex_state;
732 PL_lex_expect = PL_expect;
733 PL_lex_state = LEX_KNOWNEXT;
79072805
LW
734 }
735}
736
ffb4593c
NT
737/*
738 * S_force_word
739 * When the lexer knows the next thing is a word (for instance, it has
740 * just seen -> and it knows that the next char is a word char, then
741 * it calls S_force_word to stick the next word into the PL_next lookahead.
742 *
743 * Arguments:
b1b65b59 744 * char *start : buffer position (must be within PL_linestr)
ffb4593c
NT
745 * int token : PL_next will be this type of bare word (e.g., METHOD,WORD)
746 * int check_keyword : if true, Perl checks to make sure the word isn't
747 * a keyword (do this if the word is a label, e.g. goto FOO)
748 * int allow_pack : if true, : characters will also be allowed (require,
749 * use, etc. do this)
9cbb5ea2 750 * int allow_initial_tick : used by the "sub" lexer only.
ffb4593c
NT
751 */
752
76e3520e 753STATIC char *
cea2e8a9 754S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
79072805 755{
463ee0b2
LW
756 register char *s;
757 STRLEN len;
758
759 start = skipspace(start);
760 s = start;
7e2040f0 761 if (isIDFIRST_lazy_if(s,UTF) ||
a0d0e21e 762 (allow_pack && *s == ':') ||
15f0808c 763 (allow_initial_tick && *s == '\'') )
a0d0e21e 764 {
3280af22
NIS
765 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
766 if (check_keyword && keyword(PL_tokenbuf, len))
463ee0b2
LW
767 return start;
768 if (token == METHOD) {
769 s = skipspace(s);
770 if (*s == '(')
3280af22 771 PL_expect = XTERM;
463ee0b2 772 else {
3280af22 773 PL_expect = XOPERATOR;
463ee0b2 774 }
79072805 775 }
3280af22
NIS
776 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(PL_tokenbuf,0));
777 PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
79072805
LW
778 force_next(token);
779 }
780 return s;
781}
782
ffb4593c
NT
783/*
784 * S_force_ident
9cbb5ea2 785 * Called when the lexer wants $foo *foo &foo etc, but the program
ffb4593c
NT
786 * text only contains the "foo" portion. The first argument is a pointer
787 * to the "foo", and the second argument is the type symbol to prefix.
788 * Forces the next token to be a "WORD".
9cbb5ea2 789 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
ffb4593c
NT
790 */
791
76e3520e 792STATIC void
cea2e8a9 793S_force_ident(pTHX_ register char *s, int kind)
79072805
LW
794{
795 if (s && *s) {
11343788 796 OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
3280af22 797 PL_nextval[PL_nexttoke].opval = o;
79072805 798 force_next(WORD);
748a9306 799 if (kind) {
e858de61 800 dTHR; /* just for in_eval */
11343788 801 o->op_private = OPpCONST_ENTERED;
55497cff
PP
802 /* XXX see note in pp_entereval() for why we forgo typo
803 warnings if the symbol must be introduced in an eval.
804 GSAR 96-10-12 */
3280af22 805 gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
a0d0e21e
LW
806 kind == '$' ? SVt_PV :
807 kind == '@' ? SVt_PVAV :
808 kind == '%' ? SVt_PVHV :
809 SVt_PVGV
810 );
748a9306 811 }
79072805
LW
812 }
813}
814
1571675a
GS
815NV
816Perl_str_to_version(pTHX_ SV *sv)
817{
818 NV retval = 0.0;
819 NV nshift = 1.0;
820 STRLEN len;
821 char *start = SvPVx(sv,len);
822 bool utf = SvUTF8(sv);
823 char *end = start + len;
824 while (start < end) {
825 I32 skip;
826 UV n;
827 if (utf)
828 n = utf8_to_uv((U8*)start, &skip);
829 else {
830 n = *(U8*)start;
831 skip = 1;
832 }
833 retval += ((NV)n)/nshift;
834 start += skip;
835 nshift *= 1000;
836 }
837 return retval;
838}
839
ffb4593c
NT
840/*
841 * S_force_version
842 * Forces the next token to be a version number.
843 */
844
76e3520e 845STATIC char *
cea2e8a9 846S_force_version(pTHX_ char *s)
89bfa8cd
PP
847{
848 OP *version = Nullop;
44dcb63b 849 char *d;
89bfa8cd
PP
850
851 s = skipspace(s);
852
44dcb63b 853 d = s;
dd629d5b 854 if (*d == 'v')
44dcb63b 855 d++;
44dcb63b 856 if (isDIGIT(*d)) {
a7cb1f99 857 for (; isDIGIT(*d) || *d == '_' || *d == '.'; d++);
9f3d182e 858 if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
dd629d5b 859 SV *ver;
89bfa8cd 860 s = scan_num(s);
89bfa8cd 861 version = yylval.opval;
dd629d5b
GS
862 ver = cSVOPx(version)->op_sv;
863 if (SvPOK(ver) && !SvNIOK(ver)) {
155aba94 864 (void)SvUPGRADE(ver, SVt_PVNV);
1571675a
GS
865 SvNVX(ver) = str_to_version(ver);
866 SvNOK_on(ver); /* hint that it is a version */
44dcb63b 867 }
89bfa8cd
PP
868 }
869 }
870
871 /* NOTE: The parser sees the package name and the VERSION swapped */
3280af22 872 PL_nextval[PL_nexttoke].opval = version;
89bfa8cd
PP
873 force_next(WORD);
874
875 return (s);
876}
877
ffb4593c
NT
878/*
879 * S_tokeq
880 * Tokenize a quoted string passed in as an SV. It finds the next
881 * chunk, up to end of string or a backslash. It may make a new
882 * SV containing that chunk (if HINT_NEW_STRING is on). It also
883 * turns \\ into \.
884 */
885
76e3520e 886STATIC SV *
cea2e8a9 887S_tokeq(pTHX_ SV *sv)
79072805
LW
888{
889 register char *s;
890 register char *send;
891 register char *d;
b3ac6de7
IZ
892 STRLEN len = 0;
893 SV *pv = sv;
79072805
LW
894
895 if (!SvLEN(sv))
b3ac6de7 896 goto finish;
79072805 897
a0d0e21e 898 s = SvPV_force(sv, len);
748a9306 899 if (SvIVX(sv) == -1)
b3ac6de7 900 goto finish;
463ee0b2 901 send = s + len;
79072805
LW
902 while (s < send && *s != '\\')
903 s++;
904 if (s == send)
b3ac6de7 905 goto finish;
79072805 906 d = s;
3280af22 907 if ( PL_hints & HINT_NEW_STRING )
79cb57f6 908 pv = sv_2mortal(newSVpvn(SvPVX(pv), len));
79072805
LW
909 while (s < send) {
910 if (*s == '\\') {
a0d0e21e 911 if (s + 1 < send && (s[1] == '\\'))
79072805
LW
912 s++; /* all that, just for this */
913 }
914 *d++ = *s++;
915 }
916 *d = '\0';
463ee0b2 917 SvCUR_set(sv, d - SvPVX(sv));
b3ac6de7 918 finish:
3280af22 919 if ( PL_hints & HINT_NEW_STRING )
b3ac6de7 920 return new_constant(NULL, 0, "q", sv, pv, "q");
79072805
LW
921 return sv;
922}
923
ffb4593c
NT
924/*
925 * Now come three functions related to double-quote context,
926 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
927 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
928 * interact with PL_lex_state, and create fake ( ... ) argument lists
929 * to handle functions and concatenation.
930 * They assume that whoever calls them will be setting up a fake
931 * join call, because each subthing puts a ',' after it. This lets
932 * "lower \luPpEr"
933 * become
934 * join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
935 *
936 * (I'm not sure whether the spurious commas at the end of lcfirst's
937 * arguments and join's arguments are created or not).
938 */
939
940/*
941 * S_sublex_start
942 * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST).
943 *
944 * Pattern matching will set PL_lex_op to the pattern-matching op to
945 * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise).
946 *
947 * OP_CONST and OP_READLINE are easy--just make the new op and return.
948 *
949 * Everything else becomes a FUNC.
950 *
951 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
952 * had an OP_CONST or OP_READLINE). This just sets us up for a
953 * call to S_sublex_push().
954 */
955
76e3520e 956STATIC I32
cea2e8a9 957S_sublex_start(pTHX)
79072805
LW
958{
959 register I32 op_type = yylval.ival;
79072805
LW
960
961 if (op_type == OP_NULL) {
3280af22
NIS
962 yylval.opval = PL_lex_op;
963 PL_lex_op = Nullop;
79072805
LW
964 return THING;
965 }
966 if (op_type == OP_CONST || op_type == OP_READLINE) {
3280af22 967 SV *sv = tokeq(PL_lex_stuff);
b3ac6de7
IZ
968
969 if (SvTYPE(sv) == SVt_PVIV) {
970 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
971 STRLEN len;
972 char *p;
973 SV *nsv;
974
975 p = SvPV(sv, len);
79cb57f6 976 nsv = newSVpvn(p, len);
b3ac6de7
IZ
977 SvREFCNT_dec(sv);
978 sv = nsv;
979 }
980 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
3280af22 981 PL_lex_stuff = Nullsv;
79072805
LW
982 return THING;
983 }
984
3280af22
NIS
985 PL_sublex_info.super_state = PL_lex_state;
986 PL_sublex_info.sub_inwhat = op_type;
987 PL_sublex_info.sub_op = PL_lex_op;
988 PL_lex_state = LEX_INTERPPUSH;
55497cff 989
3280af22
NIS
990 PL_expect = XTERM;
991 if (PL_lex_op) {
992 yylval.opval = PL_lex_op;
993 PL_lex_op = Nullop;
55497cff
PP
994 return PMFUNC;
995 }
996 else
997 return FUNC;
998}
999
ffb4593c
NT
1000/*
1001 * S_sublex_push
1002 * Create a new scope to save the lexing state. The scope will be
1003 * ended in S_sublex_done. Returns a '(', starting the function arguments
1004 * to the uc, lc, etc. found before.
1005 * Sets PL_lex_state to LEX_INTERPCONCAT.
1006 */
1007
76e3520e 1008STATIC I32
cea2e8a9 1009S_sublex_push(pTHX)
55497cff 1010{
0f15f207 1011 dTHR;
f46d017c 1012 ENTER;
55497cff 1013
3280af22
NIS
1014 PL_lex_state = PL_sublex_info.super_state;
1015 SAVEI32(PL_lex_dojoin);
1016 SAVEI32(PL_lex_brackets);
3280af22
NIS
1017 SAVEI32(PL_lex_casemods);
1018 SAVEI32(PL_lex_starts);
1019 SAVEI32(PL_lex_state);
7766f137 1020 SAVEVPTR(PL_lex_inpat);
3280af22 1021 SAVEI32(PL_lex_inwhat);
57843af0 1022 SAVECOPLINE(PL_curcop);
3280af22
NIS
1023 SAVEPPTR(PL_bufptr);
1024 SAVEPPTR(PL_oldbufptr);
1025 SAVEPPTR(PL_oldoldbufptr);
1026 SAVEPPTR(PL_linestart);
1027 SAVESPTR(PL_linestr);
1028 SAVEPPTR(PL_lex_brackstack);
1029 SAVEPPTR(PL_lex_casestack);
1030
1031 PL_linestr = PL_lex_stuff;
1032 PL_lex_stuff = Nullsv;
1033
9cbb5ea2
GS
1034 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
1035 = SvPVX(PL_linestr);
3280af22
NIS
1036 PL_bufend += SvCUR(PL_linestr);
1037 SAVEFREESV(PL_linestr);
1038
1039 PL_lex_dojoin = FALSE;
1040 PL_lex_brackets = 0;
3280af22
NIS
1041 New(899, PL_lex_brackstack, 120, char);
1042 New(899, PL_lex_casestack, 12, char);
1043 SAVEFREEPV(PL_lex_brackstack);
1044 SAVEFREEPV(PL_lex_casestack);
1045 PL_lex_casemods = 0;
1046 *PL_lex_casestack = '\0';
1047 PL_lex_starts = 0;
1048 PL_lex_state = LEX_INTERPCONCAT;
57843af0 1049 CopLINE_set(PL_curcop, PL_multi_start);
3280af22
NIS
1050
1051 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1052 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1053 PL_lex_inpat = PL_sublex_info.sub_op;
79072805 1054 else
3280af22 1055 PL_lex_inpat = Nullop;
79072805 1056
55497cff 1057 return '(';
79072805
LW
1058}
1059
ffb4593c
NT
1060/*
1061 * S_sublex_done
1062 * Restores lexer state after a S_sublex_push.
1063 */
1064
76e3520e 1065STATIC I32
cea2e8a9 1066S_sublex_done(pTHX)
79072805 1067{
3280af22
NIS
1068 if (!PL_lex_starts++) {
1069 PL_expect = XOPERATOR;
79cb57f6 1070 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpvn("",0));
79072805
LW
1071 return THING;
1072 }
1073
3280af22
NIS
1074 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
1075 PL_lex_state = LEX_INTERPCASEMOD;
cea2e8a9 1076 return yylex();
79072805
LW
1077 }
1078
ffb4593c 1079 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
3280af22
NIS
1080 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1081 PL_linestr = PL_lex_repl;
1082 PL_lex_inpat = 0;
1083 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1084 PL_bufend += SvCUR(PL_linestr);
1085 SAVEFREESV(PL_linestr);
1086 PL_lex_dojoin = FALSE;
1087 PL_lex_brackets = 0;
3280af22
NIS
1088 PL_lex_casemods = 0;
1089 *PL_lex_casestack = '\0';
1090 PL_lex_starts = 0;
25da4f38 1091 if (SvEVALED(PL_lex_repl)) {
3280af22
NIS
1092 PL_lex_state = LEX_INTERPNORMAL;
1093 PL_lex_starts++;
e9fa98b2
HS
1094 /* we don't clear PL_lex_repl here, so that we can check later
1095 whether this is an evalled subst; that means we rely on the
1096 logic to ensure sublex_done() is called again only via the
1097 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
79072805 1098 }
e9fa98b2 1099 else {
3280af22 1100 PL_lex_state = LEX_INTERPCONCAT;
e9fa98b2
HS
1101 PL_lex_repl = Nullsv;
1102 }
79072805 1103 return ',';
ffed7fef
LW
1104 }
1105 else {
f46d017c 1106 LEAVE;
3280af22
NIS
1107 PL_bufend = SvPVX(PL_linestr);
1108 PL_bufend += SvCUR(PL_linestr);
1109 PL_expect = XOPERATOR;
09bef843 1110 PL_sublex_info.sub_inwhat = 0;
79072805 1111 return ')';
ffed7fef
LW
1112 }
1113}
1114
02aa26ce
NT
1115/*
1116 scan_const
1117
1118 Extracts a pattern, double-quoted string, or transliteration. This
1119 is terrifying code.
1120
3280af22
NIS
1121 It looks at lex_inwhat and PL_lex_inpat to find out whether it's
1122 processing a pattern (PL_lex_inpat is true), a transliteration
02aa26ce
NT
1123 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
1124
9b599b2a
GS
1125 Returns a pointer to the character scanned up to. Iff this is
1126 advanced from the start pointer supplied (ie if anything was
1127 successfully parsed), will leave an OP for the substring scanned
1128 in yylval. Caller must intuit reason for not parsing further
1129 by looking at the next characters herself.
1130
02aa26ce
NT
1131 In patterns:
1132 backslashes:
1133 double-quoted style: \r and \n
1134 regexp special ones: \D \s
1135 constants: \x3
1136 backrefs: \1 (deprecated in substitution replacements)
1137 case and quoting: \U \Q \E
1138 stops on @ and $, but not for $ as tail anchor
1139
1140 In transliterations:
1141 characters are VERY literal, except for - not at the start or end
1142 of the string, which indicates a range. scan_const expands the
1143 range to the full set of intermediate characters.
1144
1145 In double-quoted strings:
1146 backslashes:
1147 double-quoted style: \r and \n
1148 constants: \x3
1149 backrefs: \1 (deprecated)
1150 case and quoting: \U \Q \E
1151 stops on @ and $
1152
1153 scan_const does *not* construct ops to handle interpolated strings.
1154 It stops processing as soon as it finds an embedded $ or @ variable
1155 and leaves it to the caller to work out what's going on.
1156
1157 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
1158
1159 $ in pattern could be $foo or could be tail anchor. Assumption:
1160 it's a tail anchor if $ is the last thing in the string, or if it's
1161 followed by one of ")| \n\t"
1162
1163 \1 (backreferences) are turned into $1
1164
1165 The structure of the code is
1166 while (there's a character to process) {
1167 handle transliteration ranges
1168 skip regexp comments
1169 skip # initiated comments in //x patterns
1170 check for embedded @foo
1171 check for embedded scalars
1172 if (backslash) {
1173 leave intact backslashes from leave (below)
1174 deprecate \1 in strings and sub replacements
1175 handle string-changing backslashes \l \U \Q \E, etc.
1176 switch (what was escaped) {
1177 handle - in a transliteration (becomes a literal -)
1178 handle \132 octal characters
1179 handle 0x15 hex characters
1180 handle \cV (control V)
1181 handle printf backslashes (\f, \r, \n, etc)
1182 } (end switch)
1183 } (end if backslash)
1184 } (end while character to read)
1185
1186*/
1187
76e3520e 1188STATIC char *
cea2e8a9 1189S_scan_const(pTHX_ char *start)
79072805 1190{
3280af22 1191 register char *send = PL_bufend; /* end of the constant */
02aa26ce
NT
1192 SV *sv = NEWSV(93, send - start); /* sv for the constant */
1193 register char *s = start; /* start of the constant */
1194 register char *d = SvPVX(sv); /* destination for copies */
1195 bool dorange = FALSE; /* are we in a translit range? */
7e2040f0 1196 bool has_utf = FALSE; /* embedded \x{} */
02aa26ce 1197 I32 len; /* ? */
012bcf8d
GS
1198 UV uv;
1199
ac2262e3 1200 I32 utf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op)
a0ed51b3
LW
1201 ? (PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
1202 : UTF;
ac2262e3 1203 I32 thisutf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op)
9cbb5ea2
GS
1204 ? (PL_sublex_info.sub_op->op_private & (PL_lex_repl ?
1205 OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF))
a0ed51b3 1206 : UTF;
dff6d3cd 1207 const char *leaveit = /* set of acceptably-backslashed characters */
3280af22 1208 PL_lex_inpat
4a2d328f 1209 ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
9b599b2a 1210 : "";
79072805
LW
1211
1212 while (s < send || dorange) {
02aa26ce 1213 /* get transliterations out of the way (they're most literal) */
3280af22 1214 if (PL_lex_inwhat == OP_TRANS) {
02aa26ce 1215 /* expand a range A-Z to the full set of characters. AIE! */
79072805 1216 if (dorange) {
02aa26ce 1217 I32 i; /* current expanded character */
8ada0baa 1218 I32 min; /* first character in range */
02aa26ce
NT
1219 I32 max; /* last character in range */
1220
1221 i = d - SvPVX(sv); /* remember current offset */
9cbb5ea2
GS
1222 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
1223 d = SvPVX(sv) + i; /* refresh d after realloc */
02aa26ce
NT
1224 d -= 2; /* eat the first char and the - */
1225
8ada0baa
JH
1226 min = (U8)*d; /* first char in range */
1227 max = (U8)d[1]; /* last char in range */
1228
1229#ifndef ASCIIish
1230 if ((isLOWER(min) && isLOWER(max)) ||
1231 (isUPPER(min) && isUPPER(max))) {
1232 if (isLOWER(min)) {
1233 for (i = min; i <= max; i++)
1234 if (isLOWER(i))
1235 *d++ = i;
1236 } else {
1237 for (i = min; i <= max; i++)
1238 if (isUPPER(i))
1239 *d++ = i;
1240 }
1241 }
1242 else
1243#endif
1244 for (i = min; i <= max; i++)
1245 *d++ = i;
02aa26ce
NT
1246
1247 /* mark the range as done, and continue */
79072805
LW
1248 dorange = FALSE;
1249 continue;
1250 }
02aa26ce
NT
1251
1252 /* range begins (ignore - as first or last char) */
79072805 1253 else if (*s == '-' && s+1 < send && s != start) {
a0ed51b3 1254 if (utf) {
a176fa2a 1255 *d++ = (char)0xff; /* use illegal utf8 byte--see pmtrans */
a0ed51b3
LW
1256 s++;
1257 continue;
1258 }
79072805
LW
1259 dorange = TRUE;
1260 s++;
1261 }
1262 }
02aa26ce
NT
1263
1264 /* if we get here, we're not doing a transliteration */
1265
0f5d15d6
IZ
1266 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
1267 except for the last char, which will be done separately. */
3280af22 1268 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
cc6b7395
IZ
1269 if (s[2] == '#') {
1270 while (s < send && *s != ')')
1271 *d++ = *s++;
155aba94
GS
1272 }
1273 else if (s[2] == '{' /* This should match regcomp.c */
1274 || ((s[2] == 'p' || s[2] == '?') && s[3] == '{'))
1275 {
cc6b7395 1276 I32 count = 1;
0f5d15d6 1277 char *regparse = s + (s[2] == '{' ? 3 : 4);
cc6b7395
IZ
1278 char c;
1279
d9f97599
GS
1280 while (count && (c = *regparse)) {
1281 if (c == '\\' && regparse[1])
1282 regparse++;
cc6b7395
IZ
1283 else if (c == '{')
1284 count++;
1285 else if (c == '}')
1286 count--;
d9f97599 1287 regparse++;
cc6b7395 1288 }
5bdf89e7
IZ
1289 if (*regparse != ')') {
1290 regparse--; /* Leave one char for continuation. */
cc6b7395 1291 yyerror("Sequence (?{...}) not terminated or not {}-balanced");
5bdf89e7 1292 }
0f5d15d6 1293 while (s < regparse)
cc6b7395
IZ
1294 *d++ = *s++;
1295 }
748a9306 1296 }
02aa26ce
NT
1297
1298 /* likewise skip #-initiated comments in //x patterns */
3280af22
NIS
1299 else if (*s == '#' && PL_lex_inpat &&
1300 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
748a9306
LW
1301 while (s+1 < send && *s != '\n')
1302 *d++ = *s++;
1303 }
02aa26ce
NT
1304
1305 /* check for embedded arrays (@foo, @:foo, @'foo, @{foo}, @$foo) */
7e2040f0
GS
1306 else if (*s == '@' && s[1]
1307 && (isALNUM_lazy_if(s+1,UTF) || strchr(":'{$", s[1])))
79072805 1308 break;
02aa26ce
NT
1309
1310 /* check for embedded scalars. only stop if we're sure it's a
1311 variable.
1312 */
79072805 1313 else if (*s == '$') {
3280af22 1314 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
79072805 1315 break;
c277df42 1316 if (s + 1 < send && !strchr("()| \n\t", s[1]))
79072805
LW
1317 break; /* in regexp, $ might be tail anchor */
1318 }
02aa26ce 1319
a0ed51b3
LW
1320 /* (now in tr/// code again) */
1321
d008e5eb 1322 if (*s & 0x80 && thisutf) {
012bcf8d
GS
1323 (void)utf8_to_uv((U8*)s, &len);
1324 if (len == 1) {
1325 /* illegal UTF8, make it valid */
012bcf8d 1326 char *old_pvx = SvPVX(sv);
bee7c419
GS
1327 /* need space for one extra char (NOTE: SvCUR() not set here) */
1328 d = SvGROW(sv, SvLEN(sv) + 1) + (d - old_pvx);
012bcf8d
GS
1329 d = (char*)uv_to_utf8((U8*)d, (U8)*s++);
1330 }
1331 else {
1332 while (len--)
1333 *d++ = *s++;
1334 }
1335 has_utf = TRUE;
1336 continue;
a0ed51b3
LW
1337 }
1338
02aa26ce 1339 /* backslashes */
79072805
LW
1340 if (*s == '\\' && s+1 < send) {
1341 s++;
02aa26ce
NT
1342
1343 /* some backslashes we leave behind */
c9f97d15 1344 if (*leaveit && *s && strchr(leaveit, *s)) {
79072805
LW
1345 *d++ = '\\';
1346 *d++ = *s++;
1347 continue;
1348 }
02aa26ce
NT
1349
1350 /* deprecate \1 in strings and substitution replacements */
3280af22 1351 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
a0d0e21e 1352 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
79072805 1353 {
d008e5eb 1354 dTHR; /* only for ckWARN */
599cee73 1355 if (ckWARN(WARN_SYNTAX))
cea2e8a9 1356 Perl_warner(aTHX_ WARN_SYNTAX, "\\%c better written as $%c", *s, *s);
79072805
LW
1357 *--s = '$';
1358 break;
1359 }
02aa26ce
NT
1360
1361 /* string-change backslash escapes */
3280af22 1362 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
79072805
LW
1363 --s;
1364 break;
1365 }
02aa26ce
NT
1366
1367 /* if we get here, it's either a quoted -, or a digit */
79072805 1368 switch (*s) {
02aa26ce
NT
1369
1370 /* quoted - in transliterations */
79072805 1371 case '-':
3280af22 1372 if (PL_lex_inwhat == OP_TRANS) {
79072805
LW
1373 *d++ = *s++;
1374 continue;
1375 }
1376 /* FALL THROUGH */
1377 default:
11b8faa4
JH
1378 {
1379 dTHR;
e476b1b5
GS
1380 if (ckWARN(WARN_MISC) && isALPHA(*s))
1381 Perl_warner(aTHX_ WARN_MISC,
11b8faa4
JH
1382 "Unrecognized escape \\%c passed through",
1383 *s);
1384 /* default action is to copy the quoted character */
1385 *d++ = *s++;
1386 continue;
1387 }
02aa26ce
NT
1388
1389 /* \132 indicates an octal constant */
79072805
LW
1390 case '0': case '1': case '2': case '3':
1391 case '4': case '5': case '6': case '7':
012bcf8d 1392 uv = (UV)scan_oct(s, 3, &len);
79072805 1393 s += len;
012bcf8d 1394 goto NUM_ESCAPE_INSERT;
02aa26ce
NT
1395
1396 /* \x24 indicates a hex constant */
79072805 1397 case 'x':
a0ed51b3
LW
1398 ++s;
1399 if (*s == '{') {
1400 char* e = strchr(s, '}');
adaeee49 1401 if (!e) {
a0ed51b3 1402 yyerror("Missing right brace on \\x{}");
adaeee49
GA
1403 e = s;
1404 }
012bcf8d
GS
1405 uv = (UV)scan_hex(s + 1, e - s - 1, &len);
1406 s = e + 1;
a0ed51b3
LW
1407 }
1408 else {
012bcf8d
GS
1409 uv = (UV)scan_hex(s, 2, &len);
1410 s += len;
1411 }
1412
1413 NUM_ESCAPE_INSERT:
1414 /* Insert oct or hex escaped character.
1415 * There will always enough room in sv since such escapes will
1416 * be longer than any utf8 sequence they can end up as
1417 */
1418 if (uv > 127) {
1419 if (!thisutf && !has_utf && uv > 255) {
1420 /* might need to recode whatever we have accumulated so far
1421 * if it contains any hibit chars
1422 */
1423 int hicount = 0;
1424 char *c;
1425 for (c = SvPVX(sv); c < d; c++) {
1426 if (*c & 0x80)
1427 hicount++;
1428 }
1429 if (hicount) {
1430 char *old_pvx = SvPVX(sv);
1431 char *src, *dst;
1432 d = SvGROW(sv, SvCUR(sv) + hicount + 1) + (d - old_pvx);
1433
1434 src = d - 1;
1435 d += hicount;
1436 dst = d - 1;
1437
1438 while (src < dst) {
1439 if (*src & 0x80) {
1440 dst--;
1441 uv_to_utf8((U8*)dst, (U8)*src--);
1442 dst--;
1443 }
1444 else {
1445 *dst-- = *src--;
1446 }
1447 }
1448 }
1449 }
1450
1451 if (thisutf || uv > 255) {
1452 d = (char*)uv_to_utf8((U8*)d, uv);
7e2040f0 1453 has_utf = TRUE;
012bcf8d 1454 }
a0ed51b3 1455 else {
012bcf8d 1456 *d++ = (char)uv;
a0ed51b3 1457 }
012bcf8d
GS
1458 }
1459 else {
1460 *d++ = (char)uv;
a0ed51b3 1461 }
79072805 1462 continue;
02aa26ce 1463
4a2d328f
IZ
1464 /* \N{latin small letter a} is a named character */
1465 case 'N':
423cee85
JH
1466 ++s;
1467 if (*s == '{') {
1468 char* e = strchr(s, '}');
155aba94 1469 SV *res;
423cee85
JH
1470 STRLEN len;
1471 char *str;
423cee85
JH
1472
1473 if (!e) {
5777a3f7 1474 yyerror("Missing right brace on \\N{}");
423cee85
JH
1475 e = s - 1;
1476 goto cont_scan;
1477 }
1478 res = newSVpvn(s + 1, e - s - 1);
1479 res = new_constant( Nullch, 0, "charnames",
5777a3f7 1480 res, Nullsv, "\\N{...}" );
423cee85 1481 str = SvPV(res,len);
f08d6ad9
GS
1482 if (!has_utf && SvUTF8(res)) {
1483 char *ostart = SvPVX(sv);
1484 SvCUR_set(sv, d - ostart);
1485 SvPOK_on(sv);
1486 sv_utf8_upgrade(sv);
1487 d = SvPVX(sv) + SvCUR(sv);
e1992b6d 1488 has_utf = TRUE;
f08d6ad9 1489 }
423cee85
JH
1490 if (len > e - s + 4) {
1491 char *odest = SvPVX(sv);
1492
1493 SvGROW(sv, (SvCUR(sv) + len - (e - s + 4)));
1494 d = SvPVX(sv) + (d - odest);
1495 }
1496 Copy(str, d, len, char);
1497 d += len;
1498 SvREFCNT_dec(res);
1499 cont_scan:
1500 s = e + 1;
1501 }
1502 else
5777a3f7 1503 yyerror("Missing braces on \\N{}");
423cee85
JH
1504 continue;
1505
02aa26ce 1506 /* \c is a control character */
79072805
LW
1507 case 'c':
1508 s++;
9d116dd7
JH
1509#ifdef EBCDIC
1510 *d = *s++;
1511 if (isLOWER(*d))
1512 *d = toUPPER(*d);
774a9426
GS
1513 *d = toCTRL(*d);
1514 d++;
9d116dd7 1515#else
bbce6d69
PP
1516 len = *s++;
1517 *d++ = toCTRL(len);
9d116dd7 1518#endif
79072805 1519 continue;
02aa26ce
NT
1520
1521 /* printf-style backslashes, formfeeds, newlines, etc */
79072805
LW
1522 case 'b':
1523 *d++ = '\b';
1524 break;
1525 case 'n':
1526 *d++ = '\n';
1527 break;
1528 case 'r':
1529 *d++ = '\r';
1530 break;
1531 case 'f':
1532 *d++ = '\f';
1533 break;
1534 case 't':
1535 *d++ = '\t';
1536 break;
34a3fe2a
PP
1537#ifdef EBCDIC
1538 case 'e':
1539 *d++ = '\047'; /* CP 1047 */
1540 break;
1541 case 'a':
1542 *d++ = '\057'; /* CP 1047 */
1543 break;
1544#else
79072805
LW
1545 case 'e':
1546 *d++ = '\033';
1547 break;
1548 case 'a':
1549 *d++ = '\007';
1550 break;
34a3fe2a 1551#endif
02aa26ce
NT
1552 } /* end switch */
1553
79072805
LW
1554 s++;
1555 continue;
02aa26ce
NT
1556 } /* end if (backslash) */
1557
79072805 1558 *d++ = *s++;
02aa26ce
NT
1559 } /* while loop to process each character */
1560
1561 /* terminate the string and set up the sv */
79072805 1562 *d = '\0';
463ee0b2 1563 SvCUR_set(sv, d - SvPVX(sv));
79072805 1564 SvPOK_on(sv);
7e2040f0
GS
1565 if (has_utf)
1566 SvUTF8_on(sv);
79072805 1567
02aa26ce 1568 /* shrink the sv if we allocated more than we used */
79072805
LW
1569 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1570 SvLEN_set(sv, SvCUR(sv) + 1);
463ee0b2 1571 Renew(SvPVX(sv), SvLEN(sv), char);
79072805 1572 }
02aa26ce 1573
9b599b2a 1574 /* return the substring (via yylval) only if we parsed anything */
3280af22
NIS
1575 if (s > PL_bufptr) {
1576 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1577 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
b3ac6de7 1578 sv, Nullsv,
3280af22 1579 ( PL_lex_inwhat == OP_TRANS
b3ac6de7 1580 ? "tr"
3280af22 1581 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
b3ac6de7
IZ
1582 ? "s"
1583 : "qq")));
79072805 1584 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
b3ac6de7 1585 } else
8990e307 1586 SvREFCNT_dec(sv);
79072805
LW
1587 return s;
1588}
1589
ffb4593c
NT
1590/* S_intuit_more
1591 * Returns TRUE if there's more to the expression (e.g., a subscript),
1592 * FALSE otherwise.
ffb4593c
NT
1593 *
1594 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
1595 *
1596 * ->[ and ->{ return TRUE
1597 * { and [ outside a pattern are always subscripts, so return TRUE
1598 * if we're outside a pattern and it's not { or [, then return FALSE
1599 * if we're in a pattern and the first char is a {
1600 * {4,5} (any digits around the comma) returns FALSE
1601 * if we're in a pattern and the first char is a [
1602 * [] returns FALSE
1603 * [SOMETHING] has a funky algorithm to decide whether it's a
1604 * character class or not. It has to deal with things like
1605 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
1606 * anything else returns TRUE
1607 */
1608
9cbb5ea2
GS
1609/* This is the one truly awful dwimmer necessary to conflate C and sed. */
1610
76e3520e 1611STATIC int
cea2e8a9 1612S_intuit_more(pTHX_ register char *s)
79072805 1613{
3280af22 1614 if (PL_lex_brackets)
79072805
LW
1615 return TRUE;
1616 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1617 return TRUE;
1618 if (*s != '{' && *s != '[')
1619 return FALSE;
3280af22 1620 if (!PL_lex_inpat)
79072805
LW
1621 return TRUE;
1622
1623 /* In a pattern, so maybe we have {n,m}. */
1624 if (*s == '{') {
1625 s++;
1626 if (!isDIGIT(*s))
1627 return TRUE;
1628 while (isDIGIT(*s))
1629 s++;
1630 if (*s == ',')
1631 s++;
1632 while (isDIGIT(*s))
1633 s++;
1634 if (*s == '}')
1635 return FALSE;
1636 return TRUE;
1637
1638 }
1639
1640 /* On the other hand, maybe we have a character class */
1641
1642 s++;
1643 if (*s == ']' || *s == '^')
1644 return FALSE;
1645 else {
ffb4593c 1646 /* this is terrifying, and it works */
79072805
LW
1647 int weight = 2; /* let's weigh the evidence */
1648 char seen[256];
f27ffc4a 1649 unsigned char un_char = 255, last_un_char;
93a17b20 1650 char *send = strchr(s,']');
3280af22 1651 char tmpbuf[sizeof PL_tokenbuf * 4];
79072805
LW
1652
1653 if (!send) /* has to be an expression */
1654 return TRUE;
1655
1656 Zero(seen,256,char);
1657 if (*s == '$')
1658 weight -= 3;
1659 else if (isDIGIT(*s)) {
1660 if (s[1] != ']') {
1661 if (isDIGIT(s[1]) && s[2] == ']')
1662 weight -= 10;
1663 }
1664 else
1665 weight -= 100;
1666 }
1667 for (; s < send; s++) {
1668 last_un_char = un_char;
1669 un_char = (unsigned char)*s;
1670 switch (*s) {
1671 case '@':
1672 case '&':
1673 case '$':
1674 weight -= seen[un_char] * 10;
7e2040f0 1675 if (isALNUM_lazy_if(s+1,UTF)) {
8903cb82 1676 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
a0d0e21e 1677 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
79072805
LW
1678 weight -= 100;
1679 else
1680 weight -= 10;
1681 }
1682 else if (*s == '$' && s[1] &&
93a17b20
LW
1683 strchr("[#!%*<>()-=",s[1])) {
1684 if (/*{*/ strchr("])} =",s[2]))
79072805
LW
1685 weight -= 10;
1686 else
1687 weight -= 1;
1688 }
1689 break;
1690 case '\\':
1691 un_char = 254;
1692 if (s[1]) {
93a17b20 1693 if (strchr("wds]",s[1]))
79072805
LW
1694 weight += 100;
1695 else if (seen['\''] || seen['"'])
1696 weight += 1;
93a17b20 1697 else if (strchr("rnftbxcav",s[1]))
79072805
LW
1698 weight += 40;
1699 else if (isDIGIT(s[1])) {
1700 weight += 40;
1701 while (s[1] && isDIGIT(s[1]))
1702 s++;
1703 }
1704 }
1705 else
1706 weight += 100;
1707 break;
1708 case '-':
1709 if (s[1] == '\\')
1710 weight += 50;
93a17b20 1711 if (strchr("aA01! ",last_un_char))
79072805 1712 weight += 30;
93a17b20 1713 if (strchr("zZ79~",s[1]))
79072805 1714 weight += 30;
f27ffc4a
GS
1715 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1716 weight -= 5; /* cope with negative subscript */
79072805
LW
1717 break;
1718 default:
93a17b20 1719 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
79072805
LW
1720 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1721 char *d = tmpbuf;
1722 while (isALPHA(*s))
1723 *d++ = *s++;
1724 *d = '\0';
1725 if (keyword(tmpbuf, d - tmpbuf))
1726 weight -= 150;
1727 }
1728 if (un_char == last_un_char + 1)
1729 weight += 5;
1730 weight -= seen[un_char];
1731 break;
1732 }
1733 seen[un_char]++;
1734 }
1735 if (weight >= 0) /* probably a character class */
1736 return FALSE;
1737 }
1738
1739 return TRUE;
1740}
ffed7fef 1741
ffb4593c
NT
1742/*
1743 * S_intuit_method
1744 *
1745 * Does all the checking to disambiguate
1746 * foo bar
1747 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
1748 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
1749 *
1750 * First argument is the stuff after the first token, e.g. "bar".
1751 *
1752 * Not a method if bar is a filehandle.
1753 * Not a method if foo is a subroutine prototyped to take a filehandle.
1754 * Not a method if it's really "Foo $bar"
1755 * Method if it's "foo $bar"
1756 * Not a method if it's really "print foo $bar"
1757 * Method if it's really "foo package::" (interpreted as package->foo)
1758 * Not a method if bar is known to be a subroutne ("sub bar; foo bar")
3cb0bbe5 1759 * Not a method if bar is a filehandle or package, but is quoted with
ffb4593c
NT
1760 * =>
1761 */
1762
76e3520e 1763STATIC int
cea2e8a9 1764S_intuit_method(pTHX_ char *start, GV *gv)
a0d0e21e
LW
1765{
1766 char *s = start + (*start == '$');
3280af22 1767 char tmpbuf[sizeof PL_tokenbuf];
a0d0e21e
LW
1768 STRLEN len;
1769 GV* indirgv;
1770
1771 if (gv) {
b6c543e3 1772 CV *cv;
a0d0e21e
LW
1773 if (GvIO(gv))
1774 return 0;
b6c543e3
IZ
1775 if ((cv = GvCVu(gv))) {
1776 char *proto = SvPVX(cv);
1777 if (proto) {
1778 if (*proto == ';')
1779 proto++;
1780 if (*proto == '*')
1781 return 0;
1782 }
1783 } else
a0d0e21e
LW
1784 gv = 0;
1785 }
8903cb82 1786 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
ffb4593c
NT
1787 /* start is the beginning of the possible filehandle/object,
1788 * and s is the end of it
1789 * tmpbuf is a copy of it
1790 */
1791
a0d0e21e 1792 if (*start == '$') {
3280af22 1793 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
a0d0e21e
LW
1794 return 0;
1795 s = skipspace(s);
3280af22
NIS
1796 PL_bufptr = start;
1797 PL_expect = XREF;
a0d0e21e
LW
1798 return *s == '(' ? FUNCMETH : METHOD;
1799 }
1800 if (!keyword(tmpbuf, len)) {
c3e0f903
GS
1801 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1802 len -= 2;
1803 tmpbuf[len] = '\0';
1804 goto bare_package;
1805 }
1806 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
8ebc5c01 1807 if (indirgv && GvCVu(indirgv))
a0d0e21e
LW
1808 return 0;
1809 /* filehandle or package name makes it a method */
89bfa8cd 1810 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
a0d0e21e 1811 s = skipspace(s);
3280af22 1812 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
55497cff 1813 return 0; /* no assumptions -- "=>" quotes bearword */
c3e0f903 1814 bare_package:
3280af22 1815 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
79cb57f6 1816 newSVpvn(tmpbuf,len));
3280af22
NIS
1817 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1818 PL_expect = XTERM;
a0d0e21e 1819 force_next(WORD);
3280af22 1820 PL_bufptr = s;
a0d0e21e
LW
1821 return *s == '(' ? FUNCMETH : METHOD;
1822 }
1823 }
1824 return 0;
1825}
1826
ffb4593c
NT
1827/*
1828 * S_incl_perldb
1829 * Return a string of Perl code to load the debugger. If PERL5DB
1830 * is set, it will return the contents of that, otherwise a
1831 * compile-time require of perl5db.pl.
1832 */
1833
76e3520e 1834STATIC char*
cea2e8a9 1835S_incl_perldb(pTHX)
a0d0e21e 1836{
3280af22 1837 if (PL_perldb) {
76e3520e 1838 char *pdb = PerlEnv_getenv("PERL5DB");
a0d0e21e
LW
1839
1840 if (pdb)
1841 return pdb;
61bb5906 1842 SETERRNO(0,SS$_NORMAL);
a0d0e21e
LW
1843 return "BEGIN { require 'perl5db.pl' }";
1844 }
1845 return "";
1846}
1847
1848
16d20bd9
AD
1849/* Encoded script support. filter_add() effectively inserts a
1850 * 'pre-processing' function into the current source input stream.
1851 * Note that the filter function only applies to the current source file
1852 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1853 *
1854 * The datasv parameter (which may be NULL) can be used to pass
1855 * private data to this instance of the filter. The filter function
1856 * can recover the SV using the FILTER_DATA macro and use it to
1857 * store private buffers and state information.
1858 *
1859 * The supplied datasv parameter is upgraded to a PVIO type
e0c19803
GS
1860 * and the IoDIRP field is used to store the function pointer,
1861 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
16d20bd9
AD
1862 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1863 * private use must be set using malloc'd pointers.
1864 */
16d20bd9
AD
1865
1866SV *
864dbfa3 1867Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
16d20bd9 1868{
f4c556ac
GS
1869 if (!funcp)
1870 return Nullsv;
1871
3280af22
NIS
1872 if (!PL_rsfp_filters)
1873 PL_rsfp_filters = newAV();
16d20bd9 1874 if (!datasv)
8c52afec 1875 datasv = NEWSV(255,0);
16d20bd9 1876 if (!SvUPGRADE(datasv, SVt_PVIO))
cea2e8a9 1877 Perl_die(aTHX_ "Can't upgrade filter_add data to SVt_PVIO");
16d20bd9 1878 IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
e0c19803 1879 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
f4c556ac
GS
1880 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
1881 funcp, SvPV_nolen(datasv)));
3280af22
NIS
1882 av_unshift(PL_rsfp_filters, 1);
1883 av_store(PL_rsfp_filters, 0, datasv) ;
16d20bd9
AD
1884 return(datasv);
1885}
1886
1887
1888/* Delete most recently added instance of this filter function. */
a0d0e21e 1889void
864dbfa3 1890Perl_filter_del(pTHX_ filter_t funcp)
16d20bd9 1891{
e0c19803 1892 SV *datasv;
f4c556ac 1893 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", funcp));
3280af22 1894 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
16d20bd9
AD
1895 return;
1896 /* if filter is on top of stack (usual case) just pop it off */
e0c19803
GS
1897 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
1898 if (IoDIRP(datasv) == (DIR*)funcp) {
1899 IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
1900 IoDIRP(datasv) = (DIR*)NULL;
3280af22 1901 sv_free(av_pop(PL_rsfp_filters));
e50aee73 1902
16d20bd9
AD
1903 return;
1904 }
1905 /* we need to search for the correct entry and clear it */
cea2e8a9 1906 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
16d20bd9
AD
1907}
1908
1909
1910/* Invoke the n'th filter function for the current rsfp. */
1911I32
864dbfa3 1912Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
8ac85365
NIS
1913
1914
1915 /* 0 = read one text line */
a0d0e21e 1916{
16d20bd9
AD
1917 filter_t funcp;
1918 SV *datasv = NULL;
e50aee73 1919
3280af22 1920 if (!PL_rsfp_filters)
16d20bd9 1921 return -1;
3280af22 1922 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
16d20bd9
AD
1923 /* Provide a default input filter to make life easy. */
1924 /* Note that we append to the line. This is handy. */
f4c556ac
GS
1925 DEBUG_P(PerlIO_printf(Perl_debug_log,
1926 "filter_read %d: from rsfp\n", idx));
16d20bd9
AD
1927 if (maxlen) {
1928 /* Want a block */
1929 int len ;
1930 int old_len = SvCUR(buf_sv) ;
1931
1932 /* ensure buf_sv is large enough */
1933 SvGROW(buf_sv, old_len + maxlen) ;
3280af22
NIS
1934 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1935 if (PerlIO_error(PL_rsfp))
37120919
AD
1936 return -1; /* error */
1937 else
1938 return 0 ; /* end of file */
1939 }
16d20bd9
AD
1940 SvCUR_set(buf_sv, old_len + len) ;
1941 } else {
1942 /* Want a line */
3280af22
NIS
1943 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
1944 if (PerlIO_error(PL_rsfp))
37120919
AD
1945 return -1; /* error */
1946 else
1947 return 0 ; /* end of file */
1948 }
16d20bd9
AD
1949 }
1950 return SvCUR(buf_sv);
1951 }
1952 /* Skip this filter slot if filter has been deleted */
3280af22 1953 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
f4c556ac
GS
1954 DEBUG_P(PerlIO_printf(Perl_debug_log,
1955 "filter_read %d: skipped (filter deleted)\n",
1956 idx));
16d20bd9
AD
1957 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1958 }
1959 /* Get function pointer hidden within datasv */
1960 funcp = (filter_t)IoDIRP(datasv);
f4c556ac
GS
1961 DEBUG_P(PerlIO_printf(Perl_debug_log,
1962 "filter_read %d: via function %p (%s)\n",
1963 idx, funcp, SvPV_nolen(datasv)));
16d20bd9
AD
1964 /* Call function. The function is expected to */
1965 /* call "FILTER_READ(idx+1, buf_sv)" first. */
37120919 1966 /* Return: <0:error, =0:eof, >0:not eof */
0cb96387 1967 return (*funcp)(aTHXo_ idx, buf_sv, maxlen);
16d20bd9
AD
1968}
1969
76e3520e 1970STATIC char *
cea2e8a9 1971S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
16d20bd9 1972{
c39cd008 1973#ifdef PERL_CR_FILTER
3280af22 1974 if (!PL_rsfp_filters) {
c39cd008 1975 filter_add(S_cr_textfilter,NULL);
a868473f
NIS
1976 }
1977#endif
3280af22 1978 if (PL_rsfp_filters) {
16d20bd9 1979
55497cff
PP
1980 if (!append)
1981 SvCUR_set(sv, 0); /* start with empty line */
16d20bd9
AD
1982 if (FILTER_READ(0, sv, 0) > 0)
1983 return ( SvPVX(sv) ) ;
1984 else
1985 return Nullch ;
1986 }
9d116dd7 1987 else
fd049845 1988 return (sv_gets(sv, fp, append));
a0d0e21e
LW
1989}
1990
1991
748a9306
LW
1992#ifdef DEBUGGING
1993 static char* exp_name[] =
09bef843
SB
1994 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
1995 "ATTRTERM", "TERMBLOCK"
1996 };
748a9306 1997#endif
463ee0b2 1998
02aa26ce
NT
1999/*
2000 yylex
2001
2002 Works out what to call the token just pulled out of the input
2003 stream. The yacc parser takes care of taking the ops we return and
2004 stitching them into a tree.
2005
2006 Returns:
2007 PRIVATEREF
2008
2009 Structure:
2010 if read an identifier
2011 if we're in a my declaration
2012 croak if they tried to say my($foo::bar)
2013 build the ops for a my() declaration
2014 if it's an access to a my() variable
2015 are we in a sort block?
2016 croak if my($a); $a <=> $b
2017 build ops for access to a my() variable
2018 if in a dq string, and they've said @foo and we can't find @foo
2019 croak
2020 build ops for a bareword
2021 if we already built the token before, use it.
2022*/
2023
864dbfa3
GS
2024int
2025#ifdef USE_PURE_BISON
cea2e8a9 2026Perl_yylex(pTHX_ YYSTYPE *lvalp, int *lcharp)
864dbfa3 2027#else
cea2e8a9 2028Perl_yylex(pTHX)
864dbfa3 2029#endif
378cc40b 2030{
11343788 2031 dTHR;
79072805 2032 register char *s;
378cc40b 2033 register char *d;
79072805 2034 register I32 tmp;
463ee0b2 2035 STRLEN len;
161b471a
NIS
2036 GV *gv = Nullgv;
2037 GV **gvp = 0;
a687059c 2038
a1a0e61e
TD
2039#ifdef USE_PURE_BISON
2040 yylval_pointer = lvalp;
2041 yychar_pointer = lcharp;
2042#endif
2043
02aa26ce 2044 /* check if there's an identifier for us to look at */
3280af22 2045 if (PL_pending_ident) {
02aa26ce 2046 /* pit holds the identifier we read and pending_ident is reset */
3280af22
NIS
2047 char pit = PL_pending_ident;
2048 PL_pending_ident = 0;
bbce6d69 2049
02aa26ce
NT
2050 /* if we're in a my(), we can't allow dynamics here.
2051 $foo'bar has already been turned into $foo::bar, so
2052 just check for colons.
2053
2054 if it's a legal name, the OP is a PADANY.
2055 */
3280af22 2056 if (PL_in_my) {
77ca0c92 2057 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
1ec3e8de
GS
2058 if (strchr(PL_tokenbuf,':'))
2059 yyerror(Perl_form(aTHX_ "No package name allowed for "
2060 "variable %s in \"our\"",
2061 PL_tokenbuf));
77ca0c92
LW
2062 tmp = pad_allocmy(PL_tokenbuf);
2063 }
2064 else {
2065 if (strchr(PL_tokenbuf,':'))
2066 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
02aa26ce 2067
77ca0c92
LW
2068 yylval.opval = newOP(OP_PADANY, 0);
2069 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
2070 return PRIVATEREF;
2071 }
bbce6d69
PP
2072 }
2073
02aa26ce
NT
2074 /*
2075 build the ops for accesses to a my() variable.
2076
2077 Deny my($a) or my($b) in a sort block, *if* $a or $b is
2078 then used in a comparison. This catches most, but not
2079 all cases. For instance, it catches
2080 sort { my($a); $a <=> $b }
2081 but not
2082 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
2083 (although why you'd do that is anyone's guess).
2084 */
2085
3280af22 2086 if (!strchr(PL_tokenbuf,':')) {
a863c7d1 2087#ifdef USE_THREADS
54b9620d 2088 /* Check for single character per-thread SVs */
3280af22
NIS
2089 if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
2090 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
2091 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
554b3eca 2092 {
2faa37cc 2093 yylval.opval = newOP(OP_THREADSV, 0);
a863c7d1
MB
2094 yylval.opval->op_targ = tmp;
2095 return PRIVATEREF;
2096 }
2097#endif /* USE_THREADS */
3280af22 2098 if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
f472eb5c 2099 SV *namesv = AvARRAY(PL_comppad_name)[tmp];
77ca0c92 2100 /* might be an "our" variable" */
f472eb5c 2101 if (SvFLAGS(namesv) & SVpad_OUR) {
77ca0c92 2102 /* build ops for a bareword */
f472eb5c
GS
2103 SV *sym = newSVpv(HvNAME(GvSTASH(namesv)),0);
2104 sv_catpvn(sym, "::", 2);
2105 sv_catpv(sym, PL_tokenbuf+1);
2106 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
77ca0c92 2107 yylval.opval->op_private = OPpCONST_ENTERED;
f472eb5c 2108 gv_fetchpv(SvPVX(sym),
77ca0c92 2109 (PL_in_eval
f472eb5c
GS
2110 ? (GV_ADDMULTI | GV_ADDINEVAL)
2111 : TRUE
77ca0c92
LW
2112 ),
2113 ((PL_tokenbuf[0] == '$') ? SVt_PV
2114 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
2115 : SVt_PVHV));
2116 return WORD;
2117 }
2118
02aa26ce 2119 /* if it's a sort block and they're naming $a or $b */
3280af22
NIS
2120 if (PL_last_lop_op == OP_SORT &&
2121 PL_tokenbuf[0] == '$' &&
2122 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
2123 && !PL_tokenbuf[2])
bbce6d69 2124 {
3280af22
NIS
2125 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
2126 d < PL_bufend && *d != '\n';
a863c7d1
MB
2127 d++)
2128 {
2129 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
cea2e8a9 2130 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
3280af22 2131 PL_tokenbuf);
a863c7d1 2132 }
bbce6d69
PP
2133 }
2134 }
bbce6d69 2135
a863c7d1
MB
2136 yylval.opval = newOP(OP_PADANY, 0);
2137 yylval.opval->op_targ = tmp;
2138 return PRIVATEREF;
2139 }
bbce6d69
PP
2140 }
2141
02aa26ce
NT
2142 /*
2143 Whine if they've said @foo in a doublequoted string,
2144 and @foo isn't a variable we can find in the symbol
2145 table.
2146 */
3280af22
NIS
2147 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
2148 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
2149 if (!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
cea2e8a9 2150 yyerror(Perl_form(aTHX_ "In string, %s now must be written as \\%s",
3280af22 2151 PL_tokenbuf, PL_tokenbuf));
bbce6d69
PP
2152 }
2153
02aa26ce 2154 /* build ops for a bareword */
3280af22 2155 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
bbce6d69 2156 yylval.opval->op_private = OPpCONST_ENTERED;
3280af22
NIS
2157 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
2158 ((PL_tokenbuf[0] == '$') ? SVt_PV
2159 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
bbce6d69
PP
2160 : SVt_PVHV));
2161 return WORD;
2162 }
2163
02aa26ce
NT
2164 /* no identifier pending identification */
2165
3280af22 2166 switch (PL_lex_state) {
79072805
LW
2167#ifdef COMMENTARY
2168 case LEX_NORMAL: /* Some compilers will produce faster */
2169 case LEX_INTERPNORMAL: /* code if we comment these out. */
2170 break;
2171#endif
2172
09bef843 2173 /* when we've already built the next token, just pull it out of the queue */
79072805 2174 case LEX_KNOWNEXT:
3280af22
NIS
2175 PL_nexttoke--;
2176 yylval = PL_nextval[PL_nexttoke];
2177 if (!PL_nexttoke) {
2178 PL_lex_state = PL_lex_defer;
2179 PL_expect = PL_lex_expect;
2180 PL_lex_defer = LEX_NORMAL;
463ee0b2 2181 }
3280af22 2182 return(PL_nexttype[PL_nexttoke]);
79072805 2183
02aa26ce 2184 /* interpolated case modifiers like \L \U, including \Q and \E.
3280af22 2185 when we get here, PL_bufptr is at the \
02aa26ce 2186 */
79072805
LW
2187 case LEX_INTERPCASEMOD:
2188#ifdef DEBUGGING
3280af22 2189 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
cea2e8a9 2190 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
79072805 2191#endif
02aa26ce 2192 /* handle \E or end of string */
3280af22 2193 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
a0d0e21e 2194 char oldmod;
02aa26ce
NT
2195
2196 /* if at a \E */
3280af22
NIS
2197 if (PL_lex_casemods) {
2198 oldmod = PL_lex_casestack[--PL_lex_casemods];
2199 PL_lex_casestack[PL_lex_casemods] = '\0';
02aa26ce 2200
3280af22
NIS
2201 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
2202 PL_bufptr += 2;
2203 PL_lex_state = LEX_INTERPCONCAT;
a0d0e21e 2204 }
79072805
LW
2205 return ')';
2206 }
3280af22
NIS
2207 if (PL_bufptr != PL_bufend)
2208 PL_bufptr += 2;
2209 PL_lex_state = LEX_INTERPCONCAT;
cea2e8a9 2210 return yylex();
79072805
LW
2211 }
2212 else {
3280af22 2213 s = PL_bufptr + 1;
79072805
LW
2214 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
2215 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
a0d0e21e 2216 if (strchr("LU", *s) &&
3280af22 2217 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
a0d0e21e 2218 {
3280af22 2219 PL_lex_casestack[--PL_lex_casemods] = '\0';
a0d0e21e
LW
2220 return ')';
2221 }
3280af22
NIS
2222 if (PL_lex_casemods > 10) {
2223 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
2224 if (newlb != PL_lex_casestack) {
a0d0e21e 2225 SAVEFREEPV(newlb);
3280af22 2226 PL_lex_casestack = newlb;
a0d0e21e
LW
2227 }
2228 }
3280af22
NIS
2229 PL_lex_casestack[PL_lex_casemods++] = *s;
2230 PL_lex_casestack[PL_lex_casemods] = '\0';
2231 PL_lex_state = LEX_INTERPCONCAT;
2232 PL_nextval[PL_nexttoke].ival = 0;
79072805
LW
2233 force_next('(');
2234 if (*s == 'l')
3280af22 2235 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
79072805 2236 else if (*s == 'u')
3280af22 2237 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
79072805 2238 else if (*s == 'L')
3280af22 2239 PL_nextval[PL_nexttoke].ival = OP_LC;
79072805 2240 else if (*s == 'U')
3280af22 2241 PL_nextval[PL_nexttoke].ival = OP_UC;
a0d0e21e 2242 else if (*s == 'Q')
3280af22 2243 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
79072805 2244 else
cea2e8a9 2245 Perl_croak(aTHX_ "panic: yylex");
3280af22 2246 PL_bufptr = s + 1;
79072805 2247 force_next(FUNC);
3280af22
NIS
2248 if (PL_lex_starts) {
2249 s = PL_bufptr;
2250 PL_lex_starts = 0;
79072805
LW
2251 Aop(OP_CONCAT);
2252 }
2253 else
cea2e8a9 2254 return yylex();
79072805
LW
2255 }
2256
55497cff
PP
2257 case LEX_INTERPPUSH:
2258 return sublex_push();
2259
79072805 2260 case LEX_INTERPSTART:
3280af22 2261 if (PL_bufptr == PL_bufend)
79072805 2262 return sublex_done();
3280af22
NIS
2263 PL_expect = XTERM;
2264 PL_lex_dojoin = (*PL_bufptr == '@');
2265 PL_lex_state = LEX_INTERPNORMAL;
2266 if (PL_lex_dojoin) {
2267 PL_nextval[PL_nexttoke].ival = 0;
79072805 2268 force_next(',');
554b3eca 2269#ifdef USE_THREADS
533c011a
NIS
2270 PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
2271 PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
554b3eca
MB
2272 force_next(PRIVATEREF);
2273#else
a0d0e21e 2274 force_ident("\"", '$');
554b3eca 2275#endif /* USE_THREADS */
3280af22 2276 PL_nextval[PL_nexttoke].ival = 0;
79072805 2277 force_next('$');
3280af22 2278 PL_nextval[PL_nexttoke].ival = 0;
79072805 2279 force_next('(');
3280af22 2280 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
79072805
LW
2281 force_next(FUNC);
2282 }
3280af22
NIS
2283 if (PL_lex_starts++) {
2284 s = PL_bufptr;
79072805
LW
2285 Aop(OP_CONCAT);
2286 }
cea2e8a9 2287 return yylex();
79072805
LW
2288
2289 case LEX_INTERPENDMAYBE:
3280af22
NIS
2290 if (intuit_more(PL_bufptr)) {
2291 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
79072805
LW
2292 break;
2293 }
2294 /* FALL THROUGH */
2295
2296 case LEX_INTERPEND:
3280af22
NIS
2297 if (PL_lex_dojoin) {
2298 PL_lex_dojoin = FALSE;
2299 PL_lex_state = LEX_INTERPCONCAT;
79072805
LW
2300 return ')';
2301 }
43a16006 2302 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
25da4f38 2303 && SvEVALED(PL_lex_repl))
43a16006 2304 {
e9fa98b2 2305 if (PL_bufptr != PL_bufend)
cea2e8a9 2306 Perl_croak(aTHX_ "Bad evalled substitution pattern");
e9fa98b2
HS
2307 PL_lex_repl = Nullsv;
2308 }
79072805
LW
2309 /* FALLTHROUGH */
2310 case LEX_INTERPCONCAT:
2311#ifdef DEBUGGING
3280af22 2312 if (PL_lex_brackets)
cea2e8a9 2313 Perl_croak(aTHX_ "panic: INTERPCONCAT");
79072805 2314#endif
3280af22 2315 if (PL_bufptr == PL_bufend)
79072805
LW
2316 return sublex_done();
2317
3280af22
NIS
2318 if (SvIVX(PL_linestr) == '\'') {
2319 SV *sv = newSVsv(PL_linestr);
2320 if (!PL_lex_inpat)
76e3520e 2321 sv = tokeq(sv);
3280af22 2322 else if ( PL_hints & HINT_NEW_RE )
b3ac6de7 2323 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
79072805 2324 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3280af22 2325 s = PL_bufend;
79072805
LW
2326 }
2327 else {
3280af22 2328 s = scan_const(PL_bufptr);
79072805 2329 if (*s == '\\')
3280af22 2330 PL_lex_state = LEX_INTERPCASEMOD;
79072805 2331 else
3280af22 2332 PL_lex_state = LEX_INTERPSTART;
79072805
LW
2333 }
2334
3280af22
NIS
2335 if (s != PL_bufptr) {
2336 PL_nextval[PL_nexttoke] = yylval;
2337 PL_expect = XTERM;
79072805 2338 force_next(THING);
3280af22 2339 if (PL_lex_starts++)
79072805
LW
2340 Aop(OP_CONCAT);
2341 else {
3280af22 2342 PL_bufptr = s;
cea2e8a9 2343 return yylex();
79072805
LW
2344 }
2345 }
2346
cea2e8a9 2347 return yylex();
a0d0e21e 2348 case LEX_FORMLINE:
3280af22
NIS
2349 PL_lex_state = LEX_NORMAL;
2350 s = scan_formline(PL_bufptr);
2351 if (!PL_lex_formbrack)
a0d0e21e
LW
2352 goto rightbracket;
2353 OPERATOR(';');
79072805
LW
2354 }
2355
3280af22
NIS
2356 s = PL_bufptr;
2357 PL_oldoldbufptr = PL_oldbufptr;
2358 PL_oldbufptr = s;
79072805 2359 DEBUG_p( {
bf49b057
GS
2360 PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at %s\n",
2361 exp_name[PL_expect], s);
79072805 2362 } )
463ee0b2
LW
2363
2364 retry:
378cc40b
LW
2365 switch (*s) {
2366 default:
7e2040f0 2367 if (isIDFIRST_lazy_if(s,UTF))
834a4ddd 2368 goto keylookup;
cea2e8a9 2369 Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
e929a76b
LW
2370 case 4:
2371 case 26:
2372 goto fake_eof; /* emulate EOF on ^D or ^Z */
378cc40b 2373 case 0:
3280af22
NIS
2374 if (!PL_rsfp) {
2375 PL_last_uni = 0;
2376 PL_last_lop = 0;
2377 if (PL_lex_brackets)
d98d5fff 2378 yyerror("Missing right curly or square bracket");
79072805 2379 TOKEN(0);
463ee0b2 2380 }
3280af22 2381 if (s++ < PL_bufend)
a687059c 2382 goto retry; /* ignore stray nulls */
3280af22
NIS
2383 PL_last_uni = 0;
2384 PL_last_lop = 0;
2385 if (!PL_in_eval && !PL_preambled) {
2386 PL_preambled = TRUE;
2387 sv_setpv(PL_linestr,incl_perldb());
2388 if (SvCUR(PL_linestr))
2389 sv_catpv(PL_linestr,";");
2390 if (PL_preambleav){
2391 while(AvFILLp(PL_preambleav) >= 0) {
2392 SV *tmpsv = av_shift(PL_preambleav);
2393 sv_catsv(PL_linestr, tmpsv);
2394 sv_catpv(PL_linestr, ";");
91b7def8
PP
2395 sv_free(tmpsv);
2396 }
3280af22
NIS
2397 sv_free((SV*)PL_preambleav);
2398 PL_preambleav = NULL;
91b7def8 2399 }
3280af22
NIS
2400 if (PL_minus_n || PL_minus_p) {
2401 sv_catpv(PL_linestr, "LINE: while (<>) {");
2402 if (PL_minus_l)
2403 sv_catpv(PL_linestr,"chomp;");
2404 if (PL_minus_a) {
8fd239a7
CS
2405 GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
2406 if (gv)
2407 GvIMPORTED_AV_on(gv);
3280af22
NIS
2408 if (PL_minus_F) {
2409 if (strchr("/'\"", *PL_splitstr)
2410 && strchr(PL_splitstr + 1, *PL_splitstr))
cea2e8a9 2411 Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s);", PL_splitstr);
54310121
PP
2412 else {
2413 char delim;
2414 s = "'~#\200\1'"; /* surely one char is unused...*/
3280af22 2415 while (s[1] && strchr(PL_splitstr, *s)) s++;
54310121 2416 delim = *s;
cea2e8a9 2417 Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s%c",
46fc3d4c 2418 "q" + (delim == '\''), delim);
3280af22 2419 for (s = PL_splitstr; *s; s++) {
54310121 2420 if (*s == '\\')
3280af22
NIS
2421 sv_catpvn(PL_linestr, "\\", 1);
2422 sv_catpvn(PL_linestr, s, 1);
54310121 2423 }
cea2e8a9 2424 Perl_sv_catpvf(aTHX_ PL_linestr, "%c);", delim);
54310121 2425 }
2304df62
AD
2426 }
2427 else
3280af22 2428 sv_catpv(PL_linestr,"@F=split(' ');");
2304df62 2429 }
79072805 2430 }
3280af22
NIS
2431 sv_catpv(PL_linestr, "\n");
2432 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2433 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2434 if (PERLDB_LINE && PL_curstash != PL_debstash) {
a0d0e21e
LW
2435 SV *sv = NEWSV(85,0);
2436
2437 sv_upgrade(sv, SVt_PVMG);
3280af22 2438 sv_setsv(sv,PL_linestr);
57843af0 2439 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
a0d0e21e 2440 }
79072805 2441 goto retry;
a687059c 2442 }
e929a76b 2443 do {
3280af22 2444 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
e929a76b 2445 fake_eof:
3280af22
NIS
2446 if (PL_rsfp) {
2447 if (PL_preprocess && !PL_in_eval)
2448 (void)PerlProc_pclose(PL_rsfp);
2449 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2450 PerlIO_clearerr(PL_rsfp);
395c3793 2451 else
3280af22
NIS
2452 (void)PerlIO_close(PL_rsfp);
2453 PL_rsfp = Nullfp;
4a9ae47a 2454 PL_doextract = FALSE;
395c3793 2455 }
3280af22
NIS
2456 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2457 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
2458 sv_catpv(PL_linestr,";}");
2459 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2460 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2461 PL_minus_n = PL_minus_p = 0;
e929a76b
LW
2462 goto retry;
2463 }
3280af22
NIS
2464 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2465 sv_setpv(PL_linestr,"");
79072805 2466 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
378cc40b 2467 }
3280af22 2468 if (PL_doextract) {
a0d0e21e 2469 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
3280af22 2470 PL_doextract = FALSE;
a0d0e21e
LW
2471
2472 /* Incest with pod. */
2473 if (*s == '=' && strnEQ(s, "=cut", 4)) {
3280af22
NIS
2474 sv_setpv(PL_linestr, "");
2475 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2476 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2477 PL_doextract = FALSE;
a0d0e21e
LW
2478 }
2479 }
463ee0b2 2480 incline(s);
3280af22
NIS
2481 } while (PL_doextract);
2482 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2483 if (PERLDB_LINE && PL_curstash != PL_debstash) {
79072805 2484 SV *sv = NEWSV(85,0);
a687059c 2485
93a17b20 2486 sv_upgrade(sv, SVt_PVMG);
3280af22 2487 sv_setsv(sv,PL_linestr);
57843af0 2488 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
a687059c 2489 }
3280af22 2490 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
57843af0 2491 if (CopLINE(PL_curcop) == 1) {
3280af22 2492 while (s < PL_bufend && isSPACE(*s))
79072805 2493 s++;
a0d0e21e 2494 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
79072805 2495 s++;
44a8e56a 2496 d = Nullch;
3280af22 2497 if (!PL_in_eval) {
44a8e56a
PP
2498 if (*s == '#' && *(s+1) == '!')
2499 d = s + 2;
2500#ifdef ALTERNATE_SHEBANG
2501 else {
2502 static char as[] = ALTERNATE_SHEBANG;
2503 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2504 d = s + (sizeof(as) - 1);
2505 }
2506#endif /* ALTERNATE_SHEBANG */
2507 }
2508 if (d) {
b8378b72 2509 char *ipath;
774d564b 2510 char *ipathend;
b8378b72 2511
774d564b 2512 while (isSPACE(*d))
b8378b72
CS
2513 d++;
2514 ipath = d;
774d564b
PP
2515 while (*d && !isSPACE(*d))
2516 d++;
2517 ipathend = d;
2518
2519#ifdef ARG_ZERO_IS_SCRIPT
2520 if (ipathend > ipath) {
2521 /*
2522 * HP-UX (at least) sets argv[0] to the script name,
2523 * which makes $^X incorrect. And Digital UNIX and Linux,
2524 * at least, set argv[0] to the basename of the Perl
2525 * interpreter. So, having found "#!", we'll set it right.
2526 */
2527 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
2528 assert(SvPOK(x) || SvGMAGICAL(x));
cc49e20b 2529 if (sv_eq(x, CopFILESV(PL_curcop))) {
774d564b 2530 sv_setpvn(x, ipath, ipathend - ipath);
9607fc9c
PP
2531 SvSETMAGIC(x);
2532 }
774d564b 2533 TAINT_NOT; /* $^X is always tainted, but that's OK */
8ebc5c01 2534 }
774d564b 2535#endif /* ARG_ZERO_IS_SCRIPT */
b8378b72
CS
2536
2537 /*
2538 * Look for options.
2539 */
748a9306 2540 d = instr(s,"perl -");
84e30d1a 2541 if (!d) {
748a9306 2542 d = instr(s,"perl");
84e30d1a
GS
2543#if defined(DOSISH)
2544 /* avoid getting into infinite loops when shebang
2545 * line contains "Perl" rather than "perl" */
2546 if (!d) {
2547 for (d = ipathend-4; d >= ipath; --d) {
2548 if ((*d == 'p' || *d == 'P')
2549 && !ibcmp(d, "perl", 4))
2550 {
2551 break;
2552 }
2553 }
2554 if (d < ipath)
2555 d = Nullch;
2556 }
2557#endif
2558 }
44a8e56a
PP
2559#ifdef ALTERNATE_SHEBANG
2560 /*
2561 * If the ALTERNATE_SHEBANG on this system starts with a
2562 * character that can be part of a Perl expression, then if
2563 * we see it but not "perl", we're probably looking at the
2564 * start of Perl code, not a request to hand off to some
2565 * other interpreter. Similarly, if "perl" is there, but
2566 * not in the first 'word' of the line, we assume the line
2567 * contains the start of the Perl program.
44a8e56a
PP
2568 */
2569 if (d && *s != '#') {
774d564b 2570 char *c = ipath;
44a8e56a
PP
2571 while (*c && !strchr("; \t\r\n\f\v#", *c))
2572 c++;
2573 if (c < d)
2574 d = Nullch; /* "perl" not in first word; ignore */
2575 else
2576 *s = '#'; /* Don't try to parse shebang line */
2577 }
774d564b 2578#endif /* ALTERNATE_SHEBANG */
748a9306 2579 if (!d &&
44a8e56a 2580 *s == '#' &&
774d564b 2581 ipathend > ipath &&
3280af22 2582 !PL_minus_c &&
748a9306 2583 !instr(s,"indir") &&
3280af22 2584 instr(PL_origargv[0],"perl"))
748a9306 2585 {
9f68db38 2586 char **newargv;
9f68db38 2587
774d564b
PP
2588 *ipathend = '\0';
2589 s = ipathend + 1;
3280af22 2590 while (s < PL_bufend && isSPACE(*s))
9f68db38 2591 s++;
3280af22
NIS
2592 if (s < PL_bufend) {
2593 Newz(899,newargv,PL_origargc+3,char*);
9f68db38 2594 newargv[1] = s;
3280af22 2595 while (s < PL_bufend && !isSPACE(*s))
9f68db38
LW
2596 s++;
2597 *s = '\0';
3280af22 2598 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
9f68db38
LW
2599 }
2600 else
3280af22 2601 newargv = PL_origargv;
774d564b 2602 newargv[0] = ipath;
80252599 2603 PerlProc_execv(ipath, newargv);
cea2e8a9 2604 Perl_croak(aTHX_ "Can't exec %s", ipath);
9f68db38 2605 }
748a9306 2606 if (d) {
3280af22
NIS
2607 U32 oldpdb = PL_perldb;
2608 bool oldn = PL_minus_n;
2609 bool oldp = PL_minus_p;
748a9306
LW
2610
2611 while (*d && !isSPACE(*d)) d++;
89bfa8cd 2612 while (*d == ' ' || *d == '\t') d++;
748a9306
LW
2613
2614 if (*d++ == '-') {
8cc95fdb
PP
2615 do {
2616 if (*d == 'M' || *d == 'm') {
2617 char *m = d;
2618 while (*d && !isSPACE(*d)) d++;
cea2e8a9 2619 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
8cc95fdb
PP
2620 (int)(d - m), m);
2621 }
2622 d = moreswitches(d);
2623 } while (d);
155aba94
GS
2624 if ((PERLDB_LINE && !oldpdb) ||
2625 ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
b084f20b
PP
2626 /* if we have already added "LINE: while (<>) {",
2627 we must not do it again */
748a9306 2628 {
3280af22
NIS
2629 sv_setpv(PL_linestr, "");
2630 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2631 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2632 PL_preambled = FALSE;
84902520 2633 if (PERLDB_LINE)
3280af22 2634 (void)gv_fetchfile(PL_origfilename);
748a9306
LW
2635 goto retry;
2636 }
a0d0e21e 2637 }
79072805 2638 }
9f68db38 2639 }
79072805 2640 }
3280af22
NIS
2641 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2642 PL_bufptr = s;
2643 PL_lex_state = LEX_FORMLINE;
cea2e8a9 2644 return yylex();
ae986130 2645 }
378cc40b 2646 goto retry;
4fdae800 2647 case '\r':
6a27c188 2648#ifdef PERL_STRICT_CR
cea2e8a9
GS
2649 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2650 Perl_croak(aTHX_
cc507455 2651 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
a868473f 2652#endif
4fdae800 2653 case ' ': case '\t': case '\f': case 013:
378cc40b
LW
2654 s++;
2655 goto retry;
378cc40b 2656 case '#':
e929a76b 2657 case '\n':
3280af22
NIS
2658 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2659 d = PL_bufend;
a687059c 2660 while (s < d && *s != '\n')
378cc40b 2661 s++;
0f85fab0 2662 if (s < d)
378cc40b 2663 s++;
463ee0b2 2664 incline(s);
3280af22
NIS
2665 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2666 PL_bufptr = s;
2667 PL_lex_state = LEX_FORMLINE;
cea2e8a9 2668 return yylex();
a687059c 2669 }
378cc40b 2670 }
a687059c 2671 else {
378cc40b 2672 *s = '\0';
3280af22 2673 PL_bufend = s;
a687059c 2674 }
378cc40b
LW
2675 goto retry;
2676 case '-':
79072805 2677 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
378cc40b 2678 s++;
3280af22 2679 PL_bufptr = s;
748a9306
LW
2680 tmp = *s++;
2681
3280af22 2682 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
748a9306
LW
2683 s++;
2684
2685 if (strnEQ(s,"=>",2)) {
3280af22 2686 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
748a9306
LW
2687 OPERATOR('-'); /* unary minus */
2688 }
3280af22
NIS
2689 PL_last_uni = PL_oldbufptr;
2690 PL_last_lop_op = OP_FTEREAD; /* good enough */
748a9306 2691 switch (tmp) {
79072805
LW
2692 case 'r': FTST(OP_FTEREAD);
2693 case 'w': FTST(OP_FTEWRITE);
2694 case 'x': FTST(OP_FTEEXEC);
2695 case 'o': FTST(OP_FTEOWNED);
2696 case 'R': FTST(OP_FTRREAD);
2697 case 'W': FTST(OP_FTRWRITE);
2698 case 'X': FTST(OP_FTREXEC);
2699 case 'O': FTST(OP_FTROWNED);
2700 case 'e': FTST(OP_FTIS);
2701 case 'z': FTST(OP_FTZERO);
2702 case 's': FTST(OP_FTSIZE);
2703 case 'f': FTST(OP_FTFILE);
2704 case 'd': FTST(OP_FTDIR);
2705 case 'l': FTST(OP_FTLINK);
2706 case 'p': FTST(OP_FTPIPE);
2707 case 'S': FTST(OP_FTSOCK);
2708 case 'u': FTST(OP_FTSUID);
2709 case 'g': FTST(OP_FTSGID);
2710 case 'k': FTST(OP_FTSVTX);
2711 case 'b': FTST(OP_FTBLK);
2712 case 'c': FTST(OP_FTCHR);
2713 case 't': FTST(OP_FTTTY);
2714 case 'T': FTST(OP_FTTEXT);
2715 case 'B': FTST(OP_FTBINARY);
85e6fe83
LW
2716 case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2717 case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2718 case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
378cc40b 2719 default:
cea2e8a9 2720 Perl_croak(aTHX_ "Unrecognized file test: -%c", (int)tmp);
378cc40b
LW
2721 break;
2722 }
2723 }
a687059c
LW
2724 tmp = *s++;
2725 if (*s == tmp) {
2726 s++;
3280af22 2727 if (PL_expect == XOPERATOR)
79072805
LW
2728 TERM(POSTDEC);
2729 else
2730 OPERATOR(PREDEC);
2731 }
2732 else if (*s == '>') {
2733 s++;
2734 s = skipspace(s);
7e2040f0 2735 if (isIDFIRST_lazy_if(s,UTF)) {
a0d0e21e 2736 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
463ee0b2 2737 TOKEN(ARROW);
79072805 2738 }
748a9306
LW
2739 else if (*s == '$')
2740 OPERATOR(ARROW);
463ee0b2 2741 else
748a9306 2742 TERM(ARROW);
a687059c 2743 }
3280af22 2744 if (PL_expect == XOPERATOR)
79072805
LW
2745 Aop(OP_SUBTRACT);
2746 else {
3280af22 2747 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2f3197b3 2748 check_uni();
79072805 2749 OPERATOR('-'); /* unary minus */
2f3197b3 2750 }
79072805 2751
378cc40b 2752 case '+':
a687059c
LW
2753 tmp = *s++;
2754 if (*s == tmp) {
378cc40b 2755 s++;
3280af22 2756 if (PL_expect == XOPERATOR)
79072805
LW
2757 TERM(POSTINC);
2758 else
2759 OPERATOR(PREINC);
378cc40b 2760 }
3280af22 2761 if (PL_expect == XOPERATOR)
79072805
LW
2762 Aop(OP_ADD);
2763 else {
3280af22 2764 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2f3197b3 2765 check_uni();
a687059c 2766 OPERATOR('+');
2f3197b3 2767 }
a687059c 2768
378cc40b 2769 case '*':
3280af22
NIS
2770 if (PL_expect != XOPERATOR) {
2771 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2772 PL_expect = XOPERATOR;
2773 force_ident(PL_tokenbuf, '*');
2774 if (!*PL_tokenbuf)
a0d0e21e 2775 PREREF('*');
79072805 2776 TERM('*');
a687059c 2777 }
79072805
LW
2778 s++;
2779 if (*s == '*') {
a687059c 2780 s++;
79072805 2781 PWop(OP_POW);
a687059c 2782 }
79072805
LW
2783 Mop(OP_MULTIPLY);
2784
378cc40b 2785 case '%':
3280af22 2786 if (PL_expect == XOPERATOR) {
bbce6d69
PP
2787 ++s;
2788 Mop(OP_MODULO);
a687059c 2789 }
3280af22
NIS
2790 PL_tokenbuf[0] = '%';
2791 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2792 if (!PL_tokenbuf[1]) {
2793 if (s == PL_bufend)
bbce6d69
PP
2794 yyerror("Final % should be \\% or %name");
2795 PREREF('%');
a687059c 2796 }
3280af22 2797 PL_pending_ident = '%';
bbce6d69 2798 TERM('%');
a687059c 2799
378cc40b 2800 case '^':
79072805 2801 s++;
a0d0e21e 2802 BOop(OP_BIT_XOR);
79072805 2803 case '[':
3280af22 2804 PL_lex_brackets++;
79072805 2805 /* FALL THROUGH */
378cc40b 2806 case '~':
378cc40b 2807 case ',':
378cc40b
LW
2808 tmp = *s++;
2809 OPERATOR(tmp);
a0d0e21e
LW
2810 case ':':
2811 if (s[1] == ':') {
2812 len = 0;
2813 goto just_a_word;
2814 }
2815 s++;
09bef843
SB
2816 switch (PL_expect) {
2817 OP *attrs;
2818 case XOPERATOR:
2819 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
2820 break;
2821 PL_bufptr = s; /* update in case we back off */
2822 goto grabattrs;
2823 case XATTRBLOCK:
2824 PL_expect = XBLOCK;
2825 goto grabattrs;
2826 case XATTRTERM:
2827 PL_expect = XTERMBLOCK;
2828 grabattrs:
2829 s = skipspace(s);
2830 attrs = Nullop;
7e2040f0 2831 while (isIDFIRST_lazy_if(s,UTF)) {
09bef843 2832 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
f9829d6b
GS
2833 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
2834 if (tmp < 0) tmp = -tmp;
2835 switch (tmp) {
2836 case KEY_or:
2837 case KEY_and:
2838 case KEY_for:
2839 case KEY_unless:
2840 case KEY_if:
2841 case KEY_while:
2842 case KEY_until:
2843 goto got_attrs;
2844 default:
2845 break;
2846 }
2847 }
09bef843
SB
2848 if (*d == '(') {
2849 d = scan_str(d,TRUE,TRUE);
2850 if (!d) {
2851 if (PL_lex_stuff) {
2852 SvREFCNT_dec(PL_lex_stuff);
2853 PL_lex_stuff = Nullsv;
2854 }
2855 /* MUST advance bufptr here to avoid bogus
2856 "at end of line" context messages from yyerror().
2857 */
2858 PL_bufptr = s + len;
2859 yyerror("Unterminated attribute parameter in attribute list");
2860 if (attrs)
2861 op_free(attrs);
2862 return 0; /* EOF indicator */
2863 }
2864 }
2865 if (PL_lex_stuff) {
2866 SV *sv = newSVpvn(s, len);
2867 sv_catsv(sv, PL_lex_stuff);
2868 attrs = append_elem(OP_LIST, attrs,
2869 newSVOP(OP_CONST, 0, sv));
2870 SvREFCNT_dec(PL_lex_stuff);
2871 PL_lex_stuff = Nullsv;
2872 }
2873 else {
2874 attrs = append_elem(OP_LIST, attrs,
2875 newSVOP(OP_CONST, 0,
2876 newSVpvn(s, len)));
2877 }
2878 s = skipspace(d);
0120eecf 2879 if (*s == ':' && s[1] != ':')
09bef843 2880 s = skipspace(s+1);
0120eecf
GS
2881 else if (s == d)
2882 break; /* require real whitespace or :'s */
09bef843 2883 }
f9829d6b
GS
2884 tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
2885 if (*s != ';' && *s != tmp && (tmp != '=' || *s != ')')) {
09bef843
SB
2886 char q = ((*s == '\'') ? '"' : '\'');
2887 /* If here for an expression, and parsed no attrs, back off. */
2888 if (tmp == '=' && !attrs) {
2889 s = PL_bufptr;
2890 break;
2891 }
2892 /* MUST advance bufptr here to avoid bogus "at end of line"
2893 context messages from yyerror().
2894 */
2895 PL_bufptr = s;
2896 if (!*s)
2897 yyerror("Unterminated attribute list");
2898 else
2899 yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list",
2900 q, *s, q));
2901 if (attrs)
2902 op_free(attrs);
2903 OPERATOR(':');
2904 }
f9829d6b 2905 got_attrs:
09bef843
SB
2906 if (attrs) {
2907 PL_nextval[PL_nexttoke].opval = attrs;
2908 force_next(THING);
2909 }
2910 TOKEN(COLONATTR);
2911 }
a0d0e21e 2912 OPERATOR(':');
8990e307
LW
2913 case '(':
2914 s++;
3280af22
NIS
2915 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
2916 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
a0d0e21e 2917 else
3280af22 2918 PL_expect = XTERM;
a0d0e21e 2919 TOKEN('(');
378cc40b 2920 case ';':
57843af0
GS
2921 if (CopLINE(PL_curcop) < PL_copline)
2922 PL_copline = CopLINE(PL_curcop);
378cc40b
LW
2923 tmp = *s++;
2924 OPERATOR(tmp);
2925 case ')':
378cc40b 2926 tmp = *s++;
16d20bd9
AD
2927 s = skipspace(s);
2928 if (*s == '{')
2929 PREBLOCK(tmp);
378cc40b 2930 TERM(tmp);
79072805
LW
2931 case ']':
2932 s++;
3280af22 2933 if (PL_lex_brackets <= 0)
d98d5fff 2934 yyerror("Unmatched right square bracket");
463ee0b2 2935 else
3280af22
NIS
2936 --PL_lex_brackets;
2937 if (PL_lex_state == LEX_INTERPNORMAL) {
2938 if (PL_lex_brackets == 0) {
a0d0e21e 2939 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
3280af22 2940 PL_lex_state = LEX_INTERPEND;
79072805
LW
2941 }
2942 }
4633a7c4 2943 TERM(']');
79072805
LW
2944 case '{':
2945 leftbracket:
79072805 2946 s++;
3280af22
NIS
2947 if (PL_lex_brackets > 100) {
2948 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
2949 if (newlb != PL_lex_brackstack) {
8990e307 2950 SAVEFREEPV(newlb);
3280af22 2951 PL_lex_brackstack = newlb;
8990e307
LW
2952 }
2953 }
3280af22 2954 switch (PL_expect) {
a0d0e21e 2955 case XTERM:
3280af22 2956 if (PL_lex_formbrack) {
a0d0e21e
LW
2957 s--;
2958 PRETERMBLOCK(DO);
2959 }
3280af22
NIS
2960 if (PL_oldoldbufptr == PL_last_lop)
2961 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
a0d0e21e 2962 else
3280af22 2963 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
79072805 2964 OPERATOR(HASHBRACK);
a0d0e21e 2965 case XOPERATOR:
3280af22 2966 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
748a9306 2967 s++;
44a8e56a 2968 d = s;
3280af22
NIS
2969 PL_tokenbuf[0] = '\0';
2970 if (d < PL_bufend && *d == '-') {
2971 PL_tokenbuf[0] = '-';
44a8e56a 2972 d++;
3280af22 2973 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
44a8e56a
PP
2974 d++;
2975 }
7e2040f0 2976 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
3280af22 2977 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
8903cb82 2978 FALSE, &len);
3280af22 2979 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
748a9306
LW
2980 d++;
2981 if (*d == '}') {
3280af22 2982 char minus = (PL_tokenbuf[0] == '-');
44a8e56a
PP
2983 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2984 if (minus)
2985 force_next('-');
748a9306
LW
2986 }
2987 }
2988 /* FALL THROUGH */
09bef843 2989 case XATTRBLOCK:
748a9306 2990 case XBLOCK:
3280af22
NIS
2991 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
2992 PL_expect = XSTATE;
a0d0e21e 2993 break;
09bef843 2994 case XATTRTERM:
a0d0e21e 2995 case XTERMBLOCK:
3280af22
NIS
2996 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2997 PL_expect = XSTATE;
a0d0e21e
LW
2998 break;
2999 default: {
3000 char *t;
3280af22
NIS
3001 if (PL_oldoldbufptr == PL_last_lop)
3002 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
a0d0e21e 3003 else
3280af22 3004 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
a0d0e21e 3005 s = skipspace(s);
09ecc4b6 3006 if (*s == '}')
a0d0e21e 3007 OPERATOR(HASHBRACK);
b8a4b1be
GS
3008 /* This hack serves to disambiguate a pair of curlies
3009 * as being a block or an anon hash. Normally, expectation
3010 * determines that, but in cases where we're not in a
3011 * position to expect anything in particular (like inside
3012 * eval"") we have to resolve the ambiguity. This code
3013 * covers the case where the first term in the curlies is a
3014 * quoted string. Most other cases need to be explicitly
3015 * disambiguated by prepending a `+' before the opening
3016 * curly in order to force resolution as an anon hash.
3017 *
3018 * XXX should probably propagate the outer expectation
3019 * into eval"" to rely less on this hack, but that could
3020 * potentially break current behavior of eval"".
3021 * GSAR 97-07-21
3022 */
3023 t = s;
3024 if (*s == '\'' || *s == '"' || *s == '`') {
3025 /* common case: get past first string, handling escapes */
3280af22 3026 for (t++; t < PL_bufend && *t != *s;)
b8a4b1be
GS
3027 if (*t++ == '\\' && (*t == '\\' || *t == *s))
3028 t++;
3029 t++;
a0d0e21e 3030 }
b8a4b1be 3031 else if (*s == 'q') {
3280af22 3032 if (++t < PL_bufend
b8a4b1be 3033 && (!isALNUM(*t)
3280af22 3034 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
0505442f
GS
3035 && !isALNUM(*t))))
3036 {
b8a4b1be
GS
3037 char *tmps;
3038 char open, close, term;
3039 I32 brackets = 1;
3040
3280af22 3041 while (t < PL_bufend && isSPACE(*t))
b8a4b1be
GS
3042 t++;
3043 term = *t;
3044 open = term;
3045 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
3046 term = tmps[5];
3047 close = term;
3048 if (open == close)
3280af22
NIS
3049 for (t++; t < PL_bufend; t++) {
3050 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
b8a4b1be 3051 t++;
6d07e5e9 3052 else if (*t == open)
b8a4b1be
GS
3053 break;
3054 }
3055 else
3280af22
NIS
3056 for (t++; t < PL_bufend; t++) {
3057 if (*t == '\\' && t+1 < PL_bufend)
b8a4b1be 3058 t++;
6d07e5e9 3059 else if (*t == close && --brackets <= 0)
b8a4b1be
GS
3060 break;
3061 else if (*t == open)
3062 brackets++;
3063 }
3064 }
3065 t++;
a0d0e21e 3066 }
7e2040f0 3067 else if (isALNUM_lazy_if(t,UTF)) {
0505442f 3068 t += UTF8SKIP(t);
7e2040f0 3069 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
0505442f 3070 t += UTF8SKIP(t);
a0d0e21e 3071 }
3280af22 3072 while (t < PL_bufend && isSPACE(*t))
a0d0e21e 3073 t++;
b8a4b1be
GS
3074 /* if comma follows first term, call it an anon hash */
3075 /* XXX it could be a comma expression with loop modifiers */
3280af22 3076 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
b8a4b1be 3077 || (*t == '=' && t[1] == '>')))
a0d0e21e 3078 OPERATOR(HASHBRACK);
3280af22 3079 if (PL_expect == XREF)
4e4e412b 3080 PL_expect = XTERM;
a0d0e21e 3081 else {
3280af22
NIS
3082 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
3083 PL_expect = XSTATE;
a0d0e21e 3084 }
8990e307 3085 }
a0d0e21e 3086 break;
463ee0b2 3087 }
57843af0 3088 yylval.ival = CopLINE(PL_curcop);
79072805 3089 if (isSPACE(*s) || *s == '#')
3280af22 3090 PL_copline = NOLINE; /* invalidate current command line number */
79072805 3091 TOKEN('{');
378cc40b 3092 case '}':
79072805
LW
3093 rightbracket:
3094 s++;
3280af22 3095 if (PL_lex_brackets <= 0)
d98d5fff 3096 yyerror("Unmatched right curly bracket");
463ee0b2 3097 else
3280af22
NIS
3098 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
3099 if (PL_lex_brackets < PL_lex_formbrack)
3100 PL_lex_formbrack = 0;
3101 if (PL_lex_state == LEX_INTERPNORMAL) {
3102 if (PL_lex_brackets == 0) {
9059aa12
LW
3103 if (PL_expect & XFAKEBRACK) {
3104 PL_expect &= XENUMMASK;
3280af22
NIS
3105 PL_lex_state = LEX_INTERPEND;
3106 PL_bufptr = s;
cea2e8a9 3107 return yylex(); /* ignore fake brackets */
79072805 3108 }
fa83b5b6 3109 if (*s == '-' && s[1] == '>')
3280af22 3110 PL_lex_state = LEX_INTERPENDMAYBE;
fa83b5b6 3111 else if (*s != '[' && *s != '{')
3280af22 3112 PL_lex_state = LEX_INTERPEND;
79072805
LW
3113 }
3114 }
9059aa12
LW
3115 if (PL_expect & XFAKEBRACK) {
3116 PL_expect &= XENUMMASK;
3280af22 3117 PL_bufptr = s;
cea2e8a9 3118 return yylex(); /* ignore fake brackets */
748a9306 3119 }
79072805
LW
3120 force_next('}');
3121 TOKEN(';');
378cc40b
LW
3122 case '&':
3123 s++;
3124 tmp = *s++;
3125 if (tmp == '&')
a0d0e21e 3126 AOPERATOR(ANDAND);
378cc40b 3127 s--;
3280af22 3128 if (PL_expect == XOPERATOR) {
7e2040f0
GS
3129 if (ckWARN(WARN_SEMICOLON)
3130 && isIDFIRST_lazy_if(s,UTF) && PL_bufptr == PL_linestart)
3131 {
57843af0 3132 CopLINE_dec(PL_curcop);
cea2e8a9 3133 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
57843af0 3134 CopLINE_inc(PL_curcop);
463ee0b2 3135 }
79072805 3136 BAop(OP_BIT_AND);
463ee0b2 3137 }
79072805 3138
3280af22
NIS
3139 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3140 if (*PL_tokenbuf) {
3141 PL_expect = XOPERATOR;
3142 force_ident(PL_tokenbuf, '&');
463ee0b2 3143 }
79072805
LW
3144 else
3145 PREREF('&');
c07a80fd 3146 yylval.ival = (OPpENTERSUB_AMPER<<8);
79072805
LW
3147 TERM('&');
3148
378cc40b
LW
3149 case '|':
3150 s++;
3151 tmp = *s++;
3152 if (tmp == '|')
a0d0e21e 3153 AOPERATOR(OROR);
378cc40b 3154 s--;
79072805 3155 BOop(OP_BIT_OR);
378cc40b
LW
3156 case '=':
3157 s++;
3158 tmp = *s++;
3159 if (tmp == '=')
79072805
LW
3160 Eop(OP_EQ);
3161 if (tmp == '>')
3162 OPERATOR(',');
378cc40b 3163 if (tmp == '~')
79072805 3164 PMop(OP_MATCH);
599cee73 3165 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
cea2e8a9 3166 Perl_warner(aTHX_ WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
378cc40b 3167 s--;
3280af22
NIS
3168 if (PL_expect == XSTATE && isALPHA(tmp) &&
3169 (s == PL_linestart+1 || s[-2] == '\n') )
748a9306 3170 {
3280af22
NIS
3171 if (PL_in_eval && !PL_rsfp) {
3172 d = PL_bufend;
a5f75d66
AD
3173 while (s < d) {
3174 if (*s++ == '\n') {
3175 incline(s);
3176 if (strnEQ(s,"=cut",4)) {
3177 s = strchr(s,'\n');
3178 if (s)
3179 s++;
3180 else
3181 s = d;
3182 incline(s);
3183 goto retry;
3184 }
3185 }
3186 }
3187 goto retry;
3188 }
3280af22
NIS
3189 s = PL_bufend;
3190 PL_doextract = TRUE;
a0d0e21e
LW
3191 goto retry;
3192 }
3280af22 3193 if (PL_lex_brackets < PL_lex_formbrack) {
a0d0e21e 3194 char *t;
51882d45 3195#ifdef PERL_STRICT_CR
a0d0e21e 3196 for (t = s; *t == ' ' || *t == '\t'; t++) ;
51882d45
GS
3197#else
3198 for (t = s; *t == ' ' || *t == '\t' || *t == '\r'; t++) ;
3199#endif
a0d0e21e
LW
3200 if (*t == '\n' || *t == '#') {
3201 s--;
3280af22 3202 PL_expect = XBLOCK;
a0d0e21e
LW
3203 goto leftbracket;
3204 }
79072805 3205 }
a0d0e21e
LW
3206 yylval.ival = 0;
3207 OPERATOR(ASSIGNOP);
378cc40b
LW
3208 case '!':
3209 s++;
3210 tmp = *s++;
3211 if (tmp == '=')
79072805 3212 Eop(OP_NE);
378cc40b 3213 if (tmp == '~')
79072805 3214 PMop(OP_NOT);
378cc40b
LW
3215 s--;
3216 OPERATOR('!');
3217 case '<':
3280af22 3218 if (PL_expect != XOPERATOR) {
93a17b20 3219 if (s[1] != '<' && !strchr(s,'>'))
2f3197b3 3220 check_uni();
79072805
LW
3221 if (s[1] == '<')
3222 s = scan_heredoc(s);
3223 else
3224 s = scan_inputsymbol(s);
3225 TERM(sublex_start());
378cc40b
LW
3226 }
3227 s++;
3228 tmp = *s++;
3229 if (tmp == '<')
79072805 3230 SHop(OP_LEFT_SHIFT);
395c3793
LW
3231 if (tmp == '=') {
3232 tmp = *s++;
3233 if (tmp == '>')
79072805 3234 Eop(OP_NCMP);
395c3793 3235 s--;
79072805 3236 Rop(OP_LE);
395c3793 3237 }
378cc40b 3238 s--;
79072805 3239 Rop(OP_LT);
378cc40b
LW
3240 case '>':
3241 s++;
3242 tmp = *s++;
3243 if (tmp == '>')
79072805 3244 SHop(OP_RIGHT_SHIFT);
378cc40b 3245 if (tmp == '=')
79072805 3246 Rop(OP_GE);
378cc40b 3247 s--;
79072805 3248 Rop(OP_GT);
378cc40b
LW
3249
3250 case '$':
bbce6d69
PP
3251 CLINE;
3252
3280af22
NIS
3253 if (PL_expect == XOPERATOR) {
3254 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3255 PL_expect = XTERM;
a0d0e21e 3256 depcom();
bbce6d69 3257 return ','; /* grandfather non-comma-format format */
a0d0e21e 3258 }
8990e307 3259 }
a0d0e21e 3260
7e2040f0 3261 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
3280af22 3262 PL_tokenbuf[0] = '@';
376b8730
SM
3263 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3264 sizeof PL_tokenbuf - 1, FALSE);
3265 if (PL_expect == XOPERATOR)
3266 no_op("Array length", s);
3280af22 3267 if (!PL_tokenbuf[1])
a0d0e21e 3268 PREREF(DOLSHARP);
3280af22
NIS
3269 PL_expect = XOPERATOR;
3270 PL_pending_ident = '#';
463ee0b2 3271 TOKEN(DOLSHARP);
79072805 3272 }
bbce6d69 3273
3280af22 3274 PL_tokenbuf[0] = '$';
376b8730
SM
3275 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3276 sizeof PL_tokenbuf - 1, FALSE);
3277 if (PL_expect == XOPERATOR)
3278 no_op("Scalar", s);
3280af22
NIS
3279 if (!PL_tokenbuf[1]) {
3280 if (s == PL_bufend)
bbce6d69
PP
3281 yyerror("Final $ should be \\$ or $name");
3282 PREREF('$');
8990e307 3283 }
a0d0e21e 3284
bbce6d69 3285 /* This kludge not intended to be bulletproof. */
3280af22 3286 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
bbce6d69 3287 yylval.opval = newSVOP(OP_CONST, 0,
b448e4fe 3288 newSViv(PL_compiling.cop_arybase));
bbce6d69
PP
3289 yylval.opval->op_private = OPpCONST_ARYBASE;
3290 TERM(THING);
3291 }
3292
ff68c719 3293 d = s;
69d2bceb 3294 tmp = (I32)*s;
3280af22 3295 if (PL_lex_state == LEX_NORMAL)
ff68c719
PP
3296 s = skipspace(s);
3297
3280af22 3298 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
bbce6d69
PP
3299 char *t;
3300 if (*s == '[') {
3280af22 3301 PL_tokenbuf[0] = '@';
599cee73 3302 if (ckWARN(WARN_SYNTAX)) {
bbce6d69 3303 for(t = s + 1;
7e2040f0 3304 isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$';
bbce6d69 3305 t++) ;
a0d0e21e 3306 if (*t++ == ',') {
3280af22
NIS
3307 PL_bufptr = skipspace(PL_bufptr);
3308 while (t < PL_bufend && *t != ']')
bbce6d69 3309 t++;
cea2e8a9 3310 Perl_warner(aTHX_ WARN_SYNTAX,
599cee73
PM
3311 "Multidimensional syntax %.*s not supported",
3312 (t - PL_bufptr) + 1, PL_bufptr);
a0d0e21e
LW
3313 }
3314 }
bbce6d69
PP
3315 }
3316 else if (*s == '{') {
3280af22 3317 PL_tokenbuf[0] = '%';
599cee73 3318 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
bbce6d69
PP
3319 (t = strchr(s, '}')) && (t = strchr(t, '=')))
3320 {
3280af22 3321 char tmpbuf[sizeof PL_tokenbuf];
a0d0e21e
LW
3322 STRLEN len;
3323 for (t++; isSPACE(*t); t++) ;
7e2040f0 3324 if (isIDFIRST_lazy_if(t,UTF)) {
8903cb82 3325 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
59a6d928 3326 for (; isSPACE(*t); t++) ;
864dbfa3 3327 if (*t == ';' && get_cv(tmpbuf, FALSE))
cea2e8a9 3328 Perl_warner(aTHX_ WARN_SYNTAX,
599cee73 3329 "You need to quote \"%s\"", tmpbuf);
748a9306 3330 }
93a17b20
LW
3331 }
3332 }
2f3197b3 3333 }
bbce6d69 3334
3280af22 3335 PL_expect = XOPERATOR;
69d2bceb 3336 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3280af22
NIS
3337 bool islop = (PL_last_lop == PL_oldoldbufptr);
3338 if (!islop || PL_last_lop_op == OP_GREPSTART)
3339 PL_expect = XOPERATOR;
bbce6d69 3340 else if (strchr("$@\"'`q", *s))
3280af22 3341 PL_expect = XTERM; /* e.g. print $fh "foo" */
7e2040f0 3342 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
3280af22 3343 PL_expect = XTERM; /* e.g. print $fh &sub */
7e2040f0 3344 else if (isIDFIRST_lazy_if(s,UTF)) {
3280af22 3345 char tmpbuf[sizeof PL_tokenbuf];
8903cb82 3346 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
155aba94 3347 if ((tmp = keyword(tmpbuf, len))) {
84902520
TB
3348 /* binary operators exclude handle interpretations */
3349 switch (tmp) {
3350 case -KEY_x:
3351 case -KEY_eq:
3352 case -KEY_ne:
3353 case -KEY_gt:
3354 case -KEY_lt:
3355 case -KEY_ge:
3356 case -KEY_le:
3357 case -KEY_cmp:
3358 break;
3359 default:
3280af22 3360 PL_expect = XTERM; /* e.g. print $fh length() */
84902520
TB
3361 break;
3362 }
3363 }
68dc0745
PP
3364 else {
3365 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
3366 if (gv && GvCVu(gv))
3280af22 3367 PL_expect = XTERM; /* e.g. print $fh subr() */
93a17b20 3368 }
93a17b20 3369 }
bbce6d69 3370 else if (isDIGIT(*s))
3280af22 3371 PL_expect = XTERM; /* e.g. print $fh 3 */
bbce6d69 3372 else if (*s == '.' && isDIGIT(s[1]))
3280af22 3373 PL_expect = XTERM; /* e.g. print $fh .3 */
e0587a03 3374 else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
3280af22 3375 PL_expect = XTERM; /* e.g. print $fh -1 */
e0587a03 3376 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3280af22 3377 PL_expect = XTERM; /* print $fh <<"EOF" */
bbce6d69 3378 }
3280af22 3379 PL_pending_ident = '$';
79072805 3380 TOKEN('$');
378cc40b
LW
3381
3382 case '@':
3280af22 3383 if (PL_expect == XOPERATOR)
bbce6d69 3384 no_op("Array", s);
3280af22
NIS
3385 PL_tokenbuf[0] = '@';
3386 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3387 if (!PL_tokenbuf[1]) {
3388 if (s == PL_bufend)
bbce6d69
PP
3389 yyerror("Final @ should be \\@ or @name");
3390 PREREF('@');
3391 }
3280af22 3392 if (PL_lex_state == LEX_NORMAL)
ff68c719 3393 s = skipspace(s);
3280af22 3394 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
bbce6d69 3395 if (*s == '{')
3280af22 3396 PL_tokenbuf[0] = '%';
a0d0e21e
LW
3397
3398 /* Warn about @ where they meant $. */
599cee73 3399 if (ckWARN(WARN_SYNTAX)) {
a0d0e21e
LW
3400 if (*s == '[' || *s == '{') {
3401 char *t = s + 1;
7e2040f0 3402 while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
a0d0e21e
LW
3403 t++;
3404 if (*t == '}' || *t == ']') {
3405 t++;
3280af22 3406 PL_bufptr = skipspace(PL_bufptr);
cea2e8a9 3407 Perl_warner(aTHX_ WARN_SYNTAX,
599cee73 3408 "Scalar value %.*s better written as $%.*s",
3280af22 3409 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
a0d0e21e 3410 }
93a17b20
LW
3411 }
3412 }
463ee0b2 3413 }
3280af22 3414 PL_pending_ident = '@';
79072805 3415 TERM('@');
378cc40b
LW
3416
3417 case '/': /* may either be division or pattern */
3418 case '?': /* may either be conditional or pattern */
3280af22 3419 if (PL_expect != XOPERATOR) {
c277df42 3420 /* Disable warning on "study /blah/" */
3280af22
NIS
3421 if (PL_oldoldbufptr == PL_last_uni
3422 && (*PL_last_uni != 's' || s - PL_last_uni < 5
7e2040f0
GS
3423 || memNE(PL_last_uni, "study", 5)
3424 || isALNUM_lazy_if(PL_last_uni+5,UTF)))
c277df42 3425 check_uni();
8782bef2 3426 s = scan_pat(s,OP_MATCH);
79072805 3427 TERM(sublex_start());
378cc40b
LW
3428 }
3429 tmp = *s++;
a687059c 3430 if (tmp == '/')
79072805 3431 Mop(OP_DIVIDE);
378cc40b
LW
3432 OPERATOR(tmp);
3433
3434 case '.':
51882d45
GS
3435 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3436#ifdef PERL_STRICT_CR
3437 && s[1] == '\n'
3438#else
3439 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3440#endif
3441 && (s == PL_linestart || s[-1] == '\n') )
3442 {
3280af22
NIS
3443 PL_lex_formbrack = 0;
3444 PL_expect = XSTATE;
79072805
LW
3445 goto rightbracket;
3446 }
3280af22 3447 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
378cc40b 3448 tmp = *s++;
a687059c
LW
3449 if (*s == tmp) {
3450 s++;
2f3197b3
LW
3451 if (*s == tmp) {
3452 s++;
79072805 3453 yylval.ival = OPf_SPECIAL;
2f3197b3
LW
3454 }
3455 else
79072805 3456 yylval.ival = 0;
378cc40b 3457 OPERATOR(DOTDOT);
a687059c 3458 }
3280af22 3459 if (PL_expect != XOPERATOR)
2f3197b3 3460 check_uni();
79072805 3461 Aop(OP_CONCAT);
378cc40b
LW
3462 }
3463 /* FALL THROUGH */
3464 case '0': case '1': case '2': case '3': case '4':
3465 case '5': case '6': case '7': case '8': case '9':
79072805 3466 s = scan_num(s);
3280af22 3467 if (PL_expect == XOPERATOR)
8990e307 3468 no_op("Number",s);
79072805
LW
3469 TERM(THING);
3470
3471 case '\'':
09bef843 3472 s = scan_str(s,FALSE,FALSE);
3280af22
NIS
3473 if (PL_expect == XOPERATOR) {
3474 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3475 PL_expect = XTERM;
a0d0e21e
LW
3476 depcom();
3477 return ','; /* grandfather non-comma-format format */
3478 }
463ee0b2 3479 else
8990e307 3480 no_op("String",s);
463ee0b2 3481 }
79072805 3482 if (!s)
85e6fe83 3483 missingterm((char*)0);
79072805
LW
3484 yylval.ival = OP_CONST;
3485 TERM(sublex_start());
3486
3487 case '"':
09bef843 3488 s = scan_str(s,FALSE,FALSE);
3280af22
NIS
3489 if (PL_expect == XOPERATOR) {
3490 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3491 PL_expect = XTERM;
a0d0e21e
LW
3492 depcom();
3493 return ','; /* grandfather non-comma-format format */
3494 }
463ee0b2 3495 else
8990e307 3496 no_op("String",s);
463ee0b2 3497 }
79072805 3498 if (!s)
85e6fe83 3499 missingterm((char*)0);
4633a7c4 3500 yylval.ival = OP_CONST;
3280af22 3501 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
a0ed51b3 3502 if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
4633a7c4
LW
3503 yylval.ival = OP_STRINGIFY;
3504 break;
3505 }
3506 }
79072805
LW
3507 TERM(sublex_start());
3508
3509 case '`':
09bef843 3510 s = scan_str(s,FALSE,FALSE);
3280af22 3511 if (PL_expect == XOPERATOR)
8990e307 3512 no_op("Backticks",s);
79072805 3513 if (!s)
85e6fe83 3514 missingterm((char*)0);
79072805
LW
3515 yylval.ival = OP_BACKTICK;
3516 set_csh();
3517 TERM(sublex_start());
3518
3519 case '\\':
3520 s++;
599cee73 3521 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
cea2e8a9 3522 Perl_warner(aTHX_ WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
599cee73 3523 *s, *s);
3280af22 3524 if (PL_expect == XOPERATOR)
8990e307 3525 no_op("Backslash",s);
79072805
LW
3526 OPERATOR(REFGEN);
3527
a7cb1f99 3528 case 'v':
e526c9e6 3529 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
a7cb1f99
GS
3530 char *start = s;
3531 start++;
3532 start++;
dd629d5b 3533 while (isDIGIT(*start) || *start == '_')
a7cb1f99
GS
3534 start++;
3535 if (*start == '.' && isDIGIT(start[1])) {
3536 s = scan_num(s);
3537 TERM(THING);
3538 }
e526c9e6
GS
3539 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
3540 else if (!isALPHA(*start) && (PL_expect == XTERM || PL_expect == XREF)) {
3541 char c = *start;
3542 GV *gv;
3543 *start = '\0';
3544 gv = gv_fetchpv(s, FALSE, SVt_PVCV);
3545 *start = c;
3546 if (!gv) {
3547 s = scan_num(s);
3548 TERM(THING);
3549 }
3550 }
a7cb1f99
GS
3551 }
3552 goto keylookup;
79072805 3553 case 'x':
3280af22 3554 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
79072805
LW
3555 s++;
3556 Mop(OP_REPEAT);
2f3197b3 3557 }
79072805
LW
3558 goto keylookup;
3559
378cc40b 3560 case '_':
79072805
LW
3561 case 'a': case 'A':
3562 case 'b': case 'B':
3563 case 'c': case 'C':
3564 case 'd': case 'D':
3565 case 'e': case 'E':
3566 case 'f': case 'F':
3567 case 'g': case 'G':
3568 case 'h': case 'H':
3569 case 'i': case 'I':
3570 case 'j': case 'J':
3571 case 'k': case 'K':
3572 case 'l': case 'L':
3573 case 'm': case 'M':
3574 case 'n': case 'N':
3575 case 'o': case 'O':
3576 case 'p': case 'P':
3577 case 'q': case 'Q':
3578 case 'r': case 'R':
3579 case 's': case 'S':
3580 case 't': case 'T':
3581 case 'u': case 'U':
a7cb1f99 3582 case 'V':
79072805
LW
3583 case 'w': case 'W':
3584 case 'X':
3585 case 'y': case 'Y':
3586 case 'z': case 'Z':
3587
49dc05e3 3588 keylookup: {
161b471a
NIS
3589 gv = Nullgv;
3590 gvp = 0;
49dc05e3 3591
3280af22
NIS
3592 PL_bufptr = s;
3593 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
8ebc5c01
PP
3594
3595 /* Some keywords can be followed by any delimiter, including ':' */
155aba94
GS
3596 tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
3597 (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
3598 (PL_tokenbuf[0] == 'q' &&