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