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