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