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