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