This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
RE: maint @ 19683
[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),
4e553d73 685 "Warning: Use of \"%s\" without parens 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;
79072805
LW
789 force_next(token);
790 }
791 return s;
792}
793
ffb4593c
NT
794/*
795 * S_force_ident
9cbb5ea2 796 * Called when the lexer wants $foo *foo &foo etc, but the program
ffb4593c
NT
797 * text only contains the "foo" portion. The first argument is a pointer
798 * to the "foo", and the second argument is the type symbol to prefix.
799 * Forces the next token to be a "WORD".
9cbb5ea2 800 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
ffb4593c
NT
801 */
802
76e3520e 803STATIC void
cea2e8a9 804S_force_ident(pTHX_ register char *s, int kind)
79072805
LW
805{
806 if (s && *s) {
11343788 807 OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
3280af22 808 PL_nextval[PL_nexttoke].opval = o;
79072805 809 force_next(WORD);
748a9306 810 if (kind) {
11343788 811 o->op_private = OPpCONST_ENTERED;
55497cff
PP
812 /* XXX see note in pp_entereval() for why we forgo typo
813 warnings if the symbol must be introduced in an eval.
814 GSAR 96-10-12 */
3280af22 815 gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
a0d0e21e
LW
816 kind == '$' ? SVt_PV :
817 kind == '@' ? SVt_PVAV :
818 kind == '%' ? SVt_PVHV :
819 SVt_PVGV
820 );
748a9306 821 }
79072805
LW
822 }
823}
824
1571675a
GS
825NV
826Perl_str_to_version(pTHX_ SV *sv)
827{
828 NV retval = 0.0;
829 NV nshift = 1.0;
830 STRLEN len;
831 char *start = SvPVx(sv,len);
3aa33fe5 832 bool utf = SvUTF8(sv) ? TRUE : FALSE;
1571675a
GS
833 char *end = start + len;
834 while (start < end) {
ba210ebe 835 STRLEN skip;
1571675a
GS
836 UV n;
837 if (utf)
9041c2e3 838 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
1571675a
GS
839 else {
840 n = *(U8*)start;
841 skip = 1;
842 }
843 retval += ((NV)n)/nshift;
844 start += skip;
845 nshift *= 1000;
846 }
847 return retval;
848}
849
4e553d73 850/*
ffb4593c
NT
851 * S_force_version
852 * Forces the next token to be a version number.
e759cc13
RGS
853 * If the next token appears to be an invalid version number, (e.g. "v2b"),
854 * and if "guessing" is TRUE, then no new token is created (and the caller
855 * must use an alternative parsing method).
ffb4593c
NT
856 */
857
76e3520e 858STATIC char *
e759cc13 859S_force_version(pTHX_ char *s, int guessing)
89bfa8cd
PP
860{
861 OP *version = Nullop;
44dcb63b 862 char *d;
89bfa8cd
PP
863
864 s = skipspace(s);
865
44dcb63b 866 d = s;
dd629d5b 867 if (*d == 'v')
44dcb63b 868 d++;
44dcb63b 869 if (isDIGIT(*d)) {
e759cc13
RGS
870 while (isDIGIT(*d) || *d == '_' || *d == '.')
871 d++;
9f3d182e 872 if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
dd629d5b 873 SV *ver;
b73d6f50 874 s = scan_num(s, &yylval);
89bfa8cd 875 version = yylval.opval;
dd629d5b
GS
876 ver = cSVOPx(version)->op_sv;
877 if (SvPOK(ver) && !SvNIOK(ver)) {
155aba94 878 (void)SvUPGRADE(ver, SVt_PVNV);
1571675a
GS
879 SvNVX(ver) = str_to_version(ver);
880 SvNOK_on(ver); /* hint that it is a version */
44dcb63b 881 }
89bfa8cd 882 }
e759cc13
RGS
883 else if (guessing)
884 return s;
89bfa8cd
PP
885 }
886
887 /* NOTE: The parser sees the package name and the VERSION swapped */
3280af22 888 PL_nextval[PL_nexttoke].opval = version;
4e553d73 889 force_next(WORD);
89bfa8cd 890
e759cc13 891 return s;
89bfa8cd
PP
892}
893
ffb4593c
NT
894/*
895 * S_tokeq
896 * Tokenize a quoted string passed in as an SV. It finds the next
897 * chunk, up to end of string or a backslash. It may make a new
898 * SV containing that chunk (if HINT_NEW_STRING is on). It also
899 * turns \\ into \.
900 */
901
76e3520e 902STATIC SV *
cea2e8a9 903S_tokeq(pTHX_ SV *sv)
79072805
LW
904{
905 register char *s;
906 register char *send;
907 register char *d;
b3ac6de7
IZ
908 STRLEN len = 0;
909 SV *pv = sv;
79072805
LW
910
911 if (!SvLEN(sv))
b3ac6de7 912 goto finish;
79072805 913
a0d0e21e 914 s = SvPV_force(sv, len);
21a311ee 915 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
b3ac6de7 916 goto finish;
463ee0b2 917 send = s + len;
79072805
LW
918 while (s < send && *s != '\\')
919 s++;
920 if (s == send)
b3ac6de7 921 goto finish;
79072805 922 d = s;
be4731d2 923 if ( PL_hints & HINT_NEW_STRING ) {
79cb57f6 924 pv = sv_2mortal(newSVpvn(SvPVX(pv), len));
be4731d2
NIS
925 if (SvUTF8(sv))
926 SvUTF8_on(pv);
927 }
79072805
LW
928 while (s < send) {
929 if (*s == '\\') {
a0d0e21e 930 if (s + 1 < send && (s[1] == '\\'))
79072805
LW
931 s++; /* all that, just for this */
932 }
933 *d++ = *s++;
934 }
935 *d = '\0';
463ee0b2 936 SvCUR_set(sv, d - SvPVX(sv));
b3ac6de7 937 finish:
3280af22 938 if ( PL_hints & HINT_NEW_STRING )
b3ac6de7 939 return new_constant(NULL, 0, "q", sv, pv, "q");
79072805
LW
940 return sv;
941}
942
ffb4593c
NT
943/*
944 * Now come three functions related to double-quote context,
945 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
946 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
947 * interact with PL_lex_state, and create fake ( ... ) argument lists
948 * to handle functions and concatenation.
949 * They assume that whoever calls them will be setting up a fake
950 * join call, because each subthing puts a ',' after it. This lets
951 * "lower \luPpEr"
952 * become
953 * join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
954 *
955 * (I'm not sure whether the spurious commas at the end of lcfirst's
956 * arguments and join's arguments are created or not).
957 */
958
959/*
960 * S_sublex_start
961 * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST).
962 *
963 * Pattern matching will set PL_lex_op to the pattern-matching op to
964 * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise).
965 *
966 * OP_CONST and OP_READLINE are easy--just make the new op and return.
967 *
968 * Everything else becomes a FUNC.
969 *
970 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
971 * had an OP_CONST or OP_READLINE). This just sets us up for a
972 * call to S_sublex_push().
973 */
974
76e3520e 975STATIC I32
cea2e8a9 976S_sublex_start(pTHX)
79072805
LW
977{
978 register I32 op_type = yylval.ival;
79072805
LW
979
980 if (op_type == OP_NULL) {
3280af22
NIS
981 yylval.opval = PL_lex_op;
982 PL_lex_op = Nullop;
79072805
LW
983 return THING;
984 }
985 if (op_type == OP_CONST || op_type == OP_READLINE) {
3280af22 986 SV *sv = tokeq(PL_lex_stuff);
b3ac6de7
IZ
987
988 if (SvTYPE(sv) == SVt_PVIV) {
989 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
990 STRLEN len;
991 char *p;
992 SV *nsv;
993
994 p = SvPV(sv, len);
79cb57f6 995 nsv = newSVpvn(p, len);
01ec43d0
GS
996 if (SvUTF8(sv))
997 SvUTF8_on(nsv);
b3ac6de7
IZ
998 SvREFCNT_dec(sv);
999 sv = nsv;
4e553d73 1000 }
b3ac6de7 1001 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
3280af22 1002 PL_lex_stuff = Nullsv;
6f33ba73
RGS
1003 /* Allow <FH> // "foo" */
1004 if (op_type == OP_READLINE)
1005 PL_expect = XTERMORDORDOR;
79072805
LW
1006 return THING;
1007 }
1008
3280af22
NIS
1009 PL_sublex_info.super_state = PL_lex_state;
1010 PL_sublex_info.sub_inwhat = op_type;
1011 PL_sublex_info.sub_op = PL_lex_op;
1012 PL_lex_state = LEX_INTERPPUSH;
55497cff 1013
3280af22
NIS
1014 PL_expect = XTERM;
1015 if (PL_lex_op) {
1016 yylval.opval = PL_lex_op;
1017 PL_lex_op = Nullop;
55497cff
PP
1018 return PMFUNC;
1019 }
1020 else
1021 return FUNC;
1022}
1023
ffb4593c
NT
1024/*
1025 * S_sublex_push
1026 * Create a new scope to save the lexing state. The scope will be
1027 * ended in S_sublex_done. Returns a '(', starting the function arguments
1028 * to the uc, lc, etc. found before.
1029 * Sets PL_lex_state to LEX_INTERPCONCAT.
1030 */
1031
76e3520e 1032STATIC I32
cea2e8a9 1033S_sublex_push(pTHX)
55497cff 1034{
f46d017c 1035 ENTER;
55497cff 1036
3280af22
NIS
1037 PL_lex_state = PL_sublex_info.super_state;
1038 SAVEI32(PL_lex_dojoin);
1039 SAVEI32(PL_lex_brackets);
3280af22
NIS
1040 SAVEI32(PL_lex_casemods);
1041 SAVEI32(PL_lex_starts);
1042 SAVEI32(PL_lex_state);
7766f137 1043 SAVEVPTR(PL_lex_inpat);
3280af22 1044 SAVEI32(PL_lex_inwhat);
57843af0 1045 SAVECOPLINE(PL_curcop);
3280af22 1046 SAVEPPTR(PL_bufptr);
8452ff4b 1047 SAVEPPTR(PL_bufend);
3280af22
NIS
1048 SAVEPPTR(PL_oldbufptr);
1049 SAVEPPTR(PL_oldoldbufptr);
207e3d1a
JH
1050 SAVEPPTR(PL_last_lop);
1051 SAVEPPTR(PL_last_uni);
3280af22
NIS
1052 SAVEPPTR(PL_linestart);
1053 SAVESPTR(PL_linestr);
8edd5f42
RGS
1054 SAVEGENERICPV(PL_lex_brackstack);
1055 SAVEGENERICPV(PL_lex_casestack);
3280af22
NIS
1056
1057 PL_linestr = PL_lex_stuff;
1058 PL_lex_stuff = Nullsv;
1059
9cbb5ea2
GS
1060 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
1061 = SvPVX(PL_linestr);
3280af22 1062 PL_bufend += SvCUR(PL_linestr);
207e3d1a 1063 PL_last_lop = PL_last_uni = Nullch;
3280af22
NIS
1064 SAVEFREESV(PL_linestr);
1065
1066 PL_lex_dojoin = FALSE;
1067 PL_lex_brackets = 0;
3280af22
NIS
1068 New(899, PL_lex_brackstack, 120, char);
1069 New(899, PL_lex_casestack, 12, char);
3280af22
NIS
1070 PL_lex_casemods = 0;
1071 *PL_lex_casestack = '\0';
1072 PL_lex_starts = 0;
1073 PL_lex_state = LEX_INTERPCONCAT;
eb160463 1074 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
3280af22
NIS
1075
1076 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1077 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1078 PL_lex_inpat = PL_sublex_info.sub_op;
79072805 1079 else
3280af22 1080 PL_lex_inpat = Nullop;
79072805 1081
55497cff 1082 return '(';
79072805
LW
1083}
1084
ffb4593c
NT
1085/*
1086 * S_sublex_done
1087 * Restores lexer state after a S_sublex_push.
1088 */
1089
76e3520e 1090STATIC I32
cea2e8a9 1091S_sublex_done(pTHX)
79072805 1092{
3280af22 1093 if (!PL_lex_starts++) {
9aa983d2
JH
1094 SV *sv = newSVpvn("",0);
1095 if (SvUTF8(PL_linestr))
1096 SvUTF8_on(sv);
3280af22 1097 PL_expect = XOPERATOR;
9aa983d2 1098 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
79072805
LW
1099 return THING;
1100 }
1101
3280af22
NIS
1102 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
1103 PL_lex_state = LEX_INTERPCASEMOD;
cea2e8a9 1104 return yylex();
79072805
LW
1105 }
1106
ffb4593c 1107 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
3280af22
NIS
1108 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1109 PL_linestr = PL_lex_repl;
1110 PL_lex_inpat = 0;
1111 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1112 PL_bufend += SvCUR(PL_linestr);
207e3d1a 1113 PL_last_lop = PL_last_uni = Nullch;
3280af22
NIS
1114 SAVEFREESV(PL_linestr);
1115 PL_lex_dojoin = FALSE;
1116 PL_lex_brackets = 0;
3280af22
NIS
1117 PL_lex_casemods = 0;
1118 *PL_lex_casestack = '\0';
1119 PL_lex_starts = 0;
25da4f38 1120 if (SvEVALED(PL_lex_repl)) {
3280af22
NIS
1121 PL_lex_state = LEX_INTERPNORMAL;
1122 PL_lex_starts++;
e9fa98b2
HS
1123 /* we don't clear PL_lex_repl here, so that we can check later
1124 whether this is an evalled subst; that means we rely on the
1125 logic to ensure sublex_done() is called again only via the
1126 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
79072805 1127 }
e9fa98b2 1128 else {
3280af22 1129 PL_lex_state = LEX_INTERPCONCAT;
e9fa98b2
HS
1130 PL_lex_repl = Nullsv;
1131 }
79072805 1132 return ',';
ffed7fef
LW
1133 }
1134 else {
f46d017c 1135 LEAVE;
3280af22
NIS
1136 PL_bufend = SvPVX(PL_linestr);
1137 PL_bufend += SvCUR(PL_linestr);
1138 PL_expect = XOPERATOR;
09bef843 1139 PL_sublex_info.sub_inwhat = 0;
79072805 1140 return ')';
ffed7fef
LW
1141 }
1142}
1143
02aa26ce
NT
1144/*
1145 scan_const
1146
1147 Extracts a pattern, double-quoted string, or transliteration. This
1148 is terrifying code.
1149
3280af22
NIS
1150 It looks at lex_inwhat and PL_lex_inpat to find out whether it's
1151 processing a pattern (PL_lex_inpat is true), a transliteration
02aa26ce
NT
1152 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
1153
9b599b2a
GS
1154 Returns a pointer to the character scanned up to. Iff this is
1155 advanced from the start pointer supplied (ie if anything was
1156 successfully parsed), will leave an OP for the substring scanned
1157 in yylval. Caller must intuit reason for not parsing further
1158 by looking at the next characters herself.
1159
02aa26ce
NT
1160 In patterns:
1161 backslashes:
1162 double-quoted style: \r and \n
1163 regexp special ones: \D \s
1164 constants: \x3
1165 backrefs: \1 (deprecated in substitution replacements)
1166 case and quoting: \U \Q \E
1167 stops on @ and $, but not for $ as tail anchor
1168
1169 In transliterations:
1170 characters are VERY literal, except for - not at the start or end
1171 of the string, which indicates a range. scan_const expands the
1172 range to the full set of intermediate characters.
1173
1174 In double-quoted strings:
1175 backslashes:
1176 double-quoted style: \r and \n
1177 constants: \x3
1178 backrefs: \1 (deprecated)
1179 case and quoting: \U \Q \E
1180 stops on @ and $
1181
1182 scan_const does *not* construct ops to handle interpolated strings.
1183 It stops processing as soon as it finds an embedded $ or @ variable
1184 and leaves it to the caller to work out what's going on.
1185
da6eedaa 1186 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @::foo.
02aa26ce
NT
1187
1188 $ in pattern could be $foo or could be tail anchor. Assumption:
1189 it's a tail anchor if $ is the last thing in the string, or if it's
1190 followed by one of ")| \n\t"
1191
1192 \1 (backreferences) are turned into $1
1193
1194 The structure of the code is
1195 while (there's a character to process) {
1196 handle transliteration ranges
1197 skip regexp comments
1198 skip # initiated comments in //x patterns
1199 check for embedded @foo
1200 check for embedded scalars
1201 if (backslash) {
1202 leave intact backslashes from leave (below)
1203 deprecate \1 in strings and sub replacements
1204 handle string-changing backslashes \l \U \Q \E, etc.
1205 switch (what was escaped) {
1206 handle - in a transliteration (becomes a literal -)
1207 handle \132 octal characters
1208 handle 0x15 hex characters
1209 handle \cV (control V)
1210 handle printf backslashes (\f, \r, \n, etc)
1211 } (end switch)
1212 } (end if backslash)
1213 } (end while character to read)
4e553d73 1214
02aa26ce
NT
1215*/
1216
76e3520e 1217STATIC char *
cea2e8a9 1218S_scan_const(pTHX_ char *start)
79072805 1219{
3280af22 1220 register char *send = PL_bufend; /* end of the constant */
02aa26ce
NT
1221 SV *sv = NEWSV(93, send - start); /* sv for the constant */
1222 register char *s = start; /* start of the constant */
1223 register char *d = SvPVX(sv); /* destination for copies */
1224 bool dorange = FALSE; /* are we in a translit range? */
c2e66d9e 1225 bool didrange = FALSE; /* did we just finish a range? */
2b9d42f0
NIS
1226 I32 has_utf8 = FALSE; /* Output constant is UTF8 */
1227 I32 this_utf8 = UTF; /* The source string is assumed to be UTF8 */
012bcf8d
GS
1228 UV uv;
1229
dff6d3cd 1230 const char *leaveit = /* set of acceptably-backslashed characters */
3280af22 1231 PL_lex_inpat
4a2d328f 1232 ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
9b599b2a 1233 : "";
79072805 1234
2b9d42f0
NIS
1235 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1236 /* If we are doing a trans and we know we want UTF8 set expectation */
1237 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
1238 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1239 }
1240
1241
79072805 1242 while (s < send || dorange) {
02aa26ce 1243 /* get transliterations out of the way (they're most literal) */
3280af22 1244 if (PL_lex_inwhat == OP_TRANS) {
02aa26ce 1245 /* expand a range A-Z to the full set of characters. AIE! */
79072805 1246 if (dorange) {
1ba5c669
JH
1247 I32 i; /* current expanded character */
1248 I32 min; /* first character in range */
1249 I32 max; /* last character in range */
02aa26ce 1250
2b9d42f0 1251 if (has_utf8) {
8973db79
JH
1252 char *c = (char*)utf8_hop((U8*)d, -1);
1253 char *e = d++;
1254 while (e-- > c)
1255 *(e + 1) = *e;
25716404 1256 *c = (char)UTF_TO_NATIVE(0xff);
8973db79
JH
1257 /* mark the range as done, and continue */
1258 dorange = FALSE;
1259 didrange = TRUE;
1260 continue;
1261 }
2b9d42f0 1262
02aa26ce 1263 i = d - SvPVX(sv); /* remember current offset */
9cbb5ea2
GS
1264 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
1265 d = SvPVX(sv) + i; /* refresh d after realloc */
02aa26ce
NT
1266 d -= 2; /* eat the first char and the - */
1267
8ada0baa
JH
1268 min = (U8)*d; /* first char in range */
1269 max = (U8)d[1]; /* last char in range */
1270
c2e66d9e 1271 if (min > max) {
01ec43d0 1272 Perl_croak(aTHX_
d1573ac7 1273 "Invalid range \"%c-%c\" in transliteration operator",
1ba5c669 1274 (char)min, (char)max);
c2e66d9e
GS
1275 }
1276
c7f1f016 1277#ifdef EBCDIC
8ada0baa
JH
1278 if ((isLOWER(min) && isLOWER(max)) ||
1279 (isUPPER(min) && isUPPER(max))) {
1280 if (isLOWER(min)) {
1281 for (i = min; i <= max; i++)
1282 if (isLOWER(i))
db42d148 1283 *d++ = NATIVE_TO_NEED(has_utf8,i);
8ada0baa
JH
1284 } else {
1285 for (i = min; i <= max; i++)
1286 if (isUPPER(i))
db42d148 1287 *d++ = NATIVE_TO_NEED(has_utf8,i);
8ada0baa
JH
1288 }
1289 }
1290 else
1291#endif
1292 for (i = min; i <= max; i++)
eb160463 1293 *d++ = (char)i;
02aa26ce
NT
1294
1295 /* mark the range as done, and continue */
79072805 1296 dorange = FALSE;
01ec43d0 1297 didrange = TRUE;
79072805 1298 continue;
4e553d73 1299 }
02aa26ce
NT
1300
1301 /* range begins (ignore - as first or last char) */
79072805 1302 else if (*s == '-' && s+1 < send && s != start) {
4e553d73 1303 if (didrange) {
1fafa243 1304 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
01ec43d0 1305 }
2b9d42f0 1306 if (has_utf8) {
25716404 1307 *d++ = (char)UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */
a0ed51b3
LW
1308 s++;
1309 continue;
1310 }
79072805
LW
1311 dorange = TRUE;
1312 s++;
01ec43d0
GS
1313 }
1314 else {
1315 didrange = FALSE;
1316 }
79072805 1317 }
02aa26ce
NT
1318
1319 /* if we get here, we're not doing a transliteration */
1320
0f5d15d6
IZ
1321 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
1322 except for the last char, which will be done separately. */
3280af22 1323 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
cc6b7395
IZ
1324 if (s[2] == '#') {
1325 while (s < send && *s != ')')
db42d148 1326 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
155aba94
GS
1327 }
1328 else if (s[2] == '{' /* This should match regcomp.c */
1329 || ((s[2] == 'p' || s[2] == '?') && s[3] == '{'))
1330 {
cc6b7395 1331 I32 count = 1;
0f5d15d6 1332 char *regparse = s + (s[2] == '{' ? 3 : 4);
cc6b7395
IZ
1333 char c;
1334
d9f97599
GS
1335 while (count && (c = *regparse)) {
1336 if (c == '\\' && regparse[1])
1337 regparse++;
4e553d73 1338 else if (c == '{')
cc6b7395 1339 count++;
4e553d73 1340 else if (c == '}')
cc6b7395 1341 count--;
d9f97599 1342 regparse++;
cc6b7395 1343 }
5bdf89e7
IZ
1344 if (*regparse != ')') {
1345 regparse--; /* Leave one char for continuation. */
cc6b7395 1346 yyerror("Sequence (?{...}) not terminated or not {}-balanced");
5bdf89e7 1347 }
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;
b4748376 2707 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
cea2e8a9 2708 Perl_croak(aTHX_ "Can't exec %s", ipath);
9f68db38 2709 }
bf4acbe4 2710#endif
748a9306 2711 if (d) {
3280af22
NIS
2712 U32 oldpdb = PL_perldb;
2713 bool oldn = PL_minus_n;
2714 bool oldp = PL_minus_p;
748a9306
LW
2715
2716 while (*d && !isSPACE(*d)) d++;
bf4acbe4 2717 while (SPACE_OR_TAB(*d)) d++;
748a9306
LW
2718
2719 if (*d++ == '-') {
a11ec5a9 2720 bool switches_done = PL_doswitches;
8cc95fdb
PP
2721 do {
2722 if (*d == 'M' || *d == 'm') {
2723 char *m = d;
2724 while (*d && !isSPACE(*d)) d++;
cea2e8a9 2725 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
8cc95fdb
PP
2726 (int)(d - m), m);
2727 }
2728 d = moreswitches(d);
2729 } while (d);
155aba94
GS
2730 if ((PERLDB_LINE && !oldpdb) ||
2731 ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
b084f20b
PP
2732 /* if we have already added "LINE: while (<>) {",
2733 we must not do it again */
748a9306 2734 {
3280af22
NIS
2735 sv_setpv(PL_linestr, "");
2736 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2737 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
207e3d1a 2738 PL_last_lop = PL_last_uni = Nullch;
3280af22 2739 PL_preambled = FALSE;
84902520 2740 if (PERLDB_LINE)
3280af22 2741 (void)gv_fetchfile(PL_origfilename);
748a9306
LW
2742 goto retry;
2743 }
a11ec5a9
RGS
2744 if (PL_doswitches && !switches_done) {
2745 int argc = PL_origargc;
2746 char **argv = PL_origargv;
2747 do {
2748 argc--,argv++;
2749 } while (argc && argv[0][0] == '-' && argv[0][1]);
2750 init_argv_symbols(argc,argv);
2751 }
a0d0e21e 2752 }
79072805 2753 }
9f68db38 2754 }
79072805 2755 }
3280af22
NIS
2756 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2757 PL_bufptr = s;
2758 PL_lex_state = LEX_FORMLINE;
cea2e8a9 2759 return yylex();
ae986130 2760 }
378cc40b 2761 goto retry;
4fdae800 2762 case '\r':
6a27c188 2763#ifdef PERL_STRICT_CR
cea2e8a9 2764 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
4e553d73 2765 Perl_croak(aTHX_
cc507455 2766 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
a868473f 2767#endif
4fdae800 2768 case ' ': case '\t': case '\f': case 013:
bf4acbe4
GS
2769#ifdef MACOS_TRADITIONAL
2770 case '\312':
2771#endif
378cc40b
LW
2772 s++;
2773 goto retry;
378cc40b 2774 case '#':
e929a76b 2775 case '\n':
3280af22 2776 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
df0deb90
GS
2777 if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
2778 /* handle eval qq[#line 1 "foo"\n ...] */
2779 CopLINE_dec(PL_curcop);
2780 incline(s);
2781 }
3280af22 2782 d = PL_bufend;
a687059c 2783 while (s < d && *s != '\n')
378cc40b 2784 s++;
0f85fab0 2785 if (s < d)
378cc40b 2786 s++;
78c267c1 2787 else if (s > d) /* Found by Ilya: feed random input to Perl. */
a8406387 2788 Perl_croak(aTHX_ "panic: input overflow");
463ee0b2 2789 incline(s);
3280af22
NIS
2790 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2791 PL_bufptr = s;
2792 PL_lex_state = LEX_FORMLINE;
cea2e8a9 2793 return yylex();
a687059c 2794 }
378cc40b 2795 }
a687059c 2796 else {
378cc40b 2797 *s = '\0';
3280af22 2798 PL_bufend = s;
a687059c 2799 }
378cc40b
LW
2800 goto retry;
2801 case '-':
79072805 2802 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
e5edeb50
JH
2803 I32 ftst = 0;
2804
378cc40b 2805 s++;
3280af22 2806 PL_bufptr = s;
748a9306
LW
2807 tmp = *s++;
2808
bf4acbe4 2809 while (s < PL_bufend && SPACE_OR_TAB(*s))
748a9306
LW
2810 s++;
2811
2812 if (strnEQ(s,"=>",2)) {
3280af22 2813 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
4e553d73 2814 DEBUG_T( { PerlIO_printf(Perl_debug_log,
607df283 2815 "### Saw unary minus before =>, forcing word '%s'\n", s);
5f80b19c 2816 } );
748a9306
LW
2817 OPERATOR('-'); /* unary minus */
2818 }
3280af22 2819 PL_last_uni = PL_oldbufptr;
748a9306 2820 switch (tmp) {
e5edeb50
JH
2821 case 'r': ftst = OP_FTEREAD; break;
2822 case 'w': ftst = OP_FTEWRITE; break;
2823 case 'x': ftst = OP_FTEEXEC; break;
2824 case 'o': ftst = OP_FTEOWNED; break;
2825 case 'R': ftst = OP_FTRREAD; break;
2826 case 'W': ftst = OP_FTRWRITE; break;
2827 case 'X': ftst = OP_FTREXEC; break;
2828 case 'O': ftst = OP_FTROWNED; break;
2829 case 'e': ftst = OP_FTIS; break;
2830 case 'z': ftst = OP_FTZERO; break;
2831 case 's': ftst = OP_FTSIZE; break;
2832 case 'f': ftst = OP_FTFILE; break;
2833 case 'd': ftst = OP_FTDIR; break;
2834 case 'l': ftst = OP_FTLINK; break;
2835 case 'p': ftst = OP_FTPIPE; break;
2836 case 'S': ftst = OP_FTSOCK; break;
2837 case 'u': ftst = OP_FTSUID; break;
2838 case 'g': ftst = OP_FTSGID; break;
2839 case 'k': ftst = OP_FTSVTX; break;
2840 case 'b': ftst = OP_FTBLK; break;
2841 case 'c': ftst = OP_FTCHR; break;
2842 case 't': ftst = OP_FTTTY; break;
2843 case 'T': ftst = OP_FTTEXT; break;
2844 case 'B': ftst = OP_FTBINARY; break;
2845 case 'M': case 'A': case 'C':
2846 gv_fetchpv("\024",TRUE, SVt_PV);
2847 switch (tmp) {
2848 case 'M': ftst = OP_FTMTIME; break;
2849 case 'A': ftst = OP_FTATIME; break;
2850 case 'C': ftst = OP_FTCTIME; break;
2851 default: break;
2852 }
2853 break;
378cc40b 2854 default:
378cc40b
LW
2855 break;
2856 }
e5edeb50 2857 if (ftst) {
eb160463 2858 PL_last_lop_op = (OPCODE)ftst;
4e553d73 2859 DEBUG_T( { PerlIO_printf(Perl_debug_log,
0844c848 2860 "### Saw file test %c\n", (int)ftst);
5f80b19c 2861 } );
e5edeb50
JH
2862 FTST(ftst);
2863 }
2864 else {
2865 /* Assume it was a minus followed by a one-letter named
2866 * subroutine call (or a -bareword), then. */
95c31fe3 2867 DEBUG_T( { PerlIO_printf(Perl_debug_log,
0844c848
RB
2868 "### %c looked like a file test but was not\n",
2869 (int)ftst);
5f80b19c 2870 } );
e5edeb50
JH
2871 s -= 2;
2872 }
378cc40b 2873 }
a687059c
LW
2874 tmp = *s++;
2875 if (*s == tmp) {
2876 s++;
3280af22 2877 if (PL_expect == XOPERATOR)
79072805
LW
2878 TERM(POSTDEC);
2879 else
2880 OPERATOR(PREDEC);
2881 }
2882 else if (*s == '>') {
2883 s++;
2884 s = skipspace(s);
7e2040f0 2885 if (isIDFIRST_lazy_if(s,UTF)) {
a0d0e21e 2886 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
463ee0b2 2887 TOKEN(ARROW);
79072805 2888 }
748a9306
LW
2889 else if (*s == '$')
2890 OPERATOR(ARROW);
463ee0b2 2891 else
748a9306 2892 TERM(ARROW);
a687059c 2893 }
3280af22 2894 if (PL_expect == XOPERATOR)
79072805
LW
2895 Aop(OP_SUBTRACT);
2896 else {
3280af22 2897 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2f3197b3 2898 check_uni();
79072805 2899 OPERATOR('-'); /* unary minus */
2f3197b3 2900 }
79072805 2901
378cc40b 2902 case '+':
a687059c
LW
2903 tmp = *s++;
2904 if (*s == tmp) {
378cc40b 2905 s++;
3280af22 2906 if (PL_expect == XOPERATOR)
79072805
LW
2907 TERM(POSTINC);
2908 else
2909 OPERATOR(PREINC);
378cc40b 2910 }
3280af22 2911 if (PL_expect == XOPERATOR)
79072805
LW
2912 Aop(OP_ADD);
2913 else {
3280af22 2914 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2f3197b3 2915 check_uni();
a687059c 2916 OPERATOR('+');
2f3197b3 2917 }
a687059c 2918
378cc40b 2919 case '*':
3280af22
NIS
2920 if (PL_expect != XOPERATOR) {
2921 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2922 PL_expect = XOPERATOR;
2923 force_ident(PL_tokenbuf, '*');
2924 if (!*PL_tokenbuf)
a0d0e21e 2925 PREREF('*');
79072805 2926 TERM('*');
a687059c 2927 }
79072805
LW
2928 s++;
2929 if (*s == '*') {
a687059c 2930 s++;
79072805 2931 PWop(OP_POW);
a687059c 2932 }
79072805
LW
2933 Mop(OP_MULTIPLY);
2934
378cc40b 2935 case '%':
3280af22 2936 if (PL_expect == XOPERATOR) {
bbce6d69
PP
2937 ++s;
2938 Mop(OP_MODULO);
a687059c 2939 }
3280af22
NIS
2940 PL_tokenbuf[0] = '%';
2941 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2942 if (!PL_tokenbuf[1]) {
bbce6d69 2943 PREREF('%');
a687059c 2944 }
3280af22 2945 PL_pending_ident = '%';
bbce6d69 2946 TERM('%');
a687059c 2947
378cc40b 2948 case '^':
79072805 2949 s++;
a0d0e21e 2950 BOop(OP_BIT_XOR);
79072805 2951 case '[':
3280af22 2952 PL_lex_brackets++;
79072805 2953 /* FALL THROUGH */
378cc40b 2954 case '~':
378cc40b 2955 case ',':
378cc40b
LW
2956 tmp = *s++;
2957 OPERATOR(tmp);
a0d0e21e
LW
2958 case ':':
2959 if (s[1] == ':') {
2960 len = 0;
2961 goto just_a_word;
2962 }
2963 s++;
09bef843
SB
2964 switch (PL_expect) {
2965 OP *attrs;
2966 case XOPERATOR:
2967 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
2968 break;
2969 PL_bufptr = s; /* update in case we back off */
2970 goto grabattrs;
2971 case XATTRBLOCK:
2972 PL_expect = XBLOCK;
2973 goto grabattrs;
2974 case XATTRTERM:
2975 PL_expect = XTERMBLOCK;
2976 grabattrs:
2977 s = skipspace(s);
2978 attrs = Nullop;
7e2040f0 2979 while (isIDFIRST_lazy_if(s,UTF)) {
09bef843 2980 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
f9829d6b
GS
2981 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
2982 if (tmp < 0) tmp = -tmp;
2983 switch (tmp) {
2984 case KEY_or:
2985 case KEY_and:
c963b151 2986 case KEY_err:
f9829d6b
GS
2987 case KEY_for:
2988 case KEY_unless:
2989 case KEY_if:
2990 case KEY_while:
2991 case KEY_until:
2992 goto got_attrs;
2993 default:
2994 break;
2995 }
2996 }
09bef843
SB
2997 if (*d == '(') {
2998 d = scan_str(d,TRUE,TRUE);
2999 if (!d) {
09bef843
SB
3000 /* MUST advance bufptr here to avoid bogus
3001 "at end of line" context messages from yyerror().
3002 */
3003 PL_bufptr = s + len;
3004 yyerror("Unterminated attribute parameter in attribute list");
3005 if (attrs)
3006 op_free(attrs);
3007 return 0; /* EOF indicator */
3008 }
3009 }
3010 if (PL_lex_stuff) {
3011 SV *sv = newSVpvn(s, len);
3012 sv_catsv(sv, PL_lex_stuff);
3013 attrs = append_elem(OP_LIST, attrs,
3014 newSVOP(OP_CONST, 0, sv));
3015 SvREFCNT_dec(PL_lex_stuff);
3016 PL_lex_stuff = Nullsv;
3017 }
3018 else {
d3cea301
SB
3019 /* NOTE: any CV attrs applied here need to be part of
3020 the CVf_BUILTIN_ATTRS define in cv.h! */
78f9721b
SM
3021 if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len))
3022 CvLVALUE_on(PL_compcv);
3023 else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len))
3024 CvLOCKED_on(PL_compcv);
3025 else if (!PL_in_my && len == 6 && strnEQ(s, "method", len))
3026 CvMETHOD_on(PL_compcv);
06492da6
SF
3027 else if (!PL_in_my && len == 9 && strnEQ(s, "assertion", len))
3028 CvASSERTION_on(PL_compcv);
87ecf892 3029#ifdef USE_ITHREADS
d3cea301
SB
3030 else if (PL_in_my == KEY_our && len == 6 &&
3031 strnEQ(s, "unique", len))
7fb37951 3032 GvUNIQUE_on(cGVOPx_gv(yylval.opval));
87ecf892 3033#endif
78f9721b
SM
3034 /* After we've set the flags, it could be argued that
3035 we don't need to do the attributes.pm-based setting
3036 process, and shouldn't bother appending recognized
d3cea301
SB
3037 flags. To experiment with that, uncomment the
3038 following "else". (Note that's already been
3039 uncommented. That keeps the above-applied built-in
3040 attributes from being intercepted (and possibly
3041 rejected) by a package's attribute routines, but is
3042 justified by the performance win for the common case
3043 of applying only built-in attributes.) */
0256094b 3044 else
78f9721b
SM
3045 attrs = append_elem(OP_LIST, attrs,
3046 newSVOP(OP_CONST, 0,
3047 newSVpvn(s, len)));
09bef843
SB
3048 }
3049 s = skipspace(d);
0120eecf 3050 if (*s == ':' && s[1] != ':')
09bef843 3051 s = skipspace(s+1);
0120eecf
GS
3052 else if (s == d)
3053 break; /* require real whitespace or :'s */
09bef843 3054 }
f9829d6b 3055 tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
8e7ae056 3056 if (*s != ';' && *s != '}' && *s != tmp && (tmp != '=' || *s != ')')) {
09bef843
SB
3057 char q = ((*s == '\'') ? '"' : '\'');
3058 /* If here for an expression, and parsed no attrs, back off. */
3059 if (tmp == '=' && !attrs) {
3060 s = PL_bufptr;
3061 break;
3062 }
3063 /* MUST advance bufptr here to avoid bogus "at end of line"
3064 context messages from yyerror().
3065 */
3066 PL_bufptr = s;
3067 if (!*s)
3068 yyerror("Unterminated attribute list");
3069 else
3070 yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list",
3071 q, *s, q));
3072 if (attrs)
3073 op_free(attrs);
3074 OPERATOR(':');
3075 }
f9829d6b 3076 got_attrs:
09bef843
SB
3077 if (attrs) {
3078 PL_nextval[PL_nexttoke].opval = attrs;
3079 force_next(THING);
3080 }
3081 TOKEN(COLONATTR);
3082 }
a0d0e21e 3083 OPERATOR(':');
8990e307
LW
3084 case '(':
3085 s++;
3280af22
NIS
3086 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
3087 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
a0d0e21e 3088 else
3280af22 3089 PL_expect = XTERM;
4a202259 3090 s = skipspace(s);
a0d0e21e 3091 TOKEN('(');
378cc40b 3092 case ';':
f4dd75d9 3093 CLINE;
378cc40b
LW
3094 tmp = *s++;
3095 OPERATOR(tmp);
3096 case ')':
378cc40b 3097 tmp = *s++;
16d20bd9
AD
3098 s = skipspace(s);
3099 if (*s == '{')
3100 PREBLOCK(tmp);
378cc40b 3101 TERM(tmp);
79072805
LW
3102 case ']':
3103 s++;
3280af22 3104 if (PL_lex_brackets <= 0)
d98d5fff 3105 yyerror("Unmatched right square bracket");
463ee0b2 3106 else
3280af22
NIS
3107 --PL_lex_brackets;
3108 if (PL_lex_state == LEX_INTERPNORMAL) {
3109 if (PL_lex_brackets == 0) {
a0d0e21e 3110 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
3280af22 3111 PL_lex_state = LEX_INTERPEND;
79072805
LW
3112 }
3113 }
4633a7c4 3114 TERM(']');
79072805
LW
3115 case '{':
3116 leftbracket:
79072805 3117 s++;
3280af22 3118 if (PL_lex_brackets > 100) {
8edd5f42 3119 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
8990e307 3120 }
3280af22 3121 switch (PL_expect) {
a0d0e21e 3122 case XTERM:
3280af22 3123 if (PL_lex_formbrack) {
a0d0e21e
LW
3124 s--;
3125 PRETERMBLOCK(DO);
3126 }
3280af22
NIS
3127 if (PL_oldoldbufptr == PL_last_lop)
3128 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
a0d0e21e 3129 else
3280af22 3130 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
79072805 3131 OPERATOR(HASHBRACK);
a0d0e21e 3132 case XOPERATOR:
bf4acbe4 3133 while (s < PL_bufend && SPACE_OR_TAB(*s))
748a9306 3134 s++;
44a8e56a 3135 d = s;
3280af22
NIS
3136 PL_tokenbuf[0] = '\0';
3137 if (d < PL_bufend && *d == '-') {
3138 PL_tokenbuf[0] = '-';
44a8e56a 3139 d++;
bf4acbe4 3140 while (d < PL_bufend && SPACE_OR_TAB(*d))
44a8e56a
PP
3141 d++;
3142 }
7e2040f0 3143 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
3280af22 3144 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
8903cb82 3145 FALSE, &len);
bf4acbe4 3146 while (d < PL_bufend && SPACE_OR_TAB(*d))
748a9306
LW
3147 d++;
3148 if (*d == '}') {
3280af22 3149 char minus = (PL_tokenbuf[0] == '-');
44a8e56a
PP
3150 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
3151 if (minus)
3152 force_next('-');
748a9306
LW
3153 }
3154 }
3155 /* FALL THROUGH */
09bef843 3156 case XATTRBLOCK:
748a9306 3157 case XBLOCK:
3280af22
NIS
3158 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
3159 PL_expect = XSTATE;
a0d0e21e 3160 break;
09bef843 3161 case XATTRTERM:
a0d0e21e 3162 case XTERMBLOCK:
3280af22
NIS
3163 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3164 PL_expect = XSTATE;
a0d0e21e
LW
3165 break;
3166 default: {
3167 char *t;
3280af22
NIS
3168 if (PL_oldoldbufptr == PL_last_lop)
3169 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
a0d0e21e 3170 else
3280af22 3171 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
a0d0e21e 3172 s = skipspace(s);
8452ff4b
SB
3173 if (*s == '}') {
3174 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
3175 PL_expect = XTERM;
3176 /* This hack is to get the ${} in the message. */
3177 PL_bufptr = s+1;
3178 yyerror("syntax error");
3179 break;
3180 }
a0d0e21e 3181 OPERATOR(HASHBRACK);
8452ff4b 3182 }
b8a4b1be
GS
3183 /* This hack serves to disambiguate a pair of curlies
3184 * as being a block or an anon hash. Normally, expectation
3185 * determines that, but in cases where we're not in a
3186 * position to expect anything in particular (like inside
3187 * eval"") we have to resolve the ambiguity. This code
3188 * covers the case where the first term in the curlies is a
3189 * quoted string. Most other cases need to be explicitly
3190 * disambiguated by prepending a `+' before the opening
3191 * curly in order to force resolution as an anon hash.
3192 *
3193 * XXX should probably propagate the outer expectation
3194 * into eval"" to rely less on this hack, but that could
3195 * potentially break current behavior of eval"".
3196 * GSAR 97-07-21
3197 */
3198 t = s;
3199 if (*s == '\'' || *s == '"' || *s == '`') {
3200 /* common case: get past first string, handling escapes */
3280af22 3201 for (t++; t < PL_bufend && *t != *s;)
b8a4b1be
GS
3202 if (*t++ == '\\' && (*t == '\\' || *t == *s))
3203 t++;
3204 t++;
a0d0e21e 3205 }
b8a4b1be 3206 else if (*s == 'q') {
3280af22 3207 if (++t < PL_bufend
b8a4b1be 3208 && (!isALNUM(*t)
3280af22 3209 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
0505442f
GS
3210 && !isALNUM(*t))))
3211 {
abc667d1 3212 /* skip q//-like construct */
b8a4b1be
GS
3213 char *tmps;
3214 char open, close, term;
3215 I32 brackets = 1;
3216
3280af22 3217 while (t < PL_bufend && isSPACE(*t))
b8a4b1be 3218 t++;
abc667d1
DM
3219 /* check for q => */
3220 if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
3221 OPERATOR(HASHBRACK);
3222 }
b8a4b1be
GS
3223 term = *t;
3224 open = term;
3225 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
3226 term = tmps[5];
3227 close = term;
3228 if (open == close)
3280af22
NIS
3229 for (t++; t < PL_bufend; t++) {
3230 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
b8a4b1be 3231 t++;
6d07e5e9 3232 else if (*t == open)
b8a4b1be
GS
3233 break;
3234 }
abc667d1 3235 else {
3280af22
NIS
3236 for (t++; t < PL_bufend; t++) {
3237 if (*t == '\\' && t+1 < PL_bufend)
b8a4b1be 3238 t++;
6d07e5e9 3239 else if (*t == close && --brackets <= 0)
b8a4b1be
GS
3240 break;
3241 else if (*t == open)
3242 brackets++;
3243 }
abc667d1
DM
3244 }
3245 t++;
b8a4b1be 3246 }
abc667d1
DM
3247 else
3248 /* skip plain q word */
3249 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3250 t += UTF8SKIP(t);
a0d0e21e 3251 }
7e2040f0 3252 else if (isALNUM_lazy_if(t,UTF)) {
0505442f 3253 t += UTF8SKIP(t);
7e2040f0 3254 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
0505442f 3255 t += UTF8SKIP(t);
a0d0e21e 3256 }
3280af22 3257 while (t < PL_bufend && isSPACE(*t))
a0d0e21e 3258 t++;
b8a4b1be
GS
3259 /* if comma follows first term, call it an anon hash */
3260 /* XXX it could be a comma expression with loop modifiers */
3280af22 3261 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
b8a4b1be 3262 || (*t == '=' && t[1] == '>')))
a0d0e21e 3263 OPERATOR(HASHBRACK);
3280af22 3264 if (PL_expect == XREF)
4e4e412b 3265 PL_expect = XTERM;
a0d0e21e 3266 else {
3280af22
NIS
3267 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
3268 PL_expect = XSTATE;
a0d0e21e 3269 }
8990e307 3270 }
a0d0e21e 3271 break;
463ee0b2 3272 }
57843af0 3273 yylval.ival = CopLINE(PL_curcop);
79072805 3274 if (isSPACE(*s) || *s == '#')
3280af22 3275 PL_copline = NOLINE; /* invalidate current command line number */
79072805 3276 TOKEN('{');
378cc40b 3277 case '}':
79072805
LW
3278 rightbracket:
3279 s++;
3280af22 3280 if (PL_lex_brackets <= 0)
d98d5fff 3281 yyerror("Unmatched right curly bracket");
463ee0b2 3282 else
3280af22 3283 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
c2e66d9e 3284 if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
3280af22
NIS
3285 PL_lex_formbrack = 0;
3286 if (PL_lex_state == LEX_INTERPNORMAL) {
3287 if (PL_lex_brackets == 0) {
9059aa12
LW
3288 if (PL_expect & XFAKEBRACK) {
3289 PL_expect &= XENUMMASK;
3280af22
NIS
3290 PL_lex_state = LEX_INTERPEND;
3291 PL_bufptr = s;
cea2e8a9 3292 return yylex(); /* ignore fake brackets */
79072805 3293 }
fa83b5b6 3294 if (*s == '-' && s[1] == '>')
3280af22 3295 PL_lex_state = LEX_INTERPENDMAYBE;
fa83b5b6 3296 else if (*s != '[' && *s != '{')
3280af22 3297 PL_lex_state = LEX_INTERPEND;
79072805
LW
3298 }
3299 }
9059aa12
LW
3300 if (PL_expect & XFAKEBRACK) {
3301 PL_expect &= XENUMMASK;
3280af22 3302 PL_bufptr = s;
cea2e8a9 3303 return yylex(); /* ignore fake brackets */
748a9306 3304 }
79072805
LW
3305 force_next('}');
3306 TOKEN(';');
378cc40b
LW
3307 case '&':
3308 s++;
3309 tmp = *s++;
3310 if (tmp == '&')
a0d0e21e 3311 AOPERATOR(ANDAND);
378cc40b 3312 s--;
3280af22 3313 if (PL_expect == XOPERATOR) {
7e2040f0
GS
3314 if (ckWARN(WARN_SEMICOLON)
3315 && isIDFIRST_lazy_if(s,UTF) && PL_bufptr == PL_linestart)
3316 {
57843af0 3317 CopLINE_dec(PL_curcop);
9014280d 3318 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
57843af0 3319 CopLINE_inc(PL_curcop);
463ee0b2 3320 }
79072805 3321 BAop(OP_BIT_AND);
463ee0b2 3322 }
79072805 3323
3280af22
NIS
3324 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3325 if (*PL_tokenbuf) {
3326 PL_expect = XOPERATOR;
3327 force_ident(PL_tokenbuf, '&');
463ee0b2 3328 }
79072805
LW
3329 else
3330 PREREF('&');
c07a80fd 3331 yylval.ival = (OPpENTERSUB_AMPER<<8);
79072805
LW
3332 TERM('&');
3333
378cc40b
LW
3334 case '|':
3335 s++;
3336 tmp = *s++;
3337 if (tmp == '|')
a0d0e21e 3338 AOPERATOR(OROR);
378cc40b 3339 s--;
79072805 3340 BOop(OP_BIT_OR);
378cc40b
LW
3341 case '=':
3342 s++;
3343 tmp = *s++;
3344 if (tmp == '=')
79072805
LW
3345 Eop(OP_EQ);
3346 if (tmp == '>')
3347 OPERATOR(',');
378cc40b 3348 if (tmp == '~')
79072805 3349 PMop(OP_MATCH);
599cee73 3350 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
9014280d 3351 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Reversed %c= operator",(int)tmp);
378cc40b 3352 s--;
3280af22
NIS
3353 if (PL_expect == XSTATE && isALPHA(tmp) &&
3354 (s == PL_linestart+1 || s[-2] == '\n') )
748a9306 3355 {
3280af22
NIS
3356 if (PL_in_eval && !PL_rsfp) {
3357 d = PL_bufend;
a5f75d66
AD
3358 while (s < d) {
3359 if (*s++ == '\n') {
3360 incline(s);
3361 if (strnEQ(s,"=cut",4)) {
3362 s = strchr(s,'\n');
3363 if (s)
3364 s++;
3365 else
3366 s = d;
3367 incline(s);
3368 goto retry;
3369 }
3370 }
3371 }
3372 goto retry;
3373 }
3280af22
NIS
3374 s = PL_bufend;
3375 PL_doextract = TRUE;
a0d0e21e
LW
3376 goto retry;
3377 }
3280af22 3378 if (PL_lex_brackets < PL_lex_formbrack) {
a0d0e21e 3379 char *t;
51882d45 3380#ifdef PERL_STRICT_CR
bf4acbe4 3381 for (t = s; SPACE_OR_TAB(*t); t++) ;
51882d45 3382#else
bf4acbe4 3383 for (t = s; SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
51882d45 3384#endif
a0d0e21e
LW
3385 if (*t == '\n' || *t == '#') {
3386 s--;
3280af22 3387 PL_expect = XBLOCK;
a0d0e21e
LW
3388 goto leftbracket;
3389 }
79072805 3390 }
a0d0e21e
LW
3391 yylval.ival = 0;
3392 OPERATOR(ASSIGNOP);
378cc40b
LW
3393 case '!':
3394 s++;
3395 tmp = *s++;
3396 if (tmp == '=')
79072805 3397 Eop(OP_NE);
378cc40b 3398 if (tmp == '~')
79072805 3399 PMop(OP_NOT);
378cc40b
LW
3400 s--;
3401 OPERATOR('!');
3402 case '<':
3280af22 3403 if (PL_expect != XOPERATOR) {
93a17b20 3404 if (s[1] != '<' && !strchr(s,'>'))
2f3197b3 3405 check_uni();
79072805
LW
3406 if (s[1] == '<')
3407 s = scan_heredoc(s);
3408 else
3409 s = scan_inputsymbol(s);
3410 TERM(sublex_start());
378cc40b
LW
3411 }
3412 s++;
3413 tmp = *s++;
3414 if (tmp == '<')
79072805 3415 SHop(OP_LEFT_SHIFT);
395c3793
LW
3416 if (tmp == '=') {
3417 tmp = *s++;
3418 if (tmp == '>')
79072805 3419 Eop(OP_NCMP);
395c3793 3420 s--;
79072805 3421 Rop(OP_LE);
395c3793 3422 }
378cc40b 3423 s--;
79072805 3424 Rop(OP_LT);
378cc40b
LW
3425 case '>':
3426 s++;
3427 tmp = *s++;
3428 if (tmp == '>')
79072805 3429 SHop(OP_RIGHT_SHIFT);
378cc40b 3430 if (tmp == '=')
79072805 3431 Rop(OP_GE);
378cc40b 3432 s--;
79072805 3433 Rop(OP_GT);
378cc40b
LW
3434
3435 case '$':
bbce6d69
PP
3436 CLINE;
3437
3280af22
NIS
3438 if (PL_expect == XOPERATOR) {
3439 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3440 PL_expect = XTERM;
a0d0e21e 3441 depcom();
bbce6d69 3442 return ','; /* grandfather non-comma-format format */
a0d0e21e 3443 }
8990e307 3444 }
a0d0e21e 3445
7e2040f0 3446 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
3280af22 3447 PL_tokenbuf[0] = '@';
376b8730
SM
3448 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3449 sizeof PL_tokenbuf - 1, FALSE);
3450 if (PL_expect == XOPERATOR)
3451 no_op("Array length", s);
3280af22 3452 if (!PL_tokenbuf[1])
a0d0e21e 3453 PREREF(DOLSHARP);
3280af22
NIS
3454 PL_expect = XOPERATOR;
3455 PL_pending_ident = '#';
463ee0b2 3456 TOKEN(DOLSHARP);
79072805 3457 }
bbce6d69 3458
3280af22 3459 PL_tokenbuf[0] = '$';
376b8730
SM
3460 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3461 sizeof PL_tokenbuf - 1, FALSE);
3462 if (PL_expect == XOPERATOR)
3463 no_op("Scalar", s);
3280af22
NIS
3464 if (!PL_tokenbuf[1]) {
3465 if (s == PL_bufend)
bbce6d69
PP
3466 yyerror("Final $ should be \\$ or $name");
3467 PREREF('$');
8990e307 3468 }
a0d0e21e 3469
bbce6d69 3470 /* This kludge not intended to be bulletproof. */
3280af22 3471 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
bbce6d69 3472 yylval.opval = newSVOP(OP_CONST, 0,
b448e4fe 3473 newSViv(PL_compiling.cop_arybase));
bbce6d69
PP
3474 yylval.opval->op_private = OPpCONST_ARYBASE;
3475 TERM(THING);
3476 }
3477
ff68c719 3478 d = s;
69d2bceb 3479 tmp = (I32)*s;
3280af22 3480 if (PL_lex_state == LEX_NORMAL)
ff68c719
PP
3481 s = skipspace(s);
3482
3280af22 3483 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
bbce6d69
PP
3484 char *t;
3485 if (*s == '[') {
3280af22 3486 PL_tokenbuf[0] = '@';
599cee73 3487 if (ckWARN(WARN_SYNTAX)) {
bbce6d69 3488 for(t = s + 1;
7e2040f0 3489 isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$';
bbce6d69 3490 t++) ;
a0d0e21e 3491 if (*t++ == ',') {
3280af22
NIS
3492 PL_bufptr = skipspace(PL_bufptr);
3493 while (t < PL_bufend && *t != ']')
bbce6d69 3494 t++;
9014280d 3495 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
599cee73
PM
3496 "Multidimensional syntax %.*s not supported",
3497 (t - PL_bufptr) + 1, PL_bufptr);
a0d0e21e
LW
3498 }
3499 }
bbce6d69
PP
3500 }
3501 else if (*s == '{') {
3280af22 3502 PL_tokenbuf[0] = '%';
599cee73 3503 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
bbce6d69
PP
3504 (t = strchr(s, '}')) && (t = strchr(t, '=')))
3505 {
3280af22 3506 char tmpbuf[sizeof PL_tokenbuf];
a0d0e21e
LW
3507 STRLEN len;
3508 for (t++; isSPACE(*t); t++) ;
7e2040f0 3509 if (isIDFIRST_lazy_if(t,UTF)) {
8903cb82</