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