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