This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[PATCH lib/overload.t] TODO tests for bug #24313.
[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 1326 if (s[2] == '#') {
e994fd66 1327 while (s+1 < 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 }
e994fd66 1346 if (*regparse != ')')
5bdf89e7 1347 regparse--; /* Leave one char for continuation. */
0f5d15d6 1348 while (s < regparse)
db42d148 1349 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
cc6b7395 1350 }
748a9306 1351 }
02aa26ce
NT
1352
1353 /* likewise skip #-initiated comments in //x patterns */
3280af22
NIS
1354 else if (*s == '#' && PL_lex_inpat &&
1355 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
748a9306 1356 while (s+1 < send && *s != '\n')
db42d148 1357 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
748a9306 1358 }
02aa26ce 1359
5d1d4326 1360 /* check for embedded arrays
da6eedaa 1361 (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
5d1d4326 1362 */
7e2040f0 1363 else if (*s == '@' && s[1]
5d1d4326 1364 && (isALNUM_lazy_if(s+1,UTF) || strchr(":'{$+-", s[1])))
79072805 1365 break;
02aa26ce
NT
1366
1367 /* check for embedded scalars. only stop if we're sure it's a
1368 variable.
1369 */
79072805 1370 else if (*s == '$') {
3280af22 1371 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
79072805 1372 break;
6002328a 1373 if (s + 1 < send && !strchr("()| \r\n\t", s[1]))
79072805
LW
1374 break; /* in regexp, $ might be tail anchor */
1375 }
02aa26ce 1376
2b9d42f0
NIS
1377 /* End of else if chain - OP_TRANS rejoin rest */
1378
02aa26ce 1379 /* backslashes */
79072805
LW
1380 if (*s == '\\' && s+1 < send) {
1381 s++;
02aa26ce
NT
1382
1383 /* some backslashes we leave behind */
c9f97d15 1384 if (*leaveit && *s && strchr(leaveit, *s)) {
db42d148
NIS
1385 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
1386 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
79072805
LW
1387 continue;
1388 }
02aa26ce
NT
1389
1390 /* deprecate \1 in strings and substitution replacements */
3280af22 1391 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
a0d0e21e 1392 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
79072805 1393 {
599cee73 1394 if (ckWARN(WARN_SYNTAX))
9014280d 1395 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
79072805
LW
1396 *--s = '$';
1397 break;
1398 }
02aa26ce
NT
1399
1400 /* string-change backslash escapes */
3280af22 1401 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
79072805
LW
1402 --s;
1403 break;
1404 }
02aa26ce
NT
1405
1406 /* if we get here, it's either a quoted -, or a digit */
79072805 1407 switch (*s) {
02aa26ce
NT
1408
1409 /* quoted - in transliterations */
79072805 1410 case '-':
3280af22 1411 if (PL_lex_inwhat == OP_TRANS) {
79072805
LW
1412 *d++ = *s++;
1413 continue;
1414 }
1415 /* FALL THROUGH */
1416 default:
11b8faa4 1417 {
707afd92
MS
1418 if (ckWARN(WARN_MISC) &&
1419 isALNUM(*s) &&
1420 *s != '_')
9014280d 1421 Perl_warner(aTHX_ packWARN(WARN_MISC),
11b8faa4
JH
1422 "Unrecognized escape \\%c passed through",
1423 *s);
1424 /* default action is to copy the quoted character */
f9a63242 1425 goto default_action;
11b8faa4 1426 }
02aa26ce
NT
1427
1428 /* \132 indicates an octal constant */
79072805
LW
1429 case '0': case '1': case '2': case '3':
1430 case '4': case '5': case '6': case '7':
ba210ebe 1431 {
53305cf1
NC
1432 I32 flags = 0;
1433 STRLEN len = 3;
1434 uv = grok_oct(s, &len, &flags, NULL);
ba210ebe
JH
1435 s += len;
1436 }
012bcf8d 1437 goto NUM_ESCAPE_INSERT;
02aa26ce
NT
1438
1439 /* \x24 indicates a hex constant */
79072805 1440 case 'x':
a0ed51b3
LW
1441 ++s;
1442 if (*s == '{') {
1443 char* e = strchr(s, '}');
a4c04bdc
NC
1444 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
1445 PERL_SCAN_DISALLOW_PREFIX;
53305cf1 1446 STRLEN len;
355860ce 1447
53305cf1 1448 ++s;
adaeee49 1449 if (!e) {
a0ed51b3 1450 yyerror("Missing right brace on \\x{}");
355860ce 1451 continue;
ba210ebe 1452 }
53305cf1
NC
1453 len = e - s;
1454 uv = grok_hex(s, &len, &flags, NULL);
ba210ebe 1455 s = e + 1;
a0ed51b3
LW
1456 }
1457 else {
ba210ebe 1458 {
53305cf1 1459 STRLEN len = 2;
a4c04bdc 1460 I32 flags = PERL_SCAN_DISALLOW_PREFIX;
53305cf1 1461 uv = grok_hex(s, &len, &flags, NULL);
ba210ebe
JH
1462 s += len;
1463 }
012bcf8d
GS
1464 }
1465
1466 NUM_ESCAPE_INSERT:
1467 /* Insert oct or hex escaped character.
301d3d20 1468 * There will always enough room in sv since such
db42d148 1469 * escapes will be longer than any UTF-8 sequence
301d3d20 1470 * they can end up as. */
ba7cea30 1471
c7f1f016
NIS
1472 /* We need to map to chars to ASCII before doing the tests
1473 to cover EBCDIC
1474 */
c4d5f83a 1475 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(uv))) {
9aa983d2 1476 if (!has_utf8 && uv > 255) {
301d3d20
JH
1477 /* Might need to recode whatever we have
1478 * accumulated so far if it contains any
1479 * hibit chars.
1480 *
1481 * (Can't we keep track of that and avoid
1482 * this rescan? --jhi)
012bcf8d 1483 */
c7f1f016 1484 int hicount = 0;
63cd0674
NIS
1485 U8 *c;
1486 for (c = (U8 *) SvPVX(sv); c < (U8 *)d; c++) {
c4d5f83a 1487 if (!NATIVE_IS_INVARIANT(*c)) {
012bcf8d 1488 hicount++;
db42d148 1489 }
012bcf8d 1490 }
63cd0674 1491 if (hicount) {
db42d148
NIS
1492 STRLEN offset = d - SvPVX(sv);
1493 U8 *src, *dst;
1494 d = SvGROW(sv, SvLEN(sv) + hicount + 1) + offset;
1495 src = (U8 *)d - 1;
1496 dst = src+hicount;
1497 d += hicount;
1498 while (src >= (U8 *)SvPVX(sv)) {
c4d5f83a 1499 if (!NATIVE_IS_INVARIANT(*src)) {
63cd0674 1500 U8 ch = NATIVE_TO_ASCII(*src);
eb160463
GS
1501 *dst-- = (U8)UTF8_EIGHT_BIT_LO(ch);
1502 *dst-- = (U8)UTF8_EIGHT_BIT_HI(ch);
012bcf8d
GS
1503 }
1504 else {
63cd0674 1505 *dst-- = *src;
012bcf8d 1506 }
c7f1f016 1507 src--;
012bcf8d
GS
1508 }
1509 }
1510 }
1511
9aa983d2 1512 if (has_utf8 || uv > 255) {
9041c2e3 1513 d = (char*)uvchr_to_utf8((U8*)d, uv);
4e553d73 1514 has_utf8 = TRUE;
f9a63242
JH
1515 if (PL_lex_inwhat == OP_TRANS &&
1516 PL_sublex_info.sub_op) {
1517 PL_sublex_info.sub_op->op_private |=
1518 (PL_lex_repl ? OPpTRANS_FROM_UTF
1519 : OPpTRANS_TO_UTF);
f9a63242 1520 }
012bcf8d 1521 }
a0ed51b3 1522 else {
012bcf8d 1523 *d++ = (char)uv;
a0ed51b3 1524 }
012bcf8d
GS
1525 }
1526 else {
c4d5f83a 1527 *d++ = (char) uv;
a0ed51b3 1528 }
79072805 1529 continue;
02aa26ce 1530
b239daa5 1531 /* \N{LATIN SMALL LETTER A} is a named character */
4a2d328f 1532 case 'N':
55eda711 1533 ++s;
423cee85
JH
1534 if (*s == '{') {
1535 char* e = strchr(s, '}');
155aba94 1536 SV *res;
423cee85
JH
1537 STRLEN len;
1538 char *str;
4e553d73 1539
423cee85 1540 if (!e) {
5777a3f7 1541 yyerror("Missing right brace on \\N{}");
423cee85
JH
1542 e = s - 1;
1543 goto cont_scan;
1544 }
dbc0d4f2
JH
1545 if (e > s + 2 && s[1] == 'U' && s[2] == '+') {
1546 /* \N{U+...} */
1547 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
1548 PERL_SCAN_DISALLOW_PREFIX;
1549 s += 3;
1550 len = e - s;
1551 uv = grok_hex(s, &len, &flags, NULL);
1552 s = e + 1;
1553 goto NUM_ESCAPE_INSERT;
1554 }
55eda711
JH
1555 res = newSVpvn(s + 1, e - s - 1);
1556 res = new_constant( Nullch, 0, "charnames",
1557 res, Nullsv, "\\N{...}" );
f9a63242
JH
1558 if (has_utf8)
1559 sv_utf8_upgrade(res);
423cee85 1560 str = SvPV(res,len);
1c47067b
JH
1561#ifdef EBCDIC_NEVER_MIND
1562 /* charnames uses pack U and that has been
1563 * recently changed to do the below uni->native
1564 * mapping, so this would be redundant (and wrong,
1565 * the code point would be doubly converted).
1566 * But leave this in just in case the pack U change
1567 * gets revoked, but the semantics is still
1568 * desireable for charnames. --jhi */
cddc7ef4
JH
1569 {
1570 UV uv = utf8_to_uvchr((U8*)str, 0);
1571
1572 if (uv < 0x100) {
1573 U8 tmpbuf[UTF8_MAXLEN+1], *d;
1574
1575 d = uvchr_to_utf8(tmpbuf, UNI_TO_NATIVE(uv));
1576 sv_setpvn(res, (char *)tmpbuf, d - tmpbuf);
1577 str = SvPV(res, len);
1578 }
1579 }
1580#endif
89491803 1581 if (!has_utf8 && SvUTF8(res)) {
f08d6ad9
GS
1582 char *ostart = SvPVX(sv);
1583 SvCUR_set(sv, d - ostart);
1584 SvPOK_on(sv);
e4f3eed8 1585 *d = '\0';
f08d6ad9 1586 sv_utf8_upgrade(sv);
d2f449dd 1587 /* this just broke our allocation above... */
eb160463 1588 SvGROW(sv, (STRLEN)(send - start));
f08d6ad9 1589 d = SvPVX(sv) + SvCUR(sv);
89491803 1590 has_utf8 = TRUE;
f08d6ad9 1591 }
eb160463 1592 if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
423cee85
JH
1593 char *odest = SvPVX(sv);
1594
8973db79 1595 SvGROW(sv, (SvLEN(sv) + len - (e - s + 4)));
423cee85
JH
1596 d = SvPVX(sv) + (d - odest);
1597 }
1598 Copy(str, d, len, char);
1599 d += len;
1600 SvREFCNT_dec(res);
1601 cont_scan:
1602 s = e + 1;
1603 }
1604 else
5777a3f7 1605 yyerror("Missing braces on \\N{}");
423cee85
JH
1606 continue;
1607
02aa26ce 1608 /* \c is a control character */
79072805
LW
1609 case 'c':
1610 s++;
961ce445 1611 if (s < send) {
ba210ebe 1612 U8 c = *s++;
c7f1f016
NIS
1613#ifdef EBCDIC
1614 if (isLOWER(c))
1615 c = toUPPER(c);
1616#endif
db42d148 1617 *d++ = NATIVE_TO_NEED(has_utf8,toCTRL(c));
ba210ebe 1618 }
961ce445
RGS
1619 else {
1620 yyerror("Missing control char name in \\c");
1621 }
79072805 1622 continue;
02aa26ce
NT
1623
1624 /* printf-style backslashes, formfeeds, newlines, etc */
79072805 1625 case 'b':
db42d148 1626 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
79072805
LW
1627 break;
1628 case 'n':
db42d148 1629 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
79072805
LW
1630 break;
1631 case 'r':
db42d148 1632 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
79072805
LW
1633 break;
1634 case 'f':
db42d148 1635 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
79072805
LW
1636 break;
1637 case 't':
db42d148 1638 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
79072805 1639 break;
34a3fe2a 1640 case 'e':
db42d148 1641 *d++ = ASCII_TO_NEED(has_utf8,'\033');
34a3fe2a
PP
1642 break;
1643 case 'a':
db42d148 1644 *d++ = ASCII_TO_NEED(has_utf8,'\007');
79072805 1645 break;
02aa26ce
NT
1646 } /* end switch */
1647
79072805
LW
1648 s++;
1649 continue;
02aa26ce
NT
1650 } /* end if (backslash) */
1651
f9a63242 1652 default_action:
2b9d42f0
NIS
1653 /* If we started with encoded form, or already know we want it
1654 and then encode the next character */
1655 if ((has_utf8 || this_utf8) && !NATIVE_IS_INVARIANT((U8)(*s))) {
1656 STRLEN len = 1;
1657 UV uv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
1658 STRLEN need = UNISKIP(NATIVE_TO_UNI(uv));
1659 s += len;
1660 if (need > len) {
1661 /* encoded value larger than old, need extra space (NOTE: SvCUR() not set here) */
1662 STRLEN off = d - SvPVX(sv);
1663 d = SvGROW(sv, SvLEN(sv) + (need-len)) + off;
1664 }
1665 d = (char*)uvchr_to_utf8((U8*)d, uv);
1666 has_utf8 = TRUE;
1667 }
1668 else {
1669 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1670 }
02aa26ce
NT
1671 } /* while loop to process each character */
1672
1673 /* terminate the string and set up the sv */
79072805 1674 *d = '\0';
463ee0b2 1675 SvCUR_set(sv, d - SvPVX(sv));
2b9d42f0 1676 if (SvCUR(sv) >= SvLEN(sv))
d0063567 1677 Perl_croak(aTHX_ "panic: constant overflowed allocated space");
2b9d42f0 1678
79072805 1679 SvPOK_on(sv);
9f4817db 1680 if (PL_encoding && !has_utf8) {
d0063567
DK
1681 sv_recode_to_utf8(sv, PL_encoding);
1682 if (SvUTF8(sv))
1683 has_utf8 = TRUE;
9f4817db 1684 }
2b9d42f0 1685 if (has_utf8) {
7e2040f0 1686 SvUTF8_on(sv);
2b9d42f0 1687 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
d0063567 1688 PL_sublex_info.sub_op->op_private |=
2b9d42f0
NIS
1689 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1690 }
1691 }
79072805 1692
02aa26ce 1693 /* shrink the sv if we allocated more than we used */
79072805
LW
1694 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1695 SvLEN_set(sv, SvCUR(sv) + 1);
463ee0b2 1696 Renew(SvPVX(sv), SvLEN(sv), char);
79072805 1697 }
02aa26ce 1698
9b599b2a 1699 /* return the substring (via yylval) only if we parsed anything */
3280af22
NIS
1700 if (s > PL_bufptr) {
1701 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
4e553d73 1702 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
b3ac6de7 1703 sv, Nullsv,
4e553d73 1704 ( PL_lex_inwhat == OP_TRANS
b3ac6de7 1705 ? "tr"
3280af22 1706 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
b3ac6de7
IZ
1707 ? "s"
1708 : "qq")));
79072805 1709 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
b3ac6de7 1710 } else
8990e307 1711 SvREFCNT_dec(sv);
79072805
LW
1712 return s;
1713}
1714
ffb4593c
NT
1715/* S_intuit_more
1716 * Returns TRUE if there's more to the expression (e.g., a subscript),
1717 * FALSE otherwise.
ffb4593c
NT
1718 *
1719 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
1720 *
1721 * ->[ and ->{ return TRUE
1722 * { and [ outside a pattern are always subscripts, so return TRUE
1723 * if we're outside a pattern and it's not { or [, then return FALSE
1724 * if we're in a pattern and the first char is a {
1725 * {4,5} (any digits around the comma) returns FALSE
1726 * if we're in a pattern and the first char is a [
1727 * [] returns FALSE
1728 * [SOMETHING] has a funky algorithm to decide whether it's a
1729 * character class or not. It has to deal with things like
1730 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
1731 * anything else returns TRUE
1732 */
1733
9cbb5ea2
GS
1734/* This is the one truly awful dwimmer necessary to conflate C and sed. */
1735
76e3520e 1736STATIC int
cea2e8a9 1737S_intuit_more(pTHX_ register char *s)
79072805 1738{
3280af22 1739 if (PL_lex_brackets)
79072805
LW
1740 return TRUE;
1741 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1742 return TRUE;
1743 if (*s != '{' && *s != '[')
1744 return FALSE;
3280af22 1745 if (!PL_lex_inpat)
79072805
LW
1746 return TRUE;
1747
1748 /* In a pattern, so maybe we have {n,m}. */
1749 if (*s == '{') {
1750 s++;
1751 if (!isDIGIT(*s))
1752 return TRUE;
1753 while (isDIGIT(*s))
1754 s++;
1755 if (*s == ',')
1756 s++;
1757 while (isDIGIT(*s))
1758 s++;
1759 if (*s == '}')
1760 return FALSE;
1761 return TRUE;
1762
1763 }
1764
1765 /* On the other hand, maybe we have a character class */
1766
1767 s++;
1768 if (*s == ']' || *s == '^')
1769 return FALSE;
1770 else {
ffb4593c 1771 /* this is terrifying, and it works */
79072805
LW
1772 int weight = 2; /* let's weigh the evidence */
1773 char seen[256];
f27ffc4a 1774 unsigned char un_char = 255, last_un_char;
93a17b20 1775 char *send = strchr(s,']');
3280af22 1776 char tmpbuf[sizeof PL_tokenbuf * 4];
79072805
LW
1777
1778 if (!send) /* has to be an expression */
1779 return TRUE;
1780
1781 Zero(seen,256,char);
1782 if (*s == '$')
1783 weight -= 3;
1784 else if (isDIGIT(*s)) {
1785 if (s[1] != ']') {
1786 if (isDIGIT(s[1]) && s[2] == ']')
1787 weight -= 10;
1788 }
1789 else
1790 weight -= 100;
1791 }
1792 for (; s < send; s++) {
1793 last_un_char = un_char;
1794 un_char = (unsigned char)*s;
1795 switch (*s) {
1796 case '@':
1797 case '&':
1798 case '$':
1799 weight -= seen[un_char] * 10;
7e2040f0 1800 if (isALNUM_lazy_if(s+1,UTF)) {
8903cb82 1801 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
a0d0e21e 1802 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
79072805
LW
1803 weight -= 100;
1804 else
1805 weight -= 10;
1806 }
1807 else if (*s == '$' && s[1] &&
93a17b20
LW
1808 strchr("[#!%*<>()-=",s[1])) {
1809 if (/*{*/ strchr("])} =",s[2]))
79072805
LW
1810 weight -= 10;
1811 else
1812 weight -= 1;
1813 }
1814 break;
1815 case '\\':
1816 un_char = 254;
1817 if (s[1]) {
93a17b20 1818 if (strchr("wds]",s[1]))
79072805
LW
1819 weight += 100;
1820 else if (seen['\''] || seen['"'])
1821 weight += 1;
93a17b20 1822 else if (strchr("rnftbxcav",s[1]))
79072805
LW
1823 weight += 40;
1824 else if (isDIGIT(s[1])) {
1825 weight += 40;
1826 while (s[1] && isDIGIT(s[1]))
1827 s++;
1828 }
1829 }
1830 else
1831 weight += 100;
1832 break;
1833 case '-':
1834 if (s[1] == '\\')
1835 weight += 50;
93a17b20 1836 if (strchr("aA01! ",last_un_char))
79072805 1837 weight += 30;
93a17b20 1838 if (strchr("zZ79~",s[1]))
79072805 1839 weight += 30;
f27ffc4a
GS
1840 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1841 weight -= 5; /* cope with negative subscript */
79072805
LW
1842 break;
1843 default:
93a17b20 1844 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
79072805
LW
1845 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1846 char *d = tmpbuf;
1847 while (isALPHA(*s))
1848 *d++ = *s++;
1849 *d = '\0';
1850 if (keyword(tmpbuf, d - tmpbuf))
1851 weight -= 150;
1852 }
1853 if (un_char == last_un_char + 1)
1854 weight += 5;
1855 weight -= seen[un_char];
1856 break;
1857 }
1858 seen[un_char]++;
1859 }
1860 if (weight >= 0) /* probably a character class */
1861 return FALSE;
1862 }
1863
1864 return TRUE;
1865}
ffed7fef 1866
ffb4593c
NT
1867/*
1868 * S_intuit_method
1869 *
1870 * Does all the checking to disambiguate
1871 * foo bar
1872 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
1873 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
1874 *
1875 * First argument is the stuff after the first token, e.g. "bar".
1876 *
1877 * Not a method if bar is a filehandle.
1878 * Not a method if foo is a subroutine prototyped to take a filehandle.
1879 * Not a method if it's really "Foo $bar"
1880 * Method if it's "foo $bar"
1881 * Not a method if it's really "print foo $bar"
1882 * Method if it's really "foo package::" (interpreted as package->foo)
8f8cf39c 1883 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
3cb0bbe5 1884 * Not a method if bar is a filehandle or package, but is quoted with
ffb4593c
NT
1885 * =>
1886 */
1887
76e3520e 1888STATIC int
cea2e8a9 1889S_intuit_method(pTHX_ char *start, GV *gv)
a0d0e21e
LW
1890{
1891 char *s = start + (*start == '$');
3280af22 1892 char tmpbuf[sizeof PL_tokenbuf];
a0d0e21e
LW
1893 STRLEN len;
1894 GV* indirgv;
1895
1896 if (gv) {
b6c543e3 1897 CV *cv;
a0d0e21e
LW
1898 if (GvIO(gv))
1899 return 0;
b6c543e3
IZ
1900 if ((cv = GvCVu(gv))) {
1901 char *proto = SvPVX(cv);
1902 if (proto) {
1903 if (*proto == ';')
1904 proto++;
1905 if (*proto == '*')
1906 return 0;
1907 }
1908 } else
a0d0e21e
LW
1909 gv = 0;
1910 }
8903cb82 1911 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
ffb4593c
NT
1912 /* start is the beginning of the possible filehandle/object,
1913 * and s is the end of it
1914 * tmpbuf is a copy of it
1915 */
1916
a0d0e21e 1917 if (*start == '$') {
3280af22 1918 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
a0d0e21e
LW
1919 return 0;
1920 s = skipspace(s);
3280af22
NIS
1921 PL_bufptr = start;
1922 PL_expect = XREF;
a0d0e21e
LW
1923 return *s == '(' ? FUNCMETH : METHOD;
1924 }
1925 if (!keyword(tmpbuf, len)) {
c3e0f903
GS
1926 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1927 len -= 2;
1928 tmpbuf[len] = '\0';
1929 goto bare_package;
1930 }
1931 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
8ebc5c01 1932 if (indirgv && GvCVu(indirgv))
a0d0e21e
LW
1933 return 0;
1934 /* filehandle or package name makes it a method */
89bfa8cd 1935 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
a0d0e21e 1936 s = skipspace(s);
3280af22 1937 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
55497cff 1938 return 0; /* no assumptions -- "=>" quotes bearword */
c3e0f903 1939 bare_package:
3280af22 1940 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
79cb57f6 1941 newSVpvn(tmpbuf,len));
3280af22
NIS
1942 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1943 PL_expect = XTERM;
a0d0e21e 1944 force_next(WORD);
3280af22 1945 PL_bufptr = s;
a0d0e21e
LW
1946 return *s == '(' ? FUNCMETH : METHOD;
1947 }
1948 }
1949 return 0;
1950}
1951
ffb4593c
NT
1952/*
1953 * S_incl_perldb
1954 * Return a string of Perl code to load the debugger. If PERL5DB
1955 * is set, it will return the contents of that, otherwise a
1956 * compile-time require of perl5db.pl.
1957 */
1958
76e3520e 1959STATIC char*
cea2e8a9 1960S_incl_perldb(pTHX)
a0d0e21e 1961{
3280af22 1962 if (PL_perldb) {
76e3520e 1963 char *pdb = PerlEnv_getenv("PERL5DB");
a0d0e21e
LW
1964
1965 if (pdb)
1966 return pdb;
93189314 1967 SETERRNO(0,SS_NORMAL);
a0d0e21e
LW
1968 return "BEGIN { require 'perl5db.pl' }";
1969 }
1970 return "";
1971}
1972
1973
16d20bd9 1974/* Encoded script support. filter_add() effectively inserts a
4e553d73 1975 * 'pre-processing' function into the current source input stream.
16d20bd9
AD
1976 * Note that the filter function only applies to the current source file
1977 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1978 *
1979 * The datasv parameter (which may be NULL) can be used to pass
1980 * private data to this instance of the filter. The filter function
1981 * can recover the SV using the FILTER_DATA macro and use it to
1982 * store private buffers and state information.
1983 *
1984 * The supplied datasv parameter is upgraded to a PVIO type
4755096e 1985 * and the IoDIRP/IoANY field is used to store the function pointer,
e0c19803 1986 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
16d20bd9
AD
1987 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1988 * private use must be set using malloc'd pointers.
1989 */
16d20bd9
AD
1990
1991SV *
864dbfa3 1992Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
16d20bd9 1993{
f4c556ac
GS
1994 if (!funcp)
1995 return Nullsv;
1996
3280af22
NIS
1997 if (!PL_rsfp_filters)
1998 PL_rsfp_filters = newAV();
16d20bd9 1999 if (!datasv)
8c52afec 2000 datasv = NEWSV(255,0);
16d20bd9 2001 if (!SvUPGRADE(datasv, SVt_PVIO))
cea2e8a9 2002 Perl_die(aTHX_ "Can't upgrade filter_add data to SVt_PVIO");
4755096e 2003 IoANY(datasv) = (void *)funcp; /* stash funcp into spare field */
e0c19803 2004 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
f4c556ac 2005 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
fe5a182c 2006 (void*)funcp, SvPV_nolen(datasv)));
3280af22
NIS
2007 av_unshift(PL_rsfp_filters, 1);
2008 av_store(PL_rsfp_filters, 0, datasv) ;
16d20bd9
AD
2009 return(datasv);
2010}
4e553d73 2011
16d20bd9
AD
2012
2013/* Delete most recently added instance of this filter function. */
a0d0e21e 2014void
864dbfa3 2015Perl_filter_del(pTHX_ filter_t funcp)
16d20bd9 2016{
e0c19803 2017 SV *datasv;
fe5a182c 2018 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", (void*)funcp));
3280af22 2019 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
16d20bd9
AD
2020 return;
2021 /* if filter is on top of stack (usual case) just pop it off */
e0c19803 2022 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
4755096e 2023 if (IoANY(datasv) == (void *)funcp) {
e0c19803 2024 IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
4755096e 2025 IoANY(datasv) = (void *)NULL;
3280af22 2026 sv_free(av_pop(PL_rsfp_filters));
e50aee73 2027
16d20bd9
AD
2028 return;
2029 }
2030 /* we need to search for the correct entry and clear it */
cea2e8a9 2031 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
16d20bd9
AD
2032}
2033
2034
2035/* Invoke the n'th filter function for the current rsfp. */
2036I32
864dbfa3 2037Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
4e553d73
NIS
2038
2039
8ac85365 2040 /* 0 = read one text line */
a0d0e21e 2041{
16d20bd9
AD
2042 filter_t funcp;
2043 SV *datasv = NULL;
e50aee73 2044
3280af22 2045 if (!PL_rsfp_filters)
16d20bd9 2046 return -1;
3280af22 2047 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
16d20bd9
AD
2048 /* Provide a default input filter to make life easy. */
2049 /* Note that we append to the line. This is handy. */
f4c556ac
GS
2050 DEBUG_P(PerlIO_printf(Perl_debug_log,
2051 "filter_read %d: from rsfp\n", idx));
4e553d73 2052 if (maxlen) {
16d20bd9
AD
2053 /* Want a block */
2054 int len ;
2055 int old_len = SvCUR(buf_sv) ;
2056
2057 /* ensure buf_sv is large enough */
eb160463 2058 SvGROW(buf_sv, (STRLEN)(old_len + maxlen)) ;
3280af22
NIS
2059 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
2060 if (PerlIO_error(PL_rsfp))
37120919
AD
2061 return -1; /* error */
2062 else
2063 return 0 ; /* end of file */
2064 }
16d20bd9
AD
2065 SvCUR_set(buf_sv, old_len + len) ;
2066 } else {
2067 /* Want a line */
3280af22
NIS
2068 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
2069 if (PerlIO_error(PL_rsfp))
37120919
AD
2070 return -1; /* error */
2071 else
2072 return 0 ; /* end of file */
2073 }
16d20bd9
AD
2074 }
2075 return SvCUR(buf_sv);
2076 }
2077 /* Skip this filter slot if filter has been deleted */
3280af22 2078 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
f4c556ac
GS
2079 DEBUG_P(PerlIO_printf(Perl_debug_log,
2080 "filter_read %d: skipped (filter deleted)\n",
2081 idx));
16d20bd9
AD
2082 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
2083 }
2084 /* Get function pointer hidden within datasv */
4755096e 2085 funcp = (filter_t)IoANY(datasv);
f4c556ac
GS
2086 DEBUG_P(PerlIO_printf(Perl_debug_log,
2087 "filter_read %d: via function %p (%s)\n",
fe5a182c 2088 idx, (void*)funcp, SvPV_nolen(datasv)));
16d20bd9
AD
2089 /* Call function. The function is expected to */
2090 /* call "FILTER_READ(idx+1, buf_sv)" first. */
37120919 2091 /* Return: <0:error, =0:eof, >0:not eof */
acfe0abc 2092 return (*funcp)(aTHX_ idx, buf_sv, maxlen);
16d20bd9
AD
2093}
2094
76e3520e 2095STATIC char *
cea2e8a9 2096S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
16d20bd9 2097{
c39cd008 2098#ifdef PERL_CR_FILTER
3280af22 2099 if (!PL_rsfp_filters) {
c39cd008 2100 filter_add(S_cr_textfilter,NULL);
a868473f
NIS
2101 }
2102#endif
3280af22 2103 if (PL_rsfp_filters) {
16d20bd9 2104
55497cff
PP
2105 if (!append)
2106 SvCUR_set(sv, 0); /* start with empty line */
16d20bd9
AD
2107 if (FILTER_READ(0, sv, 0) > 0)
2108 return ( SvPVX(sv) ) ;
2109 else
2110 return Nullch ;
2111 }
9d116dd7 2112 else
fd049845 2113 return (sv_gets(sv, fp, append));
a0d0e21e
LW
2114}
2115
01ec43d0
GS
2116STATIC HV *
2117S_find_in_my_stash(pTHX_ char *pkgname, I32 len)
def3634b
GS
2118{
2119 GV *gv;
2120
01ec43d0 2121 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
def3634b
GS
2122 return PL_curstash;
2123
2124 if (len > 2 &&
2125 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
01ec43d0
GS
2126 (gv = gv_fetchpv(pkgname, FALSE, SVt_PVHV)))
2127 {
2128 return GvHV(gv); /* Foo:: */
def3634b
GS
2129 }
2130
2131 /* use constant CLASS => 'MyClass' */
2132 if ((gv = gv_fetchpv(pkgname, FALSE, SVt_PVCV))) {
2133 SV *sv;
2134 if (GvCV(gv) && (sv = cv_const_sv(GvCV(gv)))) {
2135 pkgname = SvPV_nolen(sv);
2136 }
2137 }
2138
2139 return gv_stashpv(pkgname, FALSE);
2140}
a0d0e21e 2141
748a9306
LW
2142#ifdef DEBUGGING
2143 static char* exp_name[] =
09bef843 2144 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
27308ded 2145 "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
09bef843 2146 };
748a9306 2147#endif
463ee0b2 2148
02aa26ce
NT
2149/*
2150 yylex
2151
2152 Works out what to call the token just pulled out of the input
2153 stream. The yacc parser takes care of taking the ops we return and
2154 stitching them into a tree.
2155
2156 Returns:
2157 PRIVATEREF
2158
2159 Structure:
2160 if read an identifier
2161 if we're in a my declaration
2162 croak if they tried to say my($foo::bar)
2163 build the ops for a my() declaration
2164 if it's an access to a my() variable
2165 are we in a sort block?
2166 croak if my($a); $a <=> $b
2167 build ops for access to a my() variable
2168 if in a dq string, and they've said @foo and we can't find @foo
2169 croak
2170 build ops for a bareword
2171 if we already built the token before, use it.
2172*/
2173
dba4d153 2174#ifdef USE_PURE_BISON
864dbfa3 2175int
dba4d153 2176Perl_yylex_r(pTHX_ YYSTYPE *lvalp, int *lcharp)
378cc40b 2177{
20141f0e
RI
2178 int r;
2179
6f202aea 2180 yyactlevel++;
20141f0e
RI
2181 yylval_pointer[yyactlevel] = lvalp;
2182 yychar_pointer[yyactlevel] = lcharp;
b73d6f50
RI
2183 if (yyactlevel >= YYMAXLEVEL)
2184 Perl_croak(aTHX_ "panic: YYMAXLEVEL");
20141f0e 2185
dba4d153 2186 r = Perl_yylex(aTHX);
20141f0e 2187
d8ae6756
RI
2188 if (yyactlevel > 0)
2189 yyactlevel--;
20141f0e
RI
2190
2191 return r;
2192}
dba4d153 2193#endif
20141f0e 2194
dba4d153
JH
2195#ifdef __SC__
2196#pragma segment Perl_yylex
2197#endif
dba4d153 2198int
dba4d153 2199Perl_yylex(pTHX)
20141f0e 2200{
79072805 2201 register char *s;
378cc40b 2202 register char *d;
79072805 2203 register I32 tmp;
463ee0b2 2204 STRLEN len;
161b471a
NIS
2205 GV *gv = Nullgv;
2206 GV **gvp = 0;
aa7440fb 2207 bool bof = FALSE;
1d239bbb 2208 I32 orig_keyword = 0;
a687059c 2209
02aa26ce 2210 /* check if there's an identifier for us to look at */
ba979b31 2211 if (PL_pending_ident)
e930465f 2212 return S_pending_ident(aTHX);
bbce6d69 2213
02aa26ce
NT
2214 /* no identifier pending identification */
2215
3280af22 2216 switch (PL_lex_state) {
79072805
LW
2217#ifdef COMMENTARY
2218 case LEX_NORMAL: /* Some compilers will produce faster */
2219 case LEX_INTERPNORMAL: /* code if we comment these out. */
2220 break;
2221#endif
2222
09bef843 2223 /* when we've already built the next token, just pull it out of the queue */
79072805 2224 case LEX_KNOWNEXT:
3280af22
NIS
2225 PL_nexttoke--;
2226 yylval = PL_nextval[PL_nexttoke];
2227 if (!PL_nexttoke) {
2228 PL_lex_state = PL_lex_defer;
2229 PL_expect = PL_lex_expect;
2230 PL_lex_defer = LEX_NORMAL;
463ee0b2 2231 }
607df283 2232 DEBUG_T({ PerlIO_printf(Perl_debug_log,
4659c93f 2233 "### Next token after '%s' was known, type %"IVdf"\n", PL_bufptr,
5f80b19c 2234 (IV)PL_nexttype[PL_nexttoke]); });
607df283 2235
3280af22 2236 return(PL_nexttype[PL_nexttoke]);
79072805 2237
02aa26ce 2238 /* interpolated case modifiers like \L \U, including \Q and \E.
3280af22 2239 when we get here, PL_bufptr is at the \
02aa26ce 2240 */
79072805
LW
2241 case LEX_INTERPCASEMOD:
2242#ifdef DEBUGGING
3280af22 2243 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
cea2e8a9 2244 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
79072805 2245#endif
02aa26ce 2246 /* handle \E or end of string */
3280af22 2247 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
a0d0e21e 2248 char oldmod;
02aa26ce
NT
2249
2250 /* if at a \E */
3280af22
NIS
2251 if (PL_lex_casemods) {
2252 oldmod = PL_lex_casestack[--PL_lex_casemods];
2253 PL_lex_casestack[PL_lex_casemods] = '\0';
02aa26ce 2254
3280af22
NIS
2255 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
2256 PL_bufptr += 2;
2257 PL_lex_state = LEX_INTERPCONCAT;
a0d0e21e 2258 }
79072805
LW
2259 return ')';
2260 }
3280af22
NIS
2261 if (PL_bufptr != PL_bufend)
2262 PL_bufptr += 2;
2263 PL_lex_state = LEX_INTERPCONCAT;
cea2e8a9 2264 return yylex();
79072805
LW
2265 }
2266 else {
607df283 2267 DEBUG_T({ PerlIO_printf(Perl_debug_log,
5f80b19c 2268 "### Saw case modifier at '%s'\n", PL_bufptr); });
3280af22 2269 s = PL_bufptr + 1;
6e909404
JH
2270 if (s[1] == '\\' && s[2] == 'E') {
2271 PL_bufptr = s + 3;
2272 PL_lex_state = LEX_INTERPCONCAT;
2273 return yylex();
a0d0e21e 2274 }
6e909404
JH
2275 else {
2276 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
2277 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
2278 if (strchr("LU", *s) &&
2279 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) {
2280 PL_lex_casestack[--PL_lex_casemods] = '\0';
2281 return ')';
2282 }
2283 if (PL_lex_casemods > 10)
2284 Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
2285 PL_lex_casestack[PL_lex_casemods++] = *s;
2286 PL_lex_casestack[PL_lex_casemods] = '\0';
2287 PL_lex_state = LEX_INTERPCONCAT;
2288 PL_nextval[PL_nexttoke].ival = 0;
2289 force_next('(');
2290 if (*s == 'l')
2291 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
2292 else if (*s == 'u')
2293 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
2294 else if (*s == 'L')
2295 PL_nextval[PL_nexttoke].ival = OP_LC;
2296 else if (*s == 'U')
2297 PL_nextval[PL_nexttoke].ival = OP_UC;
2298 else if (*s == 'Q')
2299 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
2300 else
2301 Perl_croak(aTHX_ "panic: yylex");
2302 PL_bufptr = s + 1;
a0d0e21e 2303 }
79072805 2304 force_next(FUNC);
3280af22
NIS
2305 if (PL_lex_starts) {
2306 s = PL_bufptr;
2307 PL_lex_starts = 0;
79072805
LW
2308 Aop(OP_CONCAT);
2309 }
2310 else
cea2e8a9 2311 return yylex();
79072805
LW
2312 }
2313
55497cff
PP
2314 case LEX_INTERPPUSH:
2315 return sublex_push();
2316
79072805 2317 case LEX_INTERPSTART:
3280af22 2318 if (PL_bufptr == PL_bufend)
79072805 2319 return sublex_done();
607df283 2320 DEBUG_T({ PerlIO_printf(Perl_debug_log,
5f80b19c 2321 "### Interpolated variable at '%s'\n", PL_bufptr); });
3280af22
NIS
2322 PL_expect = XTERM;
2323 PL_lex_dojoin = (*PL_bufptr == '@');
2324 PL_lex_state = LEX_INTERPNORMAL;
2325 if (PL_lex_dojoin) {
2326 PL_nextval[PL_nexttoke].ival = 0;
79072805 2327 force_next(',');
a0d0e21e 2328 force_ident("\"", '$');
3280af22 2329 PL_nextval[PL_nexttoke].ival = 0;
79072805 2330 force_next('$');
3280af22 2331 PL_nextval[PL_nexttoke].ival = 0;
79072805 2332 force_next('(');
3280af22 2333 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
79072805
LW
2334 force_next(FUNC);
2335 }
3280af22
NIS
2336 if (PL_lex_starts++) {
2337 s = PL_bufptr;
79072805
LW
2338 Aop(OP_CONCAT);
2339 }
cea2e8a9 2340 return yylex();
79072805
LW
2341
2342 case LEX_INTERPENDMAYBE:
3280af22
NIS
2343 if (intuit_more(PL_bufptr)) {
2344 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
79072805
LW
2345 break;
2346 }
2347 /* FALL THROUGH */
2348
2349 case LEX_INTERPEND:
3280af22
NIS
2350 if (PL_lex_dojoin) {
2351 PL_lex_dojoin = FALSE;
2352 PL_lex_state = LEX_INTERPCONCAT;
79072805
LW
2353 return ')';
2354 }
43a16006 2355 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
25da4f38 2356 && SvEVALED(PL_lex_repl))
43a16006 2357 {
e9fa98b2 2358 if (PL_bufptr != PL_bufend)
cea2e8a9 2359 Perl_croak(aTHX_ "Bad evalled substitution pattern");
e9fa98b2
HS
2360 PL_lex_repl = Nullsv;
2361 }
79072805
LW
2362 /* FALLTHROUGH */
2363 case LEX_INTERPCONCAT:
2364#ifdef DEBUGGING
3280af22 2365 if (PL_lex_brackets)
cea2e8a9 2366 Perl_croak(aTHX_ "panic: INTERPCONCAT");
79072805 2367#endif
3280af22 2368 if (PL_bufptr == PL_bufend)
79072805
LW
2369 return sublex_done();
2370
3280af22
NIS
2371 if (SvIVX(PL_linestr) == '\'') {
2372 SV *sv = newSVsv(PL_linestr);
2373 if (!PL_lex_inpat)
76e3520e 2374 sv = tokeq(sv);
3280af22 2375 else if ( PL_hints & HINT_NEW_RE )
b3ac6de7 2376 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
79072805 2377 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3280af22 2378 s = PL_bufend;
79072805
LW
2379 }
2380 else {
3280af22 2381 s = scan_const(PL_bufptr);
79072805 2382 if (*s == '\\')
3280af22 2383 PL_lex_state = LEX_INTERPCASEMOD;
79072805 2384 else
3280af22 2385 PL_lex_state = LEX_INTERPSTART;
79072805
LW
2386 }
2387
3280af22
NIS
2388 if (s != PL_bufptr) {
2389 PL_nextval[PL_nexttoke] = yylval;
2390 PL_expect = XTERM;
79072805 2391 force_next(THING);
3280af22 2392 if (PL_lex_starts++)
79072805
LW
2393 Aop(OP_CONCAT);
2394 else {
3280af22 2395 PL_bufptr = s;
cea2e8a9 2396 return yylex();
79072805
LW
2397 }
2398 }
2399
cea2e8a9 2400 return yylex();
a0d0e21e 2401 case LEX_FORMLINE:
3280af22
NIS
2402 PL_lex_state = LEX_NORMAL;
2403 s = scan_formline(PL_bufptr);
2404 if (!PL_lex_formbrack)
a0d0e21e
LW
2405 goto rightbracket;
2406 OPERATOR(';');
79072805
LW
2407 }
2408
3280af22
NIS
2409 s = PL_bufptr;
2410 PL_oldoldbufptr = PL_oldbufptr;
2411 PL_oldbufptr = s;
607df283 2412 DEBUG_T( {
bf49b057
GS
2413 PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at %s\n",
2414 exp_name[PL_expect], s);
5f80b19c 2415 } );
463ee0b2
LW
2416
2417 retry:
378cc40b
LW
2418 switch (*s) {
2419 default:
7e2040f0 2420 if (isIDFIRST_lazy_if(s,UTF))
834a4ddd 2421 goto keylookup;
cea2e8a9 2422 Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
e929a76b
LW
2423 case 4:
2424 case 26:
2425 goto fake_eof; /* emulate EOF on ^D or ^Z */
378cc40b 2426 case 0:
3280af22
NIS
2427 if (!PL_rsfp) {
2428 PL_last_uni = 0;
2429 PL_last_lop = 0;
2430 if (PL_lex_brackets)
d98d5fff 2431 yyerror("Missing right curly or square bracket");
4e553d73 2432 DEBUG_T( { PerlIO_printf(Perl_debug_log,
607df283 2433 "### Tokener got EOF\n");
5f80b19c 2434 } );
79072805 2435 TOKEN(0);
463ee0b2 2436 }
3280af22 2437 if (s++ < PL_bufend)
a687059c 2438 goto retry; /* ignore stray nulls */
3280af22
NIS
2439 PL_last_uni = 0;
2440 PL_last_lop = 0;
2441 if (!PL_in_eval && !PL_preambled) {
2442 PL_preambled = TRUE;
2443 sv_setpv(PL_linestr,incl_perldb());
2444 if (SvCUR(PL_linestr))
2445 sv_catpv(PL_linestr,";");
2446 if (PL_preambleav){
2447 while(AvFILLp(PL_preambleav) >= 0) {
2448 SV *tmpsv = av_shift(PL_preambleav);
2449 sv_catsv(PL_linestr, tmpsv);
2450 sv_catpv(PL_linestr, ";");
91b7def8
PP
2451 sv_free(tmpsv);
2452 }
3280af22
NIS
2453 sv_free((SV*)PL_preambleav);
2454 PL_preambleav = NULL;
91b7def8 2455 }
3280af22
NIS
2456 if (PL_minus_n || PL_minus_p) {
2457 sv_catpv(PL_linestr, "LINE: while (<>) {");
2458 if (PL_minus_l)
2459 sv_catpv(PL_linestr,"chomp;");
2460 if (PL_minus_a) {
3280af22
NIS
2461 if (PL_minus_F) {
2462 if (strchr("/'\"", *PL_splitstr)
2463 && strchr(PL_splitstr + 1, *PL_splitstr))
3db68c4c 2464 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
54310121
PP
2465 else {
2466 char delim;
2467 s = "'~#\200\1'"; /* surely one char is unused...*/
3280af22 2468 while (s[1] && strchr(PL_splitstr, *s)) s++;
54310121 2469 delim = *s;
75c72d73 2470 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s%c",
46fc3d4c 2471 "q" + (delim == '\''), delim);
3280af22 2472 for (s = PL_splitstr; *s; s++) {
54310121 2473 if (*s == '\\')
3280af22
NIS
2474 sv_catpvn(PL_linestr, "\\", 1);
2475 sv_catpvn(PL_linestr, s, 1);
54310121 2476 }
cea2e8a9 2477 Perl_sv_catpvf(aTHX_ PL_linestr, "%c);", delim);
54310121 2478 }
2304df62
AD
2479 }
2480 else
75c72d73 2481 sv_catpv(PL_linestr,"our @F=split(' ');");
2304df62 2482 }
79072805 2483 }
3280af22
NIS
2484 sv_catpv(PL_linestr, "\n");
2485 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2486 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
207e3d1a 2487 PL_last_lop = PL_last_uni = Nullch;
3280af22 2488 if (PERLDB_LINE && PL_curstash != PL_debstash) {
a0d0e21e
LW
2489 SV *sv = NEWSV(85,0);
2490
2491 sv_upgrade(sv, SVt_PVMG);
3280af22 2492 sv_setsv(sv,PL_linestr);
0ac0412a
MJD
2493 (void)SvIOK_on(sv);
2494 SvIVX(sv) = 0;
57843af0 2495 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
a0d0e21e 2496 }
79072805 2497 goto retry;
a687059c 2498 }
e929a76b 2499 do {
aa7440fb 2500 bof = PL_rsfp ? TRUE : FALSE;
7e28d3af
JH
2501 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
2502 fake_eof:
2503 if (PL_rsfp) {
2504 if (PL_preprocess && !PL_in_eval)
2505 (void)PerlProc_pclose(PL_rsfp);
2506 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2507 PerlIO_clearerr(PL_rsfp);
2508 else
2509 (void)PerlIO_close(PL_rsfp);
2510 PL_rsfp = Nullfp;
2511 PL_doextract = FALSE;
2512 }
2513 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2514 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
2515 sv_catpv(PL_linestr,";}");
2516 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2517 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
207e3d1a 2518 PL_last_lop = PL_last_uni = Nullch;
7e28d3af
JH
2519 PL_minus_n = PL_minus_p = 0;
2520 goto retry;
2521 }
2522 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
207e3d1a 2523 PL_last_lop = PL_last_uni = Nullch;
7e28d3af
JH
2524 sv_setpv(PL_linestr,"");
2525 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
2526 }
2527 /* if it looks like the start of a BOM, check if it in fact is */
2528 else if (bof && (!*s || *(U8*)s == 0xEF || *(U8*)s >= 0xFE)) {
226017aa 2529#ifdef PERLIO_IS_STDIO
e3f494f1
JH
2530# ifdef __GNU_LIBRARY__
2531# if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
226017aa
DD
2532# define FTELL_FOR_PIPE_IS_BROKEN
2533# endif
e3f494f1
JH
2534# else
2535# ifdef __GLIBC__
2536# if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
2537# define FTELL_FOR_PIPE_IS_BROKEN
2538# endif
2539# endif
226017aa
DD
2540# endif
2541#endif
2542#ifdef FTELL_FOR_PIPE_IS_BROKEN
2543 /* This loses the possibility to detect the bof
2544 * situation on perl -P when the libc5 is being used.
2545 * Workaround? Maybe attach some extra state to PL_rsfp?
2546 */
2547 if (!PL_preprocess)
7e28d3af 2548 bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
226017aa 2549#else
eb160463 2550 bof = PerlIO_tell(PL_rsfp) == (Off_t)SvCUR(PL_linestr);
226017aa 2551#endif
7e28d3af 2552 if (bof) {
3280af22 2553 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7e28d3af 2554 s = swallow_bom((U8*)s);
e929a76b 2555 }
378cc40b 2556 }
3280af22 2557 if (PL_doextract) {
a0d0e21e
LW
2558 /* Incest with pod. */
2559 if (*s == '=' && strnEQ(s, "=cut", 4)) {
3280af22
NIS
2560 sv_setpv(PL_linestr, "");
2561 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2562 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
207e3d1a 2563 PL_last_lop = PL_last_uni = Nullch;
3280af22 2564 PL_doextract = FALSE;
a0d0e21e 2565 }
4e553d73 2566 }
463ee0b2 2567 incline(s);
3280af22
NIS
2568 } while (PL_doextract);
2569 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2570 if (PERLDB_LINE && PL_curstash != PL_debstash) {
79072805 2571 SV *sv = NEWSV(85,0);
a687059c 2572
93a17b20 2573 sv_upgrade(sv, SVt_PVMG);
3280af22 2574 sv_setsv(sv,PL_linestr);
0ac0412a
MJD
2575 (void)SvIOK_on(sv);
2576 SvIVX(sv) = 0;
57843af0 2577 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
a687059c 2578 }
3280af22 2579 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
207e3d1a 2580 PL_last_lop = PL_last_uni = Nullch;
57843af0 2581 if (CopLINE(PL_curcop) == 1) {
3280af22 2582 while (s < PL_bufend && isSPACE(*s))
79072805 2583 s++;
a0d0e21e 2584 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
79072805 2585 s++;
44a8e56a 2586 d = Nullch;
3280af22 2587 if (!PL_in_eval) {
44a8e56a
PP
2588 if (*s == '#' && *(s+1) == '!')
2589 d = s + 2;
2590#ifdef ALTERNATE_SHEBANG
2591 else {
2592 static char as[] = ALTERNATE_SHEBANG;
2593 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2594 d = s + (sizeof(as) - 1);
2595 }
2596#endif /* ALTERNATE_SHEBANG */
2597 }
2598 if (d) {
b8378b72 2599 char *ipath;
774d564b 2600 char *ipathend;
b8378b72 2601
774d564b 2602 while (isSPACE(*d))
b8378b72
CS
2603 d++;
2604 ipath = d;
774d564b
PP
2605 while (*d && !isSPACE(*d))
2606 d++;
2607 ipathend = d;
2608
2609#ifdef ARG_ZERO_IS_SCRIPT
2610 if (ipathend > ipath) {
2611 /*
2612 * HP-UX (at least) sets argv[0] to the script name,
2613 * which makes $^X incorrect. And Digital UNIX and Linux,
2614 * at least, set argv[0] to the basename of the Perl
2615 * interpreter. So, having found "#!", we'll set it right.
2616 */
ee2f7564 2617 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV)); /* $^X */
774d564b 2618 assert(SvPOK(x) || SvGMAGICAL(x));
cc49e20b 2619 if (sv_eq(x, CopFILESV(PL_curcop))) {
774d564b 2620 sv_setpvn(x, ipath, ipathend - ipath);
9607fc9c
PP
2621 SvSETMAGIC(x);
2622 }
556c1dec
JH
2623 else {
2624 STRLEN blen;
2625 STRLEN llen;
2626 char *bstart = SvPV(CopFILESV(PL_curcop),blen);
2627 char *lstart = SvPV(x,llen);
2628 if (llen < blen) {
2629 bstart += blen - llen;
2630 if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
2631 sv_setpvn(x, ipath, ipathend - ipath);
2632 SvSETMAGIC(x);
2633 }
2634 }
2635 }
774d564b 2636 TAINT_NOT; /* $^X is always tainted, but that's OK */
8ebc5c01 2637 }
774d564b 2638#endif /* ARG_ZERO_IS_SCRIPT */
b8378b72
CS
2639
2640 /*
2641 * Look for options.
2642 */
748a9306 2643 d = instr(s,"perl -");
84e30d1a 2644 if (!d) {
748a9306 2645 d = instr(s,"perl");
84e30d1a
GS
2646#if defined(DOSISH)
2647 /* avoid getting into infinite loops when shebang
2648 * line contains "Perl" rather than "perl" */
2649 if (!d) {
2650 for (d = ipathend-4; d >= ipath; --d) {
2651 if ((*d == 'p' || *d == 'P')
2652 && !ibcmp(d, "perl", 4))
2653 {
2654 break;
2655 }
2656 }
2657 if (d < ipath)
2658 d = Nullch;
2659 }
2660#endif
2661 }
44a8e56a
PP
2662#ifdef ALTERNATE_SHEBANG
2663 /*
2664 * If the ALTERNATE_SHEBANG on this system starts with a
2665 * character that can be part of a Perl expression, then if
2666 * we see it but not "perl", we're probably looking at the
2667 * start of Perl code, not a request to hand off to some
2668 * other interpreter. Similarly, if "perl" is there, but
2669 * not in the first 'word' of the line, we assume the line
2670 * contains the start of the Perl program.
44a8e56a
PP
2671 */
2672 if (d && *s != '#') {
774d564b 2673 char *c = ipath;
44a8e56a
PP
2674 while (*c && !strchr("; \t\r\n\f\v#", *c))
2675 c++;
2676 if (c < d)
2677 d = Nullch; /* "perl" not in first word; ignore */
2678 else
2679 *s = '#'; /* Don't try to parse shebang line */
2680 }
774d564b 2681#endif /* ALTERNATE_SHEBANG */
bf4acbe4 2682#ifndef MACOS_TRADITIONAL
748a9306 2683 if (!d &&
44a8e56a 2684 *s == '#' &&
774d564b 2685 ipathend > ipath &&
3280af22 2686 !PL_minus_c &&
748a9306 2687 !instr(s,"indir") &&
3280af22 2688 instr(PL_origargv[0],"perl"))
748a9306 2689 {
9f68db38 2690 char **newargv;
9f68db38 2691
774d564b
PP
2692 *ipathend = '\0';
2693 s = ipathend + 1;
3280af22 2694 while (s < PL_bufend && isSPACE(*s))
9f68db38 2695 s++;
3280af22
NIS
2696 if (s < PL_bufend) {
2697 Newz(899,newargv,PL_origargc+3,char*);
9f68db38 2698 newargv[1] = s;
3280af22 2699 while (s < PL_bufend && !isSPACE(*s))
9f68db38
LW
2700 s++;
2701 *s = '\0';
3280af22 2702 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
9f68db38
LW
2703 }
2704 else
3280af22 2705 newargv = PL_origargv;
774d564b 2706 newargv[0] = ipath;
b35112e7 2707 PERL_FPU_PRE_EXEC
b4748376 2708 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
b35112e7 2709 PERL_FPU_POST_EXEC
cea2e8a9 2710 Perl_croak(aTHX_ "Can't exec %s", ipath);
9f68db38 2711 }
bf4acbe4 2712#endif
748a9306 2713 if (d) {
3280af22
NIS
2714 U32 oldpdb = PL_perldb;
2715 bool oldn = PL_minus_n;
2716 bool oldp = PL_minus_p;
748a9306
LW
2717
2718 while (*d && !isSPACE(*d)) d++;
bf4acbe4 2719 while (SPACE_OR_TAB(*d)) d++;
748a9306
LW
2720
2721 if (*d++ == '-') {
a11ec5a9 2722 bool switches_done = PL_doswitches;
8cc95fdb
PP
2723 do {
2724 if (*d == 'M' || *d == 'm') {
2725 char *m = d;
2726 while (*d && !isSPACE(*d)) d++;
cea2e8a9 2727 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
8cc95fdb
PP
2728 (int)(d - m), m);
2729 }
2730 d = moreswitches(d);
2731 } while (d);
f0b2cf55
YST
2732 if (PL_doswitches && !switches_done) {
2733 int argc = PL_origargc;
2734 char **argv = PL_origargv;
2735 do {
2736 argc--,argv++;
2737 } while (argc && argv[0][0] == '-' && argv[0][1]);
2738 init_argv_symbols(argc,argv);
2739 }
155aba94
GS
2740 if ((PERLDB_LINE && !oldpdb) ||
2741 ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
b084f20b
PP
2742 /* if we have already added "LINE: while (<>) {",
2743 we must not do it again */
748a9306 2744 {
3280af22
NIS
2745 sv_setpv(PL_linestr, "");
2746 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2747 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
207e3d1a 2748 PL_last_lop = PL_last_uni = Nullch;
3280af22 2749 PL_preambled = FALSE;
84902520 2750 if (PERLDB_LINE)
3280af22 2751 (void)gv_fetchfile(PL_origfilename);
748a9306
LW
2752 goto retry;
2753 }
a11ec5a9
RGS
2754 if (PL_doswitches && !switches_done) {
2755 int argc = PL_origargc;
2756 char **argv = PL_origargv;
2757 do {
2758 argc--,argv++;
2759 } while (argc && argv[0][0] == '-' && argv[0][1]);
2760 init_argv_symbols(argc,argv);
2761 }
a0d0e21e 2762 }
79072805 2763 }
9f68db38 2764 }
79072805 2765 }
3280af22
NIS
2766 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2767 PL_bufptr = s;
2768 PL_lex_state = LEX_FORMLINE;
cea2e8a9 2769 return yylex();
ae986130 2770 }
378cc40b 2771 goto retry;
4fdae800 2772 case '\r':
6a27c188 2773#ifdef PERL_STRICT_CR
cea2e8a9 2774 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
4e553d73 2775 Perl_croak(aTHX_
cc507455 2776 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
a868473f 2777#endif
4fdae800 2778 case ' ': case '\t': case '\f': case 013:
bf4acbe4
GS
2779#ifdef MACOS_TRADITIONAL
2780 case '\312':
2781#endif
378cc40b
LW
2782 s++;
2783 goto retry;
378cc40b 2784 case '#':
e929a76b 2785 case '\n':
3280af22 2786 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
df0deb90
GS
2787 if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
2788 /* handle eval qq[#line 1 "foo"\n ...] */
2789 CopLINE_dec(PL_curcop);
2790 incline(s);
2791 }
3280af22 2792 d = PL_bufend;
a687059c 2793 while (s < d && *s != '\n')
378cc40b 2794 s++;
0f85fab0 2795 if (s < d)
378cc40b 2796 s++;
78c267c1 2797 else if (s > d) /* Found by Ilya: feed random input to Perl. */
a8406387 2798 Perl_croak(aTHX_ "panic: input overflow");
463ee0b2 2799 incline(s);
3280af22
NIS
2800 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2801 PL_bufptr = s;
2802 PL_lex_state = LEX_FORMLINE;
cea2e8a9 2803 return yylex();
a687059c 2804 }
378cc40b 2805 }
a687059c 2806 else {
378cc40b 2807 *s = '\0';
3280af22 2808 PL_bufend = s;
a687059c 2809 }
378cc40b
LW
2810 goto retry;
2811 case '-':
79072805 2812 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
e5edeb50
JH
2813 I32 ftst = 0;
2814
378cc40b 2815 s++;
3280af22 2816 PL_bufptr = s;
748a9306
LW
2817 tmp = *s++;
2818
bf4acbe4 2819 while (s < PL_bufend && SPACE_OR_TAB(*s))
748a9306
LW
2820 s++;
2821
2822 if (strnEQ(s,"=>",2)) {
3280af22 2823 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
4e553d73 2824 DEBUG_T( { PerlIO_printf(Perl_debug_log,
607df283 2825 "### Saw unary minus before =>, forcing word '%s'\n", s);
5f80b19c 2826 } );
748a9306
LW
2827 OPERATOR('-'); /* unary minus */
2828 }
3280af22 2829 PL_last_uni = PL_oldbufptr;
748a9306 2830 switch (tmp) {
e5edeb50
JH
2831 case 'r': ftst = OP_FTEREAD; break;
2832 case 'w': ftst = OP_FTEWRITE; break;
2833 case 'x': ftst = OP_FTEEXEC; break;
2834 case 'o': ftst = OP_FTEOWNED; break;
2835 case 'R': ftst = OP_FTRREAD; break;
2836 case 'W': ftst = OP_FTRWRITE; break;
2837 case 'X': ftst = OP_FTREXEC; break;
2838 case 'O': ftst = OP_FTROWNED; break;
2839 case 'e': ftst = OP_FTIS; break;
2840 case 'z': ftst = OP_FTZERO; break;
2841 case 's': ftst = OP_FTSIZE; break;
2842 case 'f': ftst = OP_FTFILE; break;
2843 case 'd': ftst = OP_FTDIR; break;
2844 case 'l': ftst = OP_FTLINK; break;
2845 case 'p': ftst = OP_FTPIPE; break;
2846 case 'S': ftst = OP_FTSOCK; break;
2847 case 'u': ftst = OP_FTSUID; break;
2848 case 'g': ftst = OP_FTSGID; break;
2849 case 'k': ftst = OP_FTSVTX; break;
2850 case 'b': ftst = OP_FTBLK; break;
2851 case 'c': ftst = OP_FTCHR; break;
2852 case 't': ftst = OP_FTTTY; break;
2853 case 'T': ftst = OP_FTTEXT; break;
2854 case 'B': ftst = OP_FTBINARY; break;
2855 case 'M': case 'A': case 'C':
2856 gv_fetchpv("\024",TRUE, SVt_PV);
2857 switch (tmp) {
2858 case 'M': ftst = OP_FTMTIME; break;
2859 case 'A': ftst = OP_FTATIME; break;
2860 case 'C': ftst = OP_FTCTIME; break;
2861 default: break;
2862 }
2863 break;
378cc40b 2864 default:
378cc40b
LW
2865 break;
2866 }
e5edeb50 2867 if (ftst) {
eb160463 2868 PL_last_lop_op = (OPCODE)ftst;
4e553d73 2869 DEBUG_T( { PerlIO_printf(Perl_debug_log,
0844c848 2870 "### Saw file test %c\n", (int)ftst);
5f80b19c 2871 } );
e5edeb50
JH
2872 FTST(ftst);
2873 }
2874 else {
2875 /* Assume it was a minus followed by a one-letter named
2876 * subroutine call (or a -bareword), then. */
95c31fe3 2877 DEBUG_T( { PerlIO_printf(Perl_debug_log,
17ad61e0
RGS
2878 "### '-%c' looked like a file test but was not\n",
2879 tmp);
5f80b19c 2880 } );
3cf7b4c4 2881 s = --PL_bufptr;
e5edeb50 2882 }
378cc40b 2883 }
a687059c
LW
2884 tmp = *s++;
2885 if (*s == tmp) {
2886 s++;
3280af22 2887 if (PL_expect == XOPERATOR)
79072805
LW
2888 TERM(POSTDEC);
2889 else
2890 OPERATOR(PREDEC);
2891 }
2892 else if (*s == '>') {
2893 s++;
2894 s = skipspace(s);
7e2040f0 2895 if (isIDFIRST_lazy_if(s,UTF)) {
a0d0e21e 2896 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
463ee0b2 2897 TOKEN(ARROW);
79072805 2898 }
748a9306
LW
2899 else if (*s == '$')
2900 OPERATOR(ARROW);
463ee0b2 2901 else
748a9306 2902 TERM(ARROW);
a687059c 2903 }
3280af22 2904 if (PL_expect == XOPERATOR)
79072805
LW
2905 Aop(OP_SUBTRACT);
2906 else {
3280af22 2907 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2f3197b3 2908 check_uni();
79072805 2909 OPERATOR('-'); /* unary minus */
2f3197b3 2910 }
79072805 2911
378cc40b 2912 case '+':
a687059c
LW
2913 tmp = *s++;
2914 if (*s == tmp) {
378cc40b 2915 s++;
3280af22 2916 if (PL_expect == XOPERATOR)
79072805
LW
2917 TERM(POSTINC);
2918 else
2919 OPERATOR(PREINC);
378cc40b 2920 }
3280af22 2921 if (PL_expect == XOPERATOR)
79072805
LW
2922 Aop(OP_ADD);
2923 else {
3280af22 2924 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2f3197b3 2925 check_uni();
a687059c 2926 OPERATOR('+');
2f3197b3 2927 }
a687059c 2928
378cc40b 2929 case '*':
3280af22
NIS
2930 if (PL_expect != XOPERATOR) {
2931 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2932 PL_expect = XOPERATOR;
2933 force_ident(PL_tokenbuf, '*');
2934 if (!*PL_tokenbuf)
a0d0e21e 2935 PREREF('*');
79072805 2936 TERM('*');
a687059c 2937 }
79072805
LW
2938 s++;
2939 if (*s == '*') {
a687059c 2940 s++;
79072805 2941 PWop(OP_POW);
a687059c 2942 }
79072805
LW
2943 Mop(OP_MULTIPLY);
2944
378cc40b 2945 case '%':
3280af22 2946 if (PL_expect == XOPERATOR) {
bbce6d69
PP
2947 ++s;
2948 Mop(OP_MODULO);
a687059c 2949 }
3280af22
NIS
2950 PL_tokenbuf[0] = '%';
2951 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2952 if (!PL_tokenbuf[1]) {
bbce6d69 2953 PREREF('%');
a687059c 2954 }
3280af22 2955 PL_pending_ident = '%';
bbce6d69 2956 TERM('%');
a687059c 2957
378cc40b 2958 case '^':
79072805 2959 s++;
a0d0e21e 2960 BOop(OP_BIT_XOR);
79072805 2961 case '[':
3280af22 2962 PL_lex_brackets++;
79072805 2963 /* FALL THROUGH */
378cc40b 2964 case '~':
378cc40b 2965 case ',':
378cc40b
LW
2966 tmp = *s++;
2967 OPERATOR(tmp);
a0d0e21e
LW
2968 case ':':
2969 if (s[1] == ':') {
2970 len = 0;
2971 goto just_a_word;
2972 }
2973 s++;
09bef843
SB
2974 switch (PL_expect) {
2975 OP *attrs;
2976 case XOPERATOR:
2977 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
2978 break;
2979 PL_bufptr = s; /* update in case we back off */
2980 goto grabattrs;
2981 case XATTRBLOCK:
2982 PL_expect = XBLOCK;
2983 goto grabattrs;
2984 case XATTRTERM:
2985 PL_expect = XTERMBLOCK;
2986 grabattrs:
2987 s = skipspace(s);
2988 attrs = Nullop;
7e2040f0 2989 while (isIDFIRST_lazy_if(s,UTF)) {
09bef843 2990 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
f9829d6b
GS
2991 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
2992 if (tmp < 0) tmp = -tmp;
2993 switch (tmp) {
2994 case KEY_or:
2995 case KEY_and:
c963b151 2996 case KEY_err:
f9829d6b
GS
2997 case KEY_for:
2998 case KEY_unless:
2999 case KEY_if:
3000 case KEY_while:
3001 case KEY_until:
3002 goto got_attrs;
3003 default:
3004 break;
3005 }
3006 }
09bef843
SB
3007 if (*d == '(') {
3008 d = scan_str(d,TRUE,TRUE);
3009 if (!d) {
09bef843
SB
3010 /* MUST advance bufptr here to avoid bogus
3011 "at end of line" context messages from yyerror().
3012 */
3013 PL_bufptr = s + len;
3014 yyerror("Unterminated attribute parameter in attribute list");
3015 if (attrs)
3016 op_free(attrs);
3017 return 0; /* EOF indicator */
3018 }
3019 }
3020 if (PL_lex_stuff) {
3021 SV *sv = newSVpvn(s, len);
3022 sv_catsv(sv, PL_lex_stuff);
3023 attrs = append_elem(OP_LIST, attrs,
3024 newSVOP(OP_CONST, 0, sv));
3025 SvREFCNT_dec(PL_lex_stuff);
3026 PL_lex_stuff = Nullsv;
3027 }
3028 else {
d3cea301
SB
3029 /* NOTE: any CV attrs applied here need to be part of
3030 the CVf_BUILTIN_ATTRS define in cv.h! */
78f9721b
SM
3031 if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len))
3032 CvLVALUE_on(PL_compcv);
3033 else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len))
3034 CvLOCKED_on(PL_compcv);
3035 else if (!PL_in_my && len == 6 && strnEQ(s, "method", len))
3036 CvMETHOD_on(PL_compcv);
06492da6
SF
3037 else if (!PL_in_my && len == 9 && strnEQ(s, "assertion", len))
3038 CvASSERTION_on(PL_compcv);
d3cea301
SB
3039 else if (PL_in_my == KEY_our && len == 6 &&
3040 strnEQ(s, "unique", len))
8becbb3b 3041#ifdef USE_ITHREADS
7fb37951 3042 GvUNIQUE_on(cGVOPx_gv(yylval.opval));
8becbb3b
RGS
3043#else
3044 ; /* skip that case to avoid loading attributes.pm */
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 }