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