This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Integrate with Sarathy.
[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
a0ed51b3 322STATIC I32
cea2e8a9 323S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
a0ed51b3
LW
324{
325 I32 count = FILTER_READ(idx+1, sv, maxlen);
326 if (count) {
dfe13c55
GS
327 U8* tmps;
328 U8* tend;
329 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
a0ed51b3 330 tend = utf16_to_utf8((U16*)SvPVX(sv), tmps, SvCUR(sv));
dfe13c55 331 sv_usepvn(sv, (char*)tmps, tend - tmps);
a0ed51b3
LW
332
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 }
349 return count;
350}
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)) {
1571675a
GS
864 SvUPGRADE(ver, SVt_PVNV);
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++;
8c8ad484
GS
1272 } else if (s[2] == '{' /* This should match regcomp.c */
1273 || (s[2] == 'p' || s[2] == '?') && s[3] == '{') {
cc6b7395 1274 I32 count = 1;
0f5d15d6 1275 char *regparse = s + (s[2] == '{' ? 3 : 4);
cc6b7395
IZ
1276 char c;
1277
d9f97599
GS
1278 while (count && (c = *regparse)) {
1279 if (c == '\\' && regparse[1])
1280 regparse++;
cc6b7395
IZ
1281 else if (c == '{')
1282 count++;
1283 else if (c == '}')
1284 count--;
d9f97599 1285 regparse++;
cc6b7395 1286 }
5bdf89e7
IZ
1287 if (*regparse != ')') {
1288 regparse--; /* Leave one char for continuation. */
cc6b7395 1289 yyerror("Sequence (?{...}) not terminated or not {}-balanced");
5bdf89e7 1290 }
0f5d15d6 1291 while (s < regparse)
cc6b7395
IZ
1292 *d++ = *s++;
1293 }
748a9306 1294 }
02aa26ce
NT
1295
1296 /* likewise skip #-initiated comments in //x patterns */
3280af22
NIS
1297 else if (*s == '#' && PL_lex_inpat &&
1298 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
748a9306
LW
1299 while (s+1 < send && *s != '\n')
1300 *d++ = *s++;
1301 }
02aa26ce
NT
1302
1303 /* check for embedded arrays (@foo, @:foo, @'foo, @{foo}, @$foo) */
7e2040f0
GS
1304 else if (*s == '@' && s[1]
1305 && (isALNUM_lazy_if(s+1,UTF) || strchr(":'{$", s[1])))
79072805 1306 break;
02aa26ce
NT
1307
1308 /* check for embedded scalars. only stop if we're sure it's a
1309 variable.
1310 */
79072805 1311 else if (*s == '$') {
3280af22 1312 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
79072805 1313 break;
c277df42 1314 if (s + 1 < send && !strchr("()| \n\t", s[1]))
79072805
LW
1315 break; /* in regexp, $ might be tail anchor */
1316 }
02aa26ce 1317
a0ed51b3
LW
1318 /* (now in tr/// code again) */
1319
d008e5eb 1320 if (*s & 0x80 && thisutf) {
012bcf8d
GS
1321 (void)utf8_to_uv((U8*)s, &len);
1322 if (len == 1) {
1323 /* illegal UTF8, make it valid */
012bcf8d 1324 char *old_pvx = SvPVX(sv);
bee7c419
GS
1325 /* need space for one extra char (NOTE: SvCUR() not set here) */
1326 d = SvGROW(sv, SvLEN(sv) + 1) + (d - old_pvx);
012bcf8d
GS
1327 d = (char*)uv_to_utf8((U8*)d, (U8)*s++);
1328 }
1329 else {
1330 while (len--)
1331 *d++ = *s++;
1332 }
1333 has_utf = TRUE;
1334 continue;
a0ed51b3
LW
1335 }
1336
02aa26ce 1337 /* backslashes */
79072805
LW
1338 if (*s == '\\' && s+1 < send) {
1339 s++;
02aa26ce
NT
1340
1341 /* some backslashes we leave behind */
c9f97d15 1342 if (*leaveit && *s && strchr(leaveit, *s)) {
79072805
LW
1343 *d++ = '\\';
1344 *d++ = *s++;
1345 continue;
1346 }
02aa26ce
NT
1347
1348 /* deprecate \1 in strings and substitution replacements */
3280af22 1349 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
a0d0e21e 1350 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
79072805 1351 {
d008e5eb 1352 dTHR; /* only for ckWARN */
599cee73 1353 if (ckWARN(WARN_SYNTAX))
cea2e8a9 1354 Perl_warner(aTHX_ WARN_SYNTAX, "\\%c better written as $%c", *s, *s);
79072805
LW
1355 *--s = '$';
1356 break;
1357 }
02aa26ce
NT
1358
1359 /* string-change backslash escapes */
3280af22 1360 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
79072805
LW
1361 --s;
1362 break;
1363 }
02aa26ce
NT
1364
1365 /* if we get here, it's either a quoted -, or a digit */
79072805 1366 switch (*s) {
02aa26ce
NT
1367
1368 /* quoted - in transliterations */
79072805 1369 case '-':
3280af22 1370 if (PL_lex_inwhat == OP_TRANS) {
79072805
LW
1371 *d++ = *s++;
1372 continue;
1373 }
1374 /* FALL THROUGH */
1375 default:
11b8faa4
JH
1376 {
1377 dTHR;
e476b1b5
GS
1378 if (ckWARN(WARN_MISC) && isALPHA(*s))
1379 Perl_warner(aTHX_ WARN_MISC,
11b8faa4
JH
1380 "Unrecognized escape \\%c passed through",
1381 *s);
1382 /* default action is to copy the quoted character */
1383 *d++ = *s++;
1384 continue;
1385 }
02aa26ce
NT
1386
1387 /* \132 indicates an octal constant */
79072805
LW
1388 case '0': case '1': case '2': case '3':
1389 case '4': case '5': case '6': case '7':
012bcf8d 1390 uv = (UV)scan_oct(s, 3, &len);
79072805 1391 s += len;
012bcf8d 1392 goto NUM_ESCAPE_INSERT;
02aa26ce
NT
1393
1394 /* \x24 indicates a hex constant */
79072805 1395 case 'x':
a0ed51b3
LW
1396 ++s;
1397 if (*s == '{') {
1398 char* e = strchr(s, '}');
adaeee49 1399 if (!e) {
a0ed51b3 1400 yyerror("Missing right brace on \\x{}");
adaeee49
GA
1401 e = s;
1402 }
012bcf8d
GS
1403 uv = (UV)scan_hex(s + 1, e - s - 1, &len);
1404 s = e + 1;
a0ed51b3
LW
1405 }
1406 else {
012bcf8d
GS
1407 uv = (UV)scan_hex(s, 2, &len);
1408 s += len;
1409 }
1410
1411 NUM_ESCAPE_INSERT:
1412 /* Insert oct or hex escaped character.
1413 * There will always enough room in sv since such escapes will
1414 * be longer than any utf8 sequence they can end up as
1415 */
1416 if (uv > 127) {
1417 if (!thisutf && !has_utf && uv > 255) {
1418 /* might need to recode whatever we have accumulated so far
1419 * if it contains any hibit chars
1420 */
1421 int hicount = 0;
1422 char *c;
1423 for (c = SvPVX(sv); c < d; c++) {
1424 if (*c & 0x80)
1425 hicount++;
1426 }
1427 if (hicount) {
1428 char *old_pvx = SvPVX(sv);
1429 char *src, *dst;
1430 d = SvGROW(sv, SvCUR(sv) + hicount + 1) + (d - old_pvx);
1431
1432 src = d - 1;
1433 d += hicount;
1434 dst = d - 1;
1435
1436 while (src < dst) {
1437 if (*src & 0x80) {
1438 dst--;
1439 uv_to_utf8((U8*)dst, (U8)*src--);
1440 dst--;
1441 }
1442 else {
1443 *dst-- = *src--;
1444 }
1445 }
1446 }
1447 }
1448
1449 if (thisutf || uv > 255) {
1450 d = (char*)uv_to_utf8((U8*)d, uv);
7e2040f0 1451 has_utf = TRUE;
012bcf8d 1452 }
a0ed51b3 1453 else {
012bcf8d 1454 *d++ = (char)uv;
a0ed51b3 1455 }
012bcf8d
GS
1456 }
1457 else {
1458 *d++ = (char)uv;
a0ed51b3 1459 }
79072805 1460 continue;
02aa26ce 1461
4a2d328f
IZ
1462 /* \N{latin small letter a} is a named character */
1463 case 'N':
423cee85
JH
1464 ++s;
1465 if (*s == '{') {
1466 char* e = strchr(s, '}');
1467 HV *hv;
1468 SV **svp;
1469 SV *res, *cv;
1470 STRLEN len;
1471 char *str;
1472 char *why = Nullch;
1473
1474 if (!e) {
5777a3f7 1475 yyerror("Missing right brace on \\N{}");
423cee85
JH
1476 e = s - 1;
1477 goto cont_scan;
1478 }
1479 res = newSVpvn(s + 1, e - s - 1);
1480 res = new_constant( Nullch, 0, "charnames",
5777a3f7 1481 res, Nullsv, "\\N{...}" );
423cee85
JH
1482 str = SvPV(res,len);
1483 if (len > e - s + 4) {
1484 char *odest = SvPVX(sv);
1485
1486 SvGROW(sv, (SvCUR(sv) + len - (e - s + 4)));
1487 d = SvPVX(sv) + (d - odest);
1488 }
1489 Copy(str, d, len, char);
1490 d += len;
1491 SvREFCNT_dec(res);
1492 cont_scan:
1493 s = e + 1;
1494 }
1495 else
5777a3f7 1496 yyerror("Missing braces on \\N{}");
423cee85
JH
1497 continue;
1498
02aa26ce 1499 /* \c is a control character */
79072805
LW
1500 case 'c':
1501 s++;
9d116dd7
JH
1502#ifdef EBCDIC
1503 *d = *s++;
1504 if (isLOWER(*d))
1505 *d = toUPPER(*d);
1506 *d++ = toCTRL(*d);
1507#else
bbce6d69
PP
1508 len = *s++;
1509 *d++ = toCTRL(len);
9d116dd7 1510#endif
79072805 1511 continue;
02aa26ce
NT
1512
1513 /* printf-style backslashes, formfeeds, newlines, etc */
79072805
LW
1514 case 'b':
1515 *d++ = '\b';
1516 break;
1517 case 'n':
1518 *d++ = '\n';
1519 break;
1520 case 'r':
1521 *d++ = '\r';
1522 break;
1523 case 'f':
1524 *d++ = '\f';
1525 break;
1526 case 't':
1527 *d++ = '\t';
1528 break;
34a3fe2a
PP
1529#ifdef EBCDIC
1530 case 'e':
1531 *d++ = '\047'; /* CP 1047 */
1532 break;
1533 case 'a':
1534 *d++ = '\057'; /* CP 1047 */
1535 break;
1536#else
79072805
LW
1537 case 'e':
1538 *d++ = '\033';
1539 break;
1540 case 'a':
1541 *d++ = '\007';
1542 break;
34a3fe2a 1543#endif
02aa26ce
NT
1544 } /* end switch */
1545
79072805
LW
1546 s++;
1547 continue;
02aa26ce
NT
1548 } /* end if (backslash) */
1549
79072805 1550 *d++ = *s++;
02aa26ce
NT
1551 } /* while loop to process each character */
1552
1553 /* terminate the string and set up the sv */
79072805 1554 *d = '\0';
463ee0b2 1555 SvCUR_set(sv, d - SvPVX(sv));
79072805 1556 SvPOK_on(sv);
7e2040f0
GS
1557 if (has_utf)
1558 SvUTF8_on(sv);
79072805 1559
02aa26ce 1560 /* shrink the sv if we allocated more than we used */
79072805
LW
1561 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1562 SvLEN_set(sv, SvCUR(sv) + 1);
463ee0b2 1563 Renew(SvPVX(sv), SvLEN(sv), char);
79072805 1564 }
02aa26ce 1565
9b599b2a 1566 /* return the substring (via yylval) only if we parsed anything */
3280af22
NIS
1567 if (s > PL_bufptr) {
1568 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1569 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
b3ac6de7 1570 sv, Nullsv,
3280af22 1571 ( PL_lex_inwhat == OP_TRANS
b3ac6de7 1572 ? "tr"
3280af22 1573 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
b3ac6de7
IZ
1574 ? "s"
1575 : "qq")));
79072805 1576 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
b3ac6de7 1577 } else
8990e307 1578 SvREFCNT_dec(sv);
79072805
LW
1579 return s;
1580}
1581
ffb4593c
NT
1582/* S_intuit_more
1583 * Returns TRUE if there's more to the expression (e.g., a subscript),
1584 * FALSE otherwise.
ffb4593c
NT
1585 *
1586 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
1587 *
1588 * ->[ and ->{ return TRUE
1589 * { and [ outside a pattern are always subscripts, so return TRUE
1590 * if we're outside a pattern and it's not { or [, then return FALSE
1591 * if we're in a pattern and the first char is a {
1592 * {4,5} (any digits around the comma) returns FALSE
1593 * if we're in a pattern and the first char is a [
1594 * [] returns FALSE
1595 * [SOMETHING] has a funky algorithm to decide whether it's a
1596 * character class or not. It has to deal with things like
1597 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
1598 * anything else returns TRUE
1599 */
1600
9cbb5ea2
GS
1601/* This is the one truly awful dwimmer necessary to conflate C and sed. */
1602
76e3520e 1603STATIC int
cea2e8a9 1604S_intuit_more(pTHX_ register char *s)
79072805 1605{
3280af22 1606 if (PL_lex_brackets)
79072805
LW
1607 return TRUE;
1608 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1609 return TRUE;
1610 if (*s != '{' && *s != '[')
1611 return FALSE;
3280af22 1612 if (!PL_lex_inpat)
79072805
LW
1613 return TRUE;
1614
1615 /* In a pattern, so maybe we have {n,m}. */
1616 if (*s == '{') {
1617 s++;
1618 if (!isDIGIT(*s))
1619 return TRUE;
1620 while (isDIGIT(*s))
1621 s++;
1622 if (*s == ',')
1623 s++;
1624 while (isDIGIT(*s))
1625 s++;
1626 if (*s == '}')
1627 return FALSE;
1628 return TRUE;
1629
1630 }
1631
1632 /* On the other hand, maybe we have a character class */
1633
1634 s++;
1635 if (*s == ']' || *s == '^')
1636 return FALSE;
1637 else {
ffb4593c 1638 /* this is terrifying, and it works */
79072805
LW
1639 int weight = 2; /* let's weigh the evidence */
1640 char seen[256];
f27ffc4a 1641 unsigned char un_char = 255, last_un_char;
93a17b20 1642 char *send = strchr(s,']');
3280af22 1643 char tmpbuf[sizeof PL_tokenbuf * 4];
79072805
LW
1644
1645 if (!send) /* has to be an expression */
1646 return TRUE;
1647
1648 Zero(seen,256,char);
1649 if (*s == '$')
1650 weight -= 3;
1651 else if (isDIGIT(*s)) {
1652 if (s[1] != ']') {
1653 if (isDIGIT(s[1]) && s[2] == ']')
1654 weight -= 10;
1655 }
1656 else
1657 weight -= 100;
1658 }
1659 for (; s < send; s++) {
1660 last_un_char = un_char;
1661 un_char = (unsigned char)*s;
1662 switch (*s) {
1663 case '@':
1664 case '&':
1665 case '$':
1666 weight -= seen[un_char] * 10;
7e2040f0 1667 if (isALNUM_lazy_if(s+1,UTF)) {
8903cb82 1668 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
a0d0e21e 1669 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
79072805
LW
1670 weight -= 100;
1671 else
1672 weight -= 10;
1673 }
1674 else if (*s == '$' && s[1] &&
93a17b20
LW
1675 strchr("[#!%*<>()-=",s[1])) {
1676 if (/*{*/ strchr("])} =",s[2]))
79072805
LW
1677 weight -= 10;
1678 else
1679 weight -= 1;
1680 }
1681 break;
1682 case '\\':
1683 un_char = 254;
1684 if (s[1]) {
93a17b20 1685 if (strchr("wds]",s[1]))
79072805
LW
1686 weight += 100;
1687 else if (seen['\''] || seen['"'])
1688 weight += 1;
93a17b20 1689 else if (strchr("rnftbxcav",s[1]))
79072805
LW
1690 weight += 40;
1691 else if (isDIGIT(s[1])) {
1692 weight += 40;
1693 while (s[1] && isDIGIT(s[1]))
1694 s++;
1695 }
1696 }
1697 else
1698 weight += 100;
1699 break;
1700 case '-':
1701 if (s[1] == '\\')
1702 weight += 50;
93a17b20 1703 if (strchr("aA01! ",last_un_char))
79072805 1704 weight += 30;
93a17b20 1705 if (strchr("zZ79~",s[1]))
79072805 1706 weight += 30;
f27ffc4a
GS
1707 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1708 weight -= 5; /* cope with negative subscript */
79072805
LW
1709 break;
1710 default:
93a17b20 1711 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
79072805
LW
1712 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1713 char *d = tmpbuf;
1714 while (isALPHA(*s))
1715 *d++ = *s++;
1716 *d = '\0';
1717 if (keyword(tmpbuf, d - tmpbuf))
1718 weight -= 150;
1719 }
1720 if (un_char == last_un_char + 1)
1721 weight += 5;
1722 weight -= seen[un_char];
1723 break;
1724 }
1725 seen[un_char]++;
1726 }
1727 if (weight >= 0) /* probably a character class */
1728 return FALSE;
1729 }
1730
1731 return TRUE;
1732}
ffed7fef 1733
ffb4593c
NT
1734/*
1735 * S_intuit_method
1736 *
1737 * Does all the checking to disambiguate
1738 * foo bar
1739 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
1740 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
1741 *
1742 * First argument is the stuff after the first token, e.g. "bar".
1743 *
1744 * Not a method if bar is a filehandle.
1745 * Not a method if foo is a subroutine prototyped to take a filehandle.
1746 * Not a method if it's really "Foo $bar"
1747 * Method if it's "foo $bar"
1748 * Not a method if it's really "print foo $bar"
1749 * Method if it's really "foo package::" (interpreted as package->foo)
1750 * Not a method if bar is known to be a subroutne ("sub bar; foo bar")
3cb0bbe5 1751 * Not a method if bar is a filehandle or package, but is quoted with
ffb4593c
NT
1752 * =>
1753 */
1754
76e3520e 1755STATIC int
cea2e8a9 1756S_intuit_method(pTHX_ char *start, GV *gv)
a0d0e21e
LW
1757{
1758 char *s = start + (*start == '$');
3280af22 1759 char tmpbuf[sizeof PL_tokenbuf];
a0d0e21e
LW
1760 STRLEN len;
1761 GV* indirgv;
1762
1763 if (gv) {
b6c543e3 1764 CV *cv;
a0d0e21e
LW
1765 if (GvIO(gv))
1766 return 0;
b6c543e3
IZ
1767 if ((cv = GvCVu(gv))) {
1768 char *proto = SvPVX(cv);
1769 if (proto) {
1770 if (*proto == ';')
1771 proto++;
1772 if (*proto == '*')
1773 return 0;
1774 }
1775 } else
a0d0e21e
LW
1776 gv = 0;
1777 }
8903cb82 1778 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
ffb4593c
NT
1779 /* start is the beginning of the possible filehandle/object,
1780 * and s is the end of it
1781 * tmpbuf is a copy of it
1782 */
1783
a0d0e21e 1784 if (*start == '$') {
3280af22 1785 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
a0d0e21e
LW
1786 return 0;
1787 s = skipspace(s);
3280af22
NIS
1788 PL_bufptr = start;
1789 PL_expect = XREF;
a0d0e21e
LW
1790 return *s == '(' ? FUNCMETH : METHOD;
1791 }
1792 if (!keyword(tmpbuf, len)) {
c3e0f903
GS
1793 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1794 len -= 2;
1795 tmpbuf[len] = '\0';
1796 goto bare_package;
1797 }
1798 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
8ebc5c01 1799 if (indirgv && GvCVu(indirgv))
a0d0e21e
LW
1800 return 0;
1801 /* filehandle or package name makes it a method */
89bfa8cd 1802 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
a0d0e21e 1803 s = skipspace(s);
3280af22 1804 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
55497cff 1805 return 0; /* no assumptions -- "=>" quotes bearword */
c3e0f903 1806 bare_package:
3280af22 1807 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
79cb57f6 1808 newSVpvn(tmpbuf,len));
3280af22
NIS
1809 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1810 PL_expect = XTERM;
a0d0e21e 1811 force_next(WORD);
3280af22 1812 PL_bufptr = s;
a0d0e21e
LW
1813 return *s == '(' ? FUNCMETH : METHOD;
1814 }
1815 }
1816 return 0;
1817}
1818
ffb4593c
NT
1819/*
1820 * S_incl_perldb
1821 * Return a string of Perl code to load the debugger. If PERL5DB
1822 * is set, it will return the contents of that, otherwise a
1823 * compile-time require of perl5db.pl.
1824 */
1825
76e3520e 1826STATIC char*
cea2e8a9 1827S_incl_perldb(pTHX)
a0d0e21e 1828{
3280af22 1829 if (PL_perldb) {
76e3520e 1830 char *pdb = PerlEnv_getenv("PERL5DB");
a0d0e21e
LW
1831
1832 if (pdb)
1833 return pdb;
61bb5906 1834 SETERRNO(0,SS$_NORMAL);
a0d0e21e
LW
1835 return "BEGIN { require 'perl5db.pl' }";
1836 }
1837 return "";
1838}
1839
1840
16d20bd9
AD
1841/* Encoded script support. filter_add() effectively inserts a
1842 * 'pre-processing' function into the current source input stream.
1843 * Note that the filter function only applies to the current source file
1844 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1845 *
1846 * The datasv parameter (which may be NULL) can be used to pass
1847 * private data to this instance of the filter. The filter function
1848 * can recover the SV using the FILTER_DATA macro and use it to
1849 * store private buffers and state information.
1850 *
1851 * The supplied datasv parameter is upgraded to a PVIO type
e0c19803
GS
1852 * and the IoDIRP field is used to store the function pointer,
1853 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
16d20bd9
AD
1854 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1855 * private use must be set using malloc'd pointers.
1856 */
16d20bd9
AD
1857
1858SV *
864dbfa3 1859Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
16d20bd9 1860{
f4c556ac
GS
1861 if (!funcp)
1862 return Nullsv;
1863
3280af22
NIS
1864 if (!PL_rsfp_filters)
1865 PL_rsfp_filters = newAV();
16d20bd9 1866 if (!datasv)
8c52afec 1867 datasv = NEWSV(255,0);
16d20bd9 1868 if (!SvUPGRADE(datasv, SVt_PVIO))
cea2e8a9 1869 Perl_die(aTHX_ "Can't upgrade filter_add data to SVt_PVIO");
16d20bd9 1870 IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
e0c19803 1871 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
f4c556ac
GS
1872 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
1873 funcp, SvPV_nolen(datasv)));
3280af22
NIS
1874 av_unshift(PL_rsfp_filters, 1);
1875 av_store(PL_rsfp_filters, 0, datasv) ;
16d20bd9
AD
1876 return(datasv);
1877}
1878
1879
1880/* Delete most recently added instance of this filter function. */
a0d0e21e 1881void
864dbfa3 1882Perl_filter_del(pTHX_ filter_t funcp)
16d20bd9 1883{
e0c19803 1884 SV *datasv;
f4c556ac 1885 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", funcp));
3280af22 1886 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
16d20bd9
AD
1887 return;
1888 /* if filter is on top of stack (usual case) just pop it off */
e0c19803
GS
1889 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
1890 if (IoDIRP(datasv) == (DIR*)funcp) {
1891 IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
1892 IoDIRP(datasv) = (DIR*)NULL;
3280af22 1893 sv_free(av_pop(PL_rsfp_filters));
e50aee73 1894
16d20bd9
AD
1895 return;
1896 }
1897 /* we need to search for the correct entry and clear it */
cea2e8a9 1898 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
16d20bd9
AD
1899}
1900
1901
1902/* Invoke the n'th filter function for the current rsfp. */
1903I32
864dbfa3 1904Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
8ac85365
NIS
1905
1906
1907 /* 0 = read one text line */
a0d0e21e 1908{
16d20bd9
AD
1909 filter_t funcp;
1910 SV *datasv = NULL;
e50aee73 1911
3280af22 1912 if (!PL_rsfp_filters)
16d20bd9 1913 return -1;
3280af22 1914 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
16d20bd9
AD
1915 /* Provide a default input filter to make life easy. */
1916 /* Note that we append to the line. This is handy. */
f4c556ac
GS
1917 DEBUG_P(PerlIO_printf(Perl_debug_log,
1918 "filter_read %d: from rsfp\n", idx));
16d20bd9
AD
1919 if (maxlen) {
1920 /* Want a block */
1921 int len ;
1922 int old_len = SvCUR(buf_sv) ;
1923
1924 /* ensure buf_sv is large enough */
1925 SvGROW(buf_sv, old_len + maxlen) ;
3280af22
NIS
1926 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1927 if (PerlIO_error(PL_rsfp))
37120919
AD
1928 return -1; /* error */
1929 else
1930 return 0 ; /* end of file */
1931 }
16d20bd9
AD
1932 SvCUR_set(buf_sv, old_len + len) ;
1933 } else {
1934 /* Want a line */
3280af22
NIS
1935 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
1936 if (PerlIO_error(PL_rsfp))
37120919
AD
1937 return -1; /* error */
1938 else
1939 return 0 ; /* end of file */
1940 }
16d20bd9
AD
1941 }
1942 return SvCUR(buf_sv);
1943 }
1944 /* Skip this filter slot if filter has been deleted */
3280af22 1945 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
f4c556ac
GS
1946 DEBUG_P(PerlIO_printf(Perl_debug_log,
1947 "filter_read %d: skipped (filter deleted)\n",
1948 idx));
16d20bd9
AD
1949 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1950 }
1951 /* Get function pointer hidden within datasv */
1952 funcp = (filter_t)IoDIRP(datasv);
f4c556ac
GS
1953 DEBUG_P(PerlIO_printf(Perl_debug_log,
1954 "filter_read %d: via function %p (%s)\n",
1955 idx, funcp, SvPV_nolen(datasv)));
16d20bd9
AD
1956 /* Call function. The function is expected to */
1957 /* call "FILTER_READ(idx+1, buf_sv)" first. */
37120919 1958 /* Return: <0:error, =0:eof, >0:not eof */
0cb96387 1959 return (*funcp)(aTHXo_ idx, buf_sv, maxlen);
16d20bd9
AD
1960}
1961
76e3520e 1962STATIC char *
cea2e8a9 1963S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
16d20bd9 1964{
c39cd008 1965#ifdef PERL_CR_FILTER
3280af22 1966 if (!PL_rsfp_filters) {
c39cd008 1967 filter_add(S_cr_textfilter,NULL);
a868473f
NIS
1968 }
1969#endif
3280af22 1970 if (PL_rsfp_filters) {
16d20bd9 1971
55497cff
PP
1972 if (!append)
1973 SvCUR_set(sv, 0); /* start with empty line */
16d20bd9
AD
1974 if (FILTER_READ(0, sv, 0) > 0)
1975 return ( SvPVX(sv) ) ;
1976 else
1977 return Nullch ;
1978 }
9d116dd7 1979 else
fd049845 1980 return (sv_gets(sv, fp, append));
a0d0e21e
LW
1981}
1982
1983
748a9306
LW
1984#ifdef DEBUGGING
1985 static char* exp_name[] =
09bef843
SB
1986 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
1987 "ATTRTERM", "TERMBLOCK"
1988 };
748a9306 1989#endif
463ee0b2 1990
02aa26ce
NT
1991/*
1992 yylex
1993
1994 Works out what to call the token just pulled out of the input
1995 stream. The yacc parser takes care of taking the ops we return and
1996 stitching them into a tree.
1997
1998 Returns:
1999 PRIVATEREF
2000
2001 Structure:
2002 if read an identifier
2003 if we're in a my declaration
2004 croak if they tried to say my($foo::bar)
2005 build the ops for a my() declaration
2006 if it's an access to a my() variable
2007 are we in a sort block?
2008 croak if my($a); $a <=> $b
2009 build ops for access to a my() variable
2010 if in a dq string, and they've said @foo and we can't find @foo
2011 croak
2012 build ops for a bareword
2013 if we already built the token before, use it.
2014*/
2015
864dbfa3
GS
2016int
2017#ifdef USE_PURE_BISON
cea2e8a9 2018Perl_yylex(pTHX_ YYSTYPE *lvalp, int *lcharp)
864dbfa3 2019#else
cea2e8a9 2020Perl_yylex(pTHX)
864dbfa3 2021#endif
378cc40b 2022{
11343788 2023 dTHR;
79072805 2024 register char *s;
378cc40b 2025 register char *d;
79072805 2026 register I32 tmp;
463ee0b2 2027 STRLEN len;
161b471a
NIS
2028 GV *gv = Nullgv;
2029 GV **gvp = 0;
a687059c 2030
a1a0e61e
TD
2031#ifdef USE_PURE_BISON
2032 yylval_pointer = lvalp;
2033 yychar_pointer = lcharp;
2034#endif
2035
02aa26ce 2036 /* check if there's an identifier for us to look at */
3280af22 2037 if (PL_pending_ident) {
02aa26ce 2038 /* pit holds the identifier we read and pending_ident is reset */
3280af22
NIS
2039 char pit = PL_pending_ident;
2040 PL_pending_ident = 0;
bbce6d69 2041
02aa26ce
NT
2042 /* if we're in a my(), we can't allow dynamics here.
2043 $foo'bar has already been turned into $foo::bar, so
2044 just check for colons.
2045
2046 if it's a legal name, the OP is a PADANY.
2047 */
3280af22 2048 if (PL_in_my) {
77ca0c92 2049 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
1ec3e8de
GS
2050 if (strchr(PL_tokenbuf,':'))
2051 yyerror(Perl_form(aTHX_ "No package name allowed for "
2052 "variable %s in \"our\"",
2053 PL_tokenbuf));
77ca0c92
LW
2054 tmp = pad_allocmy(PL_tokenbuf);
2055 }
2056 else {
2057 if (strchr(PL_tokenbuf,':'))
2058 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
02aa26ce 2059
77ca0c92
LW
2060 yylval.opval = newOP(OP_PADANY, 0);
2061 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
2062 return PRIVATEREF;
2063 }
bbce6d69
PP
2064 }
2065
02aa26ce
NT
2066 /*
2067 build the ops for accesses to a my() variable.
2068
2069 Deny my($a) or my($b) in a sort block, *if* $a or $b is
2070 then used in a comparison. This catches most, but not
2071 all cases. For instance, it catches
2072 sort { my($a); $a <=> $b }
2073 but not
2074 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
2075 (although why you'd do that is anyone's guess).
2076 */
2077
3280af22 2078 if (!strchr(PL_tokenbuf,':')) {
a863c7d1 2079#ifdef USE_THREADS
54b9620d 2080 /* Check for single character per-thread SVs */
3280af22
NIS
2081 if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
2082 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
2083 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
554b3eca 2084 {
2faa37cc 2085 yylval.opval = newOP(OP_THREADSV, 0);
a863c7d1
MB
2086 yylval.opval->op_targ = tmp;
2087 return PRIVATEREF;
2088 }
2089#endif /* USE_THREADS */
3280af22 2090 if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
f472eb5c 2091 SV *namesv = AvARRAY(PL_comppad_name)[tmp];
77ca0c92 2092 /* might be an "our" variable" */
f472eb5c 2093 if (SvFLAGS(namesv) & SVpad_OUR) {
77ca0c92 2094 /* build ops for a bareword */
f472eb5c
GS
2095 SV *sym = newSVpv(HvNAME(GvSTASH(namesv)),0);
2096 sv_catpvn(sym, "::", 2);
2097 sv_catpv(sym, PL_tokenbuf+1);
2098 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
77ca0c92 2099 yylval.opval->op_private = OPpCONST_ENTERED;
f472eb5c 2100 gv_fetchpv(SvPVX(sym),
77ca0c92 2101 (PL_in_eval
f472eb5c
GS
2102 ? (GV_ADDMULTI | GV_ADDINEVAL)
2103 : TRUE
77ca0c92
LW
2104 ),
2105 ((PL_tokenbuf[0] == '$') ? SVt_PV
2106 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
2107 : SVt_PVHV));
2108 return WORD;
2109 }
2110
02aa26ce 2111 /* if it's a sort block and they're naming $a or $b */
3280af22
NIS
2112 if (PL_last_lop_op == OP_SORT &&
2113 PL_tokenbuf[0] == '$' &&
2114 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
2115 && !PL_tokenbuf[2])
bbce6d69 2116 {
3280af22
NIS
2117 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
2118 d < PL_bufend && *d != '\n';
a863c7d1
MB
2119 d++)
2120 {
2121 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
cea2e8a9 2122 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
3280af22 2123 PL_tokenbuf);
a863c7d1 2124 }
bbce6d69
PP
2125 }
2126 }
bbce6d69 2127
a863c7d1
MB
2128 yylval.opval = newOP(OP_PADANY, 0);
2129 yylval.opval->op_targ = tmp;
2130 return PRIVATEREF;
2131 }
bbce6d69
PP
2132 }
2133
02aa26ce
NT
2134 /*
2135 Whine if they've said @foo in a doublequoted string,
2136 and @foo isn't a variable we can find in the symbol
2137 table.
2138 */
3280af22
NIS
2139 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
2140 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
2141 if (!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
cea2e8a9 2142 yyerror(Perl_form(aTHX_ "In string, %s now must be written as \\%s",
3280af22 2143 PL_tokenbuf, PL_tokenbuf));
bbce6d69
PP
2144 }
2145
02aa26ce 2146 /* build ops for a bareword */
3280af22 2147 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
bbce6d69 2148 yylval.opval->op_private = OPpCONST_ENTERED;
3280af22
NIS
2149 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
2150 ((PL_tokenbuf[0] == '$') ? SVt_PV
2151 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
bbce6d69
PP
2152 : SVt_PVHV));
2153 return WORD;
2154 }
2155
02aa26ce
NT
2156 /* no identifier pending identification */
2157
3280af22 2158 switch (PL_lex_state) {
79072805
LW
2159#ifdef COMMENTARY
2160 case LEX_NORMAL: /* Some compilers will produce faster */
2161 case LEX_INTERPNORMAL: /* code if we comment these out. */
2162 break;
2163#endif
2164
09bef843 2165 /* when we've already built the next token, just pull it out of the queue */
79072805 2166 case LEX_KNOWNEXT:
3280af22
NIS
2167 PL_nexttoke--;
2168 yylval = PL_nextval[PL_nexttoke];
2169 if (!PL_nexttoke) {
2170 PL_lex_state = PL_lex_defer;
2171 PL_expect = PL_lex_expect;
2172 PL_lex_defer = LEX_NORMAL;
463ee0b2 2173 }
3280af22 2174 return(PL_nexttype[PL_nexttoke]);
79072805 2175
02aa26ce 2176 /* interpolated case modifiers like \L \U, including \Q and \E.
3280af22 2177 when we get here, PL_bufptr is at the \
02aa26ce 2178 */
79072805
LW
2179 case LEX_INTERPCASEMOD:
2180#ifdef DEBUGGING
3280af22 2181 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
cea2e8a9 2182 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
79072805 2183#endif
02aa26ce 2184 /* handle \E or end of string */
3280af22 2185 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
a0d0e21e 2186 char oldmod;
02aa26ce
NT
2187
2188 /* if at a \E */
3280af22
NIS
2189 if (PL_lex_casemods) {
2190 oldmod = PL_lex_casestack[--PL_lex_casemods];
2191 PL_lex_casestack[PL_lex_casemods] = '\0';
02aa26ce 2192
3280af22
NIS
2193 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
2194 PL_bufptr += 2;
2195 PL_lex_state = LEX_INTERPCONCAT;
a0d0e21e 2196 }
79072805
LW
2197 return ')';
2198 }
3280af22
NIS
2199 if (PL_bufptr != PL_bufend)
2200 PL_bufptr += 2;
2201 PL_lex_state = LEX_INTERPCONCAT;
cea2e8a9 2202 return yylex();
79072805
LW
2203 }
2204 else {
3280af22 2205 s = PL_bufptr + 1;
79072805
LW
2206 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
2207 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
a0d0e21e 2208 if (strchr("LU", *s) &&
3280af22 2209 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
a0d0e21e 2210 {
3280af22 2211 PL_lex_casestack[--PL_lex_casemods] = '\0';
a0d0e21e
LW
2212 return ')';
2213 }
3280af22
NIS
2214 if (PL_lex_casemods > 10) {
2215 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
2216 if (newlb != PL_lex_casestack) {
a0d0e21e 2217 SAVEFREEPV(newlb);
3280af22 2218 PL_lex_casestack = newlb;
a0d0e21e
LW
2219 }
2220 }
3280af22
NIS
2221 PL_lex_casestack[PL_lex_casemods++] = *s;
2222 PL_lex_casestack[PL_lex_casemods] = '\0';
2223 PL_lex_state = LEX_INTERPCONCAT;
2224 PL_nextval[PL_nexttoke].ival = 0;
79072805
LW
2225 force_next('(');
2226 if (*s == 'l')
3280af22 2227 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
79072805 2228 else if (*s == 'u')
3280af22 2229 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
79072805 2230 else if (*s == 'L')
3280af22 2231 PL_nextval[PL_nexttoke].ival = OP_LC;
79072805 2232 else if (*s == 'U')
3280af22 2233 PL_nextval[PL_nexttoke].ival = OP_UC;
a0d0e21e 2234 else if (*s == 'Q')
3280af22 2235 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
79072805 2236 else
cea2e8a9 2237 Perl_croak(aTHX_ "panic: yylex");
3280af22 2238 PL_bufptr = s + 1;
79072805 2239 force_next(FUNC);
3280af22
NIS
2240 if (PL_lex_starts) {
2241 s = PL_bufptr;
2242 PL_lex_starts = 0;
79072805
LW
2243 Aop(OP_CONCAT);
2244 }
2245 else
cea2e8a9 2246 return yylex();
79072805
LW
2247 }
2248
55497cff
PP
2249 case LEX_INTERPPUSH:
2250 return sublex_push();
2251
79072805 2252 case LEX_INTERPSTART:
3280af22 2253 if (PL_bufptr == PL_bufend)
79072805 2254 return sublex_done();
3280af22
NIS
2255 PL_expect = XTERM;
2256 PL_lex_dojoin = (*PL_bufptr == '@');
2257 PL_lex_state = LEX_INTERPNORMAL;
2258 if (PL_lex_dojoin) {
2259 PL_nextval[PL_nexttoke].ival = 0;
79072805 2260 force_next(',');
554b3eca 2261#ifdef USE_THREADS
533c011a
NIS
2262 PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
2263 PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
554b3eca
MB
2264 force_next(PRIVATEREF);
2265#else
a0d0e21e 2266 force_ident("\"", '$');
554b3eca 2267#endif /* USE_THREADS */
3280af22 2268 PL_nextval[PL_nexttoke].ival = 0;
79072805 2269 force_next('$');
3280af22 2270 PL_nextval[PL_nexttoke].ival = 0;
79072805 2271 force_next('(');
3280af22 2272 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
79072805
LW
2273 force_next(FUNC);
2274 }
3280af22
NIS
2275 if (PL_lex_starts++) {
2276 s = PL_bufptr;
79072805
LW
2277 Aop(OP_CONCAT);
2278 }
cea2e8a9 2279 return yylex();
79072805
LW
2280
2281 case LEX_INTERPENDMAYBE:
3280af22
NIS
2282 if (intuit_more(PL_bufptr)) {
2283 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
79072805
LW
2284 break;
2285 }
2286 /* FALL THROUGH */
2287
2288 case LEX_INTERPEND:
3280af22
NIS
2289 if (PL_lex_dojoin) {
2290 PL_lex_dojoin = FALSE;
2291 PL_lex_state = LEX_INTERPCONCAT;
79072805
LW
2292 return ')';
2293 }
43a16006 2294 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
25da4f38 2295 && SvEVALED(PL_lex_repl))
43a16006 2296 {
e9fa98b2 2297 if (PL_bufptr != PL_bufend)
cea2e8a9 2298 Perl_croak(aTHX_ "Bad evalled substitution pattern");
e9fa98b2
HS
2299 PL_lex_repl = Nullsv;
2300 }
79072805
LW
2301 /* FALLTHROUGH */
2302 case LEX_INTERPCONCAT:
2303#ifdef DEBUGGING
3280af22 2304 if (PL_lex_brackets)
cea2e8a9 2305 Perl_croak(aTHX_ "panic: INTERPCONCAT");
79072805 2306#endif
3280af22 2307 if (PL_bufptr == PL_bufend)
79072805
LW
2308 return sublex_done();
2309
3280af22
NIS
2310 if (SvIVX(PL_linestr) == '\'') {
2311 SV *sv = newSVsv(PL_linestr);
2312 if (!PL_lex_inpat)
76e3520e 2313 sv = tokeq(sv);
3280af22 2314 else if ( PL_hints & HINT_NEW_RE )
b3ac6de7 2315 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
79072805 2316 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3280af22 2317 s = PL_bufend;
79072805
LW
2318 }
2319 else {
3280af22 2320 s = scan_const(PL_bufptr);
79072805 2321 if (*s == '\\')
3280af22 2322 PL_lex_state = LEX_INTERPCASEMOD;
79072805 2323 else
3280af22 2324 PL_lex_state = LEX_INTERPSTART;
79072805
LW
2325 }
2326
3280af22
NIS
2327 if (s != PL_bufptr) {
2328 PL_nextval[PL_nexttoke] = yylval;
2329 PL_expect = XTERM;
79072805 2330 force_next(THING);
3280af22 2331 if (PL_lex_starts++)
79072805
LW
2332 Aop(OP_CONCAT);
2333 else {
3280af22 2334 PL_bufptr = s;
cea2e8a9 2335 return yylex();
79072805
LW
2336 }
2337 }
2338
cea2e8a9 2339 return yylex();
a0d0e21e 2340 case LEX_FORMLINE:
3280af22
NIS
2341 PL_lex_state = LEX_NORMAL;
2342 s = scan_formline(PL_bufptr);
2343 if (!PL_lex_formbrack)
a0d0e21e
LW
2344 goto rightbracket;
2345 OPERATOR(';');
79072805
LW
2346 }
2347
3280af22
NIS
2348 s = PL_bufptr;
2349 PL_oldoldbufptr = PL_oldbufptr;
2350 PL_oldbufptr = s;
79072805 2351 DEBUG_p( {
bf49b057
GS
2352 PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at %s\n",
2353 exp_name[PL_expect], s);
79072805 2354 } )
463ee0b2
LW
2355
2356 retry:
378cc40b
LW
2357 switch (*s) {
2358 default:
7e2040f0 2359 if (isIDFIRST_lazy_if(s,UTF))
834a4ddd 2360 goto keylookup;
cea2e8a9 2361 Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
e929a76b
LW
2362 case 4:
2363 case 26:
2364 goto fake_eof; /* emulate EOF on ^D or ^Z */
378cc40b 2365 case 0:
3280af22
NIS
2366 if (!PL_rsfp) {
2367 PL_last_uni = 0;
2368 PL_last_lop = 0;
2369 if (PL_lex_brackets)
d98d5fff 2370 yyerror("Missing right curly or square bracket");
79072805 2371 TOKEN(0);
463ee0b2 2372 }
3280af22 2373 if (s++ < PL_bufend)
a687059c 2374 goto retry; /* ignore stray nulls */
3280af22
NIS
2375 PL_last_uni = 0;
2376 PL_last_lop = 0;
2377 if (!PL_in_eval && !PL_preambled) {
2378 PL_preambled = TRUE;
2379 sv_setpv(PL_linestr,incl_perldb());
2380 if (SvCUR(PL_linestr))
2381 sv_catpv(PL_linestr,";");
2382 if (PL_preambleav){
2383 while(AvFILLp(PL_preambleav) >= 0) {
2384 SV *tmpsv = av_shift(PL_preambleav);
2385 sv_catsv(PL_linestr, tmpsv);
2386 sv_catpv(PL_linestr, ";");
91b7def8
PP
2387 sv_free(tmpsv);
2388 }
3280af22
NIS
2389 sv_free((SV*)PL_preambleav);
2390 PL_preambleav = NULL;
91b7def8 2391 }
3280af22
NIS
2392 if (PL_minus_n || PL_minus_p) {
2393 sv_catpv(PL_linestr, "LINE: while (<>) {");
2394 if (PL_minus_l)
2395 sv_catpv(PL_linestr,"chomp;");
2396 if (PL_minus_a) {
8fd239a7
CS
2397 GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
2398 if (gv)
2399 GvIMPORTED_AV_on(gv);
3280af22
NIS
2400 if (PL_minus_F) {
2401 if (strchr("/'\"", *PL_splitstr)
2402 && strchr(PL_splitstr + 1, *PL_splitstr))
cea2e8a9 2403 Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s);", PL_splitstr);
54310121
PP
2404 else {
2405 char delim;
2406 s = "'~#\200\1'"; /* surely one char is unused...*/
3280af22 2407 while (s[1] && strchr(PL_splitstr, *s)) s++;
54310121 2408 delim = *s;
cea2e8a9 2409 Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s%c",
46fc3d4c 2410 "q" + (delim == '\''), delim);
3280af22 2411 for (s = PL_splitstr; *s; s++) {
54310121 2412 if (*s == '\\')
3280af22
NIS
2413 sv_catpvn(PL_linestr, "\\", 1);
2414 sv_catpvn(PL_linestr, s, 1);
54310121 2415 }
cea2e8a9 2416 Perl_sv_catpvf(aTHX_ PL_linestr, "%c);", delim);
54310121 2417 }
2304df62
AD
2418 }
2419 else
3280af22 2420 sv_catpv(PL_linestr,"@F=split(' ');");
2304df62 2421 }
79072805 2422 }
3280af22
NIS
2423 sv_catpv(PL_linestr, "\n");
2424 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2425 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2426 if (PERLDB_LINE && PL_curstash != PL_debstash) {
a0d0e21e
LW
2427 SV *sv = NEWSV(85,0);
2428
2429 sv_upgrade(sv, SVt_PVMG);
3280af22 2430 sv_setsv(sv,PL_linestr);
57843af0 2431 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
a0d0e21e 2432 }
79072805 2433 goto retry;
a687059c 2434 }
e929a76b 2435 do {
3280af22 2436 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
e929a76b 2437 fake_eof:
3280af22
NIS
2438 if (PL_rsfp) {
2439 if (PL_preprocess && !PL_in_eval)
2440 (void)PerlProc_pclose(PL_rsfp);
2441 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2442 PerlIO_clearerr(PL_rsfp);
395c3793 2443 else
3280af22
NIS
2444 (void)PerlIO_close(PL_rsfp);
2445 PL_rsfp = Nullfp;
4a9ae47a 2446 PL_doextract = FALSE;
395c3793 2447 }
3280af22
NIS
2448 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2449 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
2450 sv_catpv(PL_linestr,";}");
2451 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2452 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2453 PL_minus_n = PL_minus_p = 0;
e929a76b
LW
2454 goto retry;
2455 }
3280af22
NIS
2456 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2457 sv_setpv(PL_linestr,"");
79072805 2458 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
378cc40b 2459 }
3280af22 2460 if (PL_doextract) {
a0d0e21e 2461 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
3280af22 2462 PL_doextract = FALSE;
a0d0e21e
LW
2463
2464 /* Incest with pod. */
2465 if (*s == '=' && strnEQ(s, "=cut", 4)) {
3280af22
NIS
2466 sv_setpv(PL_linestr, "");
2467 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2468 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2469 PL_doextract = FALSE;
a0d0e21e
LW
2470 }
2471 }
463ee0b2 2472 incline(s);
3280af22
NIS
2473 } while (PL_doextract);
2474 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2475 if (PERLDB_LINE && PL_curstash != PL_debstash) {
79072805 2476 SV *sv = NEWSV(85,0);
a687059c 2477
93a17b20 2478 sv_upgrade(sv, SVt_PVMG);
3280af22 2479 sv_setsv(sv,PL_linestr);
57843af0 2480 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
a687059c 2481 }
3280af22 2482 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
57843af0 2483 if (CopLINE(PL_curcop) == 1) {
3280af22 2484 while (s < PL_bufend && isSPACE(*s))
79072805 2485 s++;
a0d0e21e 2486 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
79072805 2487 s++;
44a8e56a 2488 d = Nullch;
3280af22 2489 if (!PL_in_eval) {
44a8e56a
PP
2490 if (*s == '#' && *(s+1) == '!')
2491 d = s + 2;
2492#ifdef ALTERNATE_SHEBANG
2493 else {
2494 static char as[] = ALTERNATE_SHEBANG;
2495 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2496 d = s + (sizeof(as) - 1);
2497 }
2498#endif /* ALTERNATE_SHEBANG */
2499 }
2500 if (d) {
b8378b72 2501 char *ipath;
774d564b 2502 char *ipathend;
b8378b72 2503
774d564b 2504 while (isSPACE(*d))
b8378b72
CS
2505 d++;
2506 ipath = d;
774d564b
PP
2507 while (*d && !isSPACE(*d))
2508 d++;
2509 ipathend = d;
2510
2511#ifdef ARG_ZERO_IS_SCRIPT
2512 if (ipathend > ipath) {
2513 /*
2514 * HP-UX (at least) sets argv[0] to the script name,
2515 * which makes $^X incorrect. And Digital UNIX and Linux,
2516 * at least, set argv[0] to the basename of the Perl
2517 * interpreter. So, having found "#!", we'll set it right.
2518 */
2519 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
2520 assert(SvPOK(x) || SvGMAGICAL(x));
cc49e20b 2521 if (sv_eq(x, CopFILESV(PL_curcop))) {
774d564b 2522 sv_setpvn(x, ipath, ipathend - ipath);
9607fc9c
PP
2523 SvSETMAGIC(x);
2524 }
774d564b 2525 TAINT_NOT; /* $^X is always tainted, but that's OK */
8ebc5c01 2526 }
774d564b 2527#endif /* ARG_ZERO_IS_SCRIPT */
b8378b72
CS
2528
2529 /*
2530 * Look for options.
2531 */
748a9306 2532 d = instr(s,"perl -");
84e30d1a 2533 if (!d) {
748a9306 2534 d = instr(s,"perl");
84e30d1a
GS
2535#if defined(DOSISH)
2536 /* avoid getting into infinite loops when shebang
2537 * line contains "Perl" rather than "perl" */
2538 if (!d) {
2539 for (d = ipathend-4; d >= ipath; --d) {
2540 if ((*d == 'p' || *d == 'P')
2541 && !ibcmp(d, "perl", 4))
2542 {
2543 break;
2544 }
2545 }
2546 if (d < ipath)
2547 d = Nullch;
2548 }
2549#endif
2550 }
44a8e56a
PP
2551#ifdef ALTERNATE_SHEBANG
2552 /*
2553 * If the ALTERNATE_SHEBANG on this system starts with a
2554 * character that can be part of a Perl expression, then if
2555 * we see it but not "perl", we're probably looking at the
2556 * start of Perl code, not a request to hand off to some
2557 * other interpreter. Similarly, if "perl" is there, but
2558 * not in the first 'word' of the line, we assume the line
2559 * contains the start of the Perl program.
44a8e56a
PP
2560 */
2561 if (d && *s != '#') {
774d564b 2562 char *c = ipath;
44a8e56a
PP
2563 while (*c && !strchr("; \t\r\n\f\v#", *c))
2564 c++;
2565 if (c < d)
2566 d = Nullch; /* "perl" not in first word; ignore */
2567 else
2568 *s = '#'; /* Don't try to parse shebang line */
2569 }
774d564b 2570#endif /* ALTERNATE_SHEBANG */
748a9306 2571 if (!d &&
44a8e56a 2572 *s == '#' &&
774d564b 2573 ipathend > ipath &&
3280af22 2574 !PL_minus_c &&
748a9306 2575 !instr(s,"indir") &&
3280af22 2576 instr(PL_origargv[0],"perl"))
748a9306 2577 {
9f68db38 2578 char **newargv;
9f68db38 2579
774d564b
PP
2580 *ipathend = '\0';
2581 s = ipathend + 1;
3280af22 2582 while (s < PL_bufend && isSPACE(*s))
9f68db38 2583 s++;
3280af22
NIS
2584 if (s < PL_bufend) {
2585 Newz(899,newargv,PL_origargc+3,char*);
9f68db38 2586 newargv[1] = s;
3280af22 2587 while (s < PL_bufend && !isSPACE(*s))
9f68db38
LW
2588 s++;
2589 *s = '\0';
3280af22 2590 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
9f68db38
LW
2591 }
2592 else
3280af22 2593 newargv = PL_origargv;
774d564b 2594 newargv[0] = ipath;
80252599 2595 PerlProc_execv(ipath, newargv);
cea2e8a9 2596 Perl_croak(aTHX_ "Can't exec %s", ipath);
9f68db38 2597 }
748a9306 2598 if (d) {
3280af22
NIS
2599 U32 oldpdb = PL_perldb;
2600 bool oldn = PL_minus_n;
2601 bool oldp = PL_minus_p;
748a9306
LW
2602
2603 while (*d && !isSPACE(*d)) d++;
89bfa8cd 2604 while (*d == ' ' || *d == '\t') d++;
748a9306
LW
2605
2606 if (*d++ == '-') {
8cc95fdb
PP
2607 do {
2608 if (*d == 'M' || *d == 'm') {
2609 char *m = d;
2610 while (*d && !isSPACE(*d)) d++;
cea2e8a9 2611 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
8cc95fdb
PP
2612 (int)(d - m), m);
2613 }
2614 d = moreswitches(d);
2615 } while (d);
84902520 2616 if (PERLDB_LINE && !oldpdb ||
3280af22 2617 ( PL_minus_n || PL_minus_p ) && !(oldn || oldp) )
b084f20b
PP
2618 /* if we have already added "LINE: while (<>) {",
2619 we must not do it again */
748a9306 2620 {
3280af22
NIS
2621 sv_setpv(PL_linestr, "");
2622 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2623 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2624 PL_preambled = FALSE;
84902520 2625 if (PERLDB_LINE)
3280af22 2626 (void)gv_fetchfile(PL_origfilename);
748a9306
LW
2627 goto retry;
2628 }
a0d0e21e 2629 }
79072805 2630 }
9f68db38 2631 }
79072805 2632 }
3280af22
NIS
2633 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2634 PL_bufptr = s;
2635 PL_lex_state = LEX_FORMLINE;
cea2e8a9 2636 return yylex();
ae986130 2637 }
378cc40b 2638 goto retry;
4fdae800 2639 case '\r':
6a27c188 2640#ifdef PERL_STRICT_CR
cea2e8a9
GS
2641 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2642 Perl_croak(aTHX_
54310121 2643 "(Maybe you didn't strip carriage returns after a network transfer?)\n");
a868473f 2644#endif
4fdae800 2645 case ' ': case '\t': case '\f': case 013:
378cc40b
LW
2646 s++;
2647 goto retry;
378cc40b 2648 case '#':
e929a76b 2649 case '\n':
3280af22
NIS
2650 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2651 d = PL_bufend;
a687059c 2652 while (s < d && *s != '\n')
378cc40b 2653 s++;
0f85fab0 2654 if (s < d)
378cc40b 2655 s++;
463ee0b2 2656 incline(s);
3280af22
NIS
2657 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2658 PL_bufptr = s;
2659 PL_lex_state = LEX_FORMLINE;
cea2e8a9 2660 return yylex();
a687059c 2661 }
378cc40b 2662 }
a687059c 2663 else {
378cc40b 2664 *s = '\0';
3280af22 2665 PL_bufend = s;
a687059c 2666 }
378cc40b
LW
2667 goto retry;
2668 case '-':
79072805 2669 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
378cc40b 2670 s++;
3280af22 2671 PL_bufptr = s;
748a9306
LW
2672 tmp = *s++;
2673
3280af22 2674 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
748a9306
LW
2675 s++;
2676
2677 if (strnEQ(s,"=>",2)) {
3280af22 2678 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
748a9306
LW
2679 OPERATOR('-'); /* unary minus */
2680 }
3280af22
NIS
2681 PL_last_uni = PL_oldbufptr;
2682 PL_last_lop_op = OP_FTEREAD; /* good enough */
748a9306 2683 switch (tmp) {
79072805
LW
2684 case 'r': FTST(OP_FTEREAD);
2685 case 'w': FTST(OP_FTEWRITE);
2686 case 'x': FTST(OP_FTEEXEC);
2687 case 'o': FTST(OP_FTEOWNED);
2688 case 'R': FTST(OP_FTRREAD);
2689 case 'W': FTST(OP_FTRWRITE);
2690 case 'X': FTST(OP_FTREXEC);
2691 case 'O': FTST(OP_FTROWNED);
2692 case 'e': FTST(OP_FTIS);
2693 case 'z': FTST(OP_FTZERO);
2694 case 's': FTST(OP_FTSIZE);
2695 case 'f': FTST(OP_FTFILE);
2696 case 'd': FTST(OP_FTDIR);
2697 case 'l': FTST(OP_FTLINK);
2698 case 'p': FTST(OP_FTPIPE);
2699 case 'S': FTST(OP_FTSOCK);
2700 case 'u': FTST(OP_FTSUID);
2701 case 'g': FTST(OP_FTSGID);
2702 case 'k': FTST(OP_FTSVTX);
2703 case 'b': FTST(OP_FTBLK);
2704 case 'c': FTST(OP_FTCHR);
2705 case 't': FTST(OP_FTTTY);
2706 case 'T': FTST(OP_FTTEXT);
2707 case 'B': FTST(OP_FTBINARY);
85e6fe83
LW
2708 case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2709 case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2710 case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
378cc40b 2711 default:
cea2e8a9 2712 Perl_croak(aTHX_ "Unrecognized file test: -%c", (int)tmp);
378cc40b
LW
2713 break;
2714 }
2715 }
a687059c
LW
2716 tmp = *s++;
2717 if (*s == tmp) {
2718 s++;
3280af22 2719 if (PL_expect == XOPERATOR)
79072805
LW
2720 TERM(POSTDEC);
2721 else
2722 OPERATOR(PREDEC);
2723 }
2724 else if (*s == '>') {
2725 s++;
2726 s = skipspace(s);
7e2040f0 2727 if (isIDFIRST_lazy_if(s,UTF)) {
a0d0e21e 2728 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
463ee0b2 2729 TOKEN(ARROW);
79072805 2730 }
748a9306
LW
2731 else if (*s == '$')
2732 OPERATOR(ARROW);
463ee0b2 2733 else
748a9306 2734 TERM(ARROW);
a687059c 2735 }
3280af22 2736 if (PL_expect == XOPERATOR)
79072805
LW
2737 Aop(OP_SUBTRACT);
2738 else {
3280af22 2739 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2f3197b3 2740 check_uni();
79072805 2741 OPERATOR('-'); /* unary minus */
2f3197b3 2742 }
79072805 2743
378cc40b 2744 case '+':
a687059c
LW
2745 tmp = *s++;
2746 if (*s == tmp) {
378cc40b 2747 s++;
3280af22 2748 if (PL_expect == XOPERATOR)
79072805
LW
2749 TERM(POSTINC);
2750 else
2751 OPERATOR(PREINC);
378cc40b 2752 }
3280af22 2753 if (PL_expect == XOPERATOR)
79072805
LW
2754 Aop(OP_ADD);
2755 else {
3280af22 2756 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2f3197b3 2757 check_uni();
a687059c 2758 OPERATOR('+');
2f3197b3 2759 }
a687059c 2760
378cc40b 2761 case '*':
3280af22
NIS
2762 if (PL_expect != XOPERATOR) {
2763 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2764 PL_expect = XOPERATOR;
2765 force_ident(PL_tokenbuf, '*');
2766 if (!*PL_tokenbuf)
a0d0e21e 2767 PREREF('*');
79072805 2768 TERM('*');
a687059c 2769 }
79072805
LW
2770 s++;
2771 if (*s == '*') {
a687059c 2772 s++;
79072805 2773 PWop(OP_POW);
a687059c 2774 }
79072805
LW
2775 Mop(OP_MULTIPLY);
2776
378cc40b 2777 case '%':
3280af22 2778 if (PL_expect == XOPERATOR) {
bbce6d69
PP
2779 ++s;
2780 Mop(OP_MODULO);
a687059c 2781 }
3280af22
NIS
2782 PL_tokenbuf[0] = '%';
2783 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2784 if (!PL_tokenbuf[1]) {
2785 if (s == PL_bufend)
bbce6d69
PP
2786 yyerror("Final % should be \\% or %name");
2787 PREREF('%');
a687059c 2788 }
3280af22 2789 PL_pending_ident = '%';
bbce6d69 2790 TERM('%');
a687059c 2791
378cc40b 2792 case '^':
79072805 2793 s++;
a0d0e21e 2794 BOop(OP_BIT_XOR);
79072805 2795 case '[':
3280af22 2796 PL_lex_brackets++;
79072805 2797 /* FALL THROUGH */
378cc40b 2798 case '~':
378cc40b 2799 case ',':
378cc40b
LW
2800 tmp = *s++;
2801 OPERATOR(tmp);
a0d0e21e
LW
2802 case ':':
2803 if (s[1] == ':') {
2804 len = 0;
2805 goto just_a_word;
2806 }
2807 s++;
09bef843
SB
2808 switch (PL_expect) {
2809 OP *attrs;
2810 case XOPERATOR:
2811 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
2812 break;
2813 PL_bufptr = s; /* update in case we back off */
2814 goto grabattrs;
2815 case XATTRBLOCK:
2816 PL_expect = XBLOCK;
2817 goto grabattrs;
2818 case XATTRTERM:
2819 PL_expect = XTERMBLOCK;
2820 grabattrs:
2821 s = skipspace(s);
2822 attrs = Nullop;
7e2040f0 2823 while (isIDFIRST_lazy_if(s,UTF)) {
09bef843 2824 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
f9829d6b
GS
2825 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
2826 if (tmp < 0) tmp = -tmp;
2827 switch (tmp) {
2828 case KEY_or:
2829 case KEY_and:
2830 case KEY_for:
2831 case KEY_unless:
2832 case KEY_if:
2833 case KEY_while:
2834 case KEY_until:
2835 goto got_attrs;
2836 default:
2837 break;
2838 }
2839 }
09bef843
SB
2840 if (*d == '(') {
2841 d = scan_str(d,TRUE,TRUE);
2842 if (!d) {
2843 if (PL_lex_stuff) {
2844 SvREFCNT_dec(PL_lex_stuff);
2845 PL_lex_stuff = Nullsv;
2846 }
2847 /* MUST advance bufptr here to avoid bogus
2848 "at end of line" context messages from yyerror().
2849 */
2850 PL_bufptr = s + len;
2851 yyerror("Unterminated attribute parameter in attribute list");
2852 if (attrs)
2853 op_free(attrs);
2854 return 0; /* EOF indicator */
2855 }
2856 }
2857 if (PL_lex_stuff) {
2858 SV *sv = newSVpvn(s, len);
2859 sv_catsv(sv, PL_lex_stuff);
2860 attrs = append_elem(OP_LIST, attrs,
2861 newSVOP(OP_CONST, 0, sv));
2862 SvREFCNT_dec(PL_lex_stuff);
2863 PL_lex_stuff = Nullsv;
2864 }
2865 else {
2866 attrs = append_elem(OP_LIST, attrs,
2867 newSVOP(OP_CONST, 0,
2868 newSVpvn(s, len)));
2869 }
2870 s = skipspace(d);
0120eecf 2871 if (*s == ':' && s[1] != ':')
09bef843 2872 s = skipspace(s+1);
0120eecf
GS
2873 else if (s == d)
2874 break; /* require real whitespace or :'s */
09bef843 2875 }
f9829d6b
GS
2876 tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
2877 if (*s != ';' && *s != tmp && (tmp != '=' || *s != ')')) {
09bef843
SB
2878 char q = ((*s == '\'') ? '"' : '\'');
2879 /* If here for an expression, and parsed no attrs, back off. */
2880 if (tmp == '=' && !attrs) {
2881 s = PL_bufptr;
2882 break;
2883 }
2884 /* MUST advance bufptr here to avoid bogus "at end of line"
2885 context messages from yyerror().
2886 */
2887 PL_bufptr = s;
2888 if (!*s)
2889 yyerror("Unterminated attribute list");
2890 else
2891 yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list",
2892 q, *s, q));
2893 if (attrs)
2894 op_free(attrs);
2895 OPERATOR(':');
2896 }
f9829d6b 2897 got_attrs:
09bef843
SB
2898 if (attrs) {
2899 PL_nextval[PL_nexttoke].opval = attrs;
2900 force_next(THING);
2901 }
2902 TOKEN(COLONATTR);
2903 }
a0d0e21e 2904 OPERATOR(':');
8990e307
LW
2905 case '(':
2906 s++;
3280af22
NIS
2907 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
2908 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
a0d0e21e 2909 else
3280af22 2910 PL_expect = XTERM;
a0d0e21e 2911 TOKEN('(');
378cc40b 2912 case ';':
57843af0
GS
2913 if (CopLINE(PL_curcop) < PL_copline)
2914 PL_copline = CopLINE(PL_curcop);
378cc40b
LW
2915 tmp = *s++;
2916 OPERATOR(tmp);
2917 case ')':
378cc40b 2918 tmp = *s++;
16d20bd9
AD
2919 s = skipspace(s);
2920 if (*s == '{')
2921 PREBLOCK(tmp);
378cc40b 2922 TERM(tmp);
79072805
LW
2923 case ']':
2924 s++;
3280af22 2925 if (PL_lex_brackets <= 0)
d98d5fff 2926 yyerror("Unmatched right square bracket");
463ee0b2 2927 else
3280af22
NIS
2928 --PL_lex_brackets;
2929 if (PL_lex_state == LEX_INTERPNORMAL) {
2930 if (PL_lex_brackets == 0) {
a0d0e21e 2931 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
3280af22 2932 PL_lex_state = LEX_INTERPEND;
79072805
LW
2933 }
2934 }
4633a7c4 2935 TERM(']');
79072805
LW
2936 case '{':
2937 leftbracket:
79072805 2938 s++;
3280af22
NIS
2939 if (PL_lex_brackets > 100) {
2940 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
2941 if (newlb != PL_lex_brackstack) {
8990e307 2942 SAVEFREEPV(newlb);
3280af22 2943 PL_lex_brackstack = newlb;
8990e307
LW
2944 }
2945 }
3280af22 2946 switch (PL_expect) {
a0d0e21e 2947 case XTERM:
3280af22 2948 if (PL_lex_formbrack) {
a0d0e21e
LW
2949 s--;
2950 PRETERMBLOCK(DO);
2951 }
3280af22
NIS
2952 if (PL_oldoldbufptr == PL_last_lop)
2953 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
a0d0e21e 2954 else
3280af22 2955 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
79072805 2956 OPERATOR(HASHBRACK);
a0d0e21e 2957 case XOPERATOR:
3280af22 2958 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
748a9306 2959 s++;
44a8e56a 2960 d = s;
3280af22
NIS
2961 PL_tokenbuf[0] = '\0';
2962 if (d < PL_bufend && *d == '-') {
2963 PL_tokenbuf[0] = '-';
44a8e56a 2964 d++;
3280af22 2965 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
44a8e56a
PP
2966 d++;
2967 }
7e2040f0 2968 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
3280af22 2969 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
8903cb82 2970 FALSE, &len);
3280af22 2971 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
748a9306
LW
2972 d++;
2973 if (*d == '}') {
3280af22 2974 char minus = (PL_tokenbuf[0] == '-');
44a8e56a
PP
2975 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2976 if (minus)
2977 force_next('-');
748a9306
LW
2978 }
2979 }
2980 /* FALL THROUGH */
09bef843 2981 case XATTRBLOCK:
748a9306 2982 case XBLOCK:
3280af22
NIS
2983 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
2984 PL_expect = XSTATE;
a0d0e21e 2985 break;
09bef843 2986 case XATTRTERM:
a0d0e21e 2987 case XTERMBLOCK:
3280af22
NIS
2988 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2989 PL_expect = XSTATE;
a0d0e21e
LW
2990 break;
2991 default: {
2992 char *t;
3280af22
NIS
2993 if (PL_oldoldbufptr == PL_last_lop)
2994 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
a0d0e21e 2995 else
3280af22 2996 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
a0d0e21e 2997 s = skipspace(s);
09ecc4b6 2998 if (*s == '}')
a0d0e21e 2999 OPERATOR(HASHBRACK);
b8a4b1be
GS
3000 /* This hack serves to disambiguate a pair of curlies
3001 * as being a block or an anon hash. Normally, expectation
3002 * determines that, but in cases where we're not in a
3003 * position to expect anything in particular (like inside
3004 * eval"") we have to resolve the ambiguity. This code
3005 * covers the case where the first term in the curlies is a
3006 * quoted string. Most other cases need to be explicitly
3007 * disambiguated by prepending a `+' before the opening
3008 * curly in order to force resolution as an anon hash.
3009 *
3010 * XXX should probably propagate the outer expectation
3011 * into eval"" to rely less on this hack, but that could
3012 * potentially break current behavior of eval"".
3013 * GSAR 97-07-21
3014 */
3015 t = s;
3016 if (*s == '\'' || *s == '"' || *s == '`') {
3017 /* common case: get past first string, handling escapes */
3280af22 3018 for (t++; t < PL_bufend && *t != *s;)
b8a4b1be
GS
3019 if (*t++ == '\\' && (*t == '\\' || *t == *s))
3020 t++;
3021 t++;
a0d0e21e 3022 }
b8a4b1be 3023 else if (*s == 'q') {
3280af22 3024 if (++t < PL_bufend
b8a4b1be 3025 && (!isALNUM(*t)
3280af22 3026 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
0505442f
GS
3027 && !isALNUM(*t))))
3028 {
b8a4b1be
GS
3029 char *tmps;
3030 char open, close, term;
3031 I32 brackets = 1;
3032
3280af22 3033 while (t < PL_bufend && isSPACE(*t))
b8a4b1be
GS
3034 t++;
3035 term = *t;
3036 open = term;
3037 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
3038 term = tmps[5];
3039 close = term;
3040 if (open == close)
3280af22
NIS
3041 for (t++; t < PL_bufend; t++) {
3042 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
b8a4b1be 3043 t++;
6d07e5e9 3044 else if (*t == open)
b8a4b1be
GS
3045 break;
3046 }
3047 else
3280af22
NIS
3048 for (t++; t < PL_bufend; t++) {
3049 if (*t == '\\' && t+1 < PL_bufend)
b8a4b1be 3050 t++;
6d07e5e9 3051 else if (*t == close && --brackets <= 0)
b8a4b1be
GS
3052 break;
3053 else if (*t == open)
3054 brackets++;
3055 }
3056 }
3057 t++;
a0d0e21e 3058 }
7e2040f0 3059 else if (isALNUM_lazy_if(t,UTF)) {
0505442f 3060 t += UTF8SKIP(t);
7e2040f0 3061 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
0505442f 3062 t += UTF8SKIP(t);
a0d0e21e 3063 }
3280af22 3064 while (t < PL_bufend && isSPACE(*t))
a0d0e21e 3065 t++;
b8a4b1be
GS
3066 /* if comma follows first term, call it an anon hash */
3067 /* XXX it could be a comma expression with loop modifiers */
3280af22 3068 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
b8a4b1be 3069 || (*t == '=' && t[1] == '>')))
a0d0e21e 3070 OPERATOR(HASHBRACK);
3280af22 3071 if (PL_expect == XREF)
4e4e412b 3072 PL_expect = XTERM;
a0d0e21e 3073 else {
3280af22
NIS
3074 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
3075 PL_expect = XSTATE;
a0d0e21e 3076 }
8990e307 3077 }
a0d0e21e 3078 break;
463ee0b2 3079 }
57843af0 3080 yylval.ival = CopLINE(PL_curcop);
79072805 3081 if (isSPACE(*s) || *s == '#')
3280af22 3082 PL_copline = NOLINE; /* invalidate current command line number */
79072805 3083 TOKEN('{');
378cc40b 3084 case '}':
79072805
LW
3085 rightbracket:
3086 s++;
3280af22 3087 if (PL_lex_brackets <= 0)
d98d5fff 3088 yyerror("Unmatched right curly bracket");
463ee0b2 3089 else
3280af22
NIS
3090 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
3091 if (PL_lex_brackets < PL_lex_formbrack)
3092 PL_lex_formbrack = 0;
3093 if (PL_lex_state == LEX_INTERPNORMAL) {
3094 if (PL_lex_brackets == 0) {
9059aa12
LW
3095 if (PL_expect & XFAKEBRACK) {
3096 PL_expect &= XENUMMASK;
3280af22
NIS
3097 PL_lex_state = LEX_INTERPEND;
3098 PL_bufptr = s;
cea2e8a9 3099 return yylex(); /* ignore fake brackets */
79072805 3100 }
fa83b5b6 3101 if (*s == '-' && s[1] == '>')
3280af22 3102 PL_lex_state = LEX_INTERPENDMAYBE;
fa83b5b6 3103 else if (*s != '[' && *s != '{')
3280af22 3104 PL_lex_state = LEX_INTERPEND;
79072805
LW
3105 }
3106 }
9059aa12
LW
3107 if (PL_expect & XFAKEBRACK) {
3108 PL_expect &= XENUMMASK;
3280af22 3109 PL_bufptr = s;
cea2e8a9 3110 return yylex(); /* ignore fake brackets */
748a9306 3111 }
79072805
LW
3112 force_next('}');
3113 TOKEN(';');
378cc40b
LW
3114 case '&':
3115 s++;
3116 tmp = *s++;
3117 if (tmp == '&')
a0d0e21e 3118 AOPERATOR(ANDAND);
378cc40b 3119 s--;
3280af22 3120 if (PL_expect == XOPERATOR) {
7e2040f0
GS
3121 if (ckWARN(WARN_SEMICOLON)
3122 && isIDFIRST_lazy_if(s,UTF) && PL_bufptr == PL_linestart)
3123 {
57843af0 3124 CopLINE_dec(PL_curcop);
cea2e8a9 3125 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
57843af0 3126 CopLINE_inc(PL_curcop);
463ee0b2 3127 }
79072805 3128 BAop(OP_BIT_AND);
463ee0b2 3129 }
79072805 3130
3280af22
NIS
3131 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3132 if (*PL_tokenbuf) {
3133 PL_expect = XOPERATOR;
3134 force_ident(PL_tokenbuf, '&');
463ee0b2 3135 }
79072805
LW
3136 else
3137 PREREF('&');
c07a80fd 3138 yylval.ival = (OPpENTERSUB_AMPER<<8);
79072805
LW
3139 TERM('&');
3140
378cc40b
LW
3141 case '|':
3142 s++;
3143 tmp = *s++;
3144 if (tmp == '|')
a0d0e21e 3145 AOPERATOR(OROR);
378cc40b 3146 s--;
79072805 3147 BOop(OP_BIT_OR);
378cc40b
LW
3148 case '=':
3149 s++;
3150 tmp = *s++;
3151 if (tmp == '=')
79072805
LW
3152 Eop(OP_EQ);
3153 if (tmp == '>')
3154 OPERATOR(',');
378cc40b 3155 if (tmp == '~')
79072805 3156 PMop(OP_MATCH);
599cee73 3157 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
cea2e8a9 3158 Perl_warner(aTHX_ WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
378cc40b 3159 s--;
3280af22
NIS
3160 if (PL_expect == XSTATE && isALPHA(tmp) &&
3161 (s == PL_linestart+1 || s[-2] == '\n') )
748a9306 3162 {
3280af22
NIS
3163 if (PL_in_eval && !PL_rsfp) {
3164 d = PL_bufend;
a5f75d66
AD
3165 while (s < d) {
3166 if (*s++ == '\n') {
3167 incline(s);
3168 if (strnEQ(s,"=cut",4)) {
3169 s = strchr(s,'\n');
3170 if (s)
3171 s++;
3172 else
3173 s = d;
3174 incline(s);
3175 goto retry;
3176 }
3177 }
3178 }
3179 goto retry;
3180 }
3280af22
NIS
3181 s = PL_bufend;
3182 PL_doextract = TRUE;
a0d0e21e
LW
3183 goto retry;
3184 }
3280af22 3185 if (PL_lex_brackets < PL_lex_formbrack) {
a0d0e21e 3186 char *t;
51882d45 3187#ifdef PERL_STRICT_CR
a0d0e21e 3188 for (t = s; *t == ' ' || *t == '\t'; t++) ;
51882d45
GS
3189#else
3190 for (t = s; *t == ' ' || *t == '\t' || *t == '\r'; t++) ;
3191#endif
a0d0e21e
LW
3192 if (*t == '\n' || *t == '#') {
3193 s--;
3280af22 3194 PL_expect = XBLOCK;
a0d0e21e
LW
3195 goto leftbracket;
3196 }
79072805 3197 }
a0d0e21e
LW
3198 yylval.ival = 0;
3199 OPERATOR(ASSIGNOP);
378cc40b
LW
3200 case '!':
3201 s++;
3202 tmp = *s++;
3203 if (tmp == '=')
79072805 3204 Eop(OP_NE);
378cc40b 3205 if (tmp == '~')
79072805 3206 PMop(OP_NOT);
378cc40b
LW
3207 s--;
3208 OPERATOR('!');
3209 case '<':
3280af22 3210 if (PL_expect != XOPERATOR) {
93a17b20 3211 if (s[1] != '<' && !strchr(s,'>'))
2f3197b3 3212 check_uni();
79072805
LW
3213 if (s[1] == '<')
3214 s = scan_heredoc(s);
3215 else
3216 s = scan_inputsymbol(s);
3217 TERM(sublex_start());
378cc40b
LW
3218 }
3219 s++;
3220 tmp = *s++;
3221 if (tmp == '<')
79072805 3222 SHop(OP_LEFT_SHIFT);
395c3793
LW
3223 if (tmp == '=') {
3224 tmp = *s++;
3225 if (tmp == '>')
79072805 3226 Eop(OP_NCMP);
395c3793 3227 s--;
79072805 3228 Rop(OP_LE);
395c3793 3229 }
378cc40b 3230 s--;
79072805 3231 Rop(OP_LT);
378cc40b
LW
3232 case '>':
3233 s++;
3234 tmp = *s++;
3235 if (tmp == '>')
79072805 3236 SHop(OP_RIGHT_SHIFT);
378cc40b 3237 if (tmp == '=')
79072805 3238 Rop(OP_GE);
378cc40b 3239 s--;
79072805 3240 Rop(OP_GT);
378cc40b
LW
3241
3242 case '$':
bbce6d69
PP
3243 CLINE;
3244
3280af22
NIS
3245 if (PL_expect == XOPERATOR) {
3246 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3247 PL_expect = XTERM;
a0d0e21e 3248 depcom();
bbce6d69 3249 return ','; /* grandfather non-comma-format format */
a0d0e21e 3250 }
8990e307 3251 }
a0d0e21e 3252
7e2040f0 3253 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
3280af22 3254 PL_tokenbuf[0] = '@';
376b8730
SM
3255 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3256 sizeof PL_tokenbuf - 1, FALSE);
3257 if (PL_expect == XOPERATOR)
3258 no_op("Array length", s);
3280af22 3259 if (!PL_tokenbuf[1])
a0d0e21e 3260 PREREF(DOLSHARP);
3280af22
NIS
3261 PL_expect = XOPERATOR;
3262 PL_pending_ident = '#';
463ee0b2 3263 TOKEN(DOLSHARP);
79072805 3264 }
bbce6d69 3265
3280af22 3266 PL_tokenbuf[0] = '$';
376b8730
SM
3267 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3268 sizeof PL_tokenbuf - 1, FALSE);
3269 if (PL_expect == XOPERATOR)
3270 no_op("Scalar", s);
3280af22
NIS
3271 if (!PL_tokenbuf[1]) {
3272 if (s == PL_bufend)
bbce6d69
PP
3273 yyerror("Final $ should be \\$ or $name");
3274 PREREF('$');
8990e307 3275 }
a0d0e21e 3276
bbce6d69 3277 /* This kludge not intended to be bulletproof. */
3280af22 3278 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
bbce6d69 3279 yylval.opval = newSVOP(OP_CONST, 0,
3280af22 3280 newSViv((IV)PL_compiling.cop_arybase));
bbce6d69
PP
3281 yylval.opval->op_private = OPpCONST_ARYBASE;
3282 TERM(THING);
3283 }
3284
ff68c719 3285 d = s;
69d2bceb 3286 tmp = (I32)*s;
3280af22 3287 if (PL_lex_state == LEX_NORMAL)
ff68c719
PP
3288 s = skipspace(s);
3289
3280af22 3290 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
bbce6d69
PP
3291 char *t;
3292 if (*s == '[') {
3280af22 3293 PL_tokenbuf[0] = '@';
599cee73 3294 if (ckWARN(WARN_SYNTAX)) {
bbce6d69 3295 for(t = s + 1;
7e2040f0 3296 isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$';
bbce6d69 3297 t++) ;
a0d0e21e 3298 if (*t++ == ',') {
3280af22
NIS
3299 PL_bufptr = skipspace(PL_bufptr);
3300 while (t < PL_bufend && *t != ']')
bbce6d69 3301 t++;
cea2e8a9 3302 Perl_warner(aTHX_ WARN_SYNTAX,
599cee73
PM
3303 "Multidimensional syntax %.*s not supported",
3304 (t - PL_bufptr) + 1, PL_bufptr);
a0d0e21e
LW
3305 }
3306 }
bbce6d69
PP
3307 }
3308 else if (*s == '{') {
3280af22 3309 PL_tokenbuf[0] = '%';
599cee73 3310 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
bbce6d69
PP
3311 (t = strchr(s, '}')) && (t = strchr(t, '=')))
3312 {
3280af22 3313 char tmpbuf[sizeof PL_tokenbuf];
a0d0e21e
LW
3314 STRLEN len;
3315 for (t++; isSPACE(*t); t++) ;
7e2040f0 3316 if (isIDFIRST_lazy_if(t,UTF)) {
8903cb82 3317 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
59a6d928 3318 for (; isSPACE(*t); t++) ;
864dbfa3 3319 if (*t == ';' && get_cv(tmpbuf, FALSE))
cea2e8a9 3320 Perl_warner(aTHX_ WARN_SYNTAX,
599cee73 3321 "You need to quote \"%s\"", tmpbuf);
748a9306 3322 }
93a17b20
LW
3323 }
3324 }
2f3197b3 3325 }
bbce6d69 3326
3280af22 3327 PL_expect = XOPERATOR;
69d2bceb 3328 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3280af22
NIS
3329 bool islop = (PL_last_lop == PL_oldoldbufptr);
3330 if (!islop || PL_last_lop_op == OP_GREPSTART)
3331 PL_expect = XOPERATOR;
bbce6d69 3332 else if (strchr("$@\"'`q", *s))
3280af22 3333 PL_expect = XTERM; /* e.g. print $fh "foo" */
7e2040f0 3334 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
3280af22 3335 PL_expect = XTERM; /* e.g. print $fh &sub */
7e2040f0 3336 else if (isIDFIRST_lazy_if(s,UTF)) {
3280af22 3337 char tmpbuf[sizeof PL_tokenbuf];
8903cb82 3338 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
84902520
TB
3339 if (tmp = keyword(tmpbuf, len)) {
3340 /* binary operators exclude handle interpretations */
3341 switch (tmp) {
3342 case -KEY_x:
3343 case -KEY_eq:
3344 case -KEY_ne:
3345 case -KEY_gt:
3346 case -KEY_lt:
3347 case -KEY_ge:
3348 case -KEY_le:
3349 case -KEY_cmp:
3350 break;
3351 default:
3280af22 3352 PL_expect = XTERM; /* e.g. print $fh length() */
84902520
TB
3353 break;
3354 }
3355 }
68dc0745
PP
3356 else {
3357 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
3358 if (gv && GvCVu(gv))
3280af22 3359 PL_expect = XTERM; /* e.g. print $fh subr() */
93a17b20 3360 }
93a17b20 3361 }
bbce6d69 3362 else if (isDIGIT(*s))
3280af22 3363 PL_expect = XTERM; /* e.g. print $fh 3 */
bbce6d69 3364 else if (*s == '.' && isDIGIT(s[1]))
3280af22 3365 PL_expect = XTERM; /* e.g. print $fh .3 */
e0587a03 3366 else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
3280af22 3367 PL_expect = XTERM; /* e.g. print $fh -1 */
e0587a03 3368 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3280af22 3369 PL_expect = XTERM; /* print $fh <<"EOF" */
bbce6d69 3370 }
3280af22 3371 PL_pending_ident = '$';
79072805 3372 TOKEN('$');
378cc40b
LW
3373
3374 case '@':
3280af22 3375 if (PL_expect == XOPERATOR)
bbce6d69 3376 no_op("Array", s);
3280af22
NIS
3377 PL_tokenbuf[0] = '@';
3378 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3379 if (!PL_tokenbuf[1]) {
3380 if (s == PL_bufend)
bbce6d69
PP
3381 yyerror("Final @ should be \\@ or @name");
3382 PREREF('@');
3383 }
3280af22 3384 if (PL_lex_state == LEX_NORMAL)
ff68c719 3385 s = skipspace(s);
3280af22 3386 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
bbce6d69 3387 if (*s == '{')
3280af22 3388 PL_tokenbuf[0] = '%';
a0d0e21e
LW
3389
3390 /* Warn about @ where they meant $. */
599cee73 3391 if (ckWARN(WARN_SYNTAX)) {
a0d0e21e
LW
3392 if (*s == '[' || *s == '{') {
3393 char *t = s + 1;
7e2040f0 3394 while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
a0d0e21e
LW
3395 t++;
3396 if (*t == '}' || *t == ']') {
3397 t++;
3280af22 3398 PL_bufptr = skipspace(PL_bufptr);
cea2e8a9 3399 Perl_warner(aTHX_ WARN_SYNTAX,
599cee73 3400 "Scalar value %.*s better written as $%.*s",
3280af22 3401 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
a0d0e21e 3402 }
93a17b20
LW
3403 }
3404 }
463ee0b2 3405 }
3280af22 3406 PL_pending_ident = '@';
79072805 3407 TERM('@');
378cc40b
LW
3408
3409 case '/': /* may either be division or pattern */
3410 case '?': /* may either be conditional or pattern */
3280af22 3411 if (PL_expect != XOPERATOR) {
c277df42 3412 /* Disable warning on "study /blah/" */
3280af22
NIS
3413 if (PL_oldoldbufptr == PL_last_uni
3414 && (*PL_last_uni != 's' || s - PL_last_uni < 5
7e2040f0
GS
3415 || memNE(PL_last_uni, "study", 5)
3416 || isALNUM_lazy_if(PL_last_uni+5,UTF)))
c277df42 3417 check_uni();
8782bef2 3418 s = scan_pat(s,OP_MATCH);
79072805 3419 TERM(sublex_start());
378cc40b
LW
3420 }
3421 tmp = *s++;
a687059c 3422 if (tmp == '/')
79072805 3423 Mop(OP_DIVIDE);
378cc40b
LW
3424 OPERATOR(tmp);
3425
3426 case '.':
51882d45
GS
3427 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3428#ifdef PERL_STRICT_CR
3429 && s[1] == '\n'
3430#else
3431 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3432#endif
3433 && (s == PL_linestart || s[-1] == '\n') )
3434 {
3280af22
NIS
3435 PL_lex_formbrack = 0;
3436 PL_expect = XSTATE;
79072805
LW
3437 goto rightbracket;
3438 }
3280af22 3439 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
378cc40b 3440 tmp = *s++;
a687059c
LW
3441 if (*s == tmp) {
3442 s++;
2f3197b3
LW
3443 if (*s == tmp) {
3444 s++;
79072805 3445 yylval.ival = OPf_SPECIAL;
2f3197b3
LW
3446 }
3447 else
79072805 3448 yylval.ival = 0;
378cc40b 3449 OPERATOR(DOTDOT);
a687059c 3450 }
3280af22 3451 if (PL_expect != XOPERATOR)
2f3197b3 3452 check_uni();
79072805 3453 Aop(OP_CONCAT);
378cc40b
LW
3454 }
3455 /* FALL THROUGH */
3456 case '0': case '1': case '2': case '3': case '4':
3457 case '5': case '6': case '7': case '8': case '9':
79072805 3458 s = scan_num(s);
3280af22 3459 if (PL_expect == XOPERATOR)
8990e307 3460 no_op("Number",s);
79072805
LW
3461 TERM(THING);
3462
3463 case '\'':
09bef843 3464 s = scan_str(s,FALSE,FALSE);
3280af22
NIS
3465 if (PL_expect == XOPERATOR) {
3466 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3467 PL_expect = XTERM;
a0d0e21e
LW
3468 depcom();
3469 return ','; /* grandfather non-comma-format format */
3470 }
463ee0b2 3471 else
8990e307 3472 no_op("String",s);
463ee0b2 3473 }
79072805 3474 if (!s)
85e6fe83 3475 missingterm((char*)0);
79072805
LW
3476 yylval.ival = OP_CONST;
3477 TERM(sublex_start());
3478
3479 case '"':
09bef843 3480 s = scan_str(s,FALSE,FALSE);
3280af22
NIS
3481 if (PL_expect == XOPERATOR) {
3482 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3483 PL_expect = XTERM;
a0d0e21e
LW
3484 depcom();
3485 return ','; /* grandfather non-comma-format format */
3486 }
463ee0b2 3487 else
8990e307 3488 no_op("String",s);
463ee0b2 3489 }
79072805 3490 if (!s)
85e6fe83 3491 missingterm((char*)0);
4633a7c4 3492 yylval.ival = OP_CONST;
3280af22 3493 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
a0ed51b3 3494 if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
4633a7c4
LW
3495 yylval.ival = OP_STRINGIFY;
3496 break;
3497 }
3498 }
79072805
LW
3499 TERM(sublex_start());
3500
3501 case '`':
09bef843 3502 s = scan_str(s,FALSE,FALSE);
3280af22 3503 if (PL_expect == XOPERATOR)
8990e307 3504 no_op("Backticks",s);
79072805 3505 if (!s)
85e6fe83 3506 missingterm((char*)0);
79072805
LW
3507 yylval.ival = OP_BACKTICK;
3508 set_csh();
3509 TERM(sublex_start());
3510
3511 case '\\':
3512 s++;
599cee73 3513 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
cea2e8a9 3514 Perl_warner(aTHX_ WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
599cee73 3515 *s, *s);
3280af22 3516 if (PL_expect == XOPERATOR)
8990e307 3517 no_op("Backslash",s);
79072805
LW
3518 OPERATOR(REFGEN);
3519
a7cb1f99 3520 case 'v':
e526c9e6 3521 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
a7cb1f99
GS
3522 char *start = s;
3523 start++;
3524 start++;
dd629d5b 3525 while (isDIGIT(*start) || *start == '_')
a7cb1f99
GS
3526 start++;
3527 if (*start == '.' && isDIGIT(start[1])) {
3528 s = scan_num(s);
3529 TERM(THING);
3530 }
e526c9e6
GS
3531 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
3532 else if (!isALPHA(*start) && (PL_expect == XTERM || PL_expect == XREF)) {
3533 char c = *start;
3534 GV *gv;
3535 *start = '\0';
3536 gv = gv_fetchpv(s, FALSE, SVt_PVCV);
3537 *start = c;
3538 if (!gv) {
3539 s = scan_num(s);
3540 TERM(THING);
3541 }
3542 }
a7cb1f99
GS
3543 }
3544 goto keylookup;
79072805 3545 case 'x':
3280af22 3546 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
79072805
LW
3547 s++;
3548 Mop(OP_REPEAT);
2f3197b3 3549 }
79072805
LW
3550 goto keylookup;
3551
378cc40b 3552 case '_':
79072805
LW
3553 case 'a': case 'A':
3554 case 'b': case 'B':
3555 case 'c': case 'C':
3556 case 'd': case 'D':
3557 case 'e': case 'E':
3558 case 'f': case 'F':
3559 case 'g': case 'G':
3560 case 'h': case 'H':
3561 case 'i': case 'I':
3562 case 'j': case 'J':
3563 case 'k': case 'K':
3564 case 'l': case 'L':
3565 case 'm': case 'M':
3566 case 'n': case 'N':
3567 case 'o': case 'O':
3568 case 'p': case 'P':
3569 case 'q': case 'Q':
3570 case 'r': case 'R':
3571 case 's': case 'S':
3572 case 't': case 'T':
3573 case 'u': case 'U':
a7cb1f99 3574 case 'V':
79072805
LW
3575 case 'w': case 'W':
3576 case 'X':
3577 case 'y': case 'Y':
3578 case 'z': case 'Z':
3579
49dc05e3 3580 keylookup: {
2d8e6c8d 3581 STRLEN n_a;
161b471a
NIS
3582 gv = Nullgv;
3583 gvp = 0;
49dc05e3 3584
3280af22
NIS
3585 PL_bufptr = s;
3586 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
8ebc5c01
PP
3587
3588 /* Some keywords can be followed by any delimiter, including ':' */
3280af22
NIS
3589 tmp = (len == 1 && strchr("msyq", PL_tokenbuf[0]) ||
3590 len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
3591 (PL_tokenbuf[0] == 'q' &&
3592 strchr("qwxr", PL_tokenbuf[1]))));
8ebc5c01
PP
3593
3594 /* x::* is just a word, unless x is "CORE" */
3280af22 3595 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
4633a7c4
LW
3596 goto just_a_word;
3597
3643fb5f 3598 d = s;
3280af22 3599 while (d < PL_bufend && isSPACE(*d))
3643fb5f
CS
3600 d++; /* no comments skipped here, or s### is misparsed */
3601