This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
rudimentary support for remote debugging, from aeons ago (somewhat
[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
57843af0 107#define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
3280af22 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);
57843af0 369 SAVECOPLINE(PL_curcop);
3280af22
NIS
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
57843af0 437 * increments the current line number in CopLINE(PL_curcop) and checks
ffb4593c 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
57843af0 452 CopLINE_inc(PL_curcop);
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)
57843af0 477 CopFILE_set(PL_curcop, s);
463ee0b2 478 else
57843af0 479 CopFILE_set(PL_curcop, PL_origfilename);
463ee0b2 480 *t = ch;
57843af0 481 CopLINE_set(PL_curcop, 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 592 sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
57843af0 593 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),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);
57843af0 972 SAVECOPLINE(PL_curcop);
3280af22
NIS
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;
57843af0 1000 CopLINE_set(PL_curcop, PL_multi_start);
3280af22
NIS
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;
dff6d3cd 1156 const 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':
dff6d3cd 1333 *d++ = (char)scan_oct(s, 3, &len);
79072805
LW
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 1354 d = (char*)uv_to_utf8((U8*)d,
dff6d3cd 1355 (UV)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
e0c19803
GS
1767 * and the IoDIRP field is used to store the function pointer,
1768 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
16d20bd9
AD
1769 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1770 * private use must be set using malloc'd pointers.
1771 */
16d20bd9
AD
1772
1773SV *
864dbfa3 1774Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
16d20bd9 1775{
f4c556ac
GS
1776 if (!funcp)
1777 return Nullsv;
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 */
e0c19803 1786 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
f4c556ac
GS
1787 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
1788 funcp, SvPV_nolen(datasv)));
3280af22
NIS
1789 av_unshift(PL_rsfp_filters, 1);
1790 av_store(PL_rsfp_filters, 0, datasv) ;
16d20bd9
AD
1791 return(datasv);
1792}
1793
1794
1795/* Delete most recently added instance of this filter function. */
a0d0e21e 1796void
864dbfa3 1797Perl_filter_del(pTHX_ filter_t funcp)
16d20bd9 1798{
e0c19803 1799 SV *datasv;
f4c556ac 1800 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", funcp));
3280af22 1801 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
16d20bd9
AD
1802 return;
1803 /* if filter is on top of stack (usual case) just pop it off */
e0c19803
GS
1804 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
1805 if (IoDIRP(datasv) == (DIR*)funcp) {
1806 IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
1807 IoDIRP(datasv) = (DIR*)NULL;
3280af22 1808 sv_free(av_pop(PL_rsfp_filters));
e50aee73 1809
16d20bd9
AD
1810 return;
1811 }
1812 /* we need to search for the correct entry and clear it */
cea2e8a9 1813 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
16d20bd9
AD
1814}
1815
1816
1817/* Invoke the n'th filter function for the current rsfp. */
1818I32
864dbfa3 1819Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
8ac85365
NIS
1820
1821
1822 /* 0 = read one text line */
a0d0e21e 1823{
16d20bd9
AD
1824 filter_t funcp;
1825 SV *datasv = NULL;
e50aee73 1826
3280af22 1827 if (!PL_rsfp_filters)
16d20bd9 1828 return -1;
3280af22 1829 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
16d20bd9
AD
1830 /* Provide a default input filter to make life easy. */
1831 /* Note that we append to the line. This is handy. */
f4c556ac
GS
1832 DEBUG_P(PerlIO_printf(Perl_debug_log,
1833 "filter_read %d: from rsfp\n", idx));
16d20bd9
AD
1834 if (maxlen) {
1835 /* Want a block */
1836 int len ;
1837 int old_len = SvCUR(buf_sv) ;
1838
1839 /* ensure buf_sv is large enough */
1840 SvGROW(buf_sv, old_len + maxlen) ;
3280af22
NIS
1841 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1842 if (PerlIO_error(PL_rsfp))
37120919
AD
1843 return -1; /* error */
1844 else
1845 return 0 ; /* end of file */
1846 }
16d20bd9
AD
1847 SvCUR_set(buf_sv, old_len + len) ;
1848 } else {
1849 /* Want a line */
3280af22
NIS
1850 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
1851 if (PerlIO_error(PL_rsfp))
37120919
AD
1852 return -1; /* error */
1853 else
1854 return 0 ; /* end of file */
1855 }
16d20bd9
AD
1856 }
1857 return SvCUR(buf_sv);
1858 }
1859 /* Skip this filter slot if filter has been deleted */
3280af22 1860 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
f4c556ac
GS
1861 DEBUG_P(PerlIO_printf(Perl_debug_log,
1862 "filter_read %d: skipped (filter deleted)\n",
1863 idx));
16d20bd9
AD
1864 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1865 }
1866 /* Get function pointer hidden within datasv */
1867 funcp = (filter_t)IoDIRP(datasv);
f4c556ac
GS
1868 DEBUG_P(PerlIO_printf(Perl_debug_log,
1869 "filter_read %d: via function %p (%s)\n",
1870 idx, funcp, SvPV_nolen(datasv)));
16d20bd9
AD
1871 /* Call function. The function is expected to */
1872 /* call "FILTER_READ(idx+1, buf_sv)" first. */
37120919 1873 /* Return: <0:error, =0:eof, >0:not eof */
0cb96387 1874 return (*funcp)(aTHXo_ idx, buf_sv, maxlen);
16d20bd9
AD
1875}
1876
76e3520e 1877STATIC char *
cea2e8a9 1878S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
16d20bd9 1879{
a868473f 1880#ifdef WIN32FILTER
3280af22 1881 if (!PL_rsfp_filters) {
a868473f
NIS
1882 filter_add(win32_textfilter,NULL);
1883 }
1884#endif
3280af22 1885 if (PL_rsfp_filters) {
16d20bd9 1886
55497cff
PP
1887 if (!append)
1888 SvCUR_set(sv, 0); /* start with empty line */
16d20bd9
AD
1889 if (FILTER_READ(0, sv, 0) > 0)
1890 return ( SvPVX(sv) ) ;
1891 else
1892 return Nullch ;
1893 }
9d116dd7 1894 else
fd049845 1895 return (sv_gets(sv, fp, append));
a0d0e21e
LW
1896}
1897
1898
748a9306
LW
1899#ifdef DEBUGGING
1900 static char* exp_name[] =
09bef843
SB
1901 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
1902 "ATTRTERM", "TERMBLOCK"
1903 };
748a9306 1904#endif
463ee0b2 1905
02aa26ce
NT
1906/*
1907 yylex
1908
1909 Works out what to call the token just pulled out of the input
1910 stream. The yacc parser takes care of taking the ops we return and
1911 stitching them into a tree.
1912
1913 Returns:
1914 PRIVATEREF
1915
1916 Structure:
1917 if read an identifier
1918 if we're in a my declaration
1919 croak if they tried to say my($foo::bar)
1920 build the ops for a my() declaration
1921 if it's an access to a my() variable
1922 are we in a sort block?
1923 croak if my($a); $a <=> $b
1924 build ops for access to a my() variable
1925 if in a dq string, and they've said @foo and we can't find @foo
1926 croak
1927 build ops for a bareword
1928 if we already built the token before, use it.
1929*/
1930
864dbfa3
GS
1931int
1932#ifdef USE_PURE_BISON
cea2e8a9 1933Perl_yylex(pTHX_ YYSTYPE *lvalp, int *lcharp)
864dbfa3 1934#else
cea2e8a9 1935Perl_yylex(pTHX)
864dbfa3 1936#endif
378cc40b 1937{
11343788 1938 dTHR;
79072805 1939 register char *s;
378cc40b 1940 register char *d;
79072805 1941 register I32 tmp;
463ee0b2 1942 STRLEN len;
161b471a
NIS
1943 GV *gv = Nullgv;
1944 GV **gvp = 0;
a687059c 1945
a1a0e61e
TD
1946#ifdef USE_PURE_BISON
1947 yylval_pointer = lvalp;
1948 yychar_pointer = lcharp;
1949#endif
1950
02aa26ce 1951 /* check if there's an identifier for us to look at */
3280af22 1952 if (PL_pending_ident) {
02aa26ce 1953 /* pit holds the identifier we read and pending_ident is reset */
3280af22
NIS
1954 char pit = PL_pending_ident;
1955 PL_pending_ident = 0;
bbce6d69 1956
02aa26ce
NT
1957 /* if we're in a my(), we can't allow dynamics here.
1958 $foo'bar has already been turned into $foo::bar, so
1959 just check for colons.
1960
1961 if it's a legal name, the OP is a PADANY.
1962 */
3280af22 1963 if (PL_in_my) {
77ca0c92
LW
1964 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
1965 tmp = pad_allocmy(PL_tokenbuf);
1966 }
1967 else {
1968 if (strchr(PL_tokenbuf,':'))
1969 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
02aa26ce 1970
77ca0c92
LW
1971 yylval.opval = newOP(OP_PADANY, 0);
1972 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
1973 return PRIVATEREF;
1974 }
bbce6d69
PP
1975 }
1976
02aa26ce
NT
1977 /*
1978 build the ops for accesses to a my() variable.
1979
1980 Deny my($a) or my($b) in a sort block, *if* $a or $b is
1981 then used in a comparison. This catches most, but not
1982 all cases. For instance, it catches
1983 sort { my($a); $a <=> $b }
1984 but not
1985 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
1986 (although why you'd do that is anyone's guess).
1987 */
1988
3280af22 1989 if (!strchr(PL_tokenbuf,':')) {
a863c7d1 1990#ifdef USE_THREADS
54b9620d 1991 /* Check for single character per-thread SVs */
3280af22
NIS
1992 if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
1993 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
1994 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
554b3eca 1995 {
2faa37cc 1996 yylval.opval = newOP(OP_THREADSV, 0);
a863c7d1
MB
1997 yylval.opval->op_targ = tmp;
1998 return PRIVATEREF;
1999 }
2000#endif /* USE_THREADS */
3280af22 2001 if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
77ca0c92
LW
2002 /* might be an "our" variable" */
2003 if (SvFLAGS(AvARRAY(PL_comppad_name)[tmp]) & SVpad_OUR) {
2004 /* build ops for a bareword */
2005 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
2006 yylval.opval->op_private = OPpCONST_ENTERED;
2007 gv_fetchpv(PL_tokenbuf+1,
2008 (PL_in_eval
2009 ? (GV_ADDMULTI | GV_ADDINEVAL | GV_ADDOUR)
2010 : GV_ADDOUR
2011 ),
2012 ((PL_tokenbuf[0] == '$') ? SVt_PV
2013 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
2014 : SVt_PVHV));
2015 return WORD;
2016 }
2017
02aa26ce 2018 /* if it's a sort block and they're naming $a or $b */
3280af22
NIS
2019 if (PL_last_lop_op == OP_SORT &&
2020 PL_tokenbuf[0] == '$' &&
2021 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
2022 && !PL_tokenbuf[2])
bbce6d69 2023 {
3280af22
NIS
2024 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
2025 d < PL_bufend && *d != '\n';
a863c7d1
MB
2026 d++)
2027 {
2028 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
cea2e8a9 2029 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
3280af22 2030 PL_tokenbuf);
a863c7d1 2031 }
bbce6d69
PP
2032 }
2033 }
bbce6d69 2034
a863c7d1
MB
2035 yylval.opval = newOP(OP_PADANY, 0);
2036 yylval.opval->op_targ = tmp;
2037 return PRIVATEREF;
2038 }
bbce6d69
PP
2039 }
2040
02aa26ce
NT
2041 /*
2042 Whine if they've said @foo in a doublequoted string,
2043 and @foo isn't a variable we can find in the symbol
2044 table.
2045 */
3280af22
NIS
2046 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
2047 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
2048 if (!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
cea2e8a9 2049 yyerror(Perl_form(aTHX_ "In string, %s now must be written as \\%s",
3280af22 2050 PL_tokenbuf, PL_tokenbuf));
bbce6d69
PP
2051 }
2052
02aa26ce 2053 /* build ops for a bareword */
3280af22 2054 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
bbce6d69 2055 yylval.opval->op_private = OPpCONST_ENTERED;
3280af22
NIS
2056 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
2057 ((PL_tokenbuf[0] == '$') ? SVt_PV
2058 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
bbce6d69
PP
2059 : SVt_PVHV));
2060 return WORD;
2061 }
2062
02aa26ce
NT
2063 /* no identifier pending identification */
2064
3280af22 2065 switch (PL_lex_state) {
79072805
LW
2066#ifdef COMMENTARY
2067 case LEX_NORMAL: /* Some compilers will produce faster */
2068 case LEX_INTERPNORMAL: /* code if we comment these out. */
2069 break;
2070#endif
2071
09bef843 2072 /* when we've already built the next token, just pull it out of the queue */
79072805 2073 case LEX_KNOWNEXT:
3280af22
NIS
2074 PL_nexttoke--;
2075 yylval = PL_nextval[PL_nexttoke];
2076 if (!PL_nexttoke) {
2077 PL_lex_state = PL_lex_defer;
2078 PL_expect = PL_lex_expect;
2079 PL_lex_defer = LEX_NORMAL;
463ee0b2 2080 }
3280af22 2081 return(PL_nexttype[PL_nexttoke]);
79072805 2082
02aa26ce 2083 /* interpolated case modifiers like \L \U, including \Q and \E.
3280af22 2084 when we get here, PL_bufptr is at the \
02aa26ce 2085 */
79072805
LW
2086 case LEX_INTERPCASEMOD:
2087#ifdef DEBUGGING
3280af22 2088 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
cea2e8a9 2089 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
79072805 2090#endif
02aa26ce 2091 /* handle \E or end of string */
3280af22 2092 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
a0d0e21e 2093 char oldmod;
02aa26ce
NT
2094
2095 /* if at a \E */
3280af22
NIS
2096 if (PL_lex_casemods) {
2097 oldmod = PL_lex_casestack[--PL_lex_casemods];
2098 PL_lex_casestack[PL_lex_casemods] = '\0';
02aa26ce 2099
3280af22
NIS
2100 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
2101 PL_bufptr += 2;
2102 PL_lex_state = LEX_INTERPCONCAT;
a0d0e21e 2103 }
79072805
LW
2104 return ')';
2105 }
3280af22
NIS
2106 if (PL_bufptr != PL_bufend)
2107 PL_bufptr += 2;
2108 PL_lex_state = LEX_INTERPCONCAT;
cea2e8a9 2109 return yylex();
79072805
LW
2110 }
2111 else {
3280af22 2112 s = PL_bufptr + 1;
79072805
LW
2113 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
2114 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
a0d0e21e 2115 if (strchr("LU", *s) &&
3280af22 2116 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
a0d0e21e 2117 {
3280af22 2118 PL_lex_casestack[--PL_lex_casemods] = '\0';
a0d0e21e
LW
2119 return ')';
2120 }
3280af22
NIS
2121 if (PL_lex_casemods > 10) {
2122 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
2123 if (newlb != PL_lex_casestack) {
a0d0e21e 2124 SAVEFREEPV(newlb);
3280af22 2125 PL_lex_casestack = newlb;
a0d0e21e
LW
2126 }
2127 }
3280af22
NIS
2128 PL_lex_casestack[PL_lex_casemods++] = *s;
2129 PL_lex_casestack[PL_lex_casemods] = '\0';
2130 PL_lex_state = LEX_INTERPCONCAT;
2131 PL_nextval[PL_nexttoke].ival = 0;
79072805
LW
2132 force_next('(');
2133 if (*s == 'l')
3280af22 2134 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
79072805 2135 else if (*s == 'u')
3280af22 2136 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
79072805 2137 else if (*s == 'L')
3280af22 2138 PL_nextval[PL_nexttoke].ival = OP_LC;
79072805 2139 else if (*s == 'U')
3280af22 2140 PL_nextval[PL_nexttoke].ival = OP_UC;
a0d0e21e 2141 else if (*s == 'Q')
3280af22 2142 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
79072805 2143 else
cea2e8a9 2144 Perl_croak(aTHX_ "panic: yylex");
3280af22 2145 PL_bufptr = s + 1;
79072805 2146 force_next(FUNC);
3280af22
NIS
2147 if (PL_lex_starts) {
2148 s = PL_bufptr;
2149 PL_lex_starts = 0;
79072805
LW
2150 Aop(OP_CONCAT);
2151 }
2152 else
cea2e8a9 2153 return yylex();
79072805
LW
2154 }
2155
55497cff
PP
2156 case LEX_INTERPPUSH:
2157 return sublex_push();
2158
79072805 2159 case LEX_INTERPSTART:
3280af22 2160 if (PL_bufptr == PL_bufend)
79072805 2161 return sublex_done();
3280af22
NIS
2162 PL_expect = XTERM;
2163 PL_lex_dojoin = (*PL_bufptr == '@');
2164 PL_lex_state = LEX_INTERPNORMAL;
2165 if (PL_lex_dojoin) {
2166 PL_nextval[PL_nexttoke].ival = 0;
79072805 2167 force_next(',');
554b3eca 2168#ifdef USE_THREADS
533c011a
NIS
2169 PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
2170 PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
554b3eca
MB
2171 force_next(PRIVATEREF);
2172#else
a0d0e21e 2173 force_ident("\"", '$');
554b3eca 2174#endif /* USE_THREADS */
3280af22 2175 PL_nextval[PL_nexttoke].ival = 0;
79072805 2176 force_next('$');
3280af22 2177 PL_nextval[PL_nexttoke].ival = 0;
79072805 2178 force_next('(');
3280af22 2179 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
79072805
LW
2180 force_next(FUNC);
2181 }
3280af22
NIS
2182 if (PL_lex_starts++) {
2183 s = PL_bufptr;
79072805
LW
2184 Aop(OP_CONCAT);
2185 }
cea2e8a9 2186 return yylex();
79072805
LW
2187
2188 case LEX_INTERPENDMAYBE:
3280af22
NIS
2189 if (intuit_more(PL_bufptr)) {
2190 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
79072805
LW
2191 break;
2192 }
2193 /* FALL THROUGH */
2194
2195 case LEX_INTERPEND:
3280af22
NIS
2196 if (PL_lex_dojoin) {
2197 PL_lex_dojoin = FALSE;
2198 PL_lex_state = LEX_INTERPCONCAT;
79072805
LW
2199 return ')';
2200 }
43a16006 2201 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
25da4f38 2202 && SvEVALED(PL_lex_repl))
43a16006 2203 {
e9fa98b2 2204 if (PL_bufptr != PL_bufend)
cea2e8a9 2205 Perl_croak(aTHX_ "Bad evalled substitution pattern");
e9fa98b2
HS
2206 PL_lex_repl = Nullsv;
2207 }
79072805
LW
2208 /* FALLTHROUGH */
2209 case LEX_INTERPCONCAT:
2210#ifdef DEBUGGING
3280af22 2211 if (PL_lex_brackets)
cea2e8a9 2212 Perl_croak(aTHX_ "panic: INTERPCONCAT");
79072805 2213#endif
3280af22 2214 if (PL_bufptr == PL_bufend)
79072805
LW
2215 return sublex_done();
2216
3280af22
NIS
2217 if (SvIVX(PL_linestr) == '\'') {
2218 SV *sv = newSVsv(PL_linestr);
2219 if (!PL_lex_inpat)
76e3520e 2220 sv = tokeq(sv);
3280af22 2221 else if ( PL_hints & HINT_NEW_RE )
b3ac6de7 2222 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
79072805 2223 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3280af22 2224 s = PL_bufend;
79072805
LW
2225 }
2226 else {
3280af22 2227 s = scan_const(PL_bufptr);
79072805 2228 if (*s == '\\')
3280af22 2229 PL_lex_state = LEX_INTERPCASEMOD;
79072805 2230 else
3280af22 2231 PL_lex_state = LEX_INTERPSTART;
79072805
LW
2232 }
2233
3280af22
NIS
2234 if (s != PL_bufptr) {
2235 PL_nextval[PL_nexttoke] = yylval;
2236 PL_expect = XTERM;
79072805 2237 force_next(THING);
3280af22 2238 if (PL_lex_starts++)
79072805
LW
2239 Aop(OP_CONCAT);
2240 else {
3280af22 2241 PL_bufptr = s;
cea2e8a9 2242 return yylex();
79072805
LW
2243 }
2244 }
2245
cea2e8a9 2246 return yylex();
a0d0e21e 2247 case LEX_FORMLINE:
3280af22
NIS
2248 PL_lex_state = LEX_NORMAL;
2249 s = scan_formline(PL_bufptr);
2250 if (!PL_lex_formbrack)
a0d0e21e
LW
2251 goto rightbracket;
2252 OPERATOR(';');
79072805
LW
2253 }
2254
3280af22
NIS
2255 s = PL_bufptr;
2256 PL_oldoldbufptr = PL_oldbufptr;
2257 PL_oldbufptr = s;
79072805 2258 DEBUG_p( {
bf49b057
GS
2259 PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at %s\n",
2260 exp_name[PL_expect], s);
79072805 2261 } )
463ee0b2
LW
2262
2263 retry:
378cc40b
LW
2264 switch (*s) {
2265 default:
834a4ddd
LW
2266 if (isIDFIRST_lazy(s))
2267 goto keylookup;
cea2e8a9 2268 Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
e929a76b
LW
2269 case 4:
2270 case 26:
2271 goto fake_eof; /* emulate EOF on ^D or ^Z */
378cc40b 2272 case 0:
3280af22
NIS
2273 if (!PL_rsfp) {
2274 PL_last_uni = 0;
2275 PL_last_lop = 0;
2276 if (PL_lex_brackets)
d98d5fff 2277 yyerror("Missing right curly or square bracket");
79072805 2278 TOKEN(0);
463ee0b2 2279 }
3280af22 2280 if (s++ < PL_bufend)
a687059c 2281 goto retry; /* ignore stray nulls */
3280af22
NIS
2282 PL_last_uni = 0;
2283 PL_last_lop = 0;
2284 if (!PL_in_eval && !PL_preambled) {
2285 PL_preambled = TRUE;
2286 sv_setpv(PL_linestr,incl_perldb());
2287 if (SvCUR(PL_linestr))
2288 sv_catpv(PL_linestr,";");
2289 if (PL_preambleav){
2290 while(AvFILLp(PL_preambleav) >= 0) {
2291 SV *tmpsv = av_shift(PL_preambleav);
2292 sv_catsv(PL_linestr, tmpsv);
2293 sv_catpv(PL_linestr, ";");
91b7def8
PP
2294 sv_free(tmpsv);
2295 }
3280af22
NIS
2296 sv_free((SV*)PL_preambleav);
2297 PL_preambleav = NULL;
91b7def8 2298 }
3280af22
NIS
2299 if (PL_minus_n || PL_minus_p) {
2300 sv_catpv(PL_linestr, "LINE: while (<>) {");
2301 if (PL_minus_l)
2302 sv_catpv(PL_linestr,"chomp;");
2303 if (PL_minus_a) {
8fd239a7
CS
2304 GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
2305 if (gv)
2306 GvIMPORTED_AV_on(gv);
3280af22
NIS
2307 if (PL_minus_F) {
2308 if (strchr("/'\"", *PL_splitstr)
2309 && strchr(PL_splitstr + 1, *PL_splitstr))
cea2e8a9 2310 Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s);", PL_splitstr);
54310121
PP
2311 else {
2312 char delim;
2313 s = "'~#\200\1'"; /* surely one char is unused...*/
3280af22 2314 while (s[1] && strchr(PL_splitstr, *s)) s++;
54310121 2315 delim = *s;
cea2e8a9 2316 Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s%c",
46fc3d4c 2317 "q" + (delim == '\''), delim);
3280af22 2318 for (s = PL_splitstr; *s; s++) {
54310121 2319 if (*s == '\\')
3280af22
NIS
2320 sv_catpvn(PL_linestr, "\\", 1);
2321 sv_catpvn(PL_linestr, s, 1);
54310121 2322 }
cea2e8a9 2323 Perl_sv_catpvf(aTHX_ PL_linestr, "%c);", delim);
54310121 2324 }
2304df62
AD
2325 }
2326 else
3280af22 2327 sv_catpv(PL_linestr,"@F=split(' ');");
2304df62 2328 }
79072805 2329 }
3280af22
NIS
2330 sv_catpv(PL_linestr, "\n");
2331 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2332 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2333 if (PERLDB_LINE && PL_curstash != PL_debstash) {
a0d0e21e
LW
2334 SV *sv = NEWSV(85,0);
2335
2336 sv_upgrade(sv, SVt_PVMG);
3280af22 2337 sv_setsv(sv,PL_linestr);
57843af0 2338 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
a0d0e21e 2339 }
79072805 2340 goto retry;
a687059c 2341 }
e929a76b 2342 do {
3280af22 2343 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
e929a76b 2344 fake_eof:
3280af22
NIS
2345 if (PL_rsfp) {
2346 if (PL_preprocess && !PL_in_eval)
2347 (void)PerlProc_pclose(PL_rsfp);
2348 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2349 PerlIO_clearerr(PL_rsfp);
395c3793 2350 else
3280af22
NIS
2351 (void)PerlIO_close(PL_rsfp);
2352 PL_rsfp = Nullfp;
4a9ae47a 2353 PL_doextract = FALSE;
395c3793 2354 }
3280af22
NIS
2355 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2356 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
2357 sv_catpv(PL_linestr,";}");
2358 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2359 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2360 PL_minus_n = PL_minus_p = 0;
e929a76b
LW
2361 goto retry;
2362 }
3280af22
NIS
2363 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2364 sv_setpv(PL_linestr,"");
79072805 2365 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
378cc40b 2366 }
3280af22 2367 if (PL_doextract) {
a0d0e21e 2368 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
3280af22 2369 PL_doextract = FALSE;
a0d0e21e
LW
2370
2371 /* Incest with pod. */
2372 if (*s == '=' && strnEQ(s, "=cut", 4)) {
3280af22
NIS
2373 sv_setpv(PL_linestr, "");
2374 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2375 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2376 PL_doextract = FALSE;
a0d0e21e
LW
2377 }
2378 }
463ee0b2 2379 incline(s);
3280af22
NIS
2380 } while (PL_doextract);
2381 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2382 if (PERLDB_LINE && PL_curstash != PL_debstash) {
79072805 2383 SV *sv = NEWSV(85,0);
a687059c 2384
93a17b20 2385 sv_upgrade(sv, SVt_PVMG);
3280af22 2386 sv_setsv(sv,PL_linestr);
57843af0 2387 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
a687059c 2388 }
3280af22 2389 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
57843af0 2390 if (CopLINE(PL_curcop) == 1) {
3280af22 2391 while (s < PL_bufend && isSPACE(*s))
79072805 2392 s++;
a0d0e21e 2393 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
79072805 2394 s++;
44a8e56a 2395 d = Nullch;
3280af22 2396 if (!PL_in_eval) {
44a8e56a
PP
2397 if (*s == '#' && *(s+1) == '!')
2398 d = s + 2;
2399#ifdef ALTERNATE_SHEBANG
2400 else {
2401 static char as[] = ALTERNATE_SHEBANG;
2402 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2403 d = s + (sizeof(as) - 1);
2404 }
2405#endif /* ALTERNATE_SHEBANG */
2406 }
2407 if (d) {
b8378b72 2408 char *ipath;
774d564b 2409 char *ipathend;
b8378b72 2410
774d564b 2411 while (isSPACE(*d))
b8378b72
CS
2412 d++;
2413 ipath = d;
774d564b
PP
2414 while (*d && !isSPACE(*d))
2415 d++;
2416 ipathend = d;
2417
2418#ifdef ARG_ZERO_IS_SCRIPT
2419 if (ipathend > ipath) {
2420 /*
2421 * HP-UX (at least) sets argv[0] to the script name,
2422 * which makes $^X incorrect. And Digital UNIX and Linux,
2423 * at least, set argv[0] to the basename of the Perl
2424 * interpreter. So, having found "#!", we'll set it right.
2425 */
2426 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
2427 assert(SvPOK(x) || SvGMAGICAL(x));
cc49e20b 2428 if (sv_eq(x, CopFILESV(PL_curcop))) {
774d564b 2429 sv_setpvn(x, ipath, ipathend - ipath);
9607fc9c
PP
2430 SvSETMAGIC(x);
2431 }
774d564b 2432 TAINT_NOT; /* $^X is always tainted, but that's OK */
8ebc5c01 2433 }
774d564b 2434#endif /* ARG_ZERO_IS_SCRIPT */
b8378b72
CS
2435
2436 /*
2437 * Look for options.
2438 */
748a9306 2439 d = instr(s,"perl -");
84e30d1a 2440 if (!d) {
748a9306 2441 d = instr(s,"perl");
84e30d1a
GS
2442#if defined(DOSISH)
2443 /* avoid getting into infinite loops when shebang
2444 * line contains "Perl" rather than "perl" */
2445 if (!d) {
2446 for (d = ipathend-4; d >= ipath; --d) {
2447 if ((*d == 'p' || *d == 'P')
2448 && !ibcmp(d, "perl", 4))
2449 {
2450 break;
2451 }
2452 }
2453 if (d < ipath)
2454 d = Nullch;
2455 }
2456#endif
2457 }
44a8e56a
PP
2458#ifdef ALTERNATE_SHEBANG
2459 /*
2460 * If the ALTERNATE_SHEBANG on this system starts with a
2461 * character that can be part of a Perl expression, then if
2462 * we see it but not "perl", we're probably looking at the
2463 * start of Perl code, not a request to hand off to some
2464 * other interpreter. Similarly, if "perl" is there, but
2465 * not in the first 'word' of the line, we assume the line
2466 * contains the start of the Perl program.
44a8e56a
PP
2467 */
2468 if (d && *s != '#') {
774d564b 2469 char *c = ipath;
44a8e56a
PP
2470 while (*c && !strchr("; \t\r\n\f\v#", *c))
2471 c++;
2472 if (c < d)
2473 d = Nullch; /* "perl" not in first word; ignore */
2474 else
2475 *s = '#'; /* Don't try to parse shebang line */
2476 }
774d564b 2477#endif /* ALTERNATE_SHEBANG */
748a9306 2478 if (!d &&
44a8e56a 2479 *s == '#' &&
774d564b 2480 ipathend > ipath &&
3280af22 2481 !PL_minus_c &&
748a9306 2482 !instr(s,"indir") &&
3280af22 2483 instr(PL_origargv[0],"perl"))
748a9306 2484 {
9f68db38 2485 char **newargv;
9f68db38 2486
774d564b
PP
2487 *ipathend = '\0';
2488 s = ipathend + 1;
3280af22 2489 while (s < PL_bufend && isSPACE(*s))
9f68db38 2490 s++;
3280af22
NIS
2491 if (s < PL_bufend) {
2492 Newz(899,newargv,PL_origargc+3,char*);
9f68db38 2493 newargv[1] = s;
3280af22 2494 while (s < PL_bufend && !isSPACE(*s))
9f68db38
LW
2495 s++;
2496 *s = '\0';
3280af22 2497 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
9f68db38
LW
2498 }
2499 else
3280af22 2500 newargv = PL_origargv;
774d564b 2501 newargv[0] = ipath;
80252599 2502 PerlProc_execv(ipath, newargv);
cea2e8a9 2503 Perl_croak(aTHX_ "Can't exec %s", ipath);
9f68db38 2504 }
748a9306 2505 if (d) {
3280af22
NIS
2506 U32 oldpdb = PL_perldb;
2507 bool oldn = PL_minus_n;
2508 bool oldp = PL_minus_p;
748a9306
LW
2509
2510 while (*d && !isSPACE(*d)) d++;
89bfa8cd 2511 while (*d == ' ' || *d == '\t') d++;
748a9306
LW
2512
2513 if (*d++ == '-') {
8cc95fdb
PP
2514 do {
2515 if (*d == 'M' || *d == 'm') {
2516 char *m = d;
2517 while (*d && !isSPACE(*d)) d++;
cea2e8a9 2518 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
8cc95fdb
PP
2519 (int)(d - m), m);
2520 }
2521 d = moreswitches(d);
2522 } while (d);
84902520 2523 if (PERLDB_LINE && !oldpdb ||
3280af22 2524 ( PL_minus_n || PL_minus_p ) && !(oldn || oldp) )
b084f20b
PP
2525 /* if we have already added "LINE: while (<>) {",
2526 we must not do it again */
748a9306 2527 {
3280af22
NIS
2528 sv_setpv(PL_linestr, "");
2529 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2530 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2531 PL_preambled = FALSE;
84902520 2532 if (PERLDB_LINE)
3280af22 2533 (void)gv_fetchfile(PL_origfilename);
748a9306
LW
2534 goto retry;
2535 }
a0d0e21e 2536 }
79072805 2537 }
9f68db38 2538 }
79072805 2539 }
3280af22
NIS
2540 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2541 PL_bufptr = s;
2542 PL_lex_state = LEX_FORMLINE;
cea2e8a9 2543 return yylex();
ae986130 2544 }
378cc40b 2545 goto retry;
4fdae800 2546 case '\r':
6a27c188 2547#ifdef PERL_STRICT_CR
cea2e8a9
GS
2548 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2549 Perl_croak(aTHX_
54310121 2550 "(Maybe you didn't strip carriage returns after a network transfer?)\n");
a868473f 2551#endif
4fdae800 2552 case ' ': case '\t': case '\f': case 013:
378cc40b
LW
2553 s++;
2554 goto retry;
378cc40b 2555 case '#':
e929a76b 2556 case '\n':
3280af22
NIS
2557 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2558 d = PL_bufend;
a687059c 2559 while (s < d && *s != '\n')
378cc40b 2560 s++;
0f85fab0 2561 if (s < d)
378cc40b 2562 s++;
463ee0b2 2563 incline(s);
3280af22
NIS
2564 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2565 PL_bufptr = s;
2566 PL_lex_state = LEX_FORMLINE;
cea2e8a9 2567 return yylex();
a687059c 2568 }
378cc40b 2569 }
a687059c 2570 else {
378cc40b 2571 *s = '\0';
3280af22 2572 PL_bufend = s;
a687059c 2573 }
378cc40b
LW
2574 goto retry;
2575 case '-':
79072805 2576 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
378cc40b 2577 s++;
3280af22 2578 PL_bufptr = s;
748a9306
LW
2579 tmp = *s++;
2580
3280af22 2581 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
748a9306
LW
2582 s++;
2583
2584 if (strnEQ(s,"=>",2)) {
3280af22 2585 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
748a9306
LW
2586 OPERATOR('-'); /* unary minus */
2587 }
3280af22
NIS
2588 PL_last_uni = PL_oldbufptr;
2589 PL_last_lop_op = OP_FTEREAD; /* good enough */
748a9306 2590 switch (tmp) {
79072805
LW
2591 case 'r': FTST(OP_FTEREAD);
2592 case 'w': FTST(OP_FTEWRITE);
2593 case 'x': FTST(OP_FTEEXEC);
2594 case 'o': FTST(OP_FTEOWNED);
2595 case 'R': FTST(OP_FTRREAD);
2596 case 'W': FTST(OP_FTRWRITE);
2597 case 'X': FTST(OP_FTREXEC);
2598 case 'O': FTST(OP_FTROWNED);
2599 case 'e': FTST(OP_FTIS);
2600 case 'z': FTST(OP_FTZERO);
2601 case 's': FTST(OP_FTSIZE);
2602 case 'f': FTST(OP_FTFILE);
2603 case 'd': FTST(OP_FTDIR);
2604 case 'l': FTST(OP_FTLINK);
2605 case 'p': FTST(OP_FTPIPE);
2606 case 'S': FTST(OP_FTSOCK);
2607 case 'u': FTST(OP_FTSUID);
2608 case 'g': FTST(OP_FTSGID);
2609 case 'k': FTST(OP_FTSVTX);
2610 case 'b': FTST(OP_FTBLK);
2611 case 'c': FTST(OP_FTCHR);
2612 case 't': FTST(OP_FTTTY);
2613 case 'T': FTST(OP_FTTEXT);
2614 case 'B': FTST(OP_FTBINARY);
85e6fe83
LW
2615 case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2616 case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2617 case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
378cc40b 2618 default:
cea2e8a9 2619 Perl_croak(aTHX_ "Unrecognized file test: -%c", (int)tmp);
378cc40b
LW
2620 break;
2621 }
2622 }
a687059c
LW
2623 tmp = *s++;
2624 if (*s == tmp) {
2625 s++;
3280af22 2626 if (PL_expect == XOPERATOR)
79072805
LW
2627 TERM(POSTDEC);
2628 else
2629 OPERATOR(PREDEC);
2630 }
2631 else if (*s == '>') {
2632 s++;
2633 s = skipspace(s);
834a4ddd 2634 if (isIDFIRST_lazy(s)) {
a0d0e21e 2635 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
463ee0b2 2636 TOKEN(ARROW);
79072805 2637 }
748a9306
LW
2638 else if (*s == '$')
2639 OPERATOR(ARROW);
463ee0b2 2640 else
748a9306 2641 TERM(ARROW);
a687059c 2642 }
3280af22 2643 if (PL_expect == XOPERATOR)
79072805
LW
2644 Aop(OP_SUBTRACT);
2645 else {
3280af22 2646 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2f3197b3 2647 check_uni();
79072805 2648 OPERATOR('-'); /* unary minus */
2f3197b3 2649 }
79072805 2650
378cc40b 2651 case '+':
a687059c
LW
2652 tmp = *s++;
2653 if (*s == tmp) {
378cc40b 2654 s++;
3280af22 2655 if (PL_expect == XOPERATOR)
79072805
LW
2656 TERM(POSTINC);
2657 else
2658 OPERATOR(PREINC);
378cc40b 2659 }
3280af22 2660 if (PL_expect == XOPERATOR)
79072805
LW
2661 Aop(OP_ADD);
2662 else {
3280af22 2663 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2f3197b3 2664 check_uni();
a687059c 2665 OPERATOR('+');
2f3197b3 2666 }
a687059c 2667
378cc40b 2668 case '*':
3280af22
NIS
2669 if (PL_expect != XOPERATOR) {
2670 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2671 PL_expect = XOPERATOR;
2672 force_ident(PL_tokenbuf, '*');
2673 if (!*PL_tokenbuf)
a0d0e21e 2674 PREREF('*');
79072805 2675 TERM('*');
a687059c 2676 }
79072805
LW
2677 s++;
2678 if (*s == '*') {
a687059c 2679 s++;
79072805 2680 PWop(OP_POW);
a687059c 2681 }
79072805
LW
2682 Mop(OP_MULTIPLY);
2683
378cc40b 2684 case '%':
3280af22 2685 if (PL_expect == XOPERATOR) {
bbce6d69
PP
2686 ++s;
2687 Mop(OP_MODULO);
a687059c 2688 }
3280af22
NIS
2689 PL_tokenbuf[0] = '%';
2690 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2691 if (!PL_tokenbuf[1]) {
2692 if (s == PL_bufend)
bbce6d69
PP
2693 yyerror("Final % should be \\% or %name");
2694 PREREF('%');
a687059c 2695 }
3280af22 2696 PL_pending_ident = '%';
bbce6d69 2697 TERM('%');
a687059c 2698
378cc40b 2699 case '^':
79072805 2700 s++;
a0d0e21e 2701 BOop(OP_BIT_XOR);
79072805 2702 case '[':
3280af22 2703 PL_lex_brackets++;
79072805 2704 /* FALL THROUGH */
378cc40b 2705 case '~':
378cc40b 2706 case ',':
378cc40b
LW
2707 tmp = *s++;
2708 OPERATOR(tmp);
a0d0e21e
LW
2709 case ':':
2710 if (s[1] == ':') {
2711 len = 0;
2712 goto just_a_word;
2713 }
2714 s++;
09bef843
SB
2715 switch (PL_expect) {
2716 OP *attrs;
2717 case XOPERATOR:
2718 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
2719 break;
2720 PL_bufptr = s; /* update in case we back off */
2721 goto grabattrs;
2722 case XATTRBLOCK:
2723 PL_expect = XBLOCK;
2724 goto grabattrs;
2725 case XATTRTERM:
2726 PL_expect = XTERMBLOCK;
2727 grabattrs:
2728 s = skipspace(s);
2729 attrs = Nullop;
2730 while (isIDFIRST_lazy(s)) {
2731 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2732 if (*d == '(') {
2733 d = scan_str(d,TRUE,TRUE);
2734 if (!d) {
2735 if (PL_lex_stuff) {
2736 SvREFCNT_dec(PL_lex_stuff);
2737 PL_lex_stuff = Nullsv;
2738 }
2739 /* MUST advance bufptr here to avoid bogus
2740 "at end of line" context messages from yyerror().
2741 */
2742 PL_bufptr = s + len;
2743 yyerror("Unterminated attribute parameter in attribute list");
2744 if (attrs)
2745 op_free(attrs);
2746 return 0; /* EOF indicator */
2747 }
2748 }
2749 if (PL_lex_stuff) {
2750 SV *sv = newSVpvn(s, len);
2751 sv_catsv(sv, PL_lex_stuff);
2752 attrs = append_elem(OP_LIST, attrs,
2753 newSVOP(OP_CONST, 0, sv));
2754 SvREFCNT_dec(PL_lex_stuff);
2755 PL_lex_stuff = Nullsv;
2756 }
2757 else {
2758 attrs = append_elem(OP_LIST, attrs,
2759 newSVOP(OP_CONST, 0,
2760 newSVpvn(s, len)));
2761 }
2762 s = skipspace(d);
2763 while (*s == ',')
2764 s = skipspace(s+1);
2765 }
2766 tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}' for vi */
2767 if (*s != ';' && *s != tmp) {
2768 char q = ((*s == '\'') ? '"' : '\'');
2769 /* If here for an expression, and parsed no attrs, back off. */
2770 if (tmp == '=' && !attrs) {
2771 s = PL_bufptr;
2772 break;
2773 }
2774 /* MUST advance bufptr here to avoid bogus "at end of line"
2775 context messages from yyerror().
2776 */
2777 PL_bufptr = s;
2778 if (!*s)
2779 yyerror("Unterminated attribute list");
2780 else
2781 yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list",
2782 q, *s, q));
2783 if (attrs)
2784 op_free(attrs);
2785 OPERATOR(':');
2786 }
2787 if (attrs) {
2788 PL_nextval[PL_nexttoke].opval = attrs;
2789 force_next(THING);
2790 }
2791 TOKEN(COLONATTR);
2792 }
a0d0e21e 2793 OPERATOR(':');
8990e307
LW
2794 case '(':
2795 s++;
3280af22
NIS
2796 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
2797 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
a0d0e21e 2798 else
3280af22 2799 PL_expect = XTERM;
a0d0e21e 2800 TOKEN('(');
378cc40b 2801 case ';':
57843af0
GS
2802 if (CopLINE(PL_curcop) < PL_copline)
2803 PL_copline = CopLINE(PL_curcop);
378cc40b
LW
2804 tmp = *s++;
2805 OPERATOR(tmp);
2806 case ')':
378cc40b 2807 tmp = *s++;
16d20bd9
AD
2808 s = skipspace(s);
2809 if (*s == '{')
2810 PREBLOCK(tmp);
378cc40b 2811 TERM(tmp);
79072805
LW
2812 case ']':
2813 s++;
3280af22 2814 if (PL_lex_brackets <= 0)
d98d5fff 2815 yyerror("Unmatched right square bracket");
463ee0b2 2816 else
3280af22
NIS
2817 --PL_lex_brackets;
2818 if (PL_lex_state == LEX_INTERPNORMAL) {
2819 if (PL_lex_brackets == 0) {
a0d0e21e 2820 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
3280af22 2821 PL_lex_state = LEX_INTERPEND;
79072805
LW
2822 }
2823 }
4633a7c4 2824 TERM(']');
79072805
LW
2825 case '{':
2826 leftbracket:
79072805 2827 s++;
3280af22
NIS
2828 if (PL_lex_brackets > 100) {
2829 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
2830 if (newlb != PL_lex_brackstack) {
8990e307 2831 SAVEFREEPV(newlb);
3280af22 2832 PL_lex_brackstack = newlb;
8990e307
LW
2833 }
2834 }
3280af22 2835 switch (PL_expect) {
a0d0e21e 2836 case XTERM:
3280af22 2837 if (PL_lex_formbrack) {
a0d0e21e
LW
2838 s--;
2839 PRETERMBLOCK(DO);
2840 }
3280af22
NIS
2841 if (PL_oldoldbufptr == PL_last_lop)
2842 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
a0d0e21e 2843 else
3280af22 2844 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
79072805 2845 OPERATOR(HASHBRACK);
a0d0e21e 2846 case XOPERATOR:
3280af22 2847 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
748a9306 2848 s++;
44a8e56a 2849 d = s;
3280af22
NIS
2850 PL_tokenbuf[0] = '\0';
2851 if (d < PL_bufend && *d == '-') {
2852 PL_tokenbuf[0] = '-';
44a8e56a 2853 d++;
3280af22 2854 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
44a8e56a
PP
2855 d++;
2856 }
834a4ddd 2857 if (d < PL_bufend && isIDFIRST_lazy(d)) {
3280af22 2858 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
8903cb82 2859 FALSE, &len);
3280af22 2860 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
748a9306
LW
2861 d++;
2862 if (*d == '}') {
3280af22 2863 char minus = (PL_tokenbuf[0] == '-');
44a8e56a
PP
2864 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2865 if (minus)
2866 force_next('-');
748a9306
LW
2867 }
2868 }
2869 /* FALL THROUGH */
09bef843 2870 case XATTRBLOCK:
748a9306 2871 case XBLOCK:
3280af22
NIS
2872 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
2873 PL_expect = XSTATE;
a0d0e21e 2874 break;
09bef843 2875 case XATTRTERM:
a0d0e21e 2876 case XTERMBLOCK:
3280af22
NIS
2877 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2878 PL_expect = XSTATE;
a0d0e21e
LW
2879 break;
2880 default: {
2881 char *t;
3280af22
NIS
2882 if (PL_oldoldbufptr == PL_last_lop)
2883 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
a0d0e21e 2884 else
3280af22 2885 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
a0d0e21e 2886 s = skipspace(s);
09ecc4b6 2887 if (*s == '}')
a0d0e21e 2888 OPERATOR(HASHBRACK);
b8a4b1be
GS
2889 /* This hack serves to disambiguate a pair of curlies
2890 * as being a block or an anon hash. Normally, expectation
2891 * determines that, but in cases where we're not in a
2892 * position to expect anything in particular (like inside
2893 * eval"") we have to resolve the ambiguity. This code
2894 * covers the case where the first term in the curlies is a
2895 * quoted string. Most other cases need to be explicitly
2896 * disambiguated by prepending a `+' before the opening
2897 * curly in order to force resolution as an anon hash.
2898 *
2899 * XXX should probably propagate the outer expectation
2900 * into eval"" to rely less on this hack, but that could
2901 * potentially break current behavior of eval"".
2902 * GSAR 97-07-21
2903 */
2904 t = s;
2905 if (*s == '\'' || *s == '"' || *s == '`') {
2906 /* common case: get past first string, handling escapes */
3280af22 2907 for (t++; t < PL_bufend && *t != *s;)
b8a4b1be
GS
2908 if (*t++ == '\\' && (*t == '\\' || *t == *s))
2909 t++;
2910 t++;
a0d0e21e 2911 }
b8a4b1be 2912 else if (*s == 'q') {
3280af22 2913 if (++t < PL_bufend
b8a4b1be 2914 && (!isALNUM(*t)
3280af22 2915 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
b8a4b1be
GS
2916 && !isALNUM(*t)))) {
2917 char *tmps;
2918 char open, close, term;
2919 I32 brackets = 1;
2920
3280af22 2921 while (t < PL_bufend && isSPACE(*t))
b8a4b1be
GS
2922 t++;
2923 term = *t;
2924 open = term;
2925 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
2926 term = tmps[5];
2927 close = term;
2928 if (open == close)
3280af22
NIS
2929 for (t++; t < PL_bufend; t++) {
2930 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
b8a4b1be 2931 t++;
6d07e5e9 2932 else if (*t == open)
b8a4b1be
GS
2933 break;
2934 }
2935 else
3280af22
NIS
2936 for (t++; t < PL_bufend; t++) {
2937 if (*t == '\\' && t+1 < PL_bufend)
b8a4b1be 2938 t++;
6d07e5e9 2939 else if (*t == close && --brackets <= 0)
b8a4b1be
GS
2940 break;
2941 else if (*t == open)
2942 brackets++;
2943 }
2944 }
2945 t++;
a0d0e21e 2946 }
834a4ddd
LW
2947 else if (isIDFIRST_lazy(s)) {
2948 for (t++; t < PL_bufend && isALNUM_lazy(t); t++) ;
a0d0e21e 2949 }
3280af22 2950 while (t < PL_bufend && isSPACE(*t))
a0d0e21e 2951 t++;
b8a4b1be
GS
2952 /* if comma follows first term, call it an anon hash */
2953 /* XXX it could be a comma expression with loop modifiers */
3280af22 2954 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
b8a4b1be 2955 || (*t == '=' && t[1] == '>')))
a0d0e21e 2956 OPERATOR(HASHBRACK);
3280af22 2957 if (PL_expect == XREF)
4e4e412b 2958 PL_expect = XTERM;
a0d0e21e 2959 else {
3280af22
NIS
2960 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
2961 PL_expect = XSTATE;
a0d0e21e 2962 }
8990e307 2963 }
a0d0e21e 2964 break;
463ee0b2 2965 }
57843af0 2966 yylval.ival = CopLINE(PL_curcop);
79072805 2967 if (isSPACE(*s) || *s == '#')
3280af22 2968 PL_copline = NOLINE; /* invalidate current command line number */
79072805 2969 TOKEN('{');
378cc40b 2970 case '}':
79072805
LW
2971 rightbracket:
2972 s++;
3280af22 2973 if (PL_lex_brackets <= 0)
d98d5fff 2974 yyerror("Unmatched right curly bracket");
463ee0b2 2975 else
3280af22
NIS
2976 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
2977 if (PL_lex_brackets < PL_lex_formbrack)
2978 PL_lex_formbrack = 0;
2979 if (PL_lex_state == LEX_INTERPNORMAL) {
2980 if (PL_lex_brackets == 0) {
2981 if (PL_lex_fakebrack) {
2982 PL_lex_state = LEX_INTERPEND;
2983 PL_bufptr = s;
cea2e8a9 2984 return yylex(); /* ignore fake brackets */
79072805 2985 }
fa83b5b6 2986 if (*s == '-' && s[1] == '>')
3280af22 2987 PL_lex_state = LEX_INTERPENDMAYBE;
fa83b5b6 2988 else if (*s != '[' && *s != '{')
3280af22 2989 PL_lex_state = LEX_INTERPEND;
79072805
LW
2990 }
2991 }
3280af22
NIS
2992 if (PL_lex_brackets < PL_lex_fakebrack) {
2993 PL_bufptr = s;
2994 PL_lex_fakebrack = 0;
cea2e8a9 2995 return yylex(); /* ignore fake brackets */
748a9306 2996 }
79072805
LW
2997 force_next('}');
2998 TOKEN(';');
378cc40b
LW
2999 case '&':
3000 s++;
3001 tmp = *s++;
3002 if (tmp == '&')
a0d0e21e 3003 AOPERATOR(ANDAND);
378cc40b 3004 s--;
3280af22 3005 if (PL_expect == XOPERATOR) {
834a4ddd 3006 if (ckWARN(WARN_SEMICOLON) && isIDFIRST_lazy(s) && PL_bufptr == PL_linestart) {
57843af0 3007 CopLINE_dec(PL_curcop);
cea2e8a9 3008 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
57843af0 3009 CopLINE_inc(PL_curcop);
463ee0b2 3010 }
79072805 3011 BAop(OP_BIT_AND);
463ee0b2 3012 }
79072805 3013
3280af22
NIS
3014 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3015 if (*PL_tokenbuf) {
3016 PL_expect = XOPERATOR;
3017 force_ident(PL_tokenbuf, '&');
463ee0b2 3018 }
79072805
LW
3019 else
3020 PREREF('&');
c07a80fd 3021 yylval.ival = (OPpENTERSUB_AMPER<<8);
79072805
LW
3022 TERM('&');
3023
378cc40b
LW
3024 case '|':
3025 s++;
3026 tmp = *s++;
3027 if (tmp == '|')
a0d0e21e 3028 AOPERATOR(OROR);
378cc40b 3029 s--;
79072805 3030 BOop(OP_BIT_OR);
378cc40b
LW
3031 case '=':
3032 s++;
3033 tmp = *s++;
3034 if (tmp == '=')
79072805
LW
3035 Eop(OP_EQ);
3036 if (tmp == '>')
3037 OPERATOR(',');
378cc40b 3038 if (tmp == '~')
79072805 3039 PMop(OP_MATCH);
599cee73 3040 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
cea2e8a9 3041 Perl_warner(aTHX_ WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
378cc40b 3042 s--;
3280af22
NIS
3043 if (PL_expect == XSTATE && isALPHA(tmp) &&
3044 (s == PL_linestart+1 || s[-2] == '\n') )
748a9306 3045 {
3280af22
NIS
3046 if (PL_in_eval && !PL_rsfp) {
3047 d = PL_bufend;
a5f75d66
AD
3048 while (s < d) {
3049 if (*s++ == '\n') {
3050 incline(s);
3051 if (strnEQ(s,"=cut",4)) {
3052 s = strchr(s,'\n');
3053 if (s)
3054 s++;
3055 else
3056 s = d;
3057 incline(s);
3058 goto retry;
3059 }
3060 }
3061 }
3062 goto retry;
3063 }
3280af22
NIS
3064 s = PL_bufend;
3065 PL_doextract = TRUE;
a0d0e21e
LW
3066 goto retry;
3067 }
3280af22 3068 if (PL_lex_brackets < PL_lex_formbrack) {
a0d0e21e 3069 char *t;
51882d45 3070#ifdef PERL_STRICT_CR
a0d0e21e 3071 for (t = s; *t == ' ' || *t == '\t'; t++) ;
51882d45
GS
3072#else
3073 for (t = s; *t == ' ' || *t == '\t' || *t == '\r'; t++) ;
3074#endif
a0d0e21e
LW
3075 if (*t == '\n' || *t == '#') {
3076 s--;
3280af22 3077 PL_expect = XBLOCK;
a0d0e21e
LW
3078 goto leftbracket;
3079 }
79072805 3080 }
a0d0e21e
LW
3081 yylval.ival = 0;
3082 OPERATOR(ASSIGNOP);
378cc40b
LW
3083 case '!':
3084 s++;
3085 tmp = *s++;
3086 if (tmp == '=')
79072805 3087 Eop(OP_NE);
378cc40b 3088 if (tmp == '~')
79072805 3089 PMop(OP_NOT);
378cc40b
LW
3090 s--;
3091 OPERATOR('!');
3092 case '<':
3280af22 3093 if (PL_expect != XOPERATOR) {
93a17b20 3094 if (s[1] != '<' && !strchr(s,'>'))
2f3197b3 3095 check_uni();
79072805
LW
3096 if (s[1] == '<')
3097 s = scan_heredoc(s);
3098 else
3099 s = scan_inputsymbol(s);
3100 TERM(sublex_start());
378cc40b
LW
3101 }
3102 s++;
3103 tmp = *s++;
3104 if (tmp == '<')
79072805 3105 SHop(OP_LEFT_SHIFT);
395c3793
LW
3106 if (tmp == '=') {
3107 tmp = *s++;
3108 if (tmp == '>')
79072805 3109 Eop(OP_NCMP);
395c3793 3110 s--;
79072805 3111 Rop(OP_LE);
395c3793 3112 }
378cc40b 3113 s--;
79072805 3114 Rop(OP_LT);
378cc40b
LW
3115 case '>':
3116 s++;
3117 tmp = *s++;
3118 if (tmp == '>')
79072805 3119 SHop(OP_RIGHT_SHIFT);
378cc40b 3120 if (tmp == '=')
79072805 3121 Rop(OP_GE);
378cc40b 3122 s--;
79072805 3123 Rop(OP_GT);
378cc40b
LW
3124
3125 case '$':
bbce6d69
PP
3126 CLINE;
3127
3280af22
NIS
3128 if (PL_expect == XOPERATOR) {
3129 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3130 PL_expect = XTERM;
a0d0e21e 3131 depcom();
bbce6d69 3132 return ','; /* grandfather non-comma-format format */
a0d0e21e 3133 }
8990e307 3134 }
a0d0e21e 3135
834a4ddd 3136 if (s[1] == '#' && (isIDFIRST_lazy(s+2) || strchr("{$:+-", s[2]))) {
3280af22 3137 PL_tokenbuf[0] = '@';
376b8730
SM
3138 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3139 sizeof PL_tokenbuf - 1, FALSE);
3140 if (PL_expect == XOPERATOR)
3141 no_op("Array length", s);
3280af22 3142 if (!PL_tokenbuf[1])
a0d0e21e 3143 PREREF(DOLSHARP);
3280af22
NIS
3144 PL_expect = XOPERATOR;
3145 PL_pending_ident = '#';
463ee0b2 3146 TOKEN(DOLSHARP);
79072805 3147 }
bbce6d69 3148
3280af22 3149 PL_tokenbuf[0] = '$';
376b8730
SM
3150 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3151 sizeof PL_tokenbuf - 1, FALSE);
3152 if (PL_expect == XOPERATOR)
3153 no_op("Scalar", s);
3280af22
NIS
3154 if (!PL_tokenbuf[1]) {
3155 if (s == PL_bufend)
bbce6d69
PP
3156 yyerror("Final $ should be \\$ or $name");
3157 PREREF('$');
8990e307 3158 }
a0d0e21e 3159
bbce6d69 3160 /* This kludge not intended to be bulletproof. */
3280af22 3161 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
bbce6d69 3162 yylval.opval = newSVOP(OP_CONST, 0,
3280af22 3163 newSViv((IV)PL_compiling.cop_arybase));
bbce6d69
PP
3164 yylval.opval->op_private = OPpCONST_ARYBASE;
3165 TERM(THING);
3166 }
3167
ff68c719 3168 d = s;
69d2bceb 3169 tmp = (I32)*s;
3280af22 3170 if (PL_lex_state == LEX_NORMAL)
ff68c719
PP
3171 s = skipspace(s);
3172
3280af22 3173 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
bbce6d69
PP
3174 char *t;
3175 if (*s == '[') {
3280af22 3176 PL_tokenbuf[0] = '@';
599cee73 3177 if (ckWARN(WARN_SYNTAX)) {
bbce6d69 3178 for(t = s + 1;
834a4ddd 3179 isSPACE(*t) || isALNUM_lazy(t) || *t == '$';
bbce6d69 3180 t++) ;
a0d0e21e 3181 if (*t++ == ',') {
3280af22
NIS
3182 PL_bufptr = skipspace(PL_bufptr);
3183 while (t < PL_bufend && *t != ']')
bbce6d69 3184 t++;
cea2e8a9 3185 Perl_warner(aTHX_ WARN_SYNTAX,
599cee73
PM
3186 "Multidimensional syntax %.*s not supported",
3187 (t - PL_bufptr) + 1, PL_bufptr);
a0d0e21e
LW
3188 }
3189 }
bbce6d69
PP
3190 }
3191 else if (*s == '{') {
3280af22 3192 PL_tokenbuf[0] = '%';
599cee73 3193 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
bbce6d69
PP
3194 (t = strchr(s, '}')) && (t = strchr(t, '=')))
3195 {
3280af22 3196 char tmpbuf[sizeof PL_tokenbuf];
a0d0e21e
LW
3197 STRLEN len;
3198 for (t++; isSPACE(*t); t++) ;
834a4ddd 3199 if (isIDFIRST_lazy(t)) {
8903cb82 3200 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
59a6d928 3201 for (; isSPACE(*t); t++) ;
864dbfa3 3202 if (*t == ';' && get_cv(tmpbuf, FALSE))
cea2e8a9 3203 Perl_warner(aTHX_ WARN_SYNTAX,
599cee73 3204 "You need to quote \"%s\"", tmpbuf);
748a9306 3205 }
93a17b20
LW
3206 }
3207 }
2f3197b3 3208 }
bbce6d69 3209
3280af22 3210 PL_expect = XOPERATOR;
69d2bceb 3211 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3280af22
NIS
3212 bool islop = (PL_last_lop == PL_oldoldbufptr);
3213 if (!islop || PL_last_lop_op == OP_GREPSTART)
3214 PL_expect = XOPERATOR;
bbce6d69 3215 else if (strchr("$@\"'`q", *s))
3280af22 3216 PL_expect = XTERM; /* e.g. print $fh "foo" */
834a4ddd 3217 else if (strchr("&*<%", *s) && isIDFIRST_lazy(s+1))
3280af22 3218 PL_expect = XTERM; /* e.g. print $fh &sub */
834a4ddd 3219 else if (isIDFIRST_lazy(s)) {
3280af22 3220 char tmpbuf[sizeof PL_tokenbuf];
8903cb82 3221 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
84902520
TB
3222 if (tmp = keyword(tmpbuf, len)) {
3223 /* binary operators exclude handle interpretations */
3224 switch (tmp) {
3225 case -KEY_x:
3226 case -KEY_eq:
3227 case -KEY_ne:
3228 case -KEY_gt:
3229 case -KEY_lt:
3230 case -KEY_ge:
3231 case -KEY_le:
3232 case -KEY_cmp:
3233 break;
3234 default:
3280af22 3235 PL_expect = XTERM; /* e.g. print $fh length() */
84902520
TB
3236 break;
3237 }
3238 }
68dc0745
PP
3239 else {
3240 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
3241 if (gv && GvCVu(gv))
3280af22 3242 PL_expect = XTERM; /* e.g. print $fh subr() */
93a17b20 3243 }
93a17b20 3244 }
bbce6d69 3245 else if (isDIGIT(*s))
3280af22 3246 PL_expect = XTERM; /* e.g. print $fh 3 */
bbce6d69 3247 else if (*s == '.' && isDIGIT(s[1]))
3280af22 3248 PL_expect = XTERM; /* e.g. print $fh .3 */
e0587a03 3249 else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
3280af22 3250 PL_expect = XTERM; /* e.g. print $fh -1 */
e0587a03 3251 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3280af22 3252 PL_expect = XTERM; /* print $fh <<"EOF" */
bbce6d69 3253 }
3280af22 3254 PL_pending_ident = '$';
79072805 3255 TOKEN('$');
378cc40b
LW
3256
3257 case '@':
3280af22 3258 if (PL_expect == XOPERATOR)
bbce6d69 3259 no_op("Array", s);
3280af22
NIS
3260 PL_tokenbuf[0] = '@';
3261 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3262 if (!PL_tokenbuf[1]) {
3263 if (s == PL_bufend)
bbce6d69
PP
3264 yyerror("Final @ should be \\@ or @name");
3265 PREREF('@');
3266 }
3280af22 3267 if (PL_lex_state == LEX_NORMAL)
ff68c719 3268 s = skipspace(s);
3280af22 3269 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
bbce6d69 3270 if (*s == '{')
3280af22 3271 PL_tokenbuf[0] = '%';
a0d0e21e
LW
3272
3273 /* Warn about @ where they meant $. */
599cee73 3274 if (ckWARN(WARN_SYNTAX)) {
a0d0e21e
LW
3275 if (*s == '[' || *s == '{') {
3276 char *t = s + 1;
834a4ddd 3277 while (*t && (isALNUM_lazy(t) || strchr(" \t$#+-'\"", *t)))
a0d0e21e
LW
3278 t++;
3279 if (*t == '}' || *t == ']') {
3280 t++;
3280af22 3281 PL_bufptr = skipspace(PL_bufptr);
cea2e8a9 3282 Perl_warner(aTHX_ WARN_SYNTAX,
599cee73 3283 "Scalar value %.*s better written as $%.*s",
3280af22 3284 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
a0d0e21e 3285 }
93a17b20
LW
3286 }
3287 }
463ee0b2 3288 }
3280af22 3289 PL_pending_ident = '@';
79072805 3290 TERM('@');
378cc40b
LW
3291
3292 case '/': /* may either be division or pattern */
3293 case '?': /* may either be conditional or pattern */
3280af22 3294 if (PL_expect != XOPERATOR) {
c277df42 3295 /* Disable warning on "study /blah/" */
3280af22
NIS
3296 if (PL_oldoldbufptr == PL_last_uni
3297 && (*PL_last_uni != 's' || s - PL_last_uni < 5
834a4ddd 3298 || memNE(PL_last_uni, "study", 5) || isALNUM_lazy(PL_last_uni+5)))
c277df42 3299 check_uni();
8782bef2 3300 s = scan_pat(s,OP_MATCH);
79072805 3301 TERM(sublex_start());
378cc40b
LW
3302 }
3303 tmp = *s++;
a687059c 3304 if (tmp == '/')
79072805 3305 Mop(OP_DIVIDE);
378cc40b
LW
3306 OPERATOR(tmp);
3307
3308 case '.':
51882d45
GS
3309 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3310#ifdef PERL_STRICT_CR
3311 && s[1] == '\n'
3312#else
3313 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3314#endif
3315 && (s == PL_linestart || s[-1] == '\n') )
3316 {
3280af22
NIS
3317 PL_lex_formbrack = 0;
3318 PL_expect = XSTATE;
79072805
LW
3319 goto rightbracket;
3320 }
3280af22 3321 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
378cc40b 3322 tmp = *s++;
a687059c
LW
3323 if (*s == tmp) {
3324 s++;
2f3197b3
LW
3325 if (*s == tmp) {
3326 s++;
79072805 3327 yylval.ival = OPf_SPECIAL;
2f3197b3
LW
3328 }
3329 else
79072805 3330 yylval.ival = 0;
378cc40b 3331 OPERATOR(DOTDOT);
a687059c 3332 }
3280af22 3333 if (PL_expect != XOPERATOR)
2f3197b3 3334 check_uni();
79072805 3335 Aop(OP_CONCAT);
378cc40b
LW
3336 }
3337 /* FALL THROUGH */
3338 case '0': case '1': case '2': case '3': case '4':
3339 case '5': case '6': case '7': case '8': case '9':
79072805 3340 s = scan_num(s);
3280af22 3341 if (PL_expect == XOPERATOR)
8990e307 3342 no_op("Number",s);
79072805
LW
3343 TERM(THING);
3344
3345 case '\'':
09bef843 3346 s = scan_str(s,FALSE,FALSE);
3280af22
NIS
3347 if (PL_expect == XOPERATOR) {
3348 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3349 PL_expect = XTERM;
a0d0e21e
LW
3350 depcom();
3351 return ','; /* grandfather non-comma-format format */
3352 }
463ee0b2 3353 else
8990e307 3354 no_op("String",s);
463ee0b2 3355 }
79072805 3356 if (!s)
85e6fe83 3357 missingterm((char*)0);
79072805
LW
3358 yylval.ival = OP_CONST;
3359 TERM(sublex_start());
3360
3361 case '"':
09bef843 3362 s = scan_str(s,FALSE,FALSE);
3280af22
NIS
3363 if (PL_expect == XOPERATOR) {
3364 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3365 PL_expect = XTERM;
a0d0e21e
LW
3366 depcom();
3367 return ','; /* grandfather non-comma-format format */
3368 }
463ee0b2 3369 else
8990e307 3370 no_op("String",s);
463ee0b2 3371 }
79072805 3372 if (!s)
85e6fe83 3373 missingterm((char*)0);
4633a7c4 3374 yylval.ival = OP_CONST;
3280af22 3375 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
a0ed51b3 3376 if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
4633a7c4
LW
3377 yylval.ival = OP_STRINGIFY;
3378 break;
3379 }
3380 }
79072805
LW
3381 TERM(sublex_start());
3382
3383 case '`':
09bef843 3384 s = scan_str(s,FALSE,FALSE);
3280af22 3385 if (PL_expect == XOPERATOR)
8990e307 3386 no_op("Backticks",s);
79072805 3387 if (!s)
85e6fe83 3388 missingterm((char*)0);
79072805
LW
3389 yylval.ival = OP_BACKTICK;
3390 set_csh();
3391 TERM(sublex_start());
3392
3393 case '\\':
3394 s++;
599cee73 3395 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
cea2e8a9 3396 Perl_warner(aTHX_ WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
599cee73 3397 *s, *s);
3280af22 3398 if (PL_expect == XOPERATOR)
8990e307 3399 no_op("Backslash",s);
79072805
LW
3400 OPERATOR(REFGEN);
3401
3402 case 'x':
3280af22 3403 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
79072805
LW
3404 s++;
3405 Mop(OP_REPEAT);
2f3197b3 3406 }
79072805
LW
3407 goto keylookup;
3408
378cc40b 3409 case '_':
79072805
LW
3410 case 'a': case 'A':
3411 case 'b': case 'B':
3412 case 'c': case 'C':
3413 case 'd': case 'D':
3414 case 'e': case 'E':
3415 case 'f': case 'F':
3416 case 'g': case 'G':
3417 case 'h': case 'H':
3418 case 'i': case 'I':
3419 case 'j': case 'J':
3420 case 'k': case 'K':
3421 case 'l': case 'L':
3422 case 'm': case 'M':
3423 case 'n': case 'N':
3424 case 'o': case 'O':
3425 case 'p': case 'P':
3426 case 'q': case 'Q':
3427 case 'r': case 'R':
3428 case 's': case 'S':
3429 case 't': case 'T':
3430 case 'u': case 'U':
3431 case 'v': case 'V':
3432 case 'w': case 'W':
3433 case 'X':
3434 case 'y': case 'Y':
3435 case 'z': case 'Z':
3436
49dc05e3 3437 keylookup: {
2d8e6c8d 3438 STRLEN n_a;
161b471a
NIS
3439 gv = Nullgv;
3440 gvp = 0;
49dc05e3 3441
3280af22
NIS
3442 PL_bufptr = s;
3443 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
8ebc5c01
PP
3444
3445 /* Some keywords can be followed by any delimiter, including ':' */
3280af22
NIS
3446 tmp = (len == 1 && strchr("msyq", PL_tokenbuf[0]) ||
3447 len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
3448 (PL_tokenbuf[0] == 'q' &&
3449 strchr("qwxr", PL_tokenbuf[1]))));
8ebc5c01
PP
3450
3451 /* x::* is just a word, unless x is "CORE" */
3280af22 3452 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
4633a7c4
LW
3453 goto just_a_word;
3454
3643fb5f 3455 d = s;
3280af22 3456 while (d < PL_bufend && isSPACE(*d))
3643fb5f
CS
3457 d++; /* no comments skipped here, or s### is misparsed */
3458
3459 /* Is this a label? */
3280af22
NIS
3460 if (!tmp && PL_expect == XSTATE
3461 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
8ebc5c01 3462 s = d + 1;
3280af22 3463 yylval.pval = savepv(PL_tokenbuf);
8ebc5c01
PP
3464 CLINE;
3465 TOKEN(LABEL);
3643fb5f
CS
3466 }
3467
3468 /* Check for keywords */
3280af22 3469 tmp = keyword(PL_tokenbuf, len);
748a9306
LW
3470
3471 /* Is this a word before a => operator? */
748a9306
LW
3472 if (strnEQ(d,"=>",2)) {
3473 CLINE;
3280af22 3474 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
748a9306
LW
3475 yylval.opval->op_private = OPpCONST_BARE;
3476 TERM(WORD);
3477 }
3478
a0d0e21e 3479 if (tmp < 0) { /* second-class keyword? */
56f7f34b
CS
3480 GV *ogv = Nullgv; /* override (winner) */
3481 GV *hgv = Nullgv; /* hidden (loser) */
3280af22 3482 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
56f7f34b 3483 CV *cv;
3280af22 3484 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
56f7f34b
CS
3485 (cv = GvCVu(gv)))
3486 {
3487 if (GvIMPORTED_CV(gv))
3488 ogv = gv;
3489 else if (! CvMETHOD(cv))
3490 hgv = gv;
3491 }
3492 if (!ogv &&
3280af22
NIS
3493 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3494 (gv = *gvp) != (GV*)&PL_sv_undef &&
56f7f34b
CS
3495 GvCVu(gv) && GvIMPORTED_CV(gv))
3496 {
3497 ogv = gv;
3498 }
3499 }
3500 if (ogv) {
3501 tmp = 0; /* overridden by import or by GLOBAL */
6e7b2336
GS
3502 }
3503 else if (gv && !gvp
3504 && -tmp==KEY_lock /* XXX generalizable kludge */
3280af22 3505 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
6e7b2336
GS
3506 {
3507 tmp = 0; /* any sub overrides "weak" keyword */
a0d0e21e 3508 }
56f7f34b
CS
3509 else { /* no override */
3510 tmp = -tmp;
3511 gv = Nullgv;
3512 gvp = 0;
4944e2f7
GS
3513 if (ckWARN(WARN_AMBIGUOUS) && hgv
3514 && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
cea2e8a9 3515 Perl_warner(aTHX_ WARN_AMBIGUOUS,
599cee73 3516 "Ambiguous call resolved as CORE::%s(), %s",
2f3ca594 3517 GvENAME(hgv), "qualify as such or use &");
49dc05e3 3518 }
a0d0e21e
LW
3519 }
3520
3521 reserved_word:
3522 switch (tmp) {
79072805
LW
3523
3524 default: /* not a keyword */
93a17b20 3525 just_a_word: {
96e4d5b1 3526 SV *sv;
3280af22 3527 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
8990e307
LW
3528
3529 /* Get the rest if it looks like a package qualifier */
3530
a0d0e21e 3531 if (*s == '\'' || *s == ':' && s[1] == ':') {
c3e0f903 3532 STRLEN morelen;
3280af22 3533 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
c3e0f903
GS
3534 TRUE, &morelen);
3535 if (!morelen)
cea2e8a9 3536 Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
ec2ab091 3537 *s == '\'' ? "'" : "::");
c3e0f903 3538 len += morelen;
a0d0e21e 3539 }
8990e307 3540
3280af22
NIS
3541 if (PL_expect == XOPERATOR) {
3542 if (PL_bufptr == PL_linestart) {
57843af0 3543 CopLINE_dec(PL_curcop);
cea2e8a9 3544 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
57843af0 3545 CopLINE_inc(PL_curcop);
463ee0b2
LW
3546 }
3547 else
54310121 3548 no_op("Bareword",s);
463ee0b2 3549 }
8990e307 3550
c3e0f903
GS
3551 /* Look for a subroutine with this name in current package,
3552 unless name is "Foo::", in which case Foo is a bearword
3553 (and a package name). */
3554
3555 if (len > 2 &&
3280af22 3556 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
c3e0f903 3557 {
599cee73 3558 if (ckWARN(WARN_UNSAFE) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
cea2e8a9 3559 Perl_warner(aTHX_ WARN_UNSAFE,
599cee73 3560 "Bareword \"%s\" refers to nonexistent package",
3280af22 3561 PL_tokenbuf);
c3e0f903 3562 len -= 2;
3280af22 3563 PL_tokenbuf[len] = '\0';
c3e0f903
GS
3564 gv = Nullgv;
3565 gvp = 0;
3566 }
3567 else {
3568 len = 0;
3569 if (!gv)
3280af22 3570 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
c3e0f903
GS
3571 }
3572
3573 /* if we saw a global override before, get the right name */
8990e307 3574
49dc05e3 3575 if (gvp) {
79cb57f6 3576 sv = newSVpvn("CORE::GLOBAL::",14);
3280af22 3577 sv_catpv(sv,PL_tokenbuf);
49dc05e3
GS
3578 }
3579 else
3280af22 3580 sv = newSVpv(PL_tokenbuf,0);
8990e307 3581
a0d0e21e
LW
3582 /* Presume this is going to be a bareword of some sort. */
3583
3584 CLINE;
49dc05e3 3585 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
a0d0e21e
LW
3586 yylval.opval->op_private = OPpCONST_BARE;
3587
c3e0f903
GS
3588 /* And if "Foo::", then that's what it certainly is. */
3589
3590 if (len)
3591 goto safe_bareword;
3592
8990e307
LW
3593 /* See if it's the indirect object for a list operator. */
3594
3280af22
NIS
3595 if (PL_oldoldbufptr &&
3596 PL_oldoldbufptr < PL_bufptr &&
65cec589
GS
3597 (PL_oldoldbufptr == PL_last_lop
3598 || PL_oldoldbufptr == PL_last_uni) &&
a0d0e21e 3599 /* NO SKIPSPACE BEFORE HERE! */
a9ef352a
GS
3600 (PL_expect == XREF ||
3601 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))