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