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
[win32] merge change#904 from maintbranch
[perl5.git] / toke.c
CommitLineData
a0d0e21e 1/* toke.c
a687059c 2 *
9607fc9c 3 * Copyright (c) 1991-1997, Larry Wall
a687059c 4 *
d48672a2
LW		 5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
378cc40b 7 *
a0d0e21e
LW		 8 */
9
10/*
11 * "It all comes from here, the stench and the peril." --Frodo
378cc40b
LW		 12 */
13
14#include "EXTERN.h"
15#include "perl.h"
378cc40b 16
a0d0e21e
LW		 17static void check_uni _((void));
18static void force_next _((I32 type));
89bfa8cd 19static char *force_version _((char *start));
a0d0e21e
LW		 20static char *force_word _((char *start, int token, int check_keyword, int allow_pack, int allow_tick));
21static SV *q _((SV *sv));
22static char *scan_const _((char *start));
23static char *scan_formline _((char *s));
24static char *scan_heredoc _((char *s));
8903cb82 25static char *scan_ident _((char *s, char *send, char *dest, STRLEN destlen,
26 I32 ck_uni));
a0d0e21e
LW		 27static char *scan_inputsymbol _((char *start));
28static char *scan_pat _((char *start));
29static char *scan_str _((char *start));
30static char *scan_subst _((char *start));
31static char *scan_trans _((char *start));
8903cb82 32static char *scan_word _((char *s, char *dest, STRLEN destlen,
33 int allow_package, STRLEN *slp));
a0d0e21e
LW		 34static char *skipspace _((char *s));
35static void checkcomma _((char *s, char *name, char *what));
36static void force_ident _((char *s, int kind));
37static void incline _((char *s));
38static int intuit_method _((char *s, GV *gv));
39static int intuit_more _((char *s));
40static I32 lop _((I32 f, expectation x, char *s));
41static void missingterm _((char *s));
42static void no_op _((char *what, char *s));
43static void set_csh _((void));
44static I32 sublex_done _((void));
55497cff 45static I32 sublex_push _((void));
a0d0e21e
LW		 46static I32 sublex_start _((void));
47#ifdef CRIPPLED_CC
48static int uni _((I32 f, char *s));
49#endif
fd049845 50static char * filter_gets _((SV *sv, PerlIO *fp, STRLEN append));
6d5fb7e3 51static void restore_rsfp _((void *f));
49d8d3a1
MB		 52static void restore_expect _((void *e));
53static void restore_lex_expect _((void *e));
2f3197b3 54
fc36a67e 55static char ident_too_long[] = "Identifier too long";
8903cb82 56
fd049845 57static char *linestart; /* beg. of most recently read line */
58
bbce6d69 59static char pending_ident; /* pending identifier lookup */
60
55497cff 61static struct {
62 I32 super_state; /* lexer state to save */
63 I32 sub_inwhat; /* "lex_inwhat" to use */
64 OP *sub_op; /* "lex_op" to use */
65} sublex_info;
66
79072805
LW		 67/* The following are arranged oddly so that the guard on the switch statement
68 * can get by with a single comparison (if the compiler is smart enough).
69 */
70
fb73857a 71/* #define LEX_NOTPARSING 11 is done in perl.h. */
72
55497cff 73#define LEX_NORMAL 10
74#define LEX_INTERPNORMAL 9
75#define LEX_INTERPCASEMOD 8
76#define LEX_INTERPPUSH 7
77#define LEX_INTERPSTART 6
78#define LEX_INTERPEND 5
79#define LEX_INTERPENDMAYBE 4
80#define LEX_INTERPCONCAT 3
81#define LEX_INTERPCONST 2
82#define LEX_FORMLINE 1
83#define LEX_KNOWNEXT 0
79072805 84
395c3793
LW		 85#ifdef I_FCNTL
86#include <fcntl.h>
87#endif
fe14fcc3
LW		 88#ifdef I_SYS_FILE
89#include <sys/file.h>
90#endif
395c3793 91
a790bc05 92/* XXX If this causes problems, set i_unistd=undef in the hint file. */
93#ifdef I_UNISTD
94# include <unistd.h> /* Needed for execv() */
95#endif
96
97
79072805
LW		 98#ifdef ff_next
99#undef ff_next
d48672a2
LW		 100#endif
101
79072805 102#include "keywords.h"
fe14fcc3 103
ae986130
LW		 104#ifdef CLINE
105#undef CLINE
106#endif
79072805 107#define CLINE (copline = (curcop->cop_line < copline ? curcop->cop_line : copline))
378cc40b 108
79072805
LW		 109#define TOKEN(retval) return (bufptr = s,(int)retval)
110#define OPERATOR(retval) return (expect = XTERM,bufptr = s,(int)retval)
a0d0e21e 111#define AOPERATOR(retval) return ao((expect = XTERM,bufptr = s,(int)retval))
79072805 112#define PREBLOCK(retval) return (expect = XBLOCK,bufptr = s,(int)retval)
a0d0e21e 113#define PRETERMBLOCK(retval) return (expect = XTERMBLOCK,bufptr = s,(int)retval)
79072805
LW		 114#define PREREF(retval) return (expect = XREF,bufptr = s,(int)retval)
115#define TERM(retval) return (CLINE, expect = XOPERATOR,bufptr = s,(int)retval)
463ee0b2 116#define LOOPX(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)LOOPEX)
79072805
LW		 117#define FTST(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)UNIOP)
118#define FUN0(f) return(yylval.ival = f,expect = XOPERATOR,bufptr = s,(int)FUNC0)
119#define FUN1(f) return(yylval.ival = f,expect = XOPERATOR,bufptr = s,(int)FUNC1)
a0d0e21e
LW		 120#define BOop(f) return ao((yylval.ival=f,expect = XTERM,bufptr = s,(int)BITOROP))
121#define BAop(f) return ao((yylval.ival=f,expect = XTERM,bufptr = s,(int)BITANDOP))
122#define SHop(f) return ao((yylval.ival=f,expect = XTERM,bufptr = s,(int)SHIFTOP))
123#define PWop(f) return ao((yylval.ival=f,expect = XTERM,bufptr = s,(int)POWOP))
79072805 124#define PMop(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)MATCHOP)
a0d0e21e
LW		 125#define Aop(f) return ao((yylval.ival=f,expect = XTERM,bufptr = s,(int)ADDOP))
126#define Mop(f) return ao((yylval.ival=f,expect = XTERM,bufptr = s,(int)MULOP))
79072805
LW		 127#define Eop(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)EQOP)
128#define Rop(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)RELOP)
2f3197b3 129
a687059c
LW		 130/* This bit of chicanery makes a unary function followed by
131 * a parenthesis into a function with one argument, highest precedence.
132 */
2f3197b3 133#define UNI(f) return(yylval.ival = f, \
79072805 134 expect = XTERM, \
2f3197b3
LW		 135 bufptr = s, \
136 last_uni = oldbufptr, \
a0d0e21e 137 last_lop_op = f, \
a687059c
LW		 138 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
139
79072805
LW		 140#define UNIBRACK(f) return(yylval.ival = f, \
141 bufptr = s, \
142 last_uni = oldbufptr, \
143 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
144
9f68db38 145/* grandfather return to old style */
79072805
LW		 146#define OLDLOP(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)LSTOP)
147
a0d0e21e 148static int
8ac85365 149ao(int toketype)
a0d0e21e
LW		 150{
151 if (*bufptr == '=') {
152 bufptr++;
153 if (toketype == ANDAND)
154 yylval.ival = OP_ANDASSIGN;
155 else if (toketype == OROR)
156 yylval.ival = OP_ORASSIGN;
157 toketype = ASSIGNOP;
158 }
159 return toketype;
160}
161
8990e307 162static void
8ac85365 163no_op(char *what, char *s)
463ee0b2 164{
748a9306 165 char *oldbp = bufptr;
fd049845 166 bool is_first = (oldbufptr == linestart);
68dc0745 167
8990e307 168 bufptr = s;
46fc3d4c 169 yywarn(form("%s found where operator expected", what));
748a9306 170 if (is_first)
a0d0e21e 171 warn("\t(Missing semicolon on previous line?)\n");
748a9306
LW		 172 else if (oldoldbufptr && isIDFIRST(*oldoldbufptr)) {
173 char *t;
174 for (t = oldoldbufptr; *t && (isALNUM(*t) || *t == ':'); t++) ;
175 if (t < bufptr && isSPACE(*t))
176 warn("\t(Do you need to predeclare %.*s?)\n",
177 t - oldoldbufptr, oldoldbufptr);
178
179 }
180 else
181 warn("\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
182 bufptr = oldbp;
8990e307
LW		 183}
184
185static void
8ac85365 186missingterm(char *s)
8990e307
LW		 187{
188 char tmpbuf[3];
189 char q;
190 if (s) {
191 char *nl = strrchr(s,'\n');
a868473f 192 if (nl)
8990e307
LW		 193 *nl = '\0';
194 }
195 else if (multi_close < 32 || multi_close == 127) {
196 *tmpbuf = '^';
bbce6d69 197 tmpbuf[1] = toCTRL(multi_close);
8990e307
LW		 198 s = "\\n";
199 tmpbuf[2] = '\0';
200 s = tmpbuf;
201 }
202 else {
203 *tmpbuf = multi_close;
204 tmpbuf[1] = '\0';
205 s = tmpbuf;
206 }
207 q = strchr(s,'"') ? '\'' : '"';
208 croak("Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
463ee0b2 209}
79072805
LW		 210
211void
8ac85365 212deprecate(char *s)
a0d0e21e
LW		 213{
214 if (dowarn)
215 warn("Use of %s is deprecated", s);
216}
217
218static void
8ac85365 219depcom(void)
a0d0e21e
LW		 220{
221 deprecate("comma-less variable list");
222}
223
a868473f
NIS		 224#ifdef WIN32
225
226static I32
227win32_textfilter(int idx, SV *sv, int maxlen)
228{
229 I32 count = FILTER_READ(idx+1, sv, maxlen);
230 if (count > 0 && !maxlen)
231 win32_strip_return(sv);
232 return count;
233}
234#endif
235
236
a0d0e21e 237void
8ac85365 238lex_start(SV *line)
79072805 239{
0f15f207 240 dTHR;
8990e307
LW		 241 char *s;
242 STRLEN len;
243
55497cff 244 SAVEI32(lex_dojoin);
245 SAVEI32(lex_brackets);
246 SAVEI32(lex_fakebrack);
247 SAVEI32(lex_casemods);
248 SAVEI32(lex_starts);
249 SAVEI32(lex_state);
a0d0e21e 250 SAVESPTR(lex_inpat);
55497cff 251 SAVEI32(lex_inwhat);
252 SAVEI16(curcop->cop_line);
85e6fe83
LW		 253 SAVEPPTR(bufptr);
254 SAVEPPTR(bufend);
255 SAVEPPTR(oldbufptr);
256 SAVEPPTR(oldoldbufptr);
fd049845 257 SAVEPPTR(linestart);
463ee0b2 258 SAVESPTR(linestr);
85e6fe83 259 SAVEPPTR(lex_brackstack);
a0d0e21e 260 SAVEPPTR(lex_casestack);
6d5fb7e3 261 SAVEDESTRUCTOR(restore_rsfp, rsfp);
49d8d3a1
MB		 262 SAVESPTR(lex_stuff);
263 SAVEI32(lex_defer);
264 SAVESPTR(lex_repl);
265 SAVEDESTRUCTOR(restore_expect, tokenbuf + expect); /* encode as pointer */
266 SAVEDESTRUCTOR(restore_lex_expect, tokenbuf + expect);
463ee0b2 267
79072805
LW		 268 lex_state = LEX_NORMAL;
269 lex_defer = 0;
8990e307 270 expect = XSTATE;
79072805
LW		 271 lex_brackets = 0;
272 lex_fakebrack = 0;
8990e307 273 New(899, lex_brackstack, 120, char);
a0d0e21e 274 New(899, lex_casestack, 12, char);
8990e307 275 SAVEFREEPV(lex_brackstack);
a0d0e21e 276 SAVEFREEPV(lex_casestack);
79072805 277 lex_casemods = 0;
a0d0e21e 278 *lex_casestack = '\0';
79072805
LW		 279 lex_dojoin = 0;
280 lex_starts = 0;
79072805 281 lex_stuff = Nullsv;
79072805
LW		 282 lex_repl = Nullsv;
283 lex_inpat = 0;
284 lex_inwhat = 0;
8990e307
LW		 285 linestr = line;
286 if (SvREADONLY(linestr))
287 linestr = sv_2mortal(newSVsv(linestr));
288 s = SvPV(linestr, len);
289 if (len && s[len-1] != ';') {
a0d0e21e 290 if (!(SvFLAGS(linestr) & SVs_TEMP))
8990e307
LW		 291 linestr = sv_2mortal(newSVsv(linestr));
292 sv_catpvn(linestr, "\n;", 2);
293 }
294 SvTEMP_off(linestr);
fd049845 295 oldoldbufptr = oldbufptr = bufptr = linestart = SvPVX(linestr);
79072805 296 bufend = bufptr + SvCUR(linestr);
c07a80fd 297 SvREFCNT_dec(rs);
298 rs = newSVpv("\n", 1);
8990e307 299 rsfp = 0;
79072805 300}
a687059c 301
463ee0b2 302void
8ac85365 303lex_end(void)
463ee0b2 304{
6ca21dd3 305 doextract = FALSE;
463ee0b2
LW		 306}
307
308static void
8ac85365 309restore_rsfp(void *f)
6d5fb7e3 310{
760ac839 311 PerlIO *fp = (PerlIO*)f;
6d5fb7e3 312
760ac839
LW		 313 if (rsfp == PerlIO_stdin())
314 PerlIO_clearerr(rsfp);
a5f75d66 315 else if (rsfp && (rsfp != fp))
760ac839 316 PerlIO_close(rsfp);
6d5fb7e3
CS		 317 rsfp = fp;
318}
319
320static void
49d8d3a1
MB		 321restore_expect(e)
322void *e;
323{
324 /* a safe way to store a small integer in a pointer */
325 expect = (expectation)((char *)e - tokenbuf);
326}
327
328static void
329restore_lex_expect(e)
330void *e;
331{
332 /* a safe way to store a small integer in a pointer */
333 lex_expect = (expectation)((char *)e - tokenbuf);
334}
335
336static void
8ac85365 337incline(char *s)
463ee0b2 338{
0f15f207 339 dTHR;
463ee0b2
LW		 340 char *t;
341 char *n;
342 char ch;
343 int sawline = 0;
344
345 curcop->cop_line++;
346 if (*s++ != '#')
347 return;
348 while (*s == ' ' || *s == '\t') s++;
349 if (strnEQ(s, "line ", 5)) {
350 s += 5;
351 sawline = 1;
352 }
353 if (!isDIGIT(*s))
354 return;
355 n = s;
356 while (isDIGIT(*s))
357 s++;
358 while (*s == ' ' || *s == '\t')
359 s++;
360 if (*s == '"' && (t = strchr(s+1, '"')))
361 s++;
362 else {
363 if (!sawline)
364 return; /* false alarm */
365 for (t = s; !isSPACE(*t); t++) ;
366 }
367 ch = *t;
368 *t = '\0';
369 if (t - s > 0)
370 curcop->cop_filegv = gv_fetchfile(s);
371 else
372 curcop->cop_filegv = gv_fetchfile(origfilename);
373 *t = ch;
374 curcop->cop_line = atoi(n)-1;
375}
376
8990e307 377static char *
8ac85365 378skipspace(register char *s)
a687059c 379{
11343788 380 dTHR;
85e6fe83 381 if (lex_formbrack && lex_brackets <= lex_formbrack) {
463ee0b2
LW		 382 while (s < bufend && (*s == ' ' || *s == '\t'))
383 s++;
384 return s;
385 }
386 for (;;) {
fd049845 387 STRLEN prevlen;
463ee0b2
LW		 388 while (s < bufend && isSPACE(*s))
389 s++;
390 if (s < bufend && *s == '#') {
391 while (s < bufend && *s != '\n')
392 s++;
393 if (s < bufend)
394 s++;
395 }
a0d0e21e 396 if (s < bufend || !rsfp || lex_state != LEX_NORMAL)
463ee0b2 397 return s;
fd049845 398 if ((s = filter_gets(linestr, rsfp, (prevlen = SvCUR(linestr)))) == Nullch) {
a0d0e21e 399 if (minus_n || minus_p) {
08e9d68e
DD		 400 sv_setpv(linestr,minus_p ?
401 ";}continue{print or die qq(-p destination: $!\\n)" :
402 "");
a0d0e21e
LW		 403 sv_catpv(linestr,";}");
404 minus_n = minus_p = 0;
405 }
406 else
407 sv_setpv(linestr,";");
fd049845 408 oldoldbufptr = oldbufptr = bufptr = s = linestart = SvPVX(linestr);
a0d0e21e
LW		 409 bufend = SvPVX(linestr) + SvCUR(linestr);
410 if (preprocess && !in_eval)
3028581b 411 (void)PerlProc_pclose(rsfp);
760ac839
LW		 412 else if ((PerlIO*)rsfp == PerlIO_stdin())
413 PerlIO_clearerr(rsfp);
8990e307 414 else
760ac839 415 (void)PerlIO_close(rsfp);
90248788
TB		 416 if (e_fp == rsfp)
417 e_fp = Nullfp;
8990e307 418 rsfp = Nullfp;
463ee0b2
LW		 419 return s;
420 }
fd049845 421 linestart = bufptr = s + prevlen;
422 bufend = s + SvCUR(linestr);
423 s = bufptr;
a0d0e21e 424 incline(s);
84902520 425 if (PERLDB_LINE && curstash != debstash) {
8990e307
LW		 426 SV *sv = NEWSV(85,0);
427
428 sv_upgrade(sv, SVt_PVMG);
fd049845 429 sv_setpvn(sv,bufptr,bufend-bufptr);
8990e307
LW		 430 av_store(GvAV(curcop->cop_filegv),(I32)curcop->cop_line,sv);
431 }
463ee0b2 432 }
a687059c 433}
378cc40b 434
8990e307 435static void
8ac85365 436check_uni(void) {
2f3197b3
LW		 437 char *s;
438 char ch;
a0d0e21e 439 char *t;
2f3197b3
LW		 440
441 if (oldoldbufptr != last_uni)
442 return;
443 while (isSPACE(*last_uni))
444 last_uni++;
e334a159 445 for (s = last_uni; isALNUM(*s) || *s == '-'; s++) ;
a0d0e21e
LW		 446 if ((t = strchr(s, '(')) && t < bufptr)
447 return;
2f3197b3
LW		 448 ch = *s;
449 *s = '\0';
450 warn("Warning: Use of \"%s\" without parens is ambiguous", last_uni);
451 *s = ch;
452}
453
ffed7fef
LW		 454#ifdef CRIPPLED_CC
455
456#undef UNI
ffed7fef 457#define UNI(f) return uni(f,s)
ffed7fef 458
8990e307 459static int
8ac85365 460uni(I32 f, char *s)
ffed7fef
LW		 461{
462 yylval.ival = f;
79072805 463 expect = XTERM;
ffed7fef 464 bufptr = s;
2f3197b3 465 last_uni = oldbufptr;
a0d0e21e 466 last_lop_op = f;
ffed7fef
LW		 467 if (*s == '(')
468 return FUNC1;
469 s = skipspace(s);
470 if (*s == '(')
471 return FUNC1;
472 else
473 return UNIOP;
474}
475
a0d0e21e
LW		 476#endif /* CRIPPLED_CC */
477
478#define LOP(f,x) return lop(f,x,s)
479
8990e307 480static I32
0fa19009 481lop(I32 f, expectation x, char *s)
ffed7fef 482{
0f15f207 483 dTHR;
79072805 484 yylval.ival = f;
35c8bce7 485 CLINE;
a0d0e21e 486 expect = x;
79072805 487 bufptr = s;
8990e307
LW		 488 last_lop = oldbufptr;
489 last_lop_op = f;
a0d0e21e
LW		 490 if (nexttoke)
491 return LSTOP;
79072805
LW		 492 if (*s == '(')
493 return FUNC;
494 s = skipspace(s);
495 if (*s == '(')
496 return FUNC;
497 else
498 return LSTOP;
499}
500
8990e307 501static void
8ac85365 502force_next(I32 type)
79072805
LW		 503{
504 nexttype[nexttoke] = type;
505 nexttoke++;
506 if (lex_state != LEX_KNOWNEXT) {
507 lex_defer = lex_state;
463ee0b2 508 lex_expect = expect;
79072805
LW		 509 lex_state = LEX_KNOWNEXT;
510 }
511}
512
8990e307 513static char *
15f0808c 514force_word(register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
79072805 515{
463ee0b2
LW		 516 register char *s;
517 STRLEN len;
518
519 start = skipspace(start);
520 s = start;
a0d0e21e
LW		 521 if (isIDFIRST(*s) ||
522 (allow_pack && *s == ':') ||
15f0808c 523 (allow_initial_tick && *s == '\'') )
a0d0e21e 524 {
8903cb82 525 s = scan_word(s, tokenbuf, sizeof tokenbuf, allow_pack, &len);
463ee0b2
LW		 526 if (check_keyword && keyword(tokenbuf, len))
527 return start;
528 if (token == METHOD) {
529 s = skipspace(s);
530 if (*s == '(')
531 expect = XTERM;
532 else {
533 expect = XOPERATOR;
534 force_next(')');
535 force_next('(');
536 }
79072805 537 }
463ee0b2 538 nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(tokenbuf,0));
8990e307 539 nextval[nexttoke].opval->op_private |= OPpCONST_BARE;
79072805
LW		 540 force_next(token);
541 }
542 return s;
543}
544
8990e307 545static void
8ac85365 546force_ident(register char *s, int kind)
79072805
LW		 547{
548 if (s && *s) {
11343788
MB		 549 OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
550 nextval[nexttoke].opval = o;
79072805 551 force_next(WORD);
748a9306 552 if (kind) {
e858de61 553 dTHR; /* just for in_eval */
11343788 554 o->op_private = OPpCONST_ENTERED;
55497cff 555 /* XXX see note in pp_entereval() for why we forgo typo
556 warnings if the symbol must be introduced in an eval.
557 GSAR 96-10-12 */
93233ece 558 gv_fetchpv(s, in_eval ? (GV_ADDMULTI | 8) : TRUE,
a0d0e21e
LW		 559 kind == '$' ? SVt_PV :
560 kind == '@' ? SVt_PVAV :
561 kind == '%' ? SVt_PVHV :
562 SVt_PVGV
563 );
748a9306 564 }
79072805
LW		 565 }
566}
567
89bfa8cd 568static char *
8ac85365 569force_version(char *s)
89bfa8cd 570{
571 OP *version = Nullop;
572
573 s = skipspace(s);
574
575 /* default VERSION number -- GBARR */
576
577 if(isDIGIT(*s)) {
578 char *d;
579 int c;
55497cff 580 for( d=s, c = 1; isDIGIT(*d) || *d == '_' || (*d == '.' && c--); d++);
89bfa8cd 581 if((*d == ';' || isSPACE(*d)) && *(skipspace(d)) != ',') {
582 s = scan_num(s);
583 /* real VERSION number -- GBARR */
584 version = yylval.opval;
585 }
586 }
587
588 /* NOTE: The parser sees the package name and the VERSION swapped */
589 nextval[nexttoke].opval = version;
590 force_next(WORD);
591
592 return (s);
593}
594
8990e307 595static SV *
8ac85365 596q(SV *sv)
79072805
LW		 597{
598 register char *s;
599 register char *send;
600 register char *d;
463ee0b2 601 STRLEN len;
79072805
LW		 602
603 if (!SvLEN(sv))
604 return sv;
605
a0d0e21e 606 s = SvPV_force(sv, len);
748a9306
LW		 607 if (SvIVX(sv) == -1)
608 return sv;
463ee0b2 609 send = s + len;
79072805
LW		 610 while (s < send && *s != '\\')
611 s++;
612 if (s == send)
613 return sv;
614 d = s;
79072805
LW		 615 while (s < send) {
616 if (*s == '\\') {
a0d0e21e 617 if (s + 1 < send && (s[1] == '\\'))
79072805
LW		 618 s++; /* all that, just for this */
619 }
620 *d++ = *s++;
621 }
622 *d = '\0';
463ee0b2 623 SvCUR_set(sv, d - SvPVX(sv));
79072805
LW		 624
625 return sv;
626}
627
8990e307 628static I32
8ac85365 629sublex_start(void)
79072805
LW		 630{
631 register I32 op_type = yylval.ival;
79072805
LW		 632
633 if (op_type == OP_NULL) {
634 yylval.opval = lex_op;
635 lex_op = Nullop;
636 return THING;
637 }
638 if (op_type == OP_CONST || op_type == OP_READLINE) {
1c9c84df
CS		 639 SV *sv = q(lex_stuff);
640 STRLEN len;
641 char *p = SvPV(sv, len);
642 yylval.opval = (OP*)newSVOP(op_type, 0, newSVpv(p, len));
643 SvREFCNT_dec(sv);
79072805
LW		 644 lex_stuff = Nullsv;
645 return THING;
646 }
647
55497cff 648 sublex_info.super_state = lex_state;
649 sublex_info.sub_inwhat = op_type;
650 sublex_info.sub_op = lex_op;
651 lex_state = LEX_INTERPPUSH;
652
653 expect = XTERM;
654 if (lex_op) {
655 yylval.opval = lex_op;
656 lex_op = Nullop;
657 return PMFUNC;
658 }
659 else
660 return FUNC;
661}
662
663static I32
8ac85365 664sublex_push(void)
55497cff 665{
0f15f207 666 dTHR;
f46d017c 667 ENTER;
55497cff 668
669 lex_state = sublex_info.super_state;
670 SAVEI32(lex_dojoin);
671 SAVEI32(lex_brackets);
672 SAVEI32(lex_fakebrack);
673 SAVEI32(lex_casemods);
674 SAVEI32(lex_starts);
675 SAVEI32(lex_state);
a0d0e21e 676 SAVESPTR(lex_inpat);
55497cff 677 SAVEI32(lex_inwhat);
678 SAVEI16(curcop->cop_line);
85e6fe83
LW		 679 SAVEPPTR(bufptr);
680 SAVEPPTR(oldbufptr);
681 SAVEPPTR(oldoldbufptr);
fd049845 682 SAVEPPTR(linestart);
79072805 683 SAVESPTR(linestr);
85e6fe83 684 SAVEPPTR(lex_brackstack);
a0d0e21e 685 SAVEPPTR(lex_casestack);
79072805
LW		 686
687 linestr = lex_stuff;
688 lex_stuff = Nullsv;
689
fd049845 690 bufend = bufptr = oldbufptr = oldoldbufptr = linestart = SvPVX(linestr);
79072805 691 bufend += SvCUR(linestr);
8990e307 692 SAVEFREESV(linestr);
79072805
LW		 693
694 lex_dojoin = FALSE;
695 lex_brackets = 0;
696 lex_fakebrack = 0;
8990e307 697 New(899, lex_brackstack, 120, char);
a0d0e21e 698 New(899, lex_casestack, 12, char);
8990e307 699 SAVEFREEPV(lex_brackstack);
a0d0e21e 700 SAVEFREEPV(lex_casestack);
79072805 701 lex_casemods = 0;
a0d0e21e 702 *lex_casestack = '\0';
79072805
LW		 703 lex_starts = 0;
704 lex_state = LEX_INTERPCONCAT;
705 curcop->cop_line = multi_start;
706
55497cff 707 lex_inwhat = sublex_info.sub_inwhat;
708 if (lex_inwhat == OP_MATCH || lex_inwhat == OP_SUBST)
709 lex_inpat = sublex_info.sub_op;
79072805 710 else
55497cff 711 lex_inpat = Nullop;
79072805 712
55497cff 713 return '(';
79072805
LW		 714}
715
8990e307 716static I32
8ac85365 717sublex_done(void)
79072805
LW		 718{
719 if (!lex_starts++) {
720 expect = XOPERATOR;
93a17b20 721 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv("",0));
79072805
LW		 722 return THING;
723 }
724
725 if (lex_casemods) { /* oops, we've got some unbalanced parens */
726 lex_state = LEX_INTERPCASEMOD;
727 return yylex();
728 }
729
79072805
LW		 730 /* Is there a right-hand side to take care of? */
731 if (lex_repl && (lex_inwhat == OP_SUBST || lex_inwhat == OP_TRANS)) {
732 linestr = lex_repl;
733 lex_inpat = 0;
fd049845 734 bufend = bufptr = oldbufptr = oldoldbufptr = linestart = SvPVX(linestr);
79072805 735 bufend += SvCUR(linestr);
8990e307 736 SAVEFREESV(linestr);
79072805
LW		 737 lex_dojoin = FALSE;
738 lex_brackets = 0;
739 lex_fakebrack = 0;
740 lex_casemods = 0;
a0d0e21e 741 *lex_casestack = '\0';
79072805
LW		 742 lex_starts = 0;
743 if (SvCOMPILED(lex_repl)) {
744 lex_state = LEX_INTERPNORMAL;
745 lex_starts++;
746 }
747 else
748 lex_state = LEX_INTERPCONCAT;
749 lex_repl = Nullsv;
750 return ',';
ffed7fef
LW		 751 }
752 else {
f46d017c 753 LEAVE;
463ee0b2 754 bufend = SvPVX(linestr);
79072805
LW		 755 bufend += SvCUR(linestr);
756 expect = XOPERATOR;
757 return ')';
ffed7fef
LW		 758 }
759}
760
02aa26ce
NT		 761/*
762 scan_const
763
764 Extracts a pattern, double-quoted string, or transliteration. This
765 is terrifying code.
766
767 It looks at lex_inwhat and lex_inpat to find out whether it's
768 processing a pattern (lex_inpat is true), a transliteration
769 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
770
9b599b2a
GS		 771 Returns a pointer to the character scanned up to. Iff this is
772 advanced from the start pointer supplied (ie if anything was
773 successfully parsed), will leave an OP for the substring scanned
774 in yylval. Caller must intuit reason for not parsing further
775 by looking at the next characters herself.
776
02aa26ce
NT		 777 In patterns:
778 backslashes:
779 double-quoted style: \r and \n
780 regexp special ones: \D \s
781 constants: \x3
782 backrefs: \1 (deprecated in substitution replacements)
783 case and quoting: \U \Q \E
784 stops on @ and $, but not for $ as tail anchor
785
786 In transliterations:
787 characters are VERY literal, except for - not at the start or end
788 of the string, which indicates a range. scan_const expands the
789 range to the full set of intermediate characters.
790
791 In double-quoted strings:
792 backslashes:
793 double-quoted style: \r and \n
794 constants: \x3
795 backrefs: \1 (deprecated)
796 case and quoting: \U \Q \E
797 stops on @ and $
798
799 scan_const does *not* construct ops to handle interpolated strings.
800 It stops processing as soon as it finds an embedded $ or @ variable
801 and leaves it to the caller to work out what's going on.
802
803 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
804
805 $ in pattern could be $foo or could be tail anchor. Assumption:
806 it's a tail anchor if $ is the last thing in the string, or if it's
807 followed by one of ")| \n\t"
808
809 \1 (backreferences) are turned into $1
810
811 The structure of the code is
812 while (there's a character to process) {
813 handle transliteration ranges
814 skip regexp comments
815 skip # initiated comments in //x patterns
816 check for embedded @foo
817 check for embedded scalars
818 if (backslash) {
819 leave intact backslashes from leave (below)
820 deprecate \1 in strings and sub replacements
821 handle string-changing backslashes \l \U \Q \E, etc.
822 switch (what was escaped) {
823 handle - in a transliteration (becomes a literal -)
824 handle \132 octal characters
825 handle 0x15 hex characters
826 handle \cV (control V)
827 handle printf backslashes (\f, \r, \n, etc)
828 } (end switch)
829 } (end if backslash)
830 } (end while character to read)
831
832*/
833
8990e307 834static char *
8ac85365 835scan_const(char *start)
79072805 836{
02aa26ce
NT		 837 register char *send = bufend; /* end of the constant */
838 SV *sv = NEWSV(93, send - start); /* sv for the constant */
839 register char *s = start; /* start of the constant */
840 register char *d = SvPVX(sv); /* destination for copies */
841 bool dorange = FALSE; /* are we in a translit range? */
842 I32 len; /* ? */
843
9b599b2a 844 /* leaveit is the set of acceptably-backslashed characters */
72aaf631 845 char *leaveit =
79072805 846 lex_inpat
748a9306 847 ? "\\.^$@AGZdDwWsSbB+*?|()-nrtfeaxc0123456789[{]} \t\n\r\f\v#"
9b599b2a 848 : "";
79072805
LW		 849
850 while (s < send || dorange) {
02aa26ce 851 /* get transliterations out of the way (they're most literal) */
79072805 852 if (lex_inwhat == OP_TRANS) {
02aa26ce 853 /* expand a range A-Z to the full set of characters. AIE! */
79072805 854 if (dorange) {
02aa26ce
NT		 855 I32 i; /* current expanded character */
856 I32 max; /* last character in range */
857
858 i = d - SvPVX(sv); /* remember current offset */
859 SvGROW(sv, SvLEN(sv) + 256); /* expand the sv -- there'll never be more'n 256 chars in a range for it to grow by */
860 d = SvPVX(sv) + i; /* restore d after the grow potentially has changed the ptr */
861 d -= 2; /* eat the first char and the - */
862
863 max = (U8)d[1]; /* last char in range */
864
91b7def8 865 for (i = (U8)*d; i <= max; i++)
79072805 866 *d++ = i;
02aa26ce
NT		 867
868 /* mark the range as done, and continue */
79072805
LW		 869 dorange = FALSE;
870 continue;
871 }
02aa26ce
NT		 872
873 /* range begins (ignore - as first or last char) */
79072805
LW		 874 else if (*s == '-' && s+1 < send && s != start) {
875 dorange = TRUE;
876 s++;
877 }
878 }
02aa26ce
NT		 879
880 /* if we get here, we're not doing a transliteration */
881
882 /* skip for regexp comments /(?#comment)/ */
cc6b7395
IZ		 883 else if (*s == '(' && lex_inpat && s[1] == '?') {
884 if (s[2] == '#') {
885 while (s < send && *s != ')')
886 *d++ = *s++;
887 } else if (s[2] == '{') { /* This should march regcomp.c */
888 I32 count = 1;
889 char *regparse = s + 3;
890 char c;
891
892 while (count && (c = *regparse)) {
893 if (c == '\\' && regparse[1])
894 regparse++;
895 else if (c == '{')
896 count++;
897 else if (c == '}')
898 count--;
899 regparse++;
900 }
901 if (*regparse == ')')
902 regparse++;
903 else
904 yyerror("Sequence (?{...}) not terminated or not {}-balanced");
905 while (s < regparse && *s != ')')
906 *d++ = *s++;
907 }
748a9306 908 }
02aa26ce
NT		 909
910 /* likewise skip #-initiated comments in //x patterns */
748a9306
LW		 911 else if (*s == '#' && lex_inpat &&
912 ((PMOP*)lex_inpat)->op_pmflags & PMf_EXTENDED) {
913 while (s+1 < send && *s != '\n')
914 *d++ = *s++;
915 }
02aa26ce
NT		 916
917 /* check for embedded arrays (@foo, @:foo, @'foo, @{foo}, @$foo) */
a0d0e21e 918 else if (*s == '@' && s[1] && (isALNUM(s[1]) || strchr(":'{$", s[1])))
79072805 919 break;
02aa26ce
NT		 920
921 /* check for embedded scalars. only stop if we're sure it's a
922 variable.
923 */
79072805
LW		 924 else if (*s == '$') {
925 if (!lex_inpat) /* not a regexp, so $ must be var */
926 break;
c277df42 927 if (s + 1 < send && !strchr("()| \n\t", s[1]))
79072805
LW		 928 break; /* in regexp, $ might be tail anchor */
929 }
02aa26ce
NT		 930
931 /* backslashes */
79072805
LW		 932 if (*s == '\\' && s+1 < send) {
933 s++;
02aa26ce
NT		 934
935 /* some backslashes we leave behind */
72aaf631 936 if (*s && strchr(leaveit, *s)) {
79072805
LW		 937 *d++ = '\\';
938 *d++ = *s++;
939 continue;
940 }
02aa26ce
NT		 941
942 /* deprecate \1 in strings and substitution replacements */
79072805 943 if (lex_inwhat == OP_SUBST && !lex_inpat &&
a0d0e21e 944 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
79072805 945 {
a0d0e21e
LW		 946 if (dowarn)
947 warn("\\%c better written as $%c", *s, *s);
79072805
LW		 948 *--s = '$';
949 break;
950 }
02aa26ce
NT		 951
952 /* string-change backslash escapes */
a0d0e21e 953 if (lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
79072805
LW		 954 --s;
955 break;
956 }
02aa26ce
NT		 957
958 /* if we get here, it's either a quoted -, or a digit */
79072805 959 switch (*s) {
02aa26ce
NT		 960
961 /* quoted - in transliterations */
79072805
LW		 962 case '-':
963 if (lex_inwhat == OP_TRANS) {
964 *d++ = *s++;
965 continue;
966 }
967 /* FALL THROUGH */
02aa26ce 968 /* default action is to copy the quoted character */
79072805
LW		 969 default:
970 *d++ = *s++;
971 continue;
02aa26ce
NT		 972
973 /* \132 indicates an octal constant */
79072805
LW		 974 case '0': case '1': case '2': case '3':
975 case '4': case '5': case '6': case '7':
976 *d++ = scan_oct(s, 3, &len);
977 s += len;
978 continue;
02aa26ce
NT		 979
980 /* \x24 indicates a hex constant */
79072805
LW		 981 case 'x':
982 *d++ = scan_hex(++s, 2, &len);
983 s += len;
984 continue;
02aa26ce
NT		 985
986 /* \c is a control character */
79072805
LW		 987 case 'c':
988 s++;
bbce6d69 989 len = *s++;
990 *d++ = toCTRL(len);
79072805 991 continue;
02aa26ce
NT		 992
993 /* printf-style backslashes, formfeeds, newlines, etc */
79072805
LW		 994 case 'b':
995 *d++ = '\b';
996 break;
997 case 'n':
998 *d++ = '\n';
999 break;
1000 case 'r':
1001 *d++ = '\r';
1002 break;
1003 case 'f':
1004 *d++ = '\f';
1005 break;
1006 case 't':
1007 *d++ = '\t';
1008 break;
1009 case 'e':
1010 *d++ = '\033';
1011 break;
1012 case 'a':
1013 *d++ = '\007';
1014 break;
02aa26ce
NT		 1015 } /* end switch */
1016
79072805
LW		 1017 s++;
1018 continue;
02aa26ce
NT		 1019 } /* end if (backslash) */
1020
79072805 1021 *d++ = *s++;
02aa26ce
NT		 1022 } /* while loop to process each character */
1023
1024 /* terminate the string and set up the sv */
79072805 1025 *d = '\0';
463ee0b2 1026 SvCUR_set(sv, d - SvPVX(sv));
79072805
LW		 1027 SvPOK_on(sv);
1028
02aa26ce 1029 /* shrink the sv if we allocated more than we used */
79072805
LW		 1030 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1031 SvLEN_set(sv, SvCUR(sv) + 1);
463ee0b2 1032 Renew(SvPVX(sv), SvLEN(sv), char);
79072805 1033 }
02aa26ce 1034
9b599b2a 1035 /* return the substring (via yylval) only if we parsed anything */
79072805
LW		 1036 if (s > bufptr)
1037 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1038 else
8990e307 1039 SvREFCNT_dec(sv);
79072805
LW		 1040 return s;
1041}
1042
1043/* This is the one truly awful dwimmer necessary to conflate C and sed. */
8990e307 1044static int
8ac85365 1045intuit_more(register char *s)
79072805
LW		 1046{
1047 if (lex_brackets)
1048 return TRUE;
1049 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1050 return TRUE;
1051 if (*s != '{' && *s != '[')
1052 return FALSE;
1053 if (!lex_inpat)
1054 return TRUE;
1055
1056 /* In a pattern, so maybe we have {n,m}. */
1057 if (*s == '{') {
1058 s++;
1059 if (!isDIGIT(*s))
1060 return TRUE;
1061 while (isDIGIT(*s))
1062 s++;
1063 if (*s == ',')
1064 s++;
1065 while (isDIGIT(*s))
1066 s++;
1067 if (*s == '}')
1068 return FALSE;
1069 return TRUE;
1070
1071 }
1072
1073 /* On the other hand, maybe we have a character class */
1074
1075 s++;
1076 if (*s == ']' || *s == '^')
1077 return FALSE;
1078 else {
1079 int weight = 2; /* let's weigh the evidence */
1080 char seen[256];
1081 unsigned char un_char = 0, last_un_char;
93a17b20 1082 char *send = strchr(s,']');
8903cb82 1083 char tmpbuf[sizeof tokenbuf * 4];
79072805
LW		 1084
1085 if (!send) /* has to be an expression */
1086 return TRUE;
1087
1088 Zero(seen,256,char);
1089 if (*s == '$')
1090 weight -= 3;
1091 else if (isDIGIT(*s)) {
1092 if (s[1] != ']') {
1093 if (isDIGIT(s[1]) && s[2] == ']')
1094 weight -= 10;
1095 }
1096 else
1097 weight -= 100;
1098 }
1099 for (; s < send; s++) {
1100 last_un_char = un_char;
1101 un_char = (unsigned char)*s;
1102 switch (*s) {
1103 case '@':
1104 case '&':
1105 case '$':
1106 weight -= seen[un_char] * 10;
1107 if (isALNUM(s[1])) {
8903cb82 1108 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
a0d0e21e 1109 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
79072805
LW		 1110 weight -= 100;
1111 else
1112 weight -= 10;
1113 }
1114 else if (*s == '$' && s[1] &&
93a17b20
LW		 1115 strchr("[#!%*<>()-=",s[1])) {
1116 if (/*{*/ strchr("])} =",s[2]))
79072805
LW		 1117 weight -= 10;
1118 else
1119 weight -= 1;
1120 }
1121 break;
1122 case '\\':
1123 un_char = 254;
1124 if (s[1]) {
93a17b20 1125 if (strchr("wds]",s[1]))
79072805
LW		 1126 weight += 100;
1127 else if (seen['\''] || seen['"'])
1128 weight += 1;
93a17b20 1129 else if (strchr("rnftbxcav",s[1]))
79072805
LW		 1130 weight += 40;
1131 else if (isDIGIT(s[1])) {
1132 weight += 40;
1133 while (s[1] && isDIGIT(s[1]))
1134 s++;
1135 }
1136 }
1137 else
1138 weight += 100;
1139 break;
1140 case '-':
1141 if (s[1] == '\\')
1142 weight += 50;
93a17b20 1143 if (strchr("aA01! ",last_un_char))
79072805 1144 weight += 30;
93a17b20 1145 if (strchr("zZ79~",s[1]))
79072805
LW		 1146 weight += 30;
1147 break;
1148 default:
93a17b20 1149 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
79072805
LW		 1150 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1151 char *d = tmpbuf;
1152 while (isALPHA(*s))
1153 *d++ = *s++;
1154 *d = '\0';
1155 if (keyword(tmpbuf, d - tmpbuf))
1156 weight -= 150;
1157 }
1158 if (un_char == last_un_char + 1)
1159 weight += 5;
1160 weight -= seen[un_char];
1161 break;
1162 }
1163 seen[un_char]++;
1164 }
1165 if (weight >= 0) /* probably a character class */
1166 return FALSE;
1167 }
1168
1169 return TRUE;
1170}
ffed7fef 1171
a0d0e21e 1172static int
8ac85365 1173intuit_method(char *start, GV *gv)
a0d0e21e
LW		 1174{
1175 char *s = start + (*start == '$');
8903cb82 1176 char tmpbuf[sizeof tokenbuf];
a0d0e21e
LW		 1177 STRLEN len;
1178 GV* indirgv;
1179
1180 if (gv) {
b6c543e3 1181 CV *cv;
a0d0e21e
LW		 1182 if (GvIO(gv))
1183 return 0;
b6c543e3
IZ		 1184 if ((cv = GvCVu(gv))) {
1185 char *proto = SvPVX(cv);
1186 if (proto) {
1187 if (*proto == ';')
1188 proto++;
1189 if (*proto == '*')
1190 return 0;
1191 }
1192 } else
a0d0e21e
LW		 1193 gv = 0;
1194 }
8903cb82 1195 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
a0d0e21e
LW		 1196 if (*start == '$') {
1197 if (gv || last_lop_op == OP_PRINT || isUPPER(*tokenbuf))
1198 return 0;
1199 s = skipspace(s);
1200 bufptr = start;
1201 expect = XREF;
1202 return *s == '(' ? FUNCMETH : METHOD;
1203 }
1204 if (!keyword(tmpbuf, len)) {
c3e0f903
GS		 1205 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1206 len -= 2;
1207 tmpbuf[len] = '\0';
1208 goto bare_package;
1209 }
1210 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
8ebc5c01 1211 if (indirgv && GvCVu(indirgv))
a0d0e21e
LW		 1212 return 0;
1213 /* filehandle or package name makes it a method */
89bfa8cd 1214 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
a0d0e21e 1215 s = skipspace(s);
55497cff 1216 if ((bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1217 return 0; /* no assumptions -- "=>" quotes bearword */
c3e0f903
GS		 1218 bare_package:
1219 nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1220 newSVpv(tmpbuf,0));
1221 nextval[nexttoke].opval->op_private = OPpCONST_BARE;
a0d0e21e
LW		 1222 expect = XTERM;
1223 force_next(WORD);
1224 bufptr = s;
1225 return *s == '(' ? FUNCMETH : METHOD;
1226 }
1227 }
1228 return 0;
1229}
1230
1231static char*
8ac85365 1232incl_perldb(void)
a0d0e21e
LW		 1233{
1234 if (perldb) {
5fd9e9a4 1235 char *pdb = PerlEnv_getenv("PERL5DB");
a0d0e21e
LW		 1236
1237 if (pdb)
1238 return pdb;
61bb5906 1239 SETERRNO(0,SS$_NORMAL);
a0d0e21e
LW		 1240 return "BEGIN { require 'perl5db.pl' }";
1241 }
1242 return "";
1243}
1244
1245
16d20bd9
AD		 1246/* Encoded script support. filter_add() effectively inserts a
1247 * 'pre-processing' function into the current source input stream.
1248 * Note that the filter function only applies to the current source file
1249 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1250 *
1251 * The datasv parameter (which may be NULL) can be used to pass
1252 * private data to this instance of the filter. The filter function
1253 * can recover the SV using the FILTER_DATA macro and use it to
1254 * store private buffers and state information.
1255 *
1256 * The supplied datasv parameter is upgraded to a PVIO type
1257 * and the IoDIRP field is used to store the function pointer.
1258 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1259 * private use must be set using malloc'd pointers.
1260 */
1261static int filter_debug = 0;
1262
1263SV *
8ac85365 1264filter_add(filter_t funcp, SV *datasv)
16d20bd9
AD		 1265{
1266 if (!funcp){ /* temporary handy debugging hack to be deleted */
1267 filter_debug = atoi((char*)datasv);
1268 return NULL;
1269 }
1270 if (!rsfp_filters)
1271 rsfp_filters = newAV();
1272 if (!datasv)
8c52afec 1273 datasv = NEWSV(255,0);
16d20bd9
AD		 1274 if (!SvUPGRADE(datasv, SVt_PVIO))
1275 die("Can't upgrade filter_add data to SVt_PVIO");
1276 IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
1277 if (filter_debug)
ff0cee69 1278 warn("filter_add func %p (%s)", funcp, SvPV(datasv,na));
e50aee73
AD		 1279 av_unshift(rsfp_filters, 1);
1280 av_store(rsfp_filters, 0, datasv) ;
16d20bd9
AD		 1281 return(datasv);
1282}
1283
1284
1285/* Delete most recently added instance of this filter function. */
a0d0e21e 1286void
8ac85365 1287filter_del(filter_t funcp)
16d20bd9
AD		 1288{
1289 if (filter_debug)
ff0cee69 1290 warn("filter_del func %p", funcp);
93965878 1291 if (!rsfp_filters || AvFILLp(rsfp_filters)<0)
16d20bd9
AD		 1292 return;
1293 /* if filter is on top of stack (usual case) just pop it off */
93965878 1294 if (IoDIRP(FILTER_DATA(AvFILLp(rsfp_filters))) == (void*)funcp){
ff2faa2b 1295 sv_free(av_pop(rsfp_filters));
e50aee73 1296
16d20bd9
AD		 1297 return;
1298 }
1299 /* we need to search for the correct entry and clear it */
1300 die("filter_del can only delete in reverse order (currently)");
1301}
1302
1303
1304/* Invoke the n'th filter function for the current rsfp. */
1305I32
8ac85365
NIS		 1306filter_read(int idx, SV *buf_sv, int maxlen)
1307
1308
1309 /* 0 = read one text line */
a0d0e21e 1310{
16d20bd9
AD		 1311 filter_t funcp;
1312 SV *datasv = NULL;
e50aee73 1313
16d20bd9
AD		 1314 if (!rsfp_filters)
1315 return -1;
93965878 1316 if (idx > AvFILLp(rsfp_filters)){ /* Any more filters? */
16d20bd9
AD		 1317 /* Provide a default input filter to make life easy. */
1318 /* Note that we append to the line. This is handy. */
16d20bd9
AD		 1319 if (filter_debug)
1320 warn("filter_read %d: from rsfp\n", idx);
1321 if (maxlen) {
1322 /* Want a block */
1323 int len ;
1324 int old_len = SvCUR(buf_sv) ;
1325
1326 /* ensure buf_sv is large enough */
1327 SvGROW(buf_sv, old_len + maxlen) ;
760ac839
LW		 1328 if ((len = PerlIO_read(rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1329 if (PerlIO_error(rsfp))
37120919
AD		 1330 return -1; /* error */
1331 else
1332 return 0 ; /* end of file */
1333 }
16d20bd9
AD		 1334 SvCUR_set(buf_sv, old_len + len) ;
1335 } else {
1336 /* Want a line */
37120919 1337 if (sv_gets(buf_sv, rsfp, SvCUR(buf_sv)) == NULL) {
760ac839 1338 if (PerlIO_error(rsfp))
37120919
AD		 1339 return -1; /* error */
1340 else
1341 return 0 ; /* end of file */
1342 }
16d20bd9
AD		 1343 }
1344 return SvCUR(buf_sv);
1345 }
1346 /* Skip this filter slot if filter has been deleted */
1347 if ( (datasv = FILTER_DATA(idx)) == &sv_undef){
1348 if (filter_debug)
1349 warn("filter_read %d: skipped (filter deleted)\n", idx);
1350 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1351 }
1352 /* Get function pointer hidden within datasv */
1353 funcp = (filter_t)IoDIRP(datasv);
1354 if (filter_debug)
ff0cee69 1355 warn("filter_read %d: via function %p (%s)\n",
16d20bd9
AD		 1356 idx, funcp, SvPV(datasv,na));
1357 /* Call function. The function is expected to */
1358 /* call "FILTER_READ(idx+1, buf_sv)" first. */
37120919 1359 /* Return: <0:error, =0:eof, >0:not eof */
16d20bd9
AD		 1360 return (*funcp)(idx, buf_sv, maxlen);
1361}
1362
1363static char *
6acef3b7 1364filter_gets(register SV *sv, register PerlIO *fp, STRLEN append)
16d20bd9 1365{
a868473f
NIS		 1366#ifdef WIN32FILTER
1367 if (!rsfp_filters) {
1368 filter_add(win32_textfilter,NULL);
1369 }
1370#endif
16d20bd9
AD		 1371 if (rsfp_filters) {
1372
55497cff 1373 if (!append)
1374 SvCUR_set(sv, 0); /* start with empty line */
16d20bd9
AD		 1375 if (FILTER_READ(0, sv, 0) > 0)
1376 return ( SvPVX(sv) ) ;
1377 else
1378 return Nullch ;
1379 }
1380 else
fd049845 1381 return (sv_gets(sv, fp, append));
a0d0e21e
LW		 1382}
1383
1384
748a9306
LW		 1385#ifdef DEBUGGING
1386 static char* exp_name[] =
a0d0e21e 1387 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "TERMBLOCK" };
748a9306 1388#endif
463ee0b2 1389
71be2cbc 1390EXT int yychar; /* last token */
463ee0b2 1391
02aa26ce
NT		 1392/*
1393 yylex
1394
1395 Works out what to call the token just pulled out of the input
1396 stream. The yacc parser takes care of taking the ops we return and
1397 stitching them into a tree.
1398
1399 Returns:
1400 PRIVATEREF
1401
1402 Structure:
1403 if read an identifier
1404 if we're in a my declaration
1405 croak if they tried to say my($foo::bar)
1406 build the ops for a my() declaration
1407 if it's an access to a my() variable
1408 are we in a sort block?
1409 croak if my($a); $a <=> $b
1410 build ops for access to a my() variable
1411 if in a dq string, and they've said @foo and we can't find @foo
1412 croak
1413 build ops for a bareword
1414 if we already built the token before, use it.
1415*/
1416
2f3197b3 1417int
8ac85365 1418yylex(void)
378cc40b 1419{
11343788 1420 dTHR;
79072805 1421 register char *s;
378cc40b 1422 register char *d;
79072805 1423 register I32 tmp;
463ee0b2 1424 STRLEN len;
161b471a
NIS		 1425 GV *gv = Nullgv;
1426 GV **gvp = 0;
a687059c 1427
02aa26ce 1428 /* check if there's an identifier for us to look at */
bbce6d69 1429 if (pending_ident) {
02aa26ce 1430 /* pit holds the identifier we read and pending_ident is reset */
bbce6d69 1431 char pit = pending_ident;
1432 pending_ident = 0;
1433
02aa26ce
NT		 1434 /* if we're in a my(), we can't allow dynamics here.
1435 $foo'bar has already been turned into $foo::bar, so
1436 just check for colons.
1437
1438 if it's a legal name, the OP is a PADANY.
1439 */
bbce6d69 1440 if (in_my) {
1441 if (strchr(tokenbuf,':'))
1442 croak(no_myglob,tokenbuf);
02aa26ce 1443
bbce6d69 1444 yylval.opval = newOP(OP_PADANY, 0);
1445 yylval.opval->op_targ = pad_allocmy(tokenbuf);
1446 return PRIVATEREF;
1447 }
1448
02aa26ce
NT		 1449 /*
1450 build the ops for accesses to a my() variable.
1451
1452 Deny my($a) or my($b) in a sort block, *if* $a or $b is
1453 then used in a comparison. This catches most, but not
1454 all cases. For instance, it catches
1455 sort { my($a); $a <=> $b }
1456 but not
1457 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
1458 (although why you'd do that is anyone's guess).
1459 */
1460
a863c7d1
MB		 1461 if (!strchr(tokenbuf,':')) {
1462#ifdef USE_THREADS
54b9620d 1463 /* Check for single character per-thread SVs */
a863c7d1 1464 if (tokenbuf[0] == '$' && tokenbuf[2] == '\0'
54b9620d
MB		 1465 && !isALPHA(tokenbuf[1]) /* Rule out obvious non-threadsvs */
1466 && (tmp = find_threadsv(&tokenbuf[1])) != NOT_IN_PAD)
554b3eca 1467 {
2faa37cc 1468 yylval.opval = newOP(OP_THREADSV, 0);
a863c7d1
MB		 1469 yylval.opval->op_targ = tmp;
1470 return PRIVATEREF;
1471 }
1472#endif /* USE_THREADS */
1473 if ((tmp = pad_findmy(tokenbuf)) != NOT_IN_PAD) {
02aa26ce 1474 /* if it's a sort block and they're naming $a or $b */
a863c7d1
MB		 1475 if (last_lop_op == OP_SORT &&
1476 tokenbuf[0] == '$' &&
1477 (tokenbuf[1] == 'a' || tokenbuf[1] == 'b')
1478 && !tokenbuf[2])
bbce6d69 1479 {
a863c7d1
MB		 1480 for (d = in_eval ? oldoldbufptr : linestart;
1481 d < bufend && *d != '\n';
1482 d++)
1483 {
1484 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
1485 croak("Can't use \"my %s\" in sort comparison",
1486 tokenbuf);
1487 }
bbce6d69 1488 }
1489 }
bbce6d69 1490
a863c7d1
MB		 1491 yylval.opval = newOP(OP_PADANY, 0);
1492 yylval.opval->op_targ = tmp;
1493 return PRIVATEREF;
1494 }
bbce6d69 1495 }
1496
02aa26ce
NT		 1497 /*
1498 Whine if they've said @foo in a doublequoted string,
1499 and @foo isn't a variable we can find in the symbol
1500 table.
1501 */
bbce6d69 1502 if (pit == '@' && lex_state != LEX_NORMAL && !lex_brackets) {
1503 GV *gv = gv_fetchpv(tokenbuf+1, FALSE, SVt_PVAV);
46fc3d4c 1504 if (!gv || ((tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
1505 yyerror(form("In string, %s now must be written as \\%s",
1506 tokenbuf, tokenbuf));
bbce6d69 1507 }
1508
02aa26ce 1509 /* build ops for a bareword */
bbce6d69 1510 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(tokenbuf+1, 0));
1511 yylval.opval->op_private = OPpCONST_ENTERED;
93233ece 1512 gv_fetchpv(tokenbuf+1, in_eval ? (GV_ADDMULTI | 8) : TRUE,
bbce6d69 1513 ((tokenbuf[0] == '$') ? SVt_PV
1514 : (tokenbuf[0] == '@') ? SVt_PVAV
1515 : SVt_PVHV));
1516 return WORD;
1517 }
1518
02aa26ce
NT		 1519 /* no identifier pending identification */
1520
79072805
LW		 1521 switch (lex_state) {
1522#ifdef COMMENTARY
1523 case LEX_NORMAL: /* Some compilers will produce faster */
1524 case LEX_INTERPNORMAL: /* code if we comment these out. */
1525 break;
1526#endif
1527
02aa26ce 1528 /* when we're already built the next token, just pull it out the queue */
79072805
LW		 1529 case LEX_KNOWNEXT:
1530 nexttoke--;
1531 yylval = nextval[nexttoke];
463ee0b2 1532 if (!nexttoke) {
79072805 1533 lex_state = lex_defer;
463ee0b2 1534 expect = lex_expect;
a0d0e21e 1535 lex_defer = LEX_NORMAL;
463ee0b2 1536 }
79072805
LW		 1537 return(nexttype[nexttoke]);
1538
02aa26ce
NT		 1539 /* interpolated case modifiers like \L \U, including \Q and \E.
1540 when we get here, bufptr is at the \
1541 */
79072805
LW		 1542 case LEX_INTERPCASEMOD:
1543#ifdef DEBUGGING
1544 if (bufptr != bufend && *bufptr != '\\')
463ee0b2 1545 croak("panic: INTERPCASEMOD");
79072805 1546#endif
02aa26ce
NT		 1547 /* handle \E or end of string */
1548 if (bufptr == bufend || bufptr[1] == 'E') {
a0d0e21e 1549 char oldmod;
02aa26ce
NT		 1550
1551 /* if at a \E */
79072805 1552 if (lex_casemods) {
a0d0e21e
LW		 1553 oldmod = lex_casestack[--lex_casemods];
1554 lex_casestack[lex_casemods] = '\0';
02aa26ce 1555
a0d0e21e
LW		 1556 if (bufptr != bufend && strchr("LUQ", oldmod)) {
1557 bufptr += 2;
1558 lex_state = LEX_INTERPCONCAT;
1559 }
79072805
LW		 1560 return ')';
1561 }
a0d0e21e
LW		 1562 if (bufptr != bufend)
1563 bufptr += 2;
1564 lex_state = LEX_INTERPCONCAT;
79072805
LW		 1565 return yylex();
1566 }
1567 else {
1568 s = bufptr + 1;
1569 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
1570 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
a0d0e21e
LW		 1571 if (strchr("LU", *s) &&
1572 (strchr(lex_casestack, 'L') || strchr(lex_casestack, 'U')))
1573 {
1574 lex_casestack[--lex_casemods] = '\0';
1575 return ')';
1576 }
1577 if (lex_casemods > 10) {
89bfa8cd 1578 char* newlb = Renew(lex_casestack, lex_casemods + 2, char);
a0d0e21e
LW		 1579 if (newlb != lex_casestack) {
1580 SAVEFREEPV(newlb);
1581 lex_casestack = newlb;
1582 }
1583 }
1584 lex_casestack[lex_casemods++] = *s;
1585 lex_casestack[lex_casemods] = '\0';
79072805
LW		 1586 lex_state = LEX_INTERPCONCAT;
1587 nextval[nexttoke].ival = 0;
1588 force_next('(');
1589 if (*s == 'l')
1590 nextval[nexttoke].ival = OP_LCFIRST;
1591 else if (*s == 'u')
1592 nextval[nexttoke].ival = OP_UCFIRST;
1593 else if (*s == 'L')
1594 nextval[nexttoke].ival = OP_LC;
1595 else if (*s == 'U')
1596 nextval[nexttoke].ival = OP_UC;
a0d0e21e
LW		 1597 else if (*s == 'Q')
1598 nextval[nexttoke].ival = OP_QUOTEMETA;
79072805 1599 else
463ee0b2 1600 croak("panic: yylex");
79072805
LW		 1601 bufptr = s + 1;
1602 force_next(FUNC);
1603 if (lex_starts) {
1604 s = bufptr;
463ee0b2 1605 lex_starts = 0;
79072805
LW		 1606 Aop(OP_CONCAT);
1607 }
1608 else
1609 return yylex();
1610 }
1611
55497cff 1612 case LEX_INTERPPUSH:
1613 return sublex_push();
1614
79072805
LW		 1615 case LEX_INTERPSTART:
1616 if (bufptr == bufend)
1617 return sublex_done();
1618 expect = XTERM;
1619 lex_dojoin = (*bufptr == '@');
1620 lex_state = LEX_INTERPNORMAL;
1621 if (lex_dojoin) {
1622 nextval[nexttoke].ival = 0;
1623 force_next(',');
554b3eca 1624#ifdef USE_THREADS
2faa37cc 1625 nextval[nexttoke].opval = newOP(OP_THREADSV, 0);
54b9620d 1626 nextval[nexttoke].opval->op_targ = find_threadsv("\"");
554b3eca
MB		 1627 force_next(PRIVATEREF);
1628#else
a0d0e21e 1629 force_ident("\"", '$');
554b3eca 1630#endif /* USE_THREADS */
79072805
LW		 1631 nextval[nexttoke].ival = 0;
1632 force_next('$');
1633 nextval[nexttoke].ival = 0;
1634 force_next('(');
1635 nextval[nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
1636 force_next(FUNC);
1637 }
1638 if (lex_starts++) {
1639 s = bufptr;
1640 Aop(OP_CONCAT);
1641 }
68dc0745 1642 return yylex();
79072805
LW		 1643
1644 case LEX_INTERPENDMAYBE:
1645 if (intuit_more(bufptr)) {
1646 lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
1647 break;
1648 }
1649 /* FALL THROUGH */
1650
1651 case LEX_INTERPEND:
1652 if (lex_dojoin) {
1653 lex_dojoin = FALSE;
1654 lex_state = LEX_INTERPCONCAT;
1655 return ')';
1656 }
1657 /* FALLTHROUGH */
1658 case LEX_INTERPCONCAT:
1659#ifdef DEBUGGING
1660 if (lex_brackets)
463ee0b2 1661 croak("panic: INTERPCONCAT");
79072805
LW		 1662#endif
1663 if (bufptr == bufend)
1664 return sublex_done();
1665
ed6116ce 1666 if (SvIVX(linestr) == '\'') {
79072805
LW		 1667 SV *sv = newSVsv(linestr);
1668 if (!lex_inpat)
1669 sv = q(sv);
1670 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1671 s = bufend;
1672 }
1673 else {
1674 s = scan_const(bufptr);
1675 if (*s == '\\')
1676 lex_state = LEX_INTERPCASEMOD;
1677 else
1678 lex_state = LEX_INTERPSTART;
1679 }
1680
1681 if (s != bufptr) {
1682 nextval[nexttoke] = yylval;
463ee0b2 1683 expect = XTERM;
79072805
LW		 1684 force_next(THING);
1685 if (lex_starts++)
1686 Aop(OP_CONCAT);
1687 else {
1688 bufptr = s;
1689 return yylex();
1690 }
1691 }
1692
1693 return yylex();
a0d0e21e
LW		 1694 case LEX_FORMLINE:
1695 lex_state = LEX_NORMAL;
1696 s = scan_formline(bufptr);
1697 if (!lex_formbrack)
1698 goto rightbracket;
1699 OPERATOR(';');
79072805
LW		 1700 }
1701
1702 s = bufptr;
a687059c
LW		 1703 oldoldbufptr = oldbufptr;
1704 oldbufptr = s;
79072805 1705 DEBUG_p( {
760ac839 1706 PerlIO_printf(PerlIO_stderr(), "### Tokener expecting %s at %s\n", exp_name[expect], s);
79072805 1707 } )
463ee0b2
LW		 1708
1709 retry:
378cc40b
LW		 1710 switch (*s) {
1711 default:
54310121 1712 croak("Unrecognized character \\%03o", *s & 255);
e929a76b
LW		 1713 case 4:
1714 case 26:
1715 goto fake_eof; /* emulate EOF on ^D or ^Z */
378cc40b 1716 case 0:
463ee0b2 1717 if (!rsfp) {
55497cff 1718 last_uni = 0;
1719 last_lop = 0;
463ee0b2
LW		 1720 if (lex_brackets)
1721 yyerror("Missing right bracket");
79072805 1722 TOKEN(0);
463ee0b2 1723 }
a687059c
LW		 1724 if (s++ < bufend)
1725 goto retry; /* ignore stray nulls */
2f3197b3 1726 last_uni = 0;
79072805 1727 last_lop = 0;
a0d0e21e 1728 if (!in_eval && !preambled) {
79072805 1729 preambled = TRUE;
a0d0e21e 1730 sv_setpv(linestr,incl_perldb());
91b7def8 1731 if (SvCUR(linestr))
1732 sv_catpv(linestr,";");
1733 if (preambleav){
93965878 1734 while(AvFILLp(preambleav) >= 0) {
91b7def8 1735 SV *tmpsv = av_shift(preambleav);
1736 sv_catsv(linestr, tmpsv);
1737 sv_catpv(linestr, ";");
1738 sv_free(tmpsv);
1739 }
1740 sv_free((SV*)preambleav);
1741 preambleav = NULL;
1742 }
79072805
LW		 1743 if (minus_n || minus_p) {
1744 sv_catpv(linestr, "LINE: while (<>) {");
1745 if (minus_l)
a0d0e21e 1746 sv_catpv(linestr,"chomp;");
8fd239a7
CS		 1747 if (minus_a) {
1748 GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
1749 if (gv)
1750 GvIMPORTED_AV_on(gv);
1751 if (minus_F) {
54310121 1752 if (strchr("/'\"", *splitstr)
1753 && strchr(splitstr + 1, *splitstr))
46fc3d4c 1754 sv_catpvf(linestr, "@F=split(%s);", splitstr);
54310121 1755 else {
1756 char delim;
1757 s = "'~#\200\1'"; /* surely one char is unused...*/
1758 while (s[1] && strchr(splitstr, *s)) s++;
1759 delim = *s;
46fc3d4c 1760 sv_catpvf(linestr, "@F=split(%s%c",
1761 "q" + (delim == '\''), delim);
1762 for (s = splitstr; *s; s++) {
54310121 1763 if (*s == '\\')
46fc3d4c 1764 sv_catpvn(linestr, "\\", 1);
1765 sv_catpvn(linestr, s, 1);
54310121 1766 }
46fc3d4c 1767 sv_catpvf(linestr, "%c);", delim);
54310121 1768 }
2304df62
AD		 1769 }
1770 else
1771 sv_catpv(linestr,"@F=split(' ');");
1772 }
79072805 1773 }
a0d0e21e 1774 sv_catpv(linestr, "\n");
fd049845 1775 oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr);
463ee0b2 1776 bufend = SvPVX(linestr) + SvCUR(linestr);
84902520 1777 if (PERLDB_LINE && curstash != debstash) {
a0d0e21e
LW		 1778 SV *sv = NEWSV(85,0);
1779
1780 sv_upgrade(sv, SVt_PVMG);
1781 sv_setsv(sv,linestr);
1782 av_store(GvAV(curcop->cop_filegv),(I32)curcop->cop_line,sv);
1783 }
79072805 1784 goto retry;
a687059c 1785 }
e929a76b 1786 do {
fd049845 1787 if ((s = filter_gets(linestr, rsfp, 0)) == Nullch) {
e929a76b 1788 fake_eof:
395c3793 1789 if (rsfp) {
a0d0e21e 1790 if (preprocess && !in_eval)
3028581b 1791 (void)PerlProc_pclose(rsfp);
760ac839
LW		 1792 else if ((PerlIO *)rsfp == PerlIO_stdin())
1793 PerlIO_clearerr(rsfp);
395c3793 1794 else
760ac839 1795 (void)PerlIO_close(rsfp);
90248788
TB		 1796 if (e_fp == rsfp)
1797 e_fp = Nullfp;
395c3793
LW		 1798 rsfp = Nullfp;
1799 }
a0d0e21e 1800 if (!in_eval && (minus_n || minus_p)) {
79072805
LW		 1801 sv_setpv(linestr,minus_p ? ";}continue{print" : "");
1802 sv_catpv(linestr,";}");
fd049845 1803 oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr);
463ee0b2 1804 bufend = SvPVX(linestr) + SvCUR(linestr);
e929a76b
LW		 1805 minus_n = minus_p = 0;
1806 goto retry;
1807 }
fd049845 1808 oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr);
79072805
LW		 1809 sv_setpv(linestr,"");
1810 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
378cc40b 1811 }
a0d0e21e
LW		 1812 if (doextract) {
1813 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
1814 doextract = FALSE;
1815
1816 /* Incest with pod. */
1817 if (*s == '=' && strnEQ(s, "=cut", 4)) {
1818 sv_setpv(linestr, "");
fd049845 1819 oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr);
a0d0e21e
LW		 1820 bufend = SvPVX(linestr) + SvCUR(linestr);
1821 doextract = FALSE;
1822 }
1823 }
463ee0b2 1824 incline(s);
e929a76b 1825 } while (doextract);
fd049845 1826 oldoldbufptr = oldbufptr = bufptr = linestart = s;
84902520 1827 if (PERLDB_LINE && curstash != debstash) {
79072805 1828 SV *sv = NEWSV(85,0);
a687059c 1829
93a17b20 1830 sv_upgrade(sv, SVt_PVMG);
79072805
LW		 1831 sv_setsv(sv,linestr);
1832 av_store(GvAV(curcop->cop_filegv),(I32)curcop->cop_line,sv);
a687059c 1833 }
463ee0b2 1834 bufend = SvPVX(linestr) + SvCUR(linestr);
79072805
LW		 1835 if (curcop->cop_line == 1) {
1836 while (s < bufend && isSPACE(*s))
1837 s++;
a0d0e21e 1838 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
79072805 1839 s++;
44a8e56a 1840 d = Nullch;
1841 if (!in_eval) {
1842 if (*s == '#' && *(s+1) == '!')
1843 d = s + 2;
1844#ifdef ALTERNATE_SHEBANG
1845 else {
1846 static char as[] = ALTERNATE_SHEBANG;
1847 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
1848 d = s + (sizeof(as) - 1);
1849 }
1850#endif /* ALTERNATE_SHEBANG */
1851 }
1852 if (d) {
b8378b72 1853 char *ipath;
774d564b 1854 char *ipathend;
b8378b72 1855
774d564b 1856 while (isSPACE(*d))
b8378b72
CS		 1857 d++;
1858 ipath = d;
774d564b 1859 while (*d && !isSPACE(*d))
1860 d++;
1861 ipathend = d;
1862
1863#ifdef ARG_ZERO_IS_SCRIPT
1864 if (ipathend > ipath) {
1865 /*
1866 * HP-UX (at least) sets argv[0] to the script name,
1867 * which makes $^X incorrect. And Digital UNIX and Linux,
1868 * at least, set argv[0] to the basename of the Perl
1869 * interpreter. So, having found "#!", we'll set it right.
1870 */
1871 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
1872 assert(SvPOK(x) || SvGMAGICAL(x));
9607fc9c 1873 if (sv_eq(x, GvSV(curcop->cop_filegv))) {
774d564b 1874 sv_setpvn(x, ipath, ipathend - ipath);
9607fc9c 1875 SvSETMAGIC(x);
1876 }
774d564b 1877 TAINT_NOT; /* $^X is always tainted, but that's OK */
8ebc5c01 1878 }
774d564b 1879#endif /* ARG_ZERO_IS_SCRIPT */
b8378b72
CS		 1880
1881 /*
1882 * Look for options.
1883 */
748a9306
LW		 1884 d = instr(s,"perl -");
1885 if (!d)
1886 d = instr(s,"perl");
44a8e56a 1887#ifdef ALTERNATE_SHEBANG
1888 /*
1889 * If the ALTERNATE_SHEBANG on this system starts with a
1890 * character that can be part of a Perl expression, then if
1891 * we see it but not "perl", we're probably looking at the
1892 * start of Perl code, not a request to hand off to some
1893 * other interpreter. Similarly, if "perl" is there, but
1894 * not in the first 'word' of the line, we assume the line
1895 * contains the start of the Perl program.
44a8e56a 1896 */
1897 if (d && *s != '#') {
774d564b 1898 char *c = ipath;
44a8e56a 1899 while (*c && !strchr("; \t\r\n\f\v#", *c))
1900 c++;
1901 if (c < d)
1902 d = Nullch; /* "perl" not in first word; ignore */
1903 else
1904 *s = '#'; /* Don't try to parse shebang line */
1905 }
774d564b 1906#endif /* ALTERNATE_SHEBANG */
748a9306 1907 if (!d &&
44a8e56a 1908 *s == '#' &&
774d564b 1909 ipathend > ipath &&
748a9306
LW		 1910 !minus_c &&
1911 !instr(s,"indir") &&
1912 instr(origargv[0],"perl"))
1913 {
9f68db38 1914 char **newargv;
9f68db38 1915
774d564b 1916 *ipathend = '\0';
1917 s = ipathend + 1;
de3bb511 1918 while (s < bufend && isSPACE(*s))
9f68db38
LW		 1919 s++;
1920 if (s < bufend) {
1921 Newz(899,newargv,origargc+3,char*);
1922 newargv[1] = s;
de3bb511 1923 while (s < bufend && !isSPACE(*s))
9f68db38
LW		 1924 s++;
1925 *s = '\0';
1926 Copy(origargv+1, newargv+2, origargc+1, char*);
1927 }
1928 else
1929 newargv = origargv;
774d564b 1930 newargv[0] = ipath;
1931 execv(ipath, newargv);
1932 croak("Can't exec %s", ipath);
9f68db38 1933 }
748a9306 1934 if (d) {
ba6d6ac9
CS		 1935 U32 oldpdb = perldb;
1936 bool oldn = minus_n;
1937 bool oldp = minus_p;
748a9306
LW		 1938
1939 while (*d && !isSPACE(*d)) d++;
89bfa8cd 1940 while (*d == ' ' || *d == '\t') d++;
748a9306
LW		 1941
1942 if (*d++ == '-') {
8cc95fdb 1943 do {
1944 if (*d == 'M' || *d == 'm') {
1945 char *m = d;
1946 while (*d && !isSPACE(*d)) d++;
1947 croak("Too late for \"-%.*s\" option",
1948 (int)(d - m), m);
1949 }
1950 d = moreswitches(d);
1951 } while (d);
84902520 1952 if (PERLDB_LINE && !oldpdb ||
b084f20b 1953 ( minus_n || minus_p ) && !(oldn || oldp) )
1954 /* if we have already added "LINE: while (<>) {",
1955 we must not do it again */
748a9306
LW		 1956 {
1957 sv_setpv(linestr, "");
fd049845 1958 oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr);
748a9306
LW		 1959 bufend = SvPVX(linestr) + SvCUR(linestr);
1960 preambled = FALSE;
84902520 1961 if (PERLDB_LINE)
748a9306
LW		 1962 (void)gv_fetchfile(origfilename);
1963 goto retry;
1964 }
a0d0e21e 1965 }
79072805 1966 }
9f68db38 1967 }
79072805 1968 }
85e6fe83 1969 if (lex_formbrack && lex_brackets <= lex_formbrack) {
a0d0e21e
LW		 1970 bufptr = s;
1971 lex_state = LEX_FORMLINE;
1972 return yylex();
ae986130 1973 }
378cc40b 1974 goto retry;
4fdae800 1975 case '\r':
a868473f 1976#ifndef WIN32CHEAT
54310121 1977 warn("Illegal character \\%03o (carriage return)", '\r');
1978 croak(
1979 "(Maybe you didn't strip carriage returns after a network transfer?)\n");
a868473f 1980#endif
4fdae800 1981 case ' ': case '\t': case '\f': case 013:
378cc40b
LW		 1982 s++;
1983 goto retry;
378cc40b 1984 case '#':
e929a76b 1985 case '\n':
79072805 1986 if (lex_state != LEX_NORMAL || (in_eval && !rsfp)) {
a687059c
LW		 1987 d = bufend;
1988 while (s < d && *s != '\n')
378cc40b 1989 s++;
0f85fab0 1990 if (s < d)
378cc40b 1991 s++;
463ee0b2 1992 incline(s);
85e6fe83 1993 if (lex_formbrack && lex_brackets <= lex_formbrack) {
a0d0e21e
LW		 1994 bufptr = s;
1995 lex_state = LEX_FORMLINE;
1996 return yylex();
a687059c 1997 }
378cc40b 1998 }
a687059c 1999 else {
378cc40b 2000 *s = '\0';
a687059c
LW		 2001 bufend = s;
2002 }
378cc40b
LW		 2003 goto retry;
2004 case '-':
79072805 2005 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
378cc40b 2006 s++;
748a9306
LW		 2007 bufptr = s;
2008 tmp = *s++;
2009
2010 while (s < bufend && (*s == ' ' || *s == '\t'))
2011 s++;
2012
2013 if (strnEQ(s,"=>",2)) {
748a9306
LW		 2014 s = force_word(bufptr,WORD,FALSE,FALSE,FALSE);
2015 OPERATOR('-'); /* unary minus */
2016 }
e334a159 2017 last_uni = oldbufptr;
a0d0e21e 2018 last_lop_op = OP_FTEREAD; /* good enough */
748a9306 2019 switch (tmp) {
79072805
LW		 2020 case 'r': FTST(OP_FTEREAD);
2021 case 'w': FTST(OP_FTEWRITE);
2022 case 'x': FTST(OP_FTEEXEC);
2023 case 'o': FTST(OP_FTEOWNED);
2024 case 'R': FTST(OP_FTRREAD);
2025 case 'W': FTST(OP_FTRWRITE);
2026 case 'X': FTST(OP_FTREXEC);
2027 case 'O': FTST(OP_FTROWNED);
2028 case 'e': FTST(OP_FTIS);
2029 case 'z': FTST(OP_FTZERO);
2030 case 's': FTST(OP_FTSIZE);
2031 case 'f': FTST(OP_FTFILE);
2032 case 'd': FTST(OP_FTDIR);
2033 case 'l': FTST(OP_FTLINK);
2034 case 'p': FTST(OP_FTPIPE);
2035 case 'S': FTST(OP_FTSOCK);
2036 case 'u': FTST(OP_FTSUID);
2037 case 'g': FTST(OP_FTSGID);
2038 case 'k': FTST(OP_FTSVTX);
2039 case 'b': FTST(OP_FTBLK);
2040 case 'c': FTST(OP_FTCHR);
2041 case 't': FTST(OP_FTTTY);
2042 case 'T': FTST(OP_FTTEXT);
2043 case 'B': FTST(OP_FTBINARY);
85e6fe83
LW		 2044 case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2045 case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2046 case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
378cc40b 2047 default:
ff0cee69 2048 croak("Unrecognized file test: -%c", (int)tmp);
378cc40b
LW		 2049 break;
2050 }
2051 }
a687059c
LW		 2052 tmp = *s++;
2053 if (*s == tmp) {
2054 s++;
79072805
LW		 2055 if (expect == XOPERATOR)
2056 TERM(POSTDEC);
2057 else
2058 OPERATOR(PREDEC);
2059 }
2060 else if (*s == '>') {
2061 s++;
2062 s = skipspace(s);
2063 if (isIDFIRST(*s)) {
a0d0e21e 2064 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
463ee0b2 2065 TOKEN(ARROW);
79072805 2066 }
748a9306
LW		 2067 else if (*s == '$')
2068 OPERATOR(ARROW);
463ee0b2 2069 else
748a9306 2070 TERM(ARROW);
a687059c 2071 }
79072805
LW		 2072 if (expect == XOPERATOR)
2073 Aop(OP_SUBTRACT);
2074 else {
2f3197b3
LW		 2075 if (isSPACE(*s) || !isSPACE(*bufptr))
2076 check_uni();
79072805 2077 OPERATOR('-'); /* unary minus */
2f3197b3 2078 }
79072805 2079
378cc40b 2080 case '+':
a687059c
LW		 2081 tmp = *s++;
2082 if (*s == tmp) {
378cc40b 2083 s++;
79072805
LW		 2084 if (expect == XOPERATOR)
2085 TERM(POSTINC);
2086 else
2087 OPERATOR(PREINC);
378cc40b 2088 }
79072805
LW		 2089 if (expect == XOPERATOR)
2090 Aop(OP_ADD);
2091 else {
2f3197b3
LW		 2092 if (isSPACE(*s) || !isSPACE(*bufptr))
2093 check_uni();
a687059c 2094 OPERATOR('+');
2f3197b3 2095 }
a687059c 2096
378cc40b 2097 case '*':
79072805 2098 if (expect != XOPERATOR) {
8903cb82 2099 s = scan_ident(s, bufend, tokenbuf, sizeof tokenbuf, TRUE);
463ee0b2 2100 expect = XOPERATOR;
a0d0e21e
LW		 2101 force_ident(tokenbuf, '*');
2102 if (!*tokenbuf)
2103 PREREF('*');
79072805 2104 TERM('*');
a687059c 2105 }
79072805
LW		 2106 s++;
2107 if (*s == '*') {
a687059c 2108 s++;
79072805 2109 PWop(OP_POW);
a687059c 2110 }
79072805
LW		 2111 Mop(OP_MULTIPLY);
2112
378cc40b 2113 case '%':
bbce6d69 2114 if (expect == XOPERATOR) {
2115 ++s;
2116 Mop(OP_MODULO);
a687059c 2117 }
bbce6d69 2118 tokenbuf[0] = '%';
8903cb82 2119 s = scan_ident(s, bufend, tokenbuf + 1, sizeof tokenbuf - 1, TRUE);
bbce6d69 2120 if (!tokenbuf[1]) {
2121 if (s == bufend)
2122 yyerror("Final % should be \\% or %name");
2123 PREREF('%');
a687059c 2124 }
bbce6d69 2125 pending_ident = '%';
2126 TERM('%');
a687059c 2127
378cc40b 2128 case '^':
79072805 2129 s++;
a0d0e21e 2130 BOop(OP_BIT_XOR);
79072805
LW		 2131 case '[':
2132 lex_brackets++;
2133 /* FALL THROUGH */
378cc40b 2134 case '~':
378cc40b 2135 case ',':
378cc40b
LW		 2136 tmp = *s++;
2137 OPERATOR(tmp);
a0d0e21e
LW		 2138 case ':':
2139 if (s[1] == ':') {
2140 len = 0;
2141 goto just_a_word;
2142 }
2143 s++;
2144 OPERATOR(':');
8990e307
LW		 2145 case '(':
2146 s++;
a0d0e21e 2147 if (last_lop == oldoldbufptr || last_uni == oldoldbufptr)
8990e307 2148 oldbufptr = oldoldbufptr; /* allow print(STDOUT 123) */
a0d0e21e
LW		 2149 else
2150 expect = XTERM;
2151 TOKEN('(');
378cc40b 2152 case ';':
79072805
LW		 2153 if (curcop->cop_line < copline)
2154 copline = curcop->cop_line;
378cc40b
LW		 2155 tmp = *s++;
2156 OPERATOR(tmp);
2157 case ')':
378cc40b 2158 tmp = *s++;
16d20bd9
AD		 2159 s = skipspace(s);
2160 if (*s == '{')
2161 PREBLOCK(tmp);
378cc40b 2162 TERM(tmp);
79072805
LW		 2163 case ']':
2164 s++;
463ee0b2
LW		 2165 if (lex_brackets <= 0)
2166 yyerror("Unmatched right bracket");
2167 else
2168 --lex_brackets;
79072805 2169 if (lex_state == LEX_INTERPNORMAL) {
463ee0b2 2170 if (lex_brackets == 0) {
a0d0e21e 2171 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
79072805
LW		 2172 lex_state = LEX_INTERPEND;
2173 }
2174 }
4633a7c4 2175 TERM(']');
79072805
LW		 2176 case '{':
2177 leftbracket:
79072805 2178 s++;
8990e307 2179 if (lex_brackets > 100) {
89bfa8cd 2180 char* newlb = Renew(lex_brackstack, lex_brackets + 1, char);
8990e307
LW		 2181 if (newlb != lex_brackstack) {
2182 SAVEFREEPV(newlb);
2183 lex_brackstack = newlb;
2184 }
2185 }
a0d0e21e
LW		 2186 switch (expect) {
2187 case XTERM:
2188 if (lex_formbrack) {
2189 s--;
2190 PRETERMBLOCK(DO);
2191 }
2192 if (oldoldbufptr == last_lop)
2193 lex_brackstack[lex_brackets++] = XTERM;
2194 else
2195 lex_brackstack[lex_brackets++] = XOPERATOR;
79072805 2196 OPERATOR(HASHBRACK);
a0d0e21e 2197 case XOPERATOR:
748a9306
LW		 2198 while (s < bufend && (*s == ' ' || *s == '\t'))
2199 s++;
44a8e56a 2200 d = s;
2201 tokenbuf[0] = '\0';
2202 if (d < bufend && *d == '-') {
2203 tokenbuf[0] = '-';
2204 d++;
2205 while (d < bufend && (*d == ' ' || *d == '\t'))
2206 d++;
2207 }
2208 if (d < bufend && isIDFIRST(*d)) {
8903cb82 2209 d = scan_word(d, tokenbuf + 1, sizeof tokenbuf - 1,
2210 FALSE, &len);
748a9306
LW		 2211 while (d < bufend && (*d == ' ' || *d == '\t'))
2212 d++;
2213 if (*d == '}') {
44a8e56a 2214 char minus = (tokenbuf[0] == '-');
44a8e56a 2215 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2216 if (minus)
2217 force_next('-');
748a9306
LW		 2218 }
2219 }
2220 /* FALL THROUGH */
2221 case XBLOCK:
a0d0e21e 2222 lex_brackstack[lex_brackets++] = XSTATE;
2304df62 2223 expect = XSTATE;
a0d0e21e
LW		 2224 break;
2225 case XTERMBLOCK:
2226 lex_brackstack[lex_brackets++] = XOPERATOR;
2227 expect = XSTATE;
2228 break;
2229 default: {
2230 char *t;
2231 if (oldoldbufptr == last_lop)
2232 lex_brackstack[lex_brackets++] = XTERM;
2233 else
2234 lex_brackstack[lex_brackets++] = XOPERATOR;
2235 s = skipspace(s);
69dcf70c
MB		 2236 if (*s == '}') {
2237 if (expect == XSTATE) {
2238 lex_brackstack[lex_brackets-1] = XSTATE;
2239 break;
2240 }
a0d0e21e 2241 OPERATOR(HASHBRACK);
69dcf70c 2242 }
b8a4b1be
GS		 2243 /* This hack serves to disambiguate a pair of curlies
2244 * as being a block or an anon hash. Normally, expectation
2245 * determines that, but in cases where we're not in a
2246 * position to expect anything in particular (like inside
2247 * eval"") we have to resolve the ambiguity. This code
2248 * covers the case where the first term in the curlies is a
2249 * quoted string. Most other cases need to be explicitly
2250 * disambiguated by prepending a `+' before the opening
2251 * curly in order to force resolution as an anon hash.
2252 *
2253 * XXX should probably propagate the outer expectation
2254 * into eval"" to rely less on this hack, but that could
2255 * potentially break current behavior of eval"".
2256 * GSAR 97-07-21
2257 */
2258 t = s;
2259 if (*s == '\'' || *s == '"' || *s == '`') {
2260 /* common case: get past first string, handling escapes */
2261 for (t++; t < bufend && *t != *s;)
2262 if (*t++ == '\\' && (*t == '\\' || *t == *s))
2263 t++;
2264 t++;
a0d0e21e 2265 }
b8a4b1be
GS		 2266 else if (*s == 'q') {
2267 if (++t < bufend
2268 && (!isALNUM(*t)
2269 || ((*t == 'q' || *t == 'x') && ++t < bufend
2270 && !isALNUM(*t)))) {
2271 char *tmps;
2272 char open, close, term;
2273 I32 brackets = 1;
2274
2275 while (t < bufend && isSPACE(*t))
2276 t++;
2277 term = *t;
2278 open = term;
2279 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
2280 term = tmps[5];
2281 close = term;
2282 if (open == close)
2283 for (t++; t < bufend; t++) {
6d07e5e9 2284 if (*t == '\\' && t+1 < bufend && open != '\\')
b8a4b1be 2285 t++;
6d07e5e9 2286 else if (*t == open)
b8a4b1be
GS		 2287 break;
2288 }
2289 else
2290 for (t++; t < bufend; t++) {
6d07e5e9 2291 if (*t == '\\' && t+1 < bufend)
b8a4b1be 2292 t++;
6d07e5e9 2293 else if (*t == close && --brackets <= 0)
b8a4b1be
GS		 2294 break;
2295 else if (*t == open)
2296 brackets++;
2297 }
2298 }
2299 t++;
a0d0e21e 2300 }
b8a4b1be
GS		 2301 else if (isALPHA(*s)) {
2302 for (t++; t < bufend && isALNUM(*t); t++) ;
a0d0e21e 2303 }
a0d0e21e
LW		 2304 while (t < bufend && isSPACE(*t))
2305 t++;
b8a4b1be
GS		 2306 /* if comma follows first term, call it an anon hash */
2307 /* XXX it could be a comma expression with loop modifiers */
2308 if (t < bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
2309 || (*t == '=' && t[1] == '>')))
a0d0e21e
LW		 2310 OPERATOR(HASHBRACK);
2311 if (expect == XREF)
2312 expect = XTERM;
2313 else {
2314 lex_brackstack[lex_brackets-1] = XSTATE;
2315 expect = XSTATE;
2316 }
8990e307 2317 }
a0d0e21e 2318 break;
463ee0b2 2319 }
79072805
LW		 2320 yylval.ival = curcop->cop_line;
2321 if (isSPACE(*s) || *s == '#')
2322 copline = NOLINE; /* invalidate current command line number */
79072805 2323 TOKEN('{');
378cc40b 2324 case '}':
79072805
LW		 2325 rightbracket:
2326 s++;
463ee0b2
LW		 2327 if (lex_brackets <= 0)
2328 yyerror("Unmatched right bracket");
2329 else
2330 expect = (expectation)lex_brackstack[--lex_brackets];
85e6fe83
LW		 2331 if (lex_brackets < lex_formbrack)
2332 lex_formbrack = 0;
79072805 2333 if (lex_state == LEX_INTERPNORMAL) {
463ee0b2 2334 if (lex_brackets == 0) {
79072805
LW		 2335 if (lex_fakebrack) {
2336 lex_state = LEX_INTERPEND;
2337 bufptr = s;
2338 return yylex(); /* ignore fake brackets */
2339 }
fa83b5b6 2340 if (*s == '-' && s[1] == '>')
2341 lex_state = LEX_INTERPENDMAYBE;
2342 else if (*s != '[' && *s != '{')
79072805
LW		 2343 lex_state = LEX_INTERPEND;
2344 }
2345 }
748a9306
LW		 2346 if (lex_brackets < lex_fakebrack) {
2347 bufptr = s;
2348 lex_fakebrack = 0;
2349 return yylex(); /* ignore fake brackets */
2350 }
79072805
LW		 2351 force_next('}');
2352 TOKEN(';');
378cc40b
LW		 2353 case '&':
2354 s++;
2355 tmp = *s++;
2356 if (tmp == '&')
a0d0e21e 2357 AOPERATOR(ANDAND);
378cc40b 2358 s--;
463ee0b2 2359 if (expect == XOPERATOR) {
fd049845 2360 if (dowarn && isALPHA(*s) && bufptr == linestart) {
463ee0b2
LW		 2361 curcop->cop_line--;
2362 warn(warn_nosemi);
2363 curcop->cop_line++;
2364 }
79072805 2365 BAop(OP_BIT_AND);
463ee0b2 2366 }
79072805 2367
8903cb82 2368 s = scan_ident(s - 1, bufend, tokenbuf, sizeof tokenbuf, TRUE);
463ee0b2
LW		 2369 if (*tokenbuf) {
2370 expect = XOPERATOR;
a0d0e21e 2371 force_ident(tokenbuf, '&');
463ee0b2 2372 }
79072805
LW		 2373 else
2374 PREREF('&');
c07a80fd 2375 yylval.ival = (OPpENTERSUB_AMPER<<8);
79072805
LW		 2376 TERM('&');
2377
378cc40b
LW		 2378 case '|':
2379 s++;
2380 tmp = *s++;
2381 if (tmp == '|')
a0d0e21e 2382 AOPERATOR(OROR);
378cc40b 2383 s--;
79072805 2384 BOop(OP_BIT_OR);
378cc40b
LW		 2385 case '=':
2386 s++;
2387 tmp = *s++;
2388 if (tmp == '=')
79072805
LW		 2389 Eop(OP_EQ);
2390 if (tmp == '>')
2391 OPERATOR(',');
378cc40b 2392 if (tmp == '~')
79072805 2393 PMop(OP_MATCH);
463ee0b2 2394 if (dowarn && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
ff0cee69 2395 warn("Reversed %c= operator",(int)tmp);
378cc40b 2396 s--;
748a9306 2397 if (expect == XSTATE && isALPHA(tmp) &&
fd049845 2398 (s == linestart+1 || s[-2] == '\n') )
748a9306 2399 {
a5f75d66
AD		 2400 if (in_eval && !rsfp) {
2401 d = bufend;
2402 while (s < d) {
2403 if (*s++ == '\n') {
2404 incline(s);
2405 if (strnEQ(s,"=cut",4)) {
2406 s = strchr(s,'\n');
2407 if (s)
2408 s++;
2409 else
2410 s = d;
2411 incline(s);
2412 goto retry;
2413 }
2414 }
2415 }
2416 goto retry;
2417 }
a0d0e21e
LW		 2418 s = bufend;
2419 doextract = TRUE;
2420 goto retry;
2421 }
2422 if (lex_brackets < lex_formbrack) {
2423 char *t;
2424 for (t = s; *t == ' ' || *t == '\t'; t++) ;
2425 if (*t == '\n' || *t == '#') {
2426 s--;
2427 expect = XBLOCK;
2428 goto leftbracket;
2429 }
79072805 2430 }
a0d0e21e
LW		 2431 yylval.ival = 0;
2432 OPERATOR(ASSIGNOP);
378cc40b
LW		 2433 case '!':
2434 s++;
2435 tmp = *s++;
2436 if (tmp == '=')
79072805 2437 Eop(OP_NE);
378cc40b 2438 if (tmp == '~')
79072805 2439 PMop(OP_NOT);
378cc40b
LW		 2440 s--;
2441 OPERATOR('!');
2442 case '<':
79072805 2443 if (expect != XOPERATOR) {
93a17b20 2444 if (s[1] != '<' && !strchr(s,'>'))
2f3197b3 2445 check_uni();
79072805
LW		 2446 if (s[1] == '<')
2447 s = scan_heredoc(s);
2448 else
2449 s = scan_inputsymbol(s);
2450 TERM(sublex_start());
378cc40b
LW		 2451 }
2452 s++;
2453 tmp = *s++;
2454 if (tmp == '<')
79072805 2455 SHop(OP_LEFT_SHIFT);
395c3793
LW		 2456 if (tmp == '=') {
2457 tmp = *s++;
2458 if (tmp == '>')
79072805 2459 Eop(OP_NCMP);
395c3793 2460 s--;
79072805 2461 Rop(OP_LE);
395c3793 2462 }
378cc40b 2463 s--;
79072805 2464 Rop(OP_LT);
378cc40b
LW		 2465 case '>':
2466 s++;
2467 tmp = *s++;
2468 if (tmp == '>')
79072805 2469 SHop(OP_RIGHT_SHIFT);
378cc40b 2470 if (tmp == '=')
79072805 2471 Rop(OP_GE);
378cc40b 2472 s--;
79072805 2473 Rop(OP_GT);
378cc40b
LW		 2474
2475 case '$':
bbce6d69 2476 CLINE;
2477
8990e307 2478 if (expect == XOPERATOR) {
a0d0e21e
LW		 2479 if (lex_formbrack && lex_brackets == lex_formbrack) {
2480 expect = XTERM;
2481 depcom();
bbce6d69 2482 return ','; /* grandfather non-comma-format format */
a0d0e21e 2483 }
8990e307 2484 }
a0d0e21e 2485
bbce6d69 2486 if (s[1] == '#' && (isALPHA(s[2]) || strchr("_{$:", s[2]))) {
2487 if (expect == XOPERATOR)
2488 no_op("Array length", bufptr);
2489 tokenbuf[0] = '@';
8903cb82 2490 s = scan_ident(s + 1, bufend, tokenbuf + 1, sizeof tokenbuf - 1,
2491 FALSE);
bbce6d69 2492 if (!tokenbuf[1])
a0d0e21e 2493 PREREF(DOLSHARP);
463ee0b2 2494 expect = XOPERATOR;
bbce6d69 2495 pending_ident = '#';
463ee0b2 2496 TOKEN(DOLSHARP);
79072805 2497 }
bbce6d69 2498
2499 if (expect == XOPERATOR)
2500 no_op("Scalar", bufptr);
2501 tokenbuf[0] = '$';
8903cb82 2502 s = scan_ident(s, bufend, tokenbuf + 1, sizeof tokenbuf - 1, FALSE);
bbce6d69 2503 if (!tokenbuf[1]) {
2504 if (s == bufend)
2505 yyerror("Final $ should be \\$ or $name");
2506 PREREF('$');
8990e307 2507 }
a0d0e21e 2508
bbce6d69 2509 /* This kludge not intended to be bulletproof. */
2510 if (tokenbuf[1] == '[' && !tokenbuf[2]) {
2511 yylval.opval = newSVOP(OP_CONST, 0,
2512 newSViv((IV)compiling.cop_arybase));
2513 yylval.opval->op_private = OPpCONST_ARYBASE;
2514 TERM(THING);
2515 }
2516
ff68c719 2517 d = s;
2518 if (lex_state == LEX_NORMAL)
2519 s = skipspace(s);
2520
bbce6d69 2521 if ((expect != XREF || oldoldbufptr == last_lop) && intuit_more(s)) {
2522 char *t;
2523 if (*s == '[') {
2524 tokenbuf[0] = '@';
2525 if (dowarn) {
2526 for(t = s + 1;
2527 isSPACE(*t) || isALNUM(*t) || *t == '$';
2528 t++) ;
a0d0e21e
LW		 2529 if (*t++ == ',') {
2530 bufptr = skipspace(bufptr);
bbce6d69 2531 while (t < bufend && *t != ']')
2532 t++;
a0d0e21e 2533 warn("Multidimensional syntax %.*s not supported",
bbce6d69 2534 (t - bufptr) + 1, bufptr);
a0d0e21e
LW		 2535 }
2536 }
bbce6d69 2537 }
2538 else if (*s == '{') {
2539 tokenbuf[0] = '%';
2540 if (dowarn && strEQ(tokenbuf+1, "SIG") &&
2541 (t = strchr(s, '}')) && (t = strchr(t, '=')))
2542 {
8903cb82 2543 char tmpbuf[sizeof tokenbuf];
a0d0e21e
LW		 2544 STRLEN len;
2545 for (t++; isSPACE(*t); t++) ;
748a9306 2546 if (isIDFIRST(*t)) {
8903cb82 2547 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
748a9306
LW		 2548 if (*t != '(' && perl_get_cv(tmpbuf, FALSE))
2549 warn("You need to quote \"%s\"", tmpbuf);
2550 }
93a17b20
LW		 2551 }
2552 }
2f3197b3 2553 }
bbce6d69 2554
2555 expect = XOPERATOR;
ff68c719 2556 if (lex_state == LEX_NORMAL && isSPACE(*d)) {
bbce6d69 2557 bool islop = (last_lop == oldoldbufptr);
bbce6d69 2558 if (!islop || last_lop_op == OP_GREPSTART)
2559 expect = XOPERATOR;
2560 else if (strchr("$@\"'`q", *s))
2561 expect = XTERM; /* e.g. print $fh "foo" */
2562 else if (strchr("&*<%", *s) && isIDFIRST(s[1]))
2563 expect = XTERM; /* e.g. print $fh &sub */
68dc0745 2564 else if (isIDFIRST(*s)) {
8903cb82 2565 char tmpbuf[sizeof tokenbuf];
2566 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
84902520
TB		 2567 if (tmp = keyword(tmpbuf, len)) {
2568 /* binary operators exclude handle interpretations */
2569 switch (tmp) {
2570 case -KEY_x:
2571 case -KEY_eq:
2572 case -KEY_ne:
2573 case -KEY_gt:
2574 case -KEY_lt:
2575 case -KEY_ge:
2576 case -KEY_le:
2577 case -KEY_cmp:
2578 break;
2579 default:
2580 expect = XTERM; /* e.g. print $fh length() */
2581 break;
2582 }
2583 }
68dc0745 2584 else {
2585 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
2586 if (gv && GvCVu(gv))
2587 expect = XTERM; /* e.g. print $fh subr() */
93a17b20 2588 }
93a17b20 2589 }
bbce6d69 2590 else if (isDIGIT(*s))
2591 expect = XTERM; /* e.g. print $fh 3 */
2592 else if (*s == '.' && isDIGIT(s[1]))
2593 expect = XTERM; /* e.g. print $fh .3 */
2594 else if (strchr("/?-+", *s) && !isSPACE(s[1]))
2595 expect = XTERM; /* e.g. print $fh -1 */
2596 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]))
2597 expect = XTERM; /* print $fh <<"EOF" */
2598 }
2599 pending_ident = '$';
79072805 2600 TOKEN('$');
378cc40b
LW		 2601
2602 case '@':
8990e307 2603 if (expect == XOPERATOR)
bbce6d69 2604 no_op("Array", s);
2605 tokenbuf[0] = '@';
8903cb82 2606 s = scan_ident(s, bufend, tokenbuf + 1, sizeof tokenbuf - 1, FALSE);
bbce6d69 2607 if (!tokenbuf[1]) {
2608 if (s == bufend)
2609 yyerror("Final @ should be \\@ or @name");
2610 PREREF('@');
2611 }
ff68c719 2612 if (lex_state == LEX_NORMAL)
2613 s = skipspace(s);
bbce6d69 2614 if ((expect != XREF || oldoldbufptr == last_lop) && intuit_more(s)) {
2615 if (*s == '{')
2616 tokenbuf[0] = '%';
a0d0e21e
LW		 2617
2618 /* Warn about @ where they meant $. */
2619 if (dowarn) {
2620 if (*s == '[' || *s == '{') {
2621 char *t = s + 1;
2622 while (*t && (isALNUM(*t) || strchr(" \t$#+-'\"", *t)))
2623 t++;
2624 if (*t == '}' || *t == ']') {
2625 t++;
2626 bufptr = skipspace(bufptr);
2627 warn("Scalar value %.*s better written as $%.*s",
2628 t-bufptr, bufptr, t-bufptr-1, bufptr+1);
2629 }
93a17b20
LW		 2630 }
2631 }
463ee0b2 2632 }
bbce6d69 2633 pending_ident = '@';
79072805 2634 TERM('@');
378cc40b
LW		 2635
2636 case '/': /* may either be division or pattern */
2637 case '?': /* may either be conditional or pattern */
79072805 2638 if (expect != XOPERATOR) {
c277df42
IZ		 2639 /* Disable warning on "study /blah/" */
2640 if (oldoldbufptr == last_uni
2641 && (*last_uni != 's' || s - last_uni < 5
2642 || memNE(last_uni, "study", 5) || isALNUM(last_uni[5])))
2643 check_uni();
79072805
LW		 2644 s = scan_pat(s);
2645 TERM(sublex_start());
378cc40b
LW		 2646 }
2647 tmp = *s++;
a687059c 2648 if (tmp == '/')
79072805 2649 Mop(OP_DIVIDE);
378cc40b
LW		 2650 OPERATOR(tmp);
2651
2652 case '.':
748a9306 2653 if (lex_formbrack && lex_brackets == lex_formbrack && s[1] == '\n' &&
fd049845 2654 (s == linestart || s[-1] == '\n') ) {
85e6fe83 2655 lex_formbrack = 0;
8990e307 2656 expect = XSTATE;
79072805
LW		 2657 goto rightbracket;
2658 }
2659 if (expect == XOPERATOR || !isDIGIT(s[1])) {
378cc40b 2660 tmp = *s++;
a687059c
LW		 2661 if (*s == tmp) {
2662 s++;
2f3197b3
LW		 2663 if (*s == tmp) {
2664 s++;
79072805 2665 yylval.ival = OPf_SPECIAL;
2f3197b3
LW		 2666 }
2667 else
79072805 2668 yylval.ival = 0;
378cc40b 2669 OPERATOR(DOTDOT);
a687059c 2670 }
79072805 2671 if (expect != XOPERATOR)
2f3197b3 2672 check_uni();
79072805 2673 Aop(OP_CONCAT);
378cc40b
LW		 2674 }
2675 /* FALL THROUGH */
2676 case '0': case '1': case '2': case '3': case '4':
2677 case '5': case '6': case '7': case '8': case '9':
79072805 2678 s = scan_num(s);
8990e307
LW		 2679 if (expect == XOPERATOR)
2680 no_op("Number",s);
79072805
LW		 2681 TERM(THING);
2682
2683 case '\'':
8990e307 2684 s = scan_str(s);
463ee0b2 2685 if (expect == XOPERATOR) {
a0d0e21e
LW		 2686 if (lex_formbrack && lex_brackets == lex_formbrack) {
2687 expect = XTERM;
2688 depcom();
2689 return ','; /* grandfather non-comma-format format */
2690 }
463ee0b2 2691 else
8990e307 2692 no_op("String",s);
463ee0b2 2693 }
79072805 2694 if (!s)
85e6fe83 2695 missingterm((char*)0);
79072805
LW		 2696 yylval.ival = OP_CONST;
2697 TERM(sublex_start());
2698
2699 case '"':
8990e307 2700 s = scan_str(s);
463ee0b2 2701 if (expect == XOPERATOR) {
a0d0e21e
LW		 2702 if (lex_formbrack && lex_brackets == lex_formbrack) {
2703 expect = XTERM;
2704 depcom();
2705 return ','; /* grandfather non-comma-format format */
2706 }
463ee0b2 2707 else
8990e307 2708 no_op("String",s);
463ee0b2 2709 }
79072805 2710 if (!s)
85e6fe83 2711 missingterm((char*)0);
4633a7c4
LW		 2712 yylval.ival = OP_CONST;
2713 for (d = SvPV(lex_stuff, len); len; len--, d++) {
2714 if (*d == '$' || *d == '@' || *d == '\\') {
2715 yylval.ival = OP_STRINGIFY;
2716 break;
2717 }
2718 }
79072805
LW		 2719 TERM(sublex_start());
2720
2721 case '`':
2722 s = scan_str(s);
8990e307
LW		 2723 if (expect == XOPERATOR)
2724 no_op("Backticks",s);
79072805 2725 if (!s)
85e6fe83 2726 missingterm((char*)0);
79072805
LW		 2727 yylval.ival = OP_BACKTICK;
2728 set_csh();
2729 TERM(sublex_start());
2730
2731 case '\\':
2732 s++;
748a9306
LW		 2733 if (dowarn && lex_inwhat && isDIGIT(*s))
2734 warn("Can't use \\%c to mean $%c in expression", *s, *s);
8990e307
LW		 2735 if (expect == XOPERATOR)
2736 no_op("Backslash",s);
79072805
LW		 2737 OPERATOR(REFGEN);
2738
2739 case 'x':
2740 if (isDIGIT(s[1]) && expect == XOPERATOR) {
2741 s++;
2742 Mop(OP_REPEAT);
2f3197b3 2743 }
79072805
LW		 2744 goto keylookup;
2745
378cc40b 2746 case '_':
79072805
LW		 2747 case 'a': case 'A':
2748 case 'b': case 'B':
2749 case 'c': case 'C':
2750 case 'd': case 'D':
2751 case 'e': case 'E':
2752 case 'f': case 'F':
2753 case 'g': case 'G':
2754 case 'h': case 'H':
2755 case 'i': case 'I':
2756 case 'j': case 'J':
2757 case 'k': case 'K':
2758 case 'l': case 'L':
2759 case 'm': case 'M':
2760 case 'n': case 'N':
2761 case 'o': case 'O':
2762 case 'p': case 'P':
2763 case 'q': case 'Q':
2764 case 'r': case 'R':
2765 case 's': case 'S':
2766 case 't': case 'T':
2767 case 'u': case 'U':
2768 case 'v': case 'V':
2769 case 'w': case 'W':
2770 case 'X':
2771 case 'y': case 'Y':
2772 case 'z': case 'Z':
2773
49dc05e3 2774 keylookup: {
161b471a
NIS		 2775 gv = Nullgv;
2776 gvp = 0;
49dc05e3 2777
748a9306 2778 bufptr = s;
8903cb82 2779 s = scan_word(s, tokenbuf, sizeof tokenbuf, FALSE, &len);
8ebc5c01 2780
2781 /* Some keywords can be followed by any delimiter, including ':' */
2782 tmp = (len == 1 && strchr("msyq", tokenbuf[0]) ||
2783 len == 2 && ((tokenbuf[0] == 't' && tokenbuf[1] == 'r') ||
2784 (tokenbuf[0] == 'q' &&
2785 strchr("qwx", tokenbuf[1]))));
2786
2787 /* x::* is just a word, unless x is "CORE" */
2788 if (!tmp && *s == ':' && s[1] == ':' && strNE(tokenbuf, "CORE"))
4633a7c4
LW		 2789 goto just_a_word;
2790
3643fb5f
CS		 2791 d = s;
2792 while (d < bufend && isSPACE(*d))
2793 d++; /* no comments skipped here, or s### is misparsed */
2794
2795 /* Is this a label? */
8ebc5c01 2796 if (!tmp && expect == XSTATE
2797 && d < bufend && *d == ':' && *(d + 1) != ':') {
2798 s = d + 1;
2799 yylval.pval = savepv(tokenbuf);
2800 CLINE;
2801 TOKEN(LABEL);
3643fb5f
CS		 2802 }
2803
2804 /* Check for keywords */
a0d0e21e 2805 tmp = keyword(tokenbuf, len);
748a9306
LW		 2806
2807 /* Is this a word before a => operator? */
748a9306
LW		 2808 if (strnEQ(d,"=>",2)) {
2809 CLINE;
748a9306
LW		 2810 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(tokenbuf,0));
2811 yylval.opval->op_private = OPpCONST_BARE;
2812 TERM(WORD);
2813 }
2814
a0d0e21e 2815 if (tmp < 0) { /* second-class keyword? */
49dc05e3
GS		 2816 if (expect != XOPERATOR && (*s != ':' || s[1] != ':') &&
2817 (((gv = gv_fetchpv(tokenbuf, FALSE, SVt_PVCV)) &&
2818 GvCVu(gv) && GvIMPORTED_CV(gv)) ||
2819 ((gvp = (GV**)hv_fetch(globalstash,tokenbuf,len,FALSE)) &&
2820 (gv = *gvp) != (GV*)&sv_undef &&
2821 GvCVu(gv) && GvIMPORTED_CV(gv))))
a0d0e21e 2822 {
6e7b2336
GS		 2823 tmp = 0; /* overridden by importation */
2824 }
2825 else if (gv && !gvp
2826 && -tmp==KEY_lock /* XXX generalizable kludge */
1d64a758 2827 && !hv_fetch(GvHVn(incgv), "Thread.pm", 9, FALSE))
6e7b2336
GS		 2828 {
2829 tmp = 0; /* any sub overrides "weak" keyword */
a0d0e21e 2830 }
49dc05e3
GS		 2831 else {
2832 tmp = -tmp; gv = Nullgv; gvp = 0;
2833 }
a0d0e21e
LW		 2834 }
2835
2836 reserved_word:
2837 switch (tmp) {
79072805
LW		 2838
2839 default: /* not a keyword */
93a17b20 2840 just_a_word: {
96e4d5b1 2841 SV *sv;
748a9306 2842 char lastchar = (bufptr == oldoldbufptr ? 0 : bufptr[-1]);
8990e307
LW		 2843
2844 /* Get the rest if it looks like a package qualifier */
2845
a0d0e21e 2846 if (*s == '\'' || *s == ':' && s[1] == ':') {
c3e0f903 2847 STRLEN morelen;
8903cb82 2848 s = scan_word(s, tokenbuf + len, sizeof tokenbuf - len,
c3e0f903
GS		 2849 TRUE, &morelen);
2850 if (!morelen)
ec2ab091
HM		 2851 croak("Bad name after %s%s", tokenbuf,
2852 *s == '\'' ? "'" : "::");
c3e0f903 2853 len += morelen;
a0d0e21e 2854 }
8990e307 2855
3643fb5f 2856 if (expect == XOPERATOR) {
fd049845 2857 if (bufptr == linestart) {
463ee0b2
LW		 2858 curcop->cop_line--;
2859 warn(warn_nosemi);
2860 curcop->cop_line++;
2861 }
2862 else
54310121 2863 no_op("Bareword",s);
463ee0b2 2864 }
8990e307 2865
c3e0f903
GS		 2866 /* Look for a subroutine with this name in current package,
2867 unless name is "Foo::", in which case Foo is a bearword
2868 (and a package name). */
2869
2870 if (len > 2 &&
2871 tokenbuf[len - 2] == ':' && tokenbuf[len - 1] == ':')
2872 {
2873 if (dowarn && ! gv_fetchpv(tokenbuf, FALSE, SVt_PVHV))
2874 warn("Bareword \"%s\" refers to nonexistent package",
2875 tokenbuf);
2876 len -= 2;
2877 tokenbuf[len] = '\0';
2878 gv = Nullgv;
2879 gvp = 0;
2880 }
2881 else {
2882 len = 0;
2883 if (!gv)
2884 gv = gv_fetchpv(tokenbuf, FALSE, SVt_PVCV);
2885 }
2886
2887 /* if we saw a global override before, get the right name */
8990e307 2888
49dc05e3
GS		 2889 if (gvp) {
2890 sv = newSVpv("CORE::GLOBAL::",14);
2891 sv_catpv(sv,tokenbuf);
2892 }
2893 else
2894 sv = newSVpv(tokenbuf,0);
8990e307 2895
a0d0e21e
LW		 2896 /* Presume this is going to be a bareword of some sort. */
2897
2898 CLINE;
49dc05e3 2899 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
a0d0e21e
LW		 2900 yylval.opval->op_private = OPpCONST_BARE;
2901
c3e0f903
GS		 2902 /* And if "Foo::", then that's what it certainly is. */
2903
2904 if (len)
2905 goto safe_bareword;
2906
8990e307
LW		 2907 /* See if it's the indirect object for a list operator. */
2908
a0d0e21e
LW		 2909 if (oldoldbufptr &&
2910 oldoldbufptr < bufptr &&
2911 (oldoldbufptr == last_lop || oldoldbufptr == last_uni) &&
2912 /* NO SKIPSPACE BEFORE HERE! */
2913 (expect == XREF ||
4e35701f 2914 ((opargs[last_lop_op] >> OASHIFT)& 7) == OA_FILEREF) )
a0d0e21e 2915 {
748a9306
LW		 2916 bool immediate_paren = *s == '(';
2917
a0d0e21e
LW		 2918 /* (Now we can afford to cross potential line boundary.) */
2919 s = skipspace(s);
2920
2921 /* Two barewords in a row may indicate method call. */
2922
2923 if ((isALPHA(*s) || *s == '$') && (tmp=intuit_method(s,gv)))
2924 return tmp;
2925
2926 /* If not a declared subroutine, it's an indirect object. */
2927 /* (But it's an indir obj regardless for sort.) */
2928
8e07c86e 2929 if ((last_lop_op == OP_SORT ||
8ebc5c01 2930 (!immediate_paren && (!gv || !GvCVu(gv))) ) &&
8e07c86e 2931 (last_lop_op != OP_MAPSTART && last_lop_op != OP_GREPSTART)){
748a9306
LW		 2932 expect = (last_lop == oldoldbufptr) ? XTERM : XOPERATOR;
2933 goto bareword;
93a17b20
LW		 2934 }
2935 }
8990e307
LW		 2936
2937 /* If followed by a paren, it's certainly a subroutine. */
2938
2939 expect = XOPERATOR;
2940 s = skipspace(s);
93a17b20 2941 if (*s == '(') {
79072805 2942 CLINE;
96e4d5b1 2943 if (gv && GvCVu(gv)) {
2944 for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
2945 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
2946 s = d + 1;
2947 goto its_constant;
2948 }
2949 }
a0d0e21e 2950 nextval[nexttoke].opval = yylval.opval;
463ee0b2 2951 expect = XOPERATOR;
93a17b20 2952 force_next(WORD);
c07a80fd 2953 yylval.ival = 0;
463ee0b2 2954 TOKEN('&');
79072805 2955 }
93a17b20 2956
a0d0e21e 2957 /* If followed by var or block, call it a method (unless sub) */
8990e307 2958
8ebc5c01 2959 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
463ee0b2 2960 last_lop = oldbufptr;
8990e307 2961 last_lop_op = OP_METHOD;
93a17b20 2962 PREBLOCK(METHOD);
463ee0b2
LW		 2963 }
2964
8990e307
LW		 2965 /* If followed by a bareword, see if it looks like indir obj. */
2966
a0d0e21e
LW		 2967 if ((isALPHA(*s) || *s == '$') && (tmp = intuit_method(s,gv)))
2968 return tmp;
93a17b20 2969
8990e307
LW		 2970 /* Not a method, so call it a subroutine (if defined) */
2971
8ebc5c01 2972 if (gv && GvCVu(gv)) {
46fc3d4c 2973 CV* cv;
748a9306 2974 if (lastchar == '-')
c2960299 2975 warn("Ambiguous use of -%s resolved as -&%s()",
748a9306 2976 tokenbuf, tokenbuf);
8990e307 2977 last_lop = oldbufptr;
a0d0e21e 2978 last_lop_op = OP_ENTERSUB;
89bfa8cd 2979 /* Check for a constant sub */
46fc3d4c 2980 cv = GvCV(gv);
96e4d5b1 2981 if ((sv = cv_const_sv(cv))) {
2982 its_constant:
2983 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
2984 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
2985 yylval.opval->op_private = 0;
2986 TOKEN(WORD);
89bfa8cd 2987 }
2988
a5f75d66
AD		 2989 /* Resolve to GV now. */
2990 op_free(yylval.opval);
2991 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
4633a7c4
LW		 2992 /* Is there a prototype? */
2993 if (SvPOK(cv)) {
2994 STRLEN len;
2995 char *proto = SvPV((SV*)cv, len);
2996 if (!len)
2997 TERM(FUNC0SUB);
2998 if (strEQ(proto, "$"))
2999 OPERATOR(UNIOPSUB);
3000 if (*proto == '&' && *s == '{') {
3001 sv_setpv(subname,"__ANON__");
3002 PREBLOCK(LSTOPSUB);
3003 }
3004 }
a5f75d66 3005 nextval[nexttoke].opval = yylval.opval;
8990e307
LW		 3006 expect = XTERM;
3007 force_next(WORD);
3008 TOKEN(NOAMP);
3009 }
748a9306
LW		 3010
3011 if (hints & HINT_STRICT_SUBS &&
3012 lastchar != '-' &&
a0d0e21e 3013 strnNE(s,"->",2) &&
9b01e405 3014 last_lop_op != OP_TRUNCATE && /* S/F prototype in opcode.pl */
a0d0e21e
LW		 3015 last_lop_op != OP_ACCEPT &&
3016 last_lop_op != OP_PIPE_OP &&
3017 last_lop_op != OP_SOCKPAIR)
3018 {
3019 warn(
3020 "Bareword \"%s\" not allowed while \"strict subs\" in use",
85e6fe83
LW		 3021 tokenbuf);
3022 ++error_count;
3023 }
8990e307
LW		 3024
3025 /* Call it a bare word */
3026
748a9306
LW		 3027 bareword:
3028 if (dowarn) {
3029 if (lastchar != '-') {
3030 for (d = tokenbuf; *d && isLOWER(*d); d++) ;
3031 if (!*d)
3032 warn(warn_reserved, tokenbuf);
3033 }
3034 }
c3e0f903
GS		 3035
3036 safe_bareword:
748a9306
LW		 3037 if (lastchar && strchr("*%&", lastchar)) {
3038 warn("Operator or semicolon missing before %c%s",
3039 lastchar, tokenbuf);
c2960299 3040 warn("Ambiguous use of %c resolved as operator %c",
748a9306
LW		 3041 lastchar, lastchar);
3042 }
93a17b20 3043 TOKEN(WORD);
79072805 3044 }
79072805 3045
68dc0745 3046 case KEY___FILE__:
46fc3d4c 3047 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3048 newSVsv(GvSV(curcop->cop_filegv)));
3049 TERM(THING);
3050
79072805 3051 case KEY___LINE__:
46fc3d4c 3052 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3053 newSVpvf("%ld", (long)curcop->cop_line));
79072805 3054 TERM(THING);
68dc0745 3055
3056 case KEY___PACKAGE__:
3057 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3058 (curstash
3059 ? newSVsv(curstname)
3060 : &sv_undef));
79072805 3061 TERM(THING);
79072805 3062
e50aee73 3063 case KEY___DATA__:
79072805
LW		 3064 case KEY___END__: {
3065 GV *gv;
79072805
LW		 3066
3067 /*SUPPRESS 560*/
a5f75d66 3068 if (rsfp && (!in_eval || tokenbuf[2] == 'D')) {
e50aee73
AD		 3069 char *pname = "main";
3070 if (tokenbuf[2] == 'D')
3071 pname = HvNAME(curstash ? curstash : defstash);
46fc3d4c 3072 gv = gv_fetchpv(form("%s::DATA", pname), TRUE, SVt_PVIO);
a5f75d66 3073 GvMULTI_on(gv);
79072805 3074 if (!GvIO(gv))
a0d0e21e
LW		 3075 GvIOp(gv) = newIO();
3076 IoIFP(GvIOp(gv)) = rsfp;
3077#if defined(HAS_FCNTL) && defined(F_SETFD)
3078 {
760ac839 3079 int fd = PerlIO_fileno(rsfp);
a0d0e21e
LW		 3080 fcntl(fd,F_SETFD,fd >= 3);
3081 }
79072805 3082#endif
fd049845 3083 /* Mark this internal pseudo-handle as clean */
3084 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
79072805 3085 if (preprocess)
a0d0e21e 3086 IoTYPE(GvIOp(gv)) = '|';
760ac839 3087 else if ((PerlIO*)rsfp == PerlIO_stdin())
a0d0e21e 3088 IoTYPE(GvIOp(gv)) = '-';
79072805 3089 else
a0d0e21e 3090 IoTYPE(GvIOp(gv)) = '<';
79072805
LW		 3091 rsfp = Nullfp;
3092 }
3093 goto fake_eof;
e929a76b 3094 }
de3bb511 3095
8990e307 3096 case KEY_AUTOLOAD:
ed6116ce 3097 case KEY_DESTROY:
79072805
LW		 3098 case KEY_BEGIN:
3099 case KEY_END:
7d07dbc2 3100 case KEY_INIT:
a0d0e21e 3101 if (expect == XSTATE) {
93a17b20
LW		 3102 s = bufptr;
3103 goto really_sub;
79072805
LW		 3104 }
3105 goto just_a_word;
3106
a0d0e21e
LW		 3107 case KEY_CORE:
3108 if (*s == ':' && s[1] == ':') {
3109 s += 2;
748a9306 3110 d = s;
8903cb82 3111 s = scan_word(s, tokenbuf, sizeof tokenbuf, FALSE, &len);
a0d0e21e
LW		 3112 tmp = keyword(tokenbuf, len);
3113 if (tmp < 0)
3114 tmp = -tmp;
3115 goto reserved_word;
3116 }
3117 goto just_a_word;
3118
463ee0b2
LW		 3119 case KEY_abs:
3120 UNI(OP_ABS);
3121
79072805
LW		 3122 case KEY_alarm:
3123 UNI(OP_ALARM);
3124
3125 case KEY_accept:
a0d0e21e 3126 LOP(OP_ACCEPT,XTERM);
79072805 3127
463ee0b2
LW		 3128 case KEY_and:
3129 OPERATOR(ANDOP);
3130
79072805 3131 case KEY_atan2:
a0d0e21e 3132 LOP(OP_ATAN2,XTERM);
85e6fe83 3133
79072805 3134 case KEY_bind:
a0d0e21e 3135 LOP(OP_BIND,XTERM);
79072805
LW		 3136
3137 case KEY_binmode:
3138 UNI(OP_BINMODE);
3139
3140 case KEY_bless:
a0d0e21e 3141 LOP(OP_BLESS,XTERM);
79072805
LW		 3142
3143 case KEY_chop:
3144 UNI(OP_CHOP);
3145
3146 case KEY_continue:
3147 PREBLOCK(CONTINUE);
3148
3149 case KEY_chdir:
85e6fe83 3150 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
79072805
LW		 3151 UNI(OP_CHDIR);
3152
3153 case KEY_close:
3154 UNI(OP_CLOSE);
3155
3156 case KEY_closedir:
3157 UNI(OP_CLOSEDIR);
3158
3159 case KEY_cmp:
3160 Eop(OP_SCMP);
3161
3162 case KEY_caller:
3163 UNI(OP_CALLER);
3164
3165 case KEY_crypt:
3166#ifdef FCRYPT
de3bb511
LW		 3167 if (!cryptseen++)
3168 init_des();
a687059c 3169#endif
a0d0e21e 3170 LOP(OP_CRYPT,XTERM);
79072805
LW		 3171
3172 case KEY_chmod:
748a9306
LW		 3173 if (dowarn) {
3174 for (d = s; d < bufend && (isSPACE(*d) || *d == '('); d++) ;
3175 if (*d != '0' && isDIGIT(*d))
3176 yywarn("chmod: mode argument is missing initial 0");
3177 }
a0d0e21e 3178 LOP(OP_CHMOD,XTERM);
79072805
LW		 3179
3180 case KEY_chown:
a0d0e21e 3181 LOP(OP_CHOWN,XTERM);
79072805
LW		 3182
3183 case KEY_connect:
a0d0e21e 3184 LOP(OP_CONNECT,XTERM);
79072805 3185
463ee0b2
LW		 3186 case KEY_chr:
3187 UNI(OP_CHR);
3188
79072805
LW		 3189 case KEY_cos:
3190 UNI(OP_COS);
3191
3192 case KEY_chroot:
3193 UNI(OP_CHROOT);
3194
3195 case KEY_do:
3196 s = skipspace(s);
3197 if (*s == '{')
a0d0e21e 3198 PRETERMBLOCK(DO);
79072805 3199 if (*s != '\'')
a0d0e21e 3200 s = force_word(s,WORD,FALSE,TRUE,FALSE);
378cc40b 3201 OPERATOR(DO);
79072805
LW		 3202
3203 case KEY_die:
a0d0e21e
LW		 3204 hints |= HINT_BLOCK_SCOPE;
3205 LOP(OP_DIE,XTERM);
79072805
LW		 3206
3207 case KEY_defined:
3208 UNI(OP_DEFINED);
3209
3210 case KEY_delete:
a0d0e21e 3211 UNI(OP_DELETE);
79072805
LW		 3212
3213 case KEY_dbmopen:
a0d0e21e
LW		 3214 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3215 LOP(OP_DBMOPEN,XTERM);
79072805
LW		 3216
3217 case KEY_dbmclose:
3218 UNI(OP_DBMCLOSE);
3219
3220 case KEY_dump:
a0d0e21e 3221 s = force_word(s,WORD,TRUE,FALSE,FALSE);
79072805
LW		 3222 LOOPX(OP_DUMP);
3223
3224 case KEY_else:
3225 PREBLOCK(ELSE);
3226
3227 case KEY_elsif:
3228 yylval.ival = curcop->cop_line;
3229 OPERATOR(ELSIF);
3230
3231 case KEY_eq:
3232 Eop(OP_SEQ);
3233
a0d0e21e
LW		 3234 case KEY_exists:
3235 UNI(OP_EXISTS);
3236
79072805
LW		 3237 case KEY_exit:
3238 UNI(OP_EXIT);
3239
3240 case KEY_eval:
79072805 3241 s = skipspace(s);
a0d0e21e 3242 expect = (*s == '{') ? XTERMBLOCK : XTERM;
463ee0b2 3243 UNIBRACK(OP_ENTEREVAL);
79072805
LW		 3244
3245 case KEY_eof:
3246 UNI(OP_EOF);
3247
3248 case KEY_exp:
3249 UNI(OP_EXP);
3250
3251 case KEY_each:
3252 UNI(OP_EACH);
3253
3254 case KEY_exec:
3255 set_csh();
a0d0e21e 3256 LOP(OP_EXEC,XREF);
79072805
LW		 3257
3258 case KEY_endhostent:
3259 FUN0(OP_EHOSTENT);
3260
3261 case KEY_endnetent:
3262 FUN0(OP_ENETENT);
3263
3264 case KEY_endservent:
3265 FUN0(OP_ESERVENT);
3266
3267 case KEY_endprotoent:
3268 FUN0(OP_EPROTOENT);
3269
3270 case KEY_endpwent:
3271 FUN0(OP_EPWENT);
3272
3273 case KEY_endgrent:
3274 FUN0(OP_EGRENT);
3275
3276 case KEY_for:
3277 case KEY_foreach:
3278 yylval.ival = curcop->cop_line;
55497cff 3279 s = skipspace(s);
ecca16b0 3280 if (expect == XSTATE && isIDFIRST(*s)) {
55497cff 3281 char *p = s;
3282 if ((bufend - p) >= 3 &&
3283 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3284 p += 2;
3285 p = skipspace(p);
3286 if (isIDFIRST(*p))
3287 croak("Missing $ on loop variable");
3288 }
79072805
LW		 3289 OPERATOR(FOR);
3290
3291 case KEY_formline:
a0d0e21e 3292 LOP(OP_FORMLINE,XTERM);
79072805
LW		 3293
3294 case KEY_fork:
3295 FUN0(OP_FORK);
3296
3297 case KEY_fcntl:
a0d0e21e 3298 LOP(OP_FCNTL,XTERM);
79072805
LW		 3299
3300 case KEY_fileno:
3301 UNI(OP_FILENO);
3302
3303 case KEY_flock:
a0d0e21e 3304 LOP(OP_FLOCK,XTERM);
79072805
LW		 3305
3306 case KEY_gt:
3307 Rop(OP_SGT);
3308
3309 case KEY_ge:
3310 Rop(OP_SGE);
3311
3312 case KEY_grep:
a0d0e21e 3313 LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
79072805
LW		 3314
3315 case KEY_goto:
a0d0e21e 3316 s = force_word(s,WORD,TRUE,FALSE,FALSE);
79072805
LW		 3317 LOOPX(OP_GOTO);
3318
3319 case KEY_gmtime:
3320 UNI(OP_GMTIME);
3321
3322 case KEY_getc:
3323 UNI(OP_GETC);
3324
3325 case KEY_getppid:
3326 FUN0(OP_GETPPID);
3327
3328 case KEY_getpgrp:
3329 UNI(OP_GETPGRP);
3330
3331 case KEY_getpriority:
a0d0e21e 3332 LOP(OP_GETPRIORITY,XTERM);
79072805
LW		 3333
3334 case KEY_getprotobyname:
3335 UNI(OP_GPBYNAME);
3336
3337 case KEY_getprotobynumber:
a0d0e21e 3338 LOP(OP_GPBYNUMBER,XTERM);
79072805
LW		 3339
3340 case KEY_getprotoent:
3341 FUN0(OP_GPROTOENT);
3342
3343 case KEY_getpwent:
3344 FUN0(OP_GPWENT);
3345
3346 case KEY_getpwnam:
ff68c719 3347 UNI(OP_GPWNAM);
79072805
LW		 3348
3349 case KEY_getpwuid:
ff68c719 3350 UNI(OP_GPWUID);
79072805
LW		 3351
3352 case KEY_getpeername:
3353 UNI(OP_GETPEERNAME);
3354
3355 case KEY_gethostbyname:
3356 UNI(OP_GHBYNAME);
3357
3358 case KEY_gethostbyaddr:
a0d0e21e 3359 LOP(OP_GHBYADDR,XTERM);
79072805
LW		 3360
3361 case KEY_gethostent:
3362 FUN0(OP_GHOSTENT);
3363
3364 case KEY_getnetbyname:
3365 UNI(OP_GNBYNAME);
3366
3367 case KEY_getnetbyaddr:
a0d0e21e 3368 LOP(OP_GNBYADDR,XTERM);
79072805
LW		 3369
3370 case KEY_getnetent:
3371 FUN0(OP_GNETENT);
3372
3373 case KEY_getservbyname:
a0d0e21e 3374 LOP(OP_GSBYNAME,XTERM);
79072805
LW		 3375
3376 case KEY_getservbyport:
a0d0e21e 3377 LOP(OP_GSBYPORT,XTERM);
79072805
LW		 3378
3379 case KEY_getservent:
3380 FUN0(OP_GSERVENT);
3381
3382 case KEY_getsockname:
3383 UNI(OP_GETSOCKNAME);
3384
3385 case KEY_getsockopt:
a0d0e21e 3386 LOP(OP_GSOCKOPT,XTERM);
79072805
LW		 3387
3388 case KEY_getgrent:
3389 FUN0(OP_GGRENT);
3390
3391 case KEY_getgrnam:
ff68c719 3392 UNI(OP_GGRNAM);
79072805
LW		 3393
3394 case KEY_getgrgid:
ff68c719 3395 UNI(OP_GGRGID);
79072805
LW		 3396
3397 case KEY_getlogin:
3398 FUN0(OP_GETLOGIN);
3399
93a17b20 3400 case KEY_glob:
a0d0e21e
LW		 3401 set_csh();
3402 LOP(OP_GLOB,XTERM);
93a17b20 3403
79072805
LW		 3404 case KEY_hex:
3405 UNI(OP_HEX);
3406
3407 case KEY_if:
3408 yylval.ival = curcop->cop_line;
3409 OPERATOR(IF);
3410
3411 case KEY_index:
a0d0e21e 3412 LOP(OP_INDEX,XTERM);
79072805
LW		 3413
3414 case KEY_int:
3415 UNI(OP_INT);
3416
3417 case KEY_ioctl:
a0d0e21e 3418 LOP(OP_IOCTL,XTERM);
79072805
LW		 3419
3420 case KEY_join:
a0d0e21e 3421 LOP(OP_JOIN,XTERM);
79072805
LW		 3422
3423 case KEY_keys:
3424 UNI(OP_KEYS);
3425
3426 case KEY_kill:
a0d0e21e 3427 LOP(OP_KILL,XTERM);
79072805
LW		 3428
3429 case KEY_last:
a0d0e21e 3430 s = force_word(s,WORD,TRUE,FALSE,FALSE);
79072805 3431 LOOPX(OP_LAST);
a0d0e21e 3432
79072805
LW		 3433 case KEY_lc:
3434 UNI(OP_LC);
3435
3436 case KEY_lcfirst:
3437 UNI(OP_LCFIRST);
3438
3439 case KEY_local:
3440 OPERATOR(LOCAL);
3441
3442 case KEY_length:
3443 UNI(OP_LENGTH);
3444
3445 case KEY_lt:
3446 Rop(OP_SLT);
3447
3448 case KEY_le:
3449 Rop(OP_SLE);
3450
3451 case KEY_localtime:
3452 UNI(OP_LOCALTIME);
3453
3454 case KEY_log:
3455 UNI(OP_LOG);
3456
3457 case KEY_link:
a0d0e21e 3458 LOP(OP_LINK,XTERM);
79072805
LW		 3459
3460 case KEY_listen:
a0d0e21e 3461 LOP(OP_LISTEN,XTERM);
79072805 3462
c0329465
MB		 3463 case KEY_lock:
3464 UNI(OP_LOCK);
3465
79072805
LW		 3466 case KEY_lstat:
3467 UNI(OP_LSTAT);
3468
3469 case KEY_m:
3470 s = scan_pat(s);
3471 TERM(sublex_start());
3472
a0d0e21e
LW		 3473 case KEY_map:
3474 LOP(OP_MAPSTART,XREF);
3475
79072805 3476 case KEY_mkdir:
a0d0e21e 3477 LOP(OP_MKDIR,XTERM);
79072805
LW		 3478
3479 case KEY_msgctl:
a0d0e21e 3480 LOP(OP_MSGCTL,XTERM);
79072805
LW		 3481
3482 case KEY_msgget:
a0d0e21e 3483 LOP(OP_MSGGET,XTERM);
79072805
LW		 3484
3485 case KEY_msgrcv:
a0d0e21e 3486 LOP(OP_MSGRCV,XTERM);
79072805
LW		 3487
3488 case KEY_msgsnd:
a0d0e21e 3489 LOP(OP_MSGSND,XTERM);
79072805 3490
93a17b20
LW		 3491 case KEY_my:
3492 in_my = TRUE;
c750a3ec
MB		 3493 s = skipspace(s);
3494 if (isIDFIRST(*s)) {
97fcbf96 3495 s = scan_word(s, tokenbuf, sizeof tokenbuf, TRUE, &len);
c750a3ec
MB		 3496 in_my_stash = gv_stashpv(tokenbuf, FALSE);
3497 if (!in_my_stash) {
3498 char tmpbuf[1024];
3499 bufptr = s;
3500 sprintf(tmpbuf, "No such class %.1000s", tokenbuf);
3501 yyerror(tmpbuf);
3502 }
3503 }
55497cff 3504 OPERATOR(MY);
93a17b20 3505
79072805 3506 case KEY_next:
a0d0e21e 3507 s = force_word(s,WORD,TRUE,FALSE,FALSE);
79072805
LW		 3508 LOOPX(OP_NEXT);
3509
3510 case KEY_ne:
3511 Eop(OP_SNE);
3512
a0d0e21e
LW		 3513 case KEY_no:
3514 if (expect != XSTATE)
3515 yyerror("\"no\" not allowed in expression");
3516 s = force_word(s,WORD,FALSE,TRUE,FALSE);
89bfa8cd 3517 s = force_version(s);
a0d0e21e
LW		 3518 yylval.ival = 0;
3519 OPERATOR(USE);
3520
3521 case KEY_not:
3522 OPERATOR(NOTOP);
3523
79072805 3524 case KEY_open:
93a17b20
LW		 3525 s = skipspace(s);
3526 if (isIDFIRST(*s)) {
3527 char *t;
3528 for (d = s; isALNUM(*d); d++) ;
3529 t = skipspace(d);
3530 if (strchr("|&*+-=!?:.", *t))
3531 warn("Precedence problem: open %.*s should be open(%.*s)",
3532 d-s,s, d-s,s);
3533 }
a0d0e21e 3534 LOP(OP_OPEN,XTERM);
79072805 3535
463ee0b2 3536 case KEY_or:
a0d0e21e 3537 yylval.ival = OP_OR;
463ee0b2
LW		 3538 OPERATOR(OROP);
3539
79072805
LW		 3540 case KEY_ord:
3541 UNI(OP_ORD);
3542
3543 case KEY_oct:
3544 UNI(OP_OCT);
3545
3546 case KEY_opendir:
a0d0e21e 3547 LOP(OP_OPEN_DIR,XTERM);
79072805
LW		 3548
3549 case KEY_print:
3550 checkcomma(s,tokenbuf,"filehandle");
a0d0e21e 3551 LOP(OP_PRINT,XREF);
79072805
LW		 3552
3553 case KEY_printf:
3554 checkcomma(s,tokenbuf,"filehandle");
a0d0e21e 3555 LOP(OP_PRTF,XREF);
79072805 3556
c07a80fd 3557 case KEY_prototype:
3558 UNI(OP_PROTOTYPE);
3559
79072805 3560 case KEY_push:
a0d0e21e 3561 LOP(OP_PUSH,XTERM);
79072805
LW		 3562
3563 case KEY_pop:
3564 UNI(OP_POP);
3565
a0d0e21e
LW		 3566 case KEY_pos:
3567 UNI(OP_POS);
3568
79072805 3569 case KEY_pack:
a0d0e21e 3570 LOP(OP_PACK,XTERM);
79072805
LW		 3571
3572 case KEY_package:
a0d0e21e 3573 s = force_word(s,WORD,FALSE,TRUE,FALSE);
79072805
LW		 3574 OPERATOR(PACKAGE);
3575
3576 case KEY_pipe:
a0d0e21e 3577 LOP(OP_PIPE_OP,XTERM);
79072805
LW		 3578
3579 case KEY_q:
3580 s = scan_str(s);
3581 if (!s)
85e6fe83 3582 missingterm((char*)0);
79072805
LW		 3583 yylval.ival = OP_CONST;
3584 TERM(sublex_start());
3585
a0d0e21e
LW		 3586 case KEY_quotemeta:
3587 UNI(OP_QUOTEMETA);
3588
8990e307
LW		 3589 case KEY_qw:
3590 s = scan_str(s);
3591 if (!s)
85e6fe83 3592 missingterm((char*)0);
55497cff 3593 if (dowarn && SvLEN(lex_stuff)) {
3594 d = SvPV_force(lex_stuff, len);
3595 for (; len; --len, ++d) {
3596 if (*d == ',') {
3597 warn("Possible attempt to separate words with commas");
3598 break;
3599 }
3600 if (*d == '#') {
3601 warn("Possible attempt to put comments in qw() list");
3602 break;
3603 }
3604 }
3605 }
8990e307
LW		 3606 force_next(')');
3607 nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, q(lex_stuff));
3608 lex_stuff = Nullsv;
3609 force_next(THING);
3610 force_next(',');
3611 nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(" ",1));
3612 force_next(THING);
3613 force_next('(');
a0d0e21e
LW		 3614 yylval.ival = OP_SPLIT;
3615 CLINE;
3616 expect = XTERM;
3617 bufptr = s;
3618 last_lop = oldbufptr;
3619 last_lop_op = OP_SPLIT;
3620 return FUNC;
8990e307 3621
79072805
LW		 3622 case KEY_qq:
3623 s = scan_str(s);
3624 if (!s)
85e6fe83 3625 missingterm((char*)0);
a0d0e21e 3626 yylval.ival = OP_STRINGIFY;
ed6116ce
LW		 3627 if (SvIVX(lex_stuff) == '\'')
3628 SvIVX(lex_stuff) = 0; /* qq'$foo' should intepolate */
79072805
LW		 3629 TERM(sublex_start());
3630
3631 case KEY_qx:
3632 s = scan_str(s);
3633 if (!s)
85e6fe83 3634 missingterm((char*)0);
79072805
LW		 3635 yylval.ival = OP_BACKTICK;
3636 set_csh();
3637 TERM(sublex_start());
3638
3639 case KEY_return:
3640 OLDLOP(OP_RETURN);
3641
3642 case KEY_require:
748a9306 3643 *tokenbuf = '\0';
a0d0e21e 3644 s = force_word(s,WORD,TRUE,TRUE,FALSE);
748a9306 3645 if (isIDFIRST(*tokenbuf))
89bfa8cd 3646 gv_stashpvn(tokenbuf, strlen(tokenbuf), TRUE);
748a9306 3647 else if (*s == '<')
a0d0e21e 3648 yyerror("<> should be quotes");
463ee0b2 3649 UNI(OP_REQUIRE);
79072805
LW		 3650
3651 case KEY_reset:
3652 UNI(OP_RESET);
3653
3654 case KEY_redo:
a0d0e21e 3655 s = force_word(s,WORD,TRUE,FALSE,FALSE);
79072805
LW		 3656 LOOPX(OP_REDO);
3657
3658 case KEY_rename:
a0d0e21e 3659 LOP(OP_RENAME,XTERM);
79072805
LW		 3660
3661 case KEY_rand:
3662 UNI(OP_RAND);
3663
3664 case KEY_rmdir:
3665 UNI(OP_RMDIR);
3666
3667 case KEY_rindex:
a0d0e21e 3668 LOP(OP_RINDEX,XTERM);
79072805
LW		 3669
3670 case KEY_read:
a0d0e21e 3671 LOP(OP_READ,XTERM);
79072805
LW		 3672
3673 case KEY_readdir:
3674 UNI(OP_READDIR);
3675
93a17b20
LW		 3676 case KEY_readline:
3677 set_csh();
3678 UNI(OP_READLINE);
3679
3680 case KEY_readpipe:
3681 set_csh();
3682 UNI(OP_BACKTICK);
3683
79072805
LW		 3684 case KEY_rewinddir:
3685 UNI(OP_REWINDDIR);
3686
3687 case KEY_recv:
a0d0e21e 3688 LOP(OP_RECV,XTERM);
79072805
LW		 3689
3690 case KEY_reverse:
a0d0e21e 3691 LOP(OP_REVERSE,XTERM);
79072805
LW		 3692
3693 case KEY_readlink:
3694 UNI(OP_READLINK);
3695
3696 case KEY_ref:
3697 UNI(OP_REF);
3698
3699 case KEY_s:
3700 s = scan_subst(s);
3701 if (yylval.opval)
3702 TERM(sublex_start());
3703 else
3704 TOKEN(1); /* force error */
3705
a0d0e21e
LW		 3706 case KEY_chomp:
3707 UNI(OP_CHOMP);
3708
79072805
LW		 3709 case KEY_scalar:
3710 UNI(OP_SCALAR);
3711
3712 case KEY_select:
a0d0e21e 3713 LOP(OP_SELECT,XTERM);
79072805
LW		 3714
3715 case KEY_seek:
a0d0e21e 3716 LOP(OP_SEEK,XTERM);
79072805
LW		 3717
3718 case KEY_semctl:
a0d0e21e 3719 LOP(OP_SEMCTL,XTERM);
79072805
LW		 3720
3721 case KEY_semget:
a0d0e21e 3722 LOP(OP_SEMGET,XTERM);
79072805
LW		 3723
3724 case KEY_semop:
a0d0e21e 3725 LOP(OP_SEMOP,XTERM);
79072805
LW		 3726
3727 case KEY_send:
a0d0e21e 3728 LOP(OP_SEND,XTERM);
79072805
LW		 3729
3730 case KEY_setpgrp:
a0d0e21e 3731 LOP(OP_SETPGRP,XTERM);
79072805
LW		 3732
3733 case KEY_setpriority:
a0d0e21e 3734 LOP(OP_SETPRIORITY,XTERM);
79072805
LW		 3735
3736 case KEY_sethostent:
ff68c719 3737 UNI(OP_SHOSTENT);
79072805
LW		 3738
3739 case KEY_setnetent:
ff68c719 3740 UNI(OP_SNETENT);
79072805
LW		 3741
3742 case KEY_setservent:
ff68c719 3743 UNI(OP_SSERVENT);
79072805
LW		 3744
3745 case KEY_setprotoent:
ff68c719 3746 UNI(OP_SPROTOENT);
79072805
LW		 3747
3748 case KEY_setpwent:
3749 FUN0(OP_SPWENT);
3750
3751 case KEY_setgrent:
3752 FUN0(OP_SGRENT);
3753
3754 case KEY_seekdir:
a0d0e21e 3755 LOP(OP_SEEKDIR,XTERM);
79072805
LW		 3756
3757 case KEY_setsockopt:
a0d0e21e 3758 LOP(OP_SSOCKOPT,XTERM);
79072805
LW		 3759
3760 case KEY_shift:
3761 UNI(OP_SHIFT);
3762
3763 case KEY_shmctl:
a0d0e21e 3764 LOP(OP_SHMCTL,XTERM);
79072805
LW		 3765
3766 case KEY_shmget:
a0d0e21e 3767 LOP(OP_SHMGET,XTERM);
79072805
LW		 3768
3769 case KEY_shmread:
a0d0e21e 3770 LOP(OP_SHMREAD,XTERM);
79072805
LW		 3771
3772 case KEY_shmwrite:
a0d0e21e 3773 LOP(OP_SHMWRITE,XTERM);
79072805
LW		 3774
3775 case KEY_shutdown:
a0d0e21e 3776 LOP(OP_SHUTDOWN,XTERM);
79072805
LW		 3777
3778 case KEY_sin:
3779 UNI(OP_SIN);
3780
3781 case KEY_sleep:
3782 UNI(OP_SLEEP);
3783
3784 case KEY_socket:
a0d0e21e 3785 LOP(OP_SOCKET,XTERM);
79072805
LW		 3786
3787 case KEY_socketpair:
a0d0e21e 3788 LOP(OP_SOCKPAIR,XTERM);
79072805
LW		 3789
3790 case KEY_sort:
3791 checkcomma(s,tokenbuf,"subroutine name");
3792 s = skipspace(s);
3793 if (*s == ';' || *s == ')') /* probably a close */
463ee0b2
LW		 3794 croak("sort is now a reserved word");
3795 expect = XTERM;
15f0808c 3796 s = force_word(s,WORD,TRUE,TRUE,FALSE);
a0d0e21e 3797 LOP(OP_SORT,XREF);
79072805
LW		 3798
3799 case KEY_split:
a0d0e21e 3800 LOP(OP_SPLIT,XTERM);
79072805
LW		 3801
3802 case KEY_sprintf:
a0d0e21e 3803 LOP(OP_SPRINTF,XTERM);
79072805
LW		 3804
3805 case KEY_splice:
a0d0e21e 3806 LOP(OP_SPLICE,XTERM);
79072805
LW		 3807
3808 case KEY_sqrt:
3809 UNI(OP_SQRT);
3810
3811 case KEY_srand:
3812 UNI(OP_SRAND);
3813
3814 case KEY_stat:
3815 UNI(OP_STAT);
3816
3817 case KEY_study:
3818 sawstudy++;
3819 UNI(OP_STUDY);
3820
3821 case KEY_substr:
a0d0e21e 3822 LOP(OP_SUBSTR,XTERM);
79072805
LW		 3823
3824 case KEY_format:
3825 case KEY_sub:
93a17b20 3826 really_sub:
79072805 3827 s = skipspace(s);
4633a7c4 3828
463ee0b2 3829 if (isIDFIRST(*s) || *s == '\'' || *s == ':') {
8903cb82 3830 char tmpbuf[sizeof tokenbuf];
4633a7c4 3831 expect = XBLOCK;
8903cb82 3832 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
463ee0b2
LW		 3833 if (strchr(tmpbuf, ':'))
3834 sv_setpv(subname, tmpbuf);
3835 else {
3836 sv_setsv(subname,curstname);
8990e307 3837 sv_catpvn(subname,"::",2);
463ee0b2
LW		 3838 sv_catpvn(subname,tmpbuf,len);
3839 }
a0d0e21e 3840 s = force_word(s,WORD,FALSE,TRUE,TRUE);
4633a7c4 3841 s = skipspace(s);
79072805 3842 }
4633a7c4
LW		 3843 else {
3844 expect = XTERMBLOCK;
79072805 3845 sv_setpv(subname,"?");
4633a7c4
LW		 3846 }
3847
3848 if (tmp == KEY_format) {
3849 s = skipspace(s);
3850 if (*s == '=')
3851 lex_formbrack = lex_brackets + 1;
3852 OPERATOR(FORMAT);
3853 }
79072805 3854
4633a7c4
LW		 3855 /* Look for a prototype */
3856 if (*s == '(') {
68dc0745 3857 char *p;
3858
4633a7c4
LW		 3859 s = scan_str(s);
3860 if (!s) {
3861 if (lex_stuff)
3862 SvREFCNT_dec(lex_stuff);
3863 lex_stuff = Nullsv;
3864 croak("Prototype not terminated");
3865 }
68dc0745 3866 /* strip spaces */
3867 d = SvPVX(lex_stuff);
3868 tmp = 0;
3869 for (p = d; *p; ++p) {
3870 if (!isSPACE(*p))
3871 d[tmp++] = *p;
3872 }
3873 d[tmp] = '\0';
3874 SvCUR(lex_stuff) = tmp;
3875
4633a7c4
LW		 3876 nexttoke++;
3877 nextval[1] = nextval[0];
3878 nexttype[1] = nexttype[0];
3879 nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, lex_stuff);
3880 nexttype[0] = THING;
3881 if (nexttoke == 1) {
3882 lex_defer = lex_state;
3883 lex_expect = expect;
3884 lex_state = LEX_KNOWNEXT;
3885 }
3886 lex_stuff = Nullsv;
3887 }
79072805 3888
4633a7c4
LW		 3889 if (*SvPV(subname,na) == '?') {
3890 sv_setpv(subname,"__ANON__");
3891 TOKEN(ANONSUB);
3892 }
3893 PREBLOCK(SUB);
79072805
LW		 3894
3895 case KEY_system:
3896 set_csh();
a0d0e21e 3897 LOP(OP_SYSTEM,XREF);
79072805
LW		 3898
3899 case KEY_symlink:
a0d0e21e 3900 LOP(OP_SYMLINK,XTERM);
79072805
LW		 3901
3902 case KEY_syscall:
a0d0e21e 3903 LOP(OP_SYSCALL,XTERM);
79072805 3904
c07a80fd 3905 case KEY_sysopen:
3906 LOP(OP_SYSOPEN,XTERM);
3907
137443ea 3908 case KEY_sysseek:
3909 LOP(OP_SYSSEEK,XTERM);
3910
79072805 3911 case KEY_sysread:
a0d0e21e 3912 LOP(OP_SYSREAD,XTERM);
79072805
LW		 3913
3914 case KEY_syswrite:
a0d0e21e 3915 LOP(OP_SYSWRITE,XTERM);
79072805
LW		 3916
3917 case KEY_tr:
3918 s = scan_trans(s);
3919 TERM(sublex_start());
3920
3921 case KEY_tell:
3922 UNI(OP_TELL);
3923
3924 case KEY_telldir:
3925 UNI(OP_TELLDIR);
3926
463ee0b2 3927 case KEY_tie:
a0d0e21e 3928 LOP(OP_TIE,XTERM);
463ee0b2 3929
c07a80fd 3930 case KEY_tied:
3931 UNI(OP_TIED);
3932
79072805
LW		 3933 case KEY_time:
3934 FUN0(OP_TIME);
3935
3936 case KEY_times:
3937 FUN0(OP_TMS);
3938
3939 case KEY_truncate:
a0d0e21e 3940 LOP(OP_TRUNCATE,XTERM);
79072805
LW		 3941
3942 case KEY_uc:
3943 UNI(OP_UC);
3944
3945 case KEY_ucfirst:
3946 UNI(OP_UCFIRST);
3947
463ee0b2
LW		 3948 case KEY_untie:
3949 UNI(OP_UNTIE);
3950
79072805
LW		 3951 case KEY_until:
3952 yylval.ival = curcop->cop_line;
3953 OPERATOR(UNTIL);
3954
3955 case KEY_unless:
3956 yylval.ival = curcop->cop_line;
3957 OPERATOR(UNLESS);
3958
3959 case KEY_unlink:
a0d0e21e 3960 LOP(OP_UNLINK,XTERM);
79072805
LW		 3961
3962 case KEY_undef:
3963 UNI(OP_UNDEF);
3964
3965 case KEY_unpack:
a0d0e21e 3966 LOP(OP_UNPACK,XTERM);
79072805
LW		 3967
3968 case KEY_utime:
a0d0e21e 3969 LOP(OP_UTIME,XTERM);
79072805
LW		 3970
3971 case KEY_umask:
748a9306
LW		 3972 if (dowarn) {
3973 for (d = s; d < bufend && (isSPACE(*d) || *d == '('); d++) ;
3974 if (*d != '0' && isDIGIT(*d))
3975 yywarn("umask: argument is missing initial 0");
3976 }
79072805
LW		 3977 UNI(OP_UMASK);
3978
3979 case KEY_unshift:
a0d0e21e
LW		 3980 LOP(OP_UNSHIFT,XTERM);
3981
3982 case KEY_use:
3983 if (expect != XSTATE)
3984 yyerror("\"use\" not allowed in expression");
89bfa8cd 3985 s = skipspace(s);
3986 if(isDIGIT(*s)) {
3987 s = force_version(s);
3988 if(*s == ';' || (s = skipspace(s), *s == ';')) {
3989 nextval[nexttoke].opval = Nullop;
3990 force_next(WORD);
3991 }
3992 }
3993 else {
3994 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3995 s = force_version(s);
3996 }
a0d0e21e
LW		 3997 yylval.ival = 1;
3998 OPERATOR(USE);
79072805
LW		 3999
4000 case KEY_values:
4001 UNI(OP_VALUES);
4002
4003 case KEY_vec:
4004 sawvec = TRUE;
a0d0e21e 4005 LOP(OP_VEC,XTERM);
79072805
LW		 4006
4007 case KEY_while:
4008 yylval.ival = curcop->cop_line;
4009 OPERATOR(WHILE);
4010
4011 case KEY_warn:
a0d0e21e
LW		 4012 hints |= HINT_BLOCK_SCOPE;
4013 LOP(OP_WARN,XTERM);
79072805
LW		 4014
4015 case KEY_wait:
4016 FUN0(OP_WAIT);
4017
4018 case KEY_waitpid:
a0d0e21e 4019 LOP(OP_WAITPID,XTERM);
79072805
LW		 4020
4021 case KEY_wantarray:
4022 FUN0(OP_WANTARRAY);
4023
4024 case KEY_write:
85e6fe83 4025 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
79072805
LW		 4026 UNI(OP_ENTERWRITE);
4027
4028 case KEY_x:
4029 if (expect == XOPERATOR)
4030 Mop(OP_REPEAT);
4031 check_uni();
4032 goto just_a_word;
4033
a0d0e21e
LW		 4034 case KEY_xor:
4035 yylval.ival = OP_XOR;
4036 OPERATOR(OROP);
4037
79072805
LW		 4038 case KEY_y:
4039 s = scan_trans(s);
4040 TERM(sublex_start());
4041 }
49dc05e3 4042 }}
79072805
LW		 4043}
4044
4045I32
8ac85365 4046keyword(register char *d, I32 len)
79072805
LW		 4047{
4048 switch (*d) {
4049 case '_':
4050 if (d[1] == '_') {
a0d0e21e 4051 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
68dc0745 4052 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
4053 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
e50aee73 4054 if (strEQ(d,"__DATA__")) return KEY___DATA__;
79072805
LW		 4055 if (strEQ(d,"__END__")) return KEY___END__;
4056 }
4057 break;
8990e307
LW		 4058 case 'A':
4059 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
4060 break;
79072805 4061 case 'a':
463ee0b2
LW		 4062 switch (len) {
4063 case 3:
a0d0e21e
LW		 4064 if (strEQ(d,"and")) return -KEY_and;
4065 if (strEQ(d,"abs")) return -KEY_abs;
85e6fe83 4066 break;
463ee0b2 4067 case 5:
a0d0e21e
LW		 4068 if (strEQ(d,"alarm")) return -KEY_alarm;
4069 if (strEQ(d,"atan2")) return -KEY_atan2;
463ee0b2
LW		 4070 break;
4071 case 6:
a0d0e21e 4072 if (strEQ(d,"accept")) return -KEY_accept;
463ee0b2
LW		 4073 break;
4074 }
79072805
LW		 4075 break;
4076 case 'B':
4077 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
93a17b20 4078 break;
79072805 4079 case 'b':
a0d0e21e
LW		 4080 if (strEQ(d,"bless")) return -KEY_bless;
4081 if (strEQ(d,"bind")) return -KEY_bind;
4082 if (strEQ(d,"binmode")) return -KEY_binmode;
4083 break;
4084 case 'C':
4085 if (strEQ(d,"CORE")) return -KEY_CORE;
79072805
LW		 4086 break;
4087 case 'c':
4088 switch (len) {
4089 case 3:
a0d0e21e
LW		 4090 if (strEQ(d,"cmp")) return -KEY_cmp;
4091 if (strEQ(d,"chr")) return -KEY_chr;
4092 if (strEQ(d,"cos")) return -KEY_cos;
79072805
LW		 4093 break;
4094 case 4:
4095 if (strEQ(d,"chop")) return KEY_chop;
4096 break;
4097 case 5:
a0d0e21e
LW		 4098 if (strEQ(d,"close")) return -KEY_close;
4099 if (strEQ(d,"chdir")) return -KEY_chdir;
4100 if (strEQ(d,"chomp")) return KEY_chomp;
4101 if (strEQ(d,"chmod")) return -KEY_chmod;
4102 if (strEQ(d,"chown")) return -KEY_chown;
4103 if (strEQ(d,"crypt")) return -KEY_crypt;
79072805
LW		 4104 break;
4105 case 6:
a0d0e21e
LW		 4106 if (strEQ(d,"chroot")) return -KEY_chroot;
4107 if (strEQ(d,"caller")) return -KEY_caller;
79072805
LW		 4108 break;
4109 case 7:
a0d0e21e 4110 if (strEQ(d,"connect")) return -KEY_connect;
79072805
LW		 4111 break;
4112 case 8:
a0d0e21e
LW		 4113 if (strEQ(d,"closedir")) return -KEY_closedir;
4114 if (strEQ(d,"continue")) return -KEY_continue;
79072805
LW		 4115 break;
4116 }
4117 break;
ed6116ce
LW		 4118 case 'D':
4119 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
4120 break;
79072805
LW		 4121 case 'd':
4122 switch (len) {
4123 case 2:
4124 if (strEQ(d,"do")) return KEY_do;
4125 break;
4126 case 3:
a0d0e21e 4127 if (strEQ(d,"die")) return -KEY_die;
79072805
LW		 4128 break;
4129 case 4:
a0d0e21e 4130 if (strEQ(d,"dump")) return -KEY_dump;
79072805
LW		 4131 break;
4132 case 6:
4133 if (strEQ(d,"delete")) return KEY_delete;
4134 break;
4135 case 7:
4136 if (strEQ(d,"defined")) return KEY_defined;
a0d0e21e 4137 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
79072805
LW		 4138 break;
4139 case 8:
a0d0e21e 4140 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
79072805
LW		 4141 break;
4142 }
4143 break;
4144 case 'E':
a0d0e21e 4145 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
79072805
LW		 4146 if (strEQ(d,"END")) return KEY_END;
4147 break;
4148 case 'e':
4149 switch (len) {
4150 case 2:
a0d0e21e 4151 if (strEQ(d,"eq")) return -KEY_eq;
79072805
LW		 4152 break;
4153 case 3:
a0d0e21e
LW		 4154 if (strEQ(d,"eof")) return -KEY_eof;
4155 if (strEQ(d,"exp")) return -KEY_exp;
79072805
LW		 4156 break;
4157 case 4:
4158 if (strEQ(d,"else")) return KEY_else;
a0d0e21e 4159 if (strEQ(d,"exit")) return -KEY_exit;
79072805 4160 if (strEQ(d,"eval")) return KEY_eval;
a0d0e21e 4161 if (strEQ(d,"exec")) return -KEY_exec;
79072805
LW		 4162 if (strEQ(d,"each")) return KEY_each;
4163 break;
4164 case 5:
4165 if (strEQ(d,"elsif")) return KEY_elsif;
4166 break;
a0d0e21e
LW		 4167 case 6:
4168 if (strEQ(d,"exists")) return KEY_exists;
4633a7c4 4169 if (strEQ(d,"elseif")) warn("elseif should be elsif");
a0d0e21e 4170 break;
79072805 4171 case 8:
a0d0e21e
LW		 4172 if (strEQ(d,"endgrent")) return -KEY_endgrent;
4173 if (strEQ(d,"endpwent")) return -KEY_endpwent;
79072805
LW		 4174 break;
4175 case 9:
a0d0e21e 4176 if (strEQ(d,"endnetent")) return -KEY_endnetent;
79072805
LW		 4177 break;
4178 case 10:
a0d0e21e
LW		 4179 if (strEQ(d,"endhostent")) return -KEY_endhostent;
4180 if (strEQ(d,"endservent")) return -KEY_endservent;
79072805
LW		 4181 break;
4182 case 11:
a0d0e21e 4183 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
79072805 4184 break;
a687059c 4185 }
a687059c 4186 break;
79072805
LW		 4187 case 'f':
4188 switch (len) {
4189 case 3:
4190 if (strEQ(d,"for")) return KEY_for;
4191 break;
4192 case 4:
a0d0e21e 4193 if (strEQ(d,"fork")) return -KEY_fork;
79072805
LW		 4194 break;
4195 case 5:
a0d0e21e
LW		 4196 if (strEQ(d,"fcntl")) return -KEY_fcntl;
4197 if (strEQ(d,"flock")) return -KEY_flock;
79072805
LW		 4198 break;
4199 case 6:
4200 if (strEQ(d,"format")) return KEY_format;
a0d0e21e 4201 if (strEQ(d,"fileno")) return -KEY_fileno;
79072805
LW		 4202 break;
4203 case 7:
4204 if (strEQ(d,"foreach")) return KEY_foreach;
4205 break;
4206 case 8:
a0d0e21e 4207 if (strEQ(d,"formline")) return -KEY_formline;
79072805 4208 break;
378cc40b 4209 }
a687059c 4210 break;
79072805
LW		 4211 case 'G':
4212 if (len == 2) {
a0d0e21e
LW		 4213 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
4214 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
9f68db38 4215 }
a687059c 4216 break;
79072805 4217 case 'g':
a687059c
LW		 4218 if (strnEQ(d,"get",3)) {
4219 d += 3;
4220 if (*d == 'p') {
79072805
LW		 4221 switch (len) {
4222 case 7:
a0d0e21e
LW		 4223 if (strEQ(d,"ppid")) return -KEY_getppid;
4224 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
79072805
LW		 4225 break;
4226 case 8:
a0d0e21e
LW		 4227 if (strEQ(d,"pwent")) return -KEY_getpwent;
4228 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
4229 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
79072805
LW		 4230 break;
4231 case 11:
a0d0e21e
LW		 4232 if (strEQ(d,"peername")) return -KEY_getpeername;
4233 if (strEQ(d,"protoent")) return -KEY_getprotoent;
4234 if (strEQ(d,"priority")) return -KEY_getpriority;
79072805
LW		 4235 break;
4236 case 14:
a0d0e21e 4237 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
79072805
LW		 4238 break;
4239 case 16:
a0d0e21e 4240 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
79072805
LW		 4241 break;
4242 }
a687059c
LW		 4243 }
4244 else if (*d == 'h') {
a0d0e21e
LW		 4245 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
4246 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
4247 if (strEQ(d,"hostent")) return -KEY_gethostent;
a687059c
LW		 4248 }
4249 else if (*d == 'n') {
a0d0e21e
LW		 4250 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
4251 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
4252 if (strEQ(d,"netent")) return -KEY_getnetent;
a687059c
LW		 4253 }
4254 else if (*d == 's') {
a0d0e21e
LW		 4255 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
4256 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
4257 if (strEQ(d,"servent")) return -KEY_getservent;
4258 if (strEQ(d,"sockname")) return -KEY_getsockname;
4259 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
a687059c
LW		 4260 }
4261 else if (*d == 'g') {
a0d0e21e
LW		 4262 if (strEQ(d,"grent")) return -KEY_getgrent;
4263 if (strEQ(d,"grnam")) return -KEY_getgrnam;
4264 if (strEQ(d,"grgid")) return -KEY_getgrgid;
a687059c
LW		 4265 }
4266 else if (*d == 'l') {
a0d0e21e 4267 if (strEQ(d,"login")) return -KEY_getlogin;
a687059c 4268 }
a0d0e21e 4269 else if (strEQ(d,"c")) return -KEY_getc;
79072805 4270 break;
a687059c 4271 }
79072805
LW		 4272 switch (len) {
4273 case 2:
a0d0e21e
LW		 4274 if (strEQ(d,"gt")) return -KEY_gt;
4275 if (strEQ(d,"ge")) return -KEY_ge;
79072805
LW		 4276 break;
4277 case 4:
4278 if (strEQ(d,"grep")) return KEY_grep;
4279 if (strEQ(d,"goto")) return KEY_goto;
fb73857a 4280 if (strEQ(d,"glob")) return KEY_glob;
79072805
LW		 4281 break;
4282 case 6:
a0d0e21e 4283 if (strEQ(d,"gmtime")) return -KEY_gmtime;
79072805 4284 break;
378cc40b 4285 }
a687059c 4286 break;
79072805 4287 case 'h':
a0d0e21e 4288 if (strEQ(d,"hex")) return -KEY_hex;
a687059c 4289 break;
7d07dbc2
MB		 4290 case 'I':
4291 if (strEQ(d,"INIT")) return KEY_INIT;
4292 break;
79072805
LW		 4293 case 'i':
4294 switch (len) {
4295 case 2:
4296 if (strEQ(d,"if")) return KEY_if;
4297 break;
4298 case 3:
a0d0e21e 4299 if (strEQ(d,"int")) return -KEY_int;
79072805
LW		 4300 break;
4301 case 5:
a0d0e21e
LW		 4302 if (strEQ(d,"index")) return -KEY_index;
4303 if (strEQ(d,"ioctl")) return -KEY_ioctl;
79072805
LW		 4304 break;
4305 }
a687059c 4306 break;
79072805 4307 case 'j':
a0d0e21e 4308 if (strEQ(d,"join")) return -KEY_join;
a687059c 4309 break;
79072805
LW		 4310 case 'k':
4311 if (len == 4) {
4312 if (strEQ(d,"keys")) return KEY_keys;
a0d0e21e 4313 if (strEQ(d,"kill")) return -KEY_kill;
663a0e37 4314 }
79072805
LW		 4315 break;
4316 case 'L':
4317 if (len == 2) {
a0d0e21e
LW		 4318 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
4319 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
378cc40b 4320 }
79072805
LW		 4321 break;
4322 case 'l':
4323 switch (len) {
4324 case 2:
a0d0e21e
LW		 4325 if (strEQ(d,"lt")) return -KEY_lt;
4326 if (strEQ(d,"le")) return -KEY_le;
4327 if (strEQ(d,"lc")) return -KEY_lc;
79072805
LW		 4328 break;
4329 case 3:
a0d0e21e 4330 if (strEQ(d,"log")) return -KEY_log;
79072805
LW		 4331 break;
4332 case 4:
4333 if (strEQ(d,"last")) return KEY_last;
a0d0e21e 4334 if (strEQ(d,"link")) return -KEY_link;
c0329465 4335 if (strEQ(d,"lock")) return -KEY_lock;
395c3793 4336 break;
79072805
LW		 4337 case 5:
4338 if (strEQ(d,"local")) return KEY_local;
a0d0e21e 4339 if (strEQ(d,"lstat")) return -KEY_lstat;
79072805
LW		 4340 break;
4341 case 6:
a0d0e21e
LW		 4342 if (strEQ(d,"length")) return -KEY_length;
4343 if (strEQ(d,"listen")) return -KEY_listen;
79072805
LW		 4344 break;
4345 case 7:
a0d0e21e 4346 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
79072805
LW		 4347 break;
4348 case 9:
a0d0e21e 4349 if (strEQ(d,"localtime")) return -KEY_localtime;
395c3793
LW		 4350 break;
4351 }
a687059c 4352 break;
79072805
LW		 4353 case 'm':
4354 switch (len) {
4355 case 1: return KEY_m;
93a17b20
LW		 4356 case 2:
4357 if (strEQ(d,"my")) return KEY_my;
4358 break;
a0d0e21e
LW		 4359 case 3:
4360 if (strEQ(d,"map")) return KEY_map;
4361 break;
79072805 4362 case 5:
a0d0e21e 4363 if (strEQ(d,"mkdir")) return -KEY_mkdir;
79072805
LW		 4364 break;
4365 case 6:
a0d0e21e
LW		 4366 if (strEQ(d,"msgctl")) return -KEY_msgctl;
4367 if (strEQ(d,"msgget")) return -KEY_msgget;
4368 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
4369 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
79072805
LW		 4370 break;
4371 }
a687059c 4372 break;
79072805 4373 case 'N':
a0d0e21e 4374 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
a687059c 4375 break;
79072805
LW		 4376 case 'n':
4377 if (strEQ(d,"next")) return KEY_next;
a0d0e21e
LW		 4378 if (strEQ(d,"ne")) return -KEY_ne;
4379 if (strEQ(d,"not")) return -KEY_not;
4380 if (strEQ(d,"no")) return KEY_no;
a687059c 4381 break;
79072805
LW		 4382 case 'o':
4383 switch (len) {
463ee0b2 4384 case 2:
a0d0e21e 4385 if (strEQ(d,"or")) return -KEY_or;
463ee0b2 4386 break;
79072805 4387 case 3:
a0d0e21e
LW		 4388 if (strEQ(d,"ord")) return -KEY_ord;
4389 if (strEQ(d,"oct")) return -KEY_oct;
79072805
LW		 4390 break;
4391 case 4:
a0d0e21e 4392 if (strEQ(d,"open")) return -KEY_open;
79072805
LW		 4393 break;
4394 case 7:
a0d0e21e 4395 if (strEQ(d,"opendir")) return -KEY_opendir;
79072805 4396 break;
fe14fcc3 4397 }
a687059c 4398 break;
79072805
LW		 4399 case 'p':
4400 switch (len) {
4401 case 3:
4402 if (strEQ(d,"pop")) return KEY_pop;
a0d0e21e 4403 if (strEQ(d,"pos")) return KEY_pos;
79072805
LW		 4404 break;
4405 case 4:
4406 if (strEQ(d,"push")) return KEY_push;
a0d0e21e
LW		 4407 if (strEQ(d,"pack")) return -KEY_pack;
4408 if (strEQ(d,"pipe")) return -KEY_pipe;
79072805
LW		 4409 break;
4410 case 5:
4411 if (strEQ(d,"print")) return KEY_print;
4412 break;
4413 case 6:
4414 if (strEQ(d,"printf")) return KEY_printf;
4415 break;
4416 case 7:
4417 if (strEQ(d,"package")) return KEY_package;
4418 break;
c07a80fd 4419 case 9:
4420 if (strEQ(d,"prototype")) return KEY_prototype;
663a0e37 4421 }
79072805
LW		 4422 break;
4423 case 'q':
4424 if (len <= 2) {
4425 if (strEQ(d,"q")) return KEY_q;
4426 if (strEQ(d,"qq")) return KEY_qq;
8990e307 4427 if (strEQ(d,"qw")) return KEY_qw;
79072805 4428 if (strEQ(d,"qx")) return KEY_qx;
663a0e37 4429 }
a0d0e21e 4430 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
79072805
LW		 4431 break;
4432 case 'r':
4433 switch (len) {
4434 case 3:
a0d0e21e 4435 if (strEQ(d,"ref")) return -KEY_ref;
79072805
LW		 4436 break;
4437 case 4:
a0d0e21e
LW		 4438 if (strEQ(d,"read")) return -KEY_read;
4439 if (strEQ(d,"rand")) return -KEY_rand;
4440 if (strEQ(d,"recv")) return -KEY_recv;
79072805
LW		 4441 if (strEQ(d,"redo")) return KEY_redo;
4442 break;
4443 case 5:
a0d0e21e
LW		 4444 if (strEQ(d,"rmdir")) return -KEY_rmdir;
4445 if (strEQ(d,"reset")) return -KEY_reset;
79072805
LW		 4446 break;
4447 case 6:
4448 if (strEQ(d,"return")) return KEY_return;
a0d0e21e
LW		 4449 if (strEQ(d,"rename")) return -KEY_rename;
4450 if (strEQ(d,"rindex")) return -KEY_rindex;
79072805
LW		 4451 break;
4452 case 7:
a0d0e21e
LW		 4453 if (strEQ(d,"require")) return -KEY_require;
4454 if (strEQ(d,"reverse")) return -KEY_reverse;
4455 if (strEQ(d,"readdir")) return -KEY_readdir;
79072805
LW		 4456 break;
4457 case 8:
a0d0e21e
LW		 4458 if (strEQ(d,"readlink")) return -KEY_readlink;
4459 if (strEQ(d,"readline")) return -KEY_readline;
4460 if (strEQ(d,"readpipe")) return -KEY_readpipe;
79072805
LW		 4461 break;
4462 case 9:
a0d0e21e 4463 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
79072805 4464 break;
a687059c 4465 }
79072805
LW		 4466 break;
4467 case 's':
a687059c 4468 switch (d[1]) {
79072805 4469 case 0: return KEY_s;
a687059c 4470 case 'c':
79072805 4471 if (strEQ(d,"scalar")) return KEY_scalar;
a687059c
LW		 4472 break;
4473 case 'e':
79072805
LW		 4474 switch (len) {
4475 case 4:
a0d0e21e
LW		 4476 if (strEQ(d,"seek")) return -KEY_seek;
4477 if (strEQ(d,"send")) return -KEY_send;
79072805
LW		 4478 break;
4479 case 5:
a0d0e21e 4480 if (strEQ(d,"semop")) return -KEY_semop;
79072805
LW		 4481 break;
4482 case 6:
a0d0e21e
LW		 4483 if (strEQ(d,"select")) return -KEY_select;
4484 if (strEQ(d,"semctl")) return -KEY_semctl;
4485 if (strEQ(d,"semget")) return -KEY_semget;
79072805
LW		 4486 break;
4487 case 7:
a0d0e21e
LW		 4488 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
4489 if (strEQ(d,"seekdir")) return -KEY_seekdir;
79072805
LW		 4490 break;
4491 case 8:
a0d0e21e
LW		 4492 if (strEQ(d,"setpwent")) return -KEY_setpwent;
4493 if (strEQ(d,"setgrent")) return -KEY_setgrent;
79072805
LW		 4494 break;
4495 case 9:
a0d0e21e 4496 if (strEQ(d,"setnetent")) return -KEY_setnetent;
79072805
LW		 4497 break;
4498 case 10:
a0d0e21e
LW		 4499 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
4500 if (strEQ(d,"sethostent")) return -KEY_sethostent;
4501 if (strEQ(d,"setservent")) return -KEY_setservent;
79072805
LW		 4502 break;
4503 case 11:
a0d0e21e
LW		 4504 if (strEQ(d,"setpriority")) return -KEY_setpriority;
4505 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
79072805
LW		 4506 break;
4507 }
a687059c
LW		 4508 break;
4509 case 'h':
79072805
LW		 4510 switch (len) {
4511 case 5:
4512 if (strEQ(d,"shift")) return KEY_shift;
4513 break;
4514 case 6:
a0d0e21e
LW		 4515 if (strEQ(d,"shmctl")) return -KEY_shmctl;
4516 if (strEQ(d,"shmget")) return -KEY_shmget;
79072805
LW		 4517 break;
4518 case 7:
a0d0e21e 4519 if (strEQ(d,"shmread")) return -KEY_shmread;
79072805
LW		 4520 break;
4521 case 8:
a0d0e21e
LW		 4522 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
4523 if (strEQ(d,"shutdown")) return -KEY_shutdown;
79072805
LW		 4524 break;
4525 }
a687059c
LW		 4526 break;
4527 case 'i':
a0d0e21e 4528 if (strEQ(d,"sin")) return -KEY_sin;
a687059c
LW		 4529 break;
4530 case 'l':
a0d0e21e 4531 if (strEQ(d,"sleep")) return -KEY_sleep;
a687059c
LW		 4532 break;
4533 case 'o':
79072805 4534 if (strEQ(d,"sort")) return KEY_sort;
a0d0e21e
LW		 4535 if (strEQ(d,"socket")) return -KEY_socket;
4536 if (strEQ(d,"socketpair")) return -KEY_socketpair;
a687059c
LW		 4537 break;
4538 case 'p':
79072805 4539 if (strEQ(d,"split")) return KEY_split;
a0d0e21e 4540 if (strEQ(d,"sprintf")) return -KEY_sprintf;
79072805 4541 if (strEQ(d,"splice")) return KEY_splice;
a687059c
LW		 4542 break;
4543 case 'q':
a0d0e21e 4544 if (strEQ(d,"sqrt")) return -KEY_sqrt;
a687059c
LW		 4545 break;
4546 case 'r':
a0d0e21e 4547 if (strEQ(d,"srand")) return -KEY_srand;
a687059c
LW		 4548 break;
4549 case 't':
a0d0e21e 4550 if (strEQ(d,"stat")) return -KEY_stat;
79072805 4551 if (strEQ(d,"study")) return KEY_study;
a687059c
LW		 4552 break;
4553 case 'u':
a0d0e21e 4554 if (strEQ(d,"substr")) return -KEY_substr;
79072805 4555 if (strEQ(d,"sub")) return KEY_sub;
a687059c
LW		 4556 break;
4557 case 'y':
79072805
LW		 4558 switch (len) {
4559 case 6:
a0d0e21e 4560 if (strEQ(d,"system")) return -KEY_system;
79072805
LW		 4561 break;
4562 case 7:
a0d0e21e
LW		 4563 if (strEQ(d,"symlink")) return -KEY_symlink;
4564 if (strEQ(d,"syscall")) return -KEY_syscall;
137443ea 4565 if (strEQ(d,"sysopen")) return -KEY_sysopen;
4566 if (strEQ(d,"sysread")) return -KEY_sysread;
4567 if (strEQ(d,"sysseek")) return -KEY_sysseek;
79072805
LW		 4568 break;
4569 case 8:
a0d0e21e 4570 if (strEQ(d,"syswrite")) return -KEY_syswrite;
79072805 4571 break;
a687059c 4572 }
a687059c
LW		 4573 break;
4574 }
4575 break;
79072805
LW		 4576 case 't':
4577 switch (len) {
4578 case 2:
4579 if (strEQ(d,"tr")) return KEY_tr;
4580 break;
463ee0b2
LW		 4581 case 3:
4582 if (strEQ(d,"tie")) return KEY_tie;
4583 break;
79072805 4584 case 4:
a0d0e21e 4585 if (strEQ(d,"tell")) return -KEY_tell;
c07a80fd 4586 if (strEQ(d,"tied")) return KEY_tied;
a0d0e21e 4587 if (strEQ(d,"time")) return -KEY_time;
79072805
LW		 4588 break;
4589 case 5:
a0d0e21e 4590 if (strEQ(d,"times")) return -KEY_times;
79072805
LW		 4591 break;
4592 case 7:
a0d0e21e 4593 if (strEQ(d,"telldir")) return -KEY_telldir;
79072805
LW		 4594 break;
4595 case 8:
a0d0e21e 4596 if (strEQ(d,"truncate")) return -KEY_truncate;
79072805 4597 break;
378cc40b 4598 }
a687059c 4599 break;
79072805
LW		 4600 case 'u':
4601 switch (len) {
4602 case 2:
a0d0e21e
LW		 4603 if (strEQ(d,"uc")) return -KEY_uc;
4604 break;
4605 case 3:
4606 if (strEQ(d,"use")) return KEY_use;
79072805
LW		 4607 break;
4608 case 5:
4609 if (strEQ(d,"undef")) return KEY_undef;
4610 if (strEQ(d,"until")) return KEY_until;
463ee0b2 4611 if (strEQ(d,"untie")) return KEY_untie;
a0d0e21e
LW		 4612 if (strEQ(d,"utime")) return -KEY_utime;
4613 if (strEQ(d,"umask")) return -KEY_umask;
79072805
LW		 4614 break;
4615 case 6:
4616 if (strEQ(d,"unless")) return KEY_unless;
a0d0e21e
LW		 4617 if (strEQ(d,"unpack")) return -KEY_unpack;
4618 if (strEQ(d,"unlink")) return -KEY_unlink;
79072805
LW		 4619 break;
4620 case 7:
4621 if (strEQ(d,"unshift")) return KEY_unshift;
a0d0e21e 4622 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
79072805 4623 break;
a687059c
LW		 4624 }
4625 break;
79072805 4626 case 'v':
a0d0e21e
LW		 4627 if (strEQ(d,"values")) return -KEY_values;
4628 if (strEQ(d,"vec")) return -KEY_vec;
a687059c 4629 break;
79072805
LW		 4630 case 'w':
4631 switch (len) {
4632 case 4:
a0d0e21e
LW		 4633 if (strEQ(d,"warn")) return -KEY_warn;
4634 if (strEQ(d,"wait")) return -KEY_wait;
79072805
LW		 4635 break;
4636 case 5:
4637 if (strEQ(d,"while")) return KEY_while;
a0d0e21e 4638 if (strEQ(d,"write")) return -KEY_write;
79072805
LW		 4639 break;
4640 case 7:
a0d0e21e 4641 if (strEQ(d,"waitpid")) return -KEY_waitpid;
79072805
LW		 4642 break;
4643 case 9:
a0d0e21e 4644 if (strEQ(d,"wantarray")) return -KEY_wantarray;
79072805 4645 break;
2f3197b3 4646 }
a687059c 4647 break;
79072805 4648 case 'x':
a0d0e21e
LW		 4649 if (len == 1) return -KEY_x;
4650 if (strEQ(d,"xor")) return -KEY_xor;
a687059c 4651 break;
79072805
LW		 4652 case 'y':
4653 if (len == 1) return KEY_y;
4654 break;
4655 case 'z':
a687059c
LW		 4656 break;
4657 }
79072805 4658 return 0;
a687059c
LW		 4659}
4660
8990e307 4661static void
8ac85365 4662checkcomma(register char *s, char *name, char *what)
a687059c 4663{
2f3197b3
LW		 4664 char *w;
4665
463ee0b2 4666 if (dowarn && *s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
a0d0e21e
LW		 4667 int level = 1;
4668 for (w = s+2; *w && level; w++) {
4669 if (*w == '(')
4670 ++level;
4671 else if (*w == ')')
4672 --level;
4673 }
4674 if (*w)
4675 for (; *w && isSPACE(*w); w++) ;
d1f3fb15 4676 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
2f3197b3
LW		 4677 warn("%s (...) interpreted as function",name);
4678 }
4679 while (s < bufend && isSPACE(*s))
4680 s++;
a687059c
LW		 4681 if (*s == '(')
4682 s++;
de3bb511 4683 while (s < bufend && isSPACE(*s))
a687059c 4684 s++;
79072805 4685 if (isIDFIRST(*s)) {
2f3197b3 4686 w = s++;
de3bb511 4687 while (isALNUM(*s))
a687059c 4688 s++;
de3bb511 4689 while (s < bufend && isSPACE(*s))
a687059c 4690 s++;
e929a76b 4691 if (*s == ',') {
463ee0b2 4692 int kw;
e929a76b 4693 *s = '\0';
4633a7c4 4694 kw = keyword(w, s - w) || perl_get_cv(w, FALSE) != 0;
e929a76b 4695 *s = ',';
463ee0b2 4696 if (kw)
e929a76b 4697 return;
463ee0b2
LW		 4698 croak("No comma allowed after %s", what);
4699 }
4700 }
4701}
4702
8990e307 4703static char *
8ac85365 4704scan_word(register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
463ee0b2
LW		 4705{
4706 register char *d = dest;
8903cb82 4707 register char *e = d + destlen - 3; /* two-character token, ending NUL */
463ee0b2 4708 for (;;) {
8903cb82 4709 if (d >= e)
fc36a67e 4710 croak(ident_too_long);
463ee0b2
LW		 4711 if (isALNUM(*s))
4712 *d++ = *s++;
4713 else if (*s == '\'' && allow_package && isIDFIRST(s[1])) {
4714 *d++ = ':';
4715 *d++ = ':';
4716 s++;
4717 }
c3e0f903 4718 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
463ee0b2
LW		 4719 *d++ = *s++;
4720 *d++ = *s++;
4721 }
4722 else {
4723 *d = '\0';
4724 *slp = d - dest;
4725 return s;
e929a76b 4726 }
378cc40b
LW		 4727 }
4728}
4729
8990e307 4730static char *
8ac85365 4731scan_ident(register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
378cc40b
LW		 4732{
4733 register char *d;
8903cb82 4734 register char *e;
79072805 4735 char *bracket = 0;
748a9306 4736 char funny = *s++;
378cc40b 4737
79072805
LW		 4738 if (lex_brackets == 0)
4739 lex_fakebrack = 0;
a0d0e21e
LW		 4740 if (isSPACE(*s))
4741 s = skipspace(s);
378cc40b 4742 d = dest;
8903cb82 4743 e = d + destlen - 3; /* two-character token, ending NUL */
de3bb511 4744 if (isDIGIT(*s)) {
8903cb82 4745 while (isDIGIT(*s)) {
4746 if (d >= e)
fc36a67e 4747 croak(ident_too_long);
378cc40b 4748 *d++ = *s++;
8903cb82 4749 }
378cc40b
LW		 4750 }
4751 else {
463ee0b2 4752 for (;;) {
8903cb82 4753 if (d >= e)
fc36a67e 4754 croak(ident_too_long);
463ee0b2
LW		 4755 if (isALNUM(*s))
4756 *d++ = *s++;
4757 else if (*s == '\'' && isIDFIRST(s[1])) {
4758 *d++ = ':';
4759 *d++ = ':';
4760 s++;
4761 }
a0d0e21e 4762 else if (*s == ':' && s[1] == ':') {
463ee0b2
LW		 4763 *d++ = *s++;
4764 *d++ = *s++;
4765 }
4766 else
4767 break;
4768 }
378cc40b
LW		 4769 }
4770 *d = '\0';
4771 d = dest;
79072805
LW		 4772 if (*d) {
4773 if (lex_state != LEX_NORMAL)
4774 lex_state = LEX_INTERPENDMAYBE;
4775 return s;
378cc40b 4776 }
748a9306 4777 if (*s == '$' && s[1] &&
ff0cee69 4778 (isALNUM(s[1]) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
5cd24f17 4779 {
4780 if (isDIGIT(s[1]) && lex_state == LEX_INTERPNORMAL)
4781 deprecate("\"$$<digit>\" to mean \"${$}<digit>\"");
4782 else
4783 return s;
4784 }
79072805
LW		 4785 if (*s == '{') {
4786 bracket = s;
4787 s++;
4788 }
4789 else if (ck_uni)
4790 check_uni();
93a17b20 4791 if (s < send)
79072805
LW		 4792 *d = *s++;
4793 d[1] = '\0';
748a9306 4794 if (*d == '^' && *s && (isUPPER(*s) || strchr("[\\]^_?", *s))) {
bbce6d69 4795 *d = toCTRL(*s);
4796 s++;
de3bb511 4797 }
79072805 4798 if (bracket) {
748a9306 4799 if (isSPACE(s[-1])) {
fa83b5b6 4800 while (s < send) {
4801 char ch = *s++;
4802 if (ch != ' ' && ch != '\t') {
4803 *d = ch;
4804 break;
4805 }
4806 }
748a9306 4807 }
ff68c719 4808 if (isIDFIRST(*d)) {
79072805 4809 d++;
748a9306 4810 while (isALNUM(*s) || *s == ':')
79072805
LW		 4811 *d++ = *s++;
4812 *d = '\0';
748a9306 4813 while (s < send && (*s == ' ' || *s == '\t')) s++;
ff68c719 4814 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
748a9306
LW		 4815 if (dowarn && keyword(dest, d - dest)) {
4816 char *brack = *s == '[' ? "[...]" : "{...}";
4817 warn("Ambiguous use of %c{%s%s} resolved to %c%s%s",
4818 funny, dest, brack, funny, dest, brack);
4819 }
4820 lex_fakebrack = lex_brackets+1;
79072805 4821 bracket++;
a0d0e21e 4822 lex_brackstack[lex_brackets++] = XOPERATOR;
79072805
LW		 4823 return s;
4824 }
4825 }
4826 if (*s == '}') {
4827 s++;
4828 if (lex_state == LEX_INTERPNORMAL && !lex_brackets)
4829 lex_state = LEX_INTERPEND;
748a9306
LW		 4830 if (funny == '#')
4831 funny = '@';
84902520 4832 if (dowarn && lex_state == LEX_NORMAL &&
748a9306
LW		 4833 (keyword(dest, d - dest) || perl_get_cv(dest, FALSE)))
4834 warn("Ambiguous use of %c{%s} resolved to %c%s",
4835 funny, dest, funny, dest);
79072805
LW		 4836 }
4837 else {
4838 s = bracket; /* let the parser handle it */
93a17b20 4839 *dest = '\0';
79072805
LW		 4840 }
4841 }
4842 else if (lex_state == LEX_INTERPNORMAL && !lex_brackets && !intuit_more(s))
4843 lex_state = LEX_INTERPEND;
378cc40b
LW		 4844 return s;
4845}
4846
8ac85365 4847void pmflag(U16 *pmfl, int ch)
a0d0e21e 4848{
bbce6d69 4849 if (ch == 'i')
a0d0e21e 4850 *pmfl |= PMf_FOLD;
a0d0e21e
LW		 4851 else if (ch == 'g')
4852 *pmfl |= PMf_GLOBAL;
c90c0ff4 4853 else if (ch == 'c')
4854 *pmfl |= PMf_CONTINUE;
a0d0e21e
LW		 4855 else if (ch == 'o')
4856 *pmfl |= PMf_KEEP;
4857 else if (ch == 'm')
4858 *pmfl |= PMf_MULTILINE;
4859 else if (ch == 's')
4860 *pmfl |= PMf_SINGLELINE;
4861 else if (ch == 'x')
4862 *pmfl |= PMf_EXTENDED;
4863}
378cc40b 4864
8990e307 4865static char *
8ac85365 4866scan_pat(char *start)
378cc40b 4867{
79072805
LW		 4868 PMOP *pm;
4869 char *s;
378cc40b 4870
79072805
LW		 4871 s = scan_str(start);
4872 if (!s) {
4873 if (lex_stuff)
8990e307 4874 SvREFCNT_dec(lex_stuff);
79072805 4875 lex_stuff = Nullsv;
463ee0b2 4876 croak("Search pattern not terminated");
378cc40b 4877 }
bbce6d69 4878
79072805 4879 pm = (PMOP*)newPMOP(OP_MATCH, 0);
a0d0e21e 4880 if (multi_open == '?')
79072805 4881 pm->op_pmflags |= PMf_ONCE;
c90c0ff4 4882 while (*s && strchr("iogcmsx", *s))
a0d0e21e 4883 pmflag(&pm->op_pmflags,*s++);
4633a7c4 4884 pm->op_pmpermflags = pm->op_pmflags;
bbce6d69 4885
79072805
LW		 4886 lex_op = (OP*)pm;
4887 yylval.ival = OP_MATCH;
378cc40b
LW		 4888 return s;
4889}
4890
8990e307 4891static char *
8ac85365 4892scan_subst(char *start)
79072805 4893{
a0d0e21e 4894 register char *s;
79072805 4895 register PMOP *pm;
4fdae800 4896 I32 first_start;
79072805
LW		 4897 I32 es = 0;
4898
79072805
LW		 4899 yylval.ival = OP_NULL;
4900
a0d0e21e 4901 s = scan_str(start);
79072805
LW		 4902
4903 if (!s) {
4904 if (lex_stuff)
8990e307 4905 SvREFCNT_dec(lex_stuff);
79072805 4906 lex_stuff = Nullsv;
463ee0b2 4907 croak("Substitution pattern not terminated");
a687059c 4908 }
79072805 4909
a0d0e21e 4910 if (s[-1] == multi_open)
79072805
LW		 4911 s--;
4912
4fdae800 4913 first_start = multi_start;
79072805
LW		 4914 s = scan_str(s);
4915 if (!s) {
4916 if (lex_stuff)
8990e307 4917 SvREFCNT_dec(lex_stuff);
79072805
LW		 4918 lex_stuff = Nullsv;
4919 if (lex_repl)
8990e307 4920 SvREFCNT_dec(lex_repl);
79072805 4921 lex_repl = Nullsv;
463ee0b2 4922 croak("Substitution replacement not terminated");
a687059c 4923 }
4fdae800 4924 multi_start = first_start; /* so whole substitution is taken together */
2f3197b3 4925
79072805 4926 pm = (PMOP*)newPMOP(OP_SUBST, 0);
c90c0ff4 4927 while (*s && strchr("iogcmsex", *s)) {
a687059c
LW		 4928 if (*s == 'e') {
4929 s++;
2f3197b3 4930 es++;
a687059c 4931 }
a0d0e21e
LW		 4932 else
4933 pmflag(&pm->op_pmflags,*s++);
378cc40b 4934 }
79072805
LW		 4935
4936 if (es) {
4937 SV *repl;
4938 pm->op_pmflags |= PMf_EVAL;
463ee0b2
LW		 4939 repl = newSVpv("",0);
4940 while (es-- > 0)
a0d0e21e 4941 sv_catpv(repl, es ? "eval " : "do ");
79072805
LW		 4942 sv_catpvn(repl, "{ ", 2);
4943 sv_catsv(repl, lex_repl);
4944 sv_catpvn(repl, " };", 2);
4945 SvCOMPILED_on(repl);
8990e307 4946 SvREFCNT_dec(lex_repl);
79072805 4947 lex_repl = repl;
378cc40b 4948 }
79072805 4949
4633a7c4 4950 pm->op_pmpermflags = pm->op_pmflags;
79072805
LW		 4951 lex_op = (OP*)pm;
4952 yylval.ival = OP_SUBST;
378cc40b
LW		 4953 return s;
4954}
4955
8990e307 4956static char *
8ac85365 4957scan_trans(char *start)
378cc40b 4958{
a0d0e21e 4959 register char* s;
11343788 4960 OP *o;
79072805
LW		 4961 short *tbl;
4962 I32 squash;
8ac85365 4963 I32 Delete;
79072805
LW		 4964 I32 complement;
4965
4966 yylval.ival = OP_NULL;
4967
a0d0e21e 4968 s = scan_str(start);
79072805
LW		 4969 if (!s) {
4970 if (lex_stuff)
8990e307 4971 SvREFCNT_dec(lex_stuff);
79072805 4972 lex_stuff = Nullsv;
2c268ad5 4973 croak("Transliteration pattern not terminated");
a687059c 4974 }
a0d0e21e 4975 if (s[-1] == multi_open)
2f3197b3
LW		 4976 s--;
4977
93a17b20 4978 s = scan_str(s);
79072805
LW		 4979 if (!s) {
4980 if (lex_stuff)
8990e307 4981 SvREFCNT_dec(lex_stuff);
79072805
LW		 4982 lex_stuff = Nullsv;
4983 if (lex_repl)
8990e307 4984 SvREFCNT_dec(lex_repl);
79072805 4985 lex_repl = Nullsv;
2c268ad5 4986 croak("Transliteration replacement not terminated");
a687059c 4987 }
79072805
LW		 4988
4989 New(803,tbl,256,short);
11343788 4990 o = newPVOP(OP_TRANS, 0, (char*)tbl);
2f3197b3 4991
8ac85365 4992 complement = Delete = squash = 0;
395c3793
LW		 4993 while (*s == 'c' || *s == 'd' || *s == 's') {
4994 if (*s == 'c')
79072805 4995 complement = OPpTRANS_COMPLEMENT;
395c3793 4996 else if (*s == 'd')
8ac85365 4997 Delete = OPpTRANS_DELETE;
395c3793 4998 else
79072805 4999 squash = OPpTRANS_SQUASH;
395c3793
LW		 5000 s++;
5001 }
8ac85365 5002 o->op_private = Delete|squash|complement;
79072805 5003
11343788 5004 lex_op = o;
79072805
LW		 5005 yylval.ival = OP_TRANS;
5006 return s;
5007}
5008
8990e307 5009static char *
8ac85365 5010scan_heredoc(register char *s)
79072805 5011{
11343788 5012 dTHR;
79072805
LW		 5013 SV *herewas;
5014 I32 op_type = OP_SCALAR;
5015 I32 len;
5016 SV *tmpstr;
5017 char term;
5018 register char *d;
fc36a67e 5019 register char *e;
4633a7c4 5020 char *peek;
a2c06652 5021 int outer = (rsfp && !(lex_inwhat == OP_SCALAR));
79072805
LW		 5022
5023 s += 2;
5024 d = tokenbuf;
fc36a67e 5025 e = tokenbuf + sizeof tokenbuf - 1;
fd2d0953 5026 if (!outer)
79072805 5027 *d++ = '\n';
4633a7c4
LW		 5028 for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5029 if (*peek && strchr("`'\"",*peek)) {
5030 s = peek;
79072805 5031 term = *s++;
fc36a67e 5032 s = delimcpy(d, e, s, bufend, term, &len);
5033 d += len;
79072805
LW		 5034 if (s < bufend)
5035 s++;
79072805
LW		 5036 }
5037 else {
5038 if (*s == '\\')
5039 s++, term = '\'';
5040 else
5041 term = '"';
4633a7c4
LW		 5042 if (!isALNUM(*s))
5043 deprecate("bare << to mean <<\"\"");
fc36a67e 5044 for (; isALNUM(*s); s++) {
5045 if (d < e)
5046 *d++ = *s;
5047 }
5048 }
5049 if (d >= tokenbuf + sizeof tokenbuf - 1)
5050 croak("Delimiter for here document is too long");
79072805
LW		 5051 *d++ = '\n';
5052 *d = '\0';
5053 len = d - tokenbuf;
5054 d = "\n";
fd2d0953 5055 if (outer || !(d=ninstr(s,bufend,d,d+1)))
79072805
LW		 5056 herewas = newSVpv(s,bufend-s);
5057 else
5058 s--, herewas = newSVpv(s,d-s);
5059 s += SvCUR(herewas);
748a9306
LW		 5060
5061 tmpstr = NEWSV(87,80);
5062 sv_upgrade(tmpstr, SVt_PVIV);
5063 if (term == '\'') {
79072805 5064 op_type = OP_CONST;
748a9306
LW		 5065 SvIVX(tmpstr) = -1;
5066 }
5067 else if (term == '`') {
79072805 5068 op_type = OP_BACKTICK;
748a9306
LW		 5069 SvIVX(tmpstr) = '\\';
5070 }
79072805
LW		 5071
5072 CLINE;
5073 multi_start = curcop->cop_line;
5074 multi_open = multi_close = '<';
79072805 5075 term = *tokenbuf;
fd2d0953 5076 if (!outer) {
79072805
LW		 5077 d = s;
5078 while (s < bufend &&
36477c24 5079 (*s != term || memNE(s,tokenbuf,len)) ) {
79072805
LW		 5080 if (*s++ == '\n')
5081 curcop->cop_line++;
5082 }
5083 if (s >= bufend) {
5084 curcop->cop_line = multi_start;
8990e307 5085 missingterm(tokenbuf);
79072805
LW		 5086 }
5087 sv_setpvn(tmpstr,d+1,s-d);
5088 s += len - 1;
49d8d3a1
MB		 5089 curcop->cop_line++; /* the preceding stmt passes a newline */
5090
79072805
LW		 5091 sv_catpvn(herewas,s,bufend-s);
5092 sv_setsv(linestr,herewas);
fd049845 5093 oldoldbufptr = oldbufptr = bufptr = s = linestart = SvPVX(linestr);
463ee0b2 5094 bufend = SvPVX(linestr) + SvCUR(linestr);
79072805
LW		 5095 }
5096 else
5097 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
5098 while (s >= bufend) { /* multiple line string? */
fd2d0953 5099 if (!outer ||
fd049845 5100 !(oldoldbufptr = oldbufptr = s = linestart = filter_gets(linestr, rsfp, 0))) {
79072805 5101 curcop->cop_line = multi_start;
8990e307 5102 missingterm(tokenbuf);
79072805
LW		 5103 }
5104 curcop->cop_line++;
84902520 5105 if (PERLDB_LINE && curstash != debstash) {
79072805
LW		 5106 SV *sv = NEWSV(88,0);
5107
93a17b20 5108 sv_upgrade(sv, SVt_PVMG);
79072805
LW		 5109 sv_setsv(sv,linestr);
5110 av_store(GvAV(curcop->cop_filegv),
5111 (I32)curcop->cop_line,sv);
5112 }
463ee0b2 5113 bufend = SvPVX(linestr) + SvCUR(linestr);
36477c24 5114 if (*s == term && memEQ(s,tokenbuf,len)) {
79072805
LW		 5115 s = bufend - 1;
5116 *s = ' ';
5117 sv_catsv(linestr,herewas);
463ee0b2 5118 bufend = SvPVX(linestr) + SvCUR(linestr);
79072805
LW		 5119 }
5120 else {
5121 s = bufend;
5122 sv_catsv(tmpstr,linestr);
395c3793
LW		 5123 }
5124 }
79072805
LW		 5125 multi_end = curcop->cop_line;
5126 s++;
5127 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
5128 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
463ee0b2 5129 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
79072805 5130 }
8990e307 5131 SvREFCNT_dec(herewas);
79072805
LW		 5132 lex_stuff = tmpstr;
5133 yylval.ival = op_type;
5134 return s;
5135}
5136
02aa26ce
NT		 5137/* scan_inputsymbol
5138 takes: current position in input buffer
5139 returns: new position in input buffer
5140 side-effects: yylval and lex_op are set.
5141
5142 This code handles:
5143
5144 <> read from ARGV
5145 <FH> read from filehandle
5146 <pkg::FH> read from package qualified filehandle
5147 <pkg'FH> read from package qualified filehandle
5148 <$fh> read from filehandle in $fh
5149 <*.h> filename glob
5150
5151*/
5152
8990e307 5153static char *
8ac85365 5154scan_inputsymbol(char *start)
79072805 5155{
02aa26ce 5156 register char *s = start; /* current position in buffer */
79072805 5157 register char *d;
fc36a67e 5158 register char *e;
79072805
LW		 5159 I32 len;
5160
02aa26ce
NT		 5161 d = tokenbuf; /* start of temp holding space */
5162 e = tokenbuf + sizeof tokenbuf; /* end of temp holding space */
5163 s = delimcpy(d, e, s + 1, bufend, '>', &len); /* extract until > */
5164
5165 /* die if we didn't have space for the contents of the <>,
5166 or if it didn't end
5167 */
5168
fc36a67e 5169 if (len >= sizeof tokenbuf)
5170 croak("Excessively long <> operator");
5171 if (s >= bufend)
463ee0b2 5172 croak("Unterminated <> operator");
02aa26ce 5173
fc36a67e 5174 s++;
02aa26ce
NT		 5175
5176 /* check for <$fh>
5177 Remember, only scalar variables are interpreted as filehandles by
5178 this code. Anything more complex (e.g., <$fh{$num}>) will be
5179 treated as a glob() call.
5180 This code makes use of the fact that except for the $ at the front,
5181 a scalar variable and a filehandle look the same.
5182 */
4633a7c4 5183 if (*d == '$' && d[1]) d++;
02aa26ce
NT		 5184
5185 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
a0d0e21e 5186 while (*d && (isALNUM(*d) || *d == '\'' || *d == ':'))
79072805 5187 d++;
02aa26ce
NT		 5188
5189 /* If we've tried to read what we allow filehandles to look like, and
5190 there's still text left, then it must be a glob() and not a getline.
5191 Use scan_str to pull out the stuff between the <> and treat it
5192 as nothing more than a string.
5193 */
5194
79072805
LW		 5195 if (d - tokenbuf != len) {
5196 yylval.ival = OP_GLOB;
5197 set_csh();
5198 s = scan_str(start);
5199 if (!s)
02aa26ce 5200 croak("Glob not terminated");
79072805
LW		 5201 return s;
5202 }
395c3793 5203 else {
02aa26ce 5204 /* we're in a filehandle read situation */
79072805 5205 d = tokenbuf;
02aa26ce
NT		 5206
5207 /* turn <> into <ARGV> */
79072805
LW		 5208 if (!len)
5209 (void)strcpy(d,"ARGV");
02aa26ce
NT		 5210
5211 /* if <$fh>, create the ops to turn the variable into a
5212 filehandle
5213 */
79072805 5214 if (*d == '$') {
a0d0e21e 5215 I32 tmp;
02aa26ce
NT		 5216
5217 /* try to find it in the pad for this block, otherwise find
5218 add symbol table ops
5219 */
11343788
MB		 5220 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
5221 OP *o = newOP(OP_PADSV, 0);
5222 o->op_targ = tmp;
5223 lex_op = (OP*)newUNOP(OP_READLINE, 0, newUNOP(OP_RV2GV, 0, o));
a0d0e21e
LW		 5224 }
5225 else {
5226 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
5227 lex_op = (OP*)newUNOP(OP_READLINE, 0,
5228 newUNOP(OP_RV2GV, 0,
5229 newUNOP(OP_RV2SV, 0,
5230 newGVOP(OP_GV, 0, gv))));
5231 }
02aa26ce 5232 /* we created the ops in lex_op, so make yylval.ival a null op */
79072805
LW		 5233 yylval.ival = OP_NULL;
5234 }
02aa26ce
NT		 5235
5236 /* If it's none of the above, it must be a literal filehandle
5237 (<Foo::BAR> or <FOO>) so build a simple readline OP */
79072805 5238 else {
85e6fe83 5239 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
79072805
LW		 5240 lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
5241 yylval.ival = OP_NULL;
5242 }
5243 }
02aa26ce 5244
79072805
LW		 5245 return s;
5246}
5247
02aa26ce
NT		 5248
5249/* scan_str
5250 takes: start position in buffer
5251 returns: position to continue reading from buffer
5252 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
5253 updates the read buffer.
5254
5255 This subroutine pulls a string out of the input. It is called for:
5256 q single quotes q(literal text)
5257 ' single quotes 'literal text'
5258 qq double quotes qq(interpolate $here please)
5259 " double quotes "interpolate $here please"
5260 qx backticks qx(/bin/ls -l)
5261 ` backticks `/bin/ls -l`
5262 qw quote words @EXPORT_OK = qw( func() $spam )
5263 m// regexp match m/this/
5264 s/// regexp substitute s/this/that/
5265 tr/// string transliterate tr/this/that/
5266 y/// string transliterate y/this/that/
5267 ($*@) sub prototypes sub foo ($)
5268 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
5269
5270 In most of these cases (all but <>, patterns and transliterate)
5271 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
5272 calls scan_str(). s/// makes yylex() call scan_subst() which calls
5273 scan_str(). tr/// and y/// make yylex() call scan_trans() which
5274 calls scan_str().
5275
5276 It skips whitespace before the string starts, and treats the first
5277 character as the delimiter. If the delimiter is one of ([{< then
5278 the corresponding "close" character )]}> is used as the closing
5279 delimiter. It allows quoting of delimiters, and if the string has
5280 balanced delimiters ([{<>}]) it allows nesting.
5281
5282 The lexer always reads these strings into lex_stuff, except in the
5283 case of the operators which take *two* arguments (s/// and tr///)
5284 when it checks to see if lex_stuff is full (presumably with the 1st
5285 arg to s or tr) and if so puts the string into lex_repl.
5286
5287*/
5288
8990e307 5289static char *
8ac85365 5290scan_str(char *start)
79072805 5291{
11343788 5292 dTHR;
02aa26ce
NT		 5293 SV *sv; /* scalar value: string */
5294 char *tmps; /* temp string, used for delimiter matching */
5295 register char *s = start; /* current position in the buffer */
5296 register char term; /* terminating character */
5297 register char *to; /* current position in the sv's data */
5298 I32 brackets = 1; /* bracket nesting level */
5299
5300 /* skip space before the delimiter */
fb73857a 5301 if (isSPACE(*s))
5302 s = skipspace(s);
02aa26ce
NT		 5303
5304 /* mark where we are, in case we need to report errors */
79072805 5305 CLINE;
02aa26ce
NT		 5306
5307 /* after skipping whitespace, the next character is the terminator */
a0d0e21e 5308 term = *s;
02aa26ce 5309 /* mark where we are */
79072805
LW		 5310 multi_start = curcop->cop_line;
5311 multi_open = term;
02aa26ce
NT		 5312
5313 /* find corresponding closing delimiter */
93a17b20 5314 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
79072805
LW		 5315 term = tmps[5];
5316 multi_close = term;
5317
02aa26ce
NT		 5318 /* create a new SV to hold the contents. 87 is leak category, I'm
5319 assuming. 80 is the SV's initial length. What a random number. */
93a17b20 5320 sv = NEWSV(87,80);
ed6116ce
LW		 5321 sv_upgrade(sv, SVt_PVIV);
5322 SvIVX(sv) = term;
a0d0e21e 5323 (void)SvPOK_only(sv); /* validate pointer */
02aa26ce
NT		 5324
5325 /* move past delimiter and try to read a complete string */
93a17b20
LW		 5326 s++;
5327 for (;;) {
02aa26ce 5328 /* extend sv if need be */
93a17b20 5329 SvGROW(sv, SvCUR(sv) + (bufend - s) + 1);
02aa26ce 5330 /* set 'to' to the next character in the sv's string */
463ee0b2 5331 to = SvPVX(sv)+SvCUR(sv);
02aa26ce
NT		 5332
5333 /* if open delimiter is the close delimiter read unbridle */
93a17b20
LW		 5334 if (multi_open == multi_close) {
5335 for (; s < bufend; s++,to++) {
02aa26ce 5336 /* embedded newlines increment the current line number */
463ee0b2
LW		 5337 if (*s == '\n' && !rsfp)
5338 curcop->cop_line++;
02aa26ce 5339 /* handle quoted delimiters */
a0d0e21e
LW		 5340 if (*s == '\\' && s+1 < bufend && term != '\\') {
5341 if (s[1] == term)
5342 s++;
02aa26ce 5343 /* any other quotes are simply copied straight through */
a0d0e21e
LW		 5344 else
5345 *to++ = *s++;
5346 }
02aa26ce
NT		 5347 /* terminate when run out of buffer (the for() condition), or
5348 have found the terminator */
93a17b20
LW		 5349 else if (*s == term)
5350 break;
5351 *to = *s;
5352 }
5353 }
02aa26ce
NT		 5354
5355 /* if the terminator isn't the same as the start character (e.g.,
5356 matched brackets), we have to allow more in the quoting, and
5357 be prepared for nested brackets.
5358 */
93a17b20 5359 else {
02aa26ce 5360 /* read until we run out of string, or we find the terminator */
93a17b20 5361 for (; s < bufend; s++,to++) {
02aa26ce 5362 /* embedded newlines increment the line count */
463ee0b2
LW		 5363 if (*s == '\n' && !rsfp)
5364 curcop->cop_line++;
02aa26ce 5365 /* backslashes can escape the open or closing characters */
6d07e5e9
GS		 5366 if (*s == '\\' && s+1 < bufend) {
5367 if ((s[1] == multi_open) || (s[1] == multi_close))
a0d0e21e
LW		 5368 s++;
5369 else
5370 *to++ = *s++;
5371 }
02aa26ce 5372 /* allow nested opens and closes */
6d07e5e9 5373 else if (*s == multi_close && --brackets <= 0)
93a17b20
LW		 5374 break;
5375 else if (*s == multi_open)
5376 brackets++;
5377 *to = *s;
5378 }
5379 }
02aa26ce 5380 /* terminate the copied string and update the sv's end-of-string */
93a17b20 5381 *to = '\0';
463ee0b2 5382 SvCUR_set(sv, to - SvPVX(sv));
93a17b20 5383
02aa26ce
NT		 5384 /*
5385 * this next chunk reads more into the buffer if we're not done yet
5386 */
5387
5388 if (s < bufend) break; /* handle case where we are done yet :-) */
79072805 5389
02aa26ce
NT		 5390 /* if we're out of file, or a read fails, bail and reset the current
5391 line marker so we can report where the unterminated string began
5392 */
79072805 5393 if (!rsfp ||
fd049845 5394 !(oldoldbufptr = oldbufptr = s = linestart = filter_gets(linestr, rsfp, 0))) {
c07a80fd 5395 sv_free(sv);
79072805
LW		 5396 curcop->cop_line = multi_start;
5397 return Nullch;
5398 }
02aa26ce 5399 /* we read a line, so increment our line counter */
79072805 5400 curcop->cop_line++;
02aa26ce
NT		 5401
5402 /* update debugger info */
84902520 5403 if (PERLDB_LINE && curstash != debstash) {
79072805
LW		 5404 SV *sv = NEWSV(88,0);
5405
93a17b20 5406 sv_upgrade(sv, SVt_PVMG);
79072805
LW		 5407 sv_setsv(sv,linestr);
5408 av_store(GvAV(curcop->cop_filegv),
5409 (I32)curcop->cop_line, sv);
395c3793 5410 }
02aa26ce
NT		 5411
5412 /* having changed the buffer, we must update bufend */
463ee0b2 5413 bufend = SvPVX(linestr) + SvCUR(linestr);
378cc40b 5414 }
02aa26ce
NT		 5415
5416 /* at this point, we have successfully read the delimited string */
5417
79072805
LW		 5418 multi_end = curcop->cop_line;
5419 s++;
02aa26ce
NT		 5420
5421 /* if we allocated too much space, give some back */
93a17b20
LW		 5422 if (SvCUR(sv) + 5 < SvLEN(sv)) {
5423 SvLEN_set(sv, SvCUR(sv) + 1);
463ee0b2 5424 Renew(SvPVX(sv), SvLEN(sv), char);
79072805 5425 }
02aa26ce
NT		 5426
5427 /* decide whether this is the first or second quoted string we've read
5428 for this op
5429 */
5430
79072805 5431 if (lex_stuff)
93a17b20 5432 lex_repl = sv;
79072805 5433 else
93a17b20 5434 lex_stuff = sv;
378cc40b
LW		 5435 return s;
5436}
5437
02aa26ce
NT		 5438/*
5439 scan_num
5440 takes: pointer to position in buffer
5441 returns: pointer to new position in buffer
5442 side-effects: builds ops for the constant in yylval.op
5443
5444 Read a number in any of the formats that Perl accepts:
5445
5446 0(x[0-7A-F]+)|([0-7]+)
5447 [\d_]+(\.[\d_]*)?[Ee](\d+)
5448
5449 Underbars (_) are allowed in decimal numbers. If -w is on,
5450 underbars before a decimal point must be at three digit intervals.
5451
5452 Like most scan_ routines, it uses the tokenbuf buffer to hold the
5453 thing it reads.
5454
5455 If it reads a number without a decimal point or an exponent, it will
5456 try converting the number to an integer and see if it can do so
5457 without loss of precision.
5458*/
5459
378cc40b 5460char *
8ac85365 5461scan_num(char *start)
378cc40b 5462{
02aa26ce
NT		 5463 register char *s = start; /* current position in buffer */
5464 register char *d; /* destination in temp buffer */
5465 register char *e; /* end of temp buffer */
5466 I32 tryiv; /* used to see if it can be an int */
5467 double value; /* number read, as a double */
5468 SV *sv; /* place to put the converted number */
5469 I32 floatit; /* boolean: int or float? */
5470 char *lastub = 0; /* position of last underbar */
fc36a67e 5471 static char number_too_long[] = "Number too long";
378cc40b 5472
02aa26ce
NT		 5473 /* We use the first character to decide what type of number this is */
5474
378cc40b 5475 switch (*s) {
79072805 5476 default:
02aa26ce
NT		 5477 croak("panic: scan_num");
5478
5479 /* if it starts with a 0, it could be an octal number, a decimal in
5480 0.13 disguise, or a hexadecimal number.
5481 */
378cc40b
LW		 5482 case '0':
5483 {
02aa26ce
NT		 5484 /* variables:
5485 u holds the "number so far"
5486 shift the power of 2 of the base (hex == 4, octal == 3)
5487 overflowed was the number more than we can hold?
5488
5489 Shift is used when we add a digit. It also serves as an "are
5490 we in octal or hex?" indicator to disallow hex characters when
5491 in octal mode.
5492 */
55497cff 5493 UV u;
79072805 5494 I32 shift;
55497cff 5495 bool overflowed = FALSE;
378cc40b 5496
02aa26ce 5497 /* check for hex */
378cc40b
LW		 5498 if (s[1] == 'x') {
5499 shift = 4;
5500 s += 2;
5501 }
02aa26ce 5502 /* check for a decimal in disguise */
378cc40b
LW		 5503 else if (s[1] == '.')
5504 goto decimal;
02aa26ce 5505 /* so it must be octal */
378cc40b
LW		 5506 else
5507 shift = 3;
55497cff 5508 u = 0;
02aa26ce
NT		 5509
5510 /* read the rest of the octal number */
378cc40b 5511 for (;;) {
02aa26ce 5512 UV n, b; /* n is used in the overflow test, b is the digit we're adding on */
55497cff 5513
378cc40b 5514 switch (*s) {
02aa26ce
NT		 5515
5516 /* if we don't mention it, we're done */
378cc40b
LW		 5517 default:
5518 goto out;
02aa26ce
NT		 5519
5520 /* _ are ignored */
de3bb511
LW		 5521 case '_':
5522 s++;
5523 break;
02aa26ce
NT		 5524
5525 /* 8 and 9 are not octal */
378cc40b
LW		 5526 case '8': case '9':
5527 if (shift != 4)
a687059c 5528 yyerror("Illegal octal digit");
378cc40b 5529 /* FALL THROUGH */
02aa26ce
NT		 5530
5531 /* octal digits */
378cc40b
LW		 5532 case '0': case '1': case '2': case '3': case '4':
5533 case '5': case '6': case '7':
02aa26ce 5534 b = *s++ & 15; /* ASCII digit -> value of digit */
55497cff 5535 goto digit;
02aa26ce
NT		 5536
5537 /* hex digits */
378cc40b
LW		 5538 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
5539 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
02aa26ce 5540 /* make sure they said 0x */
378cc40b
LW		 5541 if (shift != 4)
5542 goto out;
55497cff 5543 b = (*s++ & 7) + 9;
02aa26ce
NT		 5544
5545 /* Prepare to put the digit we have onto the end
5546 of the number so far. We check for overflows.
5547 */
5548
55497cff 5549 digit:
02aa26ce 5550 n = u << shift; /* make room for the digit */
55497cff 5551 if (!overflowed && (n >> shift) != u) {
5552 warn("Integer overflow in %s number",
5553 (shift == 4) ? "hex" : "octal");
5554 overflowed = TRUE;
5555 }
02aa26ce 5556 u = n | b; /* add the digit to the end */
378cc40b
LW		 5557 break;
5558 }
5559 }
02aa26ce
NT		 5560
5561 /* if we get here, we had success: make a scalar value from
5562 the number.
5563 */
378cc40b 5564 out:
79072805 5565 sv = NEWSV(92,0);
55497cff 5566 sv_setuv(sv, u);
378cc40b
LW		 5567 }
5568 break;
02aa26ce
NT		 5569
5570 /*
5571 handle decimal numbers.
5572 we're also sent here when we read a 0 as the first digit
5573 */
378cc40b
LW		 5574 case '1': case '2': case '3': case '4': case '5':
5575 case '6': case '7': case '8': case '9': case '.':
5576 decimal:
378cc40b 5577 d = tokenbuf;
fc36a67e 5578 e = tokenbuf + sizeof tokenbuf - 6; /* room for various punctuation */
79072805 5579 floatit = FALSE;
02aa26ce
NT		 5580
5581 /* read next group of digits and _ and copy into d */
de3bb511 5582 while (isDIGIT(*s) || *s == '_') {
02aa26ce
NT		 5583 /* skip underscores, checking for misplaced ones
5584 if -w is on
5585 */
93a17b20
LW		 5586 if (*s == '_') {
5587 if (dowarn && lastub && s - lastub != 3)
8990e307 5588 warn("Misplaced _ in number");
93a17b20
LW		 5589 lastub = ++s;
5590 }
fc36a67e 5591 else {
02aa26ce 5592 /* check for end of fixed-length buffer */
fc36a67e 5593 if (d >= e)
5594 croak(number_too_long);
02aa26ce 5595 /* if we're ok, copy the character */
378cc40b 5596 *d++ = *s++;
fc36a67e 5597 }
378cc40b 5598 }
02aa26ce
NT		 5599
5600 /* final misplaced underbar check */
93a17b20 5601 if (dowarn && lastub && s - lastub != 3)
8990e307 5602 warn("Misplaced _ in number");
02aa26ce
NT		 5603
5604 /* read a decimal portion if there is one. avoid
5605 3..5 being interpreted as the number 3. followed
5606 by .5
5607 */
2f3197b3 5608 if (*s == '.' && s[1] != '.') {
79072805 5609 floatit = TRUE;
378cc40b 5610 *d++ = *s++;
02aa26ce
NT		 5611
5612 /* copy, ignoring underbars, until we run out of
5613 digits. Note: no misplaced underbar checks!
5614 */
fc36a67e 5615 for (; isDIGIT(*s) || *s == '_'; s++) {
02aa26ce 5616 /* fixed length buffer check */
fc36a67e 5617 if (d >= e)
5618 croak(number_too_long);
5619 if (*s != '_')
5620 *d++ = *s;
378cc40b
LW		 5621 }
5622 }
02aa26ce
NT		 5623
5624 /* read exponent part, if present */
93a17b20 5625 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
79072805
LW		 5626 floatit = TRUE;
5627 s++;
02aa26ce
NT		 5628
5629 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
79072805 5630 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
02aa26ce
NT		 5631
5632 /* allow positive or negative exponent */
378cc40b
LW		 5633 if (*s == '+' || *s == '-')
5634 *d++ = *s++;
02aa26ce
NT		 5635
5636 /* read digits of exponent (no underbars :-) */
fc36a67e 5637 while (isDIGIT(*s)) {
5638 if (d >= e)
5639 croak(number_too_long);
378cc40b 5640 *d++ = *s++;
fc36a67e 5641 }
378cc40b 5642 }
02aa26ce
NT		 5643
5644 /* terminate the string */
378cc40b 5645 *d = '\0';
02aa26ce
NT		 5646
5647 /* make an sv from the string */
79072805 5648 sv = NEWSV(92,0);
02aa26ce 5649 /* reset numeric locale in case we were earlier left in Swaziland */
36477c24 5650 SET_NUMERIC_STANDARD();
79072805 5651 value = atof(tokenbuf);
02aa26ce
NT		 5652
5653 /*
5654 See if we can make do with an integer value without loss of
5655 precision. We use I_V to cast to an int, because some
5656 compilers have issues. Then we try casting it back and see
5657 if it was the same. We only do this if we know we
5658 specifically read an integer.
5659
5660 Note: if floatit is true, then we don't need to do the
5661 conversion at all.
5662 */
1e422769 5663 tryiv = I_V(value);
5664 if (!floatit && (double)tryiv == value)
5665 sv_setiv(sv, tryiv);
2f3197b3 5666 else
1e422769 5667 sv_setnv(sv, value);
378cc40b 5668 break;
79072805 5669 }
a687059c 5670
02aa26ce
NT		 5671 /* make the op for the constant and return */
5672
79072805 5673 yylval.opval = newSVOP(OP_CONST, 0, sv);
a687059c 5674
378cc40b
LW		 5675 return s;
5676}
5677
8990e307 5678static char *
8ac85365 5679scan_formline(register char *s)
378cc40b 5680{
11343788 5681 dTHR;
79072805 5682 register char *eol;
378cc40b 5683 register char *t;
a0d0e21e 5684 SV *stuff = newSVpv("",0);
79072805 5685 bool needargs = FALSE;
378cc40b 5686
79072805 5687 while (!needargs) {
85e6fe83 5688 if (*s == '.' || *s == '}') {
79072805
LW		 5689 /*SUPPRESS 530*/
5690 for (t = s+1; *t == ' ' || *t == '\t'; t++) ;
5691 if (*t == '\n')
5692 break;
5693 }
0f85fab0 5694 if (in_eval && !rsfp) {
93a17b20 5695 eol = strchr(s,'\n');
0f85fab0
LW		 5696 if (!eol++)
5697 eol = bufend;
5698 }
5699 else
463ee0b2 5700 eol = bufend = SvPVX(linestr) + SvCUR(linestr);
79072805 5701 if (*s != '#') {
a0d0e21e
LW		 5702 for (t = s; t < eol; t++) {
5703 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
5704 needargs = FALSE;
5705 goto enough; /* ~~ must be first line in formline */
378cc40b 5706 }
a0d0e21e
LW		 5707 if (*t == '@' || *t == '^')
5708 needargs = TRUE;
378cc40b 5709 }
a0d0e21e 5710 sv_catpvn(stuff, s, eol-s);
79072805
LW		 5711 }
5712 s = eol;
5713 if (rsfp) {
fd049845 5714 s = filter_gets(linestr, rsfp, 0);
5715 oldoldbufptr = oldbufptr = bufptr = linestart = SvPVX(linestr);
a0d0e21e 5716 bufend = bufptr + SvCUR(linestr);
79072805
LW		 5717 if (!s) {
5718 s = bufptr;
5719 yyerror("Format not terminated");
378cc40b
LW		 5720 break;
5721 }
378cc40b 5722 }
463ee0b2 5723 incline(s);
79072805 5724 }
a0d0e21e
LW		 5725 enough:
5726 if (SvCUR(stuff)) {
463ee0b2 5727 expect = XTERM;
79072805 5728 if (needargs) {
a0d0e21e 5729 lex_state = LEX_NORMAL;
79072805
LW		 5730 nextval[nexttoke].ival = 0;
5731 force_next(',');
5732 }
a0d0e21e
LW		 5733 else
5734 lex_state = LEX_FORMLINE;
79072805
LW		 5735 nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
5736 force_next(THING);
5737 nextval[nexttoke].ival = OP_FORMLINE;
5738 force_next(LSTOP);
378cc40b 5739 }
79072805 5740 else {
8990e307 5741 SvREFCNT_dec(stuff);
85e6fe83 5742 lex_formbrack = 0;
79072805
LW		 5743 bufptr = s;
5744 }
5745 return s;
378cc40b 5746}
a687059c 5747
2f3197b3 5748static void
8ac85365 5749set_csh(void)
a687059c 5750{
ae986130
LW		 5751#ifdef CSH
5752 if (!cshlen)
5753 cshlen = strlen(cshname);
5754#endif
a687059c 5755}
463ee0b2 5756
ba6d6ac9 5757I32
8ac85365 5758start_subparse(I32 is_format, U32 flags)
8990e307 5759{
11343788 5760 dTHR;
ba6d6ac9 5761 I32 oldsavestack_ix = savestack_ix;
748a9306
LW		 5762 CV* outsidecv = compcv;
5763 AV* comppadlist;
8990e307 5764
e9a444f0
LW		 5765 if (compcv) {
5766 assert(SvTYPE(compcv) == SVt_PVCV);
5767 }
8990e307
LW		 5768 save_I32(&subline);
5769 save_item(subname);
55497cff 5770 SAVEI32(padix);
8990e307
LW		 5771 SAVESPTR(curpad);
5772 SAVESPTR(comppad);
5773 SAVESPTR(comppad_name);
748a9306 5774 SAVESPTR(compcv);
55497cff 5775 SAVEI32(comppad_name_fill);
5776 SAVEI32(min_intro_pending);
5777 SAVEI32(max_intro_pending);
5778 SAVEI32(pad_reset_pending);
748a9306
LW		 5779
5780 compcv = (CV*)NEWSV(1104,0);
774d564b 5781 sv_upgrade((SV *)compcv, is_format ? SVt_PVFM : SVt_PVCV);
fa83b5b6 5782 CvFLAGS(compcv) |= flags;
748a9306 5783
8990e307 5784 comppad = newAV();
6d4ff0d2
MB		 5785 av_push(comppad, Nullsv);
5786 curpad = AvARRAY(comppad);
8990e307
LW		 5787 comppad_name = newAV();
5788 comppad_name_fill = 0;
5789 min_intro_pending = 0;
8990e307 5790 padix = 0;
8990e307 5791 subline = curcop->cop_line;
6d4ff0d2
MB		 5792#ifdef USE_THREADS
5793 av_store(comppad_name, 0, newSVpv("@_", 2));
5794 curpad[0] = (SV*)newAV();
5795 SvPADMY_on(curpad[0]); /* XXX Needed? */
5796 CvOWNER(compcv) = 0;
12ca11f6 5797 New(666, CvMUTEXP(compcv), 1, perl_mutex);
6d4ff0d2 5798 MUTEX_INIT(CvMUTEXP(compcv));
6d4ff0d2 5799#endif /* USE_THREADS */
748a9306
LW		 5800
5801 comppadlist = newAV();
5802 AvREAL_off(comppadlist);
8e07c86e
AD		 5803 av_store(comppadlist, 0, (SV*)comppad_name);
5804 av_store(comppadlist, 1, (SV*)comppad);
748a9306
LW		 5805
5806 CvPADLIST(compcv) = comppadlist;
199100c8 5807 CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc(outsidecv);
11343788
MB		 5808#ifdef USE_THREADS
5809 CvOWNER(compcv) = 0;
12ca11f6 5810 New(666, CvMUTEXP(compcv), 1, perl_mutex);
11343788 5811 MUTEX_INIT(CvMUTEXP(compcv));
11343788 5812#endif /* USE_THREADS */
748a9306 5813
8990e307
LW		 5814 return oldsavestack_ix;
5815}
5816
5817int
8ac85365 5818yywarn(char *s)
8990e307 5819{
11343788 5820 dTHR;
8990e307 5821 --error_count;
748a9306
LW		 5822 in_eval |= 2;
5823 yyerror(s);
5824 in_eval &= ~2;
5825 return 0;
8990e307
LW		 5826}
5827
5828int
8ac85365 5829yyerror(char *s)
463ee0b2 5830{
11343788 5831 dTHR;
68dc0745 5832 char *where = NULL;
5833 char *context = NULL;
5834 int contlen = -1;
46fc3d4c 5835 SV *msg;
463ee0b2 5836
54310121 5837 if (!yychar || (yychar == ';' && !rsfp))
5838 where = "at EOF";
5839 else if (bufptr > oldoldbufptr && bufptr - oldoldbufptr < 200 &&
463ee0b2
LW		 5840 oldoldbufptr != oldbufptr && oldbufptr != bufptr) {
5841 while (isSPACE(*oldoldbufptr))
5842 oldoldbufptr++;
68dc0745 5843 context = oldoldbufptr;
5844 contlen = bufptr - oldoldbufptr;
463ee0b2
LW		 5845 }
5846 else if (bufptr > oldbufptr && bufptr - oldbufptr < 200 &&
5847 oldbufptr != bufptr) {
5848 while (isSPACE(*oldbufptr))
5849 oldbufptr++;
68dc0745 5850 context = oldbufptr;
5851 contlen = bufptr - oldbufptr;
463ee0b2
LW		 5852 }
5853 else if (yychar > 255)
68dc0745 5854 where = "next token ???";
463ee0b2
LW		 5855 else if ((yychar & 127) == 127) {
5856 if (lex_state == LEX_NORMAL ||
5857 (lex_state == LEX_KNOWNEXT && lex_defer == LEX_NORMAL))
68dc0745 5858 where = "at end of line";
4633a7c4 5859 else if (lex_inpat)
68dc0745 5860 where = "within pattern";
463ee0b2 5861 else
68dc0745 5862 where = "within string";
463ee0b2 5863 }
46fc3d4c 5864 else {
5865 SV *where_sv = sv_2mortal(newSVpv("next char ", 0));
5866 if (yychar < 32)
5867 sv_catpvf(where_sv, "^%c", toCTRL(yychar));
5868 else if (isPRINT_LC(yychar))
5869 sv_catpvf(where_sv, "%c", yychar);
463ee0b2 5870 else
46fc3d4c 5871 sv_catpvf(where_sv, "\\%03o", yychar & 255);
5872 where = SvPVX(where_sv);
463ee0b2 5873 }
46fc3d4c 5874 msg = sv_2mortal(newSVpv(s, 0));
fc36a67e 5875 sv_catpvf(msg, " at %_ line %ld, ",
46fc3d4c 5876 GvSV(curcop->cop_filegv), (long)curcop->cop_line);
68dc0745 5877 if (context)
46fc3d4c 5878 sv_catpvf(msg, "near \"%.*s\"\n", contlen, context);
463ee0b2 5879 else
46fc3d4c 5880 sv_catpvf(msg, "%s\n", where);
4fdae800 5881 if (multi_start < multi_end && (U32)(curcop->cop_line - multi_end) <= 1) {
46fc3d4c 5882 sv_catpvf(msg,
4fdae800 5883 " (Might be a runaway multi-line %c%c string starting on line %ld)\n",
ff0cee69 5884 (int)multi_open,(int)multi_close,(long)multi_start);
a0d0e21e
LW		 5885 multi_end = 0;
5886 }
748a9306 5887 if (in_eval & 2)
fc36a67e 5888 warn("%_", msg);
748a9306 5889 else if (in_eval)
38a03e6e 5890 sv_catsv(ERRSV, msg);
463ee0b2 5891 else
46fc3d4c 5892 PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
463ee0b2 5893 if (++error_count >= 10)
fc36a67e 5894 croak("%_ has too many errors.\n", GvSV(curcop->cop_filegv));
4633a7c4 5895 in_my = 0;
c750a3ec 5896 in_my_stash = Nullhv;
463ee0b2
LW		 5897 return 0;
5898}
4e35701f 5899
161b471a 5900
Unnamed repository; edit this file 'description' to name the repository.