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