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