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