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