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