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