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