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