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