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] another maintpatch (this one needed adjust of test nos.)
[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 */
558 gv_fetchpv(s, in_eval ? GV_ADDMULTI : 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
771 In patterns:
772 backslashes:
773 double-quoted style: \r and \n
774 regexp special ones: \D \s
775 constants: \x3
776 backrefs: \1 (deprecated in substitution replacements)
777 case and quoting: \U \Q \E
778 stops on @ and $, but not for $ as tail anchor
779
780 In transliterations:
781 characters are VERY literal, except for - not at the start or end
782 of the string, which indicates a range. scan_const expands the
783 range to the full set of intermediate characters.
784
785 In double-quoted strings:
786 backslashes:
787 double-quoted style: \r and \n
788 constants: \x3
789 backrefs: \1 (deprecated)
790 case and quoting: \U \Q \E
791 stops on @ and $
792
793 scan_const does *not* construct ops to handle interpolated strings.
794 It stops processing as soon as it finds an embedded $ or @ variable
795 and leaves it to the caller to work out what's going on.
796
797 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
798
799 $ in pattern could be $foo or could be tail anchor. Assumption:
800 it's a tail anchor if $ is the last thing in the string, or if it's
801 followed by one of ")| \n\t"
802
803 \1 (backreferences) are turned into $1
804
805 The structure of the code is
806 while (there's a character to process) {
807 handle transliteration ranges
808 skip regexp comments
809 skip # initiated comments in //x patterns
810 check for embedded @foo
811 check for embedded scalars
812 if (backslash) {
813 leave intact backslashes from leave (below)
814 deprecate \1 in strings and sub replacements
815 handle string-changing backslashes \l \U \Q \E, etc.
816 switch (what was escaped) {
817 handle - in a transliteration (becomes a literal -)
818 handle \132 octal characters
819 handle 0x15 hex characters
820 handle \cV (control V)
821 handle printf backslashes (\f, \r, \n, etc)
822 } (end switch)
823 } (end if backslash)
824 } (end while character to read)
825
826*/
827
8990e307 828static char *
8ac85365 829scan_const(char *start)
79072805 830{
02aa26ce
NT		 831 register char *send = bufend; /* end of the constant */
832 SV *sv = NEWSV(93, send - start); /* sv for the constant */
833 register char *s = start; /* start of the constant */
834 register char *d = SvPVX(sv); /* destination for copies */
835 bool dorange = FALSE; /* are we in a translit range? */
836 I32 len; /* ? */
837
838 /*
839 leave is the set of acceptably-backslashed characters.
840
841 I do *not* understand why there's the double hook here.
842 */
72aaf631 843 char *leaveit =
79072805 844 lex_inpat
748a9306 845 ? "\\.^$@AGZdDwWsSbB+*?|()-nrtfeaxc0123456789[{]} \t\n\r\f\v#"
79072805
LW		 846 : (lex_inwhat & OP_TRANS)
847 ? ""
848 : "";
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
NT		 1034
1035 /* ??? */
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;
1512 gv_fetchpv(tokenbuf+1, in_eval ? GV_ADDMULTI : TRUE,
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)
a0d0e21e 2851 croak("Bad name after %s::", tokenbuf);
c3e0f903 2852 len += morelen;
a0d0e21e 2853 }
8990e307 2854
3643fb5f 2855 if (expect == XOPERATOR) {
fd049845 2856 if (bufptr == linestart) {
463ee0b2
LW		 2857 curcop->cop_line--;
2858 warn(warn_nosemi);
2859 curcop->cop_line++;
2860 }
2861 else
54310121 2862 no_op("Bareword",s);
463ee0b2 2863 }
8990e307 2864
c3e0f903
GS		 2865 /* Look for a subroutine with this name in current package,
2866 unless name is "Foo::", in which case Foo is a bearword
2867 (and a package name). */
2868
2869 if (len > 2 &&
2870 tokenbuf[len - 2] == ':' && tokenbuf[len - 1] == ':')
2871 {
2872 if (dowarn && ! gv_fetchpv(tokenbuf, FALSE, SVt_PVHV))
2873 warn("Bareword \"%s\" refers to nonexistent package",
2874 tokenbuf);
2875 len -= 2;
2876 tokenbuf[len] = '\0';
2877 gv = Nullgv;
2878 gvp = 0;
2879 }
2880 else {
2881 len = 0;
2882 if (!gv)
2883 gv = gv_fetchpv(tokenbuf, FALSE, SVt_PVCV);
2884 }
2885
2886 /* if we saw a global override before, get the right name */
8990e307 2887
49dc05e3
GS		 2888 if (gvp) {
2889 sv = newSVpv("CORE::GLOBAL::",14);
2890 sv_catpv(sv,tokenbuf);
2891 }
2892 else
2893 sv = newSVpv(tokenbuf,0);
8990e307 2894
a0d0e21e
LW		 2895 /* Presume this is going to be a bareword of some sort. */
2896
2897 CLINE;
49dc05e3 2898 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
a0d0e21e
LW		 2899 yylval.opval->op_private = OPpCONST_BARE;
2900
c3e0f903
GS		 2901 /* And if "Foo::", then that's what it certainly is. */
2902
2903 if (len)
2904 goto safe_bareword;
2905
8990e307
LW		 2906 /* See if it's the indirect object for a list operator. */
2907
a0d0e21e
LW		 2908 if (oldoldbufptr &&
2909 oldoldbufptr < bufptr &&
2910 (oldoldbufptr == last_lop || oldoldbufptr == last_uni) &&
2911 /* NO SKIPSPACE BEFORE HERE! */
2912 (expect == XREF ||
4e35701f 2913 ((opargs[last_lop_op] >> OASHIFT)& 7) == OA_FILEREF) )
a0d0e21e 2914 {
748a9306
LW		 2915 bool immediate_paren = *s == '(';
2916
a0d0e21e
LW		 2917 /* (Now we can afford to cross potential line boundary.) */
2918 s = skipspace(s);
2919
2920 /* Two barewords in a row may indicate method call. */
2921
2922 if ((isALPHA(*s) || *s == '$') && (tmp=intuit_method(s,gv)))
2923 return tmp;
2924
2925 /* If not a declared subroutine, it's an indirect object. */
2926 /* (But it's an indir obj regardless for sort.) */
2927
8e07c86e 2928 if ((last_lop_op == OP_SORT ||
8ebc5c01 2929 (!immediate_paren && (!gv || !GvCVu(gv))) ) &&
8e07c86e 2930 (last_lop_op != OP_MAPSTART && last_lop_op != OP_GREPSTART)){
748a9306
LW		 2931 expect = (last_lop == oldoldbufptr) ? XTERM : XOPERATOR;
2932 goto bareword;
93a17b20
LW		 2933 }
2934 }
8990e307
LW		 2935
2936 /* If followed by a paren, it's certainly a subroutine. */
2937
2938 expect = XOPERATOR;
2939 s = skipspace(s);
93a17b20 2940 if (*s == '(') {
79072805 2941 CLINE;
96e4d5b1 2942 if (gv && GvCVu(gv)) {
2943 for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
2944 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
2945 s = d + 1;
2946 goto its_constant;
2947 }
2948 }
a0d0e21e 2949 nextval[nexttoke].opval = yylval.opval;
463ee0b2 2950 expect = XOPERATOR;
93a17b20 2951 force_next(WORD);
c07a80fd 2952 yylval.ival = 0;
463ee0b2 2953 TOKEN('&');
79072805 2954 }
93a17b20 2955
a0d0e21e 2956 /* If followed by var or block, call it a method (unless sub) */
8990e307 2957
8ebc5c01 2958 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
463ee0b2 2959 last_lop = oldbufptr;
8990e307 2960 last_lop_op = OP_METHOD;
93a17b20 2961 PREBLOCK(METHOD);
463ee0b2
LW		 2962 }
2963
8990e307
LW		 2964 /* If followed by a bareword, see if it looks like indir obj. */
2965
a0d0e21e
LW		 2966 if ((isALPHA(*s) || *s == '$') && (tmp = intuit_method(s,gv)))
2967 return tmp;
93a17b20 2968
8990e307
LW		 2969 /* Not a method, so call it a subroutine (if defined) */
2970
8ebc5c01 2971 if (gv && GvCVu(gv)) {
46fc3d4c 2972 CV* cv;
748a9306 2973 if (lastchar == '-')
c2960299 2974 warn("Ambiguous use of -%s resolved as -&%s()",
748a9306 2975 tokenbuf, tokenbuf);
8990e307 2976 last_lop = oldbufptr;
a0d0e21e 2977 last_lop_op = OP_ENTERSUB;
89bfa8cd 2978 /* Check for a constant sub */
46fc3d4c 2979 cv = GvCV(gv);
96e4d5b1 2980 if ((sv = cv_const_sv(cv))) {
2981 its_constant:
2982 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
2983 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
2984 yylval.opval->op_private = 0;
2985 TOKEN(WORD);
89bfa8cd 2986 }
2987
a5f75d66
AD		 2988 /* Resolve to GV now. */
2989 op_free(yylval.opval);
2990 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
4633a7c4
LW		 2991 /* Is there a prototype? */
2992 if (SvPOK(cv)) {
2993 STRLEN len;
2994 char *proto = SvPV((SV*)cv, len);
2995 if (!len)
2996 TERM(FUNC0SUB);
2997 if (strEQ(proto, "$"))
2998 OPERATOR(UNIOPSUB);
2999 if (*proto == '&' && *s == '{') {
3000 sv_setpv(subname,"__ANON__");
3001 PREBLOCK(LSTOPSUB);
3002 }
3003 }
a5f75d66 3004 nextval[nexttoke].opval = yylval.opval;
8990e307
LW		 3005 expect = XTERM;
3006 force_next(WORD);
3007 TOKEN(NOAMP);
3008 }
748a9306
LW		 3009
3010 if (hints & HINT_STRICT_SUBS &&
3011 lastchar != '-' &&
a0d0e21e 3012 strnNE(s,"->",2) &&
9b01e405 3013 last_lop_op != OP_TRUNCATE && /* S/F prototype in opcode.pl */
a0d0e21e
LW		 3014 last_lop_op != OP_ACCEPT &&
3015 last_lop_op != OP_PIPE_OP &&
3016 last_lop_op != OP_SOCKPAIR)
3017 {
3018 warn(
3019 "Bareword \"%s\" not allowed while \"strict subs\" in use",
85e6fe83
LW		 3020 tokenbuf);
3021 ++error_count;
3022 }
8990e307
LW		 3023
3024 /* Call it a bare word */
3025
748a9306
LW		 3026 bareword:
3027 if (dowarn) {
3028 if (lastchar != '-') {
3029 for (d = tokenbuf; *d && isLOWER(*d); d++) ;
3030 if (!*d)
3031 warn(warn_reserved, tokenbuf);
3032 }
3033 }
c3e0f903
GS		 3034
3035 safe_bareword:
748a9306
LW		 3036 if (lastchar && strchr("*%&", lastchar)) {
3037 warn("Operator or semicolon missing before %c%s",
3038 lastchar, tokenbuf);
c2960299 3039 warn("Ambiguous use of %c resolved as operator %c",
748a9306
LW		 3040 lastchar, lastchar);
3041 }
93a17b20 3042 TOKEN(WORD);
79072805 3043 }
79072805 3044
68dc0745 3045 case KEY___FILE__:
46fc3d4c 3046 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3047 newSVsv(GvSV(curcop->cop_filegv)));
3048 TERM(THING);
3049
79072805 3050 case KEY___LINE__:
46fc3d4c 3051 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3052 newSVpvf("%ld", (long)curcop->cop_line));
79072805 3053 TERM(THING);
68dc0745 3054
3055 case KEY___PACKAGE__:
3056 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3057 (curstash
3058 ? newSVsv(curstname)
3059 : &sv_undef));
79072805 3060 TERM(THING);
79072805 3061
e50aee73 3062 case KEY___DATA__:
79072805
LW		 3063 case KEY___END__: {
3064 GV *gv;
79072805
LW		 3065
3066 /*SUPPRESS 560*/
a5f75d66 3067 if (rsfp && (!in_eval || tokenbuf[2] == 'D')) {
e50aee73
AD		 3068 char *pname = "main";
3069 if (tokenbuf[2] == 'D')
3070 pname = HvNAME(curstash ? curstash : defstash);
46fc3d4c 3071 gv = gv_fetchpv(form("%s::DATA", pname), TRUE, SVt_PVIO);
a5f75d66 3072 GvMULTI_on(gv);
79072805 3073 if (!GvIO(gv))
a0d0e21e
LW		 3074 GvIOp(gv) = newIO();
3075 IoIFP(GvIOp(gv)) = rsfp;
3076#if defined(HAS_FCNTL) && defined(F_SETFD)
3077 {
760ac839 3078 int fd = PerlIO_fileno(rsfp);
a0d0e21e
LW		 3079 fcntl(fd,F_SETFD,fd >= 3);
3080 }
79072805 3081#endif
fd049845 3082 /* Mark this internal pseudo-handle as clean */
3083 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
79072805 3084 if (preprocess)
a0d0e21e 3085 IoTYPE(GvIOp(gv)) = '|';
760ac839 3086 else if ((PerlIO*)rsfp == PerlIO_stdin())
a0d0e21e 3087 IoTYPE(GvIOp(gv)) = '-';
79072805 3088 else
a0d0e21e 3089 IoTYPE(GvIOp(gv)) = '<';
79072805
LW		 3090 rsfp = Nullfp;
3091 }
3092 goto fake_eof;
e929a76b 3093 }
de3bb511 3094
8990e307 3095 case KEY_AUTOLOAD:
ed6116ce 3096 case KEY_DESTROY:
79072805
LW		 3097 case KEY_BEGIN:
3098 case KEY_END:
7d07dbc2 3099 case KEY_INIT:
a0d0e21e 3100 if (expect == XSTATE) {
93a17b20
LW		 3101 s = bufptr;
3102 goto really_sub;
79072805
LW		 3103 }
3104 goto just_a_word;
3105
a0d0e21e
LW		 3106 case KEY_CORE:
3107 if (*s == ':' && s[1] == ':') {
3108 s += 2;
748a9306 3109 d = s;
8903cb82 3110 s = scan_word(s, tokenbuf, sizeof tokenbuf, FALSE, &len);
a0d0e21e
LW		 3111 tmp = keyword(tokenbuf, len);
3112 if (tmp < 0)
3113 tmp = -tmp;
3114 goto reserved_word;
3115 }
3116 goto just_a_word;
3117
463ee0b2
LW		 3118 case KEY_abs:
3119 UNI(OP_ABS);
3120
79072805
LW		 3121 case KEY_alarm:
3122 UNI(OP_ALARM);
3123
3124 case KEY_accept:
a0d0e21e 3125 LOP(OP_ACCEPT,XTERM);
79072805 3126
463ee0b2
LW		 3127 case KEY_and:
3128 OPERATOR(ANDOP);
3129
79072805 3130 case KEY_atan2:
a0d0e21e 3131 LOP(OP_ATAN2,XTERM);
85e6fe83 3132
79072805 3133 case KEY_bind:
a0d0e21e 3134 LOP(OP_BIND,XTERM);
79072805
LW		 3135
3136 case KEY_binmode:
3137 UNI(OP_BINMODE);
3138
3139 case KEY_bless:
a0d0e21e 3140 LOP(OP_BLESS,XTERM);
79072805
LW		 3141
3142 case KEY_chop:
3143 UNI(OP_CHOP);
3144
3145 case KEY_continue:
3146 PREBLOCK(CONTINUE);
3147
3148 case KEY_chdir:
85e6fe83 3149 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
79072805
LW		 3150 UNI(OP_CHDIR);
3151
3152 case KEY_close:
3153 UNI(OP_CLOSE);
3154
3155 case KEY_closedir:
3156 UNI(OP_CLOSEDIR);
3157
3158 case KEY_cmp:
3159 Eop(OP_SCMP);
3160
3161 case KEY_caller:
3162 UNI(OP_CALLER);
3163
3164 case KEY_crypt:
3165#ifdef FCRYPT
de3bb511
LW		 3166 if (!cryptseen++)
3167 init_des();
a687059c 3168#endif
a0d0e21e 3169 LOP(OP_CRYPT,XTERM);
79072805
LW		 3170
3171 case KEY_chmod:
748a9306
LW		 3172 if (dowarn) {
3173 for (d = s; d < bufend && (isSPACE(*d) || *d == '('); d++) ;
3174 if (*d != '0' && isDIGIT(*d))
3175 yywarn("chmod: mode argument is missing initial 0");
3176 }
a0d0e21e 3177 LOP(OP_CHMOD,XTERM);
79072805
LW		 3178
3179 case KEY_chown:
a0d0e21e 3180 LOP(OP_CHOWN,XTERM);
79072805
LW		 3181
3182 case KEY_connect:
a0d0e21e 3183 LOP(OP_CONNECT,XTERM);
79072805 3184
463ee0b2
LW		 3185 case KEY_chr:
3186 UNI(OP_CHR);
3187
79072805
LW		 3188 case KEY_cos:
3189 UNI(OP_COS);
3190
3191 case KEY_chroot:
3192 UNI(OP_CHROOT);
3193
3194 case KEY_do:
3195 s = skipspace(s);
3196 if (*s == '{')
a0d0e21e 3197 PRETERMBLOCK(DO);
79072805 3198 if (*s != '\'')
a0d0e21e 3199 s = force_word(s,WORD,FALSE,TRUE,FALSE);
378cc40b 3200 OPERATOR(DO);
79072805
LW		 3201
3202 case KEY_die:
a0d0e21e
LW		 3203 hints |= HINT_BLOCK_SCOPE;
3204 LOP(OP_DIE,XTERM);
79072805
LW		 3205
3206 case KEY_defined:
3207 UNI(OP_DEFINED);
3208
3209 case KEY_delete:
a0d0e21e 3210 UNI(OP_DELETE);
79072805
LW		 3211
3212 case KEY_dbmopen:
a0d0e21e
LW		 3213 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3214 LOP(OP_DBMOPEN,XTERM);
79072805
LW		 3215
3216 case KEY_dbmclose:
3217 UNI(OP_DBMCLOSE);
3218
3219 case KEY_dump:
a0d0e21e 3220 s = force_word(s,WORD,TRUE,FALSE,FALSE);
79072805
LW		 3221 LOOPX(OP_DUMP);
3222
3223 case KEY_else:
3224 PREBLOCK(ELSE);
3225
3226 case KEY_elsif:
3227 yylval.ival = curcop->cop_line;
3228 OPERATOR(ELSIF);
3229
3230 case KEY_eq:
3231 Eop(OP_SEQ);
3232
a0d0e21e
LW		 3233 case KEY_exists:
3234 UNI(OP_EXISTS);
3235
79072805
LW		 3236 case KEY_exit:
3237 UNI(OP_EXIT);
3238
3239 case KEY_eval:
79072805 3240 s = skipspace(s);
a0d0e21e 3241 expect = (*s == '{') ? XTERMBLOCK : XTERM;
463ee0b2 3242 UNIBRACK(OP_ENTEREVAL);
79072805
LW		 3243
3244 case KEY_eof:
3245 UNI(OP_EOF);
3246
3247 case KEY_exp:
3248 UNI(OP_EXP);
3249
3250 case KEY_each:
3251 UNI(OP_EACH);
3252
3253 case KEY_exec:
3254 set_csh();
a0d0e21e 3255 LOP(OP_EXEC,XREF);
79072805
LW		 3256
3257 case KEY_endhostent:
3258 FUN0(OP_EHOSTENT);
3259
3260 case KEY_endnetent:
3261 FUN0(OP_ENETENT);
3262
3263 case KEY_endservent:
3264 FUN0(OP_ESERVENT);
3265
3266 case KEY_endprotoent:
3267 FUN0(OP_EPROTOENT);
3268
3269 case KEY_endpwent:
3270 FUN0(OP_EPWENT);
3271
3272 case KEY_endgrent:
3273 FUN0(OP_EGRENT);
3274
3275 case KEY_for:
3276 case KEY_foreach:
3277 yylval.ival = curcop->cop_line;
55497cff 3278 s = skipspace(s);
ecca16b0 3279 if (expect == XSTATE && isIDFIRST(*s)) {
55497cff 3280 char *p = s;
3281 if ((bufend - p) >= 3 &&
3282 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3283 p += 2;
3284 p = skipspace(p);
3285 if (isIDFIRST(*p))
3286 croak("Missing $ on loop variable");
3287 }
79072805
LW		 3288 OPERATOR(FOR);
3289
3290 case KEY_formline:
a0d0e21e 3291 LOP(OP_FORMLINE,XTERM);
79072805
LW		 3292
3293 case KEY_fork:
3294 FUN0(OP_FORK);
3295
3296 case KEY_fcntl:
a0d0e21e 3297 LOP(OP_FCNTL,XTERM);
79072805
LW		 3298
3299 case KEY_fileno:
3300 UNI(OP_FILENO);
3301
3302 case KEY_flock:
a0d0e21e 3303 LOP(OP_FLOCK,XTERM);
79072805
LW		 3304
3305 case KEY_gt:
3306 Rop(OP_SGT);
3307
3308 case KEY_ge:
3309 Rop(OP_SGE);
3310
3311 case KEY_grep:
a0d0e21e 3312 LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
79072805
LW		 3313
3314 case KEY_goto:
a0d0e21e 3315 s = force_word(s,WORD,TRUE,FALSE,FALSE);
79072805
LW		 3316 LOOPX(OP_GOTO);
3317
3318 case KEY_gmtime:
3319 UNI(OP_GMTIME);
3320
3321 case KEY_getc:
3322 UNI(OP_GETC);
3323
3324 case KEY_getppid:
3325 FUN0(OP_GETPPID);
3326
3327 case KEY_getpgrp:
3328 UNI(OP_GETPGRP);
3329
3330 case KEY_getpriority:
a0d0e21e 3331 LOP(OP_GETPRIORITY,XTERM);
79072805
LW		 3332
3333 case KEY_getprotobyname:
3334 UNI(OP_GPBYNAME);
3335
3336 case KEY_getprotobynumber:
a0d0e21e 3337 LOP(OP_GPBYNUMBER,XTERM);
79072805
LW		 3338
3339 case KEY_getprotoent:
3340 FUN0(OP_GPROTOENT);
3341
3342 case KEY_getpwent:
3343 FUN0(OP_GPWENT);
3344
3345 case KEY_getpwnam:
ff68c719 3346 UNI(OP_GPWNAM);
79072805
LW		 3347
3348 case KEY_getpwuid:
ff68c719 3349 UNI(OP_GPWUID);
79072805
LW		 3350
3351 case KEY_getpeername:
3352 UNI(OP_GETPEERNAME);
3353
3354 case KEY_gethostbyname:
3355 UNI(OP_GHBYNAME);
3356
3357 case KEY_gethostbyaddr:
a0d0e21e 3358 LOP(OP_GHBYADDR,XTERM);
79072805
LW		 3359
3360 case KEY_gethostent:
3361 FUN0(OP_GHOSTENT);
3362
3363 case KEY_getnetbyname:
3364 UNI(OP_GNBYNAME);
3365
3366 case KEY_getnetbyaddr:
a0d0e21e 3367 LOP(OP_GNBYADDR,XTERM);
79072805
LW		 3368
3369 case KEY_getnetent:
3370 FUN0(OP_GNETENT);
3371
3372 case KEY_getservbyname:
a0d0e21e 3373 LOP(OP_GSBYNAME,XTERM);
79072805
LW		 3374
3375 case KEY_getservbyport:
a0d0e21e 3376 LOP(OP_GSBYPORT,XTERM);
79072805
LW		 3377
3378 case KEY_getservent:
3379 FUN0(OP_GSERVENT);
3380
3381 case KEY_getsockname:
3382 UNI(OP_GETSOCKNAME);
3383
3384 case KEY_getsockopt:
a0d0e21e 3385 LOP(OP_GSOCKOPT,XTERM);
79072805
LW		 3386
3387 case KEY_getgrent:
3388 FUN0(OP_GGRENT);
3389
3390 case KEY_getgrnam:
ff68c719 3391 UNI(OP_GGRNAM);
79072805
LW		 3392
3393 case KEY_getgrgid:
ff68c719 3394 UNI(OP_GGRGID);
79072805
LW		 3395
3396 case KEY_getlogin:
3397 FUN0(OP_GETLOGIN);
3398
93a17b20 3399 case KEY_glob:
a0d0e21e
LW		 3400 set_csh();
3401 LOP(OP_GLOB,XTERM);
93a17b20 3402
79072805
LW		 3403 case KEY_hex:
3404 UNI(OP_HEX);
3405
3406 case KEY_if:
3407 yylval.ival = curcop->cop_line;
3408 OPERATOR(IF);
3409
3410 case KEY_index:
a0d0e21e 3411 LOP(OP_INDEX,XTERM);
79072805
LW		 3412
3413 case KEY_int:
3414 UNI(OP_INT);
3415
3416 case KEY_ioctl:
a0d0e21e 3417 LOP(OP_IOCTL,XTERM);
79072805
LW		 3418
3419 case KEY_join:
a0d0e21e 3420 LOP(OP_JOIN,XTERM);
79072805
LW		 3421
3422 case KEY_keys:
3423 UNI(OP_KEYS);
3424
3425 case KEY_kill:
a0d0e21e 3426 LOP(OP_KILL,XTERM);
79072805
LW		 3427
3428 case KEY_last:
a0d0e21e 3429 s = force_word(s,WORD,TRUE,FALSE,FALSE);
79072805 3430 LOOPX(OP_LAST);
a0d0e21e 3431
79072805
LW		 3432 case KEY_lc:
3433 UNI(OP_LC);
3434
3435 case KEY_lcfirst:
3436 UNI(OP_LCFIRST);
3437
3438 case KEY_local:
3439 OPERATOR(LOCAL);
3440
3441 case KEY_length:
3442 UNI(OP_LENGTH);
3443
3444 case KEY_lt:
3445 Rop(OP_SLT);
3446
3447 case KEY_le:
3448 Rop(OP_SLE);
3449
3450 case KEY_localtime:
3451 UNI(OP_LOCALTIME);
3452
3453 case KEY_log:
3454 UNI(OP_LOG);
3455
3456 case KEY_link:
a0d0e21e 3457 LOP(OP_LINK,XTERM);
79072805
LW		 3458
3459 case KEY_listen:
a0d0e21e 3460 LOP(OP_LISTEN,XTERM);
79072805 3461
c0329465
MB		 3462 case KEY_lock:
3463 UNI(OP_LOCK);
3464
79072805
LW		 3465 case KEY_lstat:
3466 UNI(OP_LSTAT);
3467
3468 case KEY_m:
3469 s = scan_pat(s);
3470 TERM(sublex_start());
3471
a0d0e21e
LW		 3472 case KEY_map:
3473 LOP(OP_MAPSTART,XREF);
3474
79072805 3475 case KEY_mkdir:
a0d0e21e 3476 LOP(OP_MKDIR,XTERM);
79072805
LW		 3477
3478 case KEY_msgctl:
a0d0e21e 3479 LOP(OP_MSGCTL,XTERM);
79072805
LW		 3480
3481 case KEY_msgget:
a0d0e21e 3482 LOP(OP_MSGGET,XTERM);
79072805
LW		 3483
3484 case KEY_msgrcv:
a0d0e21e 3485 LOP(OP_MSGRCV,XTERM);
79072805
LW		 3486
3487 case KEY_msgsnd:
a0d0e21e 3488 LOP(OP_MSGSND,XTERM);
79072805 3489
93a17b20
LW		 3490 case KEY_my:
3491 in_my = TRUE;
c750a3ec
MB		 3492 s = skipspace(s);
3493 if (isIDFIRST(*s)) {
97fcbf96 3494 s = scan_word(s, tokenbuf, sizeof tokenbuf, TRUE, &len);
c750a3ec
MB		 3495 in_my_stash = gv_stashpv(tokenbuf, FALSE);
3496 if (!in_my_stash) {
3497 char tmpbuf[1024];
3498 bufptr = s;
3499 sprintf(tmpbuf, "No such class %.1000s", tokenbuf);
3500 yyerror(tmpbuf);
3501 }
3502 }
55497cff 3503 OPERATOR(MY);
93a17b20 3504
79072805 3505 case KEY_next:
a0d0e21e 3506 s = force_word(s,WORD,TRUE,FALSE,FALSE);
79072805
LW		 3507 LOOPX(OP_NEXT);
3508
3509 case KEY_ne:
3510 Eop(OP_SNE);
3511
a0d0e21e
LW		 3512 case KEY_no:
3513 if (expect != XSTATE)
3514 yyerror("\"no\" not allowed in expression");
3515 s = force_word(s,WORD,FALSE,TRUE,FALSE);
89bfa8cd 3516 s = force_version(s);
a0d0e21e
LW		 3517 yylval.ival = 0;
3518 OPERATOR(USE);
3519
3520 case KEY_not:
3521 OPERATOR(NOTOP);
3522
79072805 3523 case KEY_open:
93a17b20
LW		 3524 s = skipspace(s);
3525 if (isIDFIRST(*s)) {
3526 char *t;
3527 for (d = s; isALNUM(*d); d++) ;
3528 t = skipspace(d);
3529 if (strchr("|&*+-=!?:.", *t))
3530 warn("Precedence problem: open %.*s should be open(%.*s)",
3531 d-s,s, d-s,s);
3532 }
a0d0e21e 3533 LOP(OP_OPEN,XTERM);
79072805 3534
463ee0b2 3535 case KEY_or:
a0d0e21e 3536 yylval.ival = OP_OR;
463ee0b2
LW		 3537 OPERATOR(OROP);
3538
79072805
LW		 3539 case KEY_ord:
3540 UNI(OP_ORD);
3541
3542 case KEY_oct:
3543 UNI(OP_OCT);
3544
3545 case KEY_opendir:
a0d0e21e 3546 LOP(OP_OPEN_DIR,XTERM);
79072805
LW		 3547
3548 case KEY_print:
3549 checkcomma(s,tokenbuf,"filehandle");
a0d0e21e 3550 LOP(OP_PRINT,XREF);
79072805
LW		 3551
3552 case KEY_printf:
3553 checkcomma(s,tokenbuf,"filehandle");
a0d0e21e 3554 LOP(OP_PRTF,XREF);
79072805 3555
c07a80fd 3556 case KEY_prototype:
3557 UNI(OP_PROTOTYPE);
3558
79072805 3559 case KEY_push:
a0d0e21e 3560 LOP(OP_PUSH,XTERM);
79072805
LW		 3561
3562 case KEY_pop:
3563 UNI(OP_POP);
3564
a0d0e21e
LW		 3565 case KEY_pos:
3566 UNI(OP_POS);
3567
79072805 3568 case KEY_pack:
a0d0e21e 3569 LOP(OP_PACK,XTERM);
79072805
LW		 3570
3571 case KEY_package:
a0d0e21e 3572 s = force_word(s,WORD,FALSE,TRUE,FALSE);
79072805
LW		 3573 OPERATOR(PACKAGE);
3574
3575 case KEY_pipe:
a0d0e21e 3576 LOP(OP_PIPE_OP,XTERM);
79072805
LW		 3577
3578 case KEY_q:
3579 s = scan_str(s);
3580 if (!s)
85e6fe83 3581 missingterm((char*)0);
79072805
LW		 3582 yylval.ival = OP_CONST;
3583 TERM(sublex_start());
3584
a0d0e21e
LW		 3585 case KEY_quotemeta:
3586 UNI(OP_QUOTEMETA);
3587
8990e307
LW		 3588 case KEY_qw:
3589 s = scan_str(s);
3590 if (!s)
85e6fe83 3591 missingterm((char*)0);
55497cff 3592 if (dowarn && SvLEN(lex_stuff)) {
3593 d = SvPV_force(lex_stuff, len);
3594 for (; len; --len, ++d) {
3595 if (*d == ',') {
3596 warn("Possible attempt to separate words with commas");
3597 break;
3598 }
3599 if (*d == '#') {
3600 warn("Possible attempt to put comments in qw() list");
3601 break;
3602 }
3603 }
3604 }
8990e307
LW		 3605 force_next(')');
3606 nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, q(lex_stuff));
3607 lex_stuff = Nullsv;
3608 force_next(THING);
3609 force_next(',');
3610 nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(" ",1));
3611 force_next(THING);
3612 force_next('(');
a0d0e21e
LW		 3613 yylval.ival = OP_SPLIT;
3614 CLINE;
3615 expect = XTERM;
3616 bufptr = s;
3617 last_lop = oldbufptr;
3618 last_lop_op = OP_SPLIT;
3619 return FUNC;
8990e307 3620
79072805
LW		 3621 case KEY_qq:
3622 s = scan_str(s);
3623 if (!s)
85e6fe83 3624 missingterm((char*)0);
a0d0e21e 3625 yylval.ival = OP_STRINGIFY;
ed6116ce
LW		 3626 if (SvIVX(lex_stuff) == '\'')
3627 SvIVX(lex_stuff) = 0; /* qq'$foo' should intepolate */
79072805
LW		 3628 TERM(sublex_start());
3629
3630 case KEY_qx:
3631 s = scan_str(s);
3632 if (!s)
85e6fe83 3633 missingterm((char*)0);
79072805
LW		 3634 yylval.ival = OP_BACKTICK;
3635 set_csh();
3636 TERM(sublex_start());
3637
3638 case KEY_return:
3639 OLDLOP(OP_RETURN);
3640
3641 case KEY_require:
748a9306 3642 *tokenbuf = '\0';
a0d0e21e 3643 s = force_word(s,WORD,TRUE,TRUE,FALSE);
748a9306 3644 if (isIDFIRST(*tokenbuf))
89bfa8cd 3645 gv_stashpvn(tokenbuf, strlen(tokenbuf), TRUE);
748a9306 3646 else if (*s == '<')
a0d0e21e 3647 yyerror("<> should be quotes");
463ee0b2 3648 UNI(OP_REQUIRE);
79072805
LW		 3649
3650 case KEY_reset:
3651 UNI(OP_RESET);
3652
3653 case KEY_redo:
a0d0e21e 3654 s = force_word(s,WORD,TRUE,FALSE,FALSE);
79072805
LW		 3655 LOOPX(OP_REDO);
3656
3657 case KEY_rename:
a0d0e21e 3658 LOP(OP_RENAME,XTERM);
79072805
LW		 3659
3660 case KEY_rand:
3661 UNI(OP_RAND);
3662
3663 case KEY_rmdir:
3664 UNI(OP_RMDIR);
3665
3666 case KEY_rindex:
a0d0e21e 3667 LOP(OP_RINDEX,XTERM);
79072805
LW		 3668
3669 case KEY_read:
a0d0e21e 3670 LOP(OP_READ,XTERM);
79072805
LW		 3671
3672 case KEY_readdir:
3673 UNI(OP_READDIR);
3674
93a17b20
LW		 3675 case KEY_readline:
3676 set_csh();
3677 UNI(OP_READLINE);
3678
3679 case KEY_readpipe:
3680 set_csh();
3681 UNI(OP_BACKTICK);
3682
79072805
LW		 3683 case KEY_rewinddir:
3684 UNI(OP_REWINDDIR);
3685
3686 case KEY_recv:
a0d0e21e 3687 LOP(OP_RECV,XTERM);
79072805
LW		 3688
3689 case KEY_reverse:
a0d0e21e 3690 LOP(OP_REVERSE,XTERM);
79072805
LW		 3691
3692 case KEY_readlink:
3693 UNI(OP_READLINK);
3694
3695 case KEY_ref:
3696 UNI(OP_REF);
3697
3698 case KEY_s:
3699 s = scan_subst(s);
3700 if (yylval.opval)
3701 TERM(sublex_start());
3702 else
3703 TOKEN(1); /* force error */
3704
a0d0e21e
LW		 3705 case KEY_chomp:
3706 UNI(OP_CHOMP);
3707
79072805
LW		 3708 case KEY_scalar:
3709 UNI(OP_SCALAR);
3710
3711 case KEY_select:
a0d0e21e 3712 LOP(OP_SELECT,XTERM);
79072805
LW		 3713
3714 case KEY_seek:
a0d0e21e 3715 LOP(OP_SEEK,XTERM);
79072805
LW		 3716
3717 case KEY_semctl:
a0d0e21e 3718 LOP(OP_SEMCTL,XTERM);
79072805
LW		 3719
3720 case KEY_semget:
a0d0e21e 3721 LOP(OP_SEMGET,XTERM);
79072805
LW		 3722
3723 case KEY_semop:
a0d0e21e 3724 LOP(OP_SEMOP,XTERM);
79072805
LW		 3725
3726 case KEY_send:
a0d0e21e 3727 LOP(OP_SEND,XTERM);
79072805
LW		 3728
3729 case KEY_setpgrp:
a0d0e21e 3730 LOP(OP_SETPGRP,XTERM);
79072805
LW		 3731
3732 case KEY_setpriority:
a0d0e21e 3733 LOP(OP_SETPRIORITY,XTERM);
79072805
LW		 3734
3735 case KEY_sethostent:
ff68c719 3736 UNI(OP_SHOSTENT);
79072805
LW		 3737
3738 case KEY_setnetent:
ff68c719 3739 UNI(OP_SNETENT);
79072805
LW		 3740
3741 case KEY_setservent:
ff68c719 3742 UNI(OP_SSERVENT);
79072805
LW		 3743
3744 case KEY_setprotoent:
ff68c719 3745 UNI(OP_SPROTOENT);
79072805
LW		 3746
3747 case KEY_setpwent:
3748 FUN0(OP_SPWENT);
3749
3750 case KEY_setgrent:
3751 FUN0(OP_SGRENT);
3752
3753 case KEY_seekdir:
a0d0e21e 3754 LOP(OP_SEEKDIR,XTERM);
79072805
LW		 3755
3756 case KEY_setsockopt:
a0d0e21e 3757 LOP(OP_SSOCKOPT,XTERM);
79072805
LW		 3758
3759 case KEY_shift:
3760 UNI(OP_SHIFT);
3761
3762 case KEY_shmctl:
a0d0e21e 3763 LOP(OP_SHMCTL,XTERM);
79072805
LW		 3764
3765 case KEY_shmget:
a0d0e21e 3766 LOP(OP_SHMGET,XTERM);
79072805
LW		 3767
3768 case KEY_shmread:
a0d0e21e 3769 LOP(OP_SHMREAD,XTERM);
79072805
LW		 3770
3771 case KEY_shmwrite:
a0d0e21e 3772 LOP(OP_SHMWRITE,XTERM);
79072805
LW		 3773
3774 case KEY_shutdown:
a0d0e21e 3775 LOP(OP_SHUTDOWN,XTERM);
79072805
LW		 3776
3777 case KEY_sin:
3778 UNI(OP_SIN);
3779
3780 case KEY_sleep:
3781 UNI(OP_SLEEP);
3782
3783 case KEY_socket:
a0d0e21e 3784 LOP(OP_SOCKET,XTERM);
79072805
LW		 3785
3786 case KEY_socketpair:
a0d0e21e 3787 LOP(OP_SOCKPAIR,XTERM);
79072805
LW		 3788
3789 case KEY_sort:
3790 checkcomma(s,tokenbuf,"subroutine name");
3791 s = skipspace(s);
3792 if (*s == ';' || *s == ')') /* probably a close */
463ee0b2
LW		 3793 croak("sort is now a reserved word");
3794 expect = XTERM;
15f0808c 3795 s = force_word(s,WORD,TRUE,TRUE,FALSE);
a0d0e21e 3796 LOP(OP_SORT,XREF);
79072805
LW		 3797
3798 case KEY_split:
a0d0e21e 3799 LOP(OP_SPLIT,XTERM);
79072805
LW		 3800
3801 case KEY_sprintf:
a0d0e21e 3802 LOP(OP_SPRINTF,XTERM);
79072805
LW		 3803
3804 case KEY_splice:
a0d0e21e 3805 LOP(OP_SPLICE,XTERM);
79072805
LW		 3806
3807 case KEY_sqrt:
3808 UNI(OP_SQRT);
3809
3810 case KEY_srand:
3811 UNI(OP_SRAND);
3812
3813 case KEY_stat:
3814 UNI(OP_STAT);
3815
3816 case KEY_study:
3817 sawstudy++;
3818 UNI(OP_STUDY);
3819
3820 case KEY_substr:
a0d0e21e 3821 LOP(OP_SUBSTR,XTERM);
79072805
LW		 3822
3823 case KEY_format:
3824 case KEY_sub:
93a17b20 3825 really_sub:
79072805 3826 s = skipspace(s);
4633a7c4 3827
463ee0b2 3828 if (isIDFIRST(*s) || *s == '\'' || *s == ':') {
8903cb82 3829 char tmpbuf[sizeof tokenbuf];
4633a7c4 3830 expect = XBLOCK;
8903cb82 3831 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
463ee0b2
LW		 3832 if (strchr(tmpbuf, ':'))
3833 sv_setpv(subname, tmpbuf);
3834 else {
3835 sv_setsv(subname,curstname);
8990e307 3836 sv_catpvn(subname,"::",2);
463ee0b2
LW		 3837 sv_catpvn(subname,tmpbuf,len);
3838 }
a0d0e21e 3839 s = force_word(s,WORD,FALSE,TRUE,TRUE);
4633a7c4 3840 s = skipspace(s);
79072805 3841 }
4633a7c4
LW		 3842 else {
3843 expect = XTERMBLOCK;
79072805 3844 sv_setpv(subname,"?");
4633a7c4
LW		 3845 }
3846
3847 if (tmp == KEY_format) {
3848 s = skipspace(s);
3849 if (*s == '=')
3850 lex_formbrack = lex_brackets + 1;
3851 OPERATOR(FORMAT);
3852 }
79072805 3853
4633a7c4
LW		 3854 /* Look for a prototype */
3855 if (*s == '(') {
68dc0745 3856 char *p;
3857
4633a7c4
LW		 3858 s = scan_str(s);
3859 if (!s) {
3860 if (lex_stuff)
3861 SvREFCNT_dec(lex_stuff);
3862 lex_stuff = Nullsv;
3863 croak("Prototype not terminated");
3864 }
68dc0745 3865 /* strip spaces */
3866 d = SvPVX(lex_stuff);
3867 tmp = 0;
3868 for (p = d; *p; ++p) {
3869 if (!isSPACE(*p))
3870 d[tmp++] = *p;
3871 }
3872 d[tmp] = '\0';
3873 SvCUR(lex_stuff) = tmp;
3874
4633a7c4
LW		 3875 nexttoke++;
3876 nextval[1] = nextval[0];
3877 nexttype[1] = nexttype[0];
3878 nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, lex_stuff);
3879 nexttype[0] = THING;
3880 if (nexttoke == 1) {
3881 lex_defer = lex_state;
3882 lex_expect = expect;
3883 lex_state = LEX_KNOWNEXT;
3884 }
3885 lex_stuff = Nullsv;
3886 }
79072805 3887
4633a7c4
LW		 3888 if (*SvPV(subname,na) == '?') {
3889 sv_setpv(subname,"__ANON__");
3890 TOKEN(ANONSUB);
3891 }
3892 PREBLOCK(SUB);
79072805
LW		 3893
3894 case KEY_system:
3895 set_csh();
a0d0e21e 3896 LOP(OP_SYSTEM,XREF);
79072805
LW		 3897
3898 case KEY_symlink:
a0d0e21e 3899 LOP(OP_SYMLINK,XTERM);
79072805
LW		 3900
3901 case KEY_syscall:
a0d0e21e 3902 LOP(OP_SYSCALL,XTERM);
79072805 3903
c07a80fd 3904 case KEY_sysopen:
3905 LOP(OP_SYSOPEN,XTERM);
3906
137443ea 3907 case KEY_sysseek:
3908 LOP(OP_SYSSEEK,XTERM);
3909
79072805 3910 case KEY_sysread:
a0d0e21e 3911 LOP(OP_SYSREAD,XTERM);
79072805
LW		 3912
3913 case KEY_syswrite:
a0d0e21e 3914 LOP(OP_SYSWRITE,XTERM);
79072805
LW		 3915
3916 case KEY_tr:
3917 s = scan_trans(s);
3918 TERM(sublex_start());
3919
3920 case KEY_tell:
3921 UNI(OP_TELL);
3922
3923 case KEY_telldir:
3924 UNI(OP_TELLDIR);
3925
463ee0b2 3926 case KEY_tie:
a0d0e21e 3927 LOP(OP_TIE,XTERM);
463ee0b2 3928
c07a80fd 3929 case KEY_tied:
3930 UNI(OP_TIED);
3931
79072805
LW		 3932 case KEY_time:
3933 FUN0(OP_TIME);
3934
3935 case KEY_times:
3936 FUN0(OP_TMS);
3937
3938 case KEY_truncate:
a0d0e21e 3939 LOP(OP_TRUNCATE,XTERM);
79072805
LW		 3940
3941 case KEY_uc:
3942 UNI(OP_UC);
3943
3944 case KEY_ucfirst:
3945 UNI(OP_UCFIRST);
3946
463ee0b2
LW		 3947 case KEY_untie:
3948 UNI(OP_UNTIE);
3949
79072805
LW		 3950 case KEY_until:
3951 yylval.ival = curcop->cop_line;
3952 OPERATOR(UNTIL);
3953
3954 case KEY_unless:
3955 yylval.ival = curcop->cop_line;
3956 OPERATOR(UNLESS);
3957
3958 case KEY_unlink:
a0d0e21e 3959 LOP(OP_UNLINK,XTERM);
79072805
LW		 3960
3961 case KEY_undef:
3962 UNI(OP_UNDEF);
3963
3964 case KEY_unpack:
a0d0e21e 3965 LOP(OP_UNPACK,XTERM);
79072805
LW		 3966
3967 case KEY_utime:
a0d0e21e 3968 LOP(OP_UTIME,XTERM);
79072805
LW		 3969
3970 case KEY_umask:
748a9306
LW		 3971 if (dowarn) {
3972 for (d = s; d < bufend && (isSPACE(*d) || *d == '('); d++) ;
3973 if (*d != '0' && isDIGIT(*d))
3974 yywarn("umask: argument is missing initial 0");
3975 }
79072805
LW		 3976 UNI(OP_UMASK);
3977
3978 case KEY_unshift:
a0d0e21e
LW		 3979 LOP(OP_UNSHIFT,XTERM);
3980
3981 case KEY_use:
3982 if (expect != XSTATE)
3983 yyerror("\"use\" not allowed in expression");
89bfa8cd 3984 s = skipspace(s);
3985 if(isDIGIT(*s)) {
3986 s = force_version(s);
3987 if(*s == ';' || (s = skipspace(s), *s == ';')) {
3988 nextval[nexttoke].opval = Nullop;
3989 force_next(WORD);
3990 }
3991 }
3992 else {
3993 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3994 s = force_version(s);
3995 }
a0d0e21e
LW		 3996 yylval.ival = 1;
3997 OPERATOR(USE);
79072805
LW		 3998
3999 case KEY_values:
4000 UNI(OP_VALUES);
4001
4002 case KEY_vec:
4003 sawvec = TRUE;
a0d0e21e 4004 LOP(OP_VEC,XTERM);
79072805
LW		 4005
4006 case KEY_while:
4007 yylval.ival = curcop->cop_line;
4008 OPERATOR(WHILE);
4009
4010 case KEY_warn:
a0d0e21e
LW		 4011 hints |= HINT_BLOCK_SCOPE;
4012 LOP(OP_WARN,XTERM);
79072805
LW		 4013
4014 case KEY_wait:
4015 FUN0(OP_WAIT);
4016
4017 case KEY_waitpid:
a0d0e21e 4018 LOP(OP_WAITPID,XTERM);
79072805
LW		 4019
4020 case KEY_wantarray:
4021 FUN0(OP_WANTARRAY);
4022
4023 case KEY_write:
85e6fe83 4024 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
79072805
LW		 4025 UNI(OP_ENTERWRITE);
4026
4027 case KEY_x:
4028 if (expect == XOPERATOR)
4029 Mop(OP_REPEAT);
4030 check_uni();
4031 goto just_a_word;
4032
a0d0e21e
LW		 4033 case KEY_xor:
4034 yylval.ival = OP_XOR;
4035 OPERATOR(OROP);
4036
79072805
LW		 4037 case KEY_y:
4038 s = scan_trans(s);
4039 TERM(sublex_start());
4040 }
49dc05e3 4041 }}
79072805
LW		 4042}
4043
4044I32
8ac85365 4045keyword(register char *d, I32 len)
79072805
LW		 4046{
4047 switch (*d) {
4048 case '_':
4049 if (d[1] == '_') {
a0d0e21e 4050 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
68dc0745 4051 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
4052 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
e50aee73 4053 if (strEQ(d,"__DATA__")) return KEY___DATA__;
79072805
LW		 4054 if (strEQ(d,"__END__")) return KEY___END__;
4055 }
4056 break;
8990e307
LW		 4057 case 'A':
4058 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
4059 break;
79072805 4060 case 'a':
463ee0b2
LW		 4061 switch (len) {
4062 case 3:
a0d0e21e
LW		 4063 if (strEQ(d,"and")) return -KEY_and;
4064 if (strEQ(d,"abs")) return -KEY_abs;
85e6fe83 4065 break;
463ee0b2 4066 case 5:
a0d0e21e
LW		 4067 if (strEQ(d,"alarm")) return -KEY_alarm;
4068 if (strEQ(d,"atan2")) return -KEY_atan2;
463ee0b2
LW		 4069 break;
4070 case 6:
a0d0e21e 4071 if (strEQ(d,"accept")) return -KEY_accept;
463ee0b2
LW		 4072 break;
4073 }
79072805
LW		 4074 break;
4075 case 'B':
4076 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
93a17b20 4077 break;
79072805 4078 case 'b':
a0d0e21e
LW		 4079 if (strEQ(d,"bless")) return -KEY_bless;
4080 if (strEQ(d,"bind")) return -KEY_bind;
4081 if (strEQ(d,"binmode")) return -KEY_binmode;
4082 break;
4083 case 'C':
4084 if (strEQ(d,"CORE")) return -KEY_CORE;
79072805
LW		 4085 break;
4086 case 'c':
4087 switch (len) {
4088 case 3:
a0d0e21e
LW		 4089 if (strEQ(d,"cmp")) return -KEY_cmp;
4090 if (strEQ(d,"chr")) return -KEY_chr;
4091 if (strEQ(d,"cos")) return -KEY_cos;
79072805
LW		 4092 break;
4093 case 4:
4094 if (strEQ(d,"chop")) return KEY_chop;
4095 break;
4096 case 5:
a0d0e21e
LW		 4097 if (strEQ(d,"close")) return -KEY_close;
4098 if (strEQ(d,"chdir")) return -KEY_chdir;
4099 if (strEQ(d,"chomp")) return KEY_chomp;
4100 if (strEQ(d,"chmod")) return -KEY_chmod;
4101 if (strEQ(d,"chown")) return -KEY_chown;
4102 if (strEQ(d,"crypt")) return -KEY_crypt;
79072805
LW		 4103 break;
4104 case 6:
a0d0e21e
LW		 4105 if (strEQ(d,"chroot")) return -KEY_chroot;
4106 if (strEQ(d,"caller")) return -KEY_caller;
79072805
LW		 4107 break;
4108 case 7:
a0d0e21e 4109 if (strEQ(d,"connect")) return -KEY_connect;
79072805
LW		 4110 break;
4111 case 8:
a0d0e21e
LW		 4112 if (strEQ(d,"closedir")) return -KEY_closedir;
4113 if (strEQ(d,"continue")) return -KEY_continue;
79072805
LW		 4114 break;
4115 }
4116 break;
ed6116ce
LW		 4117 case 'D':
4118 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
4119 break;
79072805
LW		 4120 case 'd':
4121 switch (len) {
4122 case 2:
4123 if (strEQ(d,"do")) return KEY_do;
4124 break;
4125 case 3:
a0d0e21e 4126 if (strEQ(d,"die")) return -KEY_die;
79072805
LW		 4127 break;
4128 case 4:
a0d0e21e 4129 if (strEQ(d,"dump")) return -KEY_dump;
79072805
LW		 4130 break;
4131 case 6:
4132 if (strEQ(d,"delete")) return KEY_delete;
4133 break;
4134 case 7:
4135 if (strEQ(d,"defined")) return KEY_defined;
a0d0e21e 4136 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
79072805
LW		 4137 break;
4138 case 8:
a0d0e21e 4139 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
79072805
LW		 4140 break;
4141 }
4142 break;
4143 case 'E':
a0d0e21e 4144 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
79072805
LW		 4145 if (strEQ(d,"END")) return KEY_END;
4146 break;
4147 case 'e':
4148 switch (len) {
4149 case 2:
a0d0e21e 4150 if (strEQ(d,"eq")) return -KEY_eq;
79072805
LW		 4151 break;
4152 case 3:
a0d0e21e
LW		 4153 if (strEQ(d,"eof")) return -KEY_eof;
4154 if (strEQ(d,"exp")) return -KEY_exp;
79072805
LW		 4155 break;
4156 case 4:
4157 if (strEQ(d,"else")) return KEY_else;
a0d0e21e 4158 if (strEQ(d,"exit")) return -KEY_exit;
79072805 4159 if (strEQ(d,"eval")) return KEY_eval;
a0d0e21e 4160 if (strEQ(d,"exec")) return -KEY_exec;
79072805
LW		 4161 if (strEQ(d,"each")) return KEY_each;
4162 break;
4163 case 5:
4164 if (strEQ(d,"elsif")) return KEY_elsif;
4165 break;
a0d0e21e
LW		 4166 case 6:
4167 if (strEQ(d,"exists")) return KEY_exists;
4633a7c4 4168 if (strEQ(d,"elseif")) warn("elseif should be elsif");
a0d0e21e 4169 break;
79072805 4170 case 8:
a0d0e21e
LW		 4171 if (strEQ(d,"endgrent")) return -KEY_endgrent;
4172 if (strEQ(d,"endpwent")) return -KEY_endpwent;
79072805
LW		 4173 break;
4174 case 9:
a0d0e21e 4175 if (strEQ(d,"endnetent")) return -KEY_endnetent;
79072805
LW		 4176 break;
4177 case 10:
a0d0e21e
LW		 4178 if (strEQ(d,"endhostent")) return -KEY_endhostent;
4179 if (strEQ(d,"endservent")) return -KEY_endservent;
79072805
LW		 4180 break;
4181 case 11:
a0d0e21e 4182 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
79072805 4183 break;
a687059c 4184 }
a687059c 4185 break;
79072805
LW		 4186 case 'f':
4187 switch (len) {
4188 case 3:
4189 if (strEQ(d,"for")) return KEY_for;
4190 break;
4191 case 4:
a0d0e21e 4192 if (strEQ(d,"fork")) return -KEY_fork;
79072805
LW		 4193 break;
4194 case 5:
a0d0e21e
LW		 4195 if (strEQ(d,"fcntl")) return -KEY_fcntl;
4196 if (strEQ(d,"flock")) return -KEY_flock;
79072805
LW		 4197 break;
4198 case 6:
4199 if (strEQ(d,"format")) return KEY_format;
a0d0e21e 4200 if (strEQ(d,"fileno")) return -KEY_fileno;
79072805
LW		 4201 break;
4202 case 7:
4203 if (strEQ(d,"foreach")) return KEY_foreach;
4204 break;
4205 case 8:
a0d0e21e 4206 if (strEQ(d,"formline")) return -KEY_formline;
79072805 4207 break;
378cc40b 4208 }
a687059c 4209 break;
79072805
LW		 4210 case 'G':
4211 if (len == 2) {
a0d0e21e
LW		 4212 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
4213 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
9f68db38 4214 }
a687059c 4215 break;
79072805 4216 case 'g':
a687059c
LW		 4217 if (strnEQ(d,"get",3)) {
4218 d += 3;
4219 if (*d == 'p') {
79072805
LW		 4220 switch (len) {
4221 case 7:
a0d0e21e
LW		 4222 if (strEQ(d,"ppid")) return -KEY_getppid;
4223 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
79072805
LW		 4224 break;
4225 case 8:
a0d0e21e
LW		 4226 if (strEQ(d,"pwent")) return -KEY_getpwent;
4227 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
4228 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
79072805
LW		 4229 break;
4230 case 11:
a0d0e21e
LW		 4231 if (strEQ(d,"peername")) return -KEY_getpeername;
4232 if (strEQ(d,"protoent")) return -KEY_getprotoent;
4233 if (strEQ(d,"priority")) return -KEY_getpriority;
79072805
LW		 4234 break;
4235 case 14:
a0d0e21e 4236 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
79072805
LW		 4237 break;
4238 case 16:
a0d0e21e 4239 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
79072805
LW		 4240 break;
4241 }
a687059c
LW		 4242 }
4243 else if (*d == 'h') {
a0d0e21e
LW		 4244 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
4245 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
4246 if (strEQ(d,"hostent")) return -KEY_gethostent;
a687059c
LW		 4247 }
4248 else if (*d == 'n') {
a0d0e21e
LW		 4249 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
4250 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
4251 if (strEQ(d,"netent")) return -KEY_getnetent;
a687059c
LW		 4252 }
4253 else if (*d == 's') {
a0d0e21e
LW		 4254 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
4255 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
4256 if (strEQ(d,"servent")) return -KEY_getservent;
4257 if (strEQ(d,"sockname")) return -KEY_getsockname;
4258 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
a687059c
LW		 4259 }
4260 else if (*d == 'g') {
a0d0e21e
LW		 4261 if (strEQ(d,"grent")) return -KEY_getgrent;
4262 if (strEQ(d,"grnam")) return -KEY_getgrnam;
4263 if (strEQ(d,"grgid")) return -KEY_getgrgid;
a687059c
LW		 4264 }
4265 else if (*d == 'l') {
a0d0e21e 4266 if (strEQ(d,"login")) return -KEY_getlogin;
a687059c 4267 }
a0d0e21e 4268 else if (strEQ(d,"c")) return -KEY_getc;
79072805 4269 break;
a687059c 4270 }
79072805
LW		 4271 switch (len) {
4272 case 2:
a0d0e21e
LW		 4273 if (strEQ(d,"gt")) return -KEY_gt;
4274 if (strEQ(d,"ge")) return -KEY_ge;
79072805
LW		 4275 break;
4276 case 4:
4277 if (strEQ(d,"grep")) return KEY_grep;
4278 if (strEQ(d,"goto")) return KEY_goto;
fb73857a 4279 if (strEQ(d,"glob")) return KEY_glob;
79072805
LW		 4280 break;
4281 case 6:
a0d0e21e 4282 if (strEQ(d,"gmtime")) return -KEY_gmtime;
79072805 4283 break;
378cc40b 4284 }
a687059c 4285 break;
79072805 4286 case 'h':
a0d0e21e 4287 if (strEQ(d,"hex")) return -KEY_hex;
a687059c 4288 break;
7d07dbc2
MB		 4289 case 'I':
4290 if (strEQ(d,"INIT")) return KEY_INIT;
4291 break;
79072805
LW		 4292 case 'i':
4293 switch (len) {
4294 case 2:
4295 if (strEQ(d,"if")) return KEY_if;
4296 break;
4297 case 3:
a0d0e21e 4298 if (strEQ(d,"int")) return -KEY_int;
79072805
LW		 4299 break;
4300 case 5:
a0d0e21e
LW		 4301 if (strEQ(d,"index")) return -KEY_index;
4302 if (strEQ(d,"ioctl")) return -KEY_ioctl;
79072805
LW		 4303 break;
4304 }
a687059c 4305 break;
79072805 4306 case 'j':
a0d0e21e 4307 if (strEQ(d,"join")) return -KEY_join;
a687059c 4308 break;
79072805
LW		 4309 case 'k':
4310 if (len == 4) {
4311 if (strEQ(d,"keys")) return KEY_keys;
a0d0e21e 4312 if (strEQ(d,"kill")) return -KEY_kill;
663a0e37 4313 }
79072805
LW		 4314 break;
4315 case 'L':
4316 if (len == 2) {
a0d0e21e
LW		 4317 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
4318 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
378cc40b 4319 }
79072805
LW		 4320 break;
4321 case 'l':
4322 switch (len) {
4323 case 2:
a0d0e21e
LW		 4324 if (strEQ(d,"lt")) return -KEY_lt;
4325 if (strEQ(d,"le")) return -KEY_le;
4326 if (strEQ(d,"lc")) return -KEY_lc;
79072805
LW		 4327 break;
4328 case 3:
a0d0e21e 4329 if (strEQ(d,"log")) return -KEY_log;
79072805
LW		 4330 break;
4331 case 4:
4332 if (strEQ(d,"last")) return KEY_last;
a0d0e21e 4333 if (strEQ(d,"link")) return -KEY_link;
c0329465 4334 if (strEQ(d,"lock")) return -KEY_lock;
395c3793 4335 break;
79072805
LW		 4336 case 5:
4337 if (strEQ(d,"local")) return KEY_local;
a0d0e21e 4338 if (strEQ(d,"lstat")) return -KEY_lstat;
79072805
LW		 4339 break;
4340 case 6:
a0d0e21e
LW		 4341 if (strEQ(d,"length")) return -KEY_length;
4342 if (strEQ(d,"listen")) return -KEY_listen;
79072805
LW		 4343 break;
4344 case 7:
a0d0e21e 4345 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
79072805
LW		 4346 break;
4347 case 9:
a0d0e21e 4348 if (strEQ(d,"localtime")) return -KEY_localtime;
395c3793
LW		 4349 break;
4350 }
a687059c 4351 break;
79072805
LW		 4352 case 'm':
4353 switch (len) {
4354 case 1: return KEY_m;
93a17b20
LW		 4355 case 2:
4356 if (strEQ(d,"my")) return KEY_my;
4357 break;
a0d0e21e
LW		 4358 case 3:
4359 if (strEQ(d,"map")) return KEY_map;
4360 break;
79072805 4361 case 5:
a0d0e21e 4362 if (strEQ(d,"mkdir")) return -KEY_mkdir;
79072805
LW		 4363 break;
4364 case 6:
a0d0e21e
LW		 4365 if (strEQ(d,"msgctl")) return -KEY_msgctl;
4366 if (strEQ(d,"msgget")) return -KEY_msgget;
4367 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
4368 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
79072805
LW		 4369 break;
4370 }
a687059c 4371 break;
79072805 4372 case 'N':
a0d0e21e 4373 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
a687059c 4374 break;
79072805
LW		 4375 case 'n':
4376 if (strEQ(d,"next")) return KEY_next;
a0d0e21e
LW		 4377 if (strEQ(d,"ne")) return -KEY_ne;
4378 if (strEQ(d,"not")) return -KEY_not;
4379 if (strEQ(d,"no")) return KEY_no;
a687059c 4380 break;
79072805
LW		 4381 case 'o':
4382 switch (len) {
463ee0b2 4383 case 2:
a0d0e21e 4384 if (strEQ(d,"or")) return -KEY_or;
463ee0b2 4385 break;
79072805 4386 case 3:
a0d0e21e
LW		 4387 if (strEQ(d,"ord")) return -KEY_ord;
4388 if (strEQ(d,"oct")) return -KEY_oct;
79072805
LW		 4389 break;
4390 case 4:
a0d0e21e 4391 if (strEQ(d,"open")) return -KEY_open;
79072805
LW		 4392 break;
4393 case 7:
a0d0e21e 4394 if (strEQ(d,"opendir")) return -KEY_opendir;
79072805 4395 break;
fe14fcc3 4396 }
a687059c 4397 break;
79072805
LW		 4398 case 'p':
4399 switch (len) {
4400 case 3:
4401 if (strEQ(d,"pop")) return KEY_pop;
a0d0e21e 4402 if (strEQ(d,"pos")) return KEY_pos;
79072805
LW		 4403 break;
4404 case 4:
4405 if (strEQ(d,"push")) return KEY_push;
a0d0e21e
LW		 4406 if (strEQ(d,"pack")) return -KEY_pack;
4407 if (strEQ(d,"pipe")) return -KEY_pipe;
79072805
LW		 4408 break;
4409 case 5:
4410 if (strEQ(d,"print")) return KEY_print;
4411 break;
4412 case 6:
4413 if (strEQ(d,"printf")) return KEY_printf;
4414 break;
4415 case 7:
4416 if (strEQ(d,"package")) return KEY_package;
4417 break;
c07a80fd 4418 case 9:
4419 if (strEQ(d,"prototype")) return KEY_prototype;
663a0e37 4420 }
79072805
LW		 4421 break;
4422 case 'q':
4423 if (len <= 2) {
4424 if (strEQ(d,"q")) return KEY_q;
4425 if (strEQ(d,"qq")) return KEY_qq;
8990e307 4426 if (strEQ(d,"qw")) return KEY_qw;
79072805 4427 if (strEQ(d,"qx")) return KEY_qx;
663a0e37 4428 }
a0d0e21e 4429 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
79072805
LW		 4430 break;
4431 case 'r':
4432 switch (len) {
4433 case 3:
a0d0e21e 4434 if (strEQ(d,"ref")) return -KEY_ref;
79072805
LW		 4435 break;
4436 case 4:
a0d0e21e
LW		 4437 if (strEQ(d,"read")) return -KEY_read;
4438 if (strEQ(d,"rand")) return -KEY_rand;
4439 if (strEQ(d,"recv")) return -KEY_recv;
79072805
LW		 4440 if (strEQ(d,"redo")) return KEY_redo;
4441 break;
4442 case 5:
a0d0e21e
LW		 4443 if (strEQ(d,"rmdir")) return -KEY_rmdir;
4444 if (strEQ(d,"reset")) return -KEY_reset;
79072805
LW		 4445 break;
4446 case 6:
4447 if (strEQ(d,"return")) return KEY_return;
a0d0e21e
LW		 4448 if (strEQ(d,"rename")) return -KEY_rename;
4449 if (strEQ(d,"rindex")) return -KEY_rindex;
79072805
LW		 4450 break;
4451 case 7:
a0d0e21e
LW		 4452 if (strEQ(d,"require")) return -KEY_require;
4453 if (strEQ(d,"reverse")) return -KEY_reverse;
4454 if (strEQ(d,"readdir")) return -KEY_readdir;
79072805
LW		 4455 break;
4456 case 8:
a0d0e21e
LW		 4457 if (strEQ(d,"readlink")) return -KEY_readlink;
4458 if (strEQ(d,"readline")) return -KEY_readline;
4459 if (strEQ(d,"readpipe")) return -KEY_readpipe;
79072805
LW		 4460 break;
4461 case 9:
a0d0e21e 4462 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
79072805 4463 break;
a687059c 4464 }
79072805
LW		 4465 break;
4466 case 's':
a687059c 4467 switch (d[1]) {
79072805 4468 case 0: return KEY_s;
a687059c 4469 case 'c':
79072805 4470 if (strEQ(d,"scalar")) return KEY_scalar;
a687059c
LW		 4471 break;
4472 case 'e':
79072805
LW		 4473 switch (len) {
4474 case 4:
a0d0e21e
LW		 4475 if (strEQ(d,"seek")) return -KEY_seek;
4476 if (strEQ(d,"send")) return -KEY_send;
79072805
LW		 4477 break;
4478 case 5:
a0d0e21e 4479 if (strEQ(d,"semop")) return -KEY_semop;
79072805
LW		 4480 break;
4481 case 6:
a0d0e21e
LW		 4482 if (strEQ(d,"select")) return -KEY_select;
4483 if (strEQ(d,"semctl")) return -KEY_semctl;
4484 if (strEQ(d,"semget")) return -KEY_semget;
79072805
LW		 4485 break;
4486 case 7:
a0d0e21e
LW		 4487 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
4488 if (strEQ(d,"seekdir")) return -KEY_seekdir;
79072805
LW		 4489 break;
4490 case 8:
a0d0e21e
LW		 4491 if (strEQ(d,"setpwent")) return -KEY_setpwent;
4492 if (strEQ(d,"setgrent")) return -KEY_setgrent;
79072805
LW		 4493 break;
4494 case 9:
a0d0e21e 4495 if (strEQ(d,"setnetent")) return -KEY_setnetent;
79072805
LW		 4496 break;
4497 case 10:
a0d0e21e
LW		 4498 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
4499 if (strEQ(d,"sethostent")) return -KEY_sethostent;
4500 if (strEQ(d,"setservent")) return -KEY_setservent;
79072805
LW		 4501 break;
4502 case 11:
a0d0e21e
LW		 4503 if (strEQ(d,"setpriority")) return -KEY_setpriority;
4504 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
79072805
LW		 4505 break;
4506 }
a687059c
LW		 4507 break;
4508 case 'h':
79072805
LW		 4509 switch (len) {
4510 case 5:
4511 if (strEQ(d,"shift")) return KEY_shift;
4512 break;
4513 case 6:
a0d0e21e
LW		 4514 if (strEQ(d,"shmctl")) return -KEY_shmctl;
4515 if (strEQ(d,"shmget")) return -KEY_shmget;
79072805
LW		 4516 break;
4517 case 7:
a0d0e21e 4518 if (strEQ(d,"shmread")) return -KEY_shmread;
79072805
LW		 4519 break;
4520 case 8:
a0d0e21e
LW		 4521 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
4522 if (strEQ(d,"shutdown")) return -KEY_shutdown;
79072805
LW		 4523 break;
4524 }
a687059c
LW		 4525 break;
4526 case 'i':
a0d0e21e 4527 if (strEQ(d,"sin")) return -KEY_sin;
a687059c
LW		 4528 break;
4529 case 'l':
a0d0e21e 4530 if (strEQ(d,"sleep")) return -KEY_sleep;
a687059c
LW		 4531 break;
4532 case 'o':
79072805 4533 if (strEQ(d,"sort")) return KEY_sort;
a0d0e21e
LW		 4534 if (strEQ(d,"socket")) return -KEY_socket;
4535 if (strEQ(d,"socketpair")) return -KEY_socketpair;
a687059c
LW		 4536 break;
4537 case 'p':
79072805 4538 if (strEQ(d,"split")) return KEY_split;
a0d0e21e 4539 if (strEQ(d,"sprintf")) return -KEY_sprintf;
79072805 4540 if (strEQ(d,"splice")) return KEY_splice;
a687059c
LW		 4541 break;
4542 case 'q':
a0d0e21e 4543 if (strEQ(d,"sqrt")) return -KEY_sqrt;
a687059c
LW		 4544 break;
4545 case 'r':
a0d0e21e 4546 if (strEQ(d,"srand")) return -KEY_srand;
a687059c
LW		 4547 break;
4548 case 't':
a0d0e21e 4549 if (strEQ(d,"stat")) return -KEY_stat;
79072805 4550 if (strEQ(d,"study")) return KEY_study;
a687059c
LW		 4551 break;
4552 case 'u':
a0d0e21e 4553 if (strEQ(d,"substr")) return -KEY_substr;
79072805 4554 if (strEQ(d,"sub")) return KEY_sub;
a687059c
LW		 4555 break;
4556 case 'y':
79072805
LW		 4557 switch (len) {
4558 case 6:
a0d0e21e 4559 if (strEQ(d,"system")) return -KEY_system;
79072805
LW		 4560 break;
4561 case 7:
a0d0e21e
LW		 4562 if (strEQ(d,"symlink")) return -KEY_symlink;
4563 if (strEQ(d,"syscall")) return -KEY_syscall;
137443ea 4564 if (strEQ(d,"sysopen")) return -KEY_sysopen;
4565 if (strEQ(d,"sysread")) return -KEY_sysread;
4566 if (strEQ(d,"sysseek")) return -KEY_sysseek;
79072805
LW		 4567 break;
4568 case 8:
a0d0e21e 4569 if (strEQ(d,"syswrite")) return -KEY_syswrite;
79072805 4570 break;
a687059c 4571 }
a687059c
LW		 4572 break;
4573 }
4574 break;
79072805
LW		 4575 case 't':
4576 switch (len) {
4577 case 2:
4578 if (strEQ(d,"tr")) return KEY_tr;
4579 break;
463ee0b2
LW		 4580 case 3:
4581 if (strEQ(d,"tie")) return KEY_tie;
4582 break;
79072805 4583 case 4:
a0d0e21e 4584 if (strEQ(d,"tell")) return -KEY_tell;
c07a80fd 4585 if (strEQ(d,"tied")) return KEY_tied;
a0d0e21e 4586 if (strEQ(d,"time")) return -KEY_time;
79072805
LW		 4587 break;
4588 case 5:
a0d0e21e 4589 if (strEQ(d,"times")) return -KEY_times;
79072805
LW		 4590 break;
4591 case 7:
a0d0e21e 4592 if (strEQ(d,"telldir")) return -KEY_telldir;
79072805
LW		 4593 break;
4594 case 8:
a0d0e21e 4595 if (strEQ(d,"truncate")) return -KEY_truncate;
79072805 4596 break;
378cc40b 4597 }
a687059c 4598 break;
79072805
LW		 4599 case 'u':
4600 switch (len) {
4601 case 2:
a0d0e21e
LW		 4602 if (strEQ(d,"uc")) return -KEY_uc;
4603 break;
4604 case 3:
4605 if (strEQ(d,"use")) return KEY_use;
79072805
LW		 4606 break;
4607 case 5:
4608 if (strEQ(d,"undef")) return KEY_undef;
4609 if (strEQ(d,"until")) return KEY_until;
463ee0b2 4610 if (strEQ(d,"untie")) return KEY_untie;
a0d0e21e
LW		 4611 if (strEQ(d,"utime")) return -KEY_utime;
4612 if (strEQ(d,"umask")) return -KEY_umask;
79072805
LW		 4613 break;
4614 case 6:
4615 if (strEQ(d,"unless")) return KEY_unless;
a0d0e21e
LW		 4616 if (strEQ(d,"unpack")) return -KEY_unpack;
4617 if (strEQ(d,"unlink")) return -KEY_unlink;
79072805
LW		 4618 break;
4619 case 7:
4620 if (strEQ(d,"unshift")) return KEY_unshift;
a0d0e21e 4621 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
79072805 4622 break;
a687059c
LW		 4623 }
4624 break;
79072805 4625 case 'v':
a0d0e21e
LW		 4626 if (strEQ(d,"values")) return -KEY_values;
4627 if (strEQ(d,"vec")) return -KEY_vec;
a687059c 4628 break;
79072805
LW		 4629 case 'w':
4630 switch (len) {
4631 case 4:
a0d0e21e
LW		 4632 if (strEQ(d,"warn")) return -KEY_warn;
4633 if (strEQ(d,"wait")) return -KEY_wait;
79072805
LW		 4634 break;
4635 case 5:
4636 if (strEQ(d,"while")) return KEY_while;
a0d0e21e 4637 if (strEQ(d,"write")) return -KEY_write;
79072805
LW		 4638 break;
4639 case 7:
a0d0e21e 4640 if (strEQ(d,"waitpid")) return -KEY_waitpid;
79072805
LW		 4641 break;
4642 case 9:
a0d0e21e 4643 if (strEQ(d,"wantarray")) return -KEY_wantarray;
79072805 4644 break;
2f3197b3 4645 }
a687059c 4646 break;
79072805 4647 case 'x':
a0d0e21e
LW		 4648 if (len == 1) return -KEY_x;
4649 if (strEQ(d,"xor")) return -KEY_xor;
a687059c 4650 break;
79072805
LW		 4651 case 'y':
4652 if (len == 1) return KEY_y;
4653 break;
4654 case 'z':
a687059c
LW		 4655 break;
4656 }
79072805 4657 return 0;
a687059c
LW		 4658}
4659
8990e307 4660static void
8ac85365 4661checkcomma(register char *s, char *name, char *what)
a687059c 4662{
2f3197b3
LW		 4663 char *w;
4664
463ee0b2 4665 if (dowarn && *s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
a0d0e21e
LW		 4666 int level = 1;
4667 for (w = s+2; *w && level; w++) {
4668 if (*w == '(')
4669 ++level;
4670 else if (*w == ')')
4671 --level;
4672 }
4673 if (*w)
4674 for (; *w && isSPACE(*w); w++) ;
d1f3fb15 4675 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
2f3197b3
LW		 4676 warn("%s (...) interpreted as function",name);
4677 }
4678 while (s < bufend && isSPACE(*s))
4679 s++;
a687059c
LW		 4680 if (*s == '(')
4681 s++;
de3bb511 4682 while (s < bufend && isSPACE(*s))
a687059c 4683 s++;
79072805 4684 if (isIDFIRST(*s)) {
2f3197b3 4685 w = s++;
de3bb511 4686 while (isALNUM(*s))
a687059c 4687 s++;
de3bb511 4688 while (s < bufend && isSPACE(*s))
a687059c 4689 s++;
e929a76b 4690 if (*s == ',') {
463ee0b2 4691 int kw;
e929a76b 4692 *s = '\0';
4633a7c4 4693 kw = keyword(w, s - w) || perl_get_cv(w, FALSE) != 0;
e929a76b 4694 *s = ',';
463ee0b2 4695 if (kw)
e929a76b 4696 return;
463ee0b2
LW		 4697 croak("No comma allowed after %s", what);
4698 }
4699 }
4700}
4701
8990e307 4702static char *
8ac85365 4703scan_word(register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
463ee0b2
LW		 4704{
4705 register char *d = dest;
8903cb82 4706 register char *e = d + destlen - 3; /* two-character token, ending NUL */
463ee0b2 4707 for (;;) {
8903cb82 4708 if (d >= e)
fc36a67e 4709 croak(ident_too_long);
463ee0b2
LW		 4710 if (isALNUM(*s))
4711 *d++ = *s++;
4712 else if (*s == '\'' && allow_package && isIDFIRST(s[1])) {
4713 *d++ = ':';
4714 *d++ = ':';
4715 s++;
4716 }
c3e0f903 4717 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
463ee0b2
LW		 4718 *d++ = *s++;
4719 *d++ = *s++;
4720 }
4721 else {
4722 *d = '\0';
4723 *slp = d - dest;
4724 return s;
e929a76b 4725 }
378cc40b
LW		 4726 }
4727}
4728
8990e307 4729static char *
8ac85365 4730scan_ident(register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
378cc40b
LW		 4731{
4732 register char *d;
8903cb82 4733 register char *e;
79072805 4734 char *bracket = 0;
748a9306 4735 char funny = *s++;
378cc40b 4736
79072805
LW		 4737 if (lex_brackets == 0)
4738 lex_fakebrack = 0;
a0d0e21e
LW		 4739 if (isSPACE(*s))
4740 s = skipspace(s);
378cc40b 4741 d = dest;
8903cb82 4742 e = d + destlen - 3; /* two-character token, ending NUL */
de3bb511 4743 if (isDIGIT(*s)) {
8903cb82 4744 while (isDIGIT(*s)) {
4745 if (d >= e)
fc36a67e 4746 croak(ident_too_long);
378cc40b 4747 *d++ = *s++;
8903cb82 4748 }
378cc40b
LW		 4749 }
4750 else {
463ee0b2 4751 for (;;) {
8903cb82 4752 if (d >= e)
fc36a67e 4753 croak(ident_too_long);
463ee0b2
LW		 4754 if (isALNUM(*s))
4755 *d++ = *s++;
4756 else if (*s == '\'' && isIDFIRST(s[1])) {
4757 *d++ = ':';
4758 *d++ = ':';
4759 s++;
4760 }
a0d0e21e 4761 else if (*s == ':' && s[1] == ':') {
463ee0b2
LW		 4762 *d++ = *s++;
4763 *d++ = *s++;
4764 }
4765 else
4766 break;
4767 }
378cc40b
LW		 4768 }
4769 *d = '\0';
4770 d = dest;
79072805
LW		 4771 if (*d) {
4772 if (lex_state != LEX_NORMAL)
4773 lex_state = LEX_INTERPENDMAYBE;
4774 return s;
378cc40b 4775 }
748a9306 4776 if (*s == '$' && s[1] &&
ff0cee69 4777 (isALNUM(s[1]) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
5cd24f17 4778 {
4779 if (isDIGIT(s[1]) && lex_state == LEX_INTERPNORMAL)
4780 deprecate("\"$$<digit>\" to mean \"${$}<digit>\"");
4781 else
4782 return s;
4783 }
79072805
LW		 4784 if (*s == '{') {
4785 bracket = s;
4786 s++;
4787 }
4788 else if (ck_uni)
4789 check_uni();
93a17b20 4790 if (s < send)
79072805
LW		 4791 *d = *s++;
4792 d[1] = '\0';
748a9306 4793 if (*d == '^' && *s && (isUPPER(*s) || strchr("[\\]^_?", *s))) {
bbce6d69 4794 *d = toCTRL(*s);
4795 s++;
de3bb511 4796 }
79072805 4797 if (bracket) {
748a9306 4798 if (isSPACE(s[-1])) {
fa83b5b6 4799 while (s < send) {
4800 char ch = *s++;
4801 if (ch != ' ' && ch != '\t') {
4802 *d = ch;
4803 break;
4804 }
4805 }
748a9306 4806 }
ff68c719 4807 if (isIDFIRST(*d)) {
79072805 4808 d++;
748a9306 4809 while (isALNUM(*s) || *s == ':')
79072805
LW		 4810 *d++ = *s++;
4811 *d = '\0';
748a9306 4812 while (s < send && (*s == ' ' || *s == '\t')) s++;
ff68c719 4813 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
748a9306
LW		 4814 if (dowarn && keyword(dest, d - dest)) {
4815 char *brack = *s == '[' ? "[...]" : "{...}";
4816 warn("Ambiguous use of %c{%s%s} resolved to %c%s%s",
4817 funny, dest, brack, funny, dest, brack);
4818 }
4819 lex_fakebrack = lex_brackets+1;
79072805 4820 bracket++;
a0d0e21e 4821 lex_brackstack[lex_brackets++] = XOPERATOR;
79072805
LW		 4822 return s;
4823 }
4824 }
4825 if (*s == '}') {
4826 s++;
4827 if (lex_state == LEX_INTERPNORMAL && !lex_brackets)
4828 lex_state = LEX_INTERPEND;
748a9306
LW		 4829 if (funny == '#')
4830 funny = '@';
84902520 4831 if (dowarn && lex_state == LEX_NORMAL &&
748a9306
LW		 4832 (keyword(dest, d - dest) || perl_get_cv(dest, FALSE)))
4833 warn("Ambiguous use of %c{%s} resolved to %c%s",
4834 funny, dest, funny, dest);
79072805
LW		 4835 }
4836 else {
4837 s = bracket; /* let the parser handle it */
93a17b20 4838 *dest = '\0';
79072805
LW		 4839 }
4840 }
4841 else if (lex_state == LEX_INTERPNORMAL && !lex_brackets && !intuit_more(s))
4842 lex_state = LEX_INTERPEND;
378cc40b
LW		 4843 return s;
4844}
4845
8ac85365 4846void pmflag(U16 *pmfl, int ch)
a0d0e21e 4847{
bbce6d69 4848 if (ch == 'i')
a0d0e21e 4849 *pmfl |= PMf_FOLD;
a0d0e21e
LW		 4850 else if (ch == 'g')
4851 *pmfl |= PMf_GLOBAL;
c90c0ff4 4852 else if (ch == 'c')
4853 *pmfl |= PMf_CONTINUE;
a0d0e21e
LW		 4854 else if (ch == 'o')
4855 *pmfl |= PMf_KEEP;
4856 else if (ch == 'm')
4857 *pmfl |= PMf_MULTILINE;
4858 else if (ch == 's')
4859 *pmfl |= PMf_SINGLELINE;
4860 else if (ch == 'x')
4861 *pmfl |= PMf_EXTENDED;
4862}
378cc40b 4863
8990e307 4864static char *
8ac85365 4865scan_pat(char *start)
378cc40b 4866{
79072805
LW		 4867 PMOP *pm;
4868 char *s;
378cc40b 4869
79072805
LW		 4870 s = scan_str(start);
4871 if (!s) {
4872 if (lex_stuff)
8990e307 4873 SvREFCNT_dec(lex_stuff);
79072805 4874 lex_stuff = Nullsv;
463ee0b2 4875 croak("Search pattern not terminated");
378cc40b 4876 }
bbce6d69 4877
79072805 4878 pm = (PMOP*)newPMOP(OP_MATCH, 0);
a0d0e21e 4879 if (multi_open == '?')
79072805 4880 pm->op_pmflags |= PMf_ONCE;
c90c0ff4 4881 while (*s && strchr("iogcmsx", *s))
a0d0e21e 4882 pmflag(&pm->op_pmflags,*s++);
4633a7c4 4883 pm->op_pmpermflags = pm->op_pmflags;
bbce6d69 4884
79072805
LW		 4885 lex_op = (OP*)pm;
4886 yylval.ival = OP_MATCH;
378cc40b
LW		 4887 return s;
4888}
4889
8990e307 4890static char *
8ac85365 4891scan_subst(char *start)
79072805 4892{
a0d0e21e 4893 register char *s;
79072805 4894 register PMOP *pm;
4fdae800 4895 I32 first_start;
79072805
LW		 4896 I32 es = 0;
4897
79072805
LW		 4898 yylval.ival = OP_NULL;
4899
a0d0e21e 4900 s = scan_str(start);
79072805
LW		 4901
4902 if (!s) {
4903 if (lex_stuff)
8990e307 4904 SvREFCNT_dec(lex_stuff);
79072805 4905 lex_stuff = Nullsv;
463ee0b2 4906 croak("Substitution pattern not terminated");
a687059c 4907 }
79072805 4908
a0d0e21e 4909 if (s[-1] == multi_open)
79072805
LW		 4910 s--;
4911
4fdae800 4912 first_start = multi_start;
79072805
LW		 4913 s = scan_str(s);
4914 if (!s) {
4915 if (lex_stuff)
8990e307 4916 SvREFCNT_dec(lex_stuff);
79072805
LW		 4917 lex_stuff = Nullsv;
4918 if (lex_repl)
8990e307 4919 SvREFCNT_dec(lex_repl);
79072805 4920 lex_repl = Nullsv;
463ee0b2 4921 croak("Substitution replacement not terminated");
a687059c 4922 }
4fdae800 4923 multi_start = first_start; /* so whole substitution is taken together */
2f3197b3 4924
79072805 4925 pm = (PMOP*)newPMOP(OP_SUBST, 0);
c90c0ff4 4926 while (*s && strchr("iogcmsex", *s)) {
a687059c
LW		 4927 if (*s == 'e') {
4928 s++;
2f3197b3 4929 es++;
a687059c 4930 }
a0d0e21e
LW		 4931 else
4932 pmflag(&pm->op_pmflags,*s++);
378cc40b 4933 }
79072805
LW		 4934
4935 if (es) {
4936 SV *repl;
4937 pm->op_pmflags |= PMf_EVAL;
463ee0b2
LW		 4938 repl = newSVpv("",0);
4939 while (es-- > 0)
a0d0e21e 4940 sv_catpv(repl, es ? "eval " : "do ");
79072805
LW		 4941 sv_catpvn(repl, "{ ", 2);
4942 sv_catsv(repl, lex_repl);
4943 sv_catpvn(repl, " };", 2);
4944 SvCOMPILED_on(repl);
8990e307 4945 SvREFCNT_dec(lex_repl);
79072805 4946 lex_repl = repl;
378cc40b 4947 }
79072805 4948
4633a7c4 4949 pm->op_pmpermflags = pm->op_pmflags;
79072805
LW		 4950 lex_op = (OP*)pm;
4951 yylval.ival = OP_SUBST;
378cc40b
LW		 4952 return s;
4953}
4954
8990e307 4955static char *
8ac85365 4956scan_trans(char *start)
378cc40b 4957{
a0d0e21e 4958 register char* s;
11343788 4959 OP *o;
79072805
LW		 4960 short *tbl;
4961 I32 squash;
8ac85365 4962 I32 Delete;
79072805
LW		 4963 I32 complement;
4964
4965 yylval.ival = OP_NULL;
4966
a0d0e21e 4967 s = scan_str(start);
79072805
LW		 4968 if (!s) {
4969 if (lex_stuff)
8990e307 4970 SvREFCNT_dec(lex_stuff);
79072805 4971 lex_stuff = Nullsv;
463ee0b2 4972 croak("Translation pattern not terminated");
a687059c 4973 }
a0d0e21e 4974 if (s[-1] == multi_open)
2f3197b3
LW		 4975 s--;
4976
93a17b20 4977 s = scan_str(s);
79072805
LW		 4978 if (!s) {
4979 if (lex_stuff)
8990e307 4980 SvREFCNT_dec(lex_stuff);
79072805
LW		 4981 lex_stuff = Nullsv;
4982 if (lex_repl)
8990e307 4983 SvREFCNT_dec(lex_repl);
79072805 4984 lex_repl = Nullsv;
463ee0b2 4985 croak("Translation replacement not terminated");
a687059c 4986 }
79072805
LW		 4987
4988 New(803,tbl,256,short);
11343788 4989 o = newPVOP(OP_TRANS, 0, (char*)tbl);
2f3197b3 4990
8ac85365 4991 complement = Delete = squash = 0;
395c3793
LW		 4992 while (*s == 'c' || *s == 'd' || *s == 's') {
4993 if (*s == 'c')
79072805 4994 complement = OPpTRANS_COMPLEMENT;
395c3793 4995 else if (*s == 'd')
8ac85365 4996 Delete = OPpTRANS_DELETE;
395c3793 4997 else
79072805 4998 squash = OPpTRANS_SQUASH;
395c3793
LW		 4999 s++;
5000 }
8ac85365 5001 o->op_private = Delete|squash|complement;
79072805 5002
11343788 5003 lex_op = o;
79072805
LW		 5004 yylval.ival = OP_TRANS;
5005 return s;
5006}
5007
8990e307 5008static char *
8ac85365 5009scan_heredoc(register char *s)
79072805 5010{
11343788 5011 dTHR;
79072805
LW		 5012 SV *herewas;
5013 I32 op_type = OP_SCALAR;
5014 I32 len;
5015 SV *tmpstr;
5016 char term;
5017 register char *d;
fc36a67e 5018 register char *e;
4633a7c4 5019 char *peek;
a2c06652 5020 int outer = (rsfp && !(lex_inwhat == OP_SCALAR));
79072805
LW		 5021
5022 s += 2;
5023 d = tokenbuf;
fc36a67e 5024 e = tokenbuf + sizeof tokenbuf - 1;
fd2d0953 5025 if (!outer)
79072805 5026 *d++ = '\n';
4633a7c4
LW		 5027 for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5028 if (*peek && strchr("`'\"",*peek)) {
5029 s = peek;
79072805 5030 term = *s++;
fc36a67e 5031 s = delimcpy(d, e, s, bufend, term, &len);
5032 d += len;
79072805
LW		 5033 if (s < bufend)
5034 s++;
79072805
LW		 5035 }
5036 else {
5037 if (*s == '\\')
5038 s++, term = '\'';
5039 else
5040 term = '"';
4633a7c4
LW		 5041 if (!isALNUM(*s))
5042 deprecate("bare << to mean <<\"\"");
fc36a67e 5043 for (; isALNUM(*s); s++) {
5044 if (d < e)
5045 *d++ = *s;
5046 }
5047 }
5048 if (d >= tokenbuf + sizeof tokenbuf - 1)
5049 croak("Delimiter for here document is too long");
79072805
LW		 5050 *d++ = '\n';
5051 *d = '\0';
5052 len = d - tokenbuf;
5053 d = "\n";
fd2d0953 5054 if (outer || !(d=ninstr(s,bufend,d,d+1)))
79072805
LW		 5055 herewas = newSVpv(s,bufend-s);
5056 else
5057 s--, herewas = newSVpv(s,d-s);
5058 s += SvCUR(herewas);
748a9306
LW		 5059
5060 tmpstr = NEWSV(87,80);
5061 sv_upgrade(tmpstr, SVt_PVIV);
5062 if (term == '\'') {
79072805 5063 op_type = OP_CONST;
748a9306
LW		 5064 SvIVX(tmpstr) = -1;
5065 }
5066 else if (term == '`') {
79072805 5067 op_type = OP_BACKTICK;
748a9306
LW		 5068 SvIVX(tmpstr) = '\\';
5069 }
79072805
LW		 5070
5071 CLINE;
5072 multi_start = curcop->cop_line;
5073 multi_open = multi_close = '<';
79072805 5074 term = *tokenbuf;
fd2d0953 5075 if (!outer) {
79072805
LW		 5076 d = s;
5077 while (s < bufend &&
36477c24 5078 (*s != term || memNE(s,tokenbuf,len)) ) {
79072805
LW		 5079 if (*s++ == '\n')
5080 curcop->cop_line++;
5081 }
5082 if (s >= bufend) {
5083 curcop->cop_line = multi_start;
8990e307 5084 missingterm(tokenbuf);
79072805
LW		 5085 }
5086 sv_setpvn(tmpstr,d+1,s-d);
5087 s += len - 1;
49d8d3a1
MB		 5088 curcop->cop_line++; /* the preceding stmt passes a newline */
5089
79072805
LW		 5090 sv_catpvn(herewas,s,bufend-s);
5091 sv_setsv(linestr,herewas);
fd049845 5092 oldoldbufptr = oldbufptr = bufptr = s = linestart = SvPVX(linestr);
463ee0b2 5093 bufend = SvPVX(linestr) + SvCUR(linestr);
79072805
LW		 5094 }
5095 else
5096 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
5097 while (s >= bufend) { /* multiple line string? */
fd2d0953 5098 if (!outer ||
fd049845 5099 !(oldoldbufptr = oldbufptr = s = linestart = filter_gets(linestr, rsfp, 0))) {
79072805 5100 curcop->cop_line = multi_start;
8990e307 5101 missingterm(tokenbuf);
79072805
LW		 5102 }
5103 curcop->cop_line++;
84902520 5104 if (PERLDB_LINE && curstash != debstash) {
79072805
LW		 5105 SV *sv = NEWSV(88,0);
5106
93a17b20 5107 sv_upgrade(sv, SVt_PVMG);
79072805
LW		 5108 sv_setsv(sv,linestr);
5109 av_store(GvAV(curcop->cop_filegv),
5110 (I32)curcop->cop_line,sv);
5111 }
463ee0b2 5112 bufend = SvPVX(linestr) + SvCUR(linestr);
36477c24 5113 if (*s == term && memEQ(s,tokenbuf,len)) {
79072805
LW		 5114 s = bufend - 1;
5115 *s = ' ';
5116 sv_catsv(linestr,herewas);
463ee0b2 5117 bufend = SvPVX(linestr) + SvCUR(linestr);
79072805
LW		 5118 }
5119 else {
5120 s = bufend;
5121 sv_catsv(tmpstr,linestr);
395c3793
LW		 5122 }
5123 }
79072805
LW		 5124 multi_end = curcop->cop_line;
5125 s++;
5126 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
5127 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
463ee0b2 5128 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
79072805 5129 }
8990e307 5130 SvREFCNT_dec(herewas);
79072805
LW		 5131 lex_stuff = tmpstr;
5132 yylval.ival = op_type;
5133 return s;
5134}
5135
02aa26ce
NT		 5136/* scan_inputsymbol
5137 takes: current position in input buffer
5138 returns: new position in input buffer
5139 side-effects: yylval and lex_op are set.
5140
5141 This code handles:
5142
5143 <> read from ARGV
5144 <FH> read from filehandle
5145 <pkg::FH> read from package qualified filehandle
5146 <pkg'FH> read from package qualified filehandle
5147 <$fh> read from filehandle in $fh
5148 <*.h> filename glob
5149
5150*/
5151
8990e307 5152static char *
8ac85365 5153scan_inputsymbol(char *start)
79072805 5154{
02aa26ce 5155 register char *s = start; /* current position in buffer */
79072805 5156 register char *d;
fc36a67e 5157 register char *e;
79072805
LW		 5158 I32 len;
5159
02aa26ce
NT		 5160 d = tokenbuf; /* start of temp holding space */
5161 e = tokenbuf + sizeof tokenbuf; /* end of temp holding space */
5162 s = delimcpy(d, e, s + 1, bufend, '>', &len); /* extract until > */
5163
5164 /* die if we didn't have space for the contents of the <>,
5165 or if it didn't end
5166 */
5167
fc36a67e 5168 if (len >= sizeof tokenbuf)
5169 croak("Excessively long <> operator");
5170 if (s >= bufend)
463ee0b2 5171 croak("Unterminated <> operator");
02aa26ce 5172
fc36a67e 5173 s++;
02aa26ce
NT		 5174
5175 /* check for <$fh>
5176 Remember, only scalar variables are interpreted as filehandles by
5177 this code. Anything more complex (e.g., <$fh{$num}>) will be
5178 treated as a glob() call.
5179 This code makes use of the fact that except for the $ at the front,
5180 a scalar variable and a filehandle look the same.
5181 */
4633a7c4 5182 if (*d == '$' && d[1]) d++;
02aa26ce
NT		 5183
5184 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
a0d0e21e 5185 while (*d && (isALNUM(*d) || *d == '\'' || *d == ':'))
79072805 5186 d++;
02aa26ce
NT		 5187
5188 /* If we've tried to read what we allow filehandles to look like, and
5189 there's still text left, then it must be a glob() and not a getline.
5190 Use scan_str to pull out the stuff between the <> and treat it
5191 as nothing more than a string.
5192 */
5193
79072805
LW		 5194 if (d - tokenbuf != len) {
5195 yylval.ival = OP_GLOB;
5196 set_csh();
5197 s = scan_str(start);
5198 if (!s)
02aa26ce 5199 croak("Glob not terminated");
79072805
LW		 5200 return s;
5201 }
395c3793 5202 else {
02aa26ce 5203 /* we're in a filehandle read situation */
79072805 5204 d = tokenbuf;
02aa26ce
NT		 5205
5206 /* turn <> into <ARGV> */
79072805
LW		 5207 if (!len)
5208 (void)strcpy(d,"ARGV");
02aa26ce
NT		 5209
5210 /* if <$fh>, create the ops to turn the variable into a
5211 filehandle
5212 */
79072805 5213 if (*d == '$') {
a0d0e21e 5214 I32 tmp;
02aa26ce
NT		 5215
5216 /* try to find it in the pad for this block, otherwise find
5217 add symbol table ops
5218 */
11343788
MB		 5219 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
5220 OP *o = newOP(OP_PADSV, 0);
5221 o->op_targ = tmp;
5222 lex_op = (OP*)newUNOP(OP_READLINE, 0, newUNOP(OP_RV2GV, 0, o));
a0d0e21e
LW		 5223 }
5224 else {
5225 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
5226 lex_op = (OP*)newUNOP(OP_READLINE, 0,
5227 newUNOP(OP_RV2GV, 0,
5228 newUNOP(OP_RV2SV, 0,
5229 newGVOP(OP_GV, 0, gv))));
5230 }
02aa26ce 5231 /* we created the ops in lex_op, so make yylval.ival a null op */
79072805
LW		 5232 yylval.ival = OP_NULL;
5233 }
02aa26ce
NT		 5234
5235 /* If it's none of the above, it must be a literal filehandle
5236 (<Foo::BAR> or <FOO>) so build a simple readline OP */
79072805 5237 else {
85e6fe83 5238 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
79072805
LW		 5239 lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
5240 yylval.ival = OP_NULL;
5241 }
5242 }
02aa26ce 5243
79072805
LW		 5244 return s;
5245}
5246
02aa26ce
NT		 5247
5248/* scan_str
5249 takes: start position in buffer
5250 returns: position to continue reading from buffer
5251 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
5252 updates the read buffer.
5253
5254 This subroutine pulls a string out of the input. It is called for:
5255 q single quotes q(literal text)
5256 ' single quotes 'literal text'
5257 qq double quotes qq(interpolate $here please)
5258 " double quotes "interpolate $here please"
5259 qx backticks qx(/bin/ls -l)
5260 ` backticks `/bin/ls -l`
5261 qw quote words @EXPORT_OK = qw( func() $spam )
5262 m// regexp match m/this/
5263 s/// regexp substitute s/this/that/
5264 tr/// string transliterate tr/this/that/
5265 y/// string transliterate y/this/that/
5266 ($*@) sub prototypes sub foo ($)
5267 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
5268
5269 In most of these cases (all but <>, patterns and transliterate)
5270 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
5271 calls scan_str(). s/// makes yylex() call scan_subst() which calls
5272 scan_str(). tr/// and y/// make yylex() call scan_trans() which
5273 calls scan_str().
5274
5275 It skips whitespace before the string starts, and treats the first
5276 character as the delimiter. If the delimiter is one of ([{< then
5277 the corresponding "close" character )]}> is used as the closing
5278 delimiter. It allows quoting of delimiters, and if the string has
5279 balanced delimiters ([{<>}]) it allows nesting.
5280
5281 The lexer always reads these strings into lex_stuff, except in the
5282 case of the operators which take *two* arguments (s/// and tr///)
5283 when it checks to see if lex_stuff is full (presumably with the 1st
5284 arg to s or tr) and if so puts the string into lex_repl.
5285
5286*/
5287
8990e307 5288static char *
8ac85365 5289scan_str(char *start)
79072805 5290{
11343788 5291 dTHR;
02aa26ce
NT		 5292 SV *sv; /* scalar value: string */
5293 char *tmps; /* temp string, used for delimiter matching */
5294 register char *s = start; /* current position in the buffer */
5295 register char term; /* terminating character */
5296 register char *to; /* current position in the sv's data */
5297 I32 brackets = 1; /* bracket nesting level */
5298
5299 /* skip space before the delimiter */
fb73857a 5300 if (isSPACE(*s))
5301 s = skipspace(s);
02aa26ce
NT		 5302
5303 /* mark where we are, in case we need to report errors */
79072805 5304 CLINE;
02aa26ce
NT		 5305
5306 /* after skipping whitespace, the next character is the terminator */
a0d0e21e 5307 term = *s;
02aa26ce 5308 /* mark where we are */
79072805
LW		 5309 multi_start = curcop->cop_line;
5310 multi_open = term;
02aa26ce
NT		 5311
5312 /* find corresponding closing delimiter */
93a17b20 5313 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
79072805
LW		 5314 term = tmps[5];
5315 multi_close = term;
5316
02aa26ce
NT		 5317 /* create a new SV to hold the contents. 87 is leak category, I'm
5318 assuming. 80 is the SV's initial length. What a random number. */
93a17b20 5319 sv = NEWSV(87,80);
ed6116ce
LW		 5320 sv_upgrade(sv, SVt_PVIV);
5321 SvIVX(sv) = term;
a0d0e21e 5322 (void)SvPOK_only(sv); /* validate pointer */
02aa26ce
NT		 5323
5324 /* move past delimiter and try to read a complete string */
93a17b20
LW		 5325 s++;
5326 for (;;) {
02aa26ce 5327 /* extend sv if need be */
93a17b20 5328 SvGROW(sv, SvCUR(sv) + (bufend - s) + 1);
02aa26ce 5329 /* set 'to' to the next character in the sv's string */
463ee0b2 5330 to = SvPVX(sv)+SvCUR(sv);
02aa26ce
NT		 5331
5332 /* if open delimiter is the close delimiter read unbridle */
93a17b20
LW		 5333 if (multi_open == multi_close) {
5334 for (; s < bufend; s++,to++) {
02aa26ce 5335 /* embedded newlines increment the current line number */
463ee0b2
LW		 5336 if (*s == '\n' && !rsfp)
5337 curcop->cop_line++;
02aa26ce 5338 /* handle quoted delimiters */
a0d0e21e
LW		 5339 if (*s == '\\' && s+1 < bufend && term != '\\') {
5340 if (s[1] == term)
5341 s++;
02aa26ce 5342 /* any other quotes are simply copied straight through */
a0d0e21e
LW		 5343 else
5344 *to++ = *s++;
5345 }
02aa26ce
NT		 5346 /* terminate when run out of buffer (the for() condition), or
5347 have found the terminator */
93a17b20
LW		 5348 else if (*s == term)
5349 break;
5350 *to = *s;
5351 }
5352 }
02aa26ce
NT		 5353
5354 /* if the terminator isn't the same as the start character (e.g.,
5355 matched brackets), we have to allow more in the quoting, and
5356 be prepared for nested brackets.
5357 */
93a17b20 5358 else {
02aa26ce 5359 /* read until we run out of string, or we find the terminator */
93a17b20 5360 for (; s < bufend; s++,to++) {
02aa26ce 5361 /* embedded newlines increment the line count */
463ee0b2
LW		 5362 if (*s == '\n' && !rsfp)
5363 curcop->cop_line++;
02aa26ce 5364 /* backslashes can escape the open or closing characters */
6d07e5e9
GS		 5365 if (*s == '\\' && s+1 < bufend) {
5366 if ((s[1] == multi_open) || (s[1] == multi_close))
a0d0e21e
LW		 5367 s++;
5368 else
5369 *to++ = *s++;
5370 }
02aa26ce 5371 /* allow nested opens and closes */
6d07e5e9 5372 else if (*s == multi_close && --brackets <= 0)
93a17b20
LW		 5373 break;
5374 else if (*s == multi_open)
5375 brackets++;
5376 *to = *s;
5377 }
5378 }
02aa26ce 5379 /* terminate the copied string and update the sv's end-of-string */
93a17b20 5380 *to = '\0';
463ee0b2 5381 SvCUR_set(sv, to - SvPVX(sv));
93a17b20 5382
02aa26ce
NT		 5383 /*
5384 * this next chunk reads more into the buffer if we're not done yet
5385 */
5386
5387 if (s < bufend) break; /* handle case where we are done yet :-) */
79072805 5388
02aa26ce
NT		 5389 /* if we're out of file, or a read fails, bail and reset the current
5390 line marker so we can report where the unterminated string began
5391 */
79072805 5392 if (!rsfp ||
fd049845 5393 !(oldoldbufptr = oldbufptr = s = linestart = filter_gets(linestr, rsfp, 0))) {
c07a80fd 5394 sv_free(sv);
79072805
LW		 5395 curcop->cop_line = multi_start;
5396 return Nullch;
5397 }
02aa26ce 5398 /* we read a line, so increment our line counter */
79072805 5399 curcop->cop_line++;
02aa26ce
NT		 5400
5401 /* update debugger info */
84902520 5402 if (PERLDB_LINE && curstash != debstash) {
79072805
LW		 5403 SV *sv = NEWSV(88,0);
5404
93a17b20 5405 sv_upgrade(sv, SVt_PVMG);
79072805
LW		 5406 sv_setsv(sv,linestr);
5407 av_store(GvAV(curcop->cop_filegv),
5408 (I32)curcop->cop_line, sv);
395c3793 5409 }
02aa26ce
NT		 5410
5411 /* having changed the buffer, we must update bufend */
463ee0b2 5412 bufend = SvPVX(linestr) + SvCUR(linestr);
378cc40b 5413 }
02aa26ce
NT		 5414
5415 /* at this point, we have successfully read the delimited string */
5416
79072805
LW		 5417 multi_end = curcop->cop_line;
5418 s++;
02aa26ce
NT		 5419
5420 /* if we allocated too much space, give some back */
93a17b20
LW		 5421 if (SvCUR(sv) + 5 < SvLEN(sv)) {
5422 SvLEN_set(sv, SvCUR(sv) + 1);
463ee0b2 5423 Renew(SvPVX(sv), SvLEN(sv), char);
79072805 5424 }
02aa26ce
NT		 5425
5426 /* decide whether this is the first or second quoted string we've read
5427 for this op
5428 */
5429
79072805 5430 if (lex_stuff)
93a17b20 5431 lex_repl = sv;
79072805 5432 else
93a17b20 5433 lex_stuff = sv;
378cc40b
LW		 5434 return s;
5435}
5436
02aa26ce
NT		 5437/*
5438 scan_num
5439 takes: pointer to position in buffer
5440 returns: pointer to new position in buffer
5441 side-effects: builds ops for the constant in yylval.op
5442
5443 Read a number in any of the formats that Perl accepts:
5444
5445 0(x[0-7A-F]+)|([0-7]+)
5446 [\d_]+(\.[\d_]*)?[Ee](\d+)
5447
5448 Underbars (_) are allowed in decimal numbers. If -w is on,
5449 underbars before a decimal point must be at three digit intervals.
5450
5451 Like most scan_ routines, it uses the tokenbuf buffer to hold the
5452 thing it reads.
5453
5454 If it reads a number without a decimal point or an exponent, it will
5455 try converting the number to an integer and see if it can do so
5456 without loss of precision.
5457*/
5458
378cc40b 5459char *
8ac85365 5460scan_num(char *start)
378cc40b 5461{
02aa26ce
NT		 5462 register char *s = start; /* current position in buffer */
5463 register char *d; /* destination in temp buffer */
5464 register char *e; /* end of temp buffer */
5465 I32 tryiv; /* used to see if it can be an int */
5466 double value; /* number read, as a double */
5467 SV *sv; /* place to put the converted number */
5468 I32 floatit; /* boolean: int or float? */
5469 char *lastub = 0; /* position of last underbar */
fc36a67e 5470 static char number_too_long[] = "Number too long";
378cc40b 5471
02aa26ce
NT		 5472 /* We use the first character to decide what type of number this is */
5473
378cc40b 5474 switch (*s) {
79072805 5475 default:
02aa26ce
NT		 5476 croak("panic: scan_num");
5477
5478 /* if it starts with a 0, it could be an octal number, a decimal in
5479 0.13 disguise, or a hexadecimal number.
5480 */
378cc40b
LW		 5481 case '0':
5482 {
02aa26ce
NT		 5483 /* variables:
5484 u holds the "number so far"
5485 shift the power of 2 of the base (hex == 4, octal == 3)
5486 overflowed was the number more than we can hold?
5487
5488 Shift is used when we add a digit. It also serves as an "are
5489 we in octal or hex?" indicator to disallow hex characters when
5490 in octal mode.
5491 */
55497cff 5492 UV u;
79072805 5493 I32 shift;
55497cff 5494 bool overflowed = FALSE;
378cc40b 5495
02aa26ce 5496 /* check for hex */
378cc40b
LW		 5497 if (s[1] == 'x') {
5498 shift = 4;
5499 s += 2;
5500 }
02aa26ce 5501 /* check for a decimal in disguise */
378cc40b
LW		 5502 else if (s[1] == '.')
5503 goto decimal;
02aa26ce 5504 /* so it must be octal */
378cc40b
LW		 5505 else
5506 shift = 3;
55497cff 5507 u = 0;
02aa26ce
NT		 5508
5509 /* read the rest of the octal number */
378cc40b 5510 for (;;) {
02aa26ce 5511 UV n, b; /* n is used in the overflow test, b is the digit we're adding on */
55497cff 5512
378cc40b 5513 switch (*s) {
02aa26ce
NT		 5514
5515 /* if we don't mention it, we're done */
378cc40b
LW		 5516 default:
5517 goto out;
02aa26ce
NT		 5518
5519 /* _ are ignored */
de3bb511
LW		 5520 case '_':
5521 s++;
5522 break;
02aa26ce
NT		 5523
5524 /* 8 and 9 are not octal */
378cc40b
LW		 5525 case '8': case '9':
5526 if (shift != 4)
a687059c 5527 yyerror("Illegal octal digit");
378cc40b 5528 /* FALL THROUGH */
02aa26ce
NT		 5529
5530 /* octal digits */
378cc40b
LW		 5531 case '0': case '1': case '2': case '3': case '4':
5532 case '5': case '6': case '7':
02aa26ce 5533 b = *s++ & 15; /* ASCII digit -> value of digit */
55497cff 5534 goto digit;
02aa26ce
NT		 5535
5536 /* hex digits */
378cc40b
LW		 5537 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
5538 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
02aa26ce 5539 /* make sure they said 0x */
378cc40b
LW		 5540 if (shift != 4)
5541 goto out;
55497cff 5542 b = (*s++ & 7) + 9;
02aa26ce
NT		 5543
5544 /* Prepare to put the digit we have onto the end
5545 of the number so far. We check for overflows.
5546 */
5547
55497cff 5548 digit:
02aa26ce 5549 n = u << shift; /* make room for the digit */
55497cff 5550 if (!overflowed && (n >> shift) != u) {
5551 warn("Integer overflow in %s number",
5552 (shift == 4) ? "hex" : "octal");
5553 overflowed = TRUE;
5554 }
02aa26ce 5555 u = n | b; /* add the digit to the end */
378cc40b
LW		 5556 break;
5557 }
5558 }
02aa26ce
NT		 5559
5560 /* if we get here, we had success: make a scalar value from
5561 the number.
5562 */
378cc40b 5563 out:
79072805 5564 sv = NEWSV(92,0);
55497cff 5565 sv_setuv(sv, u);
378cc40b
LW		 5566 }
5567 break;
02aa26ce
NT		 5568
5569 /*
5570 handle decimal numbers.
5571 we're also sent here when we read a 0 as the first digit
5572 */
378cc40b
LW		 5573 case '1': case '2': case '3': case '4': case '5':
5574 case '6': case '7': case '8': case '9': case '.':
5575 decimal:
378cc40b 5576 d = tokenbuf;
fc36a67e 5577 e = tokenbuf + sizeof tokenbuf - 6; /* room for various punctuation */
79072805 5578 floatit = FALSE;
02aa26ce
NT		 5579
5580 /* read next group of digits and _ and copy into d */
de3bb511 5581 while (isDIGIT(*s) || *s == '_') {
02aa26ce
NT		 5582 /* skip underscores, checking for misplaced ones
5583 if -w is on
5584 */
93a17b20
LW		 5585 if (*s == '_') {
5586 if (dowarn && lastub && s - lastub != 3)
8990e307 5587 warn("Misplaced _ in number");
93a17b20
LW		 5588 lastub = ++s;
5589 }
fc36a67e 5590 else {
02aa26ce 5591 /* check for end of fixed-length buffer */
fc36a67e 5592 if (d >= e)
5593 croak(number_too_long);
02aa26ce 5594 /* if we're ok, copy the character */
378cc40b 5595 *d++ = *s++;
fc36a67e 5596 }
378cc40b 5597 }
02aa26ce
NT		 5598
5599 /* final misplaced underbar check */
93a17b20 5600 if (dowarn && lastub && s - lastub != 3)
8990e307 5601 warn("Misplaced _ in number");
02aa26ce
NT		 5602
5603 /* read a decimal portion if there is one. avoid
5604 3..5 being interpreted as the number 3. followed
5605 by .5
5606 */
2f3197b3 5607 if (*s == '.' && s[1] != '.') {
79072805 5608 floatit = TRUE;
378cc40b 5609 *d++ = *s++;
02aa26ce
NT		 5610
5611 /* copy, ignoring underbars, until we run out of
5612 digits. Note: no misplaced underbar checks!
5613 */
fc36a67e 5614 for (; isDIGIT(*s) || *s == '_'; s++) {
02aa26ce 5615 /* fixed length buffer check */
fc36a67e 5616 if (d >= e)
5617 croak(number_too_long);
5618 if (*s != '_')
5619 *d++ = *s;
378cc40b
LW		 5620 }
5621 }
02aa26ce
NT		 5622
5623 /* read exponent part, if present */
93a17b20 5624 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
79072805
LW		 5625 floatit = TRUE;
5626 s++;
02aa26ce
NT		 5627
5628 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
79072805 5629 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
02aa26ce
NT		 5630
5631 /* allow positive or negative exponent */
378cc40b
LW		 5632 if (*s == '+' || *s == '-')
5633 *d++ = *s++;
02aa26ce
NT		 5634
5635 /* read digits of exponent (no underbars :-) */
fc36a67e 5636 while (isDIGIT(*s)) {
5637 if (d >= e)
5638 croak(number_too_long);
378cc40b 5639 *d++ = *s++;
fc36a67e 5640 }
378cc40b 5641 }
02aa26ce
NT		 5642
5643 /* terminate the string */
378cc40b 5644 *d = '\0';
02aa26ce
NT		 5645
5646 /* make an sv from the string */
79072805 5647 sv = NEWSV(92,0);
02aa26ce 5648 /* reset numeric locale in case we were earlier left in Swaziland */
36477c24 5649 SET_NUMERIC_STANDARD();
79072805 5650 value = atof(tokenbuf);
02aa26ce
NT		 5651
5652 /*
5653 See if we can make do with an integer value without loss of
5654 precision. We use I_V to cast to an int, because some
5655 compilers have issues. Then we try casting it back and see
5656 if it was the same. We only do this if we know we
5657 specifically read an integer.
5658
5659 Note: if floatit is true, then we don't need to do the
5660 conversion at all.
5661 */
1e422769 5662 tryiv = I_V(value);
5663 if (!floatit && (double)tryiv == value)
5664 sv_setiv(sv, tryiv);
2f3197b3 5665 else
1e422769 5666 sv_setnv(sv, value);
378cc40b 5667 break;
79072805 5668 }
a687059c 5669
02aa26ce
NT		 5670 /* make the op for the constant and return */
5671
79072805 5672 yylval.opval = newSVOP(OP_CONST, 0, sv);
a687059c 5673
378cc40b
LW		 5674 return s;
5675}
5676
8990e307 5677static char *
8ac85365 5678scan_formline(register char *s)
378cc40b 5679{
11343788 5680 dTHR;
79072805 5681 register char *eol;
378cc40b 5682 register char *t;
a0d0e21e 5683 SV *stuff = newSVpv("",0);
79072805 5684 bool needargs = FALSE;
378cc40b 5685
79072805 5686 while (!needargs) {
85e6fe83 5687 if (*s == '.' || *s == '}') {
79072805
LW		 5688 /*SUPPRESS 530*/
5689 for (t = s+1; *t == ' ' || *t == '\t'; t++) ;
5690 if (*t == '\n')
5691 break;
5692 }
0f85fab0 5693 if (in_eval && !rsfp) {
93a17b20 5694 eol = strchr(s,'\n');
0f85fab0
LW		 5695 if (!eol++)
5696 eol = bufend;
5697 }
5698 else
463ee0b2 5699 eol = bufend = SvPVX(linestr) + SvCUR(linestr);
79072805 5700 if (*s != '#') {
a0d0e21e
LW		 5701 for (t = s; t < eol; t++) {
5702 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
5703 needargs = FALSE;
5704 goto enough; /* ~~ must be first line in formline */
378cc40b 5705 }
a0d0e21e
LW		 5706 if (*t == '@' || *t == '^')
5707 needargs = TRUE;
378cc40b 5708 }
a0d0e21e 5709 sv_catpvn(stuff, s, eol-s);
79072805
LW		 5710 }
5711 s = eol;
5712 if (rsfp) {
fd049845 5713 s = filter_gets(linestr, rsfp, 0);
5714 oldoldbufptr = oldbufptr = bufptr = linestart = SvPVX(linestr);
a0d0e21e 5715 bufend = bufptr + SvCUR(linestr);
79072805
LW		 5716 if (!s) {
5717 s = bufptr;
5718 yyerror("Format not terminated");
378cc40b
LW		 5719 break;
5720 }
378cc40b 5721 }
463ee0b2 5722 incline(s);
79072805 5723 }
a0d0e21e
LW		 5724 enough:
5725 if (SvCUR(stuff)) {
463ee0b2 5726 expect = XTERM;
79072805 5727 if (needargs) {
a0d0e21e 5728 lex_state = LEX_NORMAL;
79072805
LW		 5729 nextval[nexttoke].ival = 0;
5730 force_next(',');
5731 }
a0d0e21e
LW		 5732 else
5733 lex_state = LEX_FORMLINE;
79072805
LW		 5734 nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
5735 force_next(THING);
5736 nextval[nexttoke].ival = OP_FORMLINE;
5737 force_next(LSTOP);
378cc40b 5738 }
79072805 5739 else {
8990e307 5740 SvREFCNT_dec(stuff);
85e6fe83 5741 lex_formbrack = 0;
79072805
LW		 5742 bufptr = s;
5743 }
5744 return s;
378cc40b 5745}
a687059c 5746
2f3197b3 5747static void
8ac85365 5748set_csh(void)
a687059c 5749{
ae986130
LW		 5750#ifdef CSH
5751 if (!cshlen)
5752 cshlen = strlen(cshname);
5753#endif
a687059c 5754}
463ee0b2 5755
ba6d6ac9 5756I32
8ac85365 5757start_subparse(I32 is_format, U32 flags)
8990e307 5758{
11343788 5759 dTHR;
ba6d6ac9 5760 I32 oldsavestack_ix = savestack_ix;
748a9306
LW		 5761 CV* outsidecv = compcv;
5762 AV* comppadlist;
8990e307 5763
e9a444f0
LW		 5764 if (compcv) {
5765 assert(SvTYPE(compcv) == SVt_PVCV);
5766 }
8990e307
LW		 5767 save_I32(&subline);
5768 save_item(subname);
55497cff 5769 SAVEI32(padix);
8990e307
LW		 5770 SAVESPTR(curpad);
5771 SAVESPTR(comppad);
5772 SAVESPTR(comppad_name);
748a9306 5773 SAVESPTR(compcv);
55497cff 5774 SAVEI32(comppad_name_fill);
5775 SAVEI32(min_intro_pending);
5776 SAVEI32(max_intro_pending);
5777 SAVEI32(pad_reset_pending);
748a9306
LW		 5778
5779 compcv = (CV*)NEWSV(1104,0);
774d564b 5780 sv_upgrade((SV *)compcv, is_format ? SVt_PVFM : SVt_PVCV);
fa83b5b6 5781 CvFLAGS(compcv) |= flags;
748a9306 5782
8990e307 5783 comppad = newAV();
6d4ff0d2
MB		 5784 av_push(comppad, Nullsv);
5785 curpad = AvARRAY(comppad);
8990e307
LW		 5786 comppad_name = newAV();
5787 comppad_name_fill = 0;
5788 min_intro_pending = 0;
8990e307 5789 padix = 0;
8990e307 5790 subline = curcop->cop_line;
6d4ff0d2
MB		 5791#ifdef USE_THREADS
5792 av_store(comppad_name, 0, newSVpv("@_", 2));
5793 curpad[0] = (SV*)newAV();
5794 SvPADMY_on(curpad[0]); /* XXX Needed? */
5795 CvOWNER(compcv) = 0;
12ca11f6 5796 New(666, CvMUTEXP(compcv), 1, perl_mutex);
6d4ff0d2 5797 MUTEX_INIT(CvMUTEXP(compcv));
6d4ff0d2 5798#endif /* USE_THREADS */
748a9306
LW		 5799
5800 comppadlist = newAV();
5801 AvREAL_off(comppadlist);
8e07c86e
AD		 5802 av_store(comppadlist, 0, (SV*)comppad_name);
5803 av_store(comppadlist, 1, (SV*)comppad);
748a9306
LW		 5804
5805 CvPADLIST(compcv) = comppadlist;
199100c8 5806 CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc(outsidecv);
11343788
MB		 5807#ifdef USE_THREADS
5808 CvOWNER(compcv) = 0;
12ca11f6 5809 New(666, CvMUTEXP(compcv), 1, perl_mutex);
11343788 5810 MUTEX_INIT(CvMUTEXP(compcv));
11343788 5811#endif /* USE_THREADS */
748a9306 5812
8990e307
LW		 5813 return oldsavestack_ix;
5814}
5815
5816int
8ac85365 5817yywarn(char *s)
8990e307 5818{
11343788 5819 dTHR;
8990e307 5820 --error_count;
748a9306
LW		 5821 in_eval |= 2;
5822 yyerror(s);
5823 in_eval &= ~2;
5824 return 0;
8990e307
LW		 5825}
5826
5827int
8ac85365 5828yyerror(char *s)
463ee0b2 5829{
11343788 5830 dTHR;
68dc0745 5831 char *where = NULL;
5832 char *context = NULL;
5833 int contlen = -1;
46fc3d4c 5834 SV *msg;
463ee0b2 5835
54310121 5836 if (!yychar || (yychar == ';' && !rsfp))
5837 where = "at EOF";
5838 else if (bufptr > oldoldbufptr && bufptr - oldoldbufptr < 200 &&
463ee0b2
LW		 5839 oldoldbufptr != oldbufptr && oldbufptr != bufptr) {
5840 while (isSPACE(*oldoldbufptr))
5841 oldoldbufptr++;
68dc0745 5842 context = oldoldbufptr;
5843 contlen = bufptr - oldoldbufptr;
463ee0b2
LW		 5844 }
5845 else if (bufptr > oldbufptr && bufptr - oldbufptr < 200 &&
5846 oldbufptr != bufptr) {
5847 while (isSPACE(*oldbufptr))
5848 oldbufptr++;
68dc0745 5849 context = oldbufptr;
5850 contlen = bufptr - oldbufptr;
463ee0b2
LW		 5851 }
5852 else if (yychar > 255)
68dc0745 5853 where = "next token ???";
463ee0b2
LW		 5854 else if ((yychar & 127) == 127) {
5855 if (lex_state == LEX_NORMAL ||
5856 (lex_state == LEX_KNOWNEXT && lex_defer == LEX_NORMAL))
68dc0745 5857 where = "at end of line";
4633a7c4 5858 else if (lex_inpat)
68dc0745 5859 where = "within pattern";
463ee0b2 5860 else
68dc0745 5861 where = "within string";
463ee0b2 5862 }
46fc3d4c 5863 else {
5864 SV *where_sv = sv_2mortal(newSVpv("next char ", 0));
5865 if (yychar < 32)
5866 sv_catpvf(where_sv, "^%c", toCTRL(yychar));
5867 else if (isPRINT_LC(yychar))
5868 sv_catpvf(where_sv, "%c", yychar);
463ee0b2 5869 else
46fc3d4c 5870 sv_catpvf(where_sv, "\\%03o", yychar & 255);
5871 where = SvPVX(where_sv);
463ee0b2 5872 }
46fc3d4c 5873 msg = sv_2mortal(newSVpv(s, 0));
fc36a67e 5874 sv_catpvf(msg, " at %_ line %ld, ",
46fc3d4c 5875 GvSV(curcop->cop_filegv), (long)curcop->cop_line);
68dc0745 5876 if (context)
46fc3d4c 5877 sv_catpvf(msg, "near \"%.*s\"\n", contlen, context);
463ee0b2 5878 else
46fc3d4c 5879 sv_catpvf(msg, "%s\n", where);
4fdae800 5880 if (multi_start < multi_end && (U32)(curcop->cop_line - multi_end) <= 1) {
46fc3d4c 5881 sv_catpvf(msg,
4fdae800 5882 " (Might be a runaway multi-line %c%c string starting on line %ld)\n",
ff0cee69 5883 (int)multi_open,(int)multi_close,(long)multi_start);
a0d0e21e
LW		 5884 multi_end = 0;
5885 }
748a9306 5886 if (in_eval & 2)
fc36a67e 5887 warn("%_", msg);
748a9306 5888 else if (in_eval)
38a03e6e 5889 sv_catsv(ERRSV, msg);
463ee0b2 5890 else
46fc3d4c 5891 PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
463ee0b2 5892 if (++error_count >= 10)
fc36a67e 5893 croak("%_ has too many errors.\n", GvSV(curcop->cop_filegv));
4633a7c4 5894 in_my = 0;
c750a3ec 5895 in_my_stash = Nullhv;
463ee0b2
LW		 5896 return 0;
5897}
4e35701f 5898
161b471a 5899
Unnamed repository; edit this file 'description' to name the repository.