This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #22969] fix $hash{utf8bareword}
[perl5.git] / toke.c
CommitLineData
a0d0e21e 1/* toke.c
a687059c 2 *
4bb101f2
JH
3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, by Larry Wall and others
a687059c 5 *
d48672a2
LW
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
378cc40b 8 *
a0d0e21e
LW
9 */
10
11/*
12 * "It all comes from here, the stench and the peril." --Frodo
378cc40b
LW
13 */
14
9cbb5ea2
GS
15/*
16 * This file is the lexer for Perl. It's closely linked to the
4e553d73 17 * parser, perly.y.
ffb4593c
NT
18 *
19 * The main routine is yylex(), which returns the next token.
20 */
21
378cc40b 22#include "EXTERN.h"
864dbfa3 23#define PERL_IN_TOKE_C
378cc40b 24#include "perl.h"
378cc40b 25
d3b6f988
GS
26#define yychar PL_yychar
27#define yylval PL_yylval
28
fc36a67e 29static char ident_too_long[] = "Identifier too long";
4ac733c9 30static char c_without_g[] = "Use of /c modifier is meaningless without /g";
64e578a2 31static char c_in_subst[] = "Use of /c modifier is meaningless in s///";
8903cb82 32
acfe0abc 33static void restore_rsfp(pTHX_ void *f);
6e3aabd6 34#ifndef PERL_NO_UTF16_FILTER
acfe0abc
GS
35static I32 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen);
36static I32 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen);
6e3aabd6 37#endif
51371543 38
9059aa12
LW
39#define XFAKEBRACK 128
40#define XENUMMASK 127
41
39e02b42
JH
42#ifdef USE_UTF8_SCRIPTS
43# define UTF (!IN_BYTES)
2b9d42f0 44#else
746b446a 45# define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || (PL_hints & HINT_UTF8))
2b9d42f0 46#endif
a0ed51b3 47
61f0cdd9 48/* In variables named $^X, these are the legal values for X.
2b92dfce
GS
49 * 1999-02-27 mjd-perl-patch@plover.com */
50#define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
51
bf4acbe4
GS
52/* On MacOS, respect nonbreaking spaces */
53#ifdef MACOS_TRADITIONAL
54#define SPACE_OR_TAB(c) ((c)==' '||(c)=='\312'||(c)=='\t')
55#else
56#define SPACE_OR_TAB(c) ((c)==' '||(c)=='\t')
57#endif
58
ffb4593c
NT
59/* LEX_* are values for PL_lex_state, the state of the lexer.
60 * They are arranged oddly so that the guard on the switch statement
79072805
LW
61 * can get by with a single comparison (if the compiler is smart enough).
62 */
63
fb73857a
PP
64/* #define LEX_NOTPARSING 11 is done in perl.h. */
65
55497cff
PP
66#define LEX_NORMAL 10
67#define LEX_INTERPNORMAL 9
68#define LEX_INTERPCASEMOD 8
69#define LEX_INTERPPUSH 7
70#define LEX_INTERPSTART 6
71#define LEX_INTERPEND 5
72#define LEX_INTERPENDMAYBE 4
73#define LEX_INTERPCONCAT 3
74#define LEX_INTERPCONST 2
75#define LEX_FORMLINE 1
76#define LEX_KNOWNEXT 0
79072805 77
79072805
LW
78#ifdef ff_next
79#undef ff_next
d48672a2
LW
80#endif
81
a1a0e61e 82#ifdef USE_PURE_BISON
dba4d153
JH
83# ifndef YYMAXLEVEL
84# define YYMAXLEVEL 100
85# endif
20141f0e
RI
86YYSTYPE* yylval_pointer[YYMAXLEVEL];
87int* yychar_pointer[YYMAXLEVEL];
6f202aea 88int yyactlevel = -1;
22c35a8c
GS
89# undef yylval
90# undef yychar
20141f0e
RI
91# define yylval (*yylval_pointer[yyactlevel])
92# define yychar (*yychar_pointer[yyactlevel])
93# define PERL_YYLEX_PARAM yylval_pointer[yyactlevel],yychar_pointer[yyactlevel]
4e553d73 94# undef yylex
dba4d153 95# define yylex() Perl_yylex_r(aTHX_ yylval_pointer[yyactlevel],yychar_pointer[yyactlevel])
a1a0e61e
TD
96#endif
97
79072805 98#include "keywords.h"
fe14fcc3 99
ffb4593c
NT
100/* CLINE is a macro that ensures PL_copline has a sane value */
101
ae986130
LW
102#ifdef CLINE
103#undef CLINE
104#endif
57843af0 105#define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
3280af22 106
ffb4593c
NT
107/*
108 * Convenience functions to return different tokens and prime the
9cbb5ea2 109 * lexer for the next token. They all take an argument.
ffb4593c
NT
110 *
111 * TOKEN : generic token (used for '(', DOLSHARP, etc)
112 * OPERATOR : generic operator
113 * AOPERATOR : assignment operator
114 * PREBLOCK : beginning the block after an if, while, foreach, ...
115 * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
116 * PREREF : *EXPR where EXPR is not a simple identifier
117 * TERM : expression term
118 * LOOPX : loop exiting command (goto, last, dump, etc)
119 * FTST : file test operator
120 * FUN0 : zero-argument function
2d2e263d 121 * FUN1 : not used, except for not, which isn't a UNIOP
ffb4593c
NT
122 * BOop : bitwise or or xor
123 * BAop : bitwise and
124 * SHop : shift operator
125 * PWop : power operator
9cbb5ea2 126 * PMop : pattern-matching operator
ffb4593c
NT
127 * Aop : addition-level operator
128 * Mop : multiplication-level operator
129 * Eop : equality-testing operator
e5edeb50 130 * Rop : relational operator <= != gt
ffb4593c
NT
131 *
132 * Also see LOP and lop() below.
133 */
134
075953c3
JH
135/* Note that REPORT() and REPORT2() will be expressions that supply
136 * their own trailing comma, not suitable for statements as such. */
998054bd 137#ifdef DEBUGGING /* Serve -DT. */
075953c3
JH
138# define REPORT(x,retval) tokereport(x,s,(int)retval),
139# define REPORT2(x,retval) tokereport(x,s, yylval.ival),
998054bd 140#else
075953c3
JH
141# define REPORT(x,retval)
142# define REPORT2(x,retval)
998054bd
SC
143#endif
144
075953c3
JH
145#define TOKEN(retval) return (REPORT2("token",retval) PL_bufptr = s,(int)retval)
146#define OPERATOR(retval) return (REPORT2("operator",retval) PL_expect = XTERM, PL_bufptr = s,(int)retval)
147#define AOPERATOR(retval) return ao((REPORT2("aop",retval) PL_expect = XTERM, PL_bufptr = s,(int)retval))
148#define PREBLOCK(retval) return (REPORT2("preblock",retval) PL_expect = XBLOCK,PL_bufptr = s,(int)retval)
149#define PRETERMBLOCK(retval) return (REPORT2("pretermblock",retval) PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval)
150#define PREREF(retval) return (REPORT2("preref",retval) PL_expect = XREF,PL_bufptr = s,(int)retval)
151#define TERM(retval) return (CLINE, REPORT2("term",retval) PL_expect = XOPERATOR, PL_bufptr = s,(int)retval)
152#define LOOPX(f) return(yylval.ival=f, REPORT("loopx",f) PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX)
6f33ba73 153#define FTST(f) return(yylval.ival=f, REPORT("ftst",f) PL_expect = XTERMORDORDOR,PL_bufptr = s,(int)UNIOP)
075953c3
JH
154#define FUN0(f) return(yylval.ival = f, REPORT("fun0",f) PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0)
155#define FUN1(f) return(yylval.ival = f, REPORT("fun1",f) PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1)
156#define BOop(f) return ao((yylval.ival=f, REPORT("bitorop",f) PL_expect = XTERM,PL_bufptr = s,(int)BITOROP))
157#define BAop(f) return ao((yylval.ival=f, REPORT("bitandop",f) PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP))
158#define SHop(f) return ao((yylval.ival=f, REPORT("shiftop",f) PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP))
159#define PWop(f) return ao((yylval.ival=f, REPORT("powop",f) PL_expect = XTERM,PL_bufptr = s,(int)POWOP))
160#define PMop(f) return(yylval.ival=f, REPORT("matchop",f) PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP)
161#define Aop(f) return ao((yylval.ival=f, REPORT("add",f) PL_expect = XTERM,PL_bufptr = s,(int)ADDOP))
162#define Mop(f) return ao((yylval.ival=f, REPORT("mul",f) PL_expect = XTERM,PL_bufptr = s,(int)MULOP))
163#define Eop(f) return(yylval.ival=f, REPORT("eq",f) PL_expect = XTERM,PL_bufptr = s,(int)EQOP)
164#define Rop(f) return(yylval.ival=f, REPORT("rel",f) PL_expect = XTERM,PL_bufptr = s,(int)RELOP)
2f3197b3 165
a687059c
LW
166/* This bit of chicanery makes a unary function followed by
167 * a parenthesis into a function with one argument, highest precedence.
6f33ba73
RGS
168 * The UNIDOR macro is for unary functions that can be followed by the //
169 * operator (such as C<shift // 0>).
a687059c 170 */
6f33ba73 171#define UNI2(f,x) return(yylval.ival = f, \
075953c3 172 REPORT("uni",f) \
6f33ba73 173 PL_expect = x, \
3280af22
NIS
174 PL_bufptr = s, \
175 PL_last_uni = PL_oldbufptr, \
176 PL_last_lop_op = f, \
a687059c 177 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
6f33ba73
RGS
178#define UNI(f) UNI2(f,XTERM)
179#define UNIDOR(f) UNI2(f,XTERMORDORDOR)
a687059c 180
79072805 181#define UNIBRACK(f) return(yylval.ival = f, \
075953c3 182 REPORT("uni",f) \
3280af22
NIS
183 PL_bufptr = s, \
184 PL_last_uni = PL_oldbufptr, \
79072805
LW
185 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
186
9f68db38 187/* grandfather return to old style */
3280af22 188#define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
79072805 189
8fa7f367
JH
190#ifdef DEBUGGING
191
2d00ba3b 192STATIC void
61b2116b 193S_tokereport(pTHX_ char *thing, char* s, I32 rv)
9041c2e3 194{
998054bd 195 DEBUG_T({
9c5ffd7c 196 SV* report = newSVpv(thing, 0);
29b291f7
RB
197 Perl_sv_catpvf(aTHX_ report, ":line %d:%"IVdf":", CopLINE(PL_curcop),
198 (IV)rv);
998054bd
SC
199
200 if (s - PL_bufptr > 0)
201 sv_catpvn(report, PL_bufptr, s - PL_bufptr);
202 else {
203 if (PL_oldbufptr && *PL_oldbufptr)
204 sv_catpv(report, PL_tokenbuf);
205 }
206 PerlIO_printf(Perl_debug_log, "### %s\n", SvPV_nolen(report));
5f80b19c 207 });
998054bd
SC
208}
209
8fa7f367
JH
210#endif
211
ffb4593c
NT
212/*
213 * S_ao
214 *
c963b151
BD
215 * This subroutine detects &&=, ||=, and //= and turns an ANDAND, OROR or DORDOR
216 * into an OP_ANDASSIGN, OP_ORASSIGN, or OP_DORASSIGN
ffb4593c
NT
217 */
218
76e3520e 219STATIC int
cea2e8a9 220S_ao(pTHX_ int toketype)
a0d0e21e 221{
3280af22
NIS
222 if (*PL_bufptr == '=') {
223 PL_bufptr++;
a0d0e21e
LW
224 if (toketype == ANDAND)
225 yylval.ival = OP_ANDASSIGN;
226 else if (toketype == OROR)
227 yylval.ival = OP_ORASSIGN;
c963b151
BD
228 else if (toketype == DORDOR)
229 yylval.ival = OP_DORASSIGN;
a0d0e21e
LW
230 toketype = ASSIGNOP;
231 }
232 return toketype;
233}
234
ffb4593c
NT
235/*
236 * S_no_op
237 * When Perl expects an operator and finds something else, no_op
238 * prints the warning. It always prints "<something> found where
239 * operator expected. It prints "Missing semicolon on previous line?"
240 * if the surprise occurs at the start of the line. "do you need to
241 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
242 * where the compiler doesn't know if foo is a method call or a function.
243 * It prints "Missing operator before end of line" if there's nothing
244 * after the missing operator, or "... before <...>" if there is something
245 * after the missing operator.
246 */
247
76e3520e 248STATIC void
cea2e8a9 249S_no_op(pTHX_ char *what, char *s)
463ee0b2 250{
3280af22
NIS
251 char *oldbp = PL_bufptr;
252 bool is_first = (PL_oldbufptr == PL_linestart);
68dc0745 253
1189a94a
GS
254 if (!s)
255 s = oldbp;
07c798fb 256 else
1189a94a 257 PL_bufptr = s;
cea2e8a9 258 yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
748a9306 259 if (is_first)
cea2e8a9 260 Perl_warn(aTHX_ "\t(Missing semicolon on previous line?)\n");
7e2040f0 261 else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
748a9306 262 char *t;
7e2040f0 263 for (t = PL_oldoldbufptr; *t && (isALNUM_lazy_if(t,UTF) || *t == ':'); t++) ;
3280af22 264 if (t < PL_bufptr && isSPACE(*t))
cea2e8a9 265 Perl_warn(aTHX_ "\t(Do you need to predeclare %.*s?)\n",
3280af22 266 t - PL_oldoldbufptr, PL_oldoldbufptr);
748a9306 267 }
07c798fb
HS
268 else {
269 assert(s >= oldbp);
cea2e8a9 270 Perl_warn(aTHX_ "\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
07c798fb 271 }
3280af22 272 PL_bufptr = oldbp;
8990e307
LW
273}
274
ffb4593c
NT
275/*
276 * S_missingterm
277 * Complain about missing quote/regexp/heredoc terminator.
278 * If it's called with (char *)NULL then it cauterizes the line buffer.
279 * If we're in a delimited string and the delimiter is a control
280 * character, it's reformatted into a two-char sequence like ^C.
281 * This is fatal.
282 */
283
76e3520e 284STATIC void
cea2e8a9 285S_missingterm(pTHX_ char *s)
8990e307
LW
286{
287 char tmpbuf[3];
288 char q;
289 if (s) {
290 char *nl = strrchr(s,'\n');
d2719217 291 if (nl)
8990e307
LW
292 *nl = '\0';
293 }
9d116dd7
JH
294 else if (
295#ifdef EBCDIC
296 iscntrl(PL_multi_close)
297#else
298 PL_multi_close < 32 || PL_multi_close == 127
299#endif
300 ) {
8990e307 301 *tmpbuf = '^';
3280af22 302 tmpbuf[1] = toCTRL(PL_multi_close);
8990e307
LW
303 s = "\\n";
304 tmpbuf[2] = '\0';
305 s = tmpbuf;
306 }
307 else {
eb160463 308 *tmpbuf = (char)PL_multi_close;
8990e307
LW
309 tmpbuf[1] = '\0';
310 s = tmpbuf;
311 }
312 q = strchr(s,'"') ? '\'' : '"';
cea2e8a9 313 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
463ee0b2 314}
79072805 315
ffb4593c
NT
316/*
317 * Perl_deprecate
ffb4593c
NT
318 */
319
79072805 320void
864dbfa3 321Perl_deprecate(pTHX_ char *s)
a0d0e21e 322{
599cee73 323 if (ckWARN(WARN_DEPRECATED))
9014280d 324 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "Use of %s is deprecated", s);
a0d0e21e
LW
325}
326
12bcd1a6
PM
327void
328Perl_deprecate_old(pTHX_ char *s)
329{
330 /* This function should NOT be called for any new deprecated warnings */
331 /* Use Perl_deprecate instead */
332 /* */
333 /* It is here to maintain backward compatibility with the pre-5.8 */
334 /* warnings category hierarchy. The "deprecated" category used to */
335 /* live under the "syntax" category. It is now a top-level category */
336 /* in its own right. */
337
338 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
339 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
340 "Use of %s is deprecated", s);
341}
342
ffb4593c
NT
343/*
344 * depcom
9cbb5ea2 345 * Deprecate a comma-less variable list.
ffb4593c
NT
346 */
347
76e3520e 348STATIC void
cea2e8a9 349S_depcom(pTHX)
a0d0e21e 350{
12bcd1a6 351 deprecate_old("comma-less variable list");
a0d0e21e
LW
352}
353
ffb4593c 354/*
9cbb5ea2
GS
355 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
356 * utf16-to-utf8-reversed.
ffb4593c
NT
357 */
358
c39cd008
GS
359#ifdef PERL_CR_FILTER
360static void
361strip_return(SV *sv)
362{
363 register char *s = SvPVX(sv);
364 register char *e = s + SvCUR(sv);
365 /* outer loop optimized to do nothing if there are no CR-LFs */
366 while (s < e) {
367 if (*s++ == '\r' && *s == '\n') {
368 /* hit a CR-LF, need to copy the rest */
369 register char *d = s - 1;
370 *d++ = *s++;
371 while (s < e) {
372 if (*s == '\r' && s[1] == '\n')
373 s++;
374 *d++ = *s++;
375 }
376 SvCUR(sv) -= s - d;
377 return;
378 }
379 }
380}
a868473f 381
76e3520e 382STATIC I32
c39cd008 383S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
a868473f 384{
c39cd008
GS
385 I32 count = FILTER_READ(idx+1, sv, maxlen);
386 if (count > 0 && !maxlen)
387 strip_return(sv);
388 return count;
a868473f
NIS
389}
390#endif
391
ffb4593c
NT
392/*
393 * Perl_lex_start
9cbb5ea2
GS
394 * Initialize variables. Uses the Perl save_stack to save its state (for
395 * recursive calls to the parser).
ffb4593c
NT
396 */
397
a0d0e21e 398void
864dbfa3 399Perl_lex_start(pTHX_ SV *line)
79072805 400{
8990e307
LW
401 char *s;
402 STRLEN len;
403
3280af22
NIS
404 SAVEI32(PL_lex_dojoin);
405 SAVEI32(PL_lex_brackets);
3280af22
NIS
406 SAVEI32(PL_lex_casemods);
407 SAVEI32(PL_lex_starts);
408 SAVEI32(PL_lex_state);
7766f137 409 SAVEVPTR(PL_lex_inpat);
3280af22 410 SAVEI32(PL_lex_inwhat);
18b09519
GS
411 if (PL_lex_state == LEX_KNOWNEXT) {
412 I32 toke = PL_nexttoke;
413 while (--toke >= 0) {
414 SAVEI32(PL_nexttype[toke]);
415 SAVEVPTR(PL_nextval[toke]);
416 }
417 SAVEI32(PL_nexttoke);
18b09519 418 }
57843af0 419 SAVECOPLINE(PL_curcop);
3280af22
NIS
420 SAVEPPTR(PL_bufptr);
421 SAVEPPTR(PL_bufend);
422 SAVEPPTR(PL_oldbufptr);
423 SAVEPPTR(PL_oldoldbufptr);
207e3d1a
JH
424 SAVEPPTR(PL_last_lop);
425 SAVEPPTR(PL_last_uni);
3280af22
NIS
426 SAVEPPTR(PL_linestart);
427 SAVESPTR(PL_linestr);
8edd5f42
RGS
428 SAVEGENERICPV(PL_lex_brackstack);
429 SAVEGENERICPV(PL_lex_casestack);
c76ac1ee 430 SAVEDESTRUCTOR_X(restore_rsfp, PL_rsfp);
3280af22
NIS
431 SAVESPTR(PL_lex_stuff);
432 SAVEI32(PL_lex_defer);
09bef843 433 SAVEI32(PL_sublex_info.sub_inwhat);
3280af22 434 SAVESPTR(PL_lex_repl);
bebdddfc
GS
435 SAVEINT(PL_expect);
436 SAVEINT(PL_lex_expect);
3280af22
NIS
437
438 PL_lex_state = LEX_NORMAL;
439 PL_lex_defer = 0;
440 PL_expect = XSTATE;
441 PL_lex_brackets = 0;
3280af22
NIS
442 New(899, PL_lex_brackstack, 120, char);
443 New(899, PL_lex_casestack, 12, char);
3280af22
NIS
444 PL_lex_casemods = 0;
445 *PL_lex_casestack = '\0';
446 PL_lex_dojoin = 0;
447 PL_lex_starts = 0;
448 PL_lex_stuff = Nullsv;
449 PL_lex_repl = Nullsv;
450 PL_lex_inpat = 0;
76be56bc 451 PL_nexttoke = 0;
3280af22 452 PL_lex_inwhat = 0;
09bef843 453 PL_sublex_info.sub_inwhat = 0;
3280af22
NIS
454 PL_linestr = line;
455 if (SvREADONLY(PL_linestr))
456 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
457 s = SvPV(PL_linestr, len);
6f27f9a7 458 if (!len || s[len-1] != ';') {
3280af22
NIS
459 if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
460 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
461 sv_catpvn(PL_linestr, "\n;", 2);
8990e307 462 }
3280af22
NIS
463 SvTEMP_off(PL_linestr);
464 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
465 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
207e3d1a 466 PL_last_lop = PL_last_uni = Nullch;
3280af22 467 PL_rsfp = 0;
79072805 468}
a687059c 469
ffb4593c
NT
470/*
471 * Perl_lex_end
9cbb5ea2
GS
472 * Finalizer for lexing operations. Must be called when the parser is
473 * done with the lexer.
ffb4593c
NT
474 */
475
463ee0b2 476void
864dbfa3 477Perl_lex_end(pTHX)
463ee0b2 478{
3280af22 479 PL_doextract = FALSE;
463ee0b2
LW
480}
481
ffb4593c
NT
482/*
483 * S_incline
484 * This subroutine has nothing to do with tilting, whether at windmills
485 * or pinball tables. Its name is short for "increment line". It
57843af0 486 * increments the current line number in CopLINE(PL_curcop) and checks
ffb4593c 487 * to see whether the line starts with a comment of the form
9cbb5ea2
GS
488 * # line 500 "foo.pm"
489 * If so, it sets the current line number and file to the values in the comment.
ffb4593c
NT
490 */
491
76e3520e 492STATIC void
cea2e8a9 493S_incline(pTHX_ char *s)
463ee0b2
LW
494{
495 char *t;
496 char *n;
73659bf1 497 char *e;
463ee0b2 498 char ch;
463ee0b2 499
57843af0 500 CopLINE_inc(PL_curcop);
463ee0b2
LW
501 if (*s++ != '#')
502 return;
bf4acbe4 503 while (SPACE_OR_TAB(*s)) s++;
73659bf1
GS
504 if (strnEQ(s, "line", 4))
505 s += 4;
506 else
507 return;
084592ab 508 if (SPACE_OR_TAB(*s))
73659bf1 509 s++;
4e553d73 510 else
73659bf1 511 return;
bf4acbe4 512 while (SPACE_OR_TAB(*s)) s++;
463ee0b2
LW
513 if (!isDIGIT(*s))
514 return;
515 n = s;
516 while (isDIGIT(*s))
517 s++;
bf4acbe4 518 while (SPACE_OR_TAB(*s))
463ee0b2 519 s++;
73659bf1 520 if (*s == '"' && (t = strchr(s+1, '"'))) {
463ee0b2 521 s++;
73659bf1
GS
522 e = t + 1;
523 }
463ee0b2 524 else {
463ee0b2 525 for (t = s; !isSPACE(*t); t++) ;
73659bf1 526 e = t;
463ee0b2 527 }
bf4acbe4 528 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
73659bf1
GS
529 e++;
530 if (*e != '\n' && *e != '\0')
531 return; /* false alarm */
532
463ee0b2
LW
533 ch = *t;
534 *t = '\0';
f4dd75d9 535 if (t - s > 0) {
05ec9bb3 536 CopFILE_free(PL_curcop);
57843af0 537 CopFILE_set(PL_curcop, s);
f4dd75d9 538 }
463ee0b2 539 *t = ch;
57843af0 540 CopLINE_set(PL_curcop, atoi(n)-1);
463ee0b2
LW
541}
542
ffb4593c
NT
543/*
544 * S_skipspace
545 * Called to gobble the appropriate amount and type of whitespace.
546 * Skips comments as well.
547 */
548
76e3520e 549STATIC char *
cea2e8a9 550S_skipspace(pTHX_ register char *s)
a687059c 551{
3280af22 552 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
bf4acbe4 553 while (s < PL_bufend && SPACE_OR_TAB(*s))
463ee0b2
LW
554 s++;
555 return s;
556 }
557 for (;;) {
fd049845 558 STRLEN prevlen;
09bef843 559 SSize_t oldprevlen, oldoldprevlen;
9c5ffd7c 560 SSize_t oldloplen = 0, oldunilen = 0;
60e6418e
GS
561 while (s < PL_bufend && isSPACE(*s)) {
562 if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
563 incline(s);
564 }
ffb4593c
NT
565
566 /* comment */
3280af22
NIS
567 if (s < PL_bufend && *s == '#') {
568 while (s < PL_bufend && *s != '\n')
463ee0b2 569 s++;
60e6418e 570 if (s < PL_bufend) {
463ee0b2 571 s++;
60e6418e
GS
572 if (PL_in_eval && !PL_rsfp) {
573 incline(s);
574 continue;
575 }
576 }
463ee0b2 577 }
ffb4593c
NT
578
579 /* only continue to recharge the buffer if we're at the end
580 * of the buffer, we're not reading from a source filter, and
581 * we're in normal lexing mode
582 */
09bef843
SB
583 if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat ||
584 PL_lex_state == LEX_FORMLINE)
463ee0b2 585 return s;
ffb4593c
NT
586
587 /* try to recharge the buffer */
9cbb5ea2
GS
588 if ((s = filter_gets(PL_linestr, PL_rsfp,
589 (prevlen = SvCUR(PL_linestr)))) == Nullch)
590 {
591 /* end of file. Add on the -p or -n magic */
3280af22
NIS
592 if (PL_minus_n || PL_minus_p) {
593 sv_setpv(PL_linestr,PL_minus_p ?
08e9d68e
DD
594 ";}continue{print or die qq(-p destination: $!\\n)" :
595 "");
3280af22
NIS
596 sv_catpv(PL_linestr,";}");
597 PL_minus_n = PL_minus_p = 0;
a0d0e21e
LW
598 }
599 else
3280af22 600 sv_setpv(PL_linestr,";");
ffb4593c
NT
601
602 /* reset variables for next time we lex */
9cbb5ea2
GS
603 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
604 = SvPVX(PL_linestr);
3280af22 605 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
207e3d1a 606 PL_last_lop = PL_last_uni = Nullch;
ffb4593c
NT
607
608 /* Close the filehandle. Could be from -P preprocessor,
609 * STDIN, or a regular file. If we were reading code from
610 * STDIN (because the commandline held no -e or filename)
611 * then we don't close it, we reset it so the code can
612 * read from STDIN too.
613 */
614
3280af22
NIS
615 if (PL_preprocess && !PL_in_eval)
616 (void)PerlProc_pclose(PL_rsfp);
617 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
618 PerlIO_clearerr(PL_rsfp);
8990e307 619 else
3280af22
NIS
620 (void)PerlIO_close(PL_rsfp);
621 PL_rsfp = Nullfp;
463ee0b2
LW
622 return s;
623 }
ffb4593c
NT
624
625 /* not at end of file, so we only read another line */
09bef843
SB
626 /* make corresponding updates to old pointers, for yyerror() */
627 oldprevlen = PL_oldbufptr - PL_bufend;
628 oldoldprevlen = PL_oldoldbufptr - PL_bufend;
629 if (PL_last_uni)
630 oldunilen = PL_last_uni - PL_bufend;
631 if (PL_last_lop)
632 oldloplen = PL_last_lop - PL_bufend;
3280af22
NIS
633 PL_linestart = PL_bufptr = s + prevlen;
634 PL_bufend = s + SvCUR(PL_linestr);
635 s = PL_bufptr;
09bef843
SB
636 PL_oldbufptr = s + oldprevlen;
637 PL_oldoldbufptr = s + oldoldprevlen;
638 if (PL_last_uni)
639 PL_last_uni = s + oldunilen;
640 if (PL_last_lop)
641 PL_last_lop = s + oldloplen;
a0d0e21e 642 incline(s);
ffb4593c
NT
643
644 /* debugger active and we're not compiling the debugger code,
645 * so store the line into the debugger's array of lines
646 */
3280af22 647 if (PERLDB_LINE && PL_curstash != PL_debstash) {
8990e307
LW
648 SV *sv = NEWSV(85,0);
649
650 sv_upgrade(sv, SVt_PVMG);
3280af22 651 sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
0ac0412a
MJD
652 (void)SvIOK_on(sv);
653 SvIVX(sv) = 0;
57843af0 654 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
8990e307 655 }
463ee0b2 656 }
a687059c 657}
378cc40b 658
ffb4593c
NT
659/*
660 * S_check_uni
661 * Check the unary operators to ensure there's no ambiguity in how they're
662 * used. An ambiguous piece of code would be:
663 * rand + 5
664 * This doesn't mean rand() + 5. Because rand() is a unary operator,
665 * the +5 is its argument.
666 */
667
76e3520e 668STATIC void
cea2e8a9 669S_check_uni(pTHX)
ba106d47 670{
2f3197b3 671 char *s;
a0d0e21e 672 char *t;
2f3197b3 673
3280af22 674 if (PL_oldoldbufptr != PL_last_uni)
2f3197b3 675 return;
3280af22
NIS
676 while (isSPACE(*PL_last_uni))
677 PL_last_uni++;
7e2040f0 678 for (s = PL_last_uni; isALNUM_lazy_if(s,UTF) || *s == '-'; s++) ;
3280af22 679 if ((t = strchr(s, '(')) && t < PL_bufptr)
a0d0e21e 680 return;
0453d815 681 if (ckWARN_d(WARN_AMBIGUOUS)){
f248d071 682 char ch = *s;
0453d815 683 *s = '\0';
9014280d 684 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
2d5ccbba 685 "Warning: Use of \"%s\" without parentheses is ambiguous",
0453d815
PM
686 PL_last_uni);
687 *s = ch;
688 }
2f3197b3
LW
689}
690
ffb4593c
NT
691/*
692 * LOP : macro to build a list operator. Its behaviour has been replaced
693 * with a subroutine, S_lop() for which LOP is just another name.
694 */
695
a0d0e21e
LW
696#define LOP(f,x) return lop(f,x,s)
697
ffb4593c
NT
698/*
699 * S_lop
700 * Build a list operator (or something that might be one). The rules:
701 * - if we have a next token, then it's a list operator [why?]
702 * - if the next thing is an opening paren, then it's a function
703 * - else it's a list operator
704 */
705
76e3520e 706STATIC I32
a0be28da 707S_lop(pTHX_ I32 f, int x, char *s)
ffed7fef 708{
79072805 709 yylval.ival = f;
35c8bce7 710 CLINE;
075953c3 711 REPORT("lop", f)
3280af22
NIS
712 PL_expect = x;
713 PL_bufptr = s;
714 PL_last_lop = PL_oldbufptr;
eb160463 715 PL_last_lop_op = (OPCODE)f;
3280af22 716 if (PL_nexttoke)
a0d0e21e 717 return LSTOP;
79072805
LW
718 if (*s == '(')
719 return FUNC;
720 s = skipspace(s);
721 if (*s == '(')
722 return FUNC;
723 else
724 return LSTOP;
725}
726
ffb4593c
NT
727/*
728 * S_force_next
9cbb5ea2 729 * When the lexer realizes it knows the next token (for instance,
ffb4593c 730 * it is reordering tokens for the parser) then it can call S_force_next
9cbb5ea2
GS
731 * to know what token to return the next time the lexer is called. Caller
732 * will need to set PL_nextval[], and possibly PL_expect to ensure the lexer
733 * handles the token correctly.
ffb4593c
NT
734 */
735
4e553d73 736STATIC void
cea2e8a9 737S_force_next(pTHX_ I32 type)
79072805 738{
3280af22
NIS
739 PL_nexttype[PL_nexttoke] = type;
740 PL_nexttoke++;
741 if (PL_lex_state != LEX_KNOWNEXT) {
742 PL_lex_defer = PL_lex_state;
743 PL_lex_expect = PL_expect;
744 PL_lex_state = LEX_KNOWNEXT;
79072805
LW
745 }
746}
747
ffb4593c
NT
748/*
749 * S_force_word
750 * When the lexer knows the next thing is a word (for instance, it has
751 * just seen -> and it knows that the next char is a word char, then
752 * it calls S_force_word to stick the next word into the PL_next lookahead.
753 *
754 * Arguments:
b1b65b59 755 * char *start : buffer position (must be within PL_linestr)
ffb4593c
NT
756 * int token : PL_next will be this type of bare word (e.g., METHOD,WORD)
757 * int check_keyword : if true, Perl checks to make sure the word isn't
758 * a keyword (do this if the word is a label, e.g. goto FOO)
759 * int allow_pack : if true, : characters will also be allowed (require,
760 * use, etc. do this)
9cbb5ea2 761 * int allow_initial_tick : used by the "sub" lexer only.
ffb4593c
NT
762 */
763
76e3520e 764STATIC char *
cea2e8a9 765S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
79072805 766{
463ee0b2
LW
767 register char *s;
768 STRLEN len;
4e553d73 769
463ee0b2
LW
770 start = skipspace(start);
771 s = start;
7e2040f0 772 if (isIDFIRST_lazy_if(s,UTF) ||
a0d0e21e 773 (allow_pack && *s == ':') ||
15f0808c 774 (allow_initial_tick && *s == '\'') )
a0d0e21e 775 {
3280af22
NIS
776 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
777 if (check_keyword && keyword(PL_tokenbuf, len))
463ee0b2
LW
778 return start;
779 if (token == METHOD) {
780 s = skipspace(s);
781 if (*s == '(')
3280af22 782 PL_expect = XTERM;
463ee0b2 783 else {
3280af22 784 PL_expect = XOPERATOR;
463ee0b2 785 }
79072805 786 }
3280af22
NIS
787 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(PL_tokenbuf,0));
788 PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
5464dbd2
RGS
789 if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
790 SvUTF8_on(((SVOP*)PL_nextval[PL_nexttoke].opval)->op_sv);
79072805
LW
791 force_next(token);
792 }
793 return s;
794}
795
ffb4593c
NT
796/*
797 * S_force_ident
9cbb5ea2 798 * Called when the lexer wants $foo *foo &foo etc, but the program
ffb4593c
NT
799 * text only contains the "foo" portion. The first argument is a pointer
800 * to the "foo", and the second argument is the type symbol to prefix.
801 * Forces the next token to be a "WORD".
9cbb5ea2 802 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
ffb4593c
NT
803 */
804
76e3520e 805STATIC void
cea2e8a9 806S_force_ident(pTHX_ register char *s, int kind)
79072805
LW
807{
808 if (s && *s) {
11343788 809 OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
3280af22 810 PL_nextval[PL_nexttoke].opval = o;
79072805 811 force_next(WORD);
748a9306 812 if (kind) {
11343788 813 o->op_private = OPpCONST_ENTERED;
55497cff
PP
814 /* XXX see note in pp_entereval() for why we forgo typo
815 warnings if the symbol must be introduced in an eval.
816 GSAR 96-10-12 */
3280af22 817 gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
a0d0e21e
LW
818 kind == '$' ? SVt_PV :
819 kind == '@' ? SVt_PVAV :
820 kind == '%' ? SVt_PVHV :
821 SVt_PVGV
822 );
748a9306 823 }
79072805
LW
824 }
825}
826
1571675a
GS
827NV
828Perl_str_to_version(pTHX_ SV *sv)
829{
830 NV retval = 0.0;
831 NV nshift = 1.0;
832 STRLEN len;
833 char *start = SvPVx(sv,len);
3aa33fe5 834 bool utf = SvUTF8(sv) ? TRUE : FALSE;
1571675a
GS
835 char *end = start + len;
836 while (start < end) {
ba210ebe 837 STRLEN skip;
1571675a
GS
838 UV n;
839 if (utf)
9041c2e3 840 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
1571675a
GS
841 else {
842 n = *(U8*)start;
843 skip = 1;
844 }
845 retval += ((NV)n)/nshift;
846 start += skip;
847 nshift *= 1000;
848 }
849 return retval;
850}
851
4e553d73 852/*
ffb4593c
NT
853 * S_force_version
854 * Forces the next token to be a version number.
e759cc13
RGS
855 * If the next token appears to be an invalid version number, (e.g. "v2b"),
856 * and if "guessing" is TRUE, then no new token is created (and the caller
857 * must use an alternative parsing method).
ffb4593c
NT
858 */
859
76e3520e 860STATIC char *
e759cc13 861S_force_version(pTHX_ char *s, int guessing)
89bfa8cd
PP
862{
863 OP *version = Nullop;
44dcb63b 864 char *d;
89bfa8cd
PP
865
866 s = skipspace(s);
867
44dcb63b 868 d = s;
dd629d5b 869 if (*d == 'v')
44dcb63b 870 d++;
44dcb63b 871 if (isDIGIT(*d)) {
e759cc13
RGS
872 while (isDIGIT(*d) || *d == '_' || *d == '.')
873 d++;
9f3d182e 874 if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
dd629d5b 875 SV *ver;
b73d6f50 876 s = scan_num(s, &yylval);
89bfa8cd 877 version = yylval.opval;
dd629d5b
GS
878 ver = cSVOPx(version)->op_sv;
879 if (SvPOK(ver) && !SvNIOK(ver)) {
155aba94 880 (void)SvUPGRADE(ver, SVt_PVNV);
1571675a
GS
881 SvNVX(ver) = str_to_version(ver);
882 SvNOK_on(ver); /* hint that it is a version */
44dcb63b 883 }
89bfa8cd 884 }
e759cc13
RGS
885 else if (guessing)
886 return s;
89bfa8cd
PP
887 }
888
889 /* NOTE: The parser sees the package name and the VERSION swapped */
3280af22 890 PL_nextval[PL_nexttoke].opval = version;
4e553d73 891 force_next(WORD);
89bfa8cd 892
e759cc13 893 return s;
89bfa8cd
PP
894}
895
ffb4593c
NT
896/*
897 * S_tokeq
898 * Tokenize a quoted string passed in as an SV. It finds the next
899 * chunk, up to end of string or a backslash. It may make a new
900 * SV containing that chunk (if HINT_NEW_STRING is on). It also
901 * turns \\ into \.
902 */
903
76e3520e 904STATIC SV *
cea2e8a9 905S_tokeq(pTHX_ SV *sv)
79072805
LW
906{
907 register char *s;
908 register char *send;
909 register char *d;
b3ac6de7
IZ
910 STRLEN len = 0;
911 SV *pv = sv;
79072805
LW
912
913 if (!SvLEN(sv))
b3ac6de7 914 goto finish;
79072805 915
a0d0e21e 916 s = SvPV_force(sv, len);
21a311ee 917 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
b3ac6de7 918 goto finish;
463ee0b2 919 send = s + len;
79072805
LW
920 while (s < send && *s != '\\')
921 s++;
922 if (s == send)
b3ac6de7 923 goto finish;
79072805 924 d = s;
be4731d2 925 if ( PL_hints & HINT_NEW_STRING ) {
79cb57f6 926 pv = sv_2mortal(newSVpvn(SvPVX(pv), len));
be4731d2
NIS
927 if (SvUTF8(sv))
928 SvUTF8_on(pv);
929 }
79072805
LW
930 while (s < send) {
931 if (*s == '\\') {
a0d0e21e 932 if (s + 1 < send && (s[1] == '\\'))
79072805
LW
933 s++; /* all that, just for this */
934 }
935 *d++ = *s++;
936 }
937 *d = '\0';
463ee0b2 938 SvCUR_set(sv, d - SvPVX(sv));
b3ac6de7 939 finish:
3280af22 940 if ( PL_hints & HINT_NEW_STRING )
b3ac6de7 941 return new_constant(NULL, 0, "q", sv, pv, "q");
79072805
LW
942 return sv;
943}
944
ffb4593c
NT
945/*
946 * Now come three functions related to double-quote context,
947 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
948 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
949 * interact with PL_lex_state, and create fake ( ... ) argument lists
950 * to handle functions and concatenation.
951 * They assume that whoever calls them will be setting up a fake
952 * join call, because each subthing puts a ',' after it. This lets
953 * "lower \luPpEr"
954 * become
955 * join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
956 *
957 * (I'm not sure whether the spurious commas at the end of lcfirst's
958 * arguments and join's arguments are created or not).
959 */
960
961/*
962 * S_sublex_start
963 * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST).
964 *
965 * Pattern matching will set PL_lex_op to the pattern-matching op to
966 * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise).
967 *
968 * OP_CONST and OP_READLINE are easy--just make the new op and return.
969 *
970 * Everything else becomes a FUNC.
971 *
972 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
973 * had an OP_CONST or OP_READLINE). This just sets us up for a
974 * call to S_sublex_push().
975 */
976
76e3520e 977STATIC I32
cea2e8a9 978S_sublex_start(pTHX)
79072805
LW
979{
980 register I32 op_type = yylval.ival;
79072805
LW
981
982 if (op_type == OP_NULL) {
3280af22
NIS
983 yylval.opval = PL_lex_op;
984 PL_lex_op = Nullop;
79072805
LW
985 return THING;
986 }
987 if (op_type == OP_CONST || op_type == OP_READLINE) {
3280af22 988 SV *sv = tokeq(PL_lex_stuff);
b3ac6de7
IZ
989
990 if (SvTYPE(sv) == SVt_PVIV) {
991 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
992 STRLEN len;
993 char *p;
994 SV *nsv;
995
996 p = SvPV(sv, len);
79cb57f6 997 nsv = newSVpvn(p, len);
01ec43d0
GS
998 if (SvUTF8(sv))
999 SvUTF8_on(nsv);
b3ac6de7
IZ
1000 SvREFCNT_dec(sv);
1001 sv = nsv;
4e553d73 1002 }
b3ac6de7 1003 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
3280af22 1004 PL_lex_stuff = Nullsv;
6f33ba73
RGS
1005 /* Allow <FH> // "foo" */
1006 if (op_type == OP_READLINE)
1007 PL_expect = XTERMORDORDOR;
79072805
LW
1008 return THING;
1009 }
1010
3280af22
NIS
1011 PL_sublex_info.super_state = PL_lex_state;
1012 PL_sublex_info.sub_inwhat = op_type;
1013 PL_sublex_info.sub_op = PL_lex_op;
1014 PL_lex_state = LEX_INTERPPUSH;
55497cff 1015
3280af22
NIS
1016 PL_expect = XTERM;
1017 if (PL_lex_op) {
1018 yylval.opval = PL_lex_op;
1019 PL_lex_op = Nullop;
55497cff
PP
1020 return PMFUNC;
1021 }
1022 else
1023 return FUNC;
1024}
1025
ffb4593c
NT
1026/*
1027 * S_sublex_push
1028 * Create a new scope to save the lexing state. The scope will be
1029 * ended in S_sublex_done. Returns a '(', starting the function arguments
1030 * to the uc, lc, etc. found before.
1031 * Sets PL_lex_state to LEX_INTERPCONCAT.
1032 */
1033
76e3520e 1034STATIC I32
cea2e8a9 1035S_sublex_push(pTHX)
55497cff 1036{
f46d017c 1037 ENTER;
55497cff 1038
3280af22
NIS
1039 PL_lex_state = PL_sublex_info.super_state;
1040 SAVEI32(PL_lex_dojoin);
1041 SAVEI32(PL_lex_brackets);
3280af22
NIS
1042 SAVEI32(PL_lex_casemods);
1043 SAVEI32(PL_lex_starts);
1044 SAVEI32(PL_lex_state);
7766f137 1045 SAVEVPTR(PL_lex_inpat);
3280af22 1046 SAVEI32(PL_lex_inwhat);
57843af0 1047 SAVECOPLINE(PL_curcop);
3280af22 1048 SAVEPPTR(PL_bufptr);
8452ff4b 1049 SAVEPPTR(PL_bufend);
3280af22
NIS
1050 SAVEPPTR(PL_oldbufptr);
1051 SAVEPPTR(PL_oldoldbufptr);
207e3d1a
JH
1052 SAVEPPTR(PL_last_lop);
1053 SAVEPPTR(PL_last_uni);
3280af22
NIS
1054 SAVEPPTR(PL_linestart);
1055 SAVESPTR(PL_linestr);
8edd5f42
RGS
1056 SAVEGENERICPV(PL_lex_brackstack);
1057 SAVEGENERICPV(PL_lex_casestack);
3280af22
NIS
1058
1059 PL_linestr = PL_lex_stuff;
1060 PL_lex_stuff = Nullsv;
1061
9cbb5ea2
GS
1062 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
1063 = SvPVX(PL_linestr);
3280af22 1064 PL_bufend += SvCUR(PL_linestr);
207e3d1a 1065 PL_last_lop = PL_last_uni = Nullch;
3280af22
NIS
1066 SAVEFREESV(PL_linestr);
1067
1068 PL_lex_dojoin = FALSE;
1069 PL_lex_brackets = 0;
3280af22
NIS
1070 New(899, PL_lex_brackstack, 120, char);
1071 New(899, PL_lex_casestack, 12, char);
3280af22
NIS
1072 PL_lex_casemods = 0;
1073 *PL_lex_casestack = '\0';
1074 PL_lex_starts = 0;
1075 PL_lex_state = LEX_INTERPCONCAT;
eb160463 1076 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
3280af22
NIS
1077
1078 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1079 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1080 PL_lex_inpat = PL_sublex_info.sub_op;
79072805 1081 else
3280af22 1082 PL_lex_inpat = Nullop;
79072805 1083
55497cff 1084 return '(';
79072805
LW
1085}
1086
ffb4593c
NT
1087/*
1088 * S_sublex_done
1089 * Restores lexer state after a S_sublex_push.
1090 */
1091
76e3520e 1092STATIC I32
cea2e8a9 1093S_sublex_done(pTHX)
79072805 1094{
3280af22 1095 if (!PL_lex_starts++) {
9aa983d2
JH
1096 SV *sv = newSVpvn("",0);
1097 if (SvUTF8(PL_linestr))
1098 SvUTF8_on(sv);
3280af22 1099 PL_expect = XOPERATOR;
9aa983d2 1100 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
79072805
LW
1101 return THING;
1102 }
1103
3280af22
NIS
1104 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
1105 PL_lex_state = LEX_INTERPCASEMOD;
cea2e8a9 1106 return yylex();
79072805
LW
1107 }
1108
ffb4593c 1109 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
3280af22
NIS
1110 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1111 PL_linestr = PL_lex_repl;
1112 PL_lex_inpat = 0;
1113 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1114 PL_bufend += SvCUR(PL_linestr);
207e3d1a 1115 PL_last_lop = PL_last_uni = Nullch;
3280af22
NIS
1116 SAVEFREESV(PL_linestr);
1117 PL_lex_dojoin = FALSE;
1118 PL_lex_brackets = 0;
3280af22
NIS
1119 PL_lex_casemods = 0;
1120 *PL_lex_casestack = '\0';
1121 PL_lex_starts = 0;
25da4f38 1122 if (SvEVALED(PL_lex_repl)) {
3280af22
NIS
1123 PL_lex_state = LEX_INTERPNORMAL;
1124 PL_lex_starts++;
e9fa98b2
HS
1125 /* we don't clear PL_lex_repl here, so that we can check later
1126 whether this is an evalled subst; that means we rely on the
1127 logic to ensure sublex_done() is called again only via the
1128 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
79072805 1129 }
e9fa98b2 1130 else {
3280af22 1131 PL_lex_state = LEX_INTERPCONCAT;
e9fa98b2
HS
1132 PL_lex_repl = Nullsv;
1133 }
79072805 1134 return ',';
ffed7fef
LW
1135 }
1136 else {
f46d017c 1137 LEAVE;
3280af22
NIS
1138 PL_bufend = SvPVX(PL_linestr);
1139 PL_bufend += SvCUR(PL_linestr);
1140 PL_expect = XOPERATOR;
09bef843 1141 PL_sublex_info.sub_inwhat = 0;
79072805 1142 return ')';
ffed7fef
LW
1143 }
1144}
1145
02aa26ce
NT
1146/*
1147 scan_const
1148
1149 Extracts a pattern, double-quoted string, or transliteration. This
1150 is terrifying code.
1151
3280af22
NIS
1152 It looks at lex_inwhat and PL_lex_inpat to find out whether it's
1153 processing a pattern (PL_lex_inpat is true), a transliteration
02aa26ce
NT
1154 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
1155
9b599b2a
GS
1156 Returns a pointer to the character scanned up to. Iff this is
1157 advanced from the start pointer supplied (ie if anything was
1158 successfully parsed), will leave an OP for the substring scanned
1159 in yylval. Caller must intuit reason for not parsing further
1160 by looking at the next characters herself.
1161
02aa26ce
NT
1162 In patterns:
1163 backslashes:
1164 double-quoted style: \r and \n
1165 regexp special ones: \D \s
1166 constants: \x3
1167 backrefs: \1 (deprecated in substitution replacements)
1168 case and quoting: \U \Q \E
1169 stops on @ and $, but not for $ as tail anchor
1170
1171 In transliterations:
1172 characters are VERY literal, except for - not at the start or end
1173 of the string, which indicates a range. scan_const expands the
1174 range to the full set of intermediate characters.
1175
1176 In double-quoted strings:
1177 backslashes:
1178 double-quoted style: \r and \n
1179 constants: \x3
1180 backrefs: \1 (deprecated)
1181 case and quoting: \U \Q \E
1182 stops on @ and $
1183
1184 scan_const does *not* construct ops to handle interpolated strings.
1185 It stops processing as soon as it finds an embedded $ or @ variable
1186 and leaves it to the caller to work out what's going on.
1187
da6eedaa 1188 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @::foo.
02aa26ce
NT
1189
1190 $ in pattern could be $foo or could be tail anchor. Assumption:
1191 it's a tail anchor if $ is the last thing in the string, or if it's
1192 followed by one of ")| \n\t"
1193
1194 \1 (backreferences) are turned into $1
1195
1196 The structure of the code is
1197 while (there's a character to process) {
1198 handle transliteration ranges
1199 skip regexp comments
1200 skip # initiated comments in //x patterns
1201 check for embedded @foo
1202 check for embedded scalars
1203 if (backslash) {
1204 leave intact backslashes from leave (below)
1205 deprecate \1 in strings and sub replacements
1206 handle string-changing backslashes \l \U \Q \E, etc.
1207 switch (what was escaped) {
1208 handle - in a transliteration (becomes a literal -)
1209 handle \132 octal characters
1210 handle 0x15 hex characters
1211 handle \cV (control V)
1212 handle printf backslashes (\f, \r, \n, etc)
1213 } (end switch)
1214 } (end if backslash)
1215 } (end while character to read)
4e553d73 1216
02aa26ce
NT
1217*/
1218
76e3520e 1219STATIC char *
cea2e8a9 1220S_scan_const(pTHX_ char *start)
79072805 1221{
3280af22 1222 register char *send = PL_bufend; /* end of the constant */
02aa26ce
NT
1223 SV *sv = NEWSV(93, send - start); /* sv for the constant */
1224 register char *s = start; /* start of the constant */
1225 register char *d = SvPVX(sv); /* destination for copies */
1226 bool dorange = FALSE; /* are we in a translit range? */
c2e66d9e 1227 bool didrange = FALSE; /* did we just finish a range? */
2b9d42f0
NIS
1228 I32 has_utf8 = FALSE; /* Output constant is UTF8 */
1229 I32 this_utf8 = UTF; /* The source string is assumed to be UTF8 */
012bcf8d
GS
1230 UV uv;
1231
dff6d3cd 1232 const char *leaveit = /* set of acceptably-backslashed characters */
3280af22 1233 PL_lex_inpat
4a2d328f 1234 ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
9b599b2a 1235 : "";
79072805 1236
2b9d42f0
NIS
1237 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1238 /* If we are doing a trans and we know we want UTF8 set expectation */
1239 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
1240 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1241 }
1242
1243
79072805 1244 while (s < send || dorange) {
02aa26ce 1245 /* get transliterations out of the way (they're most literal) */
3280af22 1246 if (PL_lex_inwhat == OP_TRANS) {
02aa26ce 1247 /* expand a range A-Z to the full set of characters. AIE! */
79072805 1248 if (dorange) {
1ba5c669
JH
1249 I32 i; /* current expanded character */
1250 I32 min; /* first character in range */
1251 I32 max; /* last character in range */
02aa26ce 1252
2b9d42f0 1253 if (has_utf8) {
8973db79
JH
1254 char *c = (char*)utf8_hop((U8*)d, -1);
1255 char *e = d++;
1256 while (e-- > c)
1257 *(e + 1) = *e;
25716404 1258 *c = (char)UTF_TO_NATIVE(0xff);
8973db79
JH
1259 /* mark the range as done, and continue */
1260 dorange = FALSE;
1261 didrange = TRUE;
1262 continue;
1263 }
2b9d42f0 1264
02aa26ce 1265 i = d - SvPVX(sv); /* remember current offset */
9cbb5ea2
GS
1266 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
1267 d = SvPVX(sv) + i; /* refresh d after realloc */
02aa26ce
NT
1268 d -= 2; /* eat the first char and the - */
1269
8ada0baa
JH
1270 min = (U8)*d; /* first char in range */
1271 max = (U8)d[1]; /* last char in range */
1272
c2e66d9e 1273 if (min > max) {
01ec43d0 1274 Perl_croak(aTHX_
d1573ac7 1275 "Invalid range \"%c-%c\" in transliteration operator",
1ba5c669 1276 (char)min, (char)max);
c2e66d9e
GS
1277 }
1278
c7f1f016 1279#ifdef EBCDIC
8ada0baa
JH
1280 if ((isLOWER(min) && isLOWER(max)) ||
1281 (isUPPER(min) && isUPPER(max))) {
1282 if (isLOWER(min)) {
1283 for (i = min; i <= max; i++)
1284 if (isLOWER(i))
db42d148 1285 *d++ = NATIVE_TO_NEED(has_utf8,i);
8ada0baa
JH
1286 } else {
1287 for (i = min; i <= max; i++)
1288 if (isUPPER(i))
db42d148 1289 *d++ = NATIVE_TO_NEED(has_utf8,i);
8ada0baa
JH
1290 }
1291 }
1292 else
1293#endif
1294 for (i = min; i <= max; i++)
eb160463 1295 *d++ = (char)i;
02aa26ce
NT
1296
1297 /* mark the range as done, and continue */
79072805 1298 dorange = FALSE;
01ec43d0 1299 didrange = TRUE;
79072805 1300 continue;
4e553d73 1301 }
02aa26ce
NT
1302
1303 /* range begins (ignore - as first or last char) */
79072805 1304 else if (*s == '-' && s+1 < send && s != start) {
4e553d73 1305 if (didrange) {
1fafa243 1306 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
01ec43d0 1307 }
2b9d42f0 1308 if (has_utf8) {
25716404 1309 *d++ = (char)UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */
a0ed51b3
LW
1310 s++;
1311 continue;
1312 }
79072805
LW
1313 dorange = TRUE;
1314 s++;
01ec43d0
GS
1315 }
1316 else {
1317 didrange = FALSE;
1318 }
79072805 1319 }
02aa26ce
NT
1320
1321 /* if we get here, we're not doing a transliteration */
1322
0f5d15d6
IZ
1323 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
1324 except for the last char, which will be done separately. */
3280af22 1325 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
cc6b7395
IZ
1326 if (s[2] == '#') {
1327 while (s < send && *s != ')')
db42d148 1328 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
155aba94
GS
1329 }
1330 else if (s[2] == '{' /* This should match regcomp.c */
1331 || ((s[2] == 'p' || s[2] == '?') && s[3] == '{'))
1332 {
cc6b7395 1333 I32 count = 1;
0f5d15d6 1334 char *regparse = s + (s[2] == '{' ? 3 : 4);
cc6b7395
IZ
1335 char c;
1336
d9f97599
GS
1337 while (count && (c = *regparse)) {
1338 if (c == '\\' && regparse[1])
1339 regparse++;
4e553d73 1340 else if (c == '{')
cc6b7395 1341 count++;
4e553d73 1342 else if (c == '}')
cc6b7395 1343 count--;
d9f97599 1344 regparse++;
cc6b7395 1345 }
5bdf89e7
IZ
1346 if (*regparse != ')') {
1347 regparse--; /* Leave one char for continuation. */
cc6b7395 1348 yyerror("Sequence (?{...}) not terminated or not {}-balanced");
5bdf89e7 1349 }
0f5d15d6 1350 while (s < regparse)
db42d148 1351 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
cc6b7395 1352 }
748a9306 1353 }
02aa26ce
NT
1354
1355 /* likewise skip #-initiated comments in //x patterns */
3280af22
NIS
1356 else if (*s == '#' && PL_lex_inpat &&
1357 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
748a9306 1358 while (s+1 < send && *s != '\n')
db42d148 1359 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
748a9306 1360 }
02aa26ce 1361
5d1d4326 1362 /* check for embedded arrays
da6eedaa 1363 (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
5d1d4326 1364 */
7e2040f0 1365 else if (*s == '@' && s[1]
5d1d4326 1366 && (isALNUM_lazy_if(s+1,UTF) || strchr(":'{$+-", s[1])))
79072805 1367 break;
02aa26ce
NT
1368
1369 /* check for embedded scalars. only stop if we're sure it's a
1370 variable.
1371 */
79072805 1372 else if (*s == '$') {
3280af22 1373 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
79072805 1374 break;
6002328a 1375 if (s + 1 < send && !strchr("()| \r\n\t", s[1]))
79072805
LW
1376 break; /* in regexp, $ might be tail anchor */
1377 }
02aa26ce 1378
2b9d42f0
NIS
1379 /* End of else if chain - OP_TRANS rejoin rest */
1380
02aa26ce 1381 /* backslashes */
79072805
LW
1382 if (*s == '\\' && s+1 < send) {
1383 s++;
02aa26ce
NT
1384
1385 /* some backslashes we leave behind */
c9f97d15 1386 if (*leaveit && *s && strchr(leaveit, *s)) {
db42d148
NIS
1387 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
1388 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
79072805
LW
1389 continue;
1390 }
02aa26ce
NT
1391
1392 /* deprecate \1 in strings and substitution replacements */
3280af22 1393 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
a0d0e21e 1394 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
79072805 1395 {
599cee73 1396 if (ckWARN(WARN_SYNTAX))
9014280d 1397 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
79072805
LW
1398 *--s = '$';
1399 break;
1400 }
02aa26ce
NT
1401
1402 /* string-change backslash escapes */
3280af22 1403 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
79072805
LW
1404 --s;
1405 break;
1406 }
02aa26ce
NT
1407
1408 /* if we get here, it's either a quoted -, or a digit */
79072805 1409 switch (*s) {
02aa26ce
NT
1410
1411 /* quoted - in transliterations */
79072805 1412 case '-':
3280af22 1413 if (PL_lex_inwhat == OP_TRANS) {
79072805
LW
1414 *d++ = *s++;
1415 continue;
1416 }
1417 /* FALL THROUGH */
1418 default:
11b8faa4 1419 {
707afd92
MS
1420 if (ckWARN(WARN_MISC) &&
1421 isALNUM(*s) &&
1422 *s != '_')
9014280d 1423 Perl_warner(aTHX_ packWARN(WARN_MISC),
11b8faa4
JH
1424 "Unrecognized escape \\%c passed through",
1425 *s);
1426 /* default action is to copy the quoted character */
f9a63242 1427 goto default_action;
11b8faa4 1428 }
02aa26ce
NT
1429
1430 /* \132 indicates an octal constant */
79072805
LW
1431 case '0': case '1': case '2': case '3':
1432 case '4': case '5': case '6': case '7':
ba210ebe 1433 {
53305cf1
NC
1434 I32 flags = 0;
1435 STRLEN len = 3;
1436 uv = grok_oct(s, &len, &flags, NULL);
ba210ebe
JH
1437 s += len;
1438 }
012bcf8d 1439 goto NUM_ESCAPE_INSERT;
02aa26ce
NT
1440
1441 /* \x24 indicates a hex constant */
79072805 1442 case 'x':
a0ed51b3
LW
1443 ++s;
1444 if (*s == '{') {
1445 char* e = strchr(s, '}');
a4c04bdc
NC
1446 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
1447 PERL_SCAN_DISALLOW_PREFIX;
53305cf1 1448 STRLEN len;
355860ce 1449
53305cf1 1450 ++s;
adaeee49 1451 if (!e) {
a0ed51b3 1452 yyerror("Missing right brace on \\x{}");
355860ce 1453 continue;
ba210ebe 1454 }
53305cf1
NC
1455 len = e - s;
1456 uv = grok_hex(s, &len, &flags, NULL);
ba210ebe 1457 s = e + 1;
a0ed51b3
LW
1458 }
1459 else {
ba210ebe 1460 {
53305cf1 1461 STRLEN len = 2;
a4c04bdc 1462 I32 flags = PERL_SCAN_DISALLOW_PREFIX;
53305cf1 1463 uv = grok_hex(s, &len, &flags, NULL);
ba210ebe
JH
1464 s += len;
1465 }
012bcf8d
GS
1466 }
1467
1468 NUM_ESCAPE_INSERT:
1469 /* Insert oct or hex escaped character.
301d3d20 1470 * There will always enough room in sv since such
db42d148 1471 * escapes will be longer than any UTF-8 sequence
301d3d20 1472 * they can end up as. */
ba7cea30 1473
c7f1f016
NIS
1474 /* We need to map to chars to ASCII before doing the tests
1475 to cover EBCDIC
1476 */
c4d5f83a 1477 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(uv))) {
9aa983d2 1478 if (!has_utf8 && uv > 255) {
301d3d20
JH
1479 /* Might need to recode whatever we have
1480 * accumulated so far if it contains any
1481 * hibit chars.
1482 *
1483 * (Can't we keep track of that and avoid
1484 * this rescan? --jhi)
012bcf8d 1485 */
c7f1f016 1486 int hicount = 0;
63cd0674
NIS
1487 U8 *c;
1488 for (c = (U8 *) SvPVX(sv); c < (U8 *)d; c++) {
c4d5f83a 1489 if (!NATIVE_IS_INVARIANT(*c)) {
012bcf8d 1490 hicount++;
db42d148 1491 }
012bcf8d 1492 }
63cd0674 1493 if (hicount) {
db42d148
NIS
1494 STRLEN offset = d - SvPVX(sv);
1495 U8 *src, *dst;
1496 d = SvGROW(sv, SvLEN(sv) + hicount + 1) + offset;
1497 src = (U8 *)d - 1;
1498 dst = src+hicount;
1499 d += hicount;
1500 while (src >= (U8 *)SvPVX(sv)) {
c4d5f83a 1501 if (!NATIVE_IS_INVARIANT(*src)) {
63cd0674 1502 U8 ch = NATIVE_TO_ASCII(*src);
eb160463
GS
1503 *dst-- = (U8)UTF8_EIGHT_BIT_LO(ch);
1504 *dst-- = (U8)UTF8_EIGHT_BIT_HI(ch);
012bcf8d
GS
1505 }
1506 else {
63cd0674 1507 *dst-- = *src;
012bcf8d 1508 }
c7f1f016 1509 src--;
012bcf8d
GS
1510 }
1511 }
1512 }
1513
9aa983d2 1514 if (has_utf8 || uv > 255) {
9041c2e3 1515 d = (char*)uvchr_to_utf8((U8*)d, uv);
4e553d73 1516 has_utf8 = TRUE;
f9a63242
JH
1517 if (PL_lex_inwhat == OP_TRANS &&
1518 PL_sublex_info.sub_op) {
1519 PL_sublex_info.sub_op->op_private |=
1520 (PL_lex_repl ? OPpTRANS_FROM_UTF
1521 : OPpTRANS_TO_UTF);
f9a63242 1522 }
012bcf8d 1523 }
a0ed51b3 1524 else {
012bcf8d 1525 *d++ = (char)uv;
a0ed51b3 1526 }
012bcf8d
GS
1527 }
1528 else {
c4d5f83a 1529 *d++ = (char) uv;
a0ed51b3 1530 }
79072805 1531 continue;
02aa26ce 1532
b239daa5 1533 /* \N{LATIN SMALL LETTER A} is a named character */
4a2d328f 1534 case 'N':
55eda711 1535 ++s;
423cee85
JH
1536 if (*s == '{') {
1537 char* e = strchr(s, '}');
155aba94 1538 SV *res;
423cee85
JH
1539 STRLEN len;
1540 char *str;
4e553d73 1541
423cee85 1542 if (!e) {
5777a3f7 1543 yyerror("Missing right brace on \\N{}");
423cee85
JH
1544 e = s - 1;
1545 goto cont_scan;
1546 }
dbc0d4f2
JH
1547 if (e > s + 2 && s[1] == 'U' && s[2] == '+') {
1548 /* \N{U+...} */
1549 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
1550 PERL_SCAN_DISALLOW_PREFIX;
1551 s += 3;
1552 len = e - s;
1553 uv = grok_hex(s, &len, &flags, NULL);
1554 s = e + 1;
1555 goto NUM_ESCAPE_INSERT;
1556 }
55eda711
JH
1557 res = newSVpvn(s + 1, e - s - 1);
1558 res = new_constant( Nullch, 0, "charnames",
1559 res, Nullsv, "\\N{...}" );
f9a63242
JH
1560 if (has_utf8)
1561 sv_utf8_upgrade(res);
423cee85 1562 str = SvPV(res,len);
1c47067b
JH
1563#ifdef EBCDIC_NEVER_MIND
1564 /* charnames uses pack U and that has been
1565 * recently changed to do the below uni->native
1566 * mapping, so this would be redundant (and wrong,
1567 * the code point would be doubly converted).
1568 * But leave this in just in case the pack U change
1569 * gets revoked, but the semantics is still
1570 * desireable for charnames. --jhi */
cddc7ef4
JH
1571 {
1572 UV uv = utf8_to_uvchr((U8*)str, 0);
1573
1574 if (uv < 0x100) {
1575 U8 tmpbuf[UTF8_MAXLEN+1], *d;
1576
1577 d = uvchr_to_utf8(tmpbuf, UNI_TO_NATIVE(uv));
1578 sv_setpvn(res, (char *)tmpbuf, d - tmpbuf);
1579 str = SvPV(res, len);
1580 }
1581 }
1582#endif
89491803 1583 if (!has_utf8 && SvUTF8(res)) {
f08d6ad9
GS
1584 char *ostart = SvPVX(sv);
1585 SvCUR_set(sv, d - ostart);
1586 SvPOK_on(sv);
e4f3eed8 1587 *d = '\0';
f08d6ad9 1588 sv_utf8_upgrade(sv);
d2f449dd 1589 /* this just broke our allocation above... */
eb160463 1590 SvGROW(sv, (STRLEN)(send - start));
f08d6ad9 1591 d = SvPVX(sv) + SvCUR(sv);
89491803 1592 has_utf8 = TRUE;
f08d6ad9 1593 }
eb160463 1594 if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
423cee85
JH
1595 char *odest = SvPVX(sv);
1596
8973db79 1597 SvGROW(sv, (SvLEN(sv) + len - (e - s + 4)));
423cee85
JH
1598 d = SvPVX(sv) + (d - odest);
1599 }
1600 Copy(str, d, len, char);
1601 d += len;
1602 SvREFCNT_dec(res);
1603 cont_scan:
1604 s = e + 1;
1605 }
1606 else
5777a3f7 1607 yyerror("Missing braces on \\N{}");
423cee85
JH
1608 continue;
1609
02aa26ce 1610 /* \c is a control character */
79072805
LW
1611 case 'c':
1612 s++;
961ce445 1613 if (s < send) {
ba210ebe 1614 U8 c = *s++;
c7f1f016
NIS
1615#ifdef EBCDIC
1616 if (isLOWER(c))
1617 c = toUPPER(c);
1618#endif
db42d148 1619 *d++ = NATIVE_TO_NEED(has_utf8,toCTRL(c));
ba210ebe 1620 }
961ce445
RGS
1621 else {
1622 yyerror("Missing control char name in \\c");
1623 }
79072805 1624 continue;
02aa26ce
NT
1625
1626 /* printf-style backslashes, formfeeds, newlines, etc */
79072805 1627 case 'b':
db42d148 1628 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
79072805
LW
1629 break;
1630 case 'n':
db42d148 1631 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
79072805
LW
1632 break;
1633 case 'r':
db42d148 1634 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
79072805
LW
1635 break;
1636 case 'f':
db42d148 1637 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
79072805
LW
1638 break;
1639 case 't':
db42d148 1640 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
79072805 1641 break;
34a3fe2a 1642 case 'e':
db42d148 1643 *d++ = ASCII_TO_NEED(has_utf8,'\033');
34a3fe2a
PP
1644 break;
1645 case 'a':
db42d148 1646 *d++ = ASCII_TO_NEED(has_utf8,'\007');
79072805 1647 break;
02aa26ce
NT
1648 } /* end switch */
1649
79072805
LW
1650 s++;
1651 continue;
02aa26ce
NT
1652 } /* end if (backslash) */
1653
f9a63242 1654 default_action:
2b9d42f0
NIS
1655 /* If we started with encoded form, or already know we want it
1656 and then encode the next character */
1657 if ((has_utf8 || this_utf8) && !NATIVE_IS_INVARIANT((U8)(*s))) {
1658 STRLEN len = 1;
1659 UV uv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
1660 STRLEN need = UNISKIP(NATIVE_TO_UNI(uv));
1661 s += len;
1662 if (need > len) {
1663 /* encoded value larger than old, need extra space (NOTE: SvCUR() not set here) */
1664 STRLEN off = d - SvPVX(sv);
1665 d = SvGROW(sv, SvLEN(sv) + (need-len)) + off;
1666 }
1667 d = (char*)uvchr_to_utf8((U8*)d, uv);
1668 has_utf8 = TRUE;
1669 }
1670 else {
1671 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1672 }
02aa26ce
NT
1673 } /* while loop to process each character */
1674
1675 /* terminate the string and set up the sv */
79072805 1676 *d = '\0';
463ee0b2 1677 SvCUR_set(sv, d - SvPVX(sv));
2b9d42f0 1678 if (SvCUR(sv) >= SvLEN(sv))
d0063567 1679 Perl_croak(aTHX_ "panic: constant overflowed allocated space");
2b9d42f0 1680
79072805 1681 SvPOK_on(sv);
9f4817db 1682 if (PL_encoding && !has_utf8) {
d0063567
DK
1683 sv_recode_to_utf8(sv, PL_encoding);
1684 if (SvUTF8(sv))
1685 has_utf8 = TRUE;
9f4817db 1686 }
2b9d42f0 1687 if (has_utf8) {
7e2040f0 1688 SvUTF8_on(sv);
2b9d42f0 1689 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
d0063567 1690 PL_sublex_info.sub_op->op_private |=
2b9d42f0
NIS
1691 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1692 }
1693 }
79072805 1694
02aa26ce 1695 /* shrink the sv if we allocated more than we used */
79072805
LW
1696 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1697 SvLEN_set(sv, SvCUR(sv) + 1);
463ee0b2 1698 Renew(SvPVX(sv), SvLEN(sv), char);
79072805 1699 }
02aa26ce 1700
9b599b2a 1701 /* return the substring (via yylval) only if we parsed anything */
3280af22
NIS
1702 if (s > PL_bufptr) {
1703 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
4e553d73 1704 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
b3ac6de7 1705 sv, Nullsv,
4e553d73 1706 ( PL_lex_inwhat == OP_TRANS
b3ac6de7 1707 ? "tr"
3280af22 1708 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
b3ac6de7
IZ
1709 ? "s"
1710 : "qq")));
79072805 1711 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
b3ac6de7 1712 } else
8990e307 1713 SvREFCNT_dec(sv);
79072805
LW
1714 return s;
1715}
1716
ffb4593c
NT
1717/* S_intuit_more
1718 * Returns TRUE if there's more to the expression (e.g., a subscript),
1719 * FALSE otherwise.
ffb4593c
NT
1720 *
1721 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
1722 *
1723 * ->[ and ->{ return TRUE
1724 * { and [ outside a pattern are always subscripts, so return TRUE
1725 * if we're outside a pattern and it's not { or [, then return FALSE
1726 * if we're in a pattern and the first char is a {
1727 * {4,5} (any digits around the comma) returns FALSE
1728 * if we're in a pattern and the first char is a [
1729 * [] returns FALSE
1730 * [SOMETHING] has a funky algorithm to decide whether it's a
1731 * character class or not. It has to deal with things like
1732 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
1733 * anything else returns TRUE
1734 */
1735
9cbb5ea2
GS
1736/* This is the one truly awful dwimmer necessary to conflate C and sed. */
1737
76e3520e 1738STATIC int
cea2e8a9 1739S_intuit_more(pTHX_ register char *s)
79072805 1740{
3280af22 1741 if (PL_lex_brackets)
79072805
LW
1742 return TRUE;
1743 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1744 return TRUE;
1745 if (*s != '{' && *s != '[')
1746 return FALSE;
3280af22 1747 if (!PL_lex_inpat)
79072805
LW
1748 return TRUE;
1749
1750 /* In a pattern, so maybe we have {n,m}. */
1751 if (*s == '{') {
1752 s++;
1753 if (!isDIGIT(*s))
1754 return TRUE;
1755 while (isDIGIT(*s))
1756 s++;
1757 if (*s == ',')
1758 s++;
1759 while (isDIGIT(*s))
1760 s++;
1761 if (*s == '}')
1762 return FALSE;
1763 return TRUE;
1764
1765 }
1766
1767 /* On the other hand, maybe we have a character class */
1768
1769 s++;
1770 if (*s == ']' || *s == '^')
1771 return FALSE;
1772 else {
ffb4593c 1773 /* this is terrifying, and it works */
79072805
LW
1774 int weight = 2; /* let's weigh the evidence */
1775 char seen[256];
f27ffc4a 1776 unsigned char un_char = 255, last_un_char;
93a17b20 1777 char *send = strchr(s,']');
3280af22 1778 char tmpbuf[sizeof PL_tokenbuf * 4];
79072805
LW
1779
1780 if (!send) /* has to be an expression */
1781 return TRUE;
1782
1783 Zero(seen,256,char);
1784 if (*s == '$')
1785 weight -= 3;
1786 else if (isDIGIT(*s)) {
1787 if (s[1] != ']') {
1788 if (isDIGIT(s[1]) && s[2] == ']')
1789 weight -= 10;
1790 }
1791 else
1792 weight -= 100;
1793 }
1794 for (; s < send; s++) {
1795 last_un_char = un_char;
1796 un_char = (unsigned char)*s;
1797 switch (*s) {
1798 case '@':
1799 case '&':
1800 case '$':
1801 weight -= seen[un_char] * 10;
7e2040f0 1802 if (isALNUM_lazy_if(s+1,UTF)) {
8903cb82 1803 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
a0d0e21e 1804 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
79072805
LW
1805 weight -= 100;
1806 else
1807 weight -= 10;
1808 }
1809 else if (*s == '$' && s[1] &&
93a17b20
LW
1810 strchr("[#!%*<>()-=",s[1])) {
1811 if (/*{*/ strchr("])} =",s[2]))
79072805
LW
1812 weight -= 10;
1813 else
1814 weight -= 1;
1815 }
1816 break;
1817 case '\\':
1818 un_char = 254;
1819 if (s[1]) {
93a17b20 1820 if (strchr("wds]",s[1]))
79072805
LW
1821 weight += 100;
1822 else if (seen['\''] || seen['"'])
1823 weight += 1;
93a17b20 1824 else if (strchr("rnftbxcav",s[1]))
79072805
LW
1825 weight += 40;
1826 else if (isDIGIT(s[1])) {
1827 weight += 40;
1828 while (s[1] && isDIGIT(s[1]))
1829 s++;
1830 }
1831 }
1832 else
1833 weight += 100;
1834 break;
1835 case '-':
1836 if (s[1] == '\\')
1837 weight += 50;
93a17b20 1838 if (strchr("aA01! ",last_un_char))
79072805 1839 weight += 30;
93a17b20 1840 if (strchr("zZ79~",s[1]))
79072805 1841 weight += 30;
f27ffc4a
GS
1842 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1843 weight -= 5; /* cope with negative subscript */
79072805
LW
1844 break;
1845 default:
93a17b20 1846 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
79072805
LW
1847 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1848 char *d = tmpbuf;
1849 while (isALPHA(*s))
1850 *d++ = *s++;
1851 *d = '\0';
1852 if (keyword(tmpbuf, d - tmpbuf))
1853 weight -= 150;
1854 }
1855 if (un_char == last_un_char + 1)
1856 weight += 5;
1857 weight -= seen[un_char];
1858 break;
1859 }
1860 seen[un_char]++;
1861 }
1862 if (weight >= 0) /* probably a character class */
1863 return FALSE;
1864 }
1865
1866 return TRUE;
1867}
ffed7fef 1868
ffb4593c
NT
1869/*
1870 * S_intuit_method
1871 *
1872 * Does all the checking to disambiguate
1873 * foo bar
1874 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
1875 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
1876 *
1877 * First argument is the stuff after the first token, e.g. "bar".
1878 *
1879 * Not a method if bar is a filehandle.
1880 * Not a method if foo is a subroutine prototyped to take a filehandle.
1881 * Not a method if it's really "Foo $bar"
1882 * Method if it's "foo $bar"
1883 * Not a method if it's really "print foo $bar"
1884 * Method if it's really "foo package::" (interpreted as package->foo)
8f8cf39c 1885 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
3cb0bbe5 1886 * Not a method if bar is a filehandle or package, but is quoted with
ffb4593c
NT
1887 * =>
1888 */
1889
76e3520e 1890STATIC int
cea2e8a9 1891S_intuit_method(pTHX_ char *start, GV *gv)
a0d0e21e
LW
1892{
1893 char *s = start + (*start == '$');
3280af22 1894 char tmpbuf[sizeof PL_tokenbuf];
a0d0e21e
LW
1895 STRLEN len;
1896 GV* indirgv;
1897
1898 if (gv) {
b6c543e3 1899 CV *cv;
a0d0e21e
LW
1900 if (GvIO(gv))
1901 return 0;
b6c543e3
IZ
1902 if ((cv = GvCVu(gv))) {
1903 char *proto = SvPVX(cv);
1904 if (proto) {
1905 if (*proto == ';')
1906 proto++;
1907 if (*proto == '*')
1908 return 0;
1909 }
1910 } else
a0d0e21e
LW
1911 gv = 0;
1912 }
8903cb82 1913 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
ffb4593c
NT
1914 /* start is the beginning of the possible filehandle/object,
1915 * and s is the end of it
1916 * tmpbuf is a copy of it
1917 */
1918
a0d0e21e 1919 if (*start == '$') {
3280af22 1920 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
a0d0e21e
LW
1921 return 0;
1922 s = skipspace(s);
3280af22
NIS
1923 PL_bufptr = start;
1924 PL_expect = XREF;
a0d0e21e
LW
1925 return *s == '(' ? FUNCMETH : METHOD;
1926 }
1927 if (!keyword(tmpbuf, len)) {
c3e0f903
GS
1928 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1929 len -= 2;
1930 tmpbuf[len] = '\0';
1931 goto bare_package;
1932 }
1933 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
8ebc5c01 1934 if (indirgv && GvCVu(indirgv))
a0d0e21e
LW
1935 return 0;
1936 /* filehandle or package name makes it a method */
89bfa8cd 1937 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
a0d0e21e 1938 s = skipspace(s);
3280af22 1939 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
55497cff 1940 return 0; /* no assumptions -- "=>" quotes bearword */
c3e0f903 1941 bare_package:
3280af22 1942 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
79cb57f6 1943 newSVpvn(tmpbuf,len));
3280af22
NIS
1944 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1945 PL_expect = XTERM;
a0d0e21e 1946 force_next(WORD);
3280af22 1947 PL_bufptr = s;
a0d0e21e
LW
1948 return *s == '(' ? FUNCMETH : METHOD;
1949 }
1950 }
1951 return 0;
1952}
1953
ffb4593c
NT
1954/*
1955 * S_incl_perldb
1956 * Return a string of Perl code to load the debugger. If PERL5DB
1957 * is set, it will return the contents of that, otherwise a
1958 * compile-time require of perl5db.pl.
1959 */
1960
76e3520e 1961STATIC char*
cea2e8a9 1962S_incl_perldb(pTHX)
a0d0e21e 1963{
3280af22 1964 if (PL_perldb) {
76e3520e 1965 char *pdb = PerlEnv_getenv("PERL5DB");
a0d0e21e
LW
1966
1967 if (pdb)
1968 return pdb;
93189314 1969 SETERRNO(0,SS_NORMAL);
a0d0e21e
LW
1970 return "BEGIN { require 'perl5db.pl' }";
1971 }
1972 return "";
1973}
1974
1975
16d20bd9 1976/* Encoded script support. filter_add() effectively inserts a
4e553d73 1977 * 'pre-processing' function into the current source input stream.
16d20bd9
AD
1978 * Note that the filter function only applies to the current source file
1979 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1980 *
1981 * The datasv parameter (which may be NULL) can be used to pass
1982 * private data to this instance of the filter. The filter function
1983 * can recover the SV using the FILTER_DATA macro and use it to
1984 * store private buffers and state information.
1985 *
1986 * The supplied datasv parameter is upgraded to a PVIO type
4755096e 1987 * and the IoDIRP/IoANY field is used to store the function pointer,
e0c19803 1988 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
16d20bd9
AD
1989 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1990 * private use must be set using malloc'd pointers.
1991 */
16d20bd9
AD
1992
1993SV *
864dbfa3 1994Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
16d20bd9 1995{
f4c556ac
GS
1996 if (!funcp)
1997 return Nullsv;
1998
3280af22
NIS
1999 if (!PL_rsfp_filters)
2000 PL_rsfp_filters = newAV();
16d20bd9 2001 if (!datasv)
8c52afec 2002 datasv = NEWSV(255,0);
16d20bd9 2003 if (!SvUPGRADE(datasv, SVt_PVIO))
cea2e8a9 2004 Perl_die(aTHX_ "Can't upgrade filter_add data to SVt_PVIO");
4755096e 2005 IoANY(datasv) = (void *)funcp; /* stash funcp into spare field */
e0c19803 2006 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
f4c556ac 2007 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
fe5a182c 2008 (void*)funcp, SvPV_nolen(datasv)));
3280af22
NIS
2009 av_unshift(PL_rsfp_filters, 1);
2010 av_store(PL_rsfp_filters, 0, datasv) ;
16d20bd9
AD
2011 return(datasv);
2012}
4e553d73 2013
16d20bd9
AD
2014
2015/* Delete most recently added instance of this filter function. */
a0d0e21e 2016void
864dbfa3 2017Perl_filter_del(pTHX_ filter_t funcp)
16d20bd9 2018{
e0c19803 2019 SV *datasv;
fe5a182c 2020 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", (void*)funcp));
3280af22 2021 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
16d20bd9
AD
2022 return;
2023 /* if filter is on top of stack (usual case) just pop it off */
e0c19803 2024 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
4755096e 2025 if (IoANY(datasv) == (void *)funcp) {
e0c19803 2026 IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
4755096e 2027 IoANY(datasv) = (void *)NULL;
3280af22 2028 sv_free(av_pop(PL_rsfp_filters));
e50aee73 2029
16d20bd9
AD
2030 return;
2031 }
2032 /* we need to search for the correct entry and clear it */
cea2e8a9 2033 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
16d20bd9
AD
2034}
2035
2036
2037/* Invoke the n'th filter function for the current rsfp. */
2038I32
864dbfa3 2039Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
4e553d73
NIS
2040
2041
8ac85365 2042 /* 0 = read one text line */
a0d0e21e 2043{
16d20bd9
AD
2044 filter_t funcp;
2045 SV *datasv = NULL;
e50aee73 2046
3280af22 2047 if (!PL_rsfp_filters)
16d20bd9 2048 return -1;
3280af22 2049 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
16d20bd9
AD
2050 /* Provide a default input filter to make life easy. */
2051 /* Note that we append to the line. This is handy. */
f4c556ac
GS
2052 DEBUG_P(PerlIO_printf(Perl_debug_log,
2053 "filter_read %d: from rsfp\n", idx));
4e553d73 2054 if (maxlen) {
16d20bd9
AD
2055 /* Want a block */
2056 int len ;
2057 int old_len = SvCUR(buf_sv) ;
2058
2059 /* ensure buf_sv is large enough */
eb160463 2060 SvGROW(buf_sv, (STRLEN)(old_len + maxlen)) ;
3280af22
NIS
2061 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
2062 if (PerlIO_error(PL_rsfp))
37120919
AD
2063 return -1; /* error */
2064 else
2065 return 0 ; /* end of file */
2066 }
16d20bd9
AD
2067 SvCUR_set(buf_sv, old_len + len) ;
2068 } else {
2069 /* Want a line */
3280af22
NIS
2070 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
2071 if (PerlIO_error(PL_rsfp))
37120919
AD
2072 return -1; /* error */
2073 else
2074 return 0 ; /* end of file */
2075 }
16d20bd9
AD
2076 }
2077 return SvCUR(buf_sv);
2078 }
2079 /* Skip this filter slot if filter has been deleted */
3280af22 2080 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
f4c556ac
GS
2081 DEBUG_P(PerlIO_printf(Perl_debug_log,
2082 "filter_read %d: skipped (filter deleted)\n",
2083 idx));
16d20bd9
AD
2084 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
2085 }
2086 /* Get function pointer hidden within datasv */
4755096e 2087 funcp = (filter_t)IoANY(datasv);
f4c556ac
GS
2088 DEBUG_P(PerlIO_printf(Perl_debug_log,
2089 "filter_read %d: via function %p (%s)\n",
fe5a182c 2090 idx, (void*)funcp, SvPV_nolen(datasv)));
16d20bd9
AD
2091 /* Call function. The function is expected to */
2092 /* call "FILTER_READ(idx+1, buf_sv)" first. */
37120919 2093 /* Return: <0:error, =0:eof, >0:not eof */
acfe0abc 2094 return (*funcp)(aTHX_ idx, buf_sv, maxlen);
16d20bd9
AD
2095}
2096
76e3520e 2097STATIC char *
cea2e8a9 2098S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
16d20bd9 2099{
c39cd008 2100#ifdef PERL_CR_FILTER
3280af22 2101 if (!PL_rsfp_filters) {
c39cd008 2102 filter_add(S_cr_textfilter,NULL);
a868473f
NIS
2103 }
2104#endif
3280af22 2105 if (PL_rsfp_filters) {
16d20bd9 2106
55497cff
PP
2107 if (!append)
2108 SvCUR_set(sv, 0); /* start with empty line */
16d20bd9
AD
2109 if (FILTER_READ(0, sv, 0) > 0)
2110 return ( SvPVX(sv) ) ;
2111 else
2112 return Nullch ;
2113 }
9d116dd7 2114 else
fd049845 2115 return (sv_gets(sv, fp, append));
a0d0e21e
LW
2116}
2117
01ec43d0
GS
2118STATIC HV *
2119S_find_in_my_stash(pTHX_ char *pkgname, I32 len)
def3634b
GS
2120{
2121 GV *gv;
2122
01ec43d0 2123 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
def3634b
GS
2124 return PL_curstash;
2125
2126 if (len > 2 &&
2127 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
01ec43d0
GS
2128 (gv = gv_fetchpv(pkgname, FALSE, SVt_PVHV)))
2129 {
2130 return GvHV(gv); /* Foo:: */
def3634b
GS
2131 }
2132
2133 /* use constant CLASS => 'MyClass' */
2134 if ((gv = gv_fetchpv(pkgname, FALSE, SVt_PVCV))) {
2135 SV *sv;
2136 if (GvCV(gv) && (sv = cv_const_sv(GvCV(gv)))) {
2137 pkgname = SvPV_nolen(sv);
2138 }
2139 }
2140
2141 return gv_stashpv(pkgname, FALSE);
2142}
a0d0e21e 2143
748a9306
LW
2144#ifdef DEBUGGING
2145 static char* exp_name[] =
09bef843 2146 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
27308ded 2147 "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
09bef843 2148 };
748a9306 2149#endif
463ee0b2 2150
02aa26ce
NT
2151/*
2152 yylex
2153
2154 Works out what to call the token just pulled out of the input
2155 stream. The yacc parser takes care of taking the ops we return and
2156 stitching them into a tree.
2157
2158 Returns:
2159 PRIVATEREF
2160
2161 Structure:
2162 if read an identifier
2163 if we're in a my declaration
2164 croak if they tried to say my($foo::bar)
2165 build the ops for a my() declaration
2166 if it's an access to a my() variable
2167 are we in a sort block?
2168 croak if my($a); $a <=> $b
2169 build ops for access to a my() variable
2170 if in a dq string, and they've said @foo and we can't find @foo
2171 croak
2172 build ops for a bareword
2173 if we already built the token before, use it.
2174*/
2175
dba4d153 2176#ifdef USE_PURE_BISON
864dbfa3 2177int
dba4d153 2178Perl_yylex_r(pTHX_ YYSTYPE *lvalp, int *lcharp)
378cc40b 2179{
20141f0e
RI
2180 int r;
2181
6f202aea 2182 yyactlevel++;
20141f0e
RI
2183 yylval_pointer[yyactlevel] = lvalp;
2184 yychar_pointer[yyactlevel] = lcharp;
b73d6f50
RI
2185 if (yyactlevel >= YYMAXLEVEL)
2186 Perl_croak(aTHX_ "panic: YYMAXLEVEL");
20141f0e 2187
dba4d153 2188 r = Perl_yylex(aTHX);
20141f0e 2189
d8ae6756
RI
2190 if (yyactlevel > 0)
2191 yyactlevel--;
20141f0e
RI
2192
2193 return r;
2194}
dba4d153 2195#endif
20141f0e 2196
dba4d153
JH
2197#ifdef __SC__
2198#pragma segment Perl_yylex
2199#endif
dba4d153 2200int
dba4d153 2201Perl_yylex(pTHX)
20141f0e 2202{
79072805 2203 register char *s;
378cc40b 2204 register char *d;
79072805 2205 register I32 tmp;
463ee0b2 2206 STRLEN len;
161b471a
NIS
2207 GV *gv = Nullgv;
2208 GV **gvp = 0;
aa7440fb 2209 bool bof = FALSE;
1d239bbb 2210 I32 orig_keyword = 0;
a687059c 2211
02aa26ce 2212 /* check if there's an identifier for us to look at */
ba979b31 2213 if (PL_pending_ident)
e930465f 2214 return S_pending_ident(aTHX);
bbce6d69 2215
02aa26ce
NT
2216 /* no identifier pending identification */
2217
3280af22 2218 switch (PL_lex_state) {
79072805
LW
2219#ifdef COMMENTARY
2220 case LEX_NORMAL: /* Some compilers will produce faster */
2221 case LEX_INTERPNORMAL: /* code if we comment these out. */
2222 break;
2223#endif
2224
09bef843 2225 /* when we've already built the next token, just pull it out of the queue */
79072805 2226 case LEX_KNOWNEXT:
3280af22
NIS
2227 PL_nexttoke--;
2228 yylval = PL_nextval[PL_nexttoke];
2229 if (!PL_nexttoke) {
2230 PL_lex_state = PL_lex_defer;
2231 PL_expect = PL_lex_expect;
2232 PL_lex_defer = LEX_NORMAL;
463ee0b2 2233 }
607df283 2234 DEBUG_T({ PerlIO_printf(Perl_debug_log,
4659c93f 2235 "### Next token after '%s' was known, type %"IVdf"\n", PL_bufptr,
5f80b19c 2236 (IV)PL_nexttype[PL_nexttoke]); });
607df283 2237
3280af22 2238 return(PL_nexttype[PL_nexttoke]);
79072805 2239
02aa26ce 2240 /* interpolated case modifiers like \L \U, including \Q and \E.
3280af22 2241 when we get here, PL_bufptr is at the \
02aa26ce 2242 */
79072805
LW
2243 case LEX_INTERPCASEMOD:
2244#ifdef DEBUGGING
3280af22 2245 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
cea2e8a9 2246 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
79072805 2247#endif
02aa26ce 2248 /* handle \E or end of string */
3280af22 2249 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
a0d0e21e 2250 char oldmod;
02aa26ce
NT
2251
2252 /* if at a \E */
3280af22
NIS
2253 if (PL_lex_casemods) {
2254 oldmod = PL_lex_casestack[--PL_lex_casemods];
2255 PL_lex_casestack[PL_lex_casemods] = '\0';
02aa26ce 2256
3280af22
NIS
2257 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
2258 PL_bufptr += 2;
2259 PL_lex_state = LEX_INTERPCONCAT;
a0d0e21e 2260 }
79072805
LW
2261 return ')';
2262 }
3280af22
NIS
2263 if (PL_bufptr != PL_bufend)
2264 PL_bufptr += 2;
2265 PL_lex_state = LEX_INTERPCONCAT;
cea2e8a9 2266 return yylex();
79072805
LW
2267 }
2268 else {
607df283 2269 DEBUG_T({ PerlIO_printf(Perl_debug_log,
5f80b19c 2270 "### Saw case modifier at '%s'\n", PL_bufptr); });
3280af22 2271 s = PL_bufptr + 1;
6e909404
JH
2272 if (s[1] == '\\' && s[2] == 'E') {
2273 PL_bufptr = s + 3;
2274 PL_lex_state = LEX_INTERPCONCAT;
2275 return yylex();
a0d0e21e 2276 }
6e909404
JH
2277 else {
2278 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
2279 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
2280 if (strchr("LU", *s) &&
2281 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) {
2282 PL_lex_casestack[--PL_lex_casemods] = '\0';
2283 return ')';
2284 }
2285 if (PL_lex_casemods > 10)
2286 Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
2287 PL_lex_casestack[PL_lex_casemods++] = *s;
2288 PL_lex_casestack[PL_lex_casemods] = '\0';
2289 PL_lex_state = LEX_INTERPCONCAT;
2290 PL_nextval[PL_nexttoke].ival = 0;
2291 force_next('(');
2292 if (*s == 'l')
2293 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
2294 else if (*s == 'u')
2295 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
2296 else if (*s == 'L')
2297 PL_nextval[PL_nexttoke].ival = OP_LC;
2298 else if (*s == 'U')
2299 PL_nextval[PL_nexttoke].ival = OP_UC;
2300 else if (*s == 'Q')
2301 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
2302 else
2303 Perl_croak(aTHX_ "panic: yylex");
2304 PL_bufptr = s + 1;
a0d0e21e 2305 }
79072805 2306 force_next(FUNC);
3280af22
NIS
2307 if (PL_lex_starts) {
2308 s = PL_bufptr;
2309 PL_lex_starts = 0;
79072805
LW
2310 Aop(OP_CONCAT);
2311 }
2312 else
cea2e8a9 2313 return yylex();
79072805
LW
2314 }
2315
55497cff
PP
2316 case LEX_INTERPPUSH:
2317 return sublex_push();
2318
79072805 2319 case LEX_INTERPSTART:
3280af22 2320 if (PL_bufptr == PL_bufend)
79072805 2321 return sublex_done();
607df283 2322 DEBUG_T({ PerlIO_printf(Perl_debug_log,
5f80b19c 2323 "### Interpolated variable at '%s'\n", PL_bufptr); });
3280af22
NIS
2324 PL_expect = XTERM;
2325 PL_lex_dojoin = (*PL_bufptr == '@');
2326 PL_lex_state = LEX_INTERPNORMAL;
2327 if (PL_lex_dojoin) {
2328 PL_nextval[PL_nexttoke].ival = 0;
79072805 2329 force_next(',');
a0d0e21e 2330 force_ident("\"", '$');
3280af22 2331 PL_nextval[PL_nexttoke].ival = 0;
79072805 2332 force_next('$');
3280af22 2333 PL_nextval[PL_nexttoke].ival = 0;
79072805 2334 force_next('(');
3280af22 2335 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
79072805
LW
2336 force_next(FUNC);
2337 }
3280af22
NIS
2338 if (PL_lex_starts++) {
2339 s = PL_bufptr;
79072805
LW
2340 Aop(OP_CONCAT);
2341 }
cea2e8a9 2342 return yylex();
79072805
LW
2343
2344 case LEX_INTERPENDMAYBE:
3280af22
NIS
2345 if (intuit_more(PL_bufptr)) {
2346 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
79072805
LW
2347 break;
2348 }
2349 /* FALL THROUGH */
2350
2351 case LEX_INTERPEND:
3280af22
NIS
2352 if (PL_lex_dojoin) {
2353 PL_lex_dojoin = FALSE;
2354 PL_lex_state = LEX_INTERPCONCAT;
79072805
LW
2355 return ')';
2356 }
43a16006 2357 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
25da4f38 2358 && SvEVALED(PL_lex_repl))
43a16006 2359 {
e9fa98b2 2360 if (PL_bufptr != PL_bufend)
cea2e8a9 2361 Perl_croak(aTHX_ "Bad evalled substitution pattern");
e9fa98b2
HS
2362 PL_lex_repl = Nullsv;
2363 }
79072805
LW
2364 /* FALLTHROUGH */
2365 case LEX_INTERPCONCAT:
2366#ifdef DEBUGGING
3280af22 2367 if (PL_lex_brackets)
cea2e8a9 2368 Perl_croak(aTHX_ "panic: INTERPCONCAT");
79072805 2369#endif
3280af22 2370 if (PL_bufptr == PL_bufend)
79072805
LW
2371 return sublex_done();
2372
3280af22
NIS
2373 if (SvIVX(PL_linestr) == '\'') {
2374 SV *sv = newSVsv(PL_linestr);
2375 if (!PL_lex_inpat)
76e3520e 2376 sv = tokeq(sv);
3280af22 2377 else if ( PL_hints & HINT_NEW_RE )
b3ac6de7 2378 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
79072805 2379 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3280af22 2380 s = PL_bufend;
79072805
LW
2381 }
2382 else {
3280af22 2383 s = scan_const(PL_bufptr);
79072805 2384 if (*s == '\\')
3280af22 2385 PL_lex_state = LEX_INTERPCASEMOD;
79072805 2386 else
3280af22 2387 PL_lex_state = LEX_INTERPSTART;
79072805
LW
2388 }
2389
3280af22
NIS
2390 if (s != PL_bufptr) {
2391 PL_nextval[PL_nexttoke] = yylval;
2392 PL_expect = XTERM;
79072805 2393 force_next(THING);
3280af22 2394 if (PL_lex_starts++)
79072805
LW
2395 Aop(OP_CONCAT);
2396 else {
3280af22 2397 PL_bufptr = s;
cea2e8a9 2398 return yylex();
79072805
LW
2399 }
2400 }
2401
cea2e8a9 2402 return yylex();
a0d0e21e 2403 case LEX_FORMLINE:
3280af22
NIS
2404 PL_lex_state = LEX_NORMAL;
2405 s = scan_formline(PL_bufptr);
2406 if (!PL_lex_formbrack)
a0d0e21e
LW
2407 goto rightbracket;
2408 OPERATOR(';');
79072805
LW
2409 }
2410
3280af22
NIS
2411 s = PL_bufptr;
2412 PL_oldoldbufptr = PL_oldbufptr;
2413 PL_oldbufptr = s;
607df283 2414 DEBUG_T( {
bf49b057
GS
2415 PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at %s\n",
2416 exp_name[PL_expect], s);
5f80b19c 2417 } );
463ee0b2
LW
2418
2419 retry:
378cc40b
LW
2420 switch (*s) {
2421 default:
7e2040f0 2422 if (isIDFIRST_lazy_if(s,UTF))
834a4ddd 2423 goto keylookup;
cea2e8a9 2424 Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
e929a76b
LW
2425 case 4:
2426 case 26:
2427 goto fake_eof; /* emulate EOF on ^D or ^Z */
378cc40b 2428 case 0:
3280af22
NIS
2429 if (!PL_rsfp) {
2430 PL_last_uni = 0;
2431 PL_last_lop = 0;
2432 if (PL_lex_brackets)
d98d5fff 2433 yyerror("Missing right curly or square bracket");
4e553d73 2434 DEBUG_T( { PerlIO_printf(Perl_debug_log,
607df283 2435 "### Tokener got EOF\n");
5f80b19c 2436 } );
79072805 2437 TOKEN(0);
463ee0b2 2438 }
3280af22 2439 if (s++ < PL_bufend)
a687059c 2440 goto retry; /* ignore stray nulls */
3280af22
NIS
2441 PL_last_uni = 0;
2442 PL_last_lop = 0;
2443 if (!PL_in_eval && !PL_preambled) {
2444 PL_preambled = TRUE;
2445 sv_setpv(PL_linestr,incl_perldb());
2446 if (SvCUR(PL_linestr))
2447 sv_catpv(PL_linestr,";");
2448 if (PL_preambleav){
2449 while(AvFILLp(PL_preambleav) >= 0) {
2450 SV *tmpsv = av_shift(PL_preambleav);
2451 sv_catsv(PL_linestr, tmpsv);
2452 sv_catpv(PL_linestr, ";");
91b7def8
PP
2453 sv_free(tmpsv);
2454 }
3280af22
NIS
2455 sv_free((SV*)PL_preambleav);
2456 PL_preambleav = NULL;
91b7def8 2457 }
3280af22
NIS
2458 if (PL_minus_n || PL_minus_p) {
2459 sv_catpv(PL_linestr, "LINE: while (<>) {");
2460 if (PL_minus_l)
2461 sv_catpv(PL_linestr,"chomp;");
2462 if (PL_minus_a) {
3280af22
NIS
2463 if (PL_minus_F) {
2464 if (strchr("/'\"", *PL_splitstr)
2465 && strchr(PL_splitstr + 1, *PL_splitstr))
3db68c4c 2466 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
54310121
PP
2467 else {
2468 char delim;
2469 s = "'~#\200\1'"; /* surely one char is unused...*/
3280af22 2470 while (s[1] && strchr(PL_splitstr, *s)) s++;
54310121 2471 delim = *s;
75c72d73 2472 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s%c",
46fc3d4c 2473 "q" + (delim == '\''), delim);
3280af22 2474 for (s = PL_splitstr; *s; s++) {
54310121 2475 if (*s == '\\')
3280af22
NIS
2476 sv_catpvn(PL_linestr, "\\", 1);
2477 sv_catpvn(PL_linestr, s, 1);
54310121 2478 }
cea2e8a9 2479 Perl_sv_catpvf(aTHX_ PL_linestr, "%c);", delim);
54310121 2480 }
2304df62
AD
2481 }
2482 else
75c72d73 2483 sv_catpv(PL_linestr,"our @F=split(' ');");
2304df62 2484 }
79072805 2485 }
3280af22
NIS
2486 sv_catpv(PL_linestr, "\n");
2487 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2488 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
207e3d1a 2489 PL_last_lop = PL_last_uni = Nullch;
3280af22 2490 if (PERLDB_LINE && PL_curstash != PL_debstash) {
a0d0e21e
LW
2491 SV *sv = NEWSV(85,0);
2492
2493 sv_upgrade(sv, SVt_PVMG);
3280af22 2494 sv_setsv(sv,PL_linestr);
0ac0412a
MJD
2495 (void)SvIOK_on(sv);
2496 SvIVX(sv) = 0;
57843af0 2497 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
a0d0e21e 2498 }
79072805 2499 goto retry;
a687059c 2500 }
e929a76b 2501 do {
aa7440fb 2502 bof = PL_rsfp ? TRUE : FALSE;
7e28d3af
JH
2503 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
2504 fake_eof:
2505 if (PL_rsfp) {
2506 if (PL_preprocess && !PL_in_eval)
2507 (void)PerlProc_pclose(PL_rsfp);
2508 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2509 PerlIO_clearerr(PL_rsfp);
2510 else
2511 (void)PerlIO_close(PL_rsfp);
2512 PL_rsfp = Nullfp;
2513 PL_doextract = FALSE;
2514 }
2515 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2516 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
2517 sv_catpv(PL_linestr,";}");
2518 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2519 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
207e3d1a 2520 PL_last_lop = PL_last_uni = Nullch;
7e28d3af
JH
2521 PL_minus_n = PL_minus_p = 0;
2522 goto retry;
2523 }
2524 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
207e3d1a 2525 PL_last_lop = PL_last_uni = Nullch;
7e28d3af
JH
2526 sv_setpv(PL_linestr,"");
2527 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
2528 }
2529 /* if it looks like the start of a BOM, check if it in fact is */
2530 else if (bof && (!*s || *(U8*)s == 0xEF || *(U8*)s >= 0xFE)) {
226017aa 2531#ifdef PERLIO_IS_STDIO
e3f494f1
JH
2532# ifdef __GNU_LIBRARY__
2533# if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
226017aa
DD
2534# define FTELL_FOR_PIPE_IS_BROKEN
2535# endif
e3f494f1
JH
2536# else
2537# ifdef __GLIBC__
2538# if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
2539# define FTELL_FOR_PIPE_IS_BROKEN
2540# endif
2541# endif
226017aa
DD
2542# endif
2543#endif
2544#ifdef FTELL_FOR_PIPE_IS_BROKEN
2545 /* This loses the possibility to detect the bof
2546 * situation on perl -P when the libc5 is being used.
2547 * Workaround? Maybe attach some extra state to PL_rsfp?
2548 */
2549 if (!PL_preprocess)
7e28d3af 2550 bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
226017aa 2551#else
eb160463 2552 bof = PerlIO_tell(PL_rsfp) == (Off_t)SvCUR(PL_linestr);
226017aa 2553#endif
7e28d3af 2554 if (bof) {
3280af22 2555 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7e28d3af 2556 s = swallow_bom((U8*)s);
e929a76b 2557 }
378cc40b 2558 }
3280af22 2559 if (PL_doextract) {
a0d0e21e
LW
2560 /* Incest with pod. */
2561 if (*s == '=' && strnEQ(s, "=cut", 4)) {
3280af22
NIS
2562 sv_setpv(PL_linestr, "");
2563 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2564 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
207e3d1a 2565 PL_last_lop = PL_last_uni = Nullch;
3280af22 2566 PL_doextract = FALSE;
a0d0e21e 2567 }
4e553d73 2568 }
463ee0b2 2569 incline(s);
3280af22
NIS
2570 } while (PL_doextract);
2571 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2572 if (PERLDB_LINE && PL_curstash != PL_debstash) {
79072805 2573 SV *sv = NEWSV(85,0);
a687059c 2574
93a17b20 2575 sv_upgrade(sv, SVt_PVMG);
3280af22 2576 sv_setsv(sv,PL_linestr);
0ac0412a
MJD
2577 (void)SvIOK_on(sv);
2578 SvIVX(sv) = 0;
57843af0 2579 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
a687059c 2580 }
3280af22 2581 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
207e3d1a 2582 PL_last_lop = PL_last_uni = Nullch;
57843af0 2583 if (CopLINE(PL_curcop) == 1) {
3280af22 2584 while (s < PL_bufend && isSPACE(*s))
79072805 2585 s++;
a0d0e21e 2586 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
79072805 2587 s++;
44a8e56a 2588 d = Nullch;
3280af22 2589 if (!PL_in_eval) {
44a8e56a
PP
2590 if (*s == '#' && *(s+1) == '!')
2591 d = s + 2;
2592#ifdef ALTERNATE_SHEBANG
2593 else {
2594 static char as[] = ALTERNATE_SHEBANG;
2595 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2596 d = s + (sizeof(as) - 1);
2597 }
2598#endif /* ALTERNATE_SHEBANG */
2599 }
2600 if (d) {
b8378b72 2601 char *ipath;
774d564b 2602 char *ipathend;
b8378b72 2603
774d564b 2604 while (isSPACE(*d))
b8378b72
CS
2605 d++;
2606 ipath = d;
774d564b
PP
2607 while (*d && !isSPACE(*d))
2608 d++;
2609 ipathend = d;
2610
2611#ifdef ARG_ZERO_IS_SCRIPT
2612 if (ipathend > ipath) {
2613 /*
2614 * HP-UX (at least) sets argv[0] to the script name,
2615 * which makes $^X incorrect. And Digital UNIX and Linux,
2616 * at least, set argv[0] to the basename of the Perl
2617 * interpreter. So, having found "#!", we'll set it right.
2618 */
ee2f7564 2619 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV)); /* $^X */
774d564b 2620 assert(SvPOK(x) || SvGMAGICAL(x));
cc49e20b 2621 if (sv_eq(x, CopFILESV(PL_curcop))) {
774d564b 2622 sv_setpvn(x, ipath, ipathend - ipath);
9607fc9c
PP
2623 SvSETMAGIC(x);
2624 }
556c1dec
JH
2625 else {
2626 STRLEN blen;
2627 STRLEN llen;
2628 char *bstart = SvPV(CopFILESV(PL_curcop),blen);
2629 char *lstart = SvPV(x,llen);
2630 if (llen < blen) {
2631 bstart += blen - llen;
2632 if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
2633 sv_setpvn(x, ipath, ipathend - ipath);
2634 SvSETMAGIC(x);
2635 }
2636 }
2637 }
774d564b 2638 TAINT_NOT; /* $^X is always tainted, but that's OK */
8ebc5c01 2639 }
774d564b 2640#endif /* ARG_ZERO_IS_SCRIPT */
b8378b72
CS
2641
2642 /*
2643 * Look for options.
2644 */
748a9306 2645 d = instr(s,"perl -");
84e30d1a 2646 if (!d) {
748a9306 2647 d = instr(s,"perl");
84e30d1a
GS
2648#if defined(DOSISH)
2649 /* avoid getting into infinite loops when shebang
2650 * line contains "Perl" rather than "perl" */
2651 if (!d) {
2652 for (d = ipathend-4; d >= ipath; --d) {
2653 if ((*d == 'p' || *d == 'P')
2654 && !ibcmp(d, "perl", 4))
2655 {
2656 break;
2657 }
2658 }
2659 if (d < ipath)
2660 d = Nullch;
2661 }
2662#endif
2663 }
44a8e56a
PP
2664#ifdef ALTERNATE_SHEBANG
2665 /*
2666 * If the ALTERNATE_SHEBANG on this system starts with a
2667 * character that can be part of a Perl expression, then if
2668 * we see it but not "perl", we're probably looking at the
2669 * start of Perl code, not a request to hand off to some
2670 * other interpreter. Similarly, if "perl" is there, but
2671 * not in the first 'word' of the line, we assume the line
2672 * contains the start of the Perl program.
44a8e56a
PP
2673 */
2674 if (d && *s != '#') {
774d564b 2675 char *c = ipath;
44a8e56a
PP
2676 while (*c && !strchr("; \t\r\n\f\v#", *c))
2677 c++;
2678 if (c < d)
2679 d = Nullch; /* "perl" not in first word; ignore */
2680 else
2681 *s = '#'; /* Don't try to parse shebang line */
2682 }
774d564b 2683#endif /* ALTERNATE_SHEBANG */
bf4acbe4 2684#ifndef MACOS_TRADITIONAL
748a9306 2685 if (!d &&
44a8e56a 2686 *s == '#' &&
774d564b 2687 ipathend > ipath &&
3280af22 2688 !PL_minus_c &&
748a9306 2689 !instr(s,"indir") &&
3280af22 2690 instr(PL_origargv[0],"perl"))
748a9306 2691 {
9f68db38 2692 char **newargv;
9f68db38 2693
774d564b
PP
2694 *ipathend = '\0';
2695 s = ipathend + 1;
3280af22 2696 while (s < PL_bufend && isSPACE(*s))
9f68db38 2697 s++;
3280af22
NIS
2698 if (s < PL_bufend) {
2699 Newz(899,newargv,PL_origargc+3,char*);
9f68db38 2700 newargv[1] = s;
3280af22 2701 while (s < PL_bufend && !isSPACE(*s))
9f68db38
LW
2702 s++;
2703 *s = '\0';
3280af22 2704 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
9f68db38
LW
2705 }
2706 else
3280af22 2707 newargv = PL_origargv;
774d564b 2708 newargv[0] = ipath;
b35112e7 2709 PERL_FPU_PRE_EXEC
b4748376 2710 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
b35112e7 2711 PERL_FPU_POST_EXEC
cea2e8a9 2712 Perl_croak(aTHX_ "Can't exec %s", ipath);
9f68db38 2713 }
bf4acbe4 2714#endif
748a9306 2715 if (d) {
3280af22
NIS
2716 U32 oldpdb = PL_perldb;
2717 bool oldn = PL_minus_n;
2718 bool oldp = PL_minus_p;
748a9306
LW
2719
2720 while (*d && !isSPACE(*d)) d++;
bf4acbe4 2721 while (SPACE_OR_TAB(*d)) d++;
748a9306
LW
2722
2723 if (*d++ == '-') {
a11ec5a9 2724 bool switches_done = PL_doswitches;
8cc95fdb
PP
2725 do {
2726 if (*d == 'M' || *d == 'm') {
2727 char *m = d;
2728 while (*d && !isSPACE(*d)) d++;
cea2e8a9 2729 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
8cc95fdb
PP
2730 (int)(d - m), m);
2731 }
2732 d = moreswitches(d);
2733 } while (d);
f0b2cf55
YST
2734 if (PL_doswitches && !switches_done) {
2735 int argc = PL_origargc;
2736 char **argv = PL_origargv;
2737 do {
2738 argc--,argv++;
2739 } while (argc && argv[0][0] == '-' && argv[0][1]);
2740 init_argv_symbols(argc,argv);
2741 }
155aba94
GS
2742 if ((PERLDB_LINE && !oldpdb) ||
2743 ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
b084f20b
PP
2744 /* if we have already added "LINE: while (<>) {",
2745 we must not do it again */
748a9306 2746 {
3280af22
NIS
2747 sv_setpv(PL_linestr, "");
2748 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2749 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
207e3d1a 2750 PL_last_lop = PL_last_uni = Nullch;
3280af22 2751 PL_preambled = FALSE;
84902520 2752 if (PERLDB_LINE)
3280af22 2753 (void)gv_fetchfile(PL_origfilename);
748a9306
LW
2754 goto retry;
2755 }
a11ec5a9
RGS
2756 if (PL_doswitches && !switches_done) {
2757 int argc = PL_origargc;
2758 char **argv = PL_origargv;
2759 do {
2760 argc--,argv++;
2761 } while (argc && argv[0][0] == '-' && argv[0][1]);
2762 init_argv_symbols(argc,argv);
2763 }
a0d0e21e 2764 }
79072805 2765 }
9f68db38 2766 }
79072805 2767 }
3280af22
NIS
2768 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2769 PL_bufptr = s;
2770 PL_lex_state = LEX_FORMLINE;
cea2e8a9 2771 return yylex();
ae986130 2772 }
378cc40b 2773 goto retry;
4fdae800 2774 case '\r':
6a27c188 2775#ifdef PERL_STRICT_CR
cea2e8a9 2776 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
4e553d73 2777 Perl_croak(aTHX_
cc507455 2778 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
a868473f 2779#endif
4fdae800 2780 case ' ': case '\t': case '\f': case 013:
bf4acbe4
GS
2781#ifdef MACOS_TRADITIONAL
2782 case '\312':
2783#endif
378cc40b
LW
2784 s++;
2785 goto retry;
378cc40b 2786 case '#':
e929a76b 2787 case '\n':
3280af22 2788 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
df0deb90
GS
2789 if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
2790 /* handle eval qq[#line 1 "foo"\n ...] */
2791 CopLINE_dec(PL_curcop);
2792 incline(s);
2793 }
3280af22 2794 d = PL_bufend;
a687059c 2795 while (s < d && *s != '\n')
378cc40b 2796 s++;
0f85fab0 2797 if (s < d)
378cc40b 2798 s++;
78c267c1 2799 else if (s > d) /* Found by Ilya: feed random input to Perl. */
a8406387 2800 Perl_croak(aTHX_ "panic: input overflow");
463ee0b2 2801 incline(s);
3280af22
NIS
2802 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2803 PL_bufptr = s;
2804 PL_lex_state = LEX_FORMLINE;
cea2e8a9 2805 return yylex();
a687059c 2806 }
378cc40b 2807 }
a687059c 2808 else {
378cc40b 2809 *s = '\0';
3280af22 2810 PL_bufend = s;
a687059c 2811 }
378cc40b
LW
2812 goto retry;
2813 case '-':
79072805 2814 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
e5edeb50
JH
2815 I32 ftst = 0;
2816
378cc40b 2817 s++;
3280af22 2818 PL_bufptr = s;
748a9306
LW
2819 tmp = *s++;
2820
bf4acbe4 2821 while (s < PL_bufend && SPACE_OR_TAB(*s))
748a9306
LW
2822 s++;
2823
2824 if (strnEQ(s,"=>",2)) {
3280af22 2825 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
4e553d73 2826 DEBUG_T( { PerlIO_printf(Perl_debug_log,
607df283 2827 "### Saw unary minus before =>, forcing word '%s'\n", s);
5f80b19c 2828 } );
748a9306
LW
2829 OPERATOR('-'); /* unary minus */
2830 }
3280af22 2831 PL_last_uni = PL_oldbufptr;
748a9306 2832 switch (tmp) {
e5edeb50
JH
2833 case 'r': ftst = OP_FTEREAD; break;
2834 case 'w': ftst = OP_FTEWRITE; break;
2835 case 'x': ftst = OP_FTEEXEC; break;
2836 case 'o': ftst = OP_FTEOWNED; break;
2837 case 'R': ftst = OP_FTRREAD; break;
2838 case 'W': ftst = OP_FTRWRITE; break;
2839 case 'X': ftst = OP_FTREXEC; break;
2840 case 'O': ftst = OP_FTROWNED; break;
2841 case 'e': ftst = OP_FTIS; break;
2842 case 'z': ftst = OP_FTZERO; break;
2843 case 's': ftst = OP_FTSIZE; break;
2844 case 'f': ftst = OP_FTFILE; break;
2845 case 'd': ftst = OP_FTDIR; break;
2846 case 'l': ftst = OP_FTLINK; break;
2847 case 'p': ftst = OP_FTPIPE; break;
2848 case 'S': ftst = OP_FTSOCK; break;
2849 case 'u': ftst = OP_FTSUID; break;
2850 case 'g': ftst = OP_FTSGID; break;
2851 case 'k': ftst = OP_FTSVTX; break;
2852 case 'b': ftst = OP_FTBLK; break;
2853 case 'c': ftst = OP_FTCHR; break;
2854 case 't': ftst = OP_FTTTY; break;
2855 case 'T': ftst = OP_FTTEXT; break;
2856 case 'B': ftst = OP_FTBINARY; break;
2857 case 'M': case 'A': case 'C':
2858 gv_fetchpv("\024",TRUE, SVt_PV);
2859 switch (tmp) {
2860 case 'M': ftst = OP_FTMTIME; break;
2861 case 'A': ftst = OP_FTATIME; break;
2862 case 'C': ftst = OP_FTCTIME; break;
2863 default: break;
2864 }
2865 break;
378cc40b 2866 default:
378cc40b
LW
2867 break;
2868 }
e5edeb50 2869 if (ftst) {
eb160463 2870 PL_last_lop_op = (OPCODE)ftst;
4e553d73 2871 DEBUG_T( { PerlIO_printf(Perl_debug_log,
0844c848 2872 "### Saw file test %c\n", (int)ftst);
5f80b19c 2873 } );
e5edeb50
JH
2874 FTST(ftst);
2875 }
2876 else {
2877 /* Assume it was a minus followed by a one-letter named
2878 * subroutine call (or a -bareword), then. */
95c31fe3 2879 DEBUG_T( { PerlIO_printf(Perl_debug_log,
0844c848
RB
2880 "### %c looked like a file test but was not\n",
2881 (int)ftst);
5f80b19c 2882 } );
e5edeb50
JH
2883 s -= 2;
2884 }
378cc40b 2885 }
a687059c
LW
2886 tmp = *s++;
2887 if (*s == tmp) {
2888 s++;
3280af22 2889 if (PL_expect == XOPERATOR)
79072805
LW
2890 TERM(POSTDEC);
2891 else
2892 OPERATOR(PREDEC);
2893 }
2894 else if (*s == '>') {
2895 s++;
2896 s = skipspace(s);
7e2040f0 2897 if (isIDFIRST_lazy_if(s,UTF)) {
a0d0e21e 2898 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
463ee0b2 2899 TOKEN(ARROW);
79072805 2900 }
748a9306
LW
2901 else if (*s == '$')
2902 OPERATOR(ARROW);
463ee0b2 2903 else
748a9306 2904 TERM(ARROW);
a687059c 2905 }
3280af22 2906 if (PL_expect == XOPERATOR)
79072805
LW
2907 Aop(OP_SUBTRACT);
2908 else {
3280af22 2909 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2f3197b3 2910 check_uni();
79072805 2911 OPERATOR('-'); /* unary minus */
2f3197b3 2912 }
79072805 2913
378cc40b 2914 case '+':
a687059c
LW
2915 tmp = *s++;
2916 if (*s == tmp) {
378cc40b 2917 s++;
3280af22 2918 if (PL_expect == XOPERATOR)
79072805
LW
2919 TERM(POSTINC);
2920 else
2921 OPERATOR(PREINC);
378cc40b 2922 }
3280af22 2923 if (PL_expect == XOPERATOR)
79072805
LW
2924 Aop(OP_ADD);
2925 else {
3280af22 2926 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2f3197b3 2927 check_uni();
a687059c 2928 OPERATOR('+');
2f3197b3 2929 }
a687059c 2930
378cc40b 2931 case '*':
3280af22
NIS
2932 if (PL_expect != XOPERATOR) {
2933 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2934 PL_expect = XOPERATOR;
2935 force_ident(PL_tokenbuf, '*');
2936 if (!*PL_tokenbuf)
a0d0e21e 2937 PREREF('*');
79072805 2938 TERM('*');
a687059c 2939 }
79072805
LW
2940 s++;
2941 if (*s == '*') {
a687059c 2942 s++;
79072805 2943 PWop(OP_POW);
a687059c 2944 }
79072805
LW
2945 Mop(OP_MULTIPLY);
2946
378cc40b 2947 case '%':
3280af22 2948 if (PL_expect == XOPERATOR) {
bbce6d69
PP
2949 ++s;
2950 Mop(OP_MODULO);
a687059c 2951 }
3280af22
NIS
2952 PL_tokenbuf[0] = '%';
2953 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2954 if (!PL_tokenbuf[1]) {
bbce6d69 2955 PREREF('%');
a687059c 2956 }
3280af22 2957 PL_pending_ident = '%';
bbce6d69 2958 TERM('%');
a687059c 2959
378cc40b 2960 case '^':
79072805 2961 s++;
a0d0e21e 2962 BOop(OP_BIT_XOR);
79072805 2963 case '[':
3280af22 2964 PL_lex_brackets++;
79072805 2965 /* FALL THROUGH */
378cc40b 2966 case '~':
378cc40b 2967 case ',':
378cc40b
LW
2968 tmp = *s++;
2969 OPERATOR(tmp);
a0d0e21e
LW
2970 case ':':
2971 if (s[1] == ':') {
2972 len = 0;
2973 goto just_a_word;
2974 }
2975 s++;
09bef843
SB
2976 switch (PL_expect) {
2977 OP *attrs;
2978 case XOPERATOR:
2979 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
2980 break;
2981 PL_bufptr = s; /* update in case we back off */
2982 goto grabattrs;
2983 case XATTRBLOCK:
2984 PL_expect = XBLOCK;
2985 goto grabattrs;
2986 case XATTRTERM:
2987 PL_expect = XTERMBLOCK;
2988 grabattrs:
2989 s = skipspace(s);
2990 attrs = Nullop;
7e2040f0 2991 while (isIDFIRST_lazy_if(s,UTF)) {
09bef843 2992 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
f9829d6b
GS
2993 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
2994 if (tmp < 0) tmp = -tmp;
2995 switch (tmp) {
2996 case KEY_or:
2997 case KEY_and:
c963b151 2998 case KEY_err:
f9829d6b
GS
2999 case KEY_for:
3000 case KEY_unless:
3001 case KEY_if:
3002 case KEY_while:
3003 case KEY_until:
3004 goto got_attrs;
3005 default:
3006 break;
3007 }
3008 }
09bef843
SB
3009 if (*d == '(') {
3010 d = scan_str(d,TRUE,TRUE);
3011 if (!d) {
09bef843
SB
3012 /* MUST advance bufptr here to avoid bogus
3013 "at end of line" context messages from yyerror().
3014 */
3015 PL_bufptr = s + len;
3016 yyerror("Unterminated attribute parameter in attribute list");
3017 if (attrs)
3018 op_free(attrs);
3019 return 0; /* EOF indicator */
3020 }
3021 }
3022 if (PL_lex_stuff) {
3023 SV *sv = newSVpvn(s, len);
3024 sv_catsv(sv, PL_lex_stuff);
3025 attrs = append_elem(OP_LIST, attrs,
3026 newSVOP(OP_CONST, 0, sv));
3027 SvREFCNT_dec(PL_lex_stuff);
3028 PL_lex_stuff = Nullsv;
3029 }
3030 else {
d3cea301
SB
3031 /* NOTE: any CV attrs applied here need to be part of
3032 the CVf_BUILTIN_ATTRS define in cv.h! */
78f9721b
SM
3033 if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len))
3034 CvLVALUE_on(PL_compcv);
3035 else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len))
3036 CvLOCKED_on(PL_compcv);
3037 else if (!PL_in_my && len == 6 && strnEQ(s, "method", len))
3038 CvMETHOD_on(PL_compcv);
06492da6
SF
3039 else if (!PL_in_my && len == 9 && strnEQ(s, "assertion", len))
3040 CvASSERTION_on(PL_compcv);
87ecf892 3041#ifdef USE_ITHREADS
d3cea301
SB
3042 else if (PL_in_my == KEY_our && len == 6 &&
3043 strnEQ(s, "unique", len))
7fb37951 3044 GvUNIQUE_on(cGVOPx_gv(yylval.opval));
87ecf892 3045#endif
78f9721b
SM
3046 /* After we've set the flags, it could be argued that
3047 we don't need to do the attributes.pm-based setting
3048 process, and shouldn't bother appending recognized
d3cea301
SB
3049 flags. To experiment with that, uncomment the
3050 following "else". (Note that's already been
3051 uncommented. That keeps the above-applied built-in
3052 attributes from being intercepted (and possibly
3053 rejected) by a package's attribute routines, but is
3054 justified by the performance win for the common case
3055 of applying only built-in attributes.) */
0256094b 3056 else
78f9721b
SM
3057 attrs = append_elem(OP_LIST, attrs,
3058 newSVOP(OP_CONST, 0,
3059 newSVpvn(s, len)));
09bef843
SB
3060 }
3061 s = skipspace(d);
0120eecf 3062 if (*s == ':' && s[1] != ':')
09bef843 3063 s = skipspace(s+1);
0120eecf
GS
3064 else if (s == d)
3065 break; /* require real whitespace or :'s */
09bef843 3066 }
f9829d6b 3067 tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
8e7ae056 3068 if (*s != ';' && *s != '}' && *s != tmp && (tmp != '=' || *s != ')')) {
09bef843
SB
3069 char q = ((*s == '\'') ? '"' : '\'');
3070 /* If here for an expression, and parsed no attrs, back off. */
3071 if (tmp == '=' && !attrs) {
3072 s = PL_bufptr;
3073 break;
3074 }
3075 /* MUST advance bufptr here to avoid bogus "at end of line"
3076 context messages from yyerror().
3077 */
3078 PL_bufptr = s;
3079 if (!*s)
3080 yyerror("Unterminated attribute list");
3081 else
3082 yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list",
3083 q, *s, q));
3084 if (attrs)
3085 op_free(attrs);
3086 OPERATOR(':');
3087 }
f9829d6b 3088 got_attrs:
09bef843
SB
3089 if (attrs) {
3090 PL_nextval[PL_nexttoke].opval = attrs;
3091 force_next(THING);
3092 }
3093 TOKEN(COLONATTR);
3094 }
a0d0e21e 3095 OPERATOR(':');
8990e307
LW
3096 case '(':
3097 s++;
3280af22
NIS
3098 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
3099 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
a0d0e21e 3100 else
3280af22 3101 PL_expect = XTERM;
4a202259 3102 s = skipspace(s);
a0d0e21e 3103 TOKEN('(');
378cc40b 3104 case ';':
f4dd75d9 3105 CLINE;
378cc40b
LW
3106 tmp = *s++;
3107 OPERATOR(tmp);
3108 case ')':
378cc40b 3109 tmp = *s++;
16d20bd9
AD
3110 s = skipspace(s);
3111 if (*s == '{')
3112 PREBLOCK(tmp);
378cc40b 3113 TERM(tmp);
79072805
LW
3114 case ']':
3115 s++;
3280af22 3116 if (PL_lex_brackets <= 0)
d98d5fff 3117 yyerror("Unmatched right square bracket");
463ee0b2 3118 else
3280af22
NIS
3119 --PL_lex_brackets;
3120 if (PL_lex_state == LEX_INTERPNORMAL) {
3121 if (PL_lex_brackets == 0) {
a0d0e21e 3122 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
3280af22 3123 PL_lex_state = LEX_INTERPEND;
79072805
LW
3124 }
3125 }
4633a7c4 3126 TERM(']');
79072805
LW
3127 case '{':
3128 leftbracket:
79072805 3129 s++;
3280af22 3130 if (PL_lex_brackets > 100) {
8edd5f42 3131 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
8990e307 3132 }
3280af22 3133 switch (PL_expect) {
a0d0e21e 3134 case XTERM:
3280af22 3135 if (PL_lex_formbrack) {
a0d0e21e
LW
3136 s--;
3137 PRETERMBLOCK(DO);
3138 }
3280af22
NIS
3139 if (PL_oldoldbufptr == PL_last_lop)
3140 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
a0d0e21e 3141 else
3280af22 3142 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
79072805 3143 OPERATOR(HASHBRACK);
a0d0e21e 3144 case XOPERATOR:
bf4acbe4 3145 while (s < PL_bufend && SPACE_OR_TAB(*s))
748a9306 3146 s++;
44a8e56a 3147 d = s;
3280af22
NIS
3148 PL_tokenbuf[0] = '\0';
3149 if (d < PL_bufend && *d == '-') {
3150 PL_tokenbuf[0] = '-';
44a8e56a 3151 d++;
bf4acbe4 3152 while (d < PL_bufend && SPACE_OR_TAB(*d))
44a8e56a
PP
3153 d++;
3154 }
7e2040f0 3155 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
3280af22 3156 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
8903cb82 3157 FALSE, &len);
bf4acbe4 3158 while (d < PL_bufend && SPACE_OR_TAB(*d))
748a9306
LW
3159 d++;
3160 if (*d == '}') {
3280af22 3161 char minus = (PL_tokenbuf[0] == '-');
44a8e56a
PP
3162 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
3163 if (minus)
3164 force_next('-');
748a9306
LW
3165 }
3166 }
3167 /* FALL THROUGH */
09bef843 3168 case XATTRBLOCK:
748a9306 3169 case XBLOCK:
3280af22
NIS
3170 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
3171 PL_expect = XSTATE;
a0d0e21e 3172 break;
09bef843 3173 case XATTRTERM:
a0d0e21e 3174 case XTERMBLOCK:
3280af22
NIS
3175 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3176 PL_expect = XSTATE;
a0d0e21e
LW
3177 break;
3178 default: {
3179 char *t;
3280af22
NIS
3180 if (PL_oldoldbufptr == PL_last_lop)
3181 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
a0d0e21e 3182 else
3280af22 3183 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
a0d0e21e 3184 s = skipspace(s);
8452ff4b
SB
3185 if (*s == '}') {
3186 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
3187 PL_expect = XTERM;
3188 /* This hack is to get the ${} in the message. */
3189 PL_bufptr = s+1;
3190 yyerror("syntax error");
3191 break;
3192 }
a0d0e21e 3193 OPERATOR(HASHBRACK);
8452ff4b 3194 }
b8a4b1be
GS
3195 /* This hack serves to disambiguate a pair of curlies
3196 * as being a block or an anon hash. Normally, expectation
3197 * determines that, but in cases where we're not in a
3198 * position to expect anything in particular (like inside
3199 * eval"") we have to resolve the ambiguity. This code
3200 * covers the case where the first term in the curlies is a
3201 * quoted string. Most other cases need to be explicitly
3202 * disambiguated by prepending a `+' before the opening
3203 * curly in order to force resolution as an anon hash.
3204 *
3205 * XXX should probably propagate the outer expectation
3206 * into eval"" to rely less on this hack, but that could
3207 * potentially break current behavior of eval"".
3208 * GSAR 97-07-21
3209 */
3210 t = s;
3211 if (*s == '\'' || *s == '"' || *s == '`') {
3212 /* common case: get past first string, handling escapes */
3280af22 3213 for (t++; t < PL_bufend && *t != *s;)
b8a4b1be
GS
3214 if (*t++ == '\\' && (*t == '\\' || *t == *s))
3215 t++;
3216 t++;
a0d0e21e 3217 }
b8a4b1be 3218 else if (*s == 'q') {
3280af22 3219 if (++t < PL_bufend
b8a4b1be 3220 && (!isALNUM(*t)
3280af22 3221 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
0505442f
GS
3222 && !isALNUM(*t))))
3223 {
abc667d1 3224 /* skip q//-like construct */
b8a4b1be
GS
3225 char *tmps;
3226 char open, close, term;
3227 I32 brackets = 1;
3228
3280af22 3229 while (t < PL_bufend && isSPACE(*t))
b8a4b1be 3230 t++;
abc667d1
DM
3231 /* check for q => */
3232 if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
3233 OPERATOR(HASHBRACK);
3234 }
b8a4b1be
GS
3235 term = *t;
3236 open = term;
3237 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
3238 term = tmps[5];
3239 close = term;
3240 if (open == close)
3280af22
NIS
3241 for (t++; t < PL_bufend; t++) {
3242 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
b8a4b1be 3243 t++;
6d07e5e9 3244 else if (*t == open)
b8a4b1be
GS
3245 break;
3246 }
abc667d1 3247 else {
3280af22
NIS
3248 for (t++; t < PL_bufend; t++) {
3249 if (*t == '\\' && t+1 < PL_bufend)
b8a4b1be 3250 t++;
6d07e5e9 3251 else if (*t == close && --brackets <= 0)
b8a4b1be
GS
3252 break;
3253 else if (*t == open)
3254 brackets++;
3255 }
abc667d1
DM
3256 }
3257 t++;
b8a4b1be 3258 }
abc667d1
DM
3259 else
3260 /* skip plain q word */
3261 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3262 t += UTF8SKIP(t);
a0d0e21e 3263 }
7e2040f0 3264 else if (isALNUM_lazy_if(t,UTF)) {
0505442f 3265 t += UTF8SKIP(t);
7e2040f0 3266 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
0505442f 3267 t += UTF8SKIP(t);
a0d0e21e 3268 }
3280af22 3269 while (t < PL_bufend && isSPACE(*t))
a0d0e21e 3270 t++;
b8a4b1be
GS
3271 /* if comma follows first term, call it an anon hash */
3272 /* XXX it could be a comma expression with loop modifiers */
3280af22 3273 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
b8a4b1be 3274 || (*t == '=' && t[1] == '>')))
a0d0e21e 3275 OPERATOR(HASHBRACK);
3280af22 3276 if (PL_expect == XREF)
4e4e412b 3277 PL_expect = XTERM;
a0d0e21e 3278 else {
3280af22
NIS
3279 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
3280 PL_expect = XSTATE;
a0d0e21e 3281 }
8990e307 3282 }
a0d0e21e 3283 break;
463ee0b2 3284 }
57843af0 3285 yylval.ival = CopLINE(PL_curcop);
79072805 3286 if (isSPACE(*s) || *s == '#')
3280af22 3287 PL_copline = NOLINE; /* invalidate current command line number */
79072805 3288 TOKEN('{');
378cc40b 3289 case '}':
79072805
LW
3290 rightbracket:
3291 s++;
3280af22 3292 if (PL_lex_brackets <= 0)
d98d5fff 3293 yyerror("Unmatched right curly bracket");
463ee0b2 3294 else
3280af22 3295 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
c2e66d9e 3296 if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
3280af22
NIS
3297 PL_lex_formbrack = 0;
3298 if (PL_lex_state == LEX_INTERPNORMAL) {
3299 if (PL_lex_brackets == 0) {
9059aa12
LW
3300 if (PL_expect & XFAKEBRACK) {
3301 PL_expect &= XENUMMASK;
3280af22
NIS
3302 PL_lex_state = LEX_INTERPEND;
3303 PL_bufptr = s;
cea2e8a9 3304 return yylex(); /* ignore fake brackets */
79072805 3305 }
fa83b5b6 3306 if (*s == '-' && s[1] == '>')
3280af22 3307 PL_lex_state = LEX_INTERPENDMAYBE;
fa83b5b6 3308 else if (*s != '[' && *s != '{')
3280af22 3309 PL_lex_state = LEX_INTERPEND;
79072805
LW
3310 }
3311 }
9059aa12
LW
3312 if (PL_expect & XFAKEBRACK) {
3313 PL_expect &= XENUMMASK;
3280af22 3314 PL_bufptr = s;
cea2e8a9 3315 return yylex(); /* ignore fake brackets */
748a9306 3316 }
79072805
LW
3317 force_next('}');
3318 TOKEN(';');
378cc40b
LW
3319 case '&':
3320 s++;
3321 tmp = *s++;
3322 if (tmp == '&')
a0d0e21e 3323 AOPERATOR(ANDAND);
378cc40b 3324 s--;
3280af22 3325 if (PL_expect == XOPERATOR) {
7e2040f0
GS
3326 if (ckWARN(WARN_SEMICOLON)
3327 && isIDFIRST_lazy_if(s,UTF) && PL_bufptr == PL_linestart)
3328 {
57843af0 3329 CopLINE_dec(PL_curcop);
9014280d 3330 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
57843af0 3331 CopLINE_inc(PL_curcop);
463ee0b2 3332 }
79072805 3333 BAop(OP_BIT_AND);
463ee0b2 3334 }
79072805 3335
3280af22
NIS
3336 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3337 if (*PL_tokenbuf) {
3338 PL_expect = XOPERATOR;
3339 force_ident(PL_tokenbuf, '&');
463ee0b2 3340 }
79072805
LW
3341 else
3342 PREREF('&');
c07a80fd 3343 yylval.ival = (OPpENTERSUB_AMPER<<8);
79072805
LW
3344 TERM('&');
3345
378cc40b
LW
3346 case '|':
3347 s++;
3348 tmp = *s++;
3349 if (tmp == '|')
a0d0e21e 3350 AOPERATOR(OROR);
378cc40b 3351 s--;
79072805 3352 BOop(OP_BIT_OR);
378cc40b
LW
3353 case '=':
3354 s++;
3355 tmp = *s++;
3356 if (tmp == '=')
79072805
LW
3357 Eop(OP_EQ);
3358 if (tmp == '>')
3359 OPERATOR(',');
378cc40b 3360 if (tmp == '~')
79072805 3361 PMop(OP_MATCH);
599cee73 3362 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
9014280d 3363 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Reversed %c= operator",(int)tmp);
378cc40b 3364 s--;
3280af22
NIS
3365 if (PL_expect == XSTATE && isALPHA(tmp) &&
3366 (s == PL_linestart+1 || s[-2] == '\n') )
748a9306 3367 {
3280af22
NIS
3368 if (PL_in_eval && !PL_rsfp) {
3369 d = PL_bufend;
a5f75d66
AD
3370 while (s < d) {
3371 if (*s++ == '\n') {
3372 incline(s);
3373 if (strnEQ(s,"=cut",4)) {
3374 s = strchr(s,'\n');
3375 if (s)
3376 s++;
3377 else
3378 s = d;
3379 incline(s);
3380 goto retry;
3381 }
3382 }
3383 }
3384 goto retry;
3385 }
3280af22
NIS
3386 s = PL_bufend;
3387 PL_doextract = TRUE;
a0d0e21e
LW
3388 goto retry;
3389 }
3280af22 3390 if (PL_lex_brackets < PL_lex_formbrack) {
a0d0e21e 3391 char *t;
51882d45 3392#ifdef PERL_STRICT_CR
bf4acbe4 3393 for (t = s; SPACE_OR_TAB(*t); t++) ;
51882d45 3394#else
bf4acbe4 3395 for (t = s; SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
51882d45 3396#endif
a0d0e21e
LW
3397 if (*t == '\n' || *t == '#') {
3398 s--;
3280af22 3399 PL_expect = XBLOCK;
a0d0e21e
LW
3400 goto leftbracket;
3401 }
79072805 3402 }
a0d0e21e
LW
3403 yylval.ival = 0;
3404 OPERATOR(ASSIGNOP);
378cc40b
LW
3405 case '!':
3406 s++;
3407 tmp = *s++;
3408 if (tmp == '=')
79072805 3409 Eop(OP_NE);
378cc40b 3410 if (tmp == '~')
79072805 3411 PMop(OP_NOT);
378cc40b
LW
3412 s--;
3413 OPERATOR('!');
3414 case '<':
3280af22 3415 if (PL_expect != XOPERATOR) {
93a17b20 3416 if (s[1] != '<' && !strchr(s,'>'))
2f3197b3 3417 check_uni();
79072805
LW
3418 if (s[1] == '<')
3419 s = scan_heredoc(s);
3420 else
3421 s = scan_inputsymbol(s);
3422 TERM(sublex_start());
378cc40b
LW
3423 }
3424 s++;
3425 tmp = *s++;
3426 if (tmp == '<')
79072805 3427 SHop(OP_LEFT_SHIFT);
395c3793
LW
3428 if (tmp == '=') {
3429 tmp = *s++;
3430 if (tmp == '>')
79072805 3431 Eop(OP_NCMP);
395c3793 3432 s--;
79072805 3433 Rop(OP_LE);
395c3793 3434 }
378cc40b 3435 s--;
79072805 3436 Rop(OP_LT);
378cc40b
LW
3437 case '>':
3438 s++;
3439 tmp = *s++;
3440 if (tmp == '>')
79072805 3441 SHop(OP_RIGHT_SHIFT);
378cc40b 3442 if (tmp == '=')
79072805 3443 Rop(OP_GE);
378cc40b 3444 s--;
79072805 3445 Rop(OP_GT);
378cc40b
LW
3446
3447 case '$':
bbce6d69
PP
3448 CLINE;
3449
3280af22
NIS
3450 if (PL_expect == XOPERATOR) {
3451 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3452 PL_expect = XTERM;
a0d0e21e 3453 depcom();
bbce6d69 3454 return ','; /* grandfather non-comma-format format */
a0d0e21e 3455 }
8990e307 3456 }
a0d0e21e 3457
7e2040f0 3458 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
3280af22 3459 PL_tokenbuf[0] = '@';
376b8730
SM
3460 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3461 sizeof PL_tokenbuf - 1, FALSE);
3462 if (PL_expect == XOPERATOR)
3463 no_op("Array length", s);
3280af22 3464 if (!PL_tokenbuf[1])
a0d0e21e 3465 PREREF(DOLSHARP);
3280af22
NIS
3466 PL_expect = XOPERATOR;
3467 PL_pending_ident = '#';
463ee0b2 3468 TOKEN(DOLSHARP);
79072805 3469 }
bbce6d69 3470
3280af22 3471 PL_tokenbuf[0] = '$';
376b8730
SM
3472 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3473 sizeof PL_tokenbuf - 1, FALSE);
3474 if (PL_expect == XOPERATOR)
3475 no_op("Scalar", s);
3280af22
NIS
3476 if (!PL_tokenbuf[1]) {
3477 if (s == PL_bufend)
bbce6d69
PP
3478 yyerror("Final $ should be \\$ or $name");
3479 PREREF('$');
8990e307 3480 }
a0d0e21e 3481
bbce6d69 3482 /* This kludge not intended to be bulletproof. */
3280af22 3483 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
bbce6d69 3484 yylval.opval = newSVOP(OP_CONST, 0,
b448e4fe 3485 newSViv(PL_compiling.cop_arybase));
bbce6d69
PP
3486 yylval.opval->op_private = OPpCONST_ARYBASE;
3487 TERM(THING);
3488 }
3489
ff68c719 3490 d = s;
69d2bceb 3491 tmp = (I32)*s;
3280af22 3492 if (PL_lex_state == LEX_NORMAL)
ff68c719
PP
3493 s = skipspace(s);
3494
3280af22 3495 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
bbce6d69
PP
3496 char *t;
3497 if (*s == '[') {
3280af22 3498 PL_tokenbuf[0] = '@';
599cee73 3499 if (ckWARN(WARN_SYNTAX)) {
bbce6d69 3500 for(t = s + 1;
7e2040f0 3501 isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$';
bbce6d69 3502 t++) ;
a0d0e21e 3503 if (*t++ == ',') {
3280af22
NIS
3504 PL_bufptr = skipspace(PL_bufptr);
3505 while (t < PL_bufend && *t != ']')
bbce6d69 3506 t++;
9014280d 3507 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
599cee73
PM
3508 "Multidimensional syntax %.*s not supported",
3509 (t - PL_bufptr) + 1, PL_bufptr);
a0d0e21e
LW
3510 }
3511 }