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
utf8 substr can access memory outside PVX buffer
[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
1079 if (!e)
1080 yyerror("Missing right brace on \\x{}");
d008e5eb
GS		 1081 if (!utf) {
1082 dTHR;
1083 if (ckWARN(WARN_UTF8))
1084 warner(WARN_UTF8,
1085 "Use of \\x{} without utf8 declaration");
1086 }
a0ed51b3 1087 /* note: utf always shorter than hex */
dfe13c55
GS		 1088 d = (char*)uv_to_utf8((U8*)d,
1089 scan_hex(s + 1, e - s - 1, &len));
a0ed51b3
LW		 1090 s = e + 1;
1091
1092 }
1093 else {
1094 UV uv = (UV)scan_hex(s, 2, &len);
1095 if (utf && PL_lex_inwhat == OP_TRANS &&
1096 utf != (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
1097 {
dfe13c55 1098 d = (char*)uv_to_utf8((U8*)d, uv); /* doing a CU or UC */
a0ed51b3
LW		 1099 }
1100 else {
d008e5eb
GS		 1101 if (uv >= 127 && UTF) {
1102 dTHR;
1103 if (ckWARN(WARN_UTF8))
1104 warner(WARN_UTF8,
1105 "\\x%.*s will produce malformed UTF-8 character; use \\x{%.*s} for that",
1106 len,s,len,s);
1107 }
a0ed51b3
LW		 1108 *d++ = (char)uv;
1109 }
1110 s += len;
1111 }
79072805 1112 continue;
02aa26ce
NT		 1113
1114 /* \c is a control character */
79072805
LW		 1115 case 'c':
1116 s++;
9d116dd7
JH		 1117#ifdef EBCDIC
1118 *d = *s++;
1119 if (isLOWER(*d))
1120 *d = toUPPER(*d);
1121 *d++ = toCTRL(*d);
1122#else
bbce6d69 1123 len = *s++;
1124 *d++ = toCTRL(len);
9d116dd7 1125#endif
79072805 1126 continue;
02aa26ce
NT		 1127
1128 /* printf-style backslashes, formfeeds, newlines, etc */
79072805
LW		 1129 case 'b':
1130 *d++ = '\b';
1131 break;
1132 case 'n':
1133 *d++ = '\n';
1134 break;
1135 case 'r':
1136 *d++ = '\r';
1137 break;
1138 case 'f':
1139 *d++ = '\f';
1140 break;
1141 case 't':
1142 *d++ = '\t';
1143 break;
1144 case 'e':
1145 *d++ = '\033';
1146 break;
1147 case 'a':
1148 *d++ = '\007';
1149 break;
02aa26ce
NT		 1150 } /* end switch */
1151
79072805
LW		 1152 s++;
1153 continue;
02aa26ce
NT		 1154 } /* end if (backslash) */
1155
79072805 1156 *d++ = *s++;
02aa26ce
NT		 1157 } /* while loop to process each character */
1158
1159 /* terminate the string and set up the sv */
79072805 1160 *d = '\0';
463ee0b2 1161 SvCUR_set(sv, d - SvPVX(sv));
79072805
LW		 1162 SvPOK_on(sv);
1163
02aa26ce 1164 /* shrink the sv if we allocated more than we used */
79072805
LW		 1165 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1166 SvLEN_set(sv, SvCUR(sv) + 1);
463ee0b2 1167 Renew(SvPVX(sv), SvLEN(sv), char);
79072805 1168 }
02aa26ce 1169
9b599b2a 1170 /* return the substring (via yylval) only if we parsed anything */
3280af22
NIS		 1171 if (s > PL_bufptr) {
1172 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1173 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
b3ac6de7 1174 sv, Nullsv,
3280af22 1175 ( PL_lex_inwhat == OP_TRANS
b3ac6de7 1176 ? "tr"
3280af22 1177 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
b3ac6de7
IZ		 1178 ? "s"
1179 : "qq")));
79072805 1180 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
b3ac6de7 1181 } else
8990e307 1182 SvREFCNT_dec(sv);
79072805
LW		 1183 return s;
1184}
1185
1186/* This is the one truly awful dwimmer necessary to conflate C and sed. */
76e3520e 1187STATIC int
8ac85365 1188intuit_more(register char *s)
79072805 1189{
3280af22 1190 if (PL_lex_brackets)
79072805
LW		 1191 return TRUE;
1192 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1193 return TRUE;
1194 if (*s != '{' && *s != '[')
1195 return FALSE;
3280af22 1196 if (!PL_lex_inpat)
79072805
LW		 1197 return TRUE;
1198
1199 /* In a pattern, so maybe we have {n,m}. */
1200 if (*s == '{') {
1201 s++;
1202 if (!isDIGIT(*s))
1203 return TRUE;
1204 while (isDIGIT(*s))
1205 s++;
1206 if (*s == ',')
1207 s++;
1208 while (isDIGIT(*s))
1209 s++;
1210 if (*s == '}')
1211 return FALSE;
1212 return TRUE;
1213
1214 }
1215
1216 /* On the other hand, maybe we have a character class */
1217
1218 s++;
1219 if (*s == ']' || *s == '^')
1220 return FALSE;
1221 else {
1222 int weight = 2; /* let's weigh the evidence */
1223 char seen[256];
f27ffc4a 1224 unsigned char un_char = 255, last_un_char;
93a17b20 1225 char *send = strchr(s,']');
3280af22 1226 char tmpbuf[sizeof PL_tokenbuf * 4];
79072805
LW		 1227
1228 if (!send) /* has to be an expression */
1229 return TRUE;
1230
1231 Zero(seen,256,char);
1232 if (*s == '$')
1233 weight -= 3;
1234 else if (isDIGIT(*s)) {
1235 if (s[1] != ']') {
1236 if (isDIGIT(s[1]) && s[2] == ']')
1237 weight -= 10;
1238 }
1239 else
1240 weight -= 100;
1241 }
1242 for (; s < send; s++) {
1243 last_un_char = un_char;
1244 un_char = (unsigned char)*s;
1245 switch (*s) {
1246 case '@':
1247 case '&':
1248 case '$':
1249 weight -= seen[un_char] * 10;
1250 if (isALNUM(s[1])) {
8903cb82 1251 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
a0d0e21e 1252 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
79072805
LW		 1253 weight -= 100;
1254 else
1255 weight -= 10;
1256 }
1257 else if (*s == '$' && s[1] &&
93a17b20
LW		 1258 strchr("[#!%*<>()-=",s[1])) {
1259 if (/*{*/ strchr("])} =",s[2]))
79072805
LW		 1260 weight -= 10;
1261 else
1262 weight -= 1;
1263 }
1264 break;
1265 case '\\':
1266 un_char = 254;
1267 if (s[1]) {
93a17b20 1268 if (strchr("wds]",s[1]))
79072805
LW		 1269 weight += 100;
1270 else if (seen['\''] || seen['"'])
1271 weight += 1;
93a17b20 1272 else if (strchr("rnftbxcav",s[1]))
79072805
LW		 1273 weight += 40;
1274 else if (isDIGIT(s[1])) {
1275 weight += 40;
1276 while (s[1] && isDIGIT(s[1]))
1277 s++;
1278 }
1279 }
1280 else
1281 weight += 100;
1282 break;
1283 case '-':
1284 if (s[1] == '\\')
1285 weight += 50;
93a17b20 1286 if (strchr("aA01! ",last_un_char))
79072805 1287 weight += 30;
93a17b20 1288 if (strchr("zZ79~",s[1]))
79072805 1289 weight += 30;
f27ffc4a
GS		 1290 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1291 weight -= 5; /* cope with negative subscript */
79072805
LW		 1292 break;
1293 default:
93a17b20 1294 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
79072805
LW		 1295 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1296 char *d = tmpbuf;
1297 while (isALPHA(*s))
1298 *d++ = *s++;
1299 *d = '\0';
1300 if (keyword(tmpbuf, d - tmpbuf))
1301 weight -= 150;
1302 }
1303 if (un_char == last_un_char + 1)
1304 weight += 5;
1305 weight -= seen[un_char];
1306 break;
1307 }
1308 seen[un_char]++;
1309 }
1310 if (weight >= 0) /* probably a character class */
1311 return FALSE;
1312 }
1313
1314 return TRUE;
1315}
ffed7fef 1316
76e3520e 1317STATIC int
8ac85365 1318intuit_method(char *start, GV *gv)
a0d0e21e
LW		 1319{
1320 char *s = start + (*start == '$');
3280af22 1321 char tmpbuf[sizeof PL_tokenbuf];
a0d0e21e
LW		 1322 STRLEN len;
1323 GV* indirgv;
1324
1325 if (gv) {
b6c543e3 1326 CV *cv;
a0d0e21e
LW		 1327 if (GvIO(gv))
1328 return 0;
b6c543e3
IZ		 1329 if ((cv = GvCVu(gv))) {
1330 char *proto = SvPVX(cv);
1331 if (proto) {
1332 if (*proto == ';')
1333 proto++;
1334 if (*proto == '*')
1335 return 0;
1336 }
1337 } else
a0d0e21e
LW		 1338 gv = 0;
1339 }
8903cb82 1340 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
a0d0e21e 1341 if (*start == '$') {
3280af22 1342 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
a0d0e21e
LW		 1343 return 0;
1344 s = skipspace(s);
3280af22
NIS		 1345 PL_bufptr = start;
1346 PL_expect = XREF;
a0d0e21e
LW		 1347 return *s == '(' ? FUNCMETH : METHOD;
1348 }
1349 if (!keyword(tmpbuf, len)) {
c3e0f903
GS		 1350 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1351 len -= 2;
1352 tmpbuf[len] = '\0';
1353 goto bare_package;
1354 }
1355 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
8ebc5c01 1356 if (indirgv && GvCVu(indirgv))
a0d0e21e
LW		 1357 return 0;
1358 /* filehandle or package name makes it a method */
89bfa8cd 1359 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
a0d0e21e 1360 s = skipspace(s);
3280af22 1361 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
55497cff 1362 return 0; /* no assumptions -- "=>" quotes bearword */
c3e0f903 1363 bare_package:
3280af22 1364 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
c3e0f903 1365 newSVpv(tmpbuf,0));
3280af22
NIS		 1366 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1367 PL_expect = XTERM;
a0d0e21e 1368 force_next(WORD);
3280af22 1369 PL_bufptr = s;
a0d0e21e
LW		 1370 return *s == '(' ? FUNCMETH : METHOD;
1371 }
1372 }
1373 return 0;
1374}
1375
76e3520e 1376STATIC char*
8ac85365 1377incl_perldb(void)
a0d0e21e 1378{
3280af22 1379 if (PL_perldb) {
76e3520e 1380 char *pdb = PerlEnv_getenv("PERL5DB");
a0d0e21e
LW		 1381
1382 if (pdb)
1383 return pdb;
61bb5906 1384 SETERRNO(0,SS$_NORMAL);
a0d0e21e
LW		 1385 return "BEGIN { require 'perl5db.pl' }";
1386 }
1387 return "";
1388}
1389
1390
16d20bd9
AD		 1391/* Encoded script support. filter_add() effectively inserts a
1392 * 'pre-processing' function into the current source input stream.
1393 * Note that the filter function only applies to the current source file
1394 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1395 *
1396 * The datasv parameter (which may be NULL) can be used to pass
1397 * private data to this instance of the filter. The filter function
1398 * can recover the SV using the FILTER_DATA macro and use it to
1399 * store private buffers and state information.
1400 *
1401 * The supplied datasv parameter is upgraded to a PVIO type
1402 * and the IoDIRP field is used to store the function pointer.
1403 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1404 * private use must be set using malloc'd pointers.
1405 */
1406static int filter_debug = 0;
1407
1408SV *
8ac85365 1409filter_add(filter_t funcp, SV *datasv)
16d20bd9
AD		 1410{
1411 if (!funcp){ /* temporary handy debugging hack to be deleted */
1412 filter_debug = atoi((char*)datasv);
1413 return NULL;
1414 }
3280af22
NIS		 1415 if (!PL_rsfp_filters)
1416 PL_rsfp_filters = newAV();
16d20bd9 1417 if (!datasv)
8c52afec 1418 datasv = NEWSV(255,0);
16d20bd9
AD		 1419 if (!SvUPGRADE(datasv, SVt_PVIO))
1420 die("Can't upgrade filter_add data to SVt_PVIO");
1421 IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
1422 if (filter_debug)
3280af22
NIS		 1423 warn("filter_add func %p (%s)", funcp, SvPV(datasv,PL_na));
1424 av_unshift(PL_rsfp_filters, 1);
1425 av_store(PL_rsfp_filters, 0, datasv) ;
16d20bd9
AD		 1426 return(datasv);
1427}
1428
1429
1430/* Delete most recently added instance of this filter function. */
a0d0e21e 1431void
8ac85365 1432filter_del(filter_t funcp)
16d20bd9
AD		 1433{
1434 if (filter_debug)
ff0cee69 1435 warn("filter_del func %p", funcp);
3280af22 1436 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
16d20bd9
AD		 1437 return;
1438 /* if filter is on top of stack (usual case) just pop it off */
677ca527 1439 if (IoDIRP(FILTER_DATA(AvFILLp(PL_rsfp_filters))) == (DIR*)funcp){
3280af22 1440 sv_free(av_pop(PL_rsfp_filters));
e50aee73 1441
16d20bd9
AD		 1442 return;
1443 }
1444 /* we need to search for the correct entry and clear it */
1445 die("filter_del can only delete in reverse order (currently)");
1446}
1447
1448
1449/* Invoke the n'th filter function for the current rsfp. */
1450I32
8ac85365
NIS		 1451filter_read(int idx, SV *buf_sv, int maxlen)
1452
1453
1454 /* 0 = read one text line */
a0d0e21e 1455{
16d20bd9
AD		 1456 filter_t funcp;
1457 SV *datasv = NULL;
e50aee73 1458
3280af22 1459 if (!PL_rsfp_filters)
16d20bd9 1460 return -1;
3280af22 1461 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
16d20bd9
AD		 1462 /* Provide a default input filter to make life easy. */
1463 /* Note that we append to the line. This is handy. */
16d20bd9
AD		 1464 if (filter_debug)
1465 warn("filter_read %d: from rsfp\n", idx);
1466 if (maxlen) {
1467 /* Want a block */
1468 int len ;
1469 int old_len = SvCUR(buf_sv) ;
1470
1471 /* ensure buf_sv is large enough */
1472 SvGROW(buf_sv, old_len + maxlen) ;
3280af22
NIS		 1473 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1474 if (PerlIO_error(PL_rsfp))
37120919
AD		 1475 return -1; /* error */
1476 else
1477 return 0 ; /* end of file */
1478 }
16d20bd9
AD		 1479 SvCUR_set(buf_sv, old_len + len) ;
1480 } else {
1481 /* Want a line */
3280af22
NIS		 1482 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
1483 if (PerlIO_error(PL_rsfp))
37120919
AD		 1484 return -1; /* error */
1485 else
1486 return 0 ; /* end of file */
1487 }
16d20bd9
AD		 1488 }
1489 return SvCUR(buf_sv);
1490 }
1491 /* Skip this filter slot if filter has been deleted */
3280af22 1492 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
16d20bd9
AD		 1493 if (filter_debug)
1494 warn("filter_read %d: skipped (filter deleted)\n", idx);
1495 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1496 }
1497 /* Get function pointer hidden within datasv */
1498 funcp = (filter_t)IoDIRP(datasv);
1499 if (filter_debug)
ff0cee69 1500 warn("filter_read %d: via function %p (%s)\n",
3280af22 1501 idx, funcp, SvPV(datasv,PL_na));
16d20bd9
AD		 1502 /* Call function. The function is expected to */
1503 /* call "FILTER_READ(idx+1, buf_sv)" first. */
37120919 1504 /* Return: <0:error, =0:eof, >0:not eof */
1d583055 1505 return (*funcp)(PERL_OBJECT_THIS_ idx, buf_sv, maxlen);
16d20bd9
AD		 1506}
1507
76e3520e
GS		 1508STATIC char *
1509filter_gets(register SV *sv, register PerlIO *fp, STRLEN append)
16d20bd9 1510{
a868473f 1511#ifdef WIN32FILTER
3280af22 1512 if (!PL_rsfp_filters) {
a868473f
NIS		 1513 filter_add(win32_textfilter,NULL);
1514 }
1515#endif
3280af22 1516 if (PL_rsfp_filters) {
16d20bd9 1517
55497cff 1518 if (!append)
1519 SvCUR_set(sv, 0); /* start with empty line */
16d20bd9
AD		 1520 if (FILTER_READ(0, sv, 0) > 0)
1521 return ( SvPVX(sv) ) ;
1522 else
1523 return Nullch ;
1524 }
9d116dd7 1525 else
fd049845 1526 return (sv_gets(sv, fp, append));
a0d0e21e
LW		 1527}
1528
1529
748a9306
LW		 1530#ifdef DEBUGGING
1531 static char* exp_name[] =
a0d0e21e 1532 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "TERMBLOCK" };
748a9306 1533#endif
463ee0b2 1534
02aa26ce
NT		 1535/*
1536 yylex
1537
1538 Works out what to call the token just pulled out of the input
1539 stream. The yacc parser takes care of taking the ops we return and
1540 stitching them into a tree.
1541
1542 Returns:
1543 PRIVATEREF
1544
1545 Structure:
1546 if read an identifier
1547 if we're in a my declaration
1548 croak if they tried to say my($foo::bar)
1549 build the ops for a my() declaration
1550 if it's an access to a my() variable
1551 are we in a sort block?
1552 croak if my($a); $a <=> $b
1553 build ops for access to a my() variable
1554 if in a dq string, and they've said @foo and we can't find @foo
1555 croak
1556 build ops for a bareword
1557 if we already built the token before, use it.
1558*/
1559
2f3197b3 1560int
8ac85365 1561yylex(void)
378cc40b 1562{
11343788 1563 dTHR;
79072805 1564 register char *s;
378cc40b 1565 register char *d;
79072805 1566 register I32 tmp;
463ee0b2 1567 STRLEN len;
161b471a
NIS		 1568 GV *gv = Nullgv;
1569 GV **gvp = 0;
a687059c 1570
02aa26ce 1571 /* check if there's an identifier for us to look at */
3280af22 1572 if (PL_pending_ident) {
02aa26ce 1573 /* pit holds the identifier we read and pending_ident is reset */
3280af22
NIS		 1574 char pit = PL_pending_ident;
1575 PL_pending_ident = 0;
bbce6d69 1576
02aa26ce
NT		 1577 /* if we're in a my(), we can't allow dynamics here.
1578 $foo'bar has already been turned into $foo::bar, so
1579 just check for colons.
1580
1581 if it's a legal name, the OP is a PADANY.
1582 */
3280af22
NIS		 1583 if (PL_in_my) {
1584 if (strchr(PL_tokenbuf,':'))
1585 croak(no_myglob,PL_tokenbuf);
02aa26ce 1586
bbce6d69 1587 yylval.opval = newOP(OP_PADANY, 0);
3280af22 1588 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
bbce6d69 1589 return PRIVATEREF;
1590 }
1591
02aa26ce
NT		 1592 /*
1593 build the ops for accesses to a my() variable.
1594
1595 Deny my($a) or my($b) in a sort block, *if* $a or $b is
1596 then used in a comparison. This catches most, but not
1597 all cases. For instance, it catches
1598 sort { my($a); $a <=> $b }
1599 but not
1600 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
1601 (although why you'd do that is anyone's guess).
1602 */
1603
3280af22 1604 if (!strchr(PL_tokenbuf,':')) {
a863c7d1 1605#ifdef USE_THREADS
54b9620d 1606 /* Check for single character per-thread SVs */
3280af22
NIS		 1607 if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
1608 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
1609 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
554b3eca 1610 {
2faa37cc 1611 yylval.opval = newOP(OP_THREADSV, 0);
a863c7d1
MB		 1612 yylval.opval->op_targ = tmp;
1613 return PRIVATEREF;
1614 }
1615#endif /* USE_THREADS */
3280af22 1616 if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
02aa26ce 1617 /* if it's a sort block and they're naming $a or $b */
3280af22
NIS		 1618 if (PL_last_lop_op == OP_SORT &&
1619 PL_tokenbuf[0] == '$' &&
1620 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
1621 && !PL_tokenbuf[2])
bbce6d69 1622 {
3280af22
NIS		 1623 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
1624 d < PL_bufend && *d != '\n';
a863c7d1
MB		 1625 d++)
1626 {
1627 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
1628 croak("Can't use \"my %s\" in sort comparison",
3280af22 1629 PL_tokenbuf);
a863c7d1 1630 }
bbce6d69 1631 }
1632 }
bbce6d69 1633
a863c7d1
MB		 1634 yylval.opval = newOP(OP_PADANY, 0);
1635 yylval.opval->op_targ = tmp;
1636 return PRIVATEREF;
1637 }
bbce6d69 1638 }
1639
02aa26ce
NT		 1640 /*
1641 Whine if they've said @foo in a doublequoted string,
1642 and @foo isn't a variable we can find in the symbol
1643 table.
1644 */
3280af22
NIS		 1645 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
1646 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
1647 if (!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
46fc3d4c 1648 yyerror(form("In string, %s now must be written as \\%s",
3280af22 1649 PL_tokenbuf, PL_tokenbuf));
bbce6d69 1650 }
1651
02aa26ce 1652 /* build ops for a bareword */
3280af22 1653 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
bbce6d69 1654 yylval.opval->op_private = OPpCONST_ENTERED;
3280af22
NIS		 1655 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
1656 ((PL_tokenbuf[0] == '$') ? SVt_PV
1657 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
bbce6d69 1658 : SVt_PVHV));
1659 return WORD;
1660 }
1661
02aa26ce
NT		 1662 /* no identifier pending identification */
1663
3280af22 1664 switch (PL_lex_state) {
79072805
LW		 1665#ifdef COMMENTARY
1666 case LEX_NORMAL: /* Some compilers will produce faster */
1667 case LEX_INTERPNORMAL: /* code if we comment these out. */
1668 break;
1669#endif
1670
02aa26ce 1671 /* when we're already built the next token, just pull it out the queue */
79072805 1672 case LEX_KNOWNEXT:
3280af22
NIS		 1673 PL_nexttoke--;
1674 yylval = PL_nextval[PL_nexttoke];
1675 if (!PL_nexttoke) {
1676 PL_lex_state = PL_lex_defer;
1677 PL_expect = PL_lex_expect;
1678 PL_lex_defer = LEX_NORMAL;
463ee0b2 1679 }
3280af22 1680 return(PL_nexttype[PL_nexttoke]);
79072805 1681
02aa26ce 1682 /* interpolated case modifiers like \L \U, including \Q and \E.
3280af22 1683 when we get here, PL_bufptr is at the \
02aa26ce 1684 */
79072805
LW		 1685 case LEX_INTERPCASEMOD:
1686#ifdef DEBUGGING
3280af22 1687 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
463ee0b2 1688 croak("panic: INTERPCASEMOD");
79072805 1689#endif
02aa26ce 1690 /* handle \E or end of string */
3280af22 1691 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
a0d0e21e 1692 char oldmod;
02aa26ce
NT		 1693
1694 /* if at a \E */
3280af22
NIS		 1695 if (PL_lex_casemods) {
1696 oldmod = PL_lex_casestack[--PL_lex_casemods];
1697 PL_lex_casestack[PL_lex_casemods] = '\0';
02aa26ce 1698
3280af22
NIS		 1699 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
1700 PL_bufptr += 2;
1701 PL_lex_state = LEX_INTERPCONCAT;
a0d0e21e 1702 }
79072805
LW		 1703 return ')';
1704 }
3280af22
NIS		 1705 if (PL_bufptr != PL_bufend)
1706 PL_bufptr += 2;
1707 PL_lex_state = LEX_INTERPCONCAT;
79072805
LW		 1708 return yylex();
1709 }
1710 else {
3280af22 1711 s = PL_bufptr + 1;
79072805
LW		 1712 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
1713 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
a0d0e21e 1714 if (strchr("LU", *s) &&
3280af22 1715 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
a0d0e21e 1716 {
3280af22 1717 PL_lex_casestack[--PL_lex_casemods] = '\0';
a0d0e21e
LW		 1718 return ')';
1719 }
3280af22
NIS		 1720 if (PL_lex_casemods > 10) {
1721 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
1722 if (newlb != PL_lex_casestack) {
a0d0e21e 1723 SAVEFREEPV(newlb);
3280af22 1724 PL_lex_casestack = newlb;
a0d0e21e
LW		 1725 }
1726 }
3280af22
NIS		 1727 PL_lex_casestack[PL_lex_casemods++] = *s;
1728 PL_lex_casestack[PL_lex_casemods] = '\0';
1729 PL_lex_state = LEX_INTERPCONCAT;
1730 PL_nextval[PL_nexttoke].ival = 0;
79072805
LW		 1731 force_next('(');
1732 if (*s == 'l')
3280af22 1733 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
79072805 1734 else if (*s == 'u')
3280af22 1735 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
79072805 1736 else if (*s == 'L')
3280af22 1737 PL_nextval[PL_nexttoke].ival = OP_LC;
79072805 1738 else if (*s == 'U')
3280af22 1739 PL_nextval[PL_nexttoke].ival = OP_UC;
a0d0e21e 1740 else if (*s == 'Q')
3280af22 1741 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
79072805 1742 else
463ee0b2 1743 croak("panic: yylex");
3280af22 1744 PL_bufptr = s + 1;
79072805 1745 force_next(FUNC);
3280af22
NIS		 1746 if (PL_lex_starts) {
1747 s = PL_bufptr;
1748 PL_lex_starts = 0;
79072805
LW		 1749 Aop(OP_CONCAT);
1750 }
1751 else
1752 return yylex();
1753 }
1754
55497cff 1755 case LEX_INTERPPUSH:
1756 return sublex_push();
1757
79072805 1758 case LEX_INTERPSTART:
3280af22 1759 if (PL_bufptr == PL_bufend)
79072805 1760 return sublex_done();
3280af22
NIS		 1761 PL_expect = XTERM;
1762 PL_lex_dojoin = (*PL_bufptr == '@');
1763 PL_lex_state = LEX_INTERPNORMAL;
1764 if (PL_lex_dojoin) {
1765 PL_nextval[PL_nexttoke].ival = 0;
79072805 1766 force_next(',');
554b3eca 1767#ifdef USE_THREADS
533c011a
NIS		 1768 PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
1769 PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
554b3eca
MB		 1770 force_next(PRIVATEREF);
1771#else
a0d0e21e 1772 force_ident("\"", '$');
554b3eca 1773#endif /* USE_THREADS */
3280af22 1774 PL_nextval[PL_nexttoke].ival = 0;
79072805 1775 force_next('$');
3280af22 1776 PL_nextval[PL_nexttoke].ival = 0;
79072805 1777 force_next('(');
3280af22 1778 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
79072805
LW		 1779 force_next(FUNC);
1780 }
3280af22
NIS		 1781 if (PL_lex_starts++) {
1782 s = PL_bufptr;
79072805
LW		 1783 Aop(OP_CONCAT);
1784 }
68dc0745 1785 return yylex();
79072805
LW		 1786
1787 case LEX_INTERPENDMAYBE:
3280af22
NIS		 1788 if (intuit_more(PL_bufptr)) {
1789 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
79072805
LW		 1790 break;
1791 }
1792 /* FALL THROUGH */
1793
1794 case LEX_INTERPEND:
3280af22
NIS		 1795 if (PL_lex_dojoin) {
1796 PL_lex_dojoin = FALSE;
1797 PL_lex_state = LEX_INTERPCONCAT;
79072805
LW		 1798 return ')';
1799 }
1800 /* FALLTHROUGH */
1801 case LEX_INTERPCONCAT:
1802#ifdef DEBUGGING
3280af22 1803 if (PL_lex_brackets)
463ee0b2 1804 croak("panic: INTERPCONCAT");
79072805 1805#endif
3280af22 1806 if (PL_bufptr == PL_bufend)
79072805
LW		 1807 return sublex_done();
1808
3280af22
NIS		 1809 if (SvIVX(PL_linestr) == '\'') {
1810 SV *sv = newSVsv(PL_linestr);
1811 if (!PL_lex_inpat)
76e3520e 1812 sv = tokeq(sv);
3280af22 1813 else if ( PL_hints & HINT_NEW_RE )
b3ac6de7 1814 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
79072805 1815 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3280af22 1816 s = PL_bufend;
79072805
LW		 1817 }
1818 else {
3280af22 1819 s = scan_const(PL_bufptr);
79072805 1820 if (*s == '\\')
3280af22 1821 PL_lex_state = LEX_INTERPCASEMOD;
79072805 1822 else
3280af22 1823 PL_lex_state = LEX_INTERPSTART;
79072805
LW		 1824 }
1825
3280af22
NIS		 1826 if (s != PL_bufptr) {
1827 PL_nextval[PL_nexttoke] = yylval;
1828 PL_expect = XTERM;
79072805 1829 force_next(THING);
3280af22 1830 if (PL_lex_starts++)
79072805
LW		 1831 Aop(OP_CONCAT);
1832 else {
3280af22 1833 PL_bufptr = s;
79072805
LW		 1834 return yylex();
1835 }
1836 }
1837
1838 return yylex();
a0d0e21e 1839 case LEX_FORMLINE:
3280af22
NIS		 1840 PL_lex_state = LEX_NORMAL;
1841 s = scan_formline(PL_bufptr);
1842 if (!PL_lex_formbrack)
a0d0e21e
LW		 1843 goto rightbracket;
1844 OPERATOR(';');
79072805
LW		 1845 }
1846
3280af22
NIS		 1847 s = PL_bufptr;
1848 PL_oldoldbufptr = PL_oldbufptr;
1849 PL_oldbufptr = s;
79072805 1850 DEBUG_p( {
3280af22 1851 PerlIO_printf(PerlIO_stderr(), "### Tokener expecting %s at %s\n", exp_name[PL_expect], s);
79072805 1852 } )
463ee0b2
LW		 1853
1854 retry:
378cc40b
LW		 1855 switch (*s) {
1856 default:
a0ed51b3
LW		 1857 /*
1858 * Note: we try to be careful never to call the isXXX_utf8() functions unless we're
1859 * pretty sure we've seen the beginning of a UTF-8 character (that is, the two high
1860 * bits are set). Otherwise we risk loading in the heavy-duty SWASHINIT and SWASHGET
1861 * routines unnecessarily. You will see this not just here but throughout this file.
1862 */
1863 if (UTF && (*s & 0xc0) == 0x80) {
dfe13c55 1864 if (isIDFIRST_utf8((U8*)s))
a0ed51b3
LW		 1865 goto keylookup;
1866 }
1867 croak("Unrecognized character \\x%02X", *s & 255);
e929a76b
LW		 1868 case 4:
1869 case 26:
1870 goto fake_eof; /* emulate EOF on ^D or ^Z */
378cc40b 1871 case 0:
3280af22
NIS		 1872 if (!PL_rsfp) {
1873 PL_last_uni = 0;
1874 PL_last_lop = 0;
1875 if (PL_lex_brackets)
463ee0b2 1876 yyerror("Missing right bracket");
79072805 1877 TOKEN(0);
463ee0b2 1878 }
3280af22 1879 if (s++ < PL_bufend)
a687059c 1880 goto retry; /* ignore stray nulls */
3280af22
NIS		 1881 PL_last_uni = 0;
1882 PL_last_lop = 0;
1883 if (!PL_in_eval && !PL_preambled) {
1884 PL_preambled = TRUE;
1885 sv_setpv(PL_linestr,incl_perldb());
1886 if (SvCUR(PL_linestr))
1887 sv_catpv(PL_linestr,";");
1888 if (PL_preambleav){
1889 while(AvFILLp(PL_preambleav) >= 0) {
1890 SV *tmpsv = av_shift(PL_preambleav);
1891 sv_catsv(PL_linestr, tmpsv);
1892 sv_catpv(PL_linestr, ";");
91b7def8 1893 sv_free(tmpsv);
1894 }
3280af22
NIS		 1895 sv_free((SV*)PL_preambleav);
1896 PL_preambleav = NULL;
91b7def8 1897 }
3280af22
NIS		 1898 if (PL_minus_n || PL_minus_p) {
1899 sv_catpv(PL_linestr, "LINE: while (<>) {");
1900 if (PL_minus_l)
1901 sv_catpv(PL_linestr,"chomp;");
1902 if (PL_minus_a) {
8fd239a7
CS		 1903 GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
1904 if (gv)
1905 GvIMPORTED_AV_on(gv);
3280af22
NIS		 1906 if (PL_minus_F) {
1907 if (strchr("/'\"", *PL_splitstr)
1908 && strchr(PL_splitstr + 1, *PL_splitstr))
1909 sv_catpvf(PL_linestr, "@F=split(%s);", PL_splitstr);
54310121 1910 else {
1911 char delim;
1912 s = "'~#\200\1'"; /* surely one char is unused...*/
3280af22 1913 while (s[1] && strchr(PL_splitstr, *s)) s++;
54310121 1914 delim = *s;
3280af22 1915 sv_catpvf(PL_linestr, "@F=split(%s%c",
46fc3d4c 1916 "q" + (delim == '\''), delim);
3280af22 1917 for (s = PL_splitstr; *s; s++) {
54310121 1918 if (*s == '\\')
3280af22
NIS		 1919 sv_catpvn(PL_linestr, "\\", 1);
1920 sv_catpvn(PL_linestr, s, 1);
54310121 1921 }
3280af22 1922 sv_catpvf(PL_linestr, "%c);", delim);
54310121 1923 }
2304df62
AD		 1924 }
1925 else
3280af22 1926 sv_catpv(PL_linestr,"@F=split(' ');");
2304df62 1927 }
79072805 1928 }
3280af22
NIS		 1929 sv_catpv(PL_linestr, "\n");
1930 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1931 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1932 if (PERLDB_LINE && PL_curstash != PL_debstash) {
a0d0e21e
LW		 1933 SV *sv = NEWSV(85,0);
1934
1935 sv_upgrade(sv, SVt_PVMG);
3280af22
NIS		 1936 sv_setsv(sv,PL_linestr);
1937 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
a0d0e21e 1938 }
79072805 1939 goto retry;
a687059c 1940 }
e929a76b 1941 do {
3280af22 1942 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
e929a76b 1943 fake_eof:
3280af22
NIS		 1944 if (PL_rsfp) {
1945 if (PL_preprocess && !PL_in_eval)
1946 (void)PerlProc_pclose(PL_rsfp);
1947 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
1948 PerlIO_clearerr(PL_rsfp);
395c3793 1949 else
3280af22
NIS		 1950 (void)PerlIO_close(PL_rsfp);
1951 PL_rsfp = Nullfp;
4a9ae47a 1952 PL_doextract = FALSE;
395c3793 1953 }
3280af22
NIS		 1954 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
1955 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
1956 sv_catpv(PL_linestr,";}");
1957 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1958 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1959 PL_minus_n = PL_minus_p = 0;
e929a76b
LW		 1960 goto retry;
1961 }
3280af22
NIS		 1962 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1963 sv_setpv(PL_linestr,"");
79072805 1964 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
378cc40b 1965 }
3280af22 1966 if (PL_doextract) {
a0d0e21e 1967 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
3280af22 1968 PL_doextract = FALSE;
a0d0e21e
LW		 1969
1970 /* Incest with pod. */
1971 if (*s == '=' && strnEQ(s, "=cut", 4)) {
3280af22
NIS		 1972 sv_setpv(PL_linestr, "");
1973 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1974 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1975 PL_doextract = FALSE;
a0d0e21e
LW		 1976 }
1977 }
463ee0b2 1978 incline(s);
3280af22
NIS		 1979 } while (PL_doextract);
1980 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
1981 if (PERLDB_LINE && PL_curstash != PL_debstash) {
79072805 1982 SV *sv = NEWSV(85,0);
a687059c 1983
93a17b20 1984 sv_upgrade(sv, SVt_PVMG);
3280af22
NIS		 1985 sv_setsv(sv,PL_linestr);
1986 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
a687059c 1987 }
3280af22
NIS		 1988 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1989 if (PL_curcop->cop_line == 1) {
1990 while (s < PL_bufend && isSPACE(*s))
79072805 1991 s++;
a0d0e21e 1992 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
79072805 1993 s++;
44a8e56a 1994 d = Nullch;
3280af22 1995 if (!PL_in_eval) {
44a8e56a 1996 if (*s == '#' && *(s+1) == '!')
1997 d = s + 2;
1998#ifdef ALTERNATE_SHEBANG
1999 else {
2000 static char as[] = ALTERNATE_SHEBANG;
2001 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2002 d = s + (sizeof(as) - 1);
2003 }
2004#endif /* ALTERNATE_SHEBANG */
2005 }
2006 if (d) {
b8378b72 2007 char *ipath;
774d564b 2008 char *ipathend;
b8378b72 2009
774d564b 2010 while (isSPACE(*d))
b8378b72
CS		 2011 d++;
2012 ipath = d;
774d564b 2013 while (*d && !isSPACE(*d))
2014 d++;
2015 ipathend = d;
2016
2017#ifdef ARG_ZERO_IS_SCRIPT
2018 if (ipathend > ipath) {
2019 /*
2020 * HP-UX (at least) sets argv[0] to the script name,
2021 * which makes $^X incorrect. And Digital UNIX and Linux,
2022 * at least, set argv[0] to the basename of the Perl
2023 * interpreter. So, having found "#!", we'll set it right.
2024 */
2025 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
2026 assert(SvPOK(x) || SvGMAGICAL(x));
6b88bc9c 2027 if (sv_eq(x, GvSV(PL_curcop->cop_filegv))) {
774d564b 2028 sv_setpvn(x, ipath, ipathend - ipath);
9607fc9c 2029 SvSETMAGIC(x);
2030 }
774d564b 2031 TAINT_NOT; /* $^X is always tainted, but that's OK */
8ebc5c01 2032 }
774d564b 2033#endif /* ARG_ZERO_IS_SCRIPT */
b8378b72
CS		 2034
2035 /*
2036 * Look for options.
2037 */
748a9306
LW		 2038 d = instr(s,"perl -");
2039 if (!d)
2040 d = instr(s,"perl");
44a8e56a 2041#ifdef ALTERNATE_SHEBANG
2042 /*
2043 * If the ALTERNATE_SHEBANG on this system starts with a
2044 * character that can be part of a Perl expression, then if
2045 * we see it but not "perl", we're probably looking at the
2046 * start of Perl code, not a request to hand off to some
2047 * other interpreter. Similarly, if "perl" is there, but
2048 * not in the first 'word' of the line, we assume the line
2049 * contains the start of the Perl program.
44a8e56a 2050 */
2051 if (d && *s != '#') {
774d564b 2052 char *c = ipath;
44a8e56a 2053 while (*c && !strchr("; \t\r\n\f\v#", *c))
2054 c++;
2055 if (c < d)
2056 d = Nullch; /* "perl" not in first word; ignore */
2057 else
2058 *s = '#'; /* Don't try to parse shebang line */
2059 }
774d564b 2060#endif /* ALTERNATE_SHEBANG */
748a9306 2061 if (!d &&
44a8e56a 2062 *s == '#' &&
774d564b 2063 ipathend > ipath &&
3280af22 2064 !PL_minus_c &&
748a9306 2065 !instr(s,"indir") &&
3280af22 2066 instr(PL_origargv[0],"perl"))
748a9306 2067 {
9f68db38 2068 char **newargv;
9f68db38 2069
774d564b 2070 *ipathend = '\0';
2071 s = ipathend + 1;
3280af22 2072 while (s < PL_bufend && isSPACE(*s))
9f68db38 2073 s++;
3280af22
NIS		 2074 if (s < PL_bufend) {
2075 Newz(899,newargv,PL_origargc+3,char*);
9f68db38 2076 newargv[1] = s;
3280af22 2077 while (s < PL_bufend && !isSPACE(*s))
9f68db38
LW		 2078 s++;
2079 *s = '\0';
3280af22 2080 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
9f68db38
LW		 2081 }
2082 else
3280af22 2083 newargv = PL_origargv;
774d564b 2084 newargv[0] = ipath;
2085 execv(ipath, newargv);
2086 croak("Can't exec %s", ipath);
9f68db38 2087 }
748a9306 2088 if (d) {
3280af22
NIS		 2089 U32 oldpdb = PL_perldb;
2090 bool oldn = PL_minus_n;
2091 bool oldp = PL_minus_p;
748a9306
LW		 2092
2093 while (*d && !isSPACE(*d)) d++;
89bfa8cd 2094 while (*d == ' ' || *d == '\t') d++;
748a9306
LW		 2095
2096 if (*d++ == '-') {
8cc95fdb 2097 do {
2098 if (*d == 'M' || *d == 'm') {
2099 char *m = d;
2100 while (*d && !isSPACE(*d)) d++;
2101 croak("Too late for \"-%.*s\" option",
2102 (int)(d - m), m);
2103 }
2104 d = moreswitches(d);
2105 } while (d);
84902520 2106 if (PERLDB_LINE && !oldpdb ||
3280af22 2107 ( PL_minus_n || PL_minus_p ) && !(oldn || oldp) )
b084f20b 2108 /* if we have already added "LINE: while (<>) {",
2109 we must not do it again */
748a9306 2110 {
3280af22
NIS		 2111 sv_setpv(PL_linestr, "");
2112 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2113 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2114 PL_preambled = FALSE;
84902520 2115 if (PERLDB_LINE)
3280af22 2116 (void)gv_fetchfile(PL_origfilename);
748a9306
LW		 2117 goto retry;
2118 }
a0d0e21e 2119 }
79072805 2120 }
9f68db38 2121 }
79072805 2122 }
3280af22
NIS		 2123 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2124 PL_bufptr = s;
2125 PL_lex_state = LEX_FORMLINE;
a0d0e21e 2126 return yylex();
ae986130 2127 }
378cc40b 2128 goto retry;
4fdae800 2129 case '\r':
6a27c188 2130#ifdef PERL_STRICT_CR
54310121 2131 warn("Illegal character \\%03o (carriage return)", '\r');
2132 croak(
2133 "(Maybe you didn't strip carriage returns after a network transfer?)\n");
a868473f 2134#endif
4fdae800 2135 case ' ': case '\t': case '\f': case 013:
378cc40b
LW		 2136 s++;
2137 goto retry;
378cc40b 2138 case '#':
e929a76b 2139 case '\n':
3280af22
NIS		 2140 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2141 d = PL_bufend;
a687059c 2142 while (s < d && *s != '\n')
378cc40b 2143 s++;
0f85fab0 2144 if (s < d)
378cc40b 2145 s++;
463ee0b2 2146 incline(s);
3280af22
NIS		 2147 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2148 PL_bufptr = s;
2149 PL_lex_state = LEX_FORMLINE;
a0d0e21e 2150 return yylex();
a687059c 2151 }
378cc40b 2152 }
a687059c 2153 else {
378cc40b 2154 *s = '\0';
3280af22 2155 PL_bufend = s;
a687059c 2156 }
378cc40b
LW		 2157 goto retry;
2158 case '-':
79072805 2159 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
378cc40b 2160 s++;
3280af22 2161 PL_bufptr = s;
748a9306
LW		 2162 tmp = *s++;
2163
3280af22 2164 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
748a9306
LW		 2165 s++;
2166
2167 if (strnEQ(s,"=>",2)) {
3280af22 2168 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
748a9306
LW		 2169 OPERATOR('-'); /* unary minus */
2170 }
3280af22
NIS		 2171 PL_last_uni = PL_oldbufptr;
2172 PL_last_lop_op = OP_FTEREAD; /* good enough */
748a9306 2173 switch (tmp) {
79072805
LW		 2174 case 'r': FTST(OP_FTEREAD);
2175 case 'w': FTST(OP_FTEWRITE);
2176 case 'x': FTST(OP_FTEEXEC);
2177 case 'o': FTST(OP_FTEOWNED);
2178 case 'R': FTST(OP_FTRREAD);
2179 case 'W': FTST(OP_FTRWRITE);
2180 case 'X': FTST(OP_FTREXEC);
2181 case 'O': FTST(OP_FTROWNED);
2182 case 'e': FTST(OP_FTIS);
2183 case 'z': FTST(OP_FTZERO);
2184 case 's': FTST(OP_FTSIZE);
2185 case 'f': FTST(OP_FTFILE);
2186 case 'd': FTST(OP_FTDIR);
2187 case 'l': FTST(OP_FTLINK);
2188 case 'p': FTST(OP_FTPIPE);
2189 case 'S': FTST(OP_FTSOCK);
2190 case 'u': FTST(OP_FTSUID);
2191 case 'g': FTST(OP_FTSGID);
2192 case 'k': FTST(OP_FTSVTX);
2193 case 'b': FTST(OP_FTBLK);
2194 case 'c': FTST(OP_FTCHR);
2195 case 't': FTST(OP_FTTTY);
2196 case 'T': FTST(OP_FTTEXT);
2197 case 'B': FTST(OP_FTBINARY);
85e6fe83
LW		 2198 case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2199 case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2200 case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
378cc40b 2201 default:
ff0cee69 2202 croak("Unrecognized file test: -%c", (int)tmp);
378cc40b
LW		 2203 break;
2204 }
2205 }
a687059c
LW		 2206 tmp = *s++;
2207 if (*s == tmp) {
2208 s++;
3280af22 2209 if (PL_expect == XOPERATOR)
79072805
LW		 2210 TERM(POSTDEC);
2211 else
2212 OPERATOR(PREDEC);
2213 }
2214 else if (*s == '>') {
2215 s++;
2216 s = skipspace(s);
2217 if (isIDFIRST(*s)) {
a0d0e21e 2218 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
463ee0b2 2219 TOKEN(ARROW);
79072805 2220 }
748a9306
LW		 2221 else if (*s == '$')
2222 OPERATOR(ARROW);
463ee0b2 2223 else
748a9306 2224 TERM(ARROW);
a687059c 2225 }
3280af22 2226 if (PL_expect == XOPERATOR)
79072805
LW		 2227 Aop(OP_SUBTRACT);
2228 else {
3280af22 2229 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2f3197b3 2230 check_uni();
79072805 2231 OPERATOR('-'); /* unary minus */
2f3197b3 2232 }
79072805 2233
378cc40b 2234 case '+':
a687059c
LW		 2235 tmp = *s++;
2236 if (*s == tmp) {
378cc40b 2237 s++;
3280af22 2238 if (PL_expect == XOPERATOR)
79072805
LW		 2239 TERM(POSTINC);
2240 else
2241 OPERATOR(PREINC);
378cc40b 2242 }
3280af22 2243 if (PL_expect == XOPERATOR)
79072805
LW		 2244 Aop(OP_ADD);
2245 else {
3280af22 2246 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2f3197b3 2247 check_uni();
a687059c 2248 OPERATOR('+');
2f3197b3 2249 }
a687059c 2250
378cc40b 2251 case '*':
3280af22
NIS		 2252 if (PL_expect != XOPERATOR) {
2253 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2254 PL_expect = XOPERATOR;
2255 force_ident(PL_tokenbuf, '*');
2256 if (!*PL_tokenbuf)
a0d0e21e 2257 PREREF('*');
79072805 2258 TERM('*');
a687059c 2259 }
79072805
LW		 2260 s++;
2261 if (*s == '*') {
a687059c 2262 s++;
79072805 2263 PWop(OP_POW);
a687059c 2264 }
79072805
LW		 2265 Mop(OP_MULTIPLY);
2266
378cc40b 2267 case '%':
3280af22 2268 if (PL_expect == XOPERATOR) {
bbce6d69 2269 ++s;
2270 Mop(OP_MODULO);
a687059c 2271 }
3280af22
NIS		 2272 PL_tokenbuf[0] = '%';
2273 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2274 if (!PL_tokenbuf[1]) {
2275 if (s == PL_bufend)
bbce6d69 2276 yyerror("Final % should be \\% or %name");
2277 PREREF('%');
a687059c 2278 }
3280af22 2279 PL_pending_ident = '%';
bbce6d69 2280 TERM('%');
a687059c 2281
378cc40b 2282 case '^':
79072805 2283 s++;
a0d0e21e 2284 BOop(OP_BIT_XOR);
79072805 2285 case '[':
3280af22 2286 PL_lex_brackets++;
79072805 2287 /* FALL THROUGH */
378cc40b 2288 case '~':
378cc40b 2289 case ',':
378cc40b
LW		 2290 tmp = *s++;
2291 OPERATOR(tmp);
a0d0e21e
LW		 2292 case ':':
2293 if (s[1] == ':') {
2294 len = 0;
2295 goto just_a_word;
2296 }
2297 s++;
2298 OPERATOR(':');
8990e307
LW		 2299 case '(':
2300 s++;
3280af22
NIS		 2301 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
2302 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
a0d0e21e 2303 else
3280af22 2304 PL_expect = XTERM;
a0d0e21e 2305 TOKEN('(');
378cc40b 2306 case ';':
3280af22
NIS		 2307 if (PL_curcop->cop_line < PL_copline)
2308 PL_copline = PL_curcop->cop_line;
378cc40b
LW		 2309 tmp = *s++;
2310 OPERATOR(tmp);
2311 case ')':
378cc40b 2312 tmp = *s++;
16d20bd9
AD		 2313 s = skipspace(s);
2314 if (*s == '{')
2315 PREBLOCK(tmp);
378cc40b 2316 TERM(tmp);
79072805
LW		 2317 case ']':
2318 s++;
3280af22 2319 if (PL_lex_brackets <= 0)
463ee0b2
LW		 2320 yyerror("Unmatched right bracket");
2321 else
3280af22
NIS		 2322 --PL_lex_brackets;
2323 if (PL_lex_state == LEX_INTERPNORMAL) {
2324 if (PL_lex_brackets == 0) {
a0d0e21e 2325 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
3280af22 2326 PL_lex_state = LEX_INTERPEND;
79072805
LW		 2327 }
2328 }
4633a7c4 2329 TERM(']');
79072805
LW		 2330 case '{':
2331 leftbracket:
79072805 2332 s++;
3280af22
NIS		 2333 if (PL_lex_brackets > 100) {
2334 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
2335 if (newlb != PL_lex_brackstack) {
8990e307 2336 SAVEFREEPV(newlb);
3280af22 2337 PL_lex_brackstack = newlb;
8990e307
LW		 2338 }
2339 }
3280af22 2340 switch (PL_expect) {
a0d0e21e 2341 case XTERM:
3280af22 2342 if (PL_lex_formbrack) {
a0d0e21e
LW		 2343 s--;
2344 PRETERMBLOCK(DO);
2345 }
3280af22
NIS		 2346 if (PL_oldoldbufptr == PL_last_lop)
2347 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
a0d0e21e 2348 else
3280af22 2349 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
79072805 2350 OPERATOR(HASHBRACK);
a0d0e21e 2351 case XOPERATOR:
3280af22 2352 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
748a9306 2353 s++;
44a8e56a 2354 d = s;
3280af22
NIS		 2355 PL_tokenbuf[0] = '\0';
2356 if (d < PL_bufend && *d == '-') {
2357 PL_tokenbuf[0] = '-';
44a8e56a 2358 d++;
3280af22 2359 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
44a8e56a 2360 d++;
2361 }
3280af22
NIS		 2362 if (d < PL_bufend && isIDFIRST(*d)) {
2363 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
8903cb82 2364 FALSE, &len);
3280af22 2365 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
748a9306
LW		 2366 d++;
2367 if (*d == '}') {
3280af22 2368 char minus = (PL_tokenbuf[0] == '-');
44a8e56a 2369 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2370 if (minus)
2371 force_next('-');
748a9306
LW		 2372 }
2373 }
2374 /* FALL THROUGH */
2375 case XBLOCK:
3280af22
NIS		 2376 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
2377 PL_expect = XSTATE;
a0d0e21e
LW		 2378 break;
2379 case XTERMBLOCK:
3280af22
NIS		 2380 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2381 PL_expect = XSTATE;
a0d0e21e
LW		 2382 break;
2383 default: {
2384 char *t;
3280af22
NIS		 2385 if (PL_oldoldbufptr == PL_last_lop)
2386 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
a0d0e21e 2387 else
3280af22 2388 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
a0d0e21e 2389 s = skipspace(s);
09ecc4b6 2390 if (*s == '}')
a0d0e21e 2391 OPERATOR(HASHBRACK);
b8a4b1be
GS		 2392 /* This hack serves to disambiguate a pair of curlies
2393 * as being a block or an anon hash. Normally, expectation
2394 * determines that, but in cases where we're not in a
2395 * position to expect anything in particular (like inside
2396 * eval"") we have to resolve the ambiguity. This code
2397 * covers the case where the first term in the curlies is a
2398 * quoted string. Most other cases need to be explicitly
2399 * disambiguated by prepending a `+' before the opening
2400 * curly in order to force resolution as an anon hash.
2401 *
2402 * XXX should probably propagate the outer expectation
2403 * into eval"" to rely less on this hack, but that could
2404 * potentially break current behavior of eval"".
2405 * GSAR 97-07-21
2406 */
2407 t = s;
2408 if (*s == '\'' || *s == '"' || *s == '`') {
2409 /* common case: get past first string, handling escapes */
3280af22 2410 for (t++; t < PL_bufend && *t != *s;)
b8a4b1be
GS		 2411 if (*t++ == '\\' && (*t == '\\' || *t == *s))
2412 t++;
2413 t++;
a0d0e21e 2414 }
b8a4b1be 2415 else if (*s == 'q') {
3280af22 2416 if (++t < PL_bufend
b8a4b1be 2417 && (!isALNUM(*t)
3280af22 2418 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
b8a4b1be
GS		 2419 && !isALNUM(*t)))) {
2420 char *tmps;
2421 char open, close, term;
2422 I32 brackets = 1;
2423
3280af22 2424 while (t < PL_bufend && isSPACE(*t))
b8a4b1be
GS		 2425 t++;
2426 term = *t;
2427 open = term;
2428 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
2429 term = tmps[5];
2430 close = term;
2431 if (open == close)
3280af22
NIS		 2432 for (t++; t < PL_bufend; t++) {
2433 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
b8a4b1be 2434 t++;
6d07e5e9 2435 else if (*t == open)
b8a4b1be
GS		 2436 break;
2437 }
2438 else
3280af22
NIS		 2439 for (t++; t < PL_bufend; t++) {
2440 if (*t == '\\' && t+1 < PL_bufend)
b8a4b1be 2441 t++;
6d07e5e9 2442 else if (*t == close && --brackets <= 0)
b8a4b1be
GS		 2443 break;
2444 else if (*t == open)
2445 brackets++;
2446 }
2447 }
2448 t++;
a0d0e21e 2449 }
b8a4b1be 2450 else if (isALPHA(*s)) {
3280af22 2451 for (t++; t < PL_bufend && isALNUM(*t); t++) ;
a0d0e21e 2452 }
3280af22 2453 while (t < PL_bufend && isSPACE(*t))
a0d0e21e 2454 t++;
b8a4b1be
GS		 2455 /* if comma follows first term, call it an anon hash */
2456 /* XXX it could be a comma expression with loop modifiers */
3280af22 2457 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
b8a4b1be 2458 || (*t == '=' && t[1] == '>')))
a0d0e21e 2459 OPERATOR(HASHBRACK);
3280af22
NIS		 2460 if (PL_expect == XREF)
2461 PL_expect = XTERM;
a0d0e21e 2462 else {
3280af22
NIS		 2463 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
2464 PL_expect = XSTATE;
a0d0e21e 2465 }
8990e307 2466 }
a0d0e21e 2467 break;
463ee0b2 2468 }
3280af22 2469 yylval.ival = PL_curcop->cop_line;
79072805 2470 if (isSPACE(*s) || *s == '#')
3280af22 2471 PL_copline = NOLINE; /* invalidate current command line number */
79072805 2472 TOKEN('{');
378cc40b 2473 case '}':
79072805
LW		 2474 rightbracket:
2475 s++;
3280af22 2476 if (PL_lex_brackets <= 0)
463ee0b2
LW		 2477 yyerror("Unmatched right bracket");
2478 else
3280af22
NIS		 2479 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
2480 if (PL_lex_brackets < PL_lex_formbrack)
2481 PL_lex_formbrack = 0;
2482 if (PL_lex_state == LEX_INTERPNORMAL) {
2483 if (PL_lex_brackets == 0) {
2484 if (PL_lex_fakebrack) {
2485 PL_lex_state = LEX_INTERPEND;
2486 PL_bufptr = s;
79072805
LW		 2487 return yylex(); /* ignore fake brackets */
2488 }
fa83b5b6 2489 if (*s == '-' && s[1] == '>')
3280af22 2490 PL_lex_state = LEX_INTERPENDMAYBE;
fa83b5b6 2491 else if (*s != '[' && *s != '{')
3280af22 2492 PL_lex_state = LEX_INTERPEND;
79072805
LW		 2493 }
2494 }
3280af22
NIS		 2495 if (PL_lex_brackets < PL_lex_fakebrack) {
2496 PL_bufptr = s;
2497 PL_lex_fakebrack = 0;
748a9306
LW		 2498 return yylex(); /* ignore fake brackets */
2499 }
79072805
LW		 2500 force_next('}');
2501 TOKEN(';');
378cc40b
LW		 2502 case '&':
2503 s++;
2504 tmp = *s++;
2505 if (tmp == '&')
a0d0e21e 2506 AOPERATOR(ANDAND);
378cc40b 2507 s--;
3280af22 2508 if (PL_expect == XOPERATOR) {
599cee73 2509 if (ckWARN(WARN_SEMICOLON) && isALPHA(*s) && PL_bufptr == PL_linestart) {
3280af22 2510 PL_curcop->cop_line--;
599cee73 2511 warner(WARN_SEMICOLON, warn_nosemi);
3280af22 2512 PL_curcop->cop_line++;
463ee0b2 2513 }
79072805 2514 BAop(OP_BIT_AND);
463ee0b2 2515 }
79072805 2516
3280af22
NIS		 2517 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2518 if (*PL_tokenbuf) {
2519 PL_expect = XOPERATOR;
2520 force_ident(PL_tokenbuf, '&');
463ee0b2 2521 }
79072805
LW		 2522 else
2523 PREREF('&');
c07a80fd 2524 yylval.ival = (OPpENTERSUB_AMPER<<8);
79072805
LW		 2525 TERM('&');
2526
378cc40b
LW		 2527 case '|':
2528 s++;
2529 tmp = *s++;
2530 if (tmp == '|')
a0d0e21e 2531 AOPERATOR(OROR);
378cc40b 2532 s--;
79072805 2533 BOop(OP_BIT_OR);
378cc40b
LW		 2534 case '=':
2535 s++;
2536 tmp = *s++;
2537 if (tmp == '=')
79072805
LW		 2538 Eop(OP_EQ);
2539 if (tmp == '>')
2540 OPERATOR(',');
378cc40b 2541 if (tmp == '~')
79072805 2542 PMop(OP_MATCH);
599cee73
PM		 2543 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
2544 warner(WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
378cc40b 2545 s--;
3280af22
NIS		 2546 if (PL_expect == XSTATE && isALPHA(tmp) &&
2547 (s == PL_linestart+1 || s[-2] == '\n') )
748a9306 2548 {
3280af22
NIS		 2549 if (PL_in_eval && !PL_rsfp) {
2550 d = PL_bufend;
a5f75d66
AD		 2551 while (s < d) {
2552 if (*s++ == '\n') {
2553 incline(s);
2554 if (strnEQ(s,"=cut",4)) {
2555 s = strchr(s,'\n');
2556 if (s)
2557 s++;
2558 else
2559 s = d;
2560 incline(s);
2561 goto retry;
2562 }
2563 }
2564 }
2565 goto retry;
2566 }
3280af22
NIS		 2567 s = PL_bufend;
2568 PL_doextract = TRUE;
a0d0e21e
LW		 2569 goto retry;
2570 }
3280af22 2571 if (PL_lex_brackets < PL_lex_formbrack) {
a0d0e21e 2572 char *t;
51882d45 2573#ifdef PERL_STRICT_CR
a0d0e21e 2574 for (t = s; *t == ' ' || *t == '\t'; t++) ;
51882d45
GS		 2575#else
2576 for (t = s; *t == ' ' || *t == '\t' || *t == '\r'; t++) ;
2577#endif
a0d0e21e
LW		 2578 if (*t == '\n' || *t == '#') {
2579 s--;
3280af22 2580 PL_expect = XBLOCK;
a0d0e21e
LW		 2581 goto leftbracket;
2582 }
79072805 2583 }
a0d0e21e
LW		 2584 yylval.ival = 0;
2585 OPERATOR(ASSIGNOP);
378cc40b
LW		 2586 case '!':
2587 s++;
2588 tmp = *s++;
2589 if (tmp == '=')
79072805 2590 Eop(OP_NE);
378cc40b 2591 if (tmp == '~')
79072805 2592 PMop(OP_NOT);
378cc40b
LW		 2593 s--;
2594 OPERATOR('!');
2595 case '<':
3280af22 2596 if (PL_expect != XOPERATOR) {
93a17b20 2597 if (s[1] != '<' && !strchr(s,'>'))
2f3197b3 2598 check_uni();
79072805
LW		 2599 if (s[1] == '<')
2600 s = scan_heredoc(s);
2601 else
2602 s = scan_inputsymbol(s);
2603 TERM(sublex_start());
378cc40b
LW		 2604 }
2605 s++;
2606 tmp = *s++;
2607 if (tmp == '<')
79072805 2608 SHop(OP_LEFT_SHIFT);
395c3793
LW		 2609 if (tmp == '=') {
2610 tmp = *s++;
2611 if (tmp == '>')
79072805 2612 Eop(OP_NCMP);
395c3793 2613 s--;
79072805 2614 Rop(OP_LE);
395c3793 2615 }
378cc40b 2616 s--;
79072805 2617 Rop(OP_LT);
378cc40b
LW		 2618 case '>':
2619 s++;
2620 tmp = *s++;
2621 if (tmp == '>')
79072805 2622 SHop(OP_RIGHT_SHIFT);
378cc40b 2623 if (tmp == '=')
79072805 2624 Rop(OP_GE);
378cc40b 2625 s--;
79072805 2626 Rop(OP_GT);
378cc40b
LW		 2627
2628 case '$':
bbce6d69 2629 CLINE;
2630
3280af22
NIS		 2631 if (PL_expect == XOPERATOR) {
2632 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2633 PL_expect = XTERM;
a0d0e21e 2634 depcom();
bbce6d69 2635 return ','; /* grandfather non-comma-format format */
a0d0e21e 2636 }
8990e307 2637 }
a0d0e21e 2638
6cef1e77 2639 if (s[1] == '#' && (isALPHA(s[2]) || strchr("_{$:+-", s[2]))) {
3280af22
NIS		 2640 if (PL_expect == XOPERATOR)
2641 no_op("Array length", PL_bufptr);
2642 PL_tokenbuf[0] = '@';
2643 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
8903cb82 2644 FALSE);
3280af22 2645 if (!PL_tokenbuf[1])
a0d0e21e 2646 PREREF(DOLSHARP);
3280af22
NIS		 2647 PL_expect = XOPERATOR;
2648 PL_pending_ident = '#';
463ee0b2 2649 TOKEN(DOLSHARP);
79072805 2650 }
bbce6d69 2651
3280af22
NIS		 2652 if (PL_expect == XOPERATOR)
2653 no_op("Scalar", PL_bufptr);
2654 PL_tokenbuf[0] = '$';
2655 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2656 if (!PL_tokenbuf[1]) {
2657 if (s == PL_bufend)
bbce6d69 2658 yyerror("Final $ should be \\$ or $name");
2659 PREREF('$');
8990e307 2660 }
a0d0e21e 2661
bbce6d69 2662 /* This kludge not intended to be bulletproof. */
3280af22 2663 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
bbce6d69 2664 yylval.opval = newSVOP(OP_CONST, 0,
3280af22 2665 newSViv((IV)PL_compiling.cop_arybase));
bbce6d69 2666 yylval.opval->op_private = OPpCONST_ARYBASE;
2667 TERM(THING);
2668 }
2669
ff68c719 2670 d = s;
3280af22 2671 if (PL_lex_state == LEX_NORMAL)
ff68c719 2672 s = skipspace(s);
2673
3280af22 2674 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
bbce6d69 2675 char *t;
2676 if (*s == '[') {
3280af22 2677 PL_tokenbuf[0] = '@';
599cee73 2678 if (ckWARN(WARN_SYNTAX)) {
bbce6d69 2679 for(t = s + 1;
2680 isSPACE(*t) || isALNUM(*t) || *t == '$';
2681 t++) ;
a0d0e21e 2682 if (*t++ == ',') {
3280af22
NIS		 2683 PL_bufptr = skipspace(PL_bufptr);
2684 while (t < PL_bufend && *t != ']')
bbce6d69 2685 t++;
599cee73
PM		 2686 warner(WARN_SYNTAX,
2687 "Multidimensional syntax %.*s not supported",
2688 (t - PL_bufptr) + 1, PL_bufptr);
a0d0e21e
LW		 2689 }
2690 }
bbce6d69 2691 }
2692 else if (*s == '{') {
3280af22 2693 PL_tokenbuf[0] = '%';
599cee73 2694 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
bbce6d69 2695 (t = strchr(s, '}')) && (t = strchr(t, '=')))
2696 {
3280af22 2697 char tmpbuf[sizeof PL_tokenbuf];
a0d0e21e
LW		 2698 STRLEN len;
2699 for (t++; isSPACE(*t); t++) ;
748a9306 2700 if (isIDFIRST(*t)) {
8903cb82 2701 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
748a9306 2702 if (*t != '(' && perl_get_cv(tmpbuf, FALSE))
599cee73
PM		 2703 warner(WARN_SYNTAX,
2704 "You need to quote \"%s\"", tmpbuf);
748a9306 2705 }
93a17b20
LW		 2706 }
2707 }
2f3197b3 2708 }
bbce6d69 2709
3280af22
NIS		 2710 PL_expect = XOPERATOR;
2711 if (PL_lex_state == LEX_NORMAL && isSPACE(*d)) {
2712 bool islop = (PL_last_lop == PL_oldoldbufptr);
2713 if (!islop || PL_last_lop_op == OP_GREPSTART)
2714 PL_expect = XOPERATOR;
bbce6d69 2715 else if (strchr("$@\"'`q", *s))
3280af22 2716 PL_expect = XTERM; /* e.g. print $fh "foo" */
bbce6d69 2717 else if (strchr("&*<%", *s) && isIDFIRST(s[1]))
3280af22 2718 PL_expect = XTERM; /* e.g. print $fh &sub */
68dc0745 2719 else if (isIDFIRST(*s)) {
3280af22 2720 char tmpbuf[sizeof PL_tokenbuf];
8903cb82 2721 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
84902520
TB		 2722 if (tmp = keyword(tmpbuf, len)) {
2723 /* binary operators exclude handle interpretations */
2724 switch (tmp) {
2725 case -KEY_x:
2726 case -KEY_eq:
2727 case -KEY_ne:
2728 case -KEY_gt:
2729 case -KEY_lt:
2730 case -KEY_ge:
2731 case -KEY_le:
2732 case -KEY_cmp:
2733 break;
2734 default:
3280af22 2735 PL_expect = XTERM; /* e.g. print $fh length() */
84902520
TB		 2736 break;
2737 }
2738 }
68dc0745 2739 else {
2740 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
2741 if (gv && GvCVu(gv))
3280af22 2742 PL_expect = XTERM; /* e.g. print $fh subr() */
93a17b20 2743 }
93a17b20 2744 }
bbce6d69 2745 else if (isDIGIT(*s))
3280af22 2746 PL_expect = XTERM; /* e.g. print $fh 3 */
bbce6d69 2747 else if (*s == '.' && isDIGIT(s[1]))
3280af22 2748 PL_expect = XTERM; /* e.g. print $fh .3 */
bbce6d69 2749 else if (strchr("/?-+", *s) && !isSPACE(s[1]))
3280af22 2750 PL_expect = XTERM; /* e.g. print $fh -1 */
bbce6d69 2751 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]))
3280af22 2752 PL_expect = XTERM; /* print $fh <<"EOF" */
bbce6d69 2753 }
3280af22 2754 PL_pending_ident = '$';
79072805 2755 TOKEN('$');
378cc40b
LW		 2756
2757 case '@':
3280af22 2758 if (PL_expect == XOPERATOR)
bbce6d69 2759 no_op("Array", s);
3280af22
NIS		 2760 PL_tokenbuf[0] = '@';
2761 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2762 if (!PL_tokenbuf[1]) {
2763 if (s == PL_bufend)
bbce6d69 2764 yyerror("Final @ should be \\@ or @name");
2765 PREREF('@');
2766 }
3280af22 2767 if (PL_lex_state == LEX_NORMAL)
ff68c719 2768 s = skipspace(s);
3280af22 2769 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
bbce6d69 2770 if (*s == '{')
3280af22 2771 PL_tokenbuf[0] = '%';
a0d0e21e
LW		 2772
2773 /* Warn about @ where they meant $. */
599cee73 2774 if (ckWARN(WARN_SYNTAX)) {
a0d0e21e
LW		 2775 if (*s == '[' || *s == '{') {
2776 char *t = s + 1;
2777 while (*t && (isALNUM(*t) || strchr(" \t$#+-'\"", *t)))
2778 t++;
2779 if (*t == '}' || *t == ']') {
2780 t++;
3280af22 2781 PL_bufptr = skipspace(PL_bufptr);
599cee73
PM		 2782 warner(WARN_SYNTAX,
2783 "Scalar value %.*s better written as $%.*s",
3280af22 2784 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
a0d0e21e 2785 }
93a17b20
LW		 2786 }
2787 }
463ee0b2 2788 }
3280af22 2789 PL_pending_ident = '@';
79072805 2790 TERM('@');
378cc40b
LW		 2791
2792 case '/': /* may either be division or pattern */
2793 case '?': /* may either be conditional or pattern */
3280af22 2794 if (PL_expect != XOPERATOR) {
c277df42 2795 /* Disable warning on "study /blah/" */
3280af22
NIS		 2796 if (PL_oldoldbufptr == PL_last_uni
2797 && (*PL_last_uni != 's' || s - PL_last_uni < 5
2798 || memNE(PL_last_uni, "study", 5) || isALNUM(PL_last_uni[5])))
c277df42 2799 check_uni();
8782bef2 2800 s = scan_pat(s,OP_MATCH);
79072805 2801 TERM(sublex_start());
378cc40b
LW		 2802 }
2803 tmp = *s++;
a687059c 2804 if (tmp == '/')
79072805 2805 Mop(OP_DIVIDE);
378cc40b
LW		 2806 OPERATOR(tmp);
2807
2808 case '.':
51882d45
GS		 2809 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
2810#ifdef PERL_STRICT_CR
2811 && s[1] == '\n'
2812#else
2813 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
2814#endif
2815 && (s == PL_linestart || s[-1] == '\n') )
2816 {
3280af22
NIS		 2817 PL_lex_formbrack = 0;
2818 PL_expect = XSTATE;
79072805
LW		 2819 goto rightbracket;
2820 }
3280af22 2821 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
378cc40b 2822 tmp = *s++;
a687059c
LW		 2823 if (*s == tmp) {
2824 s++;
2f3197b3
LW		 2825 if (*s == tmp) {
2826 s++;
79072805 2827 yylval.ival = OPf_SPECIAL;
2f3197b3
LW		 2828 }
2829 else
79072805 2830 yylval.ival = 0;
378cc40b 2831 OPERATOR(DOTDOT);
a687059c 2832 }
3280af22 2833 if (PL_expect != XOPERATOR)
2f3197b3 2834 check_uni();
79072805 2835 Aop(OP_CONCAT);
378cc40b
LW		 2836 }
2837 /* FALL THROUGH */
2838 case '0': case '1': case '2': case '3': case '4':
2839 case '5': case '6': case '7': case '8': case '9':
79072805 2840 s = scan_num(s);
3280af22 2841 if (PL_expect == XOPERATOR)
8990e307 2842 no_op("Number",s);
79072805
LW		 2843 TERM(THING);
2844
2845 case '\'':
8990e307 2846 s = scan_str(s);
3280af22
NIS		 2847 if (PL_expect == XOPERATOR) {
2848 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2849 PL_expect = XTERM;
a0d0e21e
LW		 2850 depcom();
2851 return ','; /* grandfather non-comma-format format */
2852 }
463ee0b2 2853 else
8990e307 2854 no_op("String",s);
463ee0b2 2855 }
79072805 2856 if (!s)
85e6fe83 2857 missingterm((char*)0);
79072805
LW		 2858 yylval.ival = OP_CONST;
2859 TERM(sublex_start());
2860
2861 case '"':
8990e307 2862 s = scan_str(s);
3280af22
NIS		 2863 if (PL_expect == XOPERATOR) {
2864 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2865 PL_expect = XTERM;
a0d0e21e
LW		 2866 depcom();
2867 return ','; /* grandfather non-comma-format format */
2868 }
463ee0b2 2869 else
8990e307 2870 no_op("String",s);
463ee0b2 2871 }
79072805 2872 if (!s)
85e6fe83 2873 missingterm((char*)0);
4633a7c4 2874 yylval.ival = OP_CONST;
3280af22 2875 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
a0ed51b3 2876 if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
4633a7c4
LW		 2877 yylval.ival = OP_STRINGIFY;
2878 break;
2879 }
2880 }
79072805
LW		 2881 TERM(sublex_start());
2882
2883 case '`':
2884 s = scan_str(s);
3280af22 2885 if (PL_expect == XOPERATOR)
8990e307 2886 no_op("Backticks",s);
79072805 2887 if (!s)
85e6fe83 2888 missingterm((char*)0);
79072805
LW		 2889 yylval.ival = OP_BACKTICK;
2890 set_csh();
2891 TERM(sublex_start());
2892
2893 case '\\':
2894 s++;
599cee73
PM		 2895 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
2896 warner(WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
2897 *s, *s);
3280af22 2898 if (PL_expect == XOPERATOR)
8990e307 2899 no_op("Backslash",s);
79072805
LW		 2900 OPERATOR(REFGEN);
2901
2902 case 'x':
3280af22 2903 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
79072805
LW		 2904 s++;
2905 Mop(OP_REPEAT);
2f3197b3 2906 }
79072805
LW		 2907 goto keylookup;
2908
378cc40b 2909 case '_':
79072805
LW		 2910 case 'a': case 'A':
2911 case 'b': case 'B':
2912 case 'c': case 'C':
2913 case 'd': case 'D':
2914 case 'e': case 'E':
2915 case 'f': case 'F':
2916 case 'g': case 'G':
2917 case 'h': case 'H':
2918 case 'i': case 'I':
2919 case 'j': case 'J':
2920 case 'k': case 'K':
2921 case 'l': case 'L':
2922 case 'm': case 'M':
2923 case 'n': case 'N':
2924 case 'o': case 'O':
2925 case 'p': case 'P':
2926 case 'q': case 'Q':
2927 case 'r': case 'R':
2928 case 's': case 'S':
2929 case 't': case 'T':
2930 case 'u': case 'U':
2931 case 'v': case 'V':
2932 case 'w': case 'W':
2933 case 'X':
2934 case 'y': case 'Y':
2935 case 'z': case 'Z':
2936
49dc05e3 2937 keylookup: {
161b471a
NIS		 2938 gv = Nullgv;
2939 gvp = 0;
49dc05e3 2940
3280af22
NIS		 2941 PL_bufptr = s;
2942 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
8ebc5c01 2943
2944 /* Some keywords can be followed by any delimiter, including ':' */
3280af22
NIS		 2945 tmp = (len == 1 && strchr("msyq", PL_tokenbuf[0]) ||
2946 len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
2947 (PL_tokenbuf[0] == 'q' &&
2948 strchr("qwxr", PL_tokenbuf[1]))));
8ebc5c01 2949
2950 /* x::* is just a word, unless x is "CORE" */
3280af22 2951 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
4633a7c4
LW		 2952 goto just_a_word;
2953
3643fb5f 2954 d = s;
3280af22 2955 while (d < PL_bufend && isSPACE(*d))
3643fb5f
CS		 2956 d++; /* no comments skipped here, or s### is misparsed */
2957
2958 /* Is this a label? */
3280af22
NIS		 2959 if (!tmp && PL_expect == XSTATE
2960 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
8ebc5c01 2961 s = d + 1;
3280af22 2962 yylval.pval = savepv(PL_tokenbuf);
8ebc5c01 2963 CLINE;
2964 TOKEN(LABEL);
3643fb5f
CS		 2965 }
2966
2967 /* Check for keywords */
3280af22 2968 tmp = keyword(PL_tokenbuf, len);
748a9306
LW		 2969
2970 /* Is this a word before a => operator? */
748a9306
LW		 2971 if (strnEQ(d,"=>",2)) {
2972 CLINE;
3280af22 2973 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
748a9306
LW		 2974 yylval.opval->op_private = OPpCONST_BARE;
2975 TERM(WORD);
2976 }
2977
a0d0e21e 2978 if (tmp < 0) { /* second-class keyword? */
56f7f34b
CS		 2979 GV *ogv = Nullgv; /* override (winner) */
2980 GV *hgv = Nullgv; /* hidden (loser) */
3280af22 2981 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
56f7f34b 2982 CV *cv;
3280af22 2983 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
56f7f34b
CS		 2984 (cv = GvCVu(gv)))
2985 {
2986 if (GvIMPORTED_CV(gv))
2987 ogv = gv;
2988 else if (! CvMETHOD(cv))
2989 hgv = gv;
2990 }
2991 if (!ogv &&
3280af22
NIS		 2992 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
2993 (gv = *gvp) != (GV*)&PL_sv_undef &&
56f7f34b
CS		 2994 GvCVu(gv) && GvIMPORTED_CV(gv))
2995 {
2996 ogv = gv;
2997 }
2998 }
2999 if (ogv) {
3000 tmp = 0; /* overridden by import or by GLOBAL */
6e7b2336
GS		 3001 }
3002 else if (gv && !gvp
3003 && -tmp==KEY_lock /* XXX generalizable kludge */
3280af22 3004 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
6e7b2336
GS		 3005 {
3006 tmp = 0; /* any sub overrides "weak" keyword */
a0d0e21e 3007 }
56f7f34b
CS		 3008 else { /* no override */
3009 tmp = -tmp;
3010 gv = Nullgv;
3011 gvp = 0;
4944e2f7
GS		 3012 if (ckWARN(WARN_AMBIGUOUS) && hgv
3013 && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
599cee73
PM		 3014 warner(WARN_AMBIGUOUS,
3015 "Ambiguous call resolved as CORE::%s(), %s",
2f3ca594 3016 GvENAME(hgv), "qualify as such or use &");
49dc05e3 3017 }
a0d0e21e
LW		 3018 }
3019
3020 reserved_word:
3021 switch (tmp) {
79072805
LW		 3022
3023 default: /* not a keyword */
93a17b20 3024 just_a_word: {
96e4d5b1 3025 SV *sv;
3280af22 3026 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
8990e307
LW		 3027
3028 /* Get the rest if it looks like a package qualifier */
3029
a0d0e21e 3030 if (*s == '\'' || *s == ':' && s[1] == ':') {
c3e0f903 3031 STRLEN morelen;
3280af22 3032 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
c3e0f903
GS		 3033 TRUE, &morelen);
3034 if (!morelen)
3280af22 3035 croak("Bad name after %s%s", PL_tokenbuf,
ec2ab091 3036 *s == '\'' ? "'" : "::");
c3e0f903 3037 len += morelen;
a0d0e21e 3038 }
8990e307 3039
3280af22
NIS		 3040 if (PL_expect == XOPERATOR) {
3041 if (PL_bufptr == PL_linestart) {
3042 PL_curcop->cop_line--;
599cee73 3043 warner(WARN_SEMICOLON, warn_nosemi);
3280af22 3044 PL_curcop->cop_line++;
463ee0b2
LW		 3045 }
3046 else
54310121 3047 no_op("Bareword",s);
463ee0b2 3048 }
8990e307 3049
c3e0f903
GS		 3050 /* Look for a subroutine with this name in current package,
3051 unless name is "Foo::", in which case Foo is a bearword
3052 (and a package name). */
3053
3054 if (len > 2 &&
3280af22 3055 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
c3e0f903 3056 {
599cee73
PM		 3057 if (ckWARN(WARN_UNSAFE) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3058 warner(WARN_UNSAFE,
3059 "Bareword \"%s\" refers to nonexistent package",
3280af22 3060 PL_tokenbuf);
c3e0f903 3061 len -= 2;
3280af22 3062 PL_tokenbuf[len] = '\0';
c3e0f903
GS		 3063 gv = Nullgv;
3064 gvp = 0;
3065 }
3066 else {
3067 len = 0;
3068 if (!gv)
3280af22 3069 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
c3e0f903
GS		 3070 }
3071
3072 /* if we saw a global override before, get the right name */
8990e307 3073
49dc05e3
GS		 3074 if (gvp) {
3075 sv = newSVpv("CORE::GLOBAL::",14);
3280af22 3076 sv_catpv(sv,PL_tokenbuf);
49dc05e3
GS		 3077 }
3078 else
3280af22 3079 sv = newSVpv(PL_tokenbuf,0);
8990e307 3080
a0d0e21e
LW		 3081 /* Presume this is going to be a bareword of some sort. */
3082
3083 CLINE;
49dc05e3 3084 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
a0d0e21e
LW		 3085 yylval.opval->op_private = OPpCONST_BARE;
3086
c3e0f903
GS		 3087 /* And if "Foo::", then that's what it certainly is. */
3088
3089 if (len)
3090 goto safe_bareword;
3091
8990e307
LW		 3092 /* See if it's the indirect object for a list operator. */
3093
3280af22
NIS		 3094 if (PL_oldoldbufptr &&
3095 PL_oldoldbufptr < PL_bufptr &&
3096 (PL_oldoldbufptr == PL_last_lop || PL_oldoldbufptr == PL_last_uni) &&
a0d0e21e 3097 /* NO SKIPSPACE BEFORE HERE! */
3280af22
NIS		 3098 (PL_expect == XREF
3099 || ((opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF
3100 || (PL_last_lop_op == OP_ENTERSUB
3101 && PL_last_proto
3102 && PL_last_proto[PL_last_proto[0] == ';' ? 1 : 0] == '*')) )
a0d0e21e 3103 {
748a9306
LW		 3104 bool immediate_paren = *s == '(';
3105
a0d0e21e
LW		 3106 /* (Now we can afford to cross potential line boundary.) */
3107 s = skipspace(s);
3108
3109 /* Two barewords in a row may indicate method call. */
3110
3111 if ((isALPHA(*s) || *s == '$') && (tmp=intuit_method(s,gv)))
3112 return tmp;
3113
3114 /* If not a declared subroutine, it's an indirect object. */
3115 /* (But it's an indir obj regardless for sort.) */
3116
3280af22 3117 if ((PL_last_lop_op == OP_SORT ||
8ebc5c01 3118 (!immediate_paren && (!gv || !GvCVu(gv))) ) &&
3280af22
NIS		 3119 (PL_last_lop_op != OP_MAPSTART && PL_last_lop_op != OP_GREPSTART)){
3120 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
748a9306 3121 goto bareword;
93a17b20
LW		 3122 }
3123 }
8990e307
LW		 3124
3125 /* If followed by a paren, it's certainly a subroutine. */
3126
3280af22 3127 PL_expect = XOPERATOR;
8990e307 3128 s = skipspace(s);
93a17b20 3129 if (*s == '(') {
79072805 3130 CLINE;
96e4d5b1 3131 if (gv && GvCVu(gv)) {
3132 for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
3133 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
3134 s = d + 1;
3135 goto its_constant;
3136 }
3137 }
3280af22
NIS		 3138 PL_nextval[PL_nexttoke].opval = yylval.opval;
3139 PL_expect = XOPERATOR;
93a17b20 3140 force_next(WORD);
c07a80fd 3141 yylval.ival = 0;
463ee0b2 3142 TOKEN('&');
79072805 3143 }
93a17b20 3144
a0d0e21e 3145 /* If followed by var or block, call it a method (unless sub) */
8990e307 3146
8ebc5c01 3147 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3280af22
NIS		 3148 PL_last_lop = PL_oldbufptr;
3149 PL_last_lop_op = OP_METHOD;
93a17b20 3150 PREBLOCK(METHOD);
463ee0b2
LW		 3151 }
3152
8990e307
LW		 3153 /* If followed by a bareword, see if it looks like indir obj. */
3154
a0d0e21e
LW		 3155 if ((isALPHA(*s) || *s == '$') && (tmp = intuit_method(s,gv)))
3156 return tmp;
93a17b20 3157
8990e307
LW		 3158 /* Not a method, so call it a subroutine (if defined) */
3159
8ebc5c01 3160 if (gv && GvCVu(gv)) {
46fc3d4c 3161 CV* cv;
748a9306 3162 if (lastchar == '-')
c2960299 3163 warn("Ambiguous use of -%s resolved as -&%s()",
3280af22
NIS		 3164 PL_tokenbuf, PL_tokenbuf);
3165 PL_last_lop = PL_oldbufptr;
3166 PL_last_lop_op = OP_ENTERSUB;
89bfa8cd 3167 /* Check for a constant sub */
46fc3d4c 3168 cv = GvCV(gv);
96e4d5b1 3169 if ((sv = cv_const_sv(cv))) {
3170 its_constant:
3171 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3172 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3173 yylval.opval->op_private = 0;
3174 TOKEN(WORD);
89bfa8cd 3175 }
3176
a5f75d66
AD		 3177 /* Resolve to GV now. */
3178 op_free(yylval.opval);
3179 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
4633a7c4
LW		 3180 /* Is there a prototype? */
3181 if (SvPOK(cv)) {
3182 STRLEN len;
3280af22 3183 PL_last_proto = SvPV((SV*)cv, len);
4633a7c4
LW		 3184 if (!len)
3185 TERM(FUNC0SUB);
3280af22 3186 if (strEQ(PL_last_proto, "$"))
4633a7c4 3187 OPERATOR(UNIOPSUB);
3280af22
NIS		 3188 if (*PL_last_proto == '&' && *s == '{') {
3189 sv_setpv(PL_subname,"__ANON__");
4633a7c4
LW		 3190 PREBLOCK(LSTOPSUB);
3191 }
2a841d13 3192 } else
3280af22
NIS		 3193 PL_last_proto = NULL;
3194 PL_nextval[PL_nexttoke].opval = yylval.opval;
3195 PL_expect = XTERM;
8990e307
LW		 3196 force_next(WORD);
3197 TOKEN(NOAMP);
3198 }
748a9306 3199
3280af22 3200 if (PL_hints & HINT_STRICT_SUBS &&
748a9306 3201 lastchar != '-' &&
a0d0e21e 3202 strnNE(s,"->",2) &&
3280af22
NIS		 3203 PL_last_lop_op != OP_TRUNCATE && /* S/F prototype in opcode.pl */
3204 PL_last_lop_op != OP_ACCEPT &&
3205 PL_last_lop_op != OP_PIPE_OP &&
3206 PL_last_lop_op != OP_SOCKPAIR)
a0d0e21e
LW		 3207 {
3208 warn(
3209 "Bareword \"%s\" not allowed while \"strict subs\" in use",
3280af22
NIS		 3210 PL_tokenbuf);
3211 ++PL_error_count;
85e6fe83 3212 }
8990e307
LW		 3213
3214 /* Call it a bare word */
3215
748a9306 3216 bareword:
599cee73 3217 if (ckWARN(WARN_RESERVED)) {
748a9306 3218 if (lastchar != '-') {
3280af22 3219 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
748a9306 3220 if (!*d)
599cee73 3221 warner(WARN_RESERVED, warn_reserved, PL_tokenbuf);
748a9306
LW		 3222 }
3223 }
c3e0f903
GS		 3224
3225 safe_bareword:
748a9306
LW		 3226 if (lastchar && strchr("*%&", lastchar)) {
3227 warn("Operator or semicolon missing before %c%s",
3280af22 3228 lastchar, PL_tokenbuf);
c2960299 3229 warn("Ambiguous use of %c resolved as operator %c",
748a9306
LW		 3230 lastchar, lastchar);
3231 }
93a17b20 3232 TOKEN(WORD);
79072805 3233 }
79072805 3234
68dc0745 3235 case KEY___FILE__:
46fc3d4c 3236 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3280af22 3237 newSVsv(GvSV(PL_curcop->cop_filegv)));
46fc3d4c 3238 TERM(THING);
3239
79072805 3240 case KEY___LINE__:
46fc3d4c 3241 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3280af22 3242 newSVpvf("%ld", (long)PL_curcop->cop_line));
79072805 3243 TERM(THING);
68dc0745 3244
3245 case KEY___PACKAGE__:
3246 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3280af22
NIS		 3247 (PL_curstash
3248 ? newSVsv(PL_curstname)
3249 : &PL_sv_undef));
79072805 3250 TERM(THING);
79072805 3251
e50aee73 3252 case KEY___DATA__:
79072805
LW		 3253 case KEY___END__: {
3254 GV *gv;
79072805
LW		 3255
3256 /*SUPPRESS 560*/
3280af22 3257 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
e50aee73 3258 char *pname = "main";
3280af22
NIS		 3259 if (PL_tokenbuf[2] == 'D')
3260 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
46fc3d4c 3261 gv = gv_fetchpv(form("%s::DATA", pname), TRUE, SVt_PVIO);
a5f75d66 3262 GvMULTI_on(gv);
79072805 3263 if (!GvIO(gv))
a0d0e21e 3264 GvIOp(gv) = newIO();
3280af22 3265 IoIFP(GvIOp(gv)) = PL_rsfp;
a0d0e21e
LW		 3266#if defined(HAS_FCNTL) && defined(F_SETFD)
3267 {
3280af22 3268 int fd = PerlIO_fileno(PL_rsfp);
a0d0e21e
LW		 3269 fcntl(fd,F_SETFD,fd >= 3);
3270 }
79072805 3271#endif
fd049845 3272 /* Mark this internal pseudo-handle as clean */
3273 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3280af22 3274 if (PL_preprocess)
a0d0e21e 3275 IoTYPE(GvIOp(gv)) = '|';
3280af22 3276 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
a0d0e21e 3277 IoTYPE(GvIOp(gv)) = '-';
79072805 3278 else
a0d0e21e 3279 IoTYPE(GvIOp(gv)) = '<';
3280af22 3280 PL_rsfp = Nullfp;
79072805
LW		 3281 }
3282 goto fake_eof;
e929a76b 3283 }
de3bb511 3284
8990e307 3285 case KEY_AUTOLOAD:
ed6116ce 3286 case KEY_DESTROY:
79072805
LW		 3287 case KEY_BEGIN:
3288 case KEY_END:
7d07dbc2 3289 case KEY_INIT:
3280af22
NIS		 3290 if (PL_expect == XSTATE) {
3291 s = PL_bufptr;
93a17b20 3292 goto really_sub;
79072805
LW		 3293 }
3294 goto just_a_word;
3295
a0d0e21e
LW		 3296 case KEY_CORE:
3297 if (*s == ':' && s[1] == ':') {
3298 s += 2;
748a9306 3299 d = s;
3280af22
NIS		 3300 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3301 tmp = keyword(PL_tokenbuf, len);
a0d0e21e
LW		 3302 if (tmp < 0)
3303 tmp = -tmp;
3304 goto reserved_word;
3305 }
3306 goto just_a_word;
3307
463ee0b2
LW		 3308 case KEY_abs:
3309 UNI(OP_ABS);
3310
79072805
LW		 3311 case KEY_alarm:
3312 UNI(OP_ALARM);
3313
3314 case KEY_accept:
a0d0e21e 3315 LOP(OP_ACCEPT,XTERM);
79072805 3316
463ee0b2
LW		 3317 case KEY_and:
3318 OPERATOR(ANDOP);
3319
79072805 3320 case KEY_atan2:
a0d0e21e 3321 LOP(OP_ATAN2,XTERM);
85e6fe83 3322
79072805 3323 case KEY_bind:
a0d0e21e 3324 LOP(OP_BIND,XTERM);
79072805
LW		 3325
3326 case KEY_binmode:
3327 UNI(OP_BINMODE);
3328
3329 case KEY_bless:
a0d0e21e 3330 LOP(OP_BLESS,XTERM);
79072805
LW		 3331
3332 case KEY_chop:
3333 UNI(OP_CHOP);
3334
3335 case KEY_continue:
3336 PREBLOCK(CONTINUE);
3337
3338 case KEY_chdir:
85e6fe83 3339 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
79072805
LW		 3340 UNI(OP_CHDIR);
3341
3342 case KEY_close:
3343 UNI(OP_CLOSE);
3344
3345 case KEY_closedir:
3346 UNI(OP_CLOSEDIR);
3347
3348 case KEY_cmp:
3349 Eop(OP_SCMP);
3350
3351 case KEY_caller:
3352 UNI(OP_CALLER);
3353
3354 case KEY_crypt:
3355#ifdef FCRYPT
6b88bc9c 3356 if (!PL_cryptseen++)
de3bb511 3357 init_des();
a687059c 3358#endif
a0d0e21e 3359 LOP(OP_CRYPT,XTERM);
79072805
LW		 3360
3361 case KEY_chmod:
599cee73 3362 if (ckWARN(WARN_OCTAL)) {
3280af22 3363 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
748a9306
LW		 3364 if (*d != '0' && isDIGIT(*d))
3365 yywarn("chmod: mode argument is missing initial 0");
3366 }
a0d0e21e 3367 LOP(OP_CHMOD,XTERM);
79072805
LW		 3368
3369 case KEY_chown:
a0d0e21e 3370 LOP(OP_CHOWN,XTERM);
79072805
LW		 3371
3372 case KEY_connect:
a0d0e21e 3373 LOP(OP_CONNECT,XTERM);
79072805 3374
463ee0b2
LW		 3375 case KEY_chr:
3376 UNI(OP_CHR);
3377
79072805
LW		 3378 case KEY_cos:
3379 UNI(OP_COS);
3380
3381 case KEY_chroot:
3382 UNI(OP_CHROOT);
3383
3384 case KEY_do:
3385 s = skipspace(s);
3386 if (*s == '{')
a0d0e21e 3387 PRETERMBLOCK(DO);
79072805 3388 if (*s != '\'')
a0d0e21e 3389 s = force_word(s,WORD,FALSE,TRUE,FALSE);
378cc40b 3390 OPERATOR(DO);
79072805
LW		 3391
3392 case KEY_die:
3280af22 3393 PL_hints |= HINT_BLOCK_SCOPE;
a0d0e21e 3394 LOP(OP_DIE,XTERM);
79072805
LW		 3395
3396 case KEY_defined:
3397 UNI(OP_DEFINED);
3398
3399 case KEY_delete:
a0d0e21e 3400 UNI(OP_DELETE);
79072805
LW		 3401
3402 case KEY_dbmopen:
a0d0e21e
LW		 3403 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3404 LOP(OP_DBMOPEN,XTERM);
79072805
LW		 3405
3406 case KEY_dbmclose:
3407 UNI(OP_DBMCLOSE);
3408
3409 case KEY_dump:
a0d0e21e 3410 s = force_word(s,WORD,TRUE,FALSE,FALSE);
79072805
LW		 3411 LOOPX(OP_DUMP);
3412
3413 case KEY_else:
3414 PREBLOCK(ELSE);
3415
3416 case KEY_elsif:
3280af22 3417 yylval.ival = PL_curcop->cop_line;
79072805
LW		 3418 OPERATOR(ELSIF);
3419
3420 case KEY_eq:
3421 Eop(OP_SEQ);
3422
a0d0e21e
LW		 3423 case KEY_exists:
3424 UNI(OP_EXISTS);
3425
79072805
LW		 3426 case KEY_exit:
3427 UNI(OP_EXIT);
3428
3429 case KEY_eval:
79072805 3430 s = skipspace(s);
3280af22 3431 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
463ee0b2 3432 UNIBRACK(OP_ENTEREVAL);
79072805
LW		 3433
3434 case KEY_eof:
3435 UNI(OP_EOF);
3436
3437 case KEY_exp:
3438 UNI(OP_EXP);
3439
3440 case KEY_each:
3441 UNI(OP_EACH);
3442
3443 case KEY_exec:
3444 set_csh();
a0d0e21e 3445 LOP(OP_EXEC,XREF);
79072805
LW		 3446
3447 case KEY_endhostent:
3448 FUN0(OP_EHOSTENT);
3449
3450 case KEY_endnetent:
3451 FUN0(OP_ENETENT);
3452
3453 case KEY_endservent:
3454 FUN0(OP_ESERVENT);
3455
3456 case KEY_endprotoent:
3457 FUN0(OP_EPROTOENT);
3458
3459 case KEY_endpwent:
3460 FUN0(OP_EPWENT);
3461
3462 case KEY_endgrent:
3463 FUN0(OP_EGRENT);
3464
3465 case KEY_for:
3466 case KEY_foreach:
3280af22 3467 yylval.ival = PL_curcop->cop_line;
55497cff 3468 s = skipspace(s);
3280af22 3469 if (PL_expect == XSTATE && isIDFIRST(*s)) {
55497cff 3470 char *p = s;
3280af22 3471 if ((PL_bufend - p) >= 3 &&
55497cff 3472 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3473 p += 2;
3474 p = skipspace(p);
3475 if (isIDFIRST(*p))
3476 croak("Missing $ on loop variable");
3477 }
79072805
LW		 3478 OPERATOR(FOR);
3479
3480 case KEY_formline:
a0d0e21e 3481 LOP(OP_FORMLINE,XTERM);
79072805
LW		 3482
3483 case KEY_fork:
3484 FUN0(OP_FORK);
3485
3486 case KEY_fcntl:
a0d0e21e 3487 LOP(OP_FCNTL,XTERM);
79072805
LW		 3488
3489 case KEY_fileno:
3490 UNI(OP_FILENO);
3491
3492 case KEY_flock:
a0d0e21e 3493 LOP(OP_FLOCK,XTERM);
79072805
LW		 3494
3495 case KEY_gt:
3496 Rop(OP_SGT);
3497
3498 case KEY_ge:
3499 Rop(OP_SGE);
3500
3501 case KEY_grep:
a0d0e21e 3502 LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
79072805
LW		 3503
3504 case KEY_goto:
a0d0e21e 3505 s = force_word(s,WORD,TRUE,FALSE,FALSE);
79072805
LW		 3506 LOOPX(OP_GOTO);
3507
3508 case KEY_gmtime:
3509 UNI(OP_GMTIME);
3510
3511 case KEY_getc:
3512 UNI(OP_GETC);
3513
3514 case KEY_getppid:
3515 FUN0(OP_GETPPID);
3516
3517 case KEY_getpgrp:
3518 UNI(OP_GETPGRP);
3519
3520 case KEY_getpriority:
a0d0e21e 3521 LOP(OP_GETPRIORITY,XTERM);
79072805
LW		 3522
3523 case KEY_getprotobyname:
3524 UNI(OP_GPBYNAME);
3525
3526 case KEY_getprotobynumber:
a0d0e21e 3527 LOP(OP_GPBYNUMBER,XTERM);
79072805
LW		 3528
3529 case KEY_getprotoent:
3530 FUN0(OP_GPROTOENT);
3531
3532 case KEY_getpwent:
3533 FUN0(OP_GPWENT);
3534
3535 case KEY_getpwnam:
ff68c719 3536 UNI(OP_GPWNAM);
79072805
LW		 3537
3538 case KEY_getpwuid:
ff68c719 3539 UNI(OP_GPWUID);
79072805
LW		 3540
3541 case KEY_getpeername:
3542 UNI(OP_GETPEERNAME);
3543
3544 case KEY_gethostbyname:
3545 UNI(OP_GHBYNAME);
3546
3547 case KEY_gethostbyaddr:
a0d0e21e 3548 LOP(OP_GHBYADDR,XTERM);
79072805
LW		 3549
3550 case KEY_gethostent:
3551 FUN0(OP_GHOSTENT);
3552
3553 case KEY_getnetbyname:
3554 UNI(OP_GNBYNAME);
3555
3556 case KEY_getnetbyaddr:
a0d0e21e 3557 LOP(OP_GNBYADDR,XTERM);
79072805
LW		 3558
3559 case KEY_getnetent:
3560 FUN0(OP_GNETENT);
3561
3562 case KEY_getservbyname:
a0d0e21e 3563 LOP(OP_GSBYNAME,XTERM);
79072805
LW		 3564
3565 case KEY_getservbyport:
a0d0e21e 3566 LOP(OP_GSBYPORT,XTERM);
79072805
LW		 3567
3568 case KEY_getservent:
3569 FUN0(OP_GSERVENT);
3570
3571 case KEY_getsockname:
3572 UNI(OP_GETSOCKNAME);
3573
3574 case KEY_getsockopt:
a0d0e21e 3575 LOP(OP_GSOCKOPT,XTERM);
79072805
LW		 3576
3577 case KEY_getgrent:
3578 FUN0(OP_GGRENT);
3579
3580 case KEY_getgrnam:
ff68c719 3581 UNI(OP_GGRNAM);
79072805
LW		 3582
3583 case KEY_getgrgid:
ff68c719 3584 UNI(OP_GGRGID);
79072805
LW		 3585
3586 case KEY_getlogin:
3587 FUN0(OP_GETLOGIN);
3588
93a17b20 3589 case KEY_glob:
a0d0e21e
LW		 3590 set_csh();
3591 LOP(OP_GLOB,XTERM);
93a17b20 3592
79072805
LW		 3593 case KEY_hex:
3594 UNI(OP_HEX);
3595
3596 case KEY_if:
3280af22 3597 yylval.ival = PL_curcop->cop_line;
79072805
LW		 3598 OPERATOR(IF);
3599
3600 case KEY_index:
a0d0e21e 3601 LOP(OP_INDEX,XTERM);
79072805
LW		 3602
3603 case KEY_int:
3604 UNI(OP_INT);
3605
3606 case KEY_ioctl:
a0d0e21e 3607 LOP(OP_IOCTL,XTERM);
79072805
LW		 3608
3609 case KEY_join:
a0d0e21e 3610 LOP(OP_JOIN,XTERM);
79072805
LW		 3611
3612 case KEY_keys:
3613 UNI(OP_KEYS);
3614
3615 case KEY_kill:
a0d0e21e 3616 LOP(OP_KILL,XTERM);
79072805
LW		 3617
3618 case KEY_last:
a0d0e21e 3619 s = force_word(s,WORD,TRUE,FALSE,FALSE);
79072805 3620 LOOPX(OP_LAST);