This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
avoid infinite recursive exec()s of perl.exe when shebang
[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 2427 d = instr(s,"perl -");
84e30d1a 2428 if (!d) {
748a9306 2429 d = instr(s,"perl");
84e30d1a
GS
2430#if defined(DOSISH)
2431 /* avoid getting into infinite loops when shebang
2432 * line contains "Perl" rather than "perl" */
2433 if (!d) {
2434 for (d = ipathend-4; d >= ipath; --d) {
2435 if ((*d == 'p' || *d == 'P')
2436 && !ibcmp(d, "perl", 4))
2437 {
2438 break;
2439 }
2440 }
2441 if (d < ipath)
2442 d = Nullch;
2443 }
2444#endif
2445 }
44a8e56a
PP
2446#ifdef ALTERNATE_SHEBANG
2447 /*
2448 * If the ALTERNATE_SHEBANG on this system starts with a
2449 * character that can be part of a Perl expression, then if
2450 * we see it but not "perl", we're probably looking at the
2451 * start of Perl code, not a request to hand off to some
2452 * other interpreter. Similarly, if "perl" is there, but
2453 * not in the first 'word' of the line, we assume the line
2454 * contains the start of the Perl program.
44a8e56a
PP
2455 */
2456 if (d && *s != '#') {
774d564b 2457 char *c = ipath;
44a8e56a
PP
2458 while (*c && !strchr("; \t\r\n\f\v#", *c))
2459 c++;
2460 if (c < d)
2461 d = Nullch; /* "perl" not in first word; ignore */
2462 else
2463 *s = '#'; /* Don't try to parse shebang line */
2464 }
774d564b 2465#endif /* ALTERNATE_SHEBANG */
748a9306 2466 if (!d &&
44a8e56a 2467 *s == '#' &&
774d564b 2468 ipathend > ipath &&
3280af22 2469 !PL_minus_c &&
748a9306 2470 !instr(s,"indir") &&
3280af22 2471 instr(PL_origargv[0],"perl"))
748a9306 2472 {
9f68db38 2473 char **newargv;
9f68db38 2474
774d564b
PP
2475 *ipathend = '\0';
2476 s = ipathend + 1;
3280af22 2477 while (s < PL_bufend && isSPACE(*s))
9f68db38 2478 s++;
3280af22
NIS
2479 if (s < PL_bufend) {
2480 Newz(899,newargv,PL_origargc+3,char*);
9f68db38 2481 newargv[1] = s;
3280af22 2482 while (s < PL_bufend && !isSPACE(*s))
9f68db38
LW
2483 s++;
2484 *s = '\0';
3280af22 2485 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
9f68db38
LW
2486 }
2487 else
3280af22 2488 newargv = PL_origargv;
774d564b 2489 newargv[0] = ipath;
80252599 2490 PerlProc_execv(ipath, newargv);
cea2e8a9 2491 Perl_croak(aTHX_ "Can't exec %s", ipath);
9f68db38 2492 }
748a9306 2493 if (d) {
3280af22
NIS
2494 U32 oldpdb = PL_perldb;
2495 bool oldn = PL_minus_n;
2496 bool oldp = PL_minus_p;
748a9306
LW
2497
2498 while (*d && !isSPACE(*d)) d++;
89bfa8cd 2499 while (*d == ' ' || *d == '\t') d++;
748a9306
LW
2500
2501 if (*d++ == '-') {
8cc95fdb
PP
2502 do {
2503 if (*d == 'M' || *d == 'm') {
2504 char *m = d;
2505 while (*d && !isSPACE(*d)) d++;
cea2e8a9 2506 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
8cc95fdb
PP
2507 (int)(d - m), m);
2508 }
2509 d = moreswitches(d);
2510 } while (d);
84902520 2511 if (PERLDB_LINE && !oldpdb ||
3280af22 2512 ( PL_minus_n || PL_minus_p ) && !(oldn || oldp) )
b084f20b
PP
2513 /* if we have already added "LINE: while (<>) {",
2514 we must not do it again */
748a9306 2515 {
3280af22
NIS
2516 sv_setpv(PL_linestr, "");
2517 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2518 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2519 PL_preambled = FALSE;
84902520 2520 if (PERLDB_LINE)
3280af22 2521 (void)gv_fetchfile(PL_origfilename);
748a9306
LW
2522 goto retry;
2523 }
a0d0e21e 2524 }
79072805 2525 }
9f68db38 2526 }
79072805 2527 }
3280af22
NIS
2528 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2529 PL_bufptr = s;
2530 PL_lex_state = LEX_FORMLINE;
cea2e8a9 2531 return yylex();
ae986130 2532 }
378cc40b 2533 goto retry;
4fdae800 2534 case '\r':
6a27c188 2535#ifdef PERL_STRICT_CR
cea2e8a9
GS
2536 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2537 Perl_croak(aTHX_
54310121 2538 "(Maybe you didn't strip carriage returns after a network transfer?)\n");
a868473f 2539#endif
4fdae800 2540 case ' ': case '\t': case '\f': case 013:
378cc40b
LW
2541 s++;
2542 goto retry;
378cc40b 2543 case '#':
e929a76b 2544 case '\n':
3280af22
NIS
2545 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2546 d = PL_bufend;
a687059c 2547 while (s < d && *s != '\n')
378cc40b 2548 s++;
0f85fab0 2549 if (s < d)
378cc40b 2550 s++;
463ee0b2 2551 incline(s);
3280af22
NIS
2552 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2553 PL_bufptr = s;
2554 PL_lex_state = LEX_FORMLINE;
cea2e8a9 2555 return yylex();
a687059c 2556 }
378cc40b 2557 }
a687059c 2558 else {
378cc40b 2559 *s = '\0';
3280af22 2560 PL_bufend = s;
a687059c 2561 }
378cc40b
LW
2562 goto retry;
2563 case '-':
79072805 2564 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
378cc40b 2565 s++;
3280af22 2566 PL_bufptr = s;
748a9306
LW
2567 tmp = *s++;
2568
3280af22 2569 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
748a9306
LW
2570 s++;
2571
2572 if (strnEQ(s,"=>",2)) {
3280af22 2573 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
748a9306
LW
2574 OPERATOR('-'); /* unary minus */
2575 }
3280af22
NIS
2576 PL_last_uni = PL_oldbufptr;
2577 PL_last_lop_op = OP_FTEREAD; /* good enough */
748a9306 2578 switch (tmp) {
79072805
LW
2579 case 'r': FTST(OP_FTEREAD);
2580 case 'w': FTST(OP_FTEWRITE);
2581 case 'x': FTST(OP_FTEEXEC);
2582 case 'o': FTST(OP_FTEOWNED);
2583 case 'R': FTST(OP_FTRREAD);
2584 case 'W': FTST(OP_FTRWRITE);
2585 case 'X': FTST(OP_FTREXEC);
2586 case 'O': FTST(OP_FTROWNED);
2587 case 'e': FTST(OP_FTIS);
2588 case 'z': FTST(OP_FTZERO);
2589 case 's': FTST(OP_FTSIZE);
2590 case 'f': FTST(OP_FTFILE);
2591 case 'd': FTST(OP_FTDIR);
2592 case 'l': FTST(OP_FTLINK);
2593 case 'p': FTST(OP_FTPIPE);
2594 case 'S': FTST(OP_FTSOCK);
2595 case 'u': FTST(OP_FTSUID);
2596 case 'g': FTST(OP_FTSGID);
2597 case 'k': FTST(OP_FTSVTX);
2598 case 'b': FTST(OP_FTBLK);
2599 case 'c': FTST(OP_FTCHR);
2600 case 't': FTST(OP_FTTTY);
2601 case 'T': FTST(OP_FTTEXT);
2602 case 'B': FTST(OP_FTBINARY);
85e6fe83
LW
2603 case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2604 case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2605 case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
378cc40b 2606 default:
cea2e8a9 2607 Perl_croak(aTHX_ "Unrecognized file test: -%c", (int)tmp);
378cc40b
LW
2608 break;
2609 }
2610 }
a687059c
LW
2611 tmp = *s++;
2612 if (*s == tmp) {
2613 s++;
3280af22 2614 if (PL_expect == XOPERATOR)
79072805
LW
2615 TERM(POSTDEC);
2616 else
2617 OPERATOR(PREDEC);
2618 }
2619 else if (*s == '>') {
2620 s++;
2621 s = skipspace(s);
834a4ddd 2622 if (isIDFIRST_lazy(s)) {
a0d0e21e 2623 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
463ee0b2 2624 TOKEN(ARROW);
79072805 2625 }
748a9306
LW
2626 else if (*s == '$')
2627 OPERATOR(ARROW);
463ee0b2 2628 else
748a9306 2629 TERM(ARROW);
a687059c 2630 }
3280af22 2631 if (PL_expect == XOPERATOR)
79072805
LW
2632 Aop(OP_SUBTRACT);
2633 else {
3280af22 2634 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2f3197b3 2635 check_uni();
79072805 2636 OPERATOR('-'); /* unary minus */
2f3197b3 2637 }
79072805 2638
378cc40b 2639 case '+':
a687059c
LW
2640 tmp = *s++;
2641 if (*s == tmp) {
378cc40b 2642 s++;
3280af22 2643 if (PL_expect == XOPERATOR)
79072805
LW
2644 TERM(POSTINC);
2645 else
2646 OPERATOR(PREINC);
378cc40b 2647 }
3280af22 2648 if (PL_expect == XOPERATOR)
79072805
LW
2649 Aop(OP_ADD);
2650 else {
3280af22 2651 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2f3197b3 2652 check_uni();
a687059c 2653 OPERATOR('+');
2f3197b3 2654 }
a687059c 2655
378cc40b 2656 case '*':
3280af22
NIS
2657 if (PL_expect != XOPERATOR) {
2658 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2659 PL_expect = XOPERATOR;
2660 force_ident(PL_tokenbuf, '*');
2661 if (!*PL_tokenbuf)
a0d0e21e 2662 PREREF('*');
79072805 2663 TERM('*');
a687059c 2664 }
79072805
LW
2665 s++;
2666 if (*s == '*') {
a687059c 2667 s++;
79072805 2668 PWop(OP_POW);
a687059c 2669 }
79072805
LW
2670 Mop(OP_MULTIPLY);
2671
378cc40b 2672 case '%':
3280af22 2673 if (PL_expect == XOPERATOR) {
bbce6d69
PP
2674 ++s;
2675 Mop(OP_MODULO);
a687059c 2676 }
3280af22
NIS
2677 PL_tokenbuf[0] = '%';
2678 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2679 if (!PL_tokenbuf[1]) {
2680 if (s == PL_bufend)
bbce6d69
PP
2681 yyerror("Final % should be \\% or %name");
2682 PREREF('%');
a687059c 2683 }
3280af22 2684 PL_pending_ident = '%';
bbce6d69 2685 TERM('%');
a687059c 2686
378cc40b 2687 case '^':
79072805 2688 s++;
a0d0e21e 2689 BOop(OP_BIT_XOR);
79072805 2690 case '[':
3280af22 2691 PL_lex_brackets++;
79072805 2692 /* FALL THROUGH */
378cc40b 2693 case '~':
378cc40b 2694 case ',':
378cc40b
LW
2695 tmp = *s++;
2696 OPERATOR(tmp);
a0d0e21e
LW
2697 case ':':
2698 if (s[1] == ':') {
2699 len = 0;
2700 goto just_a_word;
2701 }
2702 s++;
09bef843
SB
2703 switch (PL_expect) {
2704 OP *attrs;
2705 case XOPERATOR:
2706 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
2707 break;
2708 PL_bufptr = s; /* update in case we back off */
2709 goto grabattrs;
2710 case XATTRBLOCK:
2711 PL_expect = XBLOCK;
2712 goto grabattrs;
2713 case XATTRTERM:
2714 PL_expect = XTERMBLOCK;
2715 grabattrs:
2716 s = skipspace(s);
2717 attrs = Nullop;
2718 while (isIDFIRST_lazy(s)) {
2719 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2720 if (*d == '(') {
2721 d = scan_str(d,TRUE,TRUE);
2722 if (!d) {
2723 if (PL_lex_stuff) {
2724 SvREFCNT_dec(PL_lex_stuff);
2725 PL_lex_stuff = Nullsv;
2726 }
2727 /* MUST advance bufptr here to avoid bogus
2728 "at end of line" context messages from yyerror().
2729 */
2730 PL_bufptr = s + len;
2731 yyerror("Unterminated attribute parameter in attribute list");
2732 if (attrs)
2733 op_free(attrs);
2734 return 0; /* EOF indicator */
2735 }
2736 }
2737 if (PL_lex_stuff) {
2738 SV *sv = newSVpvn(s, len);
2739 sv_catsv(sv, PL_lex_stuff);
2740 attrs = append_elem(OP_LIST, attrs,
2741 newSVOP(OP_CONST, 0, sv));
2742 SvREFCNT_dec(PL_lex_stuff);
2743 PL_lex_stuff = Nullsv;
2744 }
2745 else {
2746 attrs = append_elem(OP_LIST, attrs,
2747 newSVOP(OP_CONST, 0,
2748 newSVpvn(s, len)));
2749 }
2750 s = skipspace(d);
2751 while (*s == ',')
2752 s = skipspace(s+1);
2753 }
2754 tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}' for vi */
2755 if (*s != ';' && *s != tmp) {
2756 char q = ((*s == '\'') ? '"' : '\'');
2757 /* If here for an expression, and parsed no attrs, back off. */
2758 if (tmp == '=' && !attrs) {
2759 s = PL_bufptr;
2760 break;
2761 }
2762 /* MUST advance bufptr here to avoid bogus "at end of line"
2763 context messages from yyerror().
2764 */
2765 PL_bufptr = s;
2766 if (!*s)
2767 yyerror("Unterminated attribute list");
2768 else
2769 yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list",
2770 q, *s, q));
2771 if (attrs)
2772 op_free(attrs);
2773 OPERATOR(':');
2774 }
2775 if (attrs) {
2776 PL_nextval[PL_nexttoke].opval = attrs;
2777 force_next(THING);
2778 }
2779 TOKEN(COLONATTR);
2780 }
a0d0e21e 2781 OPERATOR(':');
8990e307
LW
2782 case '(':
2783 s++;
3280af22
NIS
2784 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
2785 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
a0d0e21e 2786 else
3280af22 2787 PL_expect = XTERM;
a0d0e21e 2788 TOKEN('(');
378cc40b 2789 case ';':
3280af22
NIS
2790 if (PL_curcop->cop_line < PL_copline)
2791 PL_copline = PL_curcop->cop_line;
378cc40b
LW
2792 tmp = *s++;
2793 OPERATOR(tmp);
2794 case ')':
378cc40b 2795 tmp = *s++;
16d20bd9
AD
2796 s = skipspace(s);
2797 if (*s == '{')
2798 PREBLOCK(tmp);
378cc40b 2799 TERM(tmp);
79072805
LW
2800 case ']':
2801 s++;
3280af22 2802 if (PL_lex_brackets <= 0)
d98d5fff 2803 yyerror("Unmatched right square bracket");
463ee0b2 2804 else
3280af22
NIS
2805 --PL_lex_brackets;
2806 if (PL_lex_state == LEX_INTERPNORMAL) {
2807 if (PL_lex_brackets == 0) {
a0d0e21e 2808 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
3280af22 2809 PL_lex_state = LEX_INTERPEND;
79072805
LW
2810 }
2811 }
4633a7c4 2812 TERM(']');
79072805
LW
2813 case '{':
2814 leftbracket:
79072805 2815 s++;
3280af22
NIS
2816 if (PL_lex_brackets > 100) {
2817 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
2818 if (newlb != PL_lex_brackstack) {
8990e307 2819 SAVEFREEPV(newlb);
3280af22 2820 PL_lex_brackstack = newlb;
8990e307
LW
2821 }
2822 }
3280af22 2823 switch (PL_expect) {
a0d0e21e 2824 case XTERM:
3280af22 2825 if (PL_lex_formbrack) {
a0d0e21e
LW
2826 s--;
2827 PRETERMBLOCK(DO);
2828 }
3280af22
NIS
2829 if (PL_oldoldbufptr == PL_last_lop)
2830 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
a0d0e21e 2831 else
3280af22 2832 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
79072805 2833 OPERATOR(HASHBRACK);
a0d0e21e 2834 case XOPERATOR:
3280af22 2835 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
748a9306 2836 s++;
44a8e56a 2837 d = s;
3280af22
NIS
2838 PL_tokenbuf[0] = '\0';
2839 if (d < PL_bufend && *d == '-') {
2840 PL_tokenbuf[0] = '-';
44a8e56a 2841 d++;
3280af22 2842 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
44a8e56a
PP
2843 d++;
2844 }
834a4ddd 2845 if (d < PL_bufend && isIDFIRST_lazy(d)) {
3280af22 2846 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
8903cb82 2847 FALSE, &len);
3280af22 2848 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
748a9306
LW
2849 d++;
2850 if (*d == '}') {
3280af22 2851 char minus = (PL_tokenbuf[0] == '-');
44a8e56a
PP
2852 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2853 if (minus)
2854 force_next('-');
748a9306
LW
2855 }
2856 }
2857 /* FALL THROUGH */
09bef843 2858 case XATTRBLOCK:
748a9306 2859 case XBLOCK:
3280af22
NIS
2860 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
2861 PL_expect = XSTATE;
a0d0e21e 2862 break;
09bef843 2863 case XATTRTERM:
a0d0e21e 2864 case XTERMBLOCK:
3280af22
NIS
2865 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2866 PL_expect = XSTATE;
a0d0e21e
LW
2867 break;
2868 default: {
2869 char *t;
3280af22
NIS
2870 if (PL_oldoldbufptr == PL_last_lop)
2871 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
a0d0e21e 2872 else
3280af22 2873 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
a0d0e21e 2874 s = skipspace(s);
09ecc4b6 2875 if (*s == '}')
a0d0e21e 2876 OPERATOR(HASHBRACK);
b8a4b1be
GS
2877 /* This hack serves to disambiguate a pair of curlies
2878 * as being a block or an anon hash. Normally, expectation
2879 * determines that, but in cases where we're not in a
2880 * position to expect anything in particular (like inside
2881 * eval"") we have to resolve the ambiguity. This code
2882 * covers the case where the first term in the curlies is a
2883 * quoted string. Most other cases need to be explicitly
2884 * disambiguated by prepending a `+' before the opening
2885 * curly in order to force resolution as an anon hash.
2886 *
2887 * XXX should probably propagate the outer expectation
2888 * into eval"" to rely less on this hack, but that could
2889 * potentially break current behavior of eval"".
2890 * GSAR 97-07-21
2891 */
2892 t = s;
2893 if (*s == '\'' || *s == '"' || *s == '`') {
2894 /* common case: get past first string, handling escapes */
3280af22 2895 for (t++; t < PL_bufend && *t != *s;)
b8a4b1be
GS
2896 if (*t++ == '\\' && (*t == '\\' || *t == *s))
2897 t++;
2898 t++;
a0d0e21e 2899 }
b8a4b1be 2900 else if (*s == 'q') {
3280af22 2901 if (++t < PL_bufend
b8a4b1be 2902 && (!isALNUM(*t)
3280af22 2903 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
b8a4b1be
GS
2904 && !isALNUM(*t)))) {
2905 char *tmps;
2906 char open, close, term;
2907 I32 brackets = 1;
2908
3280af22 2909 while (t < PL_bufend && isSPACE(*t))
b8a4b1be
GS
2910 t++;
2911 term = *t;
2912 open = term;
2913 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
2914 term = tmps[5];
2915 close = term;
2916 if (open == close)
3280af22
NIS
2917 for (t++; t < PL_bufend; t++) {
2918 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
b8a4b1be 2919 t++;
6d07e5e9 2920 else if (*t == open)
b8a4b1be
GS
2921 break;
2922 }
2923 else
3280af22
NIS
2924 for (t++; t < PL_bufend; t++) {
2925 if (*t == '\\' && t+1 < PL_bufend)
b8a4b1be 2926 t++;
6d07e5e9 2927 else if (*t == close && --brackets <= 0)
b8a4b1be
GS
2928 break;
2929 else if (*t == open)
2930 brackets++;
2931 }
2932 }
2933 t++;
a0d0e21e 2934 }
834a4ddd
LW
2935 else if (isIDFIRST_lazy(s)) {
2936 for (t++; t < PL_bufend && isALNUM_lazy(t); t++) ;
a0d0e21e 2937 }
3280af22 2938 while (t < PL_bufend && isSPACE(*t))
a0d0e21e 2939 t++;
b8a4b1be
GS
2940 /* if comma follows first term, call it an anon hash */
2941 /* XXX it could be a comma expression with loop modifiers */
3280af22 2942 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
b8a4b1be 2943 || (*t == '=' && t[1] == '>')))
a0d0e21e 2944 OPERATOR(HASHBRACK);
3280af22 2945 if (PL_expect == XREF)
4e4e412b 2946 PL_expect = XTERM;
a0d0e21e 2947 else {
3280af22
NIS
2948 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
2949 PL_expect = XSTATE;
a0d0e21e 2950 }
8990e307 2951 }
a0d0e21e 2952 break;
463ee0b2 2953 }
3280af22 2954 yylval.ival = PL_curcop->cop_line;
79072805 2955 if (isSPACE(*s) || *s == '#')
3280af22 2956 PL_copline = NOLINE; /* invalidate current command line number */
79072805 2957 TOKEN('{');
378cc40b 2958 case '}':
79072805
LW
2959 rightbracket:
2960 s++;
3280af22 2961 if (PL_lex_brackets <= 0)
d98d5fff 2962 yyerror("Unmatched right curly bracket");
463ee0b2 2963 else
3280af22
NIS
2964 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
2965 if (PL_lex_brackets < PL_lex_formbrack)
2966 PL_lex_formbrack = 0;
2967 if (PL_lex_state == LEX_INTERPNORMAL) {
2968 if (PL_lex_brackets == 0) {
2969 if (PL_lex_fakebrack) {
2970 PL_lex_state = LEX_INTERPEND;
2971 PL_bufptr = s;
cea2e8a9 2972 return yylex(); /* ignore fake brackets */
79072805 2973 }
fa83b5b6 2974 if (*s == '-' && s[1] == '>')
3280af22 2975 PL_lex_state = LEX_INTERPENDMAYBE;
fa83b5b6 2976 else if (*s != '[' && *s != '{')
3280af22 2977 PL_lex_state = LEX_INTERPEND;
79072805
LW
2978 }
2979 }
3280af22
NIS
2980 if (PL_lex_brackets < PL_lex_fakebrack) {
2981 PL_bufptr = s;
2982 PL_lex_fakebrack = 0;
cea2e8a9 2983 return yylex(); /* ignore fake brackets */
748a9306 2984 }
79072805
LW
2985 force_next('}');
2986 TOKEN(';');
378cc40b
LW
2987 case '&':
2988 s++;
2989 tmp = *s++;
2990 if (tmp == '&')
a0d0e21e 2991 AOPERATOR(ANDAND);
378cc40b 2992 s--;
3280af22 2993 if (PL_expect == XOPERATOR) {
834a4ddd 2994 if (ckWARN(WARN_SEMICOLON) && isIDFIRST_lazy(s) && PL_bufptr == PL_linestart) {
3280af22 2995 PL_curcop->cop_line--;
cea2e8a9 2996 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3280af22 2997 PL_curcop->cop_line++;
463ee0b2 2998 }
79072805 2999 BAop(OP_BIT_AND);
463ee0b2 3000 }
79072805 3001
3280af22
NIS
3002 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3003 if (*PL_tokenbuf) {
3004 PL_expect = XOPERATOR;
3005 force_ident(PL_tokenbuf, '&');
463ee0b2 3006 }
79072805
LW
3007 else
3008 PREREF('&');
c07a80fd 3009 yylval.ival = (OPpENTERSUB_AMPER<<8);
79072805
LW
3010 TERM('&');
3011
378cc40b
LW
3012 case '|':
3013 s++;
3014 tmp = *s++;
3015 if (tmp == '|')
a0d0e21e 3016 AOPERATOR(OROR);
378cc40b 3017 s--;
79072805 3018 BOop(OP_BIT_OR);
378cc40b
LW
3019 case '=':
3020 s++;
3021 tmp = *s++;
3022 if (tmp == '=')
79072805
LW
3023 Eop(OP_EQ);
3024 if (tmp == '>')
3025 OPERATOR(',');
378cc40b 3026 if (tmp == '~')
79072805 3027 PMop(OP_MATCH);
599cee73 3028 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
cea2e8a9 3029 Perl_warner(aTHX_ WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
378cc40b 3030 s--;
3280af22
NIS
3031 if (PL_expect == XSTATE && isALPHA(tmp) &&
3032 (s == PL_linestart+1 || s[-2] == '\n') )
748a9306 3033 {
3280af22
NIS
3034 if (PL_in_eval && !PL_rsfp) {
3035 d = PL_bufend;
a5f75d66
AD
3036 while (s < d) {
3037 if (*s++ == '\n') {
3038 incline(s);
3039 if (strnEQ(s,"=cut",4)) {
3040 s = strchr(s,'\n');
3041 if (s)
3042 s++;
3043 else
3044 s = d;
3045 incline(s);
3046 goto retry;
3047 }
3048 }
3049 }
3050 goto retry;
3051 }
3280af22
NIS
3052 s = PL_bufend;
3053 PL_doextract = TRUE;
a0d0e21e
LW
3054 goto retry;
3055 }
3280af22 3056 if (PL_lex_brackets < PL_lex_formbrack) {
a0d0e21e 3057 char *t;
51882d45 3058#ifdef PERL_STRICT_CR
a0d0e21e 3059 for (t = s; *t == ' ' || *t == '\t'; t++) ;
51882d45
GS
3060#else
3061 for (t = s; *t == ' ' || *t == '\t' || *t == '\r'; t++) ;
3062#endif
a0d0e21e
LW
3063 if (*t == '\n' || *t == '#') {
3064 s--;
3280af22 3065 PL_expect = XBLOCK;
a0d0e21e
LW
3066 goto leftbracket;
3067 }
79072805 3068 }
a0d0e21e
LW
3069 yylval.ival = 0;
3070 OPERATOR(ASSIGNOP);
378cc40b
LW
3071 case '!':
3072 s++;
3073 tmp = *s++;
3074 if (tmp == '=')
79072805 3075 Eop(OP_NE);
378cc40b 3076 if (tmp == '~')
79072805 3077 PMop(OP_NOT);
378cc40b
LW
3078 s--;
3079 OPERATOR('!');
3080 case '<':
3280af22 3081 if (PL_expect != XOPERATOR) {
93a17b20 3082 if (s[1] != '<' && !strchr(s,'>'))
2f3197b3 3083 check_uni();
79072805
LW
3084 if (s[1] == '<')
3085 s = scan_heredoc(s);
3086 else
3087 s = scan_inputsymbol(s);
3088 TERM(sublex_start());
378cc40b
LW
3089 }
3090 s++;
3091 tmp = *s++;
3092 if (tmp == '<')
79072805 3093 SHop(OP_LEFT_SHIFT);
395c3793
LW
3094 if (tmp == '=') {
3095 tmp = *s++;
3096 if (tmp == '>')
79072805 3097 Eop(OP_NCMP);
395c3793 3098 s--;
79072805 3099 Rop(OP_LE);
395c3793 3100 }
378cc40b 3101 s--;
79072805 3102 Rop(OP_LT);
378cc40b
LW
3103 case '>':
3104 s++;
3105 tmp = *s++;
3106 if (tmp == '>')
79072805 3107 SHop(OP_RIGHT_SHIFT);
378cc40b 3108 if (tmp == '=')
79072805 3109 Rop(OP_GE);
378cc40b 3110 s--;
79072805 3111 Rop(OP_GT);
378cc40b
LW
3112
3113 case '$':
bbce6d69
PP
3114 CLINE;
3115
3280af22
NIS
3116 if (PL_expect == XOPERATOR) {
3117 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3118 PL_expect = XTERM;
a0d0e21e 3119 depcom();
bbce6d69 3120 return ','; /* grandfather non-comma-format format */
a0d0e21e 3121 }
8990e307 3122 }
a0d0e21e 3123
834a4ddd 3124 if (s[1] == '#' && (isIDFIRST_lazy(s+2) || strchr("{$:+-", s[2]))) {
3280af22 3125 PL_tokenbuf[0] = '@';
376b8730
SM
3126 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3127 sizeof PL_tokenbuf - 1, FALSE);
3128 if (PL_expect == XOPERATOR)
3129 no_op("Array length", s);
3280af22 3130 if (!PL_tokenbuf[1])
a0d0e21e 3131 PREREF(DOLSHARP);
3280af22
NIS
3132 PL_expect = XOPERATOR;
3133 PL_pending_ident = '#';
463ee0b2 3134 TOKEN(DOLSHARP);
79072805 3135 }
bbce6d69 3136
3280af22 3137 PL_tokenbuf[0] = '$';
376b8730
SM
3138 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3139 sizeof PL_tokenbuf - 1, FALSE);
3140 if (PL_expect == XOPERATOR)
3141 no_op("Scalar", s);
3280af22
NIS
3142 if (!PL_tokenbuf[1]) {
3143 if (s == PL_bufend)
bbce6d69
PP
3144 yyerror("Final $ should be \\$ or $name");
3145 PREREF('$');
8990e307 3146 }
a0d0e21e 3147
bbce6d69 3148 /* This kludge not intended to be bulletproof. */
3280af22 3149 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
bbce6d69 3150 yylval.opval = newSVOP(OP_CONST, 0,
3280af22 3151 newSViv((IV)PL_compiling.cop_arybase));
bbce6d69
PP
3152 yylval.opval->op_private = OPpCONST_ARYBASE;
3153 TERM(THING);
3154 }
3155
ff68c719 3156 d = s;
69d2bceb 3157 tmp = (I32)*s;
3280af22 3158 if (PL_lex_state == LEX_NORMAL)
ff68c719
PP
3159 s = skipspace(s);
3160
3280af22 3161 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
bbce6d69
PP
3162 char *t;
3163 if (*s == '[') {
3280af22 3164 PL_tokenbuf[0] = '@';
599cee73 3165 if (ckWARN(WARN_SYNTAX)) {
bbce6d69 3166 for(t = s + 1;
834a4ddd 3167 isSPACE(*t) || isALNUM_lazy(t) || *t == '$';
bbce6d69 3168 t++) ;
a0d0e21e 3169 if (*t++ == ',') {
3280af22
NIS
3170 PL_bufptr = skipspace(PL_bufptr);
3171 while (t < PL_bufend && *t != ']')
bbce6d69 3172 t++;
cea2e8a9 3173 Perl_warner(aTHX_ WARN_SYNTAX,
599cee73
PM
3174 "Multidimensional syntax %.*s not supported",
3175 (t - PL_bufptr) + 1, PL_bufptr);
a0d0e21e
LW
3176 }
3177 }
bbce6d69
PP
3178 }
3179 else if (*s == '{') {
3280af22 3180 PL_tokenbuf[0] = '%';
599cee73 3181 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
bbce6d69
PP
3182 (t = strchr(s, '}')) && (t = strchr(t, '=')))
3183 {
3280af22 3184 char tmpbuf[sizeof PL_tokenbuf];
a0d0e21e
LW
3185 STRLEN len;
3186 for (t++; isSPACE(*t); t++) ;
834a4ddd 3187 if (isIDFIRST_lazy(t)) {
8903cb82 3188 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
59a6d928 3189 for (; isSPACE(*t); t++) ;
864dbfa3 3190 if (*t == ';' && get_cv(tmpbuf, FALSE))
cea2e8a9 3191 Perl_warner(aTHX_ WARN_SYNTAX,
599cee73 3192 "You need to quote \"%s\"", tmpbuf);
748a9306 3193 }
93a17b20
LW
3194 }
3195 }
2f3197b3 3196 }
bbce6d69 3197
3280af22 3198 PL_expect = XOPERATOR;
69d2bceb 3199 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3280af22
NIS
3200 bool islop = (PL_last_lop == PL_oldoldbufptr);
3201 if (!islop || PL_last_lop_op == OP_GREPSTART)
3202 PL_expect = XOPERATOR;
bbce6d69 3203 else if (strchr("$@\"'`q", *s))
3280af22 3204 PL_expect = XTERM; /* e.g. print $fh "foo" */
834a4ddd 3205 else if (strchr("&*<%", *s) && isIDFIRST_lazy(s+1))
3280af22 3206 PL_expect = XTERM; /* e.g. print $fh &sub */
834a4ddd 3207 else if (isIDFIRST_lazy(s)) {
3280af22 3208 char tmpbuf[sizeof PL_tokenbuf];
8903cb82 3209 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
84902520
TB
3210 if (tmp = keyword(tmpbuf, len)) {
3211 /* binary operators exclude handle interpretations */
3212 switch (tmp) {
3213 case -KEY_x:
3214 case -KEY_eq:
3215 case -KEY_ne:
3216 case -KEY_gt:
3217 case -KEY_lt:
3218 case -KEY_ge:
3219 case -KEY_le:
3220 case -KEY_cmp:
3221 break;
3222 default:
3280af22 3223 PL_expect = XTERM; /* e.g. print $fh length() */
84902520
TB
3224 break;
3225 }
3226 }
68dc0745
PP
3227 else {
3228 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
3229 if (gv && GvCVu(gv))
3280af22 3230 PL_expect = XTERM; /* e.g. print $fh subr() */
93a17b20 3231 }
93a17b20 3232 }
bbce6d69 3233 else if (isDIGIT(*s))
3280af22 3234 PL_expect = XTERM; /* e.g. print $fh 3 */
bbce6d69 3235 else if (*s == '.' && isDIGIT(s[1]))
3280af22 3236 PL_expect = XTERM; /* e.g. print $fh .3 */
e0587a03 3237 else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
3280af22 3238 PL_expect = XTERM; /* e.g. print $fh -1 */
e0587a03 3239 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3280af22 3240 PL_expect = XTERM; /* print $fh <<"EOF" */
bbce6d69 3241 }
3280af22 3242 PL_pending_ident = '$';
79072805 3243 TOKEN('$');
378cc40b
LW
3244
3245 case '@':
3280af22 3246 if (PL_expect == XOPERATOR)
bbce6d69 3247 no_op("Array", s);
3280af22
NIS
3248 PL_tokenbuf[0] = '@';
3249 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3250 if (!PL_tokenbuf[1]) {
3251 if (s == PL_bufend)
bbce6d69
PP
3252 yyerror("Final @ should be \\@ or @name");
3253 PREREF('@');
3254 }
3280af22 3255 if (PL_lex_state == LEX_NORMAL)
ff68c719 3256 s = skipspace(s);
3280af22 3257 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
bbce6d69 3258 if (*s == '{')
3280af22 3259 PL_tokenbuf[0] = '%';
a0d0e21e
LW
3260
3261 /* Warn about @ where they meant $. */
599cee73 3262 if (ckWARN(WARN_SYNTAX)) {
a0d0e21e
LW
3263 if (*s == '[' || *s == '{') {
3264 char *t = s + 1;
834a4ddd 3265 while (*t && (isALNUM_lazy(t) || strchr(" \t$#+-'\"", *t)))
a0d0e21e
LW
3266 t++;
3267 if (*t == '}' || *t == ']') {
3268 t++;
3280af22 3269 PL_bufptr = skipspace(PL_bufptr);
cea2e8a9 3270 Perl_warner(aTHX_ WARN_SYNTAX,
599cee73 3271 "Scalar value %.*s better written as $%.*s",
3280af22 3272 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
a0d0e21e 3273 }
93a17b20
LW
3274 }
3275 }
463ee0b2 3276 }
3280af22 3277 PL_pending_ident = '@';
79072805 3278 TERM('@');
378cc40b
LW
3279
3280 case '/': /* may either be division or pattern */
3281 case '?': /* may either be conditional or pattern */
3280af22 3282 if (PL_expect != XOPERATOR) {
c277df42 3283 /* Disable warning on "study /blah/" */
3280af22
NIS
3284 if (PL_oldoldbufptr == PL_last_uni
3285 && (*PL_last_uni != 's' || s - PL_last_uni < 5
834a4ddd 3286 || memNE(PL_last_uni, "study", 5) || isALNUM_lazy(PL_last_uni+5)))
c277df42 3287 check_uni();
8782bef2 3288 s = scan_pat(s,OP_MATCH);
79072805 3289 TERM(sublex_start());
378cc40b
LW
3290 }
3291 tmp = *s++;
a687059c 3292 if (tmp == '/')
79072805 3293 Mop(OP_DIVIDE);
378cc40b
LW
3294 OPERATOR(tmp);
3295
3296 case '.':
51882d45
GS
3297 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3298#ifdef PERL_STRICT_CR
3299 && s[1] == '\n'
3300#else
3301 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3302#endif
3303 && (s == PL_linestart || s[-1] == '\n') )
3304 {
3280af22
NIS
3305 PL_lex_formbrack = 0;
3306 PL_expect = XSTATE;
79072805
LW
3307 goto rightbracket;
3308 }
3280af22 3309 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
378cc40b 3310 tmp = *s++;
a687059c
LW
3311 if (*s == tmp) {
3312 s++;
2f3197b3
LW
3313 if (*s == tmp) {
3314 s++;
79072805 3315 yylval.ival = OPf_SPECIAL;
2f3197b3
LW
3316 }
3317 else
79072805 3318 yylval.ival = 0;
378cc40b 3319 OPERATOR(DOTDOT);
a687059c 3320 }
3280af22 3321 if (PL_expect != XOPERATOR)
2f3197b3 3322 check_uni();
79072805 3323 Aop(OP_CONCAT);
378cc40b
LW
3324 }
3325 /* FALL THROUGH */
3326 case '0': case '1': case '2': case '3': case '4':
3327 case '5': case '6': case '7': case '8': case '9':
79072805 3328 s = scan_num(s);
3280af22 3329 if (PL_expect == XOPERATOR)
8990e307 3330 no_op("Number",s);
79072805
LW
3331 TERM(THING);
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);
79072805
LW
3346 yylval.ival = OP_CONST;
3347 TERM(sublex_start());
3348
3349 case '"':
09bef843 3350 s = scan_str(s,FALSE,FALSE);
3280af22
NIS
3351 if (PL_expect == XOPERATOR) {
3352 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3353 PL_expect = XTERM;
a0d0e21e
LW
3354 depcom();
3355 return ','; /* grandfather non-comma-format format */
3356 }
463ee0b2 3357 else
8990e307 3358 no_op("String",s);
463ee0b2 3359 }
79072805 3360 if (!s)
85e6fe83 3361 missingterm((char*)0);
4633a7c4 3362 yylval.ival = OP_CONST;
3280af22 3363 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
a0ed51b3 3364 if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
4633a7c4
LW
3365 yylval.ival = OP_STRINGIFY;
3366 break;
3367 }
3368 }
79072805
LW
3369 TERM(sublex_start());
3370
3371 case '`':
09bef843 3372 s = scan_str(s,FALSE,FALSE);
3280af22 3373 if (PL_expect == XOPERATOR)
8990e307 3374 no_op("Backticks",s);
79072805 3375 if (!s)
85e6fe83 3376 missingterm((char*)0);
79072805
LW
3377 yylval.ival = OP_BACKTICK;
3378 set_csh();
3379 TERM(sublex_start());
3380
3381 case '\\':
3382 s++;
599cee73 3383 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
cea2e8a9 3384 Perl_warner(aTHX_ WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
599cee73 3385 *s, *s);
3280af22 3386 if (PL_expect == XOPERATOR)
8990e307 3387 no_op("Backslash",s);
79072805
LW
3388 OPERATOR(REFGEN);
3389
3390 case 'x':
3280af22 3391 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
79072805
LW
3392 s++;
3393 Mop(OP_REPEAT);
2f3197b3 3394 }
79072805
LW
3395 goto keylookup;
3396
378cc40b 3397 case '_':
79072805
LW
3398 case 'a': case 'A':
3399 case 'b': case 'B':
3400 case 'c': case 'C':
3401 case 'd': case 'D':
3402 case 'e': case 'E':
3403 case 'f': case 'F':
3404 case 'g': case 'G':
3405 case 'h': case 'H':
3406 case 'i': case 'I':
3407 case 'j': case 'J':
3408 case 'k': case 'K':
3409 case 'l': case 'L':
3410 case 'm': case 'M':
3411 case 'n': case 'N':
3412 case 'o': case 'O':
3413 case 'p': case 'P':
3414 case 'q': case 'Q':
3415 case 'r': case 'R':
3416 case 's': case 'S':
3417 case 't': case 'T':
3418 case 'u': case 'U':
3419 case 'v': case 'V':
3420 case 'w': case 'W':
3421 case 'X':
3422 case 'y': case 'Y':
3423 case 'z': case 'Z':
3424
49dc05e3 3425 keylookup: {
2d8e6c8d 3426 STRLEN n_a;
161b471a
NIS
3427 gv = Nullgv;
3428 gvp = 0;
49dc05e3 3429
3280af22
NIS
3430 PL_bufptr = s;
3431 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
8ebc5c01
PP
3432
3433 /* Some keywords can be followed by any delimiter, including ':' */
3280af22
NIS
3434 tmp = (len == 1 && strchr("msyq", PL_tokenbuf[0]) ||
3435 len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
3436 (PL_tokenbuf[0] == 'q' &&
3437 strchr("qwxr", PL_tokenbuf[1]))));
8ebc5c01
PP
3438
3439 /* x::* is just a word, unless x is "CORE" */
3280af22 3440 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
4633a7c4
LW
3441 goto just_a_word;
3442
3643fb5f 3443 d = s;
3280af22 3444 while (d < PL_bufend && isSPACE(*d))
3643fb5f
CS
3445 d++; /* no comments skipped here, or s### is misparsed */
3446
3447 /* Is this a label? */
3280af22
NIS
3448 if (!tmp && PL_expect == XSTATE
3449 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
8ebc5c01 3450 s = d + 1;
3280af22 3451 yylval.pval = savepv(PL_tokenbuf);
8ebc5c01
PP
3452 CLINE;
3453 TOKEN(LABEL);
3643fb5f
CS
3454 }
3455
3456 /* Check for keywords */
3280af22 3457 tmp = keyword(PL_tokenbuf, len);
748a9306
LW
3458
3459 /* Is this a word before a => operator? */
748a9306
LW
3460 if (strnEQ(d,"=>",2)) {
3461 CLINE;
3280af22 3462 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
748a9306
LW
3463 yylval.opval->op_private = OPpCONST_BARE;
3464 TERM(WORD);
3465 }
3466
a0d0e21e 3467 if (tmp < 0) { /* second-class keyword? */
56f7f34b
CS
3468 GV *ogv = Nullgv; /* override (winner) */
3469 GV *hgv = Nullgv; /* hidden (loser) */
3280af22 3470 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
56f7f34b 3471 CV *cv;
3280af22 3472 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
56f7f34b
CS
3473 (cv = GvCVu(gv)))
3474 {
3475 if (GvIMPORTED_CV(gv))
3476 ogv = gv;
3477 else if (! CvMETHOD(cv))
3478 hgv = gv;
3479 }
3480 if (!ogv &&
3280af22
NIS
3481 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3482 (gv = *gvp) != (GV*)&PL_sv_undef &&
56f7f34b
CS
3483 GvCVu(gv) && GvIMPORTED_CV(gv))
3484 {
3485 ogv = gv;
3486 }
3487 }
3488 if (ogv) {
3489 tmp = 0; /* overridden by import or by GLOBAL */
6e7b2336
GS
3490 }
3491 else if (gv && !gvp
3492 && -tmp==KEY_lock /* XXX generalizable kludge */
3280af22 3493 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
6e7b2336
GS
3494 {
3495 tmp = 0; /* any sub overrides "weak" keyword */
a0d0e21e 3496 }
56f7f34b
CS
3497 else { /* no override */
3498 tmp = -tmp;
3499 gv = Nullgv;
3500 gvp = 0;
4944e2f7
GS
3501 if (ckWARN(WARN_AMBIGUOUS) && hgv
3502 && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
cea2e8a9 3503 Perl_warner(aTHX_ WARN_AMBIGUOUS,
599cee73 3504 "Ambiguous call resolved as CORE::%s(), %s",
2f3ca594 3505 GvENAME(hgv), "qualify as such or use &");
49dc05e3 3506 }
a0d0e21e
LW
3507 }
3508
3509 reserved_word:
3510 switch (tmp) {
79072805
LW
3511
3512 default: /* not a keyword */
93a17b20 3513 just_a_word: {
96e4d5b1 3514 SV *sv;
3280af22 3515 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
8990e307
LW
3516
3517 /* Get the rest if it looks like a package qualifier */
3518
a0d0e21e 3519 if (*s == '\'' || *s == ':' && s[1] == ':') {
c3e0f903 3520 STRLEN morelen;
3280af22 3521 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
c3e0f903
GS
3522 TRUE, &morelen);
3523 if (!morelen)
cea2e8a9 3524 Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
ec2ab091 3525 *s == '\'' ? "'" : "::");
c3e0f903 3526 len += morelen;
a0d0e21e 3527 }
8990e307 3528
3280af22
NIS
3529 if (PL_expect == XOPERATOR) {
3530 if (PL_bufptr == PL_linestart) {
3531 PL_curcop->cop_line--;
cea2e8a9 3532 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3280af22 3533 PL_curcop->cop_line++;
463ee0b2
LW
3534 }
3535 else
54310121 3536 no_op("Bareword",s);
463ee0b2 3537 }
8990e307 3538
c3e0f903
GS
3539 /* Look for a subroutine with this name in current package,
3540 unless name is "Foo::", in which case Foo is a bearword
3541 (and a package name). */
3542
3543 if (len > 2 &&
3280af22 3544 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
c3e0f903 3545 {
599cee73 3546 if (ckWARN(WARN_UNSAFE) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
cea2e8a9 3547 Perl_warner(aTHX_ WARN_UNSAFE,
599cee73 3548 "Bareword \"%s\" refers to nonexistent package",
3280af22 3549 PL_tokenbuf);
c3e0f903 3550 len -= 2;
3280af22 3551 PL_tokenbuf[len] = '\0';
c3e0f903
GS
3552 gv = Nullgv;
3553 gvp = 0;
3554 }
3555 else {
3556 len = 0;
3557 if (!gv)
3280af22 3558 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
c3e0f903
GS
3559 }
3560
3561 /* if we saw a global override before, get the right name */
8990e307 3562
49dc05e3 3563 if (gvp) {
79cb57f6 3564 sv = newSVpvn("CORE::GLOBAL::",14);
3280af22 3565 sv_catpv(sv,PL_tokenbuf);
49dc05e3
GS
3566 }
3567 else
3280af22 3568 sv = newSVpv(PL_tokenbuf,0);
8990e307 3569
a0d0e21e
LW
3570 /* Presume this is going to be a bareword of some sort. */
3571
3572 CLINE;
49dc05e3 3573 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
a0d0e21e
LW
3574 yylval.opval->op_private = OPpCONST_BARE;
3575
c3e0f903
GS
3576 /* And if "Foo::", then that's what it certainly is. */
3577
3578 if (len)
3579 goto safe_bareword;
3580
8990e307
LW
3581 /* See if it's the indirect object for a list operator. */
3582
3280af22
NIS
3583 if (PL_oldoldbufptr &&
3584 PL_oldoldbufptr < PL_bufptr &&
3585 (PL_oldoldbufptr == PL_last_lop || PL_oldoldbufptr == PL_last_uni) &&
a0d0e21e 3586 /* NO SKIPSPACE BEFORE HERE! */
a9ef352a
GS
3587 (PL_expect == XREF ||
3588 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
a0d0e21e 3589 {
748a9306
LW
3590 bool immediate_paren = *s == '(';
3591
a0d0e21e
LW
3592 /* (Now we can afford to cross potential line boundary.) */
3593 s = skipspace(s);
3594
3595 /* Two barewords in a row may indicate method call. */
3596
834a4ddd 3597 if ((isIDFIRST_lazy(s) || *s == '$') && (tmp=intuit_method(s,gv)))
a0d0e21e
LW
3598 return tmp;
3599
3600 /* If not a declared subroutine, it's an indirect object. */
3601