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