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