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