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