This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
extend "Unrecognized escape" warning to \8, \9, and \_ as well
[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;
7e84c16c 1380 if (ckWARN(WARN_MISC) && isALNUM(*s))
e476b1b5 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 2658 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
df0deb90
GS
2659 if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
2660 /* handle eval qq[#line 1 "foo"\n ...] */
2661 CopLINE_dec(PL_curcop);
2662 incline(s);
2663 }
3280af22 2664 d = PL_bufend;
a687059c 2665 while (s < d && *s != '\n')
378cc40b 2666 s++;
0f85fab0 2667 if (s < d)
378cc40b 2668 s++;
463ee0b2 2669 incline(s);
3280af22
NIS
2670 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2671 PL_bufptr = s;
2672 PL_lex_state = LEX_FORMLINE;
cea2e8a9 2673 return yylex();
a687059c 2674 }
378cc40b 2675 }
a687059c 2676 else {
378cc40b 2677 *s = '\0';
3280af22 2678 PL_bufend = s;
a687059c 2679 }
378cc40b
LW
2680 goto retry;
2681 case '-':
79072805 2682 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
378cc40b 2683 s++;
3280af22 2684 PL_bufptr = s;
748a9306
LW
2685 tmp = *s++;
2686
3280af22 2687 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
748a9306
LW
2688 s++;
2689
2690 if (strnEQ(s,"=>",2)) {
3280af22 2691 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
748a9306
LW
2692 OPERATOR('-'); /* unary minus */
2693 }
3280af22
NIS
2694 PL_last_uni = PL_oldbufptr;
2695 PL_last_lop_op = OP_FTEREAD; /* good enough */
748a9306 2696 switch (tmp) {
79072805
LW
2697 case 'r': FTST(OP_FTEREAD);
2698 case 'w': FTST(OP_FTEWRITE);
2699 case 'x': FTST(OP_FTEEXEC);
2700 case 'o': FTST(OP_FTEOWNED);
2701 case 'R': FTST(OP_FTRREAD);
2702 case 'W': FTST(OP_FTRWRITE);
2703 case 'X': FTST(OP_FTREXEC);
2704 case 'O': FTST(OP_FTROWNED);
2705 case 'e': FTST(OP_FTIS);
2706 case 'z': FTST(OP_FTZERO);
2707 case 's': FTST(OP_FTSIZE);
2708 case 'f': FTST(OP_FTFILE);
2709 case 'd': FTST(OP_FTDIR);
2710 case 'l': FTST(OP_FTLINK);
2711 case 'p': FTST(OP_FTPIPE);
2712 case 'S': FTST(OP_FTSOCK);
2713 case 'u': FTST(OP_FTSUID);
2714 case 'g': FTST(OP_FTSGID);
2715 case 'k': FTST(OP_FTSVTX);
2716 case 'b': FTST(OP_FTBLK);
2717 case 'c': FTST(OP_FTCHR);
2718 case 't': FTST(OP_FTTTY);
2719 case 'T': FTST(OP_FTTEXT);
2720 case 'B': FTST(OP_FTBINARY);
85e6fe83
LW
2721 case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2722 case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2723 case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
378cc40b 2724 default:
cea2e8a9 2725 Perl_croak(aTHX_ "Unrecognized file test: -%c", (int)tmp);
378cc40b
LW
2726 break;
2727 }
2728 }
a687059c
LW
2729 tmp = *s++;
2730 if (*s == tmp) {
2731 s++;
3280af22 2732 if (PL_expect == XOPERATOR)
79072805
LW
2733 TERM(POSTDEC);
2734 else
2735 OPERATOR(PREDEC);
2736 }
2737 else if (*s == '>') {
2738 s++;
2739 s = skipspace(s);
7e2040f0 2740 if (isIDFIRST_lazy_if(s,UTF)) {
a0d0e21e 2741 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
463ee0b2 2742 TOKEN(ARROW);
79072805 2743 }
748a9306
LW
2744 else if (*s == '$')
2745 OPERATOR(ARROW);
463ee0b2 2746 else
748a9306 2747 TERM(ARROW);
a687059c 2748 }
3280af22 2749 if (PL_expect == XOPERATOR)
79072805
LW
2750 Aop(OP_SUBTRACT);
2751 else {
3280af22 2752 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2f3197b3 2753 check_uni();
79072805 2754 OPERATOR('-'); /* unary minus */
2f3197b3 2755 }
79072805 2756
378cc40b 2757 case '+':
a687059c
LW
2758 tmp = *s++;
2759 if (*s == tmp) {
378cc40b 2760 s++;
3280af22 2761 if (PL_expect == XOPERATOR)
79072805
LW
2762 TERM(POSTINC);
2763 else
2764 OPERATOR(PREINC);
378cc40b 2765 }
3280af22 2766 if (PL_expect == XOPERATOR)
79072805
LW
2767 Aop(OP_ADD);
2768 else {
3280af22 2769 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2f3197b3 2770 check_uni();
a687059c 2771 OPERATOR('+');
2f3197b3 2772 }
a687059c 2773
378cc40b 2774 case '*':
3280af22
NIS
2775 if (PL_expect != XOPERATOR) {
2776 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2777 PL_expect = XOPERATOR;
2778 force_ident(PL_tokenbuf, '*');
2779 if (!*PL_tokenbuf)
a0d0e21e 2780 PREREF('*');
79072805 2781 TERM('*');
a687059c 2782 }
79072805
LW
2783 s++;
2784 if (*s == '*') {
a687059c 2785 s++;
79072805 2786 PWop(OP_POW);
a687059c 2787 }
79072805
LW
2788 Mop(OP_MULTIPLY);
2789
378cc40b 2790 case '%':
3280af22 2791 if (PL_expect == XOPERATOR) {
bbce6d69
PP
2792 ++s;
2793 Mop(OP_MODULO);
a687059c 2794 }
3280af22
NIS
2795 PL_tokenbuf[0] = '%';
2796 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2797 if (!PL_tokenbuf[1]) {
2798 if (s == PL_bufend)
bbce6d69
PP
2799 yyerror("Final % should be \\% or %name");
2800 PREREF('%');
a687059c 2801 }
3280af22 2802 PL_pending_ident = '%';
bbce6d69 2803 TERM('%');
a687059c 2804
378cc40b 2805 case '^':
79072805 2806 s++;
a0d0e21e 2807 BOop(OP_BIT_XOR);
79072805 2808 case '[':
3280af22 2809 PL_lex_brackets++;
79072805 2810 /* FALL THROUGH */
378cc40b 2811 case '~':
378cc40b 2812 case ',':
378cc40b
LW
2813 tmp = *s++;
2814 OPERATOR(tmp);
a0d0e21e
LW
2815 case ':':
2816 if (s[1] == ':') {
2817 len = 0;
2818 goto just_a_word;
2819 }
2820 s++;
09bef843
SB
2821 switch (PL_expect) {
2822 OP *attrs;
2823 case XOPERATOR:
2824 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
2825 break;
2826 PL_bufptr = s; /* update in case we back off */
2827 goto grabattrs;
2828 case XATTRBLOCK:
2829 PL_expect = XBLOCK;
2830 goto grabattrs;
2831 case XATTRTERM:
2832 PL_expect = XTERMBLOCK;
2833 grabattrs:
2834 s = skipspace(s);
2835 attrs = Nullop;
7e2040f0 2836 while (isIDFIRST_lazy_if(s,UTF)) {
09bef843 2837 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
f9829d6b
GS
2838 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
2839 if (tmp < 0) tmp = -tmp;
2840 switch (tmp) {
2841 case KEY_or:
2842 case KEY_and:
2843 case KEY_for:
2844 case KEY_unless:
2845 case KEY_if:
2846 case KEY_while:
2847 case KEY_until:
2848 goto got_attrs;
2849 default:
2850 break;
2851 }
2852 }
09bef843
SB
2853 if (*d == '(') {
2854 d = scan_str(d,TRUE,TRUE);
2855 if (!d) {
2856 if (PL_lex_stuff) {
2857 SvREFCNT_dec(PL_lex_stuff);
2858 PL_lex_stuff = Nullsv;
2859 }
2860 /* MUST advance bufptr here to avoid bogus
2861 "at end of line" context messages from yyerror().
2862 */
2863 PL_bufptr = s + len;
2864 yyerror("Unterminated attribute parameter in attribute list");
2865 if (attrs)
2866 op_free(attrs);
2867 return 0; /* EOF indicator */
2868 }
2869 }
2870 if (PL_lex_stuff) {
2871 SV *sv = newSVpvn(s, len);
2872 sv_catsv(sv, PL_lex_stuff);
2873 attrs = append_elem(OP_LIST, attrs,
2874 newSVOP(OP_CONST, 0, sv));
2875 SvREFCNT_dec(PL_lex_stuff);
2876 PL_lex_stuff = Nullsv;
2877 }
2878 else {
2879 attrs = append_elem(OP_LIST, attrs,
2880 newSVOP(OP_CONST, 0,
2881 newSVpvn(s, len)));
2882 }
2883 s = skipspace(d);
0120eecf 2884 if (*s == ':' && s[1] != ':')
09bef843 2885 s = skipspace(s+1);
0120eecf
GS
2886 else if (s == d)
2887 break; /* require real whitespace or :'s */
09bef843 2888 }
f9829d6b
GS
2889 tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
2890 if (*s != ';' && *s != tmp && (tmp != '=' || *s != ')')) {
09bef843
SB
2891 char q = ((*s == '\'') ? '"' : '\'');
2892 /* If here for an expression, and parsed no attrs, back off. */
2893 if (tmp == '=' && !attrs) {
2894 s = PL_bufptr;
2895 break;
2896 }
2897 /* MUST advance bufptr here to avoid bogus "at end of line"
2898 context messages from yyerror().
2899 */
2900 PL_bufptr = s;
2901 if (!*s)
2902 yyerror("Unterminated attribute list");
2903 else
2904 yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list",
2905 q, *s, q));
2906 if (attrs)
2907 op_free(attrs);
2908 OPERATOR(':');
2909 }
f9829d6b 2910 got_attrs:
09bef843
SB
2911 if (attrs) {
2912 PL_nextval[PL_nexttoke].opval = attrs;
2913 force_next(THING);
2914 }
2915 TOKEN(COLONATTR);
2916 }
a0d0e21e 2917 OPERATOR(':');
8990e307
LW
2918 case '(':
2919 s++;
3280af22
NIS
2920 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
2921 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
a0d0e21e 2922 else
3280af22 2923 PL_expect = XTERM;
a0d0e21e 2924 TOKEN('(');
378cc40b 2925 case ';':
57843af0
GS
2926 if (CopLINE(PL_curcop) < PL_copline)
2927 PL_copline = CopLINE(PL_curcop);
378cc40b
LW
2928 tmp = *s++;
2929 OPERATOR(tmp);
2930 case ')':
378cc40b 2931 tmp = *s++;
16d20bd9
AD
2932 s = skipspace(s);
2933 if (*s == '{')
2934 PREBLOCK(tmp);
378cc40b 2935 TERM(tmp);
79072805
LW
2936 case ']':
2937 s++;
3280af22 2938 if (PL_lex_brackets <= 0)
d98d5fff 2939 yyerror("Unmatched right square bracket");
463ee0b2 2940 else
3280af22
NIS
2941 --PL_lex_brackets;
2942 if (PL_lex_state == LEX_INTERPNORMAL) {
2943 if (PL_lex_brackets == 0) {
a0d0e21e 2944 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
3280af22 2945 PL_lex_state = LEX_INTERPEND;
79072805
LW
2946 }
2947 }
4633a7c4 2948 TERM(']');
79072805
LW
2949 case '{':
2950 leftbracket:
79072805 2951 s++;
3280af22
NIS
2952 if (PL_lex_brackets > 100) {
2953 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
2954 if (newlb != PL_lex_brackstack) {
8990e307 2955 SAVEFREEPV(newlb);
3280af22 2956 PL_lex_brackstack = newlb;
8990e307
LW
2957 }
2958 }
3280af22 2959 switch (PL_expect) {
a0d0e21e 2960 case XTERM:
3280af22 2961 if (PL_lex_formbrack) {
a0d0e21e
LW
2962 s--;
2963 PRETERMBLOCK(DO);
2964 }
3280af22
NIS
2965 if (PL_oldoldbufptr == PL_last_lop)
2966 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
a0d0e21e 2967 else
3280af22 2968 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
79072805 2969 OPERATOR(HASHBRACK);
a0d0e21e 2970 case XOPERATOR:
3280af22 2971 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
748a9306 2972 s++;
44a8e56a 2973 d = s;
3280af22
NIS
2974 PL_tokenbuf[0] = '\0';
2975 if (d < PL_bufend && *d == '-') {
2976 PL_tokenbuf[0] = '-';
44a8e56a 2977 d++;
3280af22 2978 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
44a8e56a
PP
2979 d++;
2980 }
7e2040f0 2981 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
3280af22 2982 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
8903cb82 2983 FALSE, &len);
3280af22 2984 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
748a9306
LW
2985 d++;
2986 if (*d == '}') {
3280af22 2987 char minus = (PL_tokenbuf[0] == '-');
44a8e56a
PP
2988 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2989 if (minus)
2990 force_next('-');
748a9306
LW
2991 }
2992 }
2993 /* FALL THROUGH */
09bef843 2994 case XATTRBLOCK:
748a9306 2995 case XBLOCK:
3280af22
NIS
2996 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
2997 PL_expect = XSTATE;
a0d0e21e 2998 break;
09bef843 2999 case XATTRTERM:
a0d0e21e 3000 case XTERMBLOCK:
3280af22
NIS
3001 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3002 PL_expect = XSTATE;
a0d0e21e
LW
3003 break;
3004 default: {
3005 char *t;
3280af22
NIS
3006 if (PL_oldoldbufptr == PL_last_lop)
3007 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
a0d0e21e 3008 else
3280af22 3009 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
a0d0e21e 3010 s = skipspace(s);
09ecc4b6 3011 if (*s == '}')
a0d0e21e 3012 OPERATOR(HASHBRACK);
b8a4b1be
GS
3013 /* This hack serves to disambiguate a pair of curlies
3014 * as being a block or an anon hash. Normally, expectation
3015 * determines that, but in cases where we're not in a
3016 * position to expect anything in particular (like inside
3017 * eval"") we have to resolve the ambiguity. This code
3018 * covers the case where the first term in the curlies is a
3019 * quoted string. Most other cases need to be explicitly
3020 * disambiguated by prepending a `+' before the opening
3021 * curly in order to force resolution as an anon hash.
3022 *
3023 * XXX should probably propagate the outer expectation
3024 * into eval"" to rely less on this hack, but that could
3025 * potentially break current behavior of eval"".
3026 * GSAR 97-07-21
3027 */
3028 t = s;
3029 if (*s == '\'' || *s == '"' || *s == '`') {
3030 /* common case: get past first string, handling escapes */
3280af22 3031 for (t++; t < PL_bufend && *t != *s;)
b8a4b1be
GS
3032 if (*t++ == '\\' && (*t == '\\' || *t == *s))
3033 t++;
3034 t++;
a0d0e21e 3035 }
b8a4b1be 3036 else if (*s == 'q') {
3280af22 3037 if (++t < PL_bufend
b8a4b1be 3038 && (!isALNUM(*t)
3280af22 3039 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
0505442f
GS
3040 && !isALNUM(*t))))
3041 {
b8a4b1be
GS
3042 char *tmps;
3043 char open, close, term;
3044 I32 brackets = 1;
3045
3280af22 3046 while (t < PL_bufend && isSPACE(*t))
b8a4b1be
GS
3047 t++;
3048 term = *t;
3049 open = term;
3050 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
3051 term = tmps[5];
3052 close = term;
3053 if (open == close)
3280af22
NIS
3054 for (t++; t < PL_bufend; t++) {
3055 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
b8a4b1be 3056 t++;
6d07e5e9 3057 else if (*t == open)
b8a4b1be
GS
3058 break;
3059 }
3060 else
3280af22
NIS
3061 for (t++; t < PL_bufend; t++) {
3062 if (*t == '\\' && t+1 < PL_bufend)
b8a4b1be 3063 t++;
6d07e5e9 3064 else if (*t == close && --brackets <= 0)
b8a4b1be
GS
3065 break;
3066 else if (*t == open)
3067 brackets++;
3068 }
3069 }
3070 t++;
a0d0e21e 3071 }
7e2040f0 3072 else if (isALNUM_lazy_if(t,UTF)) {
0505442f 3073 t += UTF8SKIP(t);
7e2040f0 3074 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
0505442f 3075 t += UTF8SKIP(t);
a0d0e21e 3076 }
3280af22 3077 while (t < PL_bufend && isSPACE(*t))
a0d0e21e 3078 t++;
b8a4b1be
GS
3079 /* if comma follows first term, call it an anon hash */
3080 /* XXX it could be a comma expression with loop modifiers */
3280af22 3081 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
b8a4b1be 3082 || (*t == '=' && t[1] == '>')))
a0d0e21e 3083 OPERATOR(HASHBRACK);
3280af22 3084 if (PL_expect == XREF)
4e4e412b 3085 PL_expect = XTERM;
a0d0e21e 3086 else {
3280af22
NIS
3087 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
3088 PL_expect = XSTATE;
a0d0e21e 3089 }
8990e307 3090 }
a0d0e21e 3091 break;
463ee0b2 3092 }
57843af0 3093 yylval.ival = CopLINE(PL_curcop);
79072805 3094 if (isSPACE(*s) || *s == '#')
3280af22 3095 PL_copline = NOLINE; /* invalidate current command line number */
79072805 3096 TOKEN('{');
378cc40b 3097 case '}':
79072805
LW
3098 rightbracket:
3099 s++;
3280af22 3100 if (PL_lex_brackets <= 0)
d98d5fff 3101 yyerror("Unmatched right curly bracket");
463ee0b2 3102 else
3280af22
NIS
3103 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
3104 if (PL_lex_brackets < PL_lex_formbrack)
3105 PL_lex_formbrack = 0;
3106 if (PL_lex_state == LEX_INTERPNORMAL) {
3107 if (PL_lex_brackets == 0) {
9059aa12
LW
3108 if (PL_expect & XFAKEBRACK) {
3109 PL_expect &= XENUMMASK;
3280af22
NIS
3110 PL_lex_state = LEX_INTERPEND;
3111 PL_bufptr = s;
cea2e8a9 3112 return yylex(); /* ignore fake brackets */
79072805 3113 }
fa83b5b6 3114 if (*s == '-' && s[1] == '>')
3280af22 3115 PL_lex_state = LEX_INTERPENDMAYBE;
fa83b5b6 3116 else if (*s != '[' && *s != '{')
3280af22 3117 PL_lex_state = LEX_INTERPEND;
79072805
LW
3118 }
3119 }
9059aa12
LW
3120 if (PL_expect & XFAKEBRACK) {
3121 PL_expect &= XENUMMASK;
3280af22 3122 PL_bufptr = s;
cea2e8a9 3123 return yylex(); /* ignore fake brackets */
748a9306 3124 }
79072805
LW
3125 force_next('}');
3126 TOKEN(';');
378cc40b
LW
3127 case '&':
3128 s++;
3129 tmp = *s++;
3130 if (tmp == '&')
a0d0e21e 3131 AOPERATOR(ANDAND);
378cc40b 3132 s--;
3280af22 3133 if (PL_expect == XOPERATOR) {
7e2040f0
GS
3134 if (ckWARN(WARN_SEMICOLON)
3135 && isIDFIRST_lazy_if(s,UTF) && PL_bufptr == PL_linestart)
3136 {
57843af0 3137 CopLINE_dec(PL_curcop);
cea2e8a9 3138 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
57843af0 3139 CopLINE_inc(PL_curcop);
463ee0b2 3140 }
79072805 3141 BAop(OP_BIT_AND);
463ee0b2 3142 }
79072805 3143
3280af22
NIS
3144 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3145 if (*PL_tokenbuf) {
3146 PL_expect = XOPERATOR;
3147 force_ident(PL_tokenbuf, '&');
463ee0b2 3148 }
79072805
LW
3149 else
3150 PREREF('&');
c07a80fd 3151 yylval.ival = (OPpENTERSUB_AMPER<<8);
79072805
LW
3152 TERM('&');
3153
378cc40b
LW
3154 case '|':
3155 s++;
3156 tmp = *s++;
3157 if (tmp == '|')
a0d0e21e 3158 AOPERATOR(OROR);
378cc40b 3159 s--;
79072805 3160 BOop(OP_BIT_OR);
378cc40b
LW
3161 case '=':
3162 s++;
3163 tmp = *s++;
3164 if (tmp == '=')
79072805
LW
3165 Eop(OP_EQ);
3166 if (tmp == '>')
3167 OPERATOR(',');
378cc40b 3168 if (tmp == '~')
79072805 3169 PMop(OP_MATCH);
599cee73 3170 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
cea2e8a9 3171 Perl_warner(aTHX_ WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
378cc40b 3172 s--;
3280af22
NIS
3173 if (PL_expect == XSTATE && isALPHA(tmp) &&
3174 (s == PL_linestart+1 || s[-2] == '\n') )
748a9306 3175 {
3280af22
NIS
3176 if (PL_in_eval && !PL_rsfp) {
3177 d = PL_bufend;
a5f75d66
AD
3178 while (s < d) {
3179 if (*s++ == '\n') {
3180 incline(s);
3181 if (strnEQ(s,"=cut",4)) {
3182 s = strchr(s,'\n');
3183 if (s)
3184 s++;
3185 else
3186 s = d;
3187 incline(s);
3188 goto retry;
3189 }
3190 }
3191 }
3192 goto retry;
3193 }
3280af22
NIS
3194 s = PL_bufend;
3195 PL_doextract = TRUE;
a0d0e21e
LW
3196 goto retry;
3197 }
3280af22 3198 if (PL_lex_brackets < PL_lex_formbrack) {
a0d0e21e 3199 char *t;
51882d45 3200#ifdef PERL_STRICT_CR
a0d0e21e 3201 for (t = s; *t == ' ' || *t == '\t'; t++) ;
51882d45
GS
3202#else
3203 for (t = s; *t == ' ' || *t == '\t' || *t == '\r'; t++) ;
3204#endif
a0d0e21e
LW
3205 if (*t == '\n' || *t == '#') {
3206 s--;
3280af22 3207 PL_expect = XBLOCK;
a0d0e21e
LW
3208 goto leftbracket;
3209 }
79072805 3210 }
a0d0e21e
LW
3211 yylval.ival = 0;
3212 OPERATOR(ASSIGNOP);
378cc40b
LW
3213 case '!':
3214 s++;
3215 tmp = *s++;
3216 if (tmp == '=')
79072805 3217 Eop(OP_NE);
378cc40b 3218 if (tmp == '~')
79072805 3219 PMop(OP_NOT);
378cc40b
LW
3220 s--;
3221 OPERATOR('!');
3222 case '<':
3280af22 3223 if (PL_expect != XOPERATOR) {
93a17b20 3224 if (s[1] != '<' && !strchr(s,'>'))
2f3197b3 3225 check_uni();
79072805
LW
3226 if (s[1] == '<')
3227 s = scan_heredoc(s);
3228 else
3229 s = scan_inputsymbol(s);
3230 TERM(sublex_start());
378cc40b
LW
3231 }
3232 s++;
3233 tmp = *s++;
3234 if (tmp == '<')
79072805 3235 SHop(OP_LEFT_SHIFT);
395c3793
LW
3236 if (tmp == '=') {
3237 tmp = *s++;
3238 if (tmp == '>')
79072805 3239 Eop(OP_NCMP);
395c3793 3240 s--;
79072805 3241 Rop(OP_LE);
395c3793 3242 }
378cc40b 3243 s--;
79072805 3244 Rop(OP_LT);
378cc40b
LW
3245 case '>':
3246 s++;
3247 tmp = *s++;
3248 if (tmp == '>')
79072805 3249 SHop(OP_RIGHT_SHIFT);
378cc40b 3250 if (tmp == '=')
79072805 3251 Rop(OP_GE);
378cc40b 3252 s--;
79072805 3253 Rop(OP_GT);
378cc40b
LW
3254
3255 case '$':
bbce6d69
PP
3256 CLINE;
3257
3280af22
NIS
3258 if (PL_expect == XOPERATOR) {
3259 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3260 PL_expect = XTERM;
a0d0e21e 3261 depcom();
bbce6d69 3262 return ','; /* grandfather non-comma-format format */
a0d0e21e 3263 }
8990e307 3264 }
a0d0e21e 3265
7e2040f0 3266 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
3280af22 3267 PL_tokenbuf[0] = '@';
376b8730
SM
3268 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3269 sizeof PL_tokenbuf - 1, FALSE);
3270 if (PL_expect == XOPERATOR)
3271 no_op("Array length", s);
3280af22 3272 if (!PL_tokenbuf[1])
a0d0e21e 3273 PREREF(DOLSHARP);
3280af22
NIS
3274 PL_expect = XOPERATOR;
3275 PL_pending_ident = '#';
463ee0b2 3276 TOKEN(DOLSHARP);
79072805 3277 }
bbce6d69 3278
3280af22 3279 PL_tokenbuf[0] = '$';
376b8730
SM
3280 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3281 sizeof PL_tokenbuf - 1, FALSE);
3282 if (PL_expect == XOPERATOR)
3283 no_op("Scalar", s);
3280af22
NIS
3284 if (!PL_tokenbuf[1]) {
3285 if (s == PL_bufend)
bbce6d69
PP
3286 yyerror("Final $ should be \\$ or $name");
3287 PREREF('$');
8990e307 3288 }
a0d0e21e 3289
bbce6d69 3290 /* This kludge not intended to be bulletproof. */
3280af22 3291 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
bbce6d69 3292 yylval.opval = newSVOP(OP_CONST, 0,
b448e4fe 3293 newSViv(PL_compiling.cop_arybase));
bbce6d69
PP
3294 yylval.opval->op_private = OPpCONST_ARYBASE;
3295 TERM(THING);
3296 }
3297
ff68c719 3298 d = s;
69d2bceb 3299 tmp = (I32)*s;
3280af22 3300 if (PL_lex_state == LEX_NORMAL)
ff68c719
PP
3301 s = skipspace(s);
3302
3280af22 3303 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
bbce6d69
PP
3304 char *t;
3305 if (*s == '[') {
3280af22 3306 PL_tokenbuf[0] = '@';
599cee73 3307 if (ckWARN(WARN_SYNTAX)) {
bbce6d69 3308 for(t = s + 1;
7e2040f0 3309 isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$';
bbce6d69 3310 t++) ;
a0d0e21e 3311 if (*t++ == ',') {
3280af22
NIS
3312 PL_bufptr = skipspace(PL_bufptr);
3313 while (t < PL_bufend && *t != ']')
bbce6d69 3314 t++;
cea2e8a9 3315 Perl_warner(aTHX_ WARN_SYNTAX,
599cee73
PM
3316 "Multidimensional syntax %.*s not supported",
3317 (t - PL_bufptr) + 1, PL_bufptr);
a0d0e21e
LW
3318 }
3319 }
bbce6d69
PP
3320 }
3321 else if (*s == '{') {
3280af22 3322 PL_tokenbuf[0] = '%';
599cee73 3323 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
bbce6d69
PP
3324 (t = strchr(s, '}')) && (t = strchr(t, '=')))
3325 {
3280af22 3326 char tmpbuf[sizeof PL_tokenbuf];
a0d0e21e
LW
3327 STRLEN len;
3328 for (t++; isSPACE(*t); t++) ;
7e2040f0 3329 if (isIDFIRST_lazy_if(t,UTF)) {
8903cb82 3330 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
59a6d928 3331 for (; isSPACE(*t); t++) ;
864dbfa3 3332 if (*t == ';' && get_cv(tmpbuf, FALSE))
cea2e8a9 3333 Perl_warner(aTHX_ WARN_SYNTAX,
599cee73 3334 "You need to quote \"%s\"", tmpbuf);
748a9306 3335 }
93a17b20
LW
3336 }
3337 }
2f3197b3 3338 }
bbce6d69 3339
3280af22 3340 PL_expect = XOPERATOR;
69d2bceb 3341 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3280af22
NIS
3342 bool islop = (PL_last_lop == PL_oldoldbufptr);
3343 if (!islop || PL_last_lop_op == OP_GREPSTART)
3344 PL_expect = XOPERATOR;
bbce6d69 3345 else if (strchr("$@\"'`q", *s))
3280af22 3346 PL_expect = XTERM; /* e.g. print $fh "foo" */
7e2040f0 3347 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
3280af22 3348 PL_expect = XTERM; /* e.g. print $fh &sub */
7e2040f0 3349 else if (isIDFIRST_lazy_if(s,UTF)) {
3280af22 3350 char tmpbuf[sizeof PL_tokenbuf];
8903cb82 3351 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
155aba94 3352 if ((tmp = keyword(tmpbuf, len))) {
84902520
TB
3353 /* binary operators exclude handle interpretations */
3354 switch (tmp) {
3355 case -KEY_x:
3356 case -KEY_eq:
3357 case -KEY_ne:
3358 case -KEY_gt:
3359 case -KEY_lt:
3360 case -KEY_ge:
3361 case -KEY_le:
3362 case -KEY_cmp:
3363 break;
3364 default:
3280af22 3365 PL_expect = XTERM; /* e.g. print $fh length() */
84902520
TB
3366 break;
3367 }
3368 }
68dc0745
PP
3369 else {
3370 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
3371 if (gv && GvCVu(gv))
3280af22 3372 PL_expect = XTERM; /* e.g. print $fh subr() */
93a17b20 3373 }
93a17b20 3374 }
bbce6d69 3375 else if (isDIGIT(*s))
3280af22 3376 PL_expect = XTERM; /* e.g. print $fh 3 */
bbce6d69 3377 else if (*s == '.' && isDIGIT(s[1]))
3280af22 3378 PL_expect = XTERM; /* e.g. print $fh .3 */
e0587a03 3379 else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
3280af22 3380 PL_expect = XTERM; /* e.g. print $fh -1 */
e0587a03 3381 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3280af22 3382 PL_expect = XTERM; /* print $fh <<"EOF" */
bbce6d69 3383 }
3280af22 3384 PL_pending_ident = '$';
79072805 3385 TOKEN('$');
378cc40b
LW
3386
3387 case '@':
3280af22 3388 if (PL_expect == XOPERATOR)
bbce6d69 3389 no_op("Array", s);
3280af22
NIS
3390 PL_tokenbuf[0] = '@';
3391 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3392 if (!PL_tokenbuf[1]) {
3393 if (s == PL_bufend)
bbce6d69
PP
3394 yyerror("Final @ should be \\@ or @name");
3395 PREREF('@');
3396 }
3280af22 3397 if (PL_lex_state == LEX_NORMAL)
ff68c719 3398 s = skipspace(s);
3280af22 3399 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
bbce6d69 3400 if (*s == '{')
3280af22 3401 PL_tokenbuf[0] = '%';
a0d0e21e
LW
3402
3403 /* Warn about @ where they meant $. */
599cee73 3404 if (ckWARN(WARN_SYNTAX)) {
a0d0e21e
LW
3405 if (*s == '[' || *s == '{') {
3406 char *t = s + 1;
7e2040f0 3407 while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
a0d0e21e
LW
3408 t++;
3409 if (*t == '}' || *t == ']') {
3410 t++;
3280af22 3411 PL_bufptr = skipspace(PL_bufptr);
cea2e8a9 3412 Perl_warner(aTHX_ WARN_SYNTAX,
599cee73 3413 "Scalar value %.*s better written as $%.*s",
3280af22 3414 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
a0d0e21e 3415 }
93a17b20
LW
3416 }
3417 }
463ee0b2 3418 }
3280af22 3419 PL_pending_ident = '@';
79072805 3420 TERM('@');
378cc40b
LW
3421
3422 case '/': /* may either be division or pattern */
3423 case '?': /* may either be conditional or pattern */
3280af22 3424 if (PL_expect != XOPERATOR) {
c277df42 3425 /* Disable warning on "study /blah/" */
3280af22
NIS
3426 if (PL_oldoldbufptr == PL_last_uni
3427 && (*PL_last_uni != 's' || s - PL_last_uni < 5
7e2040f0
GS
3428 || memNE(PL_last_uni, "study", 5)
3429 || isALNUM_lazy_if(PL_last_uni+5,UTF)))
c277df42 3430 check_uni();
8782bef2 3431 s = scan_pat(s,OP_MATCH);
79072805 3432 TERM(sublex_start());
378cc40b
LW
3433 }
3434 tmp = *s++;
a687059c 3435 if (tmp == '/')
79072805 3436 Mop(OP_DIVIDE);
378cc40b
LW
3437 OPERATOR(tmp);
3438
3439 case '.':
51882d45
GS
3440 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3441#ifdef PERL_STRICT_CR
3442 && s[1] == '\n'
3443#else
3444 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3445#endif
3446 && (s == PL_linestart || s[-1] == '\n') )
3447 {
3280af22
NIS
3448 PL_lex_formbrack = 0;
3449 PL_expect = XSTATE;
79072805
LW
3450 goto rightbracket;
3451 }
3280af22 3452 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
378cc40b 3453 tmp = *s++;
a687059c
LW
3454 if (*s == tmp) {
3455 s++;
2f3197b3
LW
3456 if (*s == tmp) {
3457 s++;
79072805 3458 yylval.ival = OPf_SPECIAL;
2f3197b3
LW
3459 }
3460 else
79072805 3461 yylval.ival = 0;
378cc40b 3462 OPERATOR(DOTDOT);
a687059c 3463 }
3280af22 3464 if (PL_expect != XOPERATOR)
2f3197b3 3465 check_uni();
79072805 3466 Aop(OP_CONCAT);
378cc40b
LW
3467 }
3468 /* FALL THROUGH */
3469 case '0': case '1': case '2': case '3': case '4':
3470 case '5': case '6': case '7': case '8': case '9':
79072805 3471 s = scan_num(s);
3280af22 3472 if (PL_expect == XOPERATOR)
8990e307 3473 no_op("Number",s);
79072805
LW
3474 TERM(THING);
3475
3476 case '\'':
09bef843 3477 s = scan_str(s,FALSE,FALSE);
3280af22
NIS
3478 if (PL_expect == XOPERATOR) {
3479 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3480 PL_expect = XTERM;
a0d0e21e
LW
3481 depcom();
3482 return ','; /* grandfather non-comma-format format */
3483 }
463ee0b2 3484 else
8990e307 3485 no_op("String",s);
463ee0b2 3486 }
79072805 3487 if (!s)
85e6fe83 3488 missingterm((char*)0);
79072805
LW
3489 yylval.ival = OP_CONST;
3490 TERM(sublex_start());
3491
3492 case '"':
09bef843 3493 s = scan_str(s,FALSE,FALSE);
3280af22
NIS
3494 if (PL_expect == XOPERATOR) {
3495 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3496 PL_expect = XTERM;
a0d0e21e
LW
3497 depcom();
3498 return ','; /* grandfather non-comma-format format */
3499 }
463ee0b2 3500 else
8990e307 3501 no_op("String",s);
463ee0b2 3502 }
79072805 3503 if (!s)
85e6fe83 3504 missingterm((char*)0);
4633a7c4 3505 yylval.ival = OP_CONST;
3280af22 3506 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
a0ed51b3 3507 if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
4633a7c4
LW
3508 yylval.ival = OP_STRINGIFY;
3509 break;
3510 }
3511 }
79072805
LW
3512 TERM(sublex_start());
3513
3514 case '`':
09bef843 3515 s = scan_str(s,FALSE,FALSE);
3280af22 3516 if (PL_expect == XOPERATOR)
8990e307 3517 no_op("Backticks",s);
79072805 3518 if (!s)
85e6fe83 3519 missingterm((char*)0);
79072805
LW
3520 yylval.ival = OP_BACKTICK;
3521 set_csh();
3522 TERM(sublex_start());
3523
3524 case '\\':
3525 s++;
599cee73 3526 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
cea2e8a9 3527 Perl_warner(aTHX_ WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
599cee73 3528 *s, *s);
3280af22 3529 if (PL_expect == XOPERATOR)
8990e307 3530 no_op("Backslash",s);
79072805
LW
3531 OPERATOR(REFGEN);
3532
a7cb1f99 3533 case 'v':
e526c9e6 3534 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
a7cb1f99
GS
3535 char *start = s;
3536 start++;
3537 start++;
dd629d5b 3538 while (isDIGIT(*start) || *start == '_')
a7cb1f99
GS
3539 start++;
3540 if (*start == '.' && isDIGIT(start[1])) {
3541 s = scan_num(s);
3542 TERM(THING);
3543 }
e526c9e6
GS
3544 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
3545 else if (!isALPHA(*start) && (PL_expect == XTERM || PL_expect == XREF)) {
3546 char c = *start;
3547 GV *gv;
3548 *start = '\0';
3549 gv = gv_fetchpv(s, FALSE, SVt_PVCV);
3550 *start = c;
3551 if (!gv) {
3552 s = scan_num(s);
3553 TERM(THING);
3554 }
3555 }
a7cb1f99
GS
3556 }
3557 goto keylookup;
79072805 3558 case 'x':
3280af22 3559 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
79072805
LW
3560 s++;
3561 Mop(OP_REPEAT);
2f3197b3 3562 }
79072805
LW
3563 goto keylookup;
3564
378cc40b 3565 case '_':
79072805
LW
3566 case 'a': case 'A':
3567 case 'b': case 'B':
3568 case 'c': case 'C':
3569 case 'd': case 'D':
3570 case 'e': case 'E':
3571 case 'f': case 'F':
3572 case 'g': case 'G':
3573 case 'h': case 'H':
3574 case 'i': case 'I':
3575 case 'j': case 'J':
3576 case 'k': case 'K':
3577 case 'l': case 'L':
3578 case 'm': case 'M':
3579 case 'n': case 'N':
3580 case 'o': case 'O':
3581 case 'p': case 'P':
3582 case 'q': case 'Q':
3583 case 'r': case 'R':
3584 case 's': case 'S':
3585 case 't': case 'T':
3586 case 'u': case 'U':
a7cb1f99 3587 case 'V':
79072805
LW
3588 case 'w': case 'W':
3589 case 'X':
3590 case 'y': case 'Y':
3591 case 'z': case 'Z':
3592
49dc05e3 3593 keylookup: {
161b471a
NIS
3594 gv = Nullgv;
3595 gvp = 0;
49dc05e3 3596
3280af22
NIS
3597 PL_bufptr = s;
3598