Context Navigation

toke.c @ 20075

Visit:

Revision 20075, 201.6 KB checked in by zacheiss, 21 years ago (diff)
This commit was generated by cvs2svn to compensate for changes in r20074, which included commits to RCS files with non-trunk default branches.

Line
1	/* toke.c
2	*
3	* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4	* 2000, 2001, 2002, 2003, by Larry Wall and others
5	*
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.
8	*
9	*/
10
11	/*
12	* "It all comes from here, the stench and the peril." --Frodo
13	*/
14
15	/*
16	* This file is the lexer for Perl. It's closely linked to the
17	* parser, perly.y.
18	*
19	* The main routine is yylex(), which returns the next token.
20	*/
21
22	#include "EXTERN.h"
23	#define PERL_IN_TOKE_C
24	#include "perl.h"
25
26	#define yychar PL_yychar
27	#define yylval PL_yylval
28
29	static char ident_too_long[] = "Identifier too long";
30	static char c_without_g[] = "Use of /c modifier is meaningless without /g";
31	static char c_in_subst[] = "Use of /c modifier is meaningless in s///";
32
33	static void restore_rsfp(pTHX_ void *f);
34	#ifndef PERL_NO_UTF16_FILTER
35	static I32 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen);
36	static I32 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen);
37	#endif
38
39	#define XFAKEBRACK 128
40	#define XENUMMASK 127
41
42	#ifdef USE_UTF8_SCRIPTS
43	# define UTF (!IN_BYTES)
44	#else
45	# define UTF ((PL_linestr && DO_UTF8(PL_linestr)) \|\| (PL_hints & HINT_UTF8))
46	#endif
47
48	/* In variables named $^X, these are the legal values for X.
49	* 1999-02-27 mjd-perl-patch@plover.com */
50	#define isCONTROLVAR(x) (isUPPER(x) \|\| strchr("[\\]^_?", (x)))
51
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
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
61	* can get by with a single comparison (if the compiler is smart enough).
62	*/
63
64	/* #define LEX_NOTPARSING 11 is done in perl.h. */
65
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
77
78	#ifdef ff_next
79	#undef ff_next
80	#endif
81
82	#ifdef USE_PURE_BISON
83	# ifndef YYMAXLEVEL
84	# define YYMAXLEVEL 100
85	# endif
86	YYSTYPE* yylval_pointer[YYMAXLEVEL];
87	int* yychar_pointer[YYMAXLEVEL];
88	int yyactlevel = -1;
89	# undef yylval
90	# undef yychar
91	# define yylval (*yylval_pointer[yyactlevel])
92	# define yychar (*yychar_pointer[yyactlevel])
93	# define PERL_YYLEX_PARAM yylval_pointer[yyactlevel],yychar_pointer[yyactlevel]
94	# undef yylex
95	# define yylex() Perl_yylex_r(aTHX_ yylval_pointer[yyactlevel],yychar_pointer[yyactlevel])
96	#endif
97
98	#include "keywords.h"
99
100	/* CLINE is a macro that ensures PL_copline has a sane value */
101
102	#ifdef CLINE
103	#undef CLINE
104	#endif
105	#define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
106
107	/*
108	* Convenience functions to return different tokens and prime the
109	* lexer for the next token. They all take an argument.
110	*
111	* TOKEN : generic token (used for '(', DOLSHARP, etc)
112	* OPERATOR : generic operator
113	* AOPERATOR : assignment operator
114	* PREBLOCK : beginning the block after an if, while, foreach, ...
115	* PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
116	* PREREF : *EXPR where EXPR is not a simple identifier
117	* TERM : expression term
118	* LOOPX : loop exiting command (goto, last, dump, etc)
119	* FTST : file test operator
120	* FUN0 : zero-argument function
121	* FUN1 : not used, except for not, which isn't a UNIOP
122	* BOop : bitwise or or xor
123	* BAop : bitwise and
124	* SHop : shift operator
125	* PWop : power operator
126	* PMop : pattern-matching operator
127	* Aop : addition-level operator
128	* Mop : multiplication-level operator
129	* Eop : equality-testing operator
130	* Rop : relational operator <= != gt
131	*
132	* Also see LOP and lop() below.
133	*/
134
135	/* Note that REPORT() and REPORT2() will be expressions that supply
136	* their own trailing comma, not suitable for statements as such. */
137	#ifdef DEBUGGING /* Serve -DT. */
138	# define REPORT(x,retval) tokereport(x,s,(int)retval),
139	# define REPORT2(x,retval) tokereport(x,s, yylval.ival),
140	#else
141	# define REPORT(x,retval)
142	# define REPORT2(x,retval)
143	#endif
144
145	#define TOKEN(retval) return (REPORT2("token",retval) PL_bufptr = s,(int)retval)
146	#define OPERATOR(retval) return (REPORT2("operator",retval) PL_expect = XTERM, PL_bufptr = s,(int)retval)
147	#define AOPERATOR(retval) return ao((REPORT2("aop",retval) PL_expect = XTERM, PL_bufptr = s,(int)retval))
148	#define PREBLOCK(retval) return (REPORT2("preblock",retval) PL_expect = XBLOCK,PL_bufptr = s,(int)retval)
149	#define PRETERMBLOCK(retval) return (REPORT2("pretermblock",retval) PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval)
150	#define PREREF(retval) return (REPORT2("preref",retval) PL_expect = XREF,PL_bufptr = s,(int)retval)
151	#define TERM(retval) return (CLINE, REPORT2("term",retval) PL_expect = XOPERATOR, PL_bufptr = s,(int)retval)
152	#define LOOPX(f) return(yylval.ival=f, REPORT("loopx",f) PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX)
153	#define FTST(f) return(yylval.ival=f, REPORT("ftst",f) PL_expect = XTERM,PL_bufptr = s,(int)UNIOP)
154	#define FUN0(f) return(yylval.ival = f, REPORT("fun0",f) PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0)
155	#define FUN1(f) return(yylval.ival = f, REPORT("fun1",f) PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1)
156	#define BOop(f) return ao((yylval.ival=f, REPORT("bitorop",f) PL_expect = XTERM,PL_bufptr = s,(int)BITOROP))
157	#define BAop(f) return ao((yylval.ival=f, REPORT("bitandop",f) PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP))
158	#define SHop(f) return ao((yylval.ival=f, REPORT("shiftop",f) PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP))
159	#define PWop(f) return ao((yylval.ival=f, REPORT("powop",f) PL_expect = XTERM,PL_bufptr = s,(int)POWOP))
160	#define PMop(f) return(yylval.ival=f, REPORT("matchop",f) PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP)
161	#define Aop(f) return ao((yylval.ival=f, REPORT("add",f) PL_expect = XTERM,PL_bufptr = s,(int)ADDOP))
162	#define Mop(f) return ao((yylval.ival=f, REPORT("mul",f) PL_expect = XTERM,PL_bufptr = s,(int)MULOP))
163	#define Eop(f) return(yylval.ival=f, REPORT("eq",f) PL_expect = XTERM,PL_bufptr = s,(int)EQOP)
164	#define Rop(f) return(yylval.ival=f, REPORT("rel",f) PL_expect = XTERM,PL_bufptr = s,(int)RELOP)
165
166	/* This bit of chicanery makes a unary function followed by
167	* a parenthesis into a function with one argument, highest precedence.
168	*/
169	#define UNI(f) return(yylval.ival = f, \
170	REPORT("uni",f) \
171	PL_expect = XTERM, \
172	PL_bufptr = s, \
173	PL_last_uni = PL_oldbufptr, \
174	PL_last_lop_op = f, \
175	(s == '(' \|\| (s = skipspace(s), s == '(') ? (int)FUNC1 : (int)UNIOP) )
176
177	#define UNIBRACK(f) return(yylval.ival = f, \
178	REPORT("uni",f) \
179	PL_bufptr = s, \
180	PL_last_uni = PL_oldbufptr, \
181	(s == '(' \|\| (s = skipspace(s), s == '(') ? (int)FUNC1 : (int)UNIOP) )
182
183	/* grandfather return to old style */
184	#define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
185
186	#ifdef DEBUGGING
187
188	STATIC void
189	S_tokereport(pTHX_ char thing, char s, I32 rv)
190	{
191	DEBUG_T({
192	SV* report = newSVpv(thing, 0);
193	Perl_sv_catpvf(aTHX_ report, ":line %d:%"IVdf":", CopLINE(PL_curcop),
194	(IV)rv);
195
196	if (s - PL_bufptr > 0)
197	sv_catpvn(report, PL_bufptr, s - PL_bufptr);
198	else {
199	if (PL_oldbufptr && *PL_oldbufptr)
200	sv_catpv(report, PL_tokenbuf);
201	}
202	PerlIO_printf(Perl_debug_log, "### %s\n", SvPV_nolen(report));
203	});
204	}
205
206	#endif
207
208	/*
209	* S_ao
210	*
211	* This subroutine detects &&= and \|\|= and turns an ANDAND or OROR
212	* into an OP_ANDASSIGN or OP_ORASSIGN
213	*/
214
215	STATIC int
216	S_ao(pTHX_ int toketype)
217	{
218	if (*PL_bufptr == '=') {
219	PL_bufptr++;
220	if (toketype == ANDAND)
221	yylval.ival = OP_ANDASSIGN;
222	else if (toketype == OROR)
223	yylval.ival = OP_ORASSIGN;
224	toketype = ASSIGNOP;
225	}
226	return toketype;
227	}
228
229	/*
230	* S_no_op
231	* When Perl expects an operator and finds something else, no_op
232	* prints the warning. It always prints "<something> found where
233	* operator expected. It prints "Missing semicolon on previous line?"
234	* if the surprise occurs at the start of the line. "do you need to
235	* predeclare ..." is printed out for code like "sub bar; foo bar $x"
236	* where the compiler doesn't know if foo is a method call or a function.
237	* It prints "Missing operator before end of line" if there's nothing
238	* after the missing operator, or "... before <...>" if there is something
239	* after the missing operator.
240	*/
241
242	STATIC void
243	S_no_op(pTHX_ char what, char s)
244	{
245	char *oldbp = PL_bufptr;
246	bool is_first = (PL_oldbufptr == PL_linestart);
247
248	if (!s)
249	s = oldbp;
250	else
251	PL_bufptr = s;
252	yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
253	if (is_first)
254	Perl_warn(aTHX_ "\t(Missing semicolon on previous line?)\n");
255	else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
256	char *t;
257	for (t = PL_oldoldbufptr; t && (isALNUM_lazy_if(t,UTF) \|\| t == ':'); t++) ;
258	if (t < PL_bufptr && isSPACE(*t))
259	Perl_warn(aTHX_ "\t(Do you need to predeclare %.*s?)\n",
260	t - PL_oldoldbufptr, PL_oldoldbufptr);
261	}
262	else {
263	assert(s >= oldbp);
264	Perl_warn(aTHX_ "\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
265	}
266	PL_bufptr = oldbp;
267	}
268
269	/*
270	* S_missingterm
271	* Complain about missing quote/regexp/heredoc terminator.
272	* If it's called with (char *)NULL then it cauterizes the line buffer.
273	* If we're in a delimited string and the delimiter is a control
274	* character, it's reformatted into a two-char sequence like ^C.
275	* This is fatal.
276	*/
277
278	STATIC void
279	S_missingterm(pTHX_ char *s)
280	{
281	char tmpbuf[3];
282	char q;
283	if (s) {
284	char *nl = strrchr(s,'\n');
285	if (nl)
286	*nl = '\0';
287	}
288	else if (
289	#ifdef EBCDIC
290	iscntrl(PL_multi_close)
291	#else
292	PL_multi_close < 32 \|\| PL_multi_close == 127
293	#endif
294	) {
295	*tmpbuf = '^';
296	tmpbuf[1] = toCTRL(PL_multi_close);
297	s = "\\n";
298	tmpbuf[2] = '\0';
299	s = tmpbuf;
300	}
301	else {
302	*tmpbuf = (char)PL_multi_close;
303	tmpbuf[1] = '\0';
304	s = tmpbuf;
305	}
306	q = strchr(s,'"') ? '\'' : '"';
307	Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
308	}
309
310	/*
311	* Perl_deprecate
312	*/
313
314	void
315	Perl_deprecate(pTHX_ char *s)
316	{
317	if (ckWARN(WARN_DEPRECATED))
318	Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "Use of %s is deprecated", s);
319	}
320
321	void
322	Perl_deprecate_old(pTHX_ char *s)
323	{
324	/* This function should NOT be called for any new deprecated warnings */
325	/* Use Perl_deprecate instead */
326	/* */
327	/* It is here to maintain backward compatibility with the pre-5.8 */
328	/* warnings category hierarchy. The "deprecated" category used to */
329	/* live under the "syntax" category. It is now a top-level category */
330	/* in its own right. */
331
332	if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
333	Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
334	"Use of %s is deprecated", s);
335	}
336
337	/*
338	* depcom
339	* Deprecate a comma-less variable list.
340	*/
341
342	STATIC void
343	S_depcom(pTHX)
344	{
345	deprecate_old("comma-less variable list");
346	}
347
348	/*
349	* experimental text filters for win32 carriage-returns, utf16-to-utf8 and
350	* utf16-to-utf8-reversed.
351	*/
352
353	#ifdef PERL_CR_FILTER
354	static void
355	strip_return(SV *sv)
356	{
357	register char *s = SvPVX(sv);
358	register char *e = s + SvCUR(sv);
359	/* outer loop optimized to do nothing if there are no CR-LFs */
360	while (s < e) {
361	if (s++ == '\r' && s == '\n') {
362	/* hit a CR-LF, need to copy the rest */
363	register char *d = s - 1;
364	d++ = s++;
365	while (s < e) {
366	if (*s == '\r' && s[1] == '\n')
367	s++;
368	d++ = s++;
369	}
370	SvCUR(sv) -= s - d;
371	return;
372	}
373	}
374	}
375
376	STATIC I32
377	S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
378	{
379	I32 count = FILTER_READ(idx+1, sv, maxlen);
380	if (count > 0 && !maxlen)
381	strip_return(sv);
382	return count;
383	}
384	#endif
385
386	/*
387	* Perl_lex_start
388	* Initialize variables. Uses the Perl save_stack to save its state (for
389	* recursive calls to the parser).
390	*/
391
392	void
393	Perl_lex_start(pTHX_ SV *line)
394	{
395	char *s;
396	STRLEN len;
397
398	SAVEI32(PL_lex_dojoin);
399	SAVEI32(PL_lex_brackets);
400	SAVEI32(PL_lex_casemods);
401	SAVEI32(PL_lex_starts);
402	SAVEI32(PL_lex_state);
403	SAVEVPTR(PL_lex_inpat);
404	SAVEI32(PL_lex_inwhat);
405	if (PL_lex_state == LEX_KNOWNEXT) {
406	I32 toke = PL_nexttoke;
407	while (--toke >= 0) {
408	SAVEI32(PL_nexttype[toke]);
409	SAVEVPTR(PL_nextval[toke]);
410	}
411	SAVEI32(PL_nexttoke);
412	}
413	SAVECOPLINE(PL_curcop);
414	SAVEPPTR(PL_bufptr);
415	SAVEPPTR(PL_bufend);
416	SAVEPPTR(PL_oldbufptr);
417	SAVEPPTR(PL_oldoldbufptr);
418	SAVEPPTR(PL_last_lop);
419	SAVEPPTR(PL_last_uni);
420	SAVEPPTR(PL_linestart);
421	SAVESPTR(PL_linestr);
422	SAVEGENERICPV(PL_lex_brackstack);
423	SAVEGENERICPV(PL_lex_casestack);
424	SAVEDESTRUCTOR_X(restore_rsfp, PL_rsfp);
425	SAVESPTR(PL_lex_stuff);
426	SAVEI32(PL_lex_defer);
427	SAVEI32(PL_sublex_info.sub_inwhat);
428	SAVESPTR(PL_lex_repl);
429	SAVEINT(PL_expect);
430	SAVEINT(PL_lex_expect);
431
432	PL_lex_state = LEX_NORMAL;
433	PL_lex_defer = 0;
434	PL_expect = XSTATE;
435	PL_lex_brackets = 0;
436	New(899, PL_lex_brackstack, 120, char);
437	New(899, PL_lex_casestack, 12, char);
438	PL_lex_casemods = 0;
439	*PL_lex_casestack = '\0';
440	PL_lex_dojoin = 0;
441	PL_lex_starts = 0;
442	PL_lex_stuff = Nullsv;
443	PL_lex_repl = Nullsv;
444	PL_lex_inpat = 0;
445	PL_nexttoke = 0;
446	PL_lex_inwhat = 0;
447	PL_sublex_info.sub_inwhat = 0;
448	PL_linestr = line;
449	if (SvREADONLY(PL_linestr))
450	PL_linestr = sv_2mortal(newSVsv(PL_linestr));
451	s = SvPV(PL_linestr, len);
452	if (!len \|\| s[len-1] != ';') {
453	if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
454	PL_linestr = sv_2mortal(newSVsv(PL_linestr));
455	sv_catpvn(PL_linestr, "\n;", 2);
456	}
457	SvTEMP_off(PL_linestr);
458	PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
459	PL_bufend = PL_bufptr + SvCUR(PL_linestr);
460	PL_last_lop = PL_last_uni = Nullch;
461	PL_rsfp = 0;
462	}
463
464	/*
465	* Perl_lex_end
466	* Finalizer for lexing operations. Must be called when the parser is
467	* done with the lexer.
468	*/
469
470	void
471	Perl_lex_end(pTHX)
472	{
473	PL_doextract = FALSE;
474	}
475
476	/*
477	* S_incline
478	* This subroutine has nothing to do with tilting, whether at windmills
479	* or pinball tables. Its name is short for "increment line". It
480	* increments the current line number in CopLINE(PL_curcop) and checks
481	* to see whether the line starts with a comment of the form
482	* # line 500 "foo.pm"
483	* If so, it sets the current line number and file to the values in the comment.
484	*/
485
486	STATIC void
487	S_incline(pTHX_ char *s)
488	{
489	char *t;
490	char *n;
491	char *e;
492	char ch;
493
494	CopLINE_inc(PL_curcop);
495	if (*s++ != '#')
496	return;
497	while (SPACE_OR_TAB(*s)) s++;
498	if (strnEQ(s, "line", 4))
499	s += 4;
500	else
501	return;
502	if (SPACE_OR_TAB(*s))
503	s++;
504	else
505	return;
506	while (SPACE_OR_TAB(*s)) s++;
507	if (!isDIGIT(*s))
508	return;
509	n = s;
510	while (isDIGIT(*s))
511	s++;
512	while (SPACE_OR_TAB(*s))
513	s++;
514	if (*s == '"' && (t = strchr(s+1, '"'))) {
515	s++;
516	e = t + 1;
517	}
518	else {
519	for (t = s; !isSPACE(*t); t++) ;
520	e = t;
521	}
522	while (SPACE_OR_TAB(e) \|\| e == '\r' \|\| *e == '\f')
523	e++;
524	if (e != '\n' && e != '\0')
525	return; /* false alarm */
526
527	ch = *t;
528	*t = '\0';
529	if (t - s > 0) {
530	CopFILE_free(PL_curcop);
531	CopFILE_set(PL_curcop, s);
532	}
533	*t = ch;
534	CopLINE_set(PL_curcop, atoi(n)-1);
535	}
536
537	/*
538	* S_skipspace
539	* Called to gobble the appropriate amount and type of whitespace.
540	* Skips comments as well.
541	*/
542
543	STATIC char *
544	S_skipspace(pTHX_ register char *s)
545	{
546	if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
547	while (s < PL_bufend && SPACE_OR_TAB(*s))
548	s++;
549	return s;
550	}
551	for (;;) {
552	STRLEN prevlen;
553	SSize_t oldprevlen, oldoldprevlen;
554	SSize_t oldloplen = 0, oldunilen = 0;
555	while (s < PL_bufend && isSPACE(*s)) {
556	if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
557	incline(s);
558	}
559
560	/* comment */
561	if (s < PL_bufend && *s == '#') {
562	while (s < PL_bufend && *s != '\n')
563	s++;
564	if (s < PL_bufend) {
565	s++;
566	if (PL_in_eval && !PL_rsfp) {
567	incline(s);
568	continue;
569	}
570	}
571	}
572
573	/* only continue to recharge the buffer if we're at the end
574	* of the buffer, we're not reading from a source filter, and
575	* we're in normal lexing mode
576	*/
577	if (s < PL_bufend \|\| !PL_rsfp \|\| PL_sublex_info.sub_inwhat \|\|
578	PL_lex_state == LEX_FORMLINE)
579	return s;
580
581	/* try to recharge the buffer */
582	if ((s = filter_gets(PL_linestr, PL_rsfp,
583	(prevlen = SvCUR(PL_linestr)))) == Nullch)
584	{
585	/* end of file. Add on the -p or -n magic */
586	if (PL_minus_n \|\| PL_minus_p) {
587	sv_setpv(PL_linestr,PL_minus_p ?
588	";}continue{print or die qq(-p destination: $!\\n)" :
589	"");
590	sv_catpv(PL_linestr,";}");
591	PL_minus_n = PL_minus_p = 0;
592	}
593	else
594	sv_setpv(PL_linestr,";");
595
596	/* reset variables for next time we lex */
597	PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
598	= SvPVX(PL_linestr);
599	PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
600	PL_last_lop = PL_last_uni = Nullch;
601
602	/* Close the filehandle. Could be from -P preprocessor,
603	* STDIN, or a regular file. If we were reading code from
604	* STDIN (because the commandline held no -e or filename)
605	* then we don't close it, we reset it so the code can
606	* read from STDIN too.
607	*/
608
609	if (PL_preprocess && !PL_in_eval)
610	(void)PerlProc_pclose(PL_rsfp);
611	else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
612	PerlIO_clearerr(PL_rsfp);
613	else
614	(void)PerlIO_close(PL_rsfp);
615	PL_rsfp = Nullfp;
616	return s;
617	}
618
619	/* not at end of file, so we only read another line */
620	/* make corresponding updates to old pointers, for yyerror() */
621	oldprevlen = PL_oldbufptr - PL_bufend;
622	oldoldprevlen = PL_oldoldbufptr - PL_bufend;
623	if (PL_last_uni)
624	oldunilen = PL_last_uni - PL_bufend;
625	if (PL_last_lop)
626	oldloplen = PL_last_lop - PL_bufend;
627	PL_linestart = PL_bufptr = s + prevlen;
628	PL_bufend = s + SvCUR(PL_linestr);
629	s = PL_bufptr;
630	PL_oldbufptr = s + oldprevlen;
631	PL_oldoldbufptr = s + oldoldprevlen;
632	if (PL_last_uni)
633	PL_last_uni = s + oldunilen;
634	if (PL_last_lop)
635	PL_last_lop = s + oldloplen;
636	incline(s);
637
638	/* debugger active and we're not compiling the debugger code,
639	* so store the line into the debugger's array of lines
640	*/
641	if (PERLDB_LINE && PL_curstash != PL_debstash) {
642	SV *sv = NEWSV(85,0);
643
644	sv_upgrade(sv, SVt_PVMG);
645	sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
646	(void)SvIOK_on(sv);
647	SvIVX(sv) = 0;
648	av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
649	}
650	}
651	}
652
653	/*
654	* S_check_uni
655	* Check the unary operators to ensure there's no ambiguity in how they're
656	* used. An ambiguous piece of code would be:
657	* rand + 5
658	* This doesn't mean rand() + 5. Because rand() is a unary operator,
659	* the +5 is its argument.
660	*/
661
662	STATIC void
663	S_check_uni(pTHX)
664	{
665	char *s;
666	char *t;
667
668	if (PL_oldoldbufptr != PL_last_uni)
669	return;
670	while (isSPACE(*PL_last_uni))
671	PL_last_uni++;
672	for (s = PL_last_uni; isALNUM_lazy_if(s,UTF) \|\| *s == '-'; s++) ;
673	if ((t = strchr(s, '(')) && t < PL_bufptr)
674	return;
675	if (ckWARN_d(WARN_AMBIGUOUS)){
676	char ch = *s;
677	*s = '\0';
678	Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
679	"Warning: Use of \"%s\" without parentheses is ambiguous",
680	PL_last_uni);
681	*s = ch;
682	}
683	}
684
685	/*
686	* LOP : macro to build a list operator. Its behaviour has been replaced
687	* with a subroutine, S_lop() for which LOP is just another name.
688	*/
689
690	#define LOP(f,x) return lop(f,x,s)
691
692	/*
693	* S_lop
694	* Build a list operator (or something that might be one). The rules:
695	* - if we have a next token, then it's a list operator [why?]
696	* - if the next thing is an opening paren, then it's a function
697	* - else it's a list operator
698	*/
699
700	STATIC I32
701	S_lop(pTHX_ I32 f, int x, char *s)
702	{
703	yylval.ival = f;
704	CLINE;
705	REPORT("lop", f)
706	PL_expect = x;
707	PL_bufptr = s;
708	PL_last_lop = PL_oldbufptr;
709	PL_last_lop_op = (OPCODE)f;
710	if (PL_nexttoke)
711	return LSTOP;
712	if (*s == '(')
713	return FUNC;
714	s = skipspace(s);
715	if (*s == '(')
716	return FUNC;
717	else
718	return LSTOP;
719	}
720
721	/*
722	* S_force_next
723	* When the lexer realizes it knows the next token (for instance,
724	* it is reordering tokens for the parser) then it can call S_force_next
725	* to know what token to return the next time the lexer is called. Caller
726	* will need to set PL_nextval[], and possibly PL_expect to ensure the lexer
727	* handles the token correctly.
728	*/
729
730	STATIC void
731	S_force_next(pTHX_ I32 type)
732	{
733	PL_nexttype[PL_nexttoke] = type;
734	PL_nexttoke++;
735	if (PL_lex_state != LEX_KNOWNEXT) {
736	PL_lex_defer = PL_lex_state;
737	PL_lex_expect = PL_expect;
738	PL_lex_state = LEX_KNOWNEXT;
739	}
740	}
741
742	/*
743	* S_force_word
744	* When the lexer knows the next thing is a word (for instance, it has
745	* just seen -> and it knows that the next char is a word char, then
746	* it calls S_force_word to stick the next word into the PL_next lookahead.
747	*
748	* Arguments:
749	* char *start : buffer position (must be within PL_linestr)
750	* int token : PL_next will be this type of bare word (e.g., METHOD,WORD)
751	* int check_keyword : if true, Perl checks to make sure the word isn't
752	* a keyword (do this if the word is a label, e.g. goto FOO)
753	* int allow_pack : if true, : characters will also be allowed (require,
754	* use, etc. do this)
755	* int allow_initial_tick : used by the "sub" lexer only.
756	*/
757
758	STATIC char *
759	S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
760	{
761	register char *s;
762	STRLEN len;
763
764	start = skipspace(start);
765	s = start;
766	if (isIDFIRST_lazy_if(s,UTF) \|\|
767	(allow_pack && *s == ':') \|\|
768	(allow_initial_tick && *s == '\'') )
769	{
770	s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
771	if (check_keyword && keyword(PL_tokenbuf, len))
772	return start;
773	if (token == METHOD) {
774	s = skipspace(s);
775	if (*s == '(')
776	PL_expect = XTERM;
777	else {
778	PL_expect = XOPERATOR;
779	}
780	}
781	PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(PL_tokenbuf,0));
782	PL_nextval[PL_nexttoke].opval->op_private \|= OPpCONST_BARE;
783	if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
784	SvUTF8_on(((SVOP*)PL_nextval[PL_nexttoke].opval)->op_sv);
785	force_next(token);
786	}
787	return s;
788	}
789
790	/*
791	* S_force_ident
792	* Called when the lexer wants $foo *foo &foo etc, but the program
793	* text only contains the "foo" portion. The first argument is a pointer
794	* to the "foo", and the second argument is the type symbol to prefix.
795	* Forces the next token to be a "WORD".
796	* Creates the symbol if it didn't already exist (via gv_fetchpv()).
797	*/
798
799	STATIC void
800	S_force_ident(pTHX_ register char *s, int kind)
801	{
802	if (s && *s) {
803	OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
804	PL_nextval[PL_nexttoke].opval = o;
805	force_next(WORD);
806	if (kind) {
807	o->op_private = OPpCONST_ENTERED;
808	/* XXX see note in pp_entereval() for why we forgo typo
809	warnings if the symbol must be introduced in an eval.
810	GSAR 96-10-12 */
811	gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI \| GV_ADDINEVAL) : TRUE,
812	kind == '$' ? SVt_PV :
813	kind == '@' ? SVt_PVAV :
814	kind == '%' ? SVt_PVHV :
815	SVt_PVGV
816	);
817	}
818	}
819	}
820
821	NV
822	Perl_str_to_version(pTHX_ SV *sv)
823	{
824	NV retval = 0.0;
825	NV nshift = 1.0;
826	STRLEN len;
827	char *start = SvPVx(sv,len);
828	bool utf = SvUTF8(sv) ? TRUE : FALSE;
829	char *end = start + len;
830	while (start < end) {
831	STRLEN skip;
832	UV n;
833	if (utf)
834	n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
835	else {
836	n = (U8)start;
837	skip = 1;
838	}
839	retval += ((NV)n)/nshift;
840	start += skip;
841	nshift *= 1000;
842	}
843	return retval;
844	}
845
846	/*
847	* S_force_version
848	* Forces the next token to be a version number.
849	* If the next token appears to be an invalid version number, (e.g. "v2b"),
850	* and if "guessing" is TRUE, then no new token is created (and the caller
851	* must use an alternative parsing method).
852	*/
853
854	STATIC char *
855	S_force_version(pTHX_ char *s, int guessing)
856	{
857	OP *version = Nullop;
858	char *d;
859
860	s = skipspace(s);
861
862	d = s;
863	if (*d == 'v')
864	d++;
865	if (isDIGIT(*d)) {
866	while (isDIGIT(d) \|\| d == '_' \|\| *d == '.')
867	d++;
868	if (d == ';' \|\| isSPACE(d) \|\| d == '}' \|\| !d) {
869	SV *ver;
870	s = scan_num(s, &yylval);
871	version = yylval.opval;
872	ver = cSVOPx(version)->op_sv;
873	if (SvPOK(ver) && !SvNIOK(ver)) {
874	(void)SvUPGRADE(ver, SVt_PVNV);
875	SvNVX(ver) = str_to_version(ver);
876	SvNOK_on(ver); /* hint that it is a version */
877	}
878	}
879	else if (guessing)
880	return s;
881	}
882
883	/* NOTE: The parser sees the package name and the VERSION swapped */
884	PL_nextval[PL_nexttoke].opval = version;
885	force_next(WORD);
886
887	return s;
888	}
889
890	/*
891	* S_tokeq
892	* Tokenize a quoted string passed in as an SV. It finds the next
893	* chunk, up to end of string or a backslash. It may make a new
894	* SV containing that chunk (if HINT_NEW_STRING is on). It also
895	* turns \\ into \.
896	*/
897
898	STATIC SV *
899	S_tokeq(pTHX_ SV *sv)
900	{
901	register char *s;
902	register char *send;
903	register char *d;
904	STRLEN len = 0;
905	SV *pv = sv;
906
907	if (!SvLEN(sv))
908	goto finish;
909
910	s = SvPV_force(sv, len);
911	if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
912	goto finish;
913	send = s + len;
914	while (s < send && *s != '\\')
915	s++;
916	if (s == send)
917	goto finish;
918	d = s;
919	if ( PL_hints & HINT_NEW_STRING ) {
920	pv = sv_2mortal(newSVpvn(SvPVX(pv), len));
921	if (SvUTF8(sv))
922	SvUTF8_on(pv);
923	}
924	while (s < send) {
925	if (*s == '\\') {
926	if (s + 1 < send && (s[1] == '\\'))
927	s++; /* all that, just for this */
928	}
929	d++ = s++;
930	}
931	*d = '\0';
932	SvCUR_set(sv, d - SvPVX(sv));
933	finish:
934	if ( PL_hints & HINT_NEW_STRING )
935	return new_constant(NULL, 0, "q", sv, pv, "q");
936	return sv;
937	}
938
939	/*
940	* Now come three functions related to double-quote context,
941	* S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
942	* converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
943	* interact with PL_lex_state, and create fake ( ... ) argument lists
944	* to handle functions and concatenation.
945	* They assume that whoever calls them will be setting up a fake
946	* join call, because each subthing puts a ',' after it. This lets
947	* "lower \luPpEr"
948	* become
949	* join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
950	*
951	* (I'm not sure whether the spurious commas at the end of lcfirst's
952	* arguments and join's arguments are created or not).
953	*/
954
955	/*
956	* S_sublex_start
957	* Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST).
958	*
959	* Pattern matching will set PL_lex_op to the pattern-matching op to
960	* make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise).
961	*
962	* OP_CONST and OP_READLINE are easy--just make the new op and return.
963	*
964	* Everything else becomes a FUNC.
965	*
966	* Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
967	* had an OP_CONST or OP_READLINE). This just sets us up for a
968	* call to S_sublex_push().
969	*/
970
971	STATIC I32
972	S_sublex_start(pTHX)
973	{
974	register I32 op_type = yylval.ival;
975
976	if (op_type == OP_NULL) {
977	yylval.opval = PL_lex_op;
978	PL_lex_op = Nullop;
979	return THING;
980	}
981	if (op_type == OP_CONST \|\| op_type == OP_READLINE) {
982	SV *sv = tokeq(PL_lex_stuff);
983
984	if (SvTYPE(sv) == SVt_PVIV) {
985	/* Overloaded constants, nothing fancy: Convert to SVt_PV: */
986	STRLEN len;
987	char *p;
988	SV *nsv;
989
990	p = SvPV(sv, len);
991	nsv = newSVpvn(p, len);
992	if (SvUTF8(sv))
993	SvUTF8_on(nsv);
994	SvREFCNT_dec(sv);
995	sv = nsv;
996	}
997	yylval.opval = (OP*)newSVOP(op_type, 0, sv);
998	PL_lex_stuff = Nullsv;
999	return THING;
1000	}
1001
1002	PL_sublex_info.super_state = PL_lex_state;
1003	PL_sublex_info.sub_inwhat = op_type;
1004	PL_sublex_info.sub_op = PL_lex_op;
1005	PL_lex_state = LEX_INTERPPUSH;
1006
1007	PL_expect = XTERM;
1008	if (PL_lex_op) {
1009	yylval.opval = PL_lex_op;
1010	PL_lex_op = Nullop;
1011	return PMFUNC;
1012	}
1013	else
1014	return FUNC;
1015	}
1016
1017	/*
1018	* S_sublex_push
1019	* Create a new scope to save the lexing state. The scope will be
1020	* ended in S_sublex_done. Returns a '(', starting the function arguments
1021	* to the uc, lc, etc. found before.
1022	* Sets PL_lex_state to LEX_INTERPCONCAT.
1023	*/
1024
1025	STATIC I32
1026	S_sublex_push(pTHX)
1027	{
1028	ENTER;
1029
1030	PL_lex_state = PL_sublex_info.super_state;
1031	SAVEI32(PL_lex_dojoin);
1032	SAVEI32(PL_lex_brackets);
1033	SAVEI32(PL_lex_casemods);
1034	SAVEI32(PL_lex_starts);
1035	SAVEI32(PL_lex_state);
1036	SAVEVPTR(PL_lex_inpat);
1037	SAVEI32(PL_lex_inwhat);
1038	SAVECOPLINE(PL_curcop);
1039	SAVEPPTR(PL_bufptr);
1040	SAVEPPTR(PL_bufend);
1041	SAVEPPTR(PL_oldbufptr);
1042	SAVEPPTR(PL_oldoldbufptr);
1043	SAVEPPTR(PL_last_lop);
1044	SAVEPPTR(PL_last_uni);
1045	SAVEPPTR(PL_linestart);
1046	SAVESPTR(PL_linestr);
1047	SAVEGENERICPV(PL_lex_brackstack);
1048	SAVEGENERICPV(PL_lex_casestack);
1049
1050	PL_linestr = PL_lex_stuff;
1051	PL_lex_stuff = Nullsv;
1052
1053	PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
1054	= SvPVX(PL_linestr);
1055	PL_bufend += SvCUR(PL_linestr);
1056	PL_last_lop = PL_last_uni = Nullch;
1057	SAVEFREESV(PL_linestr);
1058
1059	PL_lex_dojoin = FALSE;
1060	PL_lex_brackets = 0;
1061	New(899, PL_lex_brackstack, 120, char);
1062	New(899, PL_lex_casestack, 12, char);
1063	PL_lex_casemods = 0;
1064	*PL_lex_casestack = '\0';
1065	PL_lex_starts = 0;
1066	PL_lex_state = LEX_INTERPCONCAT;
1067	CopLINE_set(PL_curcop, (line_t)PL_multi_start);
1068
1069	PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1070	if (PL_lex_inwhat == OP_MATCH \|\| PL_lex_inwhat == OP_QR \|\| PL_lex_inwhat == OP_SUBST)
1071	PL_lex_inpat = PL_sublex_info.sub_op;
1072	else
1073	PL_lex_inpat = Nullop;
1074
1075	return '(';
1076	}
1077
1078	/*
1079	* S_sublex_done
1080	* Restores lexer state after a S_sublex_push.
1081	*/
1082
1083	STATIC I32
1084	S_sublex_done(pTHX)
1085	{
1086	if (!PL_lex_starts++) {
1087	SV *sv = newSVpvn("",0);
1088	if (SvUTF8(PL_linestr))
1089	SvUTF8_on(sv);
1090	PL_expect = XOPERATOR;
1091	yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1092	return THING;
1093	}
1094
1095	if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
1096	PL_lex_state = LEX_INTERPCASEMOD;
1097	return yylex();
1098	}
1099
1100	/* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1101	if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST \|\| PL_lex_inwhat == OP_TRANS)) {
1102	PL_linestr = PL_lex_repl;
1103	PL_lex_inpat = 0;
1104	PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1105	PL_bufend += SvCUR(PL_linestr);
1106	PL_last_lop = PL_last_uni = Nullch;
1107	SAVEFREESV(PL_linestr);
1108	PL_lex_dojoin = FALSE;
1109	PL_lex_brackets = 0;
1110	PL_lex_casemods = 0;
1111	*PL_lex_casestack = '\0';
1112	PL_lex_starts = 0;
1113	if (SvEVALED(PL_lex_repl)) {
1114	PL_lex_state = LEX_INTERPNORMAL;
1115	PL_lex_starts++;
1116	/* we don't clear PL_lex_repl here, so that we can check later
1117	whether this is an evalled subst; that means we rely on the
1118	logic to ensure sublex_done() is called again only via the
1119	branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1120	}
1121	else {
1122	PL_lex_state = LEX_INTERPCONCAT;
1123	PL_lex_repl = Nullsv;
1124	}
1125	return ',';
1126	}
1127	else {
1128	LEAVE;
1129	PL_bufend = SvPVX(PL_linestr);
1130	PL_bufend += SvCUR(PL_linestr);
1131	PL_expect = XOPERATOR;
1132	PL_sublex_info.sub_inwhat = 0;
1133	return ')';
1134	}
1135	}
1136
1137	/*
1138	scan_const
1139
1140	Extracts a pattern, double-quoted string, or transliteration. This
1141	is terrifying code.
1142
1143	It looks at lex_inwhat and PL_lex_inpat to find out whether it's
1144	processing a pattern (PL_lex_inpat is true), a transliteration
1145	(lex_inwhat & OP_TRANS is true), or a double-quoted string.
1146
1147	Returns a pointer to the character scanned up to. Iff this is
1148	advanced from the start pointer supplied (ie if anything was
1149	successfully parsed), will leave an OP for the substring scanned
1150	in yylval. Caller must intuit reason for not parsing further
1151	by looking at the next characters herself.
1152
1153	In patterns:
1154	backslashes:
1155	double-quoted style: \r and \n
1156	regexp special ones: \D \s
1157	constants: \x3
1158	backrefs: \1 (deprecated in substitution replacements)
1159	case and quoting: \U \Q \E
1160	stops on @ and $, but not for $ as tail anchor
1161
1162	In transliterations:
1163	characters are VERY literal, except for - not at the start or end
1164	of the string, which indicates a range. scan_const expands the
1165	range to the full set of intermediate characters.
1166
1167	In double-quoted strings:
1168	backslashes:
1169	double-quoted style: \r and \n
1170	constants: \x3
1171	backrefs: \1 (deprecated)
1172	case and quoting: \U \Q \E
1173	stops on @ and $
1174
1175	scan_const does not construct ops to handle interpolated strings.
1176	It stops processing as soon as it finds an embedded $ or @ variable
1177	and leaves it to the caller to work out what's going on.
1178
1179	@ in pattern could be: @foo, @{foo}, @$foo, @'foo, @::foo.
1180
1181	$ in pattern could be $foo or could be tail anchor. Assumption:
1182	it's a tail anchor if $ is the last thing in the string, or if it's
1183	followed by one of ")\| \n\t"
1184
1185	\1 (backreferences) are turned into $1
1186
1187	The structure of the code is
1188	while (there's a character to process) {
1189	handle transliteration ranges
1190	skip regexp comments
1191	skip # initiated comments in //x patterns
1192	check for embedded @foo
1193	check for embedded scalars
1194	if (backslash) {
1195	leave intact backslashes from leave (below)
1196	deprecate \1 in strings and sub replacements
1197	handle string-changing backslashes \l \U \Q \E, etc.
1198	switch (what was escaped) {
1199	handle - in a transliteration (becomes a literal -)
1200	handle \132 octal characters
1201	handle 0x15 hex characters
1202	handle \cV (control V)
1203	handle printf backslashes (\f, \r, \n, etc)
1204	} (end switch)
1205	} (end if backslash)
1206	} (end while character to read)
1207
1208	*/
1209
1210	STATIC char *
1211	S_scan_const(pTHX_ char *start)
1212	{
1213	register char send = PL_bufend; / end of the constant */
1214	SV sv = NEWSV(93, send - start); / sv for the constant */
1215	register char s = start; / start of the constant */
1216	register char d = SvPVX(sv); / destination for copies */
1217	bool dorange = FALSE; /* are we in a translit range? */
1218	bool didrange = FALSE; /* did we just finish a range? */
1219	I32 has_utf8 = FALSE; /* Output constant is UTF8 */
1220	I32 this_utf8 = UTF; /* The source string is assumed to be UTF8 */
1221	UV uv;
1222
1223	const char leaveit = / set of acceptably-backslashed characters */
1224	PL_lex_inpat
1225	? "\\.^$@AGZdDwWsSbBpPXC+*?\|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
1226	: "";
1227
1228	if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1229	/* If we are doing a trans and we know we want UTF8 set expectation */
1230	has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF\|OPpTRANS_TO_UTF);
1231	this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1232	}
1233
1234
1235	while (s < send \|\| dorange) {
1236	/* get transliterations out of the way (they're most literal) */
1237	if (PL_lex_inwhat == OP_TRANS) {
1238	/* expand a range A-Z to the full set of characters. AIE! */
1239	if (dorange) {
1240	I32 i; /* current expanded character */
1241	I32 min; /* first character in range */
1242	I32 max; /* last character in range */
1243
1244	if (has_utf8) {
1245	char c = (char)utf8_hop((U8*)d, -1);
1246	char *e = d++;
1247	while (e-- > c)
1248	(e + 1) = e;
1249	*c = (char)UTF_TO_NATIVE(0xff);
1250	/* mark the range as done, and continue */
1251	dorange = FALSE;
1252	didrange = TRUE;
1253	continue;
1254	}
1255
1256	i = d - SvPVX(sv); /* remember current offset */
1257	SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
1258	d = SvPVX(sv) + i; /* refresh d after realloc */
1259	d -= 2; /* eat the first char and the - */
1260
1261	min = (U8)d; / first char in range */
1262	max = (U8)d[1]; /* last char in range */
1263
1264	if (min > max) {
1265	Perl_croak(aTHX_
1266	"Invalid range \"%c-%c\" in transliteration operator",
1267	(char)min, (char)max);
1268	}
1269
1270	#ifdef EBCDIC
1271	if ((isLOWER(min) && isLOWER(max)) \|\|
1272	(isUPPER(min) && isUPPER(max))) {
1273	if (isLOWER(min)) {
1274	for (i = min; i <= max; i++)
1275	if (isLOWER(i))
1276	*d++ = NATIVE_TO_NEED(has_utf8,i);
1277	} else {
1278	for (i = min; i <= max; i++)
1279	if (isUPPER(i))
1280	*d++ = NATIVE_TO_NEED(has_utf8,i);
1281	}
1282	}
1283	else
1284	#endif
1285	for (i = min; i <= max; i++)
1286	*d++ = (char)i;
1287
1288	/* mark the range as done, and continue */
1289	dorange = FALSE;
1290	didrange = TRUE;
1291	continue;
1292	}
1293
1294	/* range begins (ignore - as first or last char) */
1295	else if (*s == '-' && s+1 < send && s != start) {
1296	if (didrange) {
1297	Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
1298	}
1299	if (has_utf8) {
1300	d++ = (char)UTF_TO_NATIVE(0xff); / use illegal utf8 byte--see pmtrans */
1301	s++;
1302	continue;
1303	}
1304	dorange = TRUE;
1305	s++;
1306	}
1307	else {
1308	didrange = FALSE;
1309	}
1310	}
1311
1312	/* if we get here, we're not doing a transliteration */
1313
1314	/* skip for regexp comments /(?#comment)/ and code /(?{code})/,
1315	except for the last char, which will be done separately. */
1316	else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
1317	if (s[2] == '#') {
1318	while (s+1 < send && *s != ')')
1319	d++ = NATIVE_TO_NEED(has_utf8,s++);
1320	}
1321	else if (s[2] == '{' /* This should match regcomp.c */
1322	\|\| ((s[2] == 'p' \|\| s[2] == '?') && s[3] == '{'))
1323	{
1324	I32 count = 1;
1325	char *regparse = s + (s[2] == '{' ? 3 : 4);
1326	char c;
1327
1328	while (count && (c = *regparse)) {
1329	if (c == '\\' && regparse[1])
1330	regparse++;
1331	else if (c == '{')
1332	count++;
1333	else if (c == '}')
1334	count--;
1335	regparse++;
1336	}
1337	if (*regparse != ')')
1338	regparse--; /* Leave one char for continuation. */
1339	while (s < regparse)
1340	d++ = NATIVE_TO_NEED(has_utf8,s++);
1341	}
1342	}
1343
1344	/* likewise skip #-initiated comments in //x patterns */
1345	else if (*s == '#' && PL_lex_inpat &&
1346	((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
1347	while (s+1 < send && *s != '\n')
1348	d++ = NATIVE_TO_NEED(has_utf8,s++);
1349	}
1350
1351	/* check for embedded arrays
1352	(@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
1353	*/
1354	else if (*s == '@' && s[1]
1355	&& (isALNUM_lazy_if(s+1,UTF) \|\| strchr(":'{$+-", s[1])))
1356	break;
1357
1358	/* check for embedded scalars. only stop if we're sure it's a
1359	variable.
1360	*/
1361	else if (*s == '$') {
1362	if (!PL_lex_inpat) /* not a regexp, so $ must be var */
1363	break;
1364	if (s + 1 < send && !strchr("()\| \r\n\t", s[1]))
1365	break; /* in regexp, $ might be tail anchor */
1366	}
1367
1368	/* End of else if chain - OP_TRANS rejoin rest */
1369
1370	/* backslashes */
1371	if (*s == '\\' && s+1 < send) {
1372	s++;
1373
1374	/* some backslashes we leave behind */
1375	if (leaveit && s && strchr(leaveit, *s)) {
1376	*d++ = NATIVE_TO_NEED(has_utf8,'\\');
1377	d++ = NATIVE_TO_NEED(has_utf8,s++);
1378	continue;
1379	}
1380
1381	/* deprecate \1 in strings and substitution replacements */
1382	if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1383	isDIGIT(s) && s != '0' && !isDIGIT(s[1]))
1384	{
1385	if (ckWARN(WARN_SYNTAX))
1386	Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", s, s);
1387	*--s = '$';
1388	break;
1389	}
1390
1391	/* string-change backslash escapes */
1392	if (PL_lex_inwhat != OP_TRANS && s && strchr("lLuUEQ", s)) {
1393	--s;
1394	break;
1395	}
1396
1397	/* if we get here, it's either a quoted -, or a digit */
1398	switch (*s) {
1399
1400	/* quoted - in transliterations */
1401	case '-':
1402	if (PL_lex_inwhat == OP_TRANS) {
1403	d++ = s++;
1404	continue;
1405	}
1406	/* FALL THROUGH */
1407	default:
1408	{
1409	if (ckWARN(WARN_MISC) &&
1410	isALNUM(*s) &&
1411	*s != '_')
1412	Perl_warner(aTHX_ packWARN(WARN_MISC),
1413	"Unrecognized escape \\%c passed through",
1414	*s);
1415	/* default action is to copy the quoted character */
1416	goto default_action;
1417	}
1418
1419	/* \132 indicates an octal constant */
1420	case '0': case '1': case '2': case '3':
1421	case '4': case '5': case '6': case '7':
1422	{
1423	I32 flags = 0;
1424	STRLEN len = 3;
1425	uv = grok_oct(s, &len, &flags, NULL);
1426	s += len;
1427	}
1428	goto NUM_ESCAPE_INSERT;
1429
1430	/* \x24 indicates a hex constant */
1431	case 'x':
1432	++s;
1433	if (*s == '{') {
1434	char* e = strchr(s, '}');
1435	I32 flags = PERL_SCAN_ALLOW_UNDERSCORES \|
1436	PERL_SCAN_DISALLOW_PREFIX;
1437	STRLEN len;
1438
1439	++s;
1440	if (!e) {
1441	yyerror("Missing right brace on \\x{}");
1442	continue;
1443	}
1444	len = e - s;
1445	uv = grok_hex(s, &len, &flags, NULL);
1446	s = e + 1;
1447	}
1448	else {
1449	{
1450	STRLEN len = 2;
1451	I32 flags = PERL_SCAN_DISALLOW_PREFIX;
1452	uv = grok_hex(s, &len, &flags, NULL);
1453	s += len;
1454	}
1455	}
1456
1457	NUM_ESCAPE_INSERT:
1458	/* Insert oct or hex escaped character.
1459	* There will always enough room in sv since such
1460	* escapes will be longer than any UTF-8 sequence
1461	* they can end up as. */
1462
1463	/* We need to map to chars to ASCII before doing the tests
1464	to cover EBCDIC
1465	*/
1466	if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(uv))) {
1467	if (!has_utf8 && uv > 255) {
1468	/* Might need to recode whatever we have
1469	* accumulated so far if it contains any
1470	* hibit chars.
1471	*
1472	* (Can't we keep track of that and avoid
1473	* this rescan? --jhi)
1474	*/
1475	int hicount = 0;
1476	U8 *c;
1477	for (c = (U8 ) SvPVX(sv); c < (U8 )d; c++) {
1478	if (!NATIVE_IS_INVARIANT(*c)) {
1479	hicount++;
1480	}
1481	}
1482	if (hicount) {
1483	STRLEN offset = d - SvPVX(sv);
1484	U8 src, dst;
1485	d = SvGROW(sv, SvLEN(sv) + hicount + 1) + offset;
1486	src = (U8 *)d - 1;
1487	dst = src+hicount;
1488	d += hicount;
1489	while (src >= (U8 *)SvPVX(sv)) {
1490	if (!NATIVE_IS_INVARIANT(*src)) {
1491	U8 ch = NATIVE_TO_ASCII(*src);
1492	*dst-- = (U8)UTF8_EIGHT_BIT_LO(ch);
1493	*dst-- = (U8)UTF8_EIGHT_BIT_HI(ch);
1494	}
1495	else {
1496	dst-- = src;
1497	}
1498	src--;
1499	}
1500	}
1501	}
1502
1503	if (has_utf8 \|\| uv > 255) {
1504	d = (char)uvchr_to_utf8((U8)d, uv);
1505	has_utf8 = TRUE;
1506	if (PL_lex_inwhat == OP_TRANS &&
1507	PL_sublex_info.sub_op) {
1508	PL_sublex_info.sub_op->op_private \|=
1509	(PL_lex_repl ? OPpTRANS_FROM_UTF
1510	: OPpTRANS_TO_UTF);
1511	}
1512	}
1513	else {
1514	*d++ = (char)uv;
1515	}
1516	}
1517	else {
1518	*d++ = (char) uv;
1519	}
1520	continue;
1521
1522	/* \N{LATIN SMALL LETTER A} is a named character */
1523	case 'N':
1524	++s;
1525	if (*s == '{') {
1526	char* e = strchr(s, '}');
1527	SV *res;
1528	STRLEN len;
1529	char *str;
1530
1531	if (!e) {
1532	yyerror("Missing right brace on \\N{}");
1533	e = s - 1;
1534	goto cont_scan;
1535	}
1536	if (e > s + 2 && s[1] == 'U' && s[2] == '+') {
1537	/* \N{U+...} */
1538	I32 flags = PERL_SCAN_ALLOW_UNDERSCORES \|
1539	PERL_SCAN_DISALLOW_PREFIX;
1540	s += 3;
1541	len = e - s;
1542	uv = grok_hex(s, &len, &flags, NULL);
1543	s = e + 1;
1544	goto NUM_ESCAPE_INSERT;
1545	}
1546	res = newSVpvn(s + 1, e - s - 1);
1547	res = new_constant( Nullch, 0, "charnames",
1548	res, Nullsv, "\\N{...}" );
1549	if (has_utf8)
1550	sv_utf8_upgrade(res);
1551	str = SvPV(res,len);
1552	#ifdef EBCDIC_NEVER_MIND
1553	/* charnames uses pack U and that has been
1554	* recently changed to do the below uni->native
1555	* mapping, so this would be redundant (and wrong,
1556	* the code point would be doubly converted).
1557	* But leave this in just in case the pack U change
1558	* gets revoked, but the semantics is still
1559	* desireable for charnames. --jhi */
1560	{
1561	UV uv = utf8_to_uvchr((U8*)str, 0);
1562
1563	if (uv < 0x100) {
1564	U8 tmpbuf[UTF8_MAXLEN+1], *d;
1565
1566	d = uvchr_to_utf8(tmpbuf, UNI_TO_NATIVE(uv));
1567	sv_setpvn(res, (char *)tmpbuf, d - tmpbuf);
1568	str = SvPV(res, len);
1569	}
1570	}
1571	#endif
1572	if (!has_utf8 && SvUTF8(res)) {
1573	char *ostart = SvPVX(sv);
1574	SvCUR_set(sv, d - ostart);
1575	SvPOK_on(sv);
1576	*d = '\0';
1577	sv_utf8_upgrade(sv);
1578	/* this just broke our allocation above... */
1579	SvGROW(sv, (STRLEN)(send - start));
1580	d = SvPVX(sv) + SvCUR(sv);
1581	has_utf8 = TRUE;
1582	}
1583	if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
1584	char *odest = SvPVX(sv);
1585
1586	SvGROW(sv, (SvLEN(sv) + len - (e - s + 4)));
1587	d = SvPVX(sv) + (d - odest);
1588	}
1589	Copy(str, d, len, char);
1590	d += len;
1591	SvREFCNT_dec(res);
1592	cont_scan:
1593	s = e + 1;
1594	}
1595	else
1596	yyerror("Missing braces on \\N{}");
1597	continue;
1598
1599	/* \c is a control character */
1600	case 'c':
1601	s++;
1602	if (s < send) {
1603	U8 c = *s++;
1604	#ifdef EBCDIC
1605	if (isLOWER(c))
1606	c = toUPPER(c);
1607	#endif
1608	*d++ = NATIVE_TO_NEED(has_utf8,toCTRL(c));
1609	}
1610	else {
1611	yyerror("Missing control char name in \\c");
1612	}
1613	continue;
1614
1615	/* printf-style backslashes, formfeeds, newlines, etc */
1616	case 'b':
1617	*d++ = NATIVE_TO_NEED(has_utf8,'\b');
1618	break;
1619	case 'n':
1620	*d++ = NATIVE_TO_NEED(has_utf8,'\n');
1621	break;
1622	case 'r':
1623	*d++ = NATIVE_TO_NEED(has_utf8,'\r');
1624	break;
1625	case 'f':
1626	*d++ = NATIVE_TO_NEED(has_utf8,'\f');
1627	break;
1628	case 't':
1629	*d++ = NATIVE_TO_NEED(has_utf8,'\t');
1630	break;
1631	case 'e':
1632	*d++ = ASCII_TO_NEED(has_utf8,'\033');
1633	break;
1634	case 'a':
1635	*d++ = ASCII_TO_NEED(has_utf8,'\007');
1636	break;
1637	} /* end switch */
1638
1639	s++;
1640	continue;
1641	} /* end if (backslash) */
1642
1643	default_action:
1644	/* If we started with encoded form, or already know we want it
1645	and then encode the next character */
1646	if ((has_utf8 \|\| this_utf8) && !NATIVE_IS_INVARIANT((U8)(*s))) {
1647	STRLEN len = 1;
1648	UV uv = (this_utf8) ? utf8n_to_uvchr((U8)s, send - s, &len, 0) : (UV) ((U8) s);
1649	STRLEN need = UNISKIP(NATIVE_TO_UNI(uv));
1650	s += len;
1651	if (need > len) {
1652	/* encoded value larger than old, need extra space (NOTE: SvCUR() not set here) */
1653	STRLEN off = d - SvPVX(sv);
1654	d = SvGROW(sv, SvLEN(sv) + (need-len)) + off;
1655	}
1656	d = (char)uvchr_to_utf8((U8)d, uv);
1657	has_utf8 = TRUE;
1658	}
1659	else {
1660	d++ = NATIVE_TO_NEED(has_utf8,s++);
1661	}
1662	} /* while loop to process each character */
1663
1664	/* terminate the string and set up the sv */
1665	*d = '\0';
1666	SvCUR_set(sv, d - SvPVX(sv));
1667	if (SvCUR(sv) >= SvLEN(sv))
1668	Perl_croak(aTHX_ "panic: constant overflowed allocated space");
1669
1670	SvPOK_on(sv);
1671	if (PL_encoding && !has_utf8) {
1672	sv_recode_to_utf8(sv, PL_encoding);
1673	if (SvUTF8(sv))
1674	has_utf8 = TRUE;
1675	}
1676	if (has_utf8) {
1677	SvUTF8_on(sv);
1678	if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1679	PL_sublex_info.sub_op->op_private \|=
1680	(PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1681	}
1682	}
1683
1684	/* shrink the sv if we allocated more than we used */
1685	if (SvCUR(sv) + 5 < SvLEN(sv)) {
1686	SvLEN_set(sv, SvCUR(sv) + 1);
1687	Renew(SvPVX(sv), SvLEN(sv), char);
1688	}
1689
1690	/* return the substring (via yylval) only if we parsed anything */
1691	if (s > PL_bufptr) {
1692	if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1693	sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1694	sv, Nullsv,
1695	( PL_lex_inwhat == OP_TRANS
1696	? "tr"
1697	: ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1698	? "s"
1699	: "qq")));
1700	yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1701	} else
1702	SvREFCNT_dec(sv);
1703	return s;
1704	}
1705
1706	/* S_intuit_more
1707	* Returns TRUE if there's more to the expression (e.g., a subscript),
1708	* FALSE otherwise.
1709	*
1710	* It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
1711	*
1712	* ->[ and ->{ return TRUE
1713	* { and [ outside a pattern are always subscripts, so return TRUE
1714	* if we're outside a pattern and it's not { or [, then return FALSE
1715	* if we're in a pattern and the first char is a {
1716	* {4,5} (any digits around the comma) returns FALSE
1717	* if we're in a pattern and the first char is a [
1718	* [] returns FALSE
1719	* [SOMETHING] has a funky algorithm to decide whether it's a
1720	* character class or not. It has to deal with things like
1721	* /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
1722	* anything else returns TRUE
1723	*/
1724
1725	/* This is the one truly awful dwimmer necessary to conflate C and sed. */
1726
1727	STATIC int
1728	S_intuit_more(pTHX_ register char *s)
1729	{
1730	if (PL_lex_brackets)
1731	return TRUE;
1732	if (*s == '-' && s[1] == '>' && (s[2] == '[' \|\| s[2] == '{'))
1733	return TRUE;
1734	if (s != '{' && s != '[')
1735	return FALSE;
1736	if (!PL_lex_inpat)
1737	return TRUE;
1738
1739	/* In a pattern, so maybe we have {n,m}. */
1740	if (*s == '{') {
1741	s++;
1742	if (!isDIGIT(*s))
1743	return TRUE;
1744	while (isDIGIT(*s))
1745	s++;
1746	if (*s == ',')
1747	s++;
1748	while (isDIGIT(*s))
1749	s++;
1750	if (*s == '}')
1751	return FALSE;
1752	return TRUE;
1753
1754	}
1755
1756	/* On the other hand, maybe we have a character class */
1757
1758	s++;
1759	if (s == ']' \|\| s == '^')
1760	return FALSE;
1761	else {
1762	/* this is terrifying, and it works */
1763	int weight = 2; /* let's weigh the evidence */
1764	char seen[256];
1765	unsigned char un_char = 255, last_un_char;
1766	char *send = strchr(s,']');
1767	char tmpbuf[sizeof PL_tokenbuf * 4];
1768
1769	if (!send) /* has to be an expression */
1770	return TRUE;
1771
1772	Zero(seen,256,char);
1773	if (*s == '$')
1774	weight -= 3;
1775	else if (isDIGIT(*s)) {
1776	if (s[1] != ']') {
1777	if (isDIGIT(s[1]) && s[2] == ']')
1778	weight -= 10;
1779	}
1780	else
1781	weight -= 100;
1782	}
1783	for (; s < send; s++) {
1784	last_un_char = un_char;
1785	un_char = (unsigned char)*s;
1786	switch (*s) {
1787	case '@':
1788	case '&':
1789	case '$':
1790	weight -= seen[un_char] * 10;
1791	if (isALNUM_lazy_if(s+1,UTF)) {
1792	scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1793	if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1794	weight -= 100;
1795	else
1796	weight -= 10;
1797	}
1798	else if (*s == '$' && s[1] &&
1799	strchr("[#!%*<>()-=",s[1])) {
1800	if (/{/ strchr("])} =",s[2]))
1801	weight -= 10;
1802	else
1803	weight -= 1;
1804	}
1805	break;
1806	case '\\':
1807	un_char = 254;
1808	if (s[1]) {
1809	if (strchr("wds]",s[1]))
1810	weight += 100;
1811	else if (seen['\''] \|\| seen['"'])
1812	weight += 1;
1813	else if (strchr("rnftbxcav",s[1]))
1814	weight += 40;
1815	else if (isDIGIT(s[1])) {
1816	weight += 40;
1817	while (s[1] && isDIGIT(s[1]))
1818	s++;
1819	}
1820	}
1821	else
1822	weight += 100;
1823	break;
1824	case '-':
1825	if (s[1] == '\\')
1826	weight += 50;
1827	if (strchr("aA01! ",last_un_char))
1828	weight += 30;
1829	if (strchr("zZ79~",s[1]))
1830	weight += 30;
1831	if (last_un_char == 255 && (isDIGIT(s[1]) \|\| s[1] == '$'))
1832	weight -= 5; /* cope with negative subscript */
1833	break;
1834	default:
1835	if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1836	isALPHA(*s) && s[1] && isALPHA(s[1])) {
1837	char *d = tmpbuf;
1838	while (isALPHA(*s))
1839	d++ = s++;
1840	*d = '\0';
1841	if (keyword(tmpbuf, d - tmpbuf))
1842	weight -= 150;
1843	}
1844	if (un_char == last_un_char + 1)
1845	weight += 5;
1846	weight -= seen[un_char];
1847	break;
1848	}
1849	seen[un_char]++;
1850	}
1851	if (weight >= 0) /* probably a character class */
1852	return FALSE;
1853	}
1854
1855	return TRUE;
1856	}
1857
1858	/*
1859	* S_intuit_method
1860	*
1861	* Does all the checking to disambiguate
1862	* foo bar
1863	* between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
1864	* FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
1865	*
1866	* First argument is the stuff after the first token, e.g. "bar".
1867	*
1868	* Not a method if bar is a filehandle.
1869	* Not a method if foo is a subroutine prototyped to take a filehandle.
1870	* Not a method if it's really "Foo $bar"
1871	* Method if it's "foo $bar"
1872	* Not a method if it's really "print foo $bar"
1873	* Method if it's really "foo package::" (interpreted as package->foo)
1874	* Not a method if bar is known to be a subroutine ("sub bar; foo bar")
1875	* Not a method if bar is a filehandle or package, but is quoted with
1876	* =>
1877	*/
1878
1879	STATIC int
1880	S_intuit_method(pTHX_ char start, GV gv)
1881	{
1882	char s = start + (start == '$');
1883	char tmpbuf[sizeof PL_tokenbuf];
1884	STRLEN len;
1885	GV* indirgv;
1886
1887	if (gv) {
1888	CV *cv;
1889	if (GvIO(gv))
1890	return 0;
1891	if ((cv = GvCVu(gv))) {
1892	char *proto = SvPVX(cv);
1893	if (proto) {
1894	if (*proto == ';')
1895	proto++;
1896	if (proto == '')
1897	return 0;
1898	}
1899	} else
1900	gv = 0;
1901	}
1902	s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1903	/* start is the beginning of the possible filehandle/object,
1904	* and s is the end of it
1905	* tmpbuf is a copy of it
1906	*/
1907
1908	if (*start == '$') {
1909	if (gv \|\| PL_last_lop_op == OP_PRINT \|\| isUPPER(*PL_tokenbuf))
1910	return 0;
1911	s = skipspace(s);
1912	PL_bufptr = start;
1913	PL_expect = XREF;
1914	return *s == '(' ? FUNCMETH : METHOD;
1915	}
1916	if (!keyword(tmpbuf, len)) {
1917	if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1918	len -= 2;
1919	tmpbuf[len] = '\0';
1920	goto bare_package;
1921	}
1922	indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1923	if (indirgv && GvCVu(indirgv))
1924	return 0;
1925	/* filehandle or package name makes it a method */
1926	if (!gv \|\| GvIO(indirgv) \|\| gv_stashpvn(tmpbuf, len, FALSE)) {
1927	s = skipspace(s);
1928	if ((PL_bufend - s) >= 2 && s == '=' && (s+1) == '>')
1929	return 0; /* no assumptions -- "=>" quotes bearword */
1930	bare_package:
1931	PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1932	newSVpvn(tmpbuf,len));
1933	PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1934	PL_expect = XTERM;
1935	force_next(WORD);
1936	PL_bufptr = s;
1937	return *s == '(' ? FUNCMETH : METHOD;
1938	}
1939	}
1940	return 0;
1941	}
1942
1943	/*
1944	* S_incl_perldb
1945	* Return a string of Perl code to load the debugger. If PERL5DB
1946	* is set, it will return the contents of that, otherwise a
1947	* compile-time require of perl5db.pl.
1948	*/
1949
1950	STATIC char*
1951	S_incl_perldb(pTHX)
1952	{
1953	if (PL_perldb) {
1954	char *pdb = PerlEnv_getenv("PERL5DB");
1955
1956	if (pdb)
1957	return pdb;
1958	SETERRNO(0,SS_NORMAL);
1959	return "BEGIN { require 'perl5db.pl' }";
1960	}
1961	return "";
1962	}
1963
1964
1965	/* Encoded script support. filter_add() effectively inserts a
1966	* 'pre-processing' function into the current source input stream.
1967	* Note that the filter function only applies to the current source file
1968	* (e.g., it will not affect files 'require'd or 'use'd by this one).
1969	*
1970	* The datasv parameter (which may be NULL) can be used to pass
1971	* private data to this instance of the filter. The filter function
1972	* can recover the SV using the FILTER_DATA macro and use it to
1973	* store private buffers and state information.
1974	*
1975	* The supplied datasv parameter is upgraded to a PVIO type
1976	* and the IoDIRP/IoANY field is used to store the function pointer,
1977	* and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
1978	* Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1979	* private use must be set using malloc'd pointers.
1980	*/
1981
1982	SV *
1983	Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
1984	{
1985	if (!funcp)
1986	return Nullsv;
1987
1988	if (!PL_rsfp_filters)
1989	PL_rsfp_filters = newAV();
1990	if (!datasv)
1991	datasv = NEWSV(255,0);
1992	if (!SvUPGRADE(datasv, SVt_PVIO))
1993	Perl_die(aTHX_ "Can't upgrade filter_add data to SVt_PVIO");
1994	IoANY(datasv) = (void )funcp; / stash funcp into spare field */
1995	IoFLAGS(datasv) \|= IOf_FAKE_DIRP;
1996	DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
1997	(void*)funcp, SvPV_nolen(datasv)));
1998	av_unshift(PL_rsfp_filters, 1);
1999	av_store(PL_rsfp_filters, 0, datasv) ;
2000	return(datasv);
2001	}
2002
2003
2004	/* Delete most recently added instance of this filter function. */
2005	void
2006	Perl_filter_del(pTHX_ filter_t funcp)
2007	{
2008	SV *datasv;
2009	DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", (void*)funcp));
2010	if (!PL_rsfp_filters \|\| AvFILLp(PL_rsfp_filters)<0)
2011	return;
2012	/* if filter is on top of stack (usual case) just pop it off */
2013	datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
2014	if (IoANY(datasv) == (void *)funcp) {
2015	IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
2016	IoANY(datasv) = (void *)NULL;
2017	sv_free(av_pop(PL_rsfp_filters));
2018
2019	return;
2020	}
2021	/* we need to search for the correct entry and clear it */
2022	Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
2023	}
2024
2025
2026	/* Invoke the n'th filter function for the current rsfp. */
2027	I32
2028	Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
2029
2030
2031	/* 0 = read one text line */
2032	{
2033	filter_t funcp;
2034	SV *datasv = NULL;
2035
2036	if (!PL_rsfp_filters)
2037	return -1;
2038	if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
2039	/* Provide a default input filter to make life easy. */
2040	/* Note that we append to the line. This is handy. */
2041	DEBUG_P(PerlIO_printf(Perl_debug_log,
2042	"filter_read %d: from rsfp\n", idx));
2043	if (maxlen) {
2044	/* Want a block */
2045	int len ;
2046	int old_len = SvCUR(buf_sv) ;
2047
2048	/* ensure buf_sv is large enough */
2049	SvGROW(buf_sv, (STRLEN)(old_len + maxlen)) ;
2050	if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
2051	if (PerlIO_error(PL_rsfp))
2052	return -1; /* error */
2053	else
2054	return 0 ; /* end of file */
2055	}
2056	SvCUR_set(buf_sv, old_len + len) ;
2057	} else {
2058	/* Want a line */
2059	if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
2060	if (PerlIO_error(PL_rsfp))
2061	return -1; /* error */
2062	else
2063	return 0 ; /* end of file */
2064	}
2065	}
2066	return SvCUR(buf_sv);
2067	}
2068	/* Skip this filter slot if filter has been deleted */
2069	if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
2070	DEBUG_P(PerlIO_printf(Perl_debug_log,
2071	"filter_read %d: skipped (filter deleted)\n",
2072	idx));
2073	return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
2074	}
2075	/* Get function pointer hidden within datasv */
2076	funcp = (filter_t)IoANY(datasv);
2077	DEBUG_P(PerlIO_printf(Perl_debug_log,
2078	"filter_read %d: via function %p (%s)\n",
2079	idx, (void*)funcp, SvPV_nolen(datasv)));
2080	/* Call function. The function is expected to */
2081	/* call "FILTER_READ(idx+1, buf_sv)" first. */
2082	/* Return: <0:error, =0:eof, >0:not eof */
2083	return (*funcp)(aTHX_ idx, buf_sv, maxlen);
2084	}
2085
2086	STATIC char *
2087	S_filter_gets(pTHX_ register SV sv, register PerlIO fp, STRLEN append)
2088	{
2089	#ifdef PERL_CR_FILTER
2090	if (!PL_rsfp_filters) {
2091	filter_add(S_cr_textfilter,NULL);
2092	}
2093	#endif
2094	if (PL_rsfp_filters) {
2095
2096	if (!append)
2097	SvCUR_set(sv, 0); /* start with empty line */
2098	if (FILTER_READ(0, sv, 0) > 0)
2099	return ( SvPVX(sv) ) ;
2100	else
2101	return Nullch ;
2102	}
2103	else
2104	return (sv_gets(sv, fp, append));
2105	}
2106
2107	STATIC HV *
2108	S_find_in_my_stash(pTHX_ char *pkgname, I32 len)
2109	{
2110	GV *gv;
2111
2112	if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
2113	return PL_curstash;
2114
2115	if (len > 2 &&
2116	(pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
2117	(gv = gv_fetchpv(pkgname, FALSE, SVt_PVHV)))
2118	{
2119	return GvHV(gv); /* Foo:: */
2120	}
2121
2122	/* use constant CLASS => 'MyClass' */
2123	if ((gv = gv_fetchpv(pkgname, FALSE, SVt_PVCV))) {
2124	SV *sv;
2125	if (GvCV(gv) && (sv = cv_const_sv(GvCV(gv)))) {
2126	pkgname = SvPV_nolen(sv);
2127	}
2128	}
2129
2130	return gv_stashpv(pkgname, FALSE);
2131	}
2132
2133	#ifdef DEBUGGING
2134	static char* exp_name[] =
2135	{ "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
2136	"ATTRTERM", "TERMBLOCK"
2137	};
2138	#endif
2139
2140	/*
2141	yylex
2142
2143	Works out what to call the token just pulled out of the input
2144	stream. The yacc parser takes care of taking the ops we return and
2145	stitching them into a tree.
2146
2147	Returns:
2148	PRIVATEREF
2149
2150	Structure:
2151	if read an identifier
2152	if we're in a my declaration
2153	croak if they tried to say my($foo::bar)
2154	build the ops for a my() declaration
2155	if it's an access to a my() variable
2156	are we in a sort block?
2157	croak if my($a); $a <=> $b
2158	build ops for access to a my() variable
2159	if in a dq string, and they've said @foo and we can't find @foo
2160	croak
2161	build ops for a bareword
2162	if we already built the token before, use it.
2163	*/
2164
2165	#ifdef USE_PURE_BISON
2166	int
2167	Perl_yylex_r(pTHX_ YYSTYPE lvalp, int lcharp)
2168	{
2169	int r;
2170
2171	yyactlevel++;
2172	yylval_pointer[yyactlevel] = lvalp;
2173	yychar_pointer[yyactlevel] = lcharp;
2174	if (yyactlevel >= YYMAXLEVEL)
2175	Perl_croak(aTHX_ "panic: YYMAXLEVEL");
2176
2177	r = Perl_yylex(aTHX);
2178
2179	if (yyactlevel > 0)
2180	yyactlevel--;
2181
2182	return r;
2183	}
2184	#endif
2185
2186	#ifdef __SC__
2187	#pragma segment Perl_yylex
2188	#endif
2189	int
2190	Perl_yylex(pTHX)
2191	{
2192	register char *s;
2193	register char *d;
2194	register I32 tmp;
2195	STRLEN len;
2196	GV *gv = Nullgv;
2197	GV **gvp = 0;
2198	bool bof = FALSE;
2199	I32 orig_keyword = 0;
2200
2201	/* check if there's an identifier for us to look at */
2202	if (PL_pending_ident)
2203	return S_pending_ident(aTHX);
2204
2205	/* no identifier pending identification */
2206
2207	switch (PL_lex_state) {
2208	#ifdef COMMENTARY
2209	case LEX_NORMAL: /* Some compilers will produce faster */
2210	case LEX_INTERPNORMAL: /* code if we comment these out. */
2211	break;
2212	#endif
2213
2214	/* when we've already built the next token, just pull it out of the queue */
2215	case LEX_KNOWNEXT:
2216	PL_nexttoke--;
2217	yylval = PL_nextval[PL_nexttoke];
2218	if (!PL_nexttoke) {
2219	PL_lex_state = PL_lex_defer;
2220	PL_expect = PL_lex_expect;
2221	PL_lex_defer = LEX_NORMAL;
2222	}
2223	DEBUG_T({ PerlIO_printf(Perl_debug_log,
2224	"### Next token after '%s' was known, type %"IVdf"\n", PL_bufptr,
2225	(IV)PL_nexttype[PL_nexttoke]); });
2226
2227	return(PL_nexttype[PL_nexttoke]);
2228
2229	/* interpolated case modifiers like \L \U, including \Q and \E.
2230	when we get here, PL_bufptr is at the \
2231	*/
2232	case LEX_INTERPCASEMOD:
2233	#ifdef DEBUGGING
2234	if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
2235	Perl_croak(aTHX_ "panic: INTERPCASEMOD");
2236	#endif
2237	/* handle \E or end of string */
2238	if (PL_bufptr == PL_bufend \|\| PL_bufptr[1] == 'E') {
2239	char oldmod;
2240
2241	/* if at a \E */
2242	if (PL_lex_casemods) {
2243	oldmod = PL_lex_casestack[--PL_lex_casemods];
2244	PL_lex_casestack[PL_lex_casemods] = '\0';
2245
2246	if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
2247	PL_bufptr += 2;
2248	PL_lex_state = LEX_INTERPCONCAT;
2249	}
2250	return ')';
2251	}
2252	if (PL_bufptr != PL_bufend)
2253	PL_bufptr += 2;
2254	PL_lex_state = LEX_INTERPCONCAT;
2255	return yylex();
2256	}
2257	else {
2258	DEBUG_T({ PerlIO_printf(Perl_debug_log,
2259	"### Saw case modifier at '%s'\n", PL_bufptr); });
2260	s = PL_bufptr + 1;
2261	if (s[1] == '\\' && s[2] == 'E') {
2262	PL_bufptr = s + 3;
2263	PL_lex_state = LEX_INTERPCONCAT;
2264	return yylex();
2265	}
2266	else {
2267	if (strnEQ(s, "L\\u", 3) \|\| strnEQ(s, "U\\l", 3))
2268	tmp = s, s = s[2], s[2] = (char)tmp; /* misordered... */
2269	if (strchr("LU", *s) &&
2270	(strchr(PL_lex_casestack, 'L') \|\| strchr(PL_lex_casestack, 'U'))) {
2271	PL_lex_casestack[--PL_lex_casemods] = '\0';
2272	return ')';
2273	}
2274	if (PL_lex_casemods > 10)
2275	Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
2276	PL_lex_casestack[PL_lex_casemods++] = *s;
2277	PL_lex_casestack[PL_lex_casemods] = '\0';
2278	PL_lex_state = LEX_INTERPCONCAT;
2279	PL_nextval[PL_nexttoke].ival = 0;
2280	force_next('(');
2281	if (*s == 'l')
2282	PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
2283	else if (*s == 'u')
2284	PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
2285	else if (*s == 'L')
2286	PL_nextval[PL_nexttoke].ival = OP_LC;
2287	else if (*s == 'U')
2288	PL_nextval[PL_nexttoke].ival = OP_UC;
2289	else if (*s == 'Q')
2290	PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
2291	else
2292	Perl_croak(aTHX_ "panic: yylex");
2293	PL_bufptr = s + 1;
2294	}
2295	force_next(FUNC);
2296	if (PL_lex_starts) {
2297	s = PL_bufptr;
2298	PL_lex_starts = 0;
2299	Aop(OP_CONCAT);
2300	}
2301	else
2302	return yylex();
2303	}
2304
2305	case LEX_INTERPPUSH:
2306	return sublex_push();
2307
2308	case LEX_INTERPSTART:
2309	if (PL_bufptr == PL_bufend)
2310	return sublex_done();
2311	DEBUG_T({ PerlIO_printf(Perl_debug_log,
2312	"### Interpolated variable at '%s'\n", PL_bufptr); });
2313	PL_expect = XTERM;
2314	PL_lex_dojoin = (*PL_bufptr == '@');
2315	PL_lex_state = LEX_INTERPNORMAL;
2316	if (PL_lex_dojoin) {
2317	PL_nextval[PL_nexttoke].ival = 0;
2318	force_next(',');
2319	#ifdef USE_5005THREADS
2320	PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
2321	PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
2322	force_next(PRIVATEREF);
2323	#else
2324	force_ident("\"", '$');
2325	#endif /* USE_5005THREADS */
2326	PL_nextval[PL_nexttoke].ival = 0;
2327	force_next('$');
2328	PL_nextval[PL_nexttoke].ival = 0;
2329	force_next('(');
2330	PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
2331	force_next(FUNC);
2332	}
2333	if (PL_lex_starts++) {
2334	s = PL_bufptr;
2335	Aop(OP_CONCAT);
2336	}
2337	return yylex();
2338
2339	case LEX_INTERPENDMAYBE:
2340	if (intuit_more(PL_bufptr)) {
2341	PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
2342	break;
2343	}
2344	/* FALL THROUGH */
2345
2346	case LEX_INTERPEND:
2347	if (PL_lex_dojoin) {
2348	PL_lex_dojoin = FALSE;
2349	PL_lex_state = LEX_INTERPCONCAT;
2350	return ')';
2351	}
2352	if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
2353	&& SvEVALED(PL_lex_repl))
2354	{
2355	if (PL_bufptr != PL_bufend)
2356	Perl_croak(aTHX_ "Bad evalled substitution pattern");
2357	PL_lex_repl = Nullsv;
2358	}
2359	/* FALLTHROUGH */
2360	case LEX_INTERPCONCAT:
2361	#ifdef DEBUGGING
2362	if (PL_lex_brackets)
2363	Perl_croak(aTHX_ "panic: INTERPCONCAT");
2364	#endif
2365	if (PL_bufptr == PL_bufend)
2366	return sublex_done();
2367
2368	if (SvIVX(PL_linestr) == '\'') {
2369	SV *sv = newSVsv(PL_linestr);
2370	if (!PL_lex_inpat)
2371	sv = tokeq(sv);
2372	else if ( PL_hints & HINT_NEW_RE )
2373	sv = new_constant(NULL, 0, "qr", sv, sv, "q");
2374	yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2375	s = PL_bufend;
2376	}
2377	else {
2378	s = scan_const(PL_bufptr);
2379	if (*s == '\\')
2380	PL_lex_state = LEX_INTERPCASEMOD;
2381	else
2382	PL_lex_state = LEX_INTERPSTART;
2383	}
2384
2385	if (s != PL_bufptr) {
2386	PL_nextval[PL_nexttoke] = yylval;
2387	PL_expect = XTERM;
2388	force_next(THING);
2389	if (PL_lex_starts++)
2390	Aop(OP_CONCAT);
2391	else {
2392	PL_bufptr = s;
2393	return yylex();
2394	}
2395	}
2396
2397	return yylex();
2398	case LEX_FORMLINE:
2399	PL_lex_state = LEX_NORMAL;
2400	s = scan_formline(PL_bufptr);
2401	if (!PL_lex_formbrack)
2402	goto rightbracket;
2403	OPERATOR(';');
2404	}
2405
2406	s = PL_bufptr;
2407	PL_oldoldbufptr = PL_oldbufptr;
2408	PL_oldbufptr = s;
2409	DEBUG_T( {
2410	PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at %s\n",
2411	exp_name[PL_expect], s);
2412	} );
2413
2414	retry:
2415	switch (*s) {
2416	default:
2417	if (isIDFIRST_lazy_if(s,UTF))
2418	goto keylookup;
2419	Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
2420	case 4:
2421	case 26:
2422	goto fake_eof; /* emulate EOF on ^D or ^Z */
2423	case 0:
2424	if (!PL_rsfp) {
2425	PL_last_uni = 0;
2426	PL_last_lop = 0;
2427	if (PL_lex_brackets)
2428	yyerror("Missing right curly or square bracket");
2429	DEBUG_T( { PerlIO_printf(Perl_debug_log,
2430	"### Tokener got EOF\n");
2431	} );
2432	TOKEN(0);
2433	}
2434	if (s++ < PL_bufend)
2435	goto retry; /* ignore stray nulls */
2436	PL_last_uni = 0;
2437	PL_last_lop = 0;
2438	if (!PL_in_eval && !PL_preambled) {
2439	PL_preambled = TRUE;
2440	sv_setpv(PL_linestr,incl_perldb());
2441	if (SvCUR(PL_linestr))
2442	sv_catpv(PL_linestr,";");
2443	if (PL_preambleav){
2444	while(AvFILLp(PL_preambleav) >= 0) {
2445	SV *tmpsv = av_shift(PL_preambleav);
2446	sv_catsv(PL_linestr, tmpsv);
2447	sv_catpv(PL_linestr, ";");
2448	sv_free(tmpsv);
2449	}
2450	sv_free((SV*)PL_preambleav);
2451	PL_preambleav = NULL;
2452	}
2453	if (PL_minus_n \|\| PL_minus_p) {
2454	sv_catpv(PL_linestr, "LINE: while (<>) {");
2455	if (PL_minus_l)
2456	sv_catpv(PL_linestr,"chomp;");
2457	if (PL_minus_a) {
2458	if (PL_minus_F) {
2459	if (strchr("/'\"", *PL_splitstr)
2460	&& strchr(PL_splitstr + 1, *PL_splitstr))
2461	Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
2462	else {
2463	char delim;
2464	s = "'~#\200\1'"; /* surely one char is unused...*/
2465	while (s[1] && strchr(PL_splitstr, *s)) s++;
2466	delim = *s;
2467	Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s%c",
2468	"q" + (delim == '\''), delim);
2469	for (s = PL_splitstr; *s; s++) {
2470	if (*s == '\\')
2471	sv_catpvn(PL_linestr, "\\", 1);
2472	sv_catpvn(PL_linestr, s, 1);
2473	}
2474	Perl_sv_catpvf(aTHX_ PL_linestr, "%c);", delim);
2475	}
2476	}
2477	else
2478	sv_catpv(PL_linestr,"our @F=split(' ');");
2479	}
2480	}
2481	sv_catpv(PL_linestr, "\n");
2482	PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2483	PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2484	PL_last_lop = PL_last_uni = Nullch;
2485	if (PERLDB_LINE && PL_curstash != PL_debstash) {
2486	SV *sv = NEWSV(85,0);
2487
2488	sv_upgrade(sv, SVt_PVMG);
2489	sv_setsv(sv,PL_linestr);
2490	(void)SvIOK_on(sv);
2491	SvIVX(sv) = 0;
2492	av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2493	}
2494	goto retry;
2495	}
2496	do {
2497	bof = PL_rsfp ? TRUE : FALSE;
2498	if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
2499	fake_eof:
2500	if (PL_rsfp) {
2501	if (PL_preprocess && !PL_in_eval)
2502	(void)PerlProc_pclose(PL_rsfp);
2503	else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2504	PerlIO_clearerr(PL_rsfp);
2505	else
2506	(void)PerlIO_close(PL_rsfp);
2507	PL_rsfp = Nullfp;
2508	PL_doextract = FALSE;
2509	}
2510	if (!PL_in_eval && (PL_minus_n \|\| PL_minus_p)) {
2511	sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
2512	sv_catpv(PL_linestr,";}");
2513	PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2514	PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2515	PL_last_lop = PL_last_uni = Nullch;
2516	PL_minus_n = PL_minus_p = 0;
2517	goto retry;
2518	}
2519	PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2520	PL_last_lop = PL_last_uni = Nullch;
2521	sv_setpv(PL_linestr,"");
2522	TOKEN(';'); /* not infinite loop because rsfp is NULL now */
2523	}
2524	/* if it looks like the start of a BOM, check if it in fact is */
2525	else if (bof && (!s \|\| (U8)s == 0xEF \|\| (U8*)s >= 0xFE)) {
2526	#ifdef PERLIO_IS_STDIO
2527	# ifdef __GNU_LIBRARY__
2528	# if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
2529	# define FTELL_FOR_PIPE_IS_BROKEN
2530	# endif
2531	# else
2532	# ifdef __GLIBC__
2533	# if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
2534	# define FTELL_FOR_PIPE_IS_BROKEN
2535	# endif
2536	# endif
2537	# endif
2538	#endif
2539	#ifdef FTELL_FOR_PIPE_IS_BROKEN
2540	/* This loses the possibility to detect the bof
2541	* situation on perl -P when the libc5 is being used.
2542	* Workaround? Maybe attach some extra state to PL_rsfp?
2543	*/
2544	if (!PL_preprocess)
2545	bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
2546	#else
2547	bof = PerlIO_tell(PL_rsfp) == (Off_t)SvCUR(PL_linestr);
2548	#endif
2549	if (bof) {
2550	PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2551	s = swallow_bom((U8*)s);
2552	}
2553	}
2554	if (PL_doextract) {
2555	/* Incest with pod. */
2556	if (*s == '=' && strnEQ(s, "=cut", 4)) {
2557	sv_setpv(PL_linestr, "");
2558	PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2559	PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2560	PL_last_lop = PL_last_uni = Nullch;
2561	PL_doextract = FALSE;
2562	}
2563	}
2564	incline(s);
2565	} while (PL_doextract);
2566	PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2567	if (PERLDB_LINE && PL_curstash != PL_debstash) {
2568	SV *sv = NEWSV(85,0);
2569
2570	sv_upgrade(sv, SVt_PVMG);
2571	sv_setsv(sv,PL_linestr);
2572	(void)SvIOK_on(sv);
2573	SvIVX(sv) = 0;
2574	av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2575	}
2576	PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2577	PL_last_lop = PL_last_uni = Nullch;
2578	if (CopLINE(PL_curcop) == 1) {
2579	while (s < PL_bufend && isSPACE(*s))
2580	s++;
2581	if (s == ':' && s[1] != ':') / for csh execing sh scripts */
2582	s++;
2583	d = Nullch;
2584	if (!PL_in_eval) {
2585	if (s == '#' && (s+1) == '!')
2586	d = s + 2;
2587	#ifdef ALTERNATE_SHEBANG
2588	else {
2589	static char as[] = ALTERNATE_SHEBANG;
2590	if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2591	d = s + (sizeof(as) - 1);
2592	}
2593	#endif /* ALTERNATE_SHEBANG */
2594	}
2595	if (d) {
2596	char *ipath;
2597	char *ipathend;
2598
2599	while (isSPACE(*d))
2600	d++;
2601	ipath = d;
2602	while (d && !isSPACE(d))
2603	d++;
2604	ipathend = d;
2605
2606	#ifdef ARG_ZERO_IS_SCRIPT
2607	if (ipathend > ipath) {
2608	/*
2609	* HP-UX (at least) sets argv[0] to the script name,
2610	* which makes $^X incorrect. And Digital UNIX and Linux,
2611	* at least, set argv[0] to the basename of the Perl
2612	* interpreter. So, having found "#!", we'll set it right.
2613	*/
2614	SV x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV)); / $^X */
2615	assert(SvPOK(x) \|\| SvGMAGICAL(x));
2616	if (sv_eq(x, CopFILESV(PL_curcop))) {
2617	sv_setpvn(x, ipath, ipathend - ipath);
2618	SvSETMAGIC(x);
2619	}
2620	else {
2621	STRLEN blen;
2622	STRLEN llen;
2623	char *bstart = SvPV(CopFILESV(PL_curcop),blen);
2624	char *lstart = SvPV(x,llen);
2625	if (llen < blen) {
2626	bstart += blen - llen;
2627	if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
2628	sv_setpvn(x, ipath, ipathend - ipath);
2629	SvSETMAGIC(x);
2630	}
2631	}
2632	}
2633	TAINT_NOT; /* $^X is always tainted, but that's OK */
2634	}
2635	#endif /* ARG_ZERO_IS_SCRIPT */
2636
2637	/*
2638	* Look for options.
2639	*/
2640	d = instr(s,"perl -");
2641	if (!d) {
2642	d = instr(s,"perl");
2643	#if defined(DOSISH)
2644	/* avoid getting into infinite loops when shebang
2645	* line contains "Perl" rather than "perl" */
2646	if (!d) {
2647	for (d = ipathend-4; d >= ipath; --d) {
2648	if ((d == 'p' \|\| d == 'P')
2649	&& !ibcmp(d, "perl", 4))
2650	{
2651	break;
2652	}
2653	}
2654	if (d < ipath)
2655	d = Nullch;
2656	}
2657	#endif
2658	}
2659	#ifdef ALTERNATE_SHEBANG
2660	/*
2661	* If the ALTERNATE_SHEBANG on this system starts with a
2662	* character that can be part of a Perl expression, then if
2663	* we see it but not "perl", we're probably looking at the
2664	* start of Perl code, not a request to hand off to some
2665	* other interpreter. Similarly, if "perl" is there, but
2666	* not in the first 'word' of the line, we assume the line
2667	* contains the start of the Perl program.
2668	*/
2669	if (d && *s != '#') {
2670	char *c = ipath;
2671	while (c && !strchr("; \t\r\n\f\v#", c))
2672	c++;
2673	if (c < d)
2674	d = Nullch; /* "perl" not in first word; ignore */
2675	else
2676	s = '#'; / Don't try to parse shebang line */
2677	}
2678	#endif /* ALTERNATE_SHEBANG */
2679	#ifndef MACOS_TRADITIONAL
2680	if (!d &&
2681	*s == '#' &&
2682	ipathend > ipath &&
2683	!PL_minus_c &&
2684	!instr(s,"indir") &&
2685	instr(PL_origargv[0],"perl"))
2686	{
2687	char **newargv;
2688
2689	*ipathend = '\0';
2690	s = ipathend + 1;
2691	while (s < PL_bufend && isSPACE(*s))
2692	s++;
2693	if (s < PL_bufend) {
2694	Newz(899,newargv,PL_origargc+3,char*);
2695	newargv[1] = s;
2696	while (s < PL_bufend && !isSPACE(*s))
2697	s++;
2698	*s = '\0';
2699	Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2700	}
2701	else
2702	newargv = PL_origargv;
2703	newargv[0] = ipath;
2704	PERL_FPU_PRE_EXEC
2705	PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
2706	PERL_FPU_POST_EXEC
2707	Perl_croak(aTHX_ "Can't exec %s", ipath);
2708	}
2709	#endif
2710	if (d) {
2711	U32 oldpdb = PL_perldb;
2712	bool oldn = PL_minus_n;
2713	bool oldp = PL_minus_p;
2714
2715	while (d && !isSPACE(d)) d++;
2716	while (SPACE_OR_TAB(*d)) d++;
2717
2718	if (*d++ == '-') {
2719	bool switches_done = PL_doswitches;
2720	do {
2721	if (d == 'M' \|\| d == 'm') {
2722	char *m = d;
2723	while (d && !isSPACE(d)) d++;
2724	Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2725	(int)(d - m), m);
2726	}
2727	d = moreswitches(d);
2728	} while (d);
2729	if (PL_doswitches && !switches_done) {
2730	int argc = PL_origargc;
2731	char **argv = PL_origargv;
2732	do {
2733	argc--,argv++;
2734	} while (argc && argv[0][0] == '-' && argv[0][1]);
2735	init_argv_symbols(argc,argv);
2736	}
2737	if ((PERLDB_LINE && !oldpdb) \|\|
2738	((PL_minus_n \|\| PL_minus_p) && !(oldn \|\| oldp)))
2739	/* if we have already added "LINE: while (<>) {",
2740	we must not do it again */
2741	{
2742	sv_setpv(PL_linestr, "");
2743	PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2744	PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2745	PL_last_lop = PL_last_uni = Nullch;
2746	PL_preambled = FALSE;
2747	if (PERLDB_LINE)
2748	(void)gv_fetchfile(PL_origfilename);
2749	goto retry;
2750	}
2751	if (PL_doswitches && !switches_done) {
2752	int argc = PL_origargc;
2753	char **argv = PL_origargv;
2754	do {
2755	argc--,argv++;
2756	} while (argc && argv[0][0] == '-' && argv[0][1]);
2757	init_argv_symbols(argc,argv);
2758	}
2759	}
2760	}
2761	}
2762	}
2763	if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2764	PL_bufptr = s;
2765	PL_lex_state = LEX_FORMLINE;
2766	return yylex();
2767	}
2768	goto retry;
2769	case '\r':
2770	#ifdef PERL_STRICT_CR
2771	Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2772	Perl_croak(aTHX_
2773	"\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
2774	#endif
2775	case ' ': case '\t': case '\f': case 013:
2776	#ifdef MACOS_TRADITIONAL
2777	case '\312':
2778	#endif
2779	s++;
2780	goto retry;
2781	case '#':
2782	case '\n':
2783	if (PL_lex_state != LEX_NORMAL \|\| (PL_in_eval && !PL_rsfp)) {
2784	if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
2785	/* handle eval qq[#line 1 "foo"\n ...] */
2786	CopLINE_dec(PL_curcop);
2787	incline(s);
2788	}
2789	d = PL_bufend;
2790	while (s < d && *s != '\n')
2791	s++;
2792	if (s < d)
2793	s++;
2794	else if (s > d) /* Found by Ilya: feed random input to Perl. */
2795	Perl_croak(aTHX_ "panic: input overflow");
2796	incline(s);
2797	if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2798	PL_bufptr = s;
2799	PL_lex_state = LEX_FORMLINE;
2800	return yylex();
2801	}
2802	}
2803	else {
2804	*s = '\0';
2805	PL_bufend = s;
2806	}
2807	goto retry;
2808	case '-':
2809	if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2810	I32 ftst = 0;
2811
2812	s++;
2813	PL_bufptr = s;
2814	tmp = *s++;
2815
2816	while (s < PL_bufend && SPACE_OR_TAB(*s))
2817	s++;
2818
2819	if (strnEQ(s,"=>",2)) {
2820	s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2821	DEBUG_T( { PerlIO_printf(Perl_debug_log,
2822	"### Saw unary minus before =>, forcing word '%s'\n", s);
2823	} );
2824	OPERATOR('-'); /* unary minus */
2825	}
2826	PL_last_uni = PL_oldbufptr;
2827	switch (tmp) {
2828	case 'r': ftst = OP_FTEREAD; break;
2829	case 'w': ftst = OP_FTEWRITE; break;
2830	case 'x': ftst = OP_FTEEXEC; break;
2831	case 'o': ftst = OP_FTEOWNED; break;
2832	case 'R': ftst = OP_FTRREAD; break;
2833	case 'W': ftst = OP_FTRWRITE; break;
2834	case 'X': ftst = OP_FTREXEC; break;
2835	case 'O': ftst = OP_FTROWNED; break;
2836	case 'e': ftst = OP_FTIS; break;
2837	case 'z': ftst = OP_FTZERO; break;
2838	case 's': ftst = OP_FTSIZE; break;
2839	case 'f': ftst = OP_FTFILE; break;
2840	case 'd': ftst = OP_FTDIR; break;
2841	case 'l': ftst = OP_FTLINK; break;
2842	case 'p': ftst = OP_FTPIPE; break;
2843	case 'S': ftst = OP_FTSOCK; break;
2844	case 'u': ftst = OP_FTSUID; break;
2845	case 'g': ftst = OP_FTSGID; break;
2846	case 'k': ftst = OP_FTSVTX; break;
2847	case 'b': ftst = OP_FTBLK; break;
2848	case 'c': ftst = OP_FTCHR; break;
2849	case 't': ftst = OP_FTTTY; break;
2850	case 'T': ftst = OP_FTTEXT; break;
2851	case 'B': ftst = OP_FTBINARY; break;
2852	case 'M': case 'A': case 'C':
2853	gv_fetchpv("\024",TRUE, SVt_PV);
2854	switch (tmp) {
2855	case 'M': ftst = OP_FTMTIME; break;
2856	case 'A': ftst = OP_FTATIME; break;
2857	case 'C': ftst = OP_FTCTIME; break;
2858	default: break;
2859	}
2860	break;
2861	default:
2862	break;
2863	}
2864	if (ftst) {
2865	PL_last_lop_op = (OPCODE)ftst;
2866	DEBUG_T( { PerlIO_printf(Perl_debug_log,
2867	"### Saw file test %c\n", (int)ftst);
2868	} );
2869	FTST(ftst);
2870	}
2871	else {
2872	/* Assume it was a minus followed by a one-letter named
2873	* subroutine call (or a -bareword), then. */
2874	DEBUG_T( { PerlIO_printf(Perl_debug_log,
2875	"### '-%c' looked like a file test but was not\n",
2876	tmp);
2877	} );
2878	s = --PL_bufptr;
2879	}
2880	}
2881	tmp = *s++;
2882	if (*s == tmp) {
2883	s++;
2884	if (PL_expect == XOPERATOR)
2885	TERM(POSTDEC);
2886	else
2887	OPERATOR(PREDEC);
2888	}
2889	else if (*s == '>') {
2890	s++;
2891	s = skipspace(s);
2892	if (isIDFIRST_lazy_if(s,UTF)) {
2893	s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2894	TOKEN(ARROW);
2895	}
2896	else if (*s == '$')
2897	OPERATOR(ARROW);
2898	else
2899	TERM(ARROW);
2900	}
2901	if (PL_expect == XOPERATOR)
2902	Aop(OP_SUBTRACT);
2903	else {
2904	if (isSPACE(s) \|\| !isSPACE(PL_bufptr))
2905	check_uni();
2906	OPERATOR('-'); /* unary minus */
2907	}
2908
2909	case '+':
2910	tmp = *s++;
2911	if (*s == tmp) {
2912	s++;
2913	if (PL_expect == XOPERATOR)
2914	TERM(POSTINC);
2915	else
2916	OPERATOR(PREINC);
2917	}
2918	if (PL_expect == XOPERATOR)
2919	Aop(OP_ADD);
2920	else {
2921	if (isSPACE(s) \|\| !isSPACE(PL_bufptr))
2922	check_uni();
2923	OPERATOR('+');
2924	}
2925
2926	case '*':
2927	if (PL_expect != XOPERATOR) {
2928	s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2929	PL_expect = XOPERATOR;
2930	force_ident(PL_tokenbuf, '*');
2931	if (!*PL_tokenbuf)
2932	PREREF('*');
2933	TERM('*');
2934	}
2935	s++;
2936	if (s == '') {
2937	s++;
2938	PWop(OP_POW);
2939	}
2940	Mop(OP_MULTIPLY);
2941
2942	case '%':
2943	if (PL_expect == XOPERATOR) {
2944	++s;
2945	Mop(OP_MODULO);
2946	}
2947	PL_tokenbuf[0] = '%';
2948	s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2949	if (!PL_tokenbuf[1]) {
2950	PREREF('%');
2951	}
2952	PL_pending_ident = '%';
2953	TERM('%');
2954
2955	case '^':
2956	s++;
2957	BOop(OP_BIT_XOR);
2958	case '[':
2959	PL_lex_brackets++;
2960	/* FALL THROUGH */
2961	case '~':
2962	case ',':
2963	tmp = *s++;
2964	OPERATOR(tmp);
2965	case ':':
2966	if (s[1] == ':') {
2967	len = 0;
2968	goto just_a_word;
2969	}
2970	s++;
2971	switch (PL_expect) {
2972	OP *attrs;
2973	case XOPERATOR:
2974	if (!PL_in_my \|\| PL_lex_state != LEX_NORMAL)
2975	break;
2976	PL_bufptr = s; /* update in case we back off */
2977	goto grabattrs;
2978	case XATTRBLOCK:
2979	PL_expect = XBLOCK;
2980	goto grabattrs;
2981	case XATTRTERM:
2982	PL_expect = XTERMBLOCK;
2983	grabattrs:
2984	s = skipspace(s);
2985	attrs = Nullop;
2986	while (isIDFIRST_lazy_if(s,UTF)) {
2987	d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2988	if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
2989	if (tmp < 0) tmp = -tmp;
2990	switch (tmp) {
2991	case KEY_or:
2992	case KEY_and:
2993	case KEY_for:
2994	case KEY_unless:
2995	case KEY_if:
2996	case KEY_while:
2997	case KEY_until:
2998	goto got_attrs;
2999	default:
3000	break;
3001	}
3002	}
3003	if (*d == '(') {
3004	d = scan_str(d,TRUE,TRUE);
3005	if (!d) {
3006	/* MUST advance bufptr here to avoid bogus
3007	"at end of line" context messages from yyerror().
3008	*/
3009	PL_bufptr = s + len;
3010	yyerror("Unterminated attribute parameter in attribute list");
3011	if (attrs)
3012	op_free(attrs);
3013	return 0; /* EOF indicator */
3014	}
3015	}
3016	if (PL_lex_stuff) {
3017	SV *sv = newSVpvn(s, len);
3018	sv_catsv(sv, PL_lex_stuff);
3019	attrs = append_elem(OP_LIST, attrs,
3020	newSVOP(OP_CONST, 0, sv));
3021	SvREFCNT_dec(PL_lex_stuff);
3022	PL_lex_stuff = Nullsv;
3023	}
3024	else {
3025	/* NOTE: any CV attrs applied here need to be part of
3026	the CVf_BUILTIN_ATTRS define in cv.h! */
3027	if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len))
3028	CvLVALUE_on(PL_compcv);
3029	else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len))
3030	CvLOCKED_on(PL_compcv);
3031	else if (!PL_in_my && len == 6 && strnEQ(s, "method", len))
3032	CvMETHOD_on(PL_compcv);
3033	else if (PL_in_my == KEY_our && len == 6 &&
3034	strnEQ(s, "unique", len))
3035	#ifdef USE_ITHREADS
3036	GvUNIQUE_on(cGVOPx_gv(yylval.opval));
3037	#else
3038	; /* skip that case to avoid loading attributes.pm */
3039	#endif
3040	/* After we've set the flags, it could be argued that
3041	we don't need to do the attributes.pm-based setting
3042	process, and shouldn't bother appending recognized
3043	flags. To experiment with that, uncomment the
3044	following "else". (Note that's already been
3045	uncommented. That keeps the above-applied built-in
3046	attributes from being intercepted (and possibly
3047	rejected) by a package's attribute routines, but is
3048	justified by the performance win for the common case
3049	of applying only built-in attributes.) */
3050	else
3051	attrs = append_elem(OP_LIST, attrs,
3052	newSVOP(OP_CONST, 0,
3053	newSVpvn(s, len)));
3054	}
3055	s = skipspace(d);
3056	if (*s == ':' && s[1] != ':')
3057	s = skipspace(s+1);
3058	else if (s == d)
3059	break; /* require real whitespace or :'s */
3060	}
3061	tmp = (PL_expect == XOPERATOR ? '=' : '{'); /'}(' for vi /
3062	if (s != ';' && s != '}' && s != tmp && (tmp != '=' \|\| s != ')')) {
3063	char q = ((*s == '\'') ? '"' : '\'');
3064	/* If here for an expression, and parsed no attrs, back off. */
3065	if (tmp == '=' && !attrs) {
3066	s = PL_bufptr;
3067	break;
3068	}
3069	/* MUST advance bufptr here to avoid bogus "at end of line"
3070	context messages from yyerror().
3071	*/
3072	PL_bufptr = s;
3073	if (!*s)
3074	yyerror("Unterminated attribute list");
3075	else
3076	yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list",
3077	q, *s, q));
3078	if (attrs)
3079	op_free(attrs);
3080	OPERATOR(':');
3081	}
3082	got_attrs:
3083	if (attrs) {
3084	PL_nextval[PL_nexttoke].opval = attrs;
3085	force_next(THING);
3086	}
3087	TOKEN(COLONATTR);
3088	}
3089	OPERATOR(':');
3090	case '(':
3091	s++;
3092	if (PL_last_lop == PL_oldoldbufptr \|\| PL_last_uni == PL_oldoldbufptr)
3093	PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
3094	else
3095	PL_expect = XTERM;
3096	s = skipspace(s);
3097	TOKEN('(');
3098	case ';':
3099	CLINE;
3100	tmp = *s++;
3101	OPERATOR(tmp);
3102	case ')':
3103	tmp = *s++;
3104	s = skipspace(s);
3105	if (*s == '{')
3106	PREBLOCK(tmp);
3107	TERM(tmp);
3108	case ']':
3109	s++;
3110	if (PL_lex_brackets <= 0)
3111	yyerror("Unmatched right square bracket");
3112	else
3113	--PL_lex_brackets;
3114	if (PL_lex_state == LEX_INTERPNORMAL) {
3115	if (PL_lex_brackets == 0) {
3116	if (s != '[' && s != '{' && (*s != '-' \|\| s[1] != '>'))
3117	PL_lex_state = LEX_INTERPEND;
3118	}
3119	}
3120	TERM(']');
3121	case '{':
3122	leftbracket:
3123	s++;
3124	if (PL_lex_brackets > 100) {
3125	Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
3126	}
3127	switch (PL_expect) {
3128	case XTERM:
3129	if (PL_lex_formbrack) {
3130	s--;
3131	PRETERMBLOCK(DO);
3132	}
3133	if (PL_oldoldbufptr == PL_last_lop)
3134	PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3135	else
3136	PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3137	OPERATOR(HASHBRACK);
3138	case XOPERATOR:
3139	while (s < PL_bufend && SPACE_OR_TAB(*s))
3140	s++;
3141	d = s;
3142	PL_tokenbuf[0] = '\0';
3143	if (d < PL_bufend && *d == '-') {
3144	PL_tokenbuf[0] = '-';
3145	d++;
3146	while (d < PL_bufend && SPACE_OR_TAB(*d))
3147	d++;
3148	}
3149	if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
3150	d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
3151	FALSE, &len);
3152	while (d < PL_bufend && SPACE_OR_TAB(*d))
3153	d++;
3154	if (*d == '}') {
3155	char minus = (PL_tokenbuf[0] == '-');
3156	s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
3157	if (minus)
3158	force_next('-');
3159	}
3160	}
3161	/* FALL THROUGH */
3162	case XATTRBLOCK:
3163	case XBLOCK:
3164	PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
3165	PL_expect = XSTATE;
3166	break;
3167	case XATTRTERM:
3168	case XTERMBLOCK:
3169	PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3170	PL_expect = XSTATE;
3171	break;
3172	default: {
3173	char *t;
3174	if (PL_oldoldbufptr == PL_last_lop)
3175	PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3176	else
3177	PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3178	s = skipspace(s);
3179	if (*s == '}') {
3180	if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
3181	PL_expect = XTERM;
3182	/* This hack is to get the ${} in the message. */
3183	PL_bufptr = s+1;
3184	yyerror("syntax error");
3185	break;
3186	}
3187	OPERATOR(HASHBRACK);
3188	}
3189	/* This hack serves to disambiguate a pair of curlies
3190	* as being a block or an anon hash. Normally, expectation
3191	* determines that, but in cases where we're not in a
3192	* position to expect anything in particular (like inside
3193	* eval"") we have to resolve the ambiguity. This code
3194	* covers the case where the first term in the curlies is a
3195	* quoted string. Most other cases need to be explicitly
3196	* disambiguated by prepending a `+' before the opening
3197	* curly in order to force resolution as an anon hash.
3198	*
3199	* XXX should probably propagate the outer expectation
3200	* into eval"" to rely less on this hack, but that could
3201	* potentially break current behavior of eval"".
3202	* GSAR 97-07-21
3203	*/
3204	t = s;
3205	if (s == '\'' \|\| s == '"' \|\| *s == '`') {
3206	/* common case: get past first string, handling escapes */
3207	for (t++; t < PL_bufend && t != s;)
3208	if (t++ == '\\' && (t == '\\' \|\| t == s))
3209	t++;
3210	t++;
3211	}
3212	else if (*s == 'q') {
3213	if (++t < PL_bufend
3214	&& (!isALNUM(*t)
3215	\|\| ((t == 'q' \|\| t == 'x') && ++t < PL_bufend
3216	&& !isALNUM(*t))))
3217	{
3218	/* skip q//-like construct */
3219	char *tmps;
3220	char open, close, term;
3221	I32 brackets = 1;
3222
3223	while (t < PL_bufend && isSPACE(*t))
3224	t++;
3225	/* check for q => */
3226	if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
3227	OPERATOR(HASHBRACK);
3228	}
3229	term = *t;
3230	open = term;
3231	if (term && (tmps = strchr("([{< )]}> )]}>",term)))
3232	term = tmps[5];
3233	close = term;
3234	if (open == close)
3235	for (t++; t < PL_bufend; t++) {
3236	if (*t == '\\' && t+1 < PL_bufend && open != '\\')
3237	t++;
3238	else if (*t == open)
3239	break;
3240	}
3241	else {
3242	for (t++; t < PL_bufend; t++) {
3243	if (*t == '\\' && t+1 < PL_bufend)
3244	t++;
3245	else if (*t == close && --brackets <= 0)
3246	break;
3247	else if (*t == open)
3248	brackets++;
3249	}
3250	}
3251	t++;
3252	}
3253	else
3254	/* skip plain q word */
3255	while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3256	t += UTF8SKIP(t);
3257	}
3258	else if (isALNUM_lazy_if(t,UTF)) {
3259	t += UTF8SKIP(t);
3260	while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3261	t += UTF8SKIP(t);
3262	}
3263	while (t < PL_bufend && isSPACE(*t))
3264	t++;
3265	/* if comma follows first term, call it an anon hash */
3266	/* XXX it could be a comma expression with loop modifiers */
3267	if (t < PL_bufend && ((t == ',' && (s == 'q' \|\| !isLOWER(*s)))
3268	\|\| (*t == '=' && t[1] == '>')))
3269	OPERATOR(HASHBRACK);
3270	if (PL_expect == XREF)
3271	PL_expect = XTERM;
3272	else {
3273	PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
3274	PL_expect = XSTATE;
3275	}
3276	}
3277	break;
3278	}
3279	yylval.ival = CopLINE(PL_curcop);
3280	if (isSPACE(s) \|\| s == '#')
3281	PL_copline = NOLINE; /* invalidate current command line number */
3282	TOKEN('{');
3283	case '}':
3284	rightbracket:
3285	s++;
3286	if (PL_lex_brackets <= 0)
3287	yyerror("Unmatched right curly bracket");
3288	else
3289	PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
3290	if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
3291	PL_lex_formbrack = 0;
3292	if (PL_lex_state == LEX_INTERPNORMAL) {
3293	if (PL_lex_brackets == 0) {
3294	if (PL_expect & XFAKEBRACK) {
3295	PL_expect &= XENUMMASK;
3296	PL_lex_state = LEX_INTERPEND;
3297	PL_bufptr = s;
3298	return yylex(); /* ignore fake brackets */
3299	}
3300	if (*s == '-' && s[1] == '>')
3301	PL_lex_state = LEX_INTERPENDMAYBE;
3302	else if (s != '[' && s != '{')
3303	PL_lex_state = LEX_INTERPEND;
3304	}
3305	}
3306	if (PL_expect & XFAKEBRACK) {
3307	PL_expect &= XENUMMASK;
3308	PL_bufptr = s;
3309	return yylex(); /* ignore fake brackets */
3310	}
3311	force_next('}');
3312	TOKEN(';');
3313	case '&':
3314	s++;
3315	tmp = *s++;
3316	if (tmp == '&')
3317	AOPERATOR(ANDAND);
3318	s--;
3319	if (PL_expect == XOPERATOR) {
3320	if (ckWARN(WARN_SEMICOLON)
3321	&& isIDFIRST_lazy_if(s,UTF) && PL_bufptr == PL_linestart)
3322	{
3323	CopLINE_dec(PL_curcop);
3324	Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
3325	CopLINE_inc(PL_curcop);
3326	}
3327	BAop(OP_BIT_AND);
3328	}
3329
3330	s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3331	if (*PL_tokenbuf) {
3332	PL_expect = XOPERATOR;
3333	force_ident(PL_tokenbuf, '&');
3334	}
3335	else
3336	PREREF('&');
3337	yylval.ival = (OPpENTERSUB_AMPER<<8);
3338	TERM('&');
3339
3340	case '\|':
3341	s++;
3342	tmp = *s++;
3343	if (tmp == '\|')
3344	AOPERATOR(OROR);
3345	s--;
3346	BOop(OP_BIT_OR);
3347	case '=':
3348	s++;
3349	tmp = *s++;
3350	if (tmp == '=')
3351	Eop(OP_EQ);
3352	if (tmp == '>')
3353	OPERATOR(',');
3354	if (tmp == '~')
3355	PMop(OP_MATCH);
3356	if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(s) && strchr("+-/%.^&\|<",tmp))
3357	Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Reversed %c= operator",(int)tmp);
3358	s--;
3359	if (PL_expect == XSTATE && isALPHA(tmp) &&
3360	(s == PL_linestart+1 \|\| s[-2] == '\n') )
3361	{
3362	if (PL_in_eval && !PL_rsfp) {
3363	d = PL_bufend;
3364	while (s < d) {
3365	if (*s++ == '\n') {
3366	incline(s);
3367	if (strnEQ(s,"=cut",4)) {
3368	s = strchr(s,'\n');
3369	if (s)
3370	s++;
3371	else
3372	s = d;
3373	incline(s);
3374	goto retry;
3375	}
3376	}
3377	}
3378	goto retry;
3379	}
3380	s = PL_bufend;
3381	PL_doextract = TRUE;
3382	goto retry;
3383	}
3384	if (PL_lex_brackets < PL_lex_formbrack) {
3385	char *t;
3386	#ifdef PERL_STRICT_CR
3387	for (t = s; SPACE_OR_TAB(*t); t++) ;
3388	#else
3389	for (t = s; SPACE_OR_TAB(t) \|\| t == '\r'; t++) ;
3390	#endif
3391	if (t == '\n' \|\| t == '#') {
3392	s--;
3393	PL_expect = XBLOCK;
3394	goto leftbracket;
3395	}
3396	}
3397	yylval.ival = 0;
3398	OPERATOR(ASSIGNOP);
3399	case '!':
3400	s++;
3401	tmp = *s++;
3402	if (tmp == '=')
3403	Eop(OP_NE);
3404	if (tmp == '~')
3405	PMop(OP_NOT);
3406	s--;
3407	OPERATOR('!');
3408	case '<':
3409	if (PL_expect != XOPERATOR) {
3410	if (s[1] != '<' && !strchr(s,'>'))
3411	check_uni();
3412	if (s[1] == '<')
3413	s = scan_heredoc(s);
3414	else
3415	s = scan_inputsymbol(s);
3416	TERM(sublex_start());
3417	}
3418	s++;
3419	tmp = *s++;
3420	if (tmp == '<')
3421	SHop(OP_LEFT_SHIFT);
3422	if (tmp == '=') {
3423	tmp = *s++;
3424	if (tmp == '>')
3425	Eop(OP_NCMP);
3426	s--;
3427	Rop(OP_LE);
3428	}
3429	s--;
3430	Rop(OP_LT);
3431	case '>':
3432	s++;
3433	tmp = *s++;
3434	if (tmp == '>')
3435	SHop(OP_RIGHT_SHIFT);
3436	if (tmp == '=')
3437	Rop(OP_GE);
3438	s--;
3439	Rop(OP_GT);
3440
3441	case '$':
3442	CLINE;
3443
3444	if (PL_expect == XOPERATOR) {
3445	if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3446	PL_expect = XTERM;
3447	depcom();
3448	return ','; /* grandfather non-comma-format format */
3449	}
3450	}
3451
3452	if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) \|\| strchr("{$:+-", s[2]))) {
3453	PL_tokenbuf[0] = '@';
3454	s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3455	sizeof PL_tokenbuf - 1, FALSE);
3456	if (PL_expect == XOPERATOR)
3457	no_op("Array length", s);
3458	if (!PL_tokenbuf[1])
3459	PREREF(DOLSHARP);
3460	PL_expect = XOPERATOR;
3461	PL_pending_ident = '#';
3462	TOKEN(DOLSHARP);
3463	}
3464
3465	PL_tokenbuf[0] = '$';
3466	s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3467	sizeof PL_tokenbuf - 1, FALSE);
3468	if (PL_expect == XOPERATOR)
3469	no_op("Scalar", s);
3470	if (!PL_tokenbuf[1]) {
3471	if (s == PL_bufend)
3472	yyerror("Final $ should be \\$ or $name");
3473	PREREF('$');
3474	}
3475
3476	/* This kludge not intended to be bulletproof. */
3477	if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
3478	yylval.opval = newSVOP(OP_CONST, 0,
3479	newSViv(PL_compiling.cop_arybase));
3480	yylval.opval->op_private = OPpCONST_ARYBASE;
3481	TERM(THING);
3482	}
3483
3484	d = s;
3485	tmp = (I32)*s;
3486	if (PL_lex_state == LEX_NORMAL)
3487	s = skipspace(s);
3488
3489	if ((PL_expect != XREF \|\| PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3490	char *t;
3491	if (*s == '[') {
3492	PL_tokenbuf[0] = '@';
3493	if (ckWARN(WARN_SYNTAX)) {
3494	for(t = s + 1;
3495	isSPACE(t) \|\| isALNUM_lazy_if(t,UTF) \|\| t == '$';
3496	t++) ;
3497	if (*t++ == ',') {
3498	PL_bufptr = skipspace(PL_bufptr);
3499	while (t < PL_bufend && *t != ']')
3500	t++;
3501	Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3502	"Multidimensional syntax %.*s not supported",
3503	(t - PL_bufptr) + 1, PL_bufptr);
3504	}
3505	}
3506	}
3507	else if (*s == '{') {
3508	PL_tokenbuf[0] = '%';
3509	if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
3510	(t = strchr(s, '}')) && (t = strchr(t, '=')))
3511	{
3512	char tmpbuf[sizeof PL_tokenbuf];
3513	STRLEN len;
3514	for (t++; isSPACE(*t); t++) ;
3515	if (isIDFIRST_lazy_if(t,UTF)) {
3516	t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
3517	for (; isSPACE(*t); t++) ;
3518	if (*t == ';' && get_cv(tmpbuf, FALSE))
3519	Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3520	"You need to quote \"%s\"", tmpbuf);
3521	}
3522	}
3523	}
3524	}
3525
3526	PL_expect = XOPERATOR;
3527	if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3528	bool islop = (PL_last_lop == PL_oldoldbufptr);
3529	if (!islop \|\| PL_last_lop_op == OP_GREPSTART)
3530	PL_expect = XOPERATOR;
3531	else if (strchr("$@\"'`q", *s))
3532	PL_expect = XTERM; /* e.g. print $fh "foo" */
3533	else if (strchr("&<%", s) && isIDFIRST_lazy_if(s+1,UTF))
3534	PL_expect = XTERM; /* e.g. print $fh &sub */
3535	else if (isIDFIRST_lazy_if(s,UTF)) {
3536	char tmpbuf[sizeof PL_tokenbuf];
3537	scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3538	if ((tmp = keyword(tmpbuf, len))) {
3539	/* binary operators exclude handle interpretations */
3540	switch (tmp) {
3541	case -KEY_x:
3542	case -KEY_eq:
3543	case -KEY_ne:
3544	case -KEY_gt:
3545	case -KEY_lt:
3546	case -KEY_ge:
3547	case -KEY_le:
3548	case -KEY_cmp:
3549	break;
3550	default:
3551	PL_expect = XTERM; /* e.g. print $fh length() */
3552	break;
3553	}
3554	}
3555	else {
3556	PL_expect = XTERM; /* e.g. print $fh subr() */
3557	}
3558	}
3559	else if (isDIGIT(*s))
3560	PL_expect = XTERM; /* e.g. print $fh 3 */
3561	else if (*s == '.' && isDIGIT(s[1]))
3562	PL_expect = XTERM; /* e.g. print $fh .3 */
3563	else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
3564	PL_expect = XTERM; /* e.g. print $fh -1 */
3565	else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3566	PL_expect = XTERM; /* print $fh <<"EOF" */
3567	}
3568	PL_pending_ident = '$';
3569	TOKEN('$');
3570
3571	case '@':
3572	if (PL_expect == XOPERATOR)
3573	no_op("Array", s);
3574	PL_tokenbuf[0] = '@';
3575	s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3576	if (!PL_tokenbuf[1]) {
3577	PREREF('@');
3578	}
3579	if (PL_lex_state == LEX_NORMAL)
3580	s = skipspace(s);
3581	if ((PL_expect != XREF \|\| PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3582	if (*s == '{')
3583	PL_tokenbuf[0] = '%';
3584
3585	/* Warn about @ where they meant $. */
3586	if (ckWARN(WARN_SYNTAX)) {
3587	if (s == '[' \|\| s == '{') {
3588	char *t = s + 1;
3589	while (t && (isALNUM_lazy_if(t,UTF) \|\| strchr(" \t$#+-'\"", t)))
3590	t++;
3591	if (t == '}' \|\| t == ']') {
3592	t++;
3593	PL_bufptr = skipspace(PL_bufptr);
3594	Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3595	"Scalar value %.s better written as $%.s",
3596	t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
3597	}
3598	}
3599	}
3600	}
3601	PL_pending_ident = '@';
3602	TERM('@');
3603
3604	case '/': /* may either be division or pattern */
3605	case '?': /* may either be conditional or pattern */
3606	if (PL_expect != XOPERATOR) {
3607	/* Disable warning on "study /blah/" */
3608	if (PL_oldoldbufptr == PL_last_uni
3609	&& (*PL_last_uni != 's' \|\| s - PL_last_uni < 5
3610	\|\| memNE(PL_last_uni, "study", 5)
3611	\|\| isALNUM_lazy_if(PL_last_uni+5,UTF)))
3612	check_uni();
3613	s = scan_pat(s,OP_MATCH);
3614	TERM(sublex_start());
3615	}
3616	tmp = *s++;
3617	if (tmp == '/')
3618	Mop(OP_DIVIDE);
3619	OPERATOR(tmp);
3620
3621	case '.':
3622	if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3623	#ifdef PERL_STRICT_CR
3624	&& s[1] == '\n'
3625	#else
3626	&& (s[1] == '\n' \|\| (s[1] == '\r' && s[2] == '\n'))
3627	#endif
3628	&& (s == PL_linestart \|\| s[-1] == '\n') )
3629	{
3630	PL_lex_formbrack = 0;
3631	PL_expect = XSTATE;
3632	goto rightbracket;
3633	}
3634	if (PL_expect == XOPERATOR \|\| !isDIGIT(s[1])) {
3635	tmp = *s++;
3636	if (*s == tmp) {
3637	s++;
3638	if (*s == tmp) {
3639	s++;
3640	yylval.ival = OPf_SPECIAL;
3641	}
3642	else
3643	yylval.ival = 0;
3644	OPERATOR(DOTDOT);
3645	}
3646	if (PL_expect != XOPERATOR)
3647	check_uni();
3648	Aop(OP_CONCAT);
3649	}
3650	/* FALL THROUGH */
3651	case '0': case '1': case '2': case '3': case '4':
3652	case '5': case '6': case '7': case '8': case '9':
3653	s = scan_num(s, &yylval);
3654	DEBUG_T( { PerlIO_printf(Perl_debug_log,
3655	"### Saw number before '%s'\n", s);
3656	} );
3657	if (PL_expect == XOPERATOR)
3658	no_op("Number",s);
3659	TERM(THING);
3660
3661	case '\'':
3662	s = scan_str(s,FALSE,FALSE);
3663	DEBUG_T( { PerlIO_printf(Perl_debug_log,
3664	"### Saw string before '%s'\n", s);
3665	} );
3666	if (PL_expect == XOPERATOR) {
3667	if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3668	PL_expect = XTERM;
3669	depcom();
3670	return ','; /* grandfather non-comma-format format */
3671	}
3672	else
3673	no_op("String",s);
3674	}
3675	if (!s)
3676	missingterm((char*)0);
3677	yylval.ival = OP_CONST;
3678	TERM(sublex_start());
3679
3680	case '"':
3681	s = scan_str(s,FALSE,FALSE);
3682	DEBUG_T( { PerlIO_printf(Perl_debug_log,
3683	"### Saw string before '%s'\n", s);
3684	} );
3685	if (PL_expect == XOPERATOR) {
3686	if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3687	PL_expect = XTERM;
3688	depcom();
3689	return ','; /* grandfather non-comma-format format */
3690	}
3691	else
3692	no_op("String",s);
3693	}
3694	if (!s)
3695	missingterm((char*)0);
3696	yylval.ival = OP_CONST;
3697	for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
3698	if (d == '$' \|\| d == '@' \|\| d == '\\' \|\| !UTF8_IS_INVARIANT((U8)d)) {
3699	yylval.ival = OP_STRINGIFY;
3700	break;
3701	}
3702	}
3703	TERM(sublex_start());
3704
3705	case '`':
3706	s = scan_str(s,FALSE,FALSE);
3707	DEBUG_T( { PerlIO_printf(Perl_debug_log,
3708	"### Saw backtick string before '%s'\n", s);
3709	} );
3710	if (PL_expect == XOPERATOR)
3711	no_op("Backticks",s);
3712	if (!s)
3713	missingterm((char*)0);
3714	yylval.ival = OP_BACKTICK;
3715	set_csh();
3716	TERM(sublex_start());
3717
3718	case '\\':
3719	s++;
3720	if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
3721	Perl_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
3722	s, s);
3723	if (PL_expect == XOPERATOR)
3724	no_op("Backslash",s);
3725	OPERATOR(REFGEN);
3726
3727	case 'v':
3728	if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
3729	char *start = s;
3730	start++;
3731	start++;
3732	while (isDIGIT(start) \|\| start == '_')
3733	start++;
3734	if (*start == '.' && isDIGIT(start[1])) {
3735	s = scan_num(s, &yylval);
3736	TERM(THING);
3737	}
3738	/* avoid v123abc() or $h{v1}, allow C<print v10;> */
3739	else if (!isALPHA(*start) && (PL_expect == XTERM \|\| PL_expect == XREF \|\| PL_expect == XSTATE)) {
3740	char c = *start;
3741	GV *gv;
3742	*start = '\0';
3743	gv = gv_fetchpv(s, FALSE, SVt_PVCV);
3744	*start = c;
3745	if (!gv) {
3746	s = scan_num(s, &yylval);
3747	TERM(THING);
3748	}
3749	}
3750	}
3751	goto keylookup;
3752	case 'x':
3753	if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
3754	s++;
3755	Mop(OP_REPEAT);
3756	}
3757	goto keylookup;
3758
3759	case '_':
3760	case 'a': case 'A':
3761	case 'b': case 'B':
3762	case 'c': case 'C':
3763	case 'd': case 'D':
3764	case 'e': case 'E':
3765	case 'f': case 'F':
3766	case 'g': case 'G':
3767	case 'h': case 'H':
3768	case 'i': case 'I':
3769	case 'j': case 'J':
3770	case 'k': case 'K':
3771	case 'l': case 'L':
3772	case 'm': case 'M':
3773	case 'n': case 'N':
3774	case 'o': case 'O':
3775	case 'p': case 'P':
3776	case 'q': case 'Q':
3777	case 'r': case 'R':
3778	case 's': case 'S':
3779	case 't': case 'T':
3780	case 'u': case 'U':
3781	case 'V':
3782	case 'w': case 'W':
3783	case 'X':
3784	case 'y': case 'Y':
3785	case 'z': case 'Z':
3786
3787	keylookup: {
3788	orig_keyword = 0;
3789	gv = Nullgv;
3790	gvp = 0;
3791
3792	PL_bufptr = s;
3793	s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3794
3795	/* Some keywords can be followed by any delimiter, including ':' */
3796	tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) \|\|
3797	(len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') \|\|
3798	(PL_tokenbuf[0] == 'q' &&
3799	strchr("qwxr", PL_tokenbuf[1])))));
3800
3801	/* x::* is just a word, unless x is "CORE" */
3802	if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
3803	goto just_a_word;
3804
3805	d = s;
3806	while (d < PL_bufend && isSPACE(*d))
3807	d++; /* no comments skipped here, or s### is misparsed */
3808
3809	/* Is this a label? */
3810	if (!tmp && PL_expect == XSTATE
3811	&& d < PL_bufend && d == ':' && (d + 1) != ':') {
3812	s = d + 1;
3813	yylval.pval = savepv(PL_tokenbuf);
3814	CLINE;
3815	TOKEN(LABEL);
3816	}
3817
3818	/* Check for keywords */
3819	tmp = keyword(PL_tokenbuf, len);
3820
3821	/* Is this a word before a => operator? */
3822	if (*d == '=' && d[1] == '>') {
3823	CLINE;
3824	yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
3825	yylval.opval->op_private = OPpCONST_BARE;
3826	if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
3827	SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
3828	TERM(WORD);
3829	}
3830
3831	if (tmp < 0) { /* second-class keyword? */
3832	GV ogv = Nullgv; / override (winner) */
3833	GV hgv = Nullgv; / hidden (loser) */
3834	if (PL_expect != XOPERATOR && (*s != ':' \|\| s[1] != ':')) {
3835	CV *cv;
3836	if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3837	(cv = GvCVu(gv)))
3838	{
3839	if (GvIMPORTED_CV(gv))
3840	ogv = gv;
3841	else if (! CvMETHOD(cv))
3842	hgv = gv;
3843	}
3844	if (!ogv &&
3845	(gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3846	(gv = gvp) != (GV)&PL_sv_undef &&
3847	GvCVu(gv) && GvIMPORTED_CV(gv))
3848	{
3849	ogv = gv;
3850	}
3851	}
3852	if (ogv) {
3853	orig_keyword = tmp;
3854	tmp = 0; /* overridden by import or by GLOBAL */
3855	}
3856	else if (gv && !gvp
3857	&& -tmp==KEY_lock /* XXX generalizable kludge */
3858	&& GvCVu(gv)
3859	&& !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3860	{
3861	tmp = 0; /* any sub overrides "weak" keyword */
3862	}
3863	else { /* no override */
3864	tmp = -tmp;
3865	if (tmp == KEY_dump && ckWARN(WARN_MISC)) {
3866	Perl_warner(aTHX_ packWARN(WARN_MISC),
3867	"dump() better written as CORE::dump()");
3868	}
3869	gv = Nullgv;
3870	gvp = 0;
3871	if (ckWARN(WARN_AMBIGUOUS) && hgv
3872	&& tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3873	Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
3874	"Ambiguous call resolved as CORE::%s(), %s",
3875	GvENAME(hgv), "qualify as such or use &");
3876	}
3877	}
3878
3879	reserved_word:
3880	switch (tmp) {
3881
3882	default: /* not a keyword */
3883	just_a_word: {
3884	SV *sv;
3885	int pkgname = 0;
3886	char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3887
3888	/* Get the rest if it looks like a package qualifier */
3889
3890	if (s == '\'' \|\| (s == ':' && s[1] == ':')) {
3891	STRLEN morelen;
3892	s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3893	TRUE, &morelen);
3894	if (!morelen)
3895	Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
3896	*s == '\'' ? "'" : "::");
3897	len += morelen;
3898	pkgname = 1;
3899	}
3900
3901	if (PL_expect == XOPERATOR) {
3902	if (PL_bufptr == PL_linestart) {
3903	CopLINE_dec(PL_curcop);
3904	Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
3905	CopLINE_inc(PL_curcop);
3906	}
3907	else
3908	no_op("Bareword",s);
3909	}
3910
3911	/* Look for a subroutine with this name in current package,
3912	unless name is "Foo::", in which case Foo is a bearword
3913	(and a package name). */
3914
3915	if (len > 2 &&
3916	PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3917	{
3918	if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3919	Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
3920	"Bareword \"%s\" refers to nonexistent package",
3921	PL_tokenbuf);
3922	len -= 2;
3923	PL_tokenbuf[len] = '\0';
3924	gv = Nullgv;
3925	gvp = 0;
3926	}
3927	else {
3928	len = 0;
3929	if (!gv)
3930	gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3931	}
3932
3933	/* if we saw a global override before, get the right name */
3934
3935	if (gvp) {
3936	sv = newSVpvn("CORE::GLOBAL::",14);
3937	sv_catpv(sv,PL_tokenbuf);
3938	}
3939	else
3940	sv = newSVpv(PL_tokenbuf,0);
3941
3942	/* Presume this is going to be a bareword of some sort. */
3943
3944	CLINE;
3945	yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3946	yylval.opval->op_private = OPpCONST_BARE;
3947	/* UTF-8 package name? */
3948	if (UTF && !IN_BYTES &&
3949	is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
3950	SvUTF8_on(sv);
3951
3952	/* And if "Foo::", then that's what it certainly is. */
3953
3954	if (len)
3955	goto safe_bareword;
3956
3957	/* See if it's the indirect object for a list operator. */
3958
3959	if (PL_oldoldbufptr &&
3960	PL_oldoldbufptr < PL_bufptr &&
3961	(PL_oldoldbufptr == PL_last_lop
3962	\|\| PL_oldoldbufptr == PL_last_uni) &&
3963	/* NO SKIPSPACE BEFORE HERE! */
3964	(PL_expect == XREF \|\|
3965	((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
3966	{
3967	bool immediate_paren = *s == '(';
3968
3969	/* (Now we can afford to cross potential line boundary.) */
3970	s = skipspace(s);
3971
3972	/* Two barewords in a row may indicate method call. */
3973
3974	if ((isIDFIRST_lazy_if(s,UTF) \|\| *s == '$') && (tmp=intuit_method(s,gv)))
3975	return tmp;
3976
3977	/* If not a declared subroutine, it's an indirect object. */
3978	/* (But it's an indir obj regardless for sort.) */
3979
3980	if ( !immediate_paren && (PL_last_lop_op == OP_SORT \|\|
3981	((!gv \|\| !GvCVu(gv)) &&
3982	(PL_last_lop_op != OP_MAPSTART &&
3983	PL_last_lop_op != OP_GREPSTART))))
3984	{
3985	PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3986	goto bareword;
3987	}
3988	}
3989
3990	PL_expect = XOPERATOR;
3991	s = skipspace(s);
3992
3993	/* Is this a word before a => operator? */
3994	if (*s == '=' && s[1] == '>' && !pkgname) {
3995	CLINE;
3996	sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
3997	if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
3998	SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
3999	TERM(WORD);
4000	}
4001
4002	/* If followed by a paren, it's certainly a subroutine. */
4003	if (*s == '(') {
4004	CLINE;
4005	if (gv && GvCVu(gv)) {
4006	for (d = s + 1; SPACE_OR_TAB(*d); d++) ;
4007	if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
4008	s = d + 1;
4009	goto its_constant;
4010	}
4011	}
4012	PL_nextval[PL_nexttoke].opval = yylval.opval;
4013	PL_expect = XOPERATOR;
4014	force_next(WORD);
4015	yylval.ival = 0;
4016	TOKEN('&');
4017	}
4018
4019	/* If followed by var or block, call it a method (unless sub) */
4020
4021	if ((s == '$' \|\| s == '{') && (!gv \|\| !GvCVu(gv))) {
4022	PL_last_lop = PL_oldbufptr;
4023	PL_last_lop_op = OP_METHOD;
4024	PREBLOCK(METHOD);
4025	}
4026
4027	/* If followed by a bareword, see if it looks like indir obj. */
4028
4029	if (!orig_keyword
4030	&& (isIDFIRST_lazy_if(s,UTF) \|\| *s == '$')
4031	&& (tmp = intuit_method(s,gv)))
4032	return tmp;
4033
4034	/* Not a method, so call it a subroutine (if defined) */
4035
4036	if (gv && GvCVu(gv)) {
4037	CV* cv;
4038	if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
4039	Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4040	"Ambiguous use of -%s resolved as -&%s()",
4041	PL_tokenbuf, PL_tokenbuf);
4042	/* Check for a constant sub */
4043	cv = GvCV(gv);
4044	if ((sv = cv_const_sv(cv))) {
4045	its_constant:
4046	SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
4047	((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
4048	yylval.opval->op_private = 0;
4049	TOKEN(WORD);
4050	}
4051
4052	/* Resolve to GV now. */
4053	op_free(yylval.opval);
4054	yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
4055	yylval.opval->op_private \|= OPpENTERSUB_NOPAREN;
4056	PL_last_lop = PL_oldbufptr;
4057	PL_last_lop_op = OP_ENTERSUB;
4058	/* Is there a prototype? */
4059	if (SvPOK(cv)) {
4060	STRLEN len;
4061	char proto = SvPV((SV)cv, len);
4062	if (!len)
4063	TERM(FUNC0SUB);
4064	if (strEQ(proto, "$"))
4065	OPERATOR(UNIOPSUB);
4066	while (*proto == ';')
4067	proto++;
4068	if (proto == '&' && s == '{') {
4069	sv_setpv(PL_subname, PL_curstash ?
4070	"__ANON__" : "__ANON__::__ANON__");
4071	PREBLOCK(LSTOPSUB);
4072	}
4073	}
4074	PL_nextval[PL_nexttoke].opval = yylval.opval;
4075	PL_expect = XTERM;
4076	force_next(WORD);
4077	TOKEN(NOAMP);
4078	}
4079
4080	/* Call it a bare word */
4081
4082	if (PL_hints & HINT_STRICT_SUBS)
4083	yylval.opval->op_private \|= OPpCONST_STRICT;
4084	else {
4085	bareword:
4086	if (ckWARN(WARN_RESERVED)) {
4087	if (lastchar != '-') {
4088	for (d = PL_tokenbuf; d && isLOWER(d); d++) ;
4089	if (!*d && !gv_stashpv(PL_tokenbuf,FALSE))
4090	Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
4091	PL_tokenbuf);
4092	}
4093	}
4094	}
4095
4096	safe_bareword:
4097	if (lastchar && strchr("*%&", lastchar) && ckWARN_d(WARN_AMBIGUOUS)) {
4098	Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4099	"Operator or semicolon missing before %c%s",
4100	lastchar, PL_tokenbuf);
4101	Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4102	"Ambiguous use of %c resolved as operator %c",
4103	lastchar, lastchar);
4104	}
4105	TOKEN(WORD);
4106	}
4107
4108	case KEY___FILE__:
4109	yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4110	newSVpv(CopFILE(PL_curcop),0));
4111	TERM(THING);
4112
4113	case KEY___LINE__:
4114	yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4115	Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
4116	TERM(THING);
4117
4118	case KEY___PACKAGE__:
4119	yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4120	(PL_curstash
4121	? newSVsv(PL_curstname)
4122	: &PL_sv_undef));
4123	TERM(THING);
4124
4125	case KEY___DATA__:
4126	case KEY___END__: {
4127	GV *gv;
4128
4129	/SUPPRESS 560/
4130	if (PL_rsfp && (!PL_in_eval \|\| PL_tokenbuf[2] == 'D')) {
4131	char *pname = "main";
4132	if (PL_tokenbuf[2] == 'D')
4133	pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
4134	gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
4135	GvMULTI_on(gv);
4136	if (!GvIO(gv))
4137	GvIOp(gv) = newIO();
4138	IoIFP(GvIOp(gv)) = PL_rsfp;
4139	#if defined(HAS_FCNTL) && defined(F_SETFD)
4140	{
4141	int fd = PerlIO_fileno(PL_rsfp);
4142	fcntl(fd,F_SETFD,fd >= 3);
4143	}
4144	#endif
4145	/* Mark this internal pseudo-handle as clean */
4146	IoFLAGS(GvIOp(gv)) \|= IOf_UNTAINT;
4147	if (PL_preprocess)
4148	IoTYPE(GvIOp(gv)) = IoTYPE_PIPE;
4149	else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
4150	IoTYPE(GvIOp(gv)) = IoTYPE_STD;
4151	else
4152	IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
4153	#if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
4154	/* if the script was opened in binmode, we need to revert
4155	* it to text mode for compatibility; but only iff it has CRs
4156	* XXX this is a questionable hack at best. */
4157	if (PL_bufend-PL_bufptr > 2
4158	&& PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
4159	{
4160	Off_t loc = 0;
4161	if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
4162	loc = PerlIO_tell(PL_rsfp);
4163	(void)PerlIO_seek(PL_rsfp, 0L, 0);
4164	}
4165	#ifdef NETWARE
4166	if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
4167	#else
4168	if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
4169	#endif /* NETWARE */
4170	#ifdef PERLIO_IS_STDIO /* really? */
4171	# if defined(__BORLANDC__)
4172	/* XXX see note in do_binmode() */
4173	((FILE*)PL_rsfp)->flags &= ~_F_BIN;
4174	# endif
4175	#endif
4176	if (loc > 0)
4177	PerlIO_seek(PL_rsfp, loc, 0);
4178	}
4179	}
4180	#endif
4181	#ifdef PERLIO_LAYERS
4182	if (!IN_BYTES) {
4183	if (UTF)
4184	PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
4185	else if (PL_encoding) {
4186	SV *name;
4187	dSP;
4188	ENTER;
4189	SAVETMPS;
4190	PUSHMARK(sp);
4191	EXTEND(SP, 1);
4192	XPUSHs(PL_encoding);
4193	PUTBACK;
4194	call_method("name", G_SCALAR);
4195	SPAGAIN;
4196	name = POPs;
4197	PUTBACK;
4198	PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
4199	Perl_form(aTHX_ ":encoding(%"SVf")",
4200	name));
4201	FREETMPS;
4202	LEAVE;
4203	}
4204	}
4205	#endif
4206	PL_rsfp = Nullfp;
4207	}
4208	goto fake_eof;
4209	}
4210
4211	case KEY_AUTOLOAD:
4212	case KEY_DESTROY:
4213	case KEY_BEGIN:
4214	case KEY_CHECK:
4215	case KEY_INIT:
4216	case KEY_END:
4217	if (PL_expect == XSTATE) {
4218	s = PL_bufptr;
4219	goto really_sub;
4220	}
4221	goto just_a_word;
4222
4223	case KEY_CORE:
4224	if (*s == ':' && s[1] == ':') {
4225	s += 2;
4226	d = s;
4227	s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4228	if (!(tmp = keyword(PL_tokenbuf, len)))
4229	Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
4230	if (tmp < 0)
4231	tmp = -tmp;
4232	goto reserved_word;
4233	}
4234	goto just_a_word;
4235
4236	case KEY_abs:
4237	UNI(OP_ABS);
4238
4239	case KEY_alarm:
4240	UNI(OP_ALARM);
4241
4242	case KEY_accept:
4243	LOP(OP_ACCEPT,XTERM);
4244
4245	case KEY_and:
4246	OPERATOR(ANDOP);
4247
4248	case KEY_atan2:
4249	LOP(OP_ATAN2,XTERM);
4250
4251	case KEY_bind:
4252	LOP(OP_BIND,XTERM);
4253
4254	case KEY_binmode:
4255	LOP(OP_BINMODE,XTERM);
4256
4257	case KEY_bless:
4258	LOP(OP_BLESS,XTERM);
4259
4260	case KEY_chop:
4261	UNI(OP_CHOP);
4262
4263	case KEY_continue:
4264	PREBLOCK(CONTINUE);
4265
4266	case KEY_chdir:
4267	(void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
4268	UNI(OP_CHDIR);
4269
4270	case KEY_close:
4271	UNI(OP_CLOSE);
4272
4273	case KEY_closedir:
4274	UNI(OP_CLOSEDIR);
4275
4276	case KEY_cmp:
4277	Eop(OP_SCMP);
4278
4279	case KEY_caller:
4280	UNI(OP_CALLER);
4281
4282	case KEY_crypt:
4283	#ifdef FCRYPT
4284	if (!PL_cryptseen) {
4285	PL_cryptseen = TRUE;
4286	init_des();
4287	}
4288	#endif
4289	LOP(OP_CRYPT,XTERM);
4290
4291	case KEY_chmod:
4292	LOP(OP_CHMOD,XTERM);
4293
4294	case KEY_chown:
4295	LOP(OP_CHOWN,XTERM);
4296
4297	case KEY_connect:
4298	LOP(OP_CONNECT,XTERM);
4299
4300	case KEY_chr:
4301	UNI(OP_CHR);
4302
4303	case KEY_cos:
4304	UNI(OP_COS);
4305
4306	case KEY_chroot:
4307	UNI(OP_CHROOT);
4308
4309	case KEY_do:
4310	s = skipspace(s);
4311	if (*s == '{')
4312	PRETERMBLOCK(DO);
4313	if (*s != '\'')
4314	s = force_word(s,WORD,TRUE,TRUE,FALSE);
4315	OPERATOR(DO);
4316
4317	case KEY_die:
4318	PL_hints \|= HINT_BLOCK_SCOPE;
4319	LOP(OP_DIE,XTERM);
4320
4321	case KEY_defined:
4322	UNI(OP_DEFINED);
4323
4324	case KEY_delete:
4325	UNI(OP_DELETE);
4326
4327	case KEY_dbmopen:
4328	gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
4329	LOP(OP_DBMOPEN,XTERM);
4330
4331	case KEY_dbmclose:
4332	UNI(OP_DBMCLOSE);
4333
4334	case KEY_dump:
4335	s = force_word(s,WORD,TRUE,FALSE,FALSE);
4336	LOOPX(OP_DUMP);
4337
4338	case KEY_else:
4339	PREBLOCK(ELSE);
4340
4341	case KEY_elsif:
4342	yylval.ival = CopLINE(PL_curcop);
4343	OPERATOR(ELSIF);
4344
4345	case KEY_eq:
4346	Eop(OP_SEQ);
4347
4348	case KEY_exists:
4349	UNI(OP_EXISTS);
4350
4351	case KEY_exit:
4352	UNI(OP_EXIT);
4353
4354	case KEY_eval:
4355	s = skipspace(s);
4356	PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
4357	UNIBRACK(OP_ENTEREVAL);
4358
4359	case KEY_eof:
4360	UNI(OP_EOF);
4361
4362	case KEY_exp:
4363	UNI(OP_EXP);
4364
4365	case KEY_each:
4366	UNI(OP_EACH);
4367
4368	case KEY_exec:
4369	set_csh();
4370	LOP(OP_EXEC,XREF);
4371
4372	case KEY_endhostent:
4373	FUN0(OP_EHOSTENT);
4374
4375	case KEY_endnetent:
4376	FUN0(OP_ENETENT);
4377
4378	case KEY_endservent:
4379	FUN0(OP_ESERVENT);
4380
4381	case KEY_endprotoent:
4382	FUN0(OP_EPROTOENT);
4383
4384	case KEY_endpwent:
4385	FUN0(OP_EPWENT);
4386
4387	case KEY_endgrent:
4388	FUN0(OP_EGRENT);
4389
4390	case KEY_for:
4391	case KEY_foreach:
4392	yylval.ival = CopLINE(PL_curcop);
4393	s = skipspace(s);
4394	if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
4395	char *p = s;
4396	if ((PL_bufend - p) >= 3 &&
4397	strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
4398	p += 2;
4399	else if ((PL_bufend - p) >= 4 &&
4400	strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
4401	p += 3;
4402	p = skipspace(p);
4403	if (isIDFIRST_lazy_if(p,UTF)) {
4404	p = scan_ident(p, PL_bufend,
4405	PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4406	p = skipspace(p);
4407	}
4408	if (*p != '$')
4409	Perl_croak(aTHX_ "Missing $ on loop variable");
4410	}
4411	OPERATOR(FOR);
4412
4413	case KEY_formline:
4414	LOP(OP_FORMLINE,XTERM);
4415
4416	case KEY_fork:
4417	FUN0(OP_FORK);
4418
4419	case KEY_fcntl:
4420	LOP(OP_FCNTL,XTERM);
4421
4422	case KEY_fileno:
4423	UNI(OP_FILENO);
4424
4425	case KEY_flock:
4426	LOP(OP_FLOCK,XTERM);
4427
4428	case KEY_gt:
4429	Rop(OP_SGT);
4430
4431	case KEY_ge:
4432	Rop(OP_SGE);
4433
4434	case KEY_grep:
4435	LOP(OP_GREPSTART, XREF);
4436
4437	case KEY_goto:
4438	s = force_word(s,WORD,TRUE,FALSE,FALSE);
4439	LOOPX(OP_GOTO);
4440
4441	case KEY_gmtime:
4442	UNI(OP_GMTIME);
4443
4444	case KEY_getc:
4445	UNI(OP_GETC);
4446
4447	case KEY_getppid:
4448	FUN0(OP_GETPPID);
4449
4450	case KEY_getpgrp:
4451	UNI(OP_GETPGRP);
4452
4453	case KEY_getpriority:
4454	LOP(OP_GETPRIORITY,XTERM);
4455
4456	case KEY_getprotobyname:
4457	UNI(OP_GPBYNAME);
4458
4459	case KEY_getprotobynumber:
4460	LOP(OP_GPBYNUMBER,XTERM);
4461
4462	case KEY_getprotoent:
4463	FUN0(OP_GPROTOENT);
4464
4465	case KEY_getpwent:
4466	FUN0(OP_GPWENT);
4467
4468	case KEY_getpwnam:
4469	UNI(OP_GPWNAM);
4470
4471	case KEY_getpwuid:
4472	UNI(OP_GPWUID);
4473
4474	case KEY_getpeername:
4475	UNI(OP_GETPEERNAME);
4476
4477	case KEY_gethostbyname:
4478	UNI(OP_GHBYNAME);
4479
4480	case KEY_gethostbyaddr:
4481	LOP(OP_GHBYADDR,XTERM);
4482
4483	case KEY_gethostent:
4484	FUN0(OP_GHOSTENT);
4485
4486	case KEY_getnetbyname:
4487	UNI(OP_GNBYNAME);
4488
4489	case KEY_getnetbyaddr:
4490	LOP(OP_GNBYADDR,XTERM);
4491
4492	case KEY_getnetent:
4493	FUN0(OP_GNETENT);
4494
4495	case KEY_getservbyname:
4496	LOP(OP_GSBYNAME,XTERM);
4497
4498	case KEY_getservbyport:
4499	LOP(OP_GSBYPORT,XTERM);
4500
4501	case KEY_getservent:
4502	FUN0(OP_GSERVENT);
4503
4504	case KEY_getsockname:
4505	UNI(OP_GETSOCKNAME);
4506
4507	case KEY_getsockopt:
4508	LOP(OP_GSOCKOPT,XTERM);
4509
4510	case KEY_getgrent:
4511	FUN0(OP_GGRENT);
4512
4513	case KEY_getgrnam:
4514	UNI(OP_GGRNAM);
4515
4516	case KEY_getgrgid:
4517	UNI(OP_GGRGID);
4518
4519	case KEY_getlogin:
4520	FUN0(OP_GETLOGIN);
4521
4522	case KEY_glob:
4523	set_csh();
4524	LOP(OP_GLOB,XTERM);
4525
4526	case KEY_hex:
4527	UNI(OP_HEX);
4528
4529	case KEY_if:
4530	yylval.ival = CopLINE(PL_curcop);
4531	OPERATOR(IF);
4532
4533	case KEY_index:
4534	LOP(OP_INDEX,XTERM);
4535
4536	case KEY_int:
4537	UNI(OP_INT);
4538
4539	case KEY_ioctl:
4540	LOP(OP_IOCTL,XTERM);
4541
4542	case KEY_join:
4543	LOP(OP_JOIN,XTERM);
4544
4545	case KEY_keys:
4546	UNI(OP_KEYS);
4547
4548	case KEY_kill:
4549	LOP(OP_KILL,XTERM);
4550
4551	case KEY_last:
4552	s = force_word(s,WORD,TRUE,FALSE,FALSE);
4553	LOOPX(OP_LAST);
4554
4555	case KEY_lc:
4556	UNI(OP_LC);
4557
4558	case KEY_lcfirst:
4559	UNI(OP_LCFIRST);
4560
4561	case KEY_local:
4562	yylval.ival = 0;
4563	OPERATOR(LOCAL);
4564
4565	case KEY_length:
4566	UNI(OP_LENGTH);
4567
4568	case KEY_lt:
4569	Rop(OP_SLT);
4570
4571	case KEY_le:
4572	Rop(OP_SLE);
4573
4574	case KEY_localtime:
4575	UNI(OP_LOCALTIME);
4576
4577	case KEY_log:
4578	UNI(OP_LOG);
4579
4580	case KEY_link:
4581	LOP(OP_LINK,XTERM);
4582
4583	case KEY_listen:
4584	LOP(OP_LISTEN,XTERM);
4585
4586	case KEY_lock:
4587	UNI(OP_LOCK);
4588
4589	case KEY_lstat:
4590	UNI(OP_LSTAT);
4591
4592	case KEY_m:
4593	s = scan_pat(s,OP_MATCH);
4594	TERM(sublex_start());
4595
4596	case KEY_map:
4597	LOP(OP_MAPSTART, XREF);
4598
4599	case KEY_mkdir:
4600	LOP(OP_MKDIR,XTERM);
4601
4602	case KEY_msgctl:
4603	LOP(OP_MSGCTL,XTERM);
4604
4605	case KEY_msgget:
4606	LOP(OP_MSGGET,XTERM);
4607
4608	case KEY_msgrcv:
4609	LOP(OP_MSGRCV,XTERM);
4610
4611	case KEY_msgsnd:
4612	LOP(OP_MSGSND,XTERM);
4613
4614	case KEY_our:
4615	case KEY_my:
4616	PL_in_my = tmp;
4617	s = skipspace(s);
4618	if (isIDFIRST_lazy_if(s,UTF)) {
4619	s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
4620	if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
4621	goto really_sub;
4622	PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
4623	if (!PL_in_my_stash) {
4624	char tmpbuf[1024];
4625	PL_bufptr = s;
4626	sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
4627	yyerror(tmpbuf);
4628	}
4629	}
4630	yylval.ival = 1;
4631	OPERATOR(MY);
4632
4633	case KEY_next:
4634	s = force_word(s,WORD,TRUE,FALSE,FALSE);
4635	LOOPX(OP_NEXT);
4636
4637	case KEY_ne:
4638	Eop(OP_SNE);
4639
4640	case KEY_no:
4641	if (PL_expect != XSTATE)
4642	yyerror("\"no\" not allowed in expression");
4643	s = force_word(s,WORD,FALSE,TRUE,FALSE);
4644	s = force_version(s, FALSE);
4645	yylval.ival = 0;
4646	OPERATOR(USE);
4647
4648	case KEY_not:
4649	if (s == '(' \|\| (s = skipspace(s), s == '('))
4650	FUN1(OP_NOT);
4651	else
4652	OPERATOR(NOTOP);
4653
4654	case KEY_open:
4655	s = skipspace(s);
4656	if (isIDFIRST_lazy_if(s,UTF)) {
4657	char *t;
4658	for (d = s; isALNUM_lazy_if(d,UTF); d++) ;
4659	t = skipspace(d);
4660	if (strchr("\|&+-=!?:.", t) && ckWARN_d(WARN_PRECEDENCE)
4661	/* [perl #16184] */
4662	&& !(t[0] == '=' && t[1] == '>')
4663	) {
4664	Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4665	"Precedence problem: open %.s should be open(%.s)",
4666	d - s, s, d - s, s);
4667	}
4668	}
4669	LOP(OP_OPEN,XTERM);
4670
4671	case KEY_or:
4672	yylval.ival = OP_OR;
4673	OPERATOR(OROP);
4674
4675	case KEY_ord:
4676	UNI(OP_ORD);
4677
4678	case KEY_oct:
4679	UNI(OP_OCT);
4680
4681	case KEY_opendir:
4682	LOP(OP_OPEN_DIR,XTERM);
4683
4684	case KEY_print:
4685	checkcomma(s,PL_tokenbuf,"filehandle");
4686	LOP(OP_PRINT,XREF);
4687
4688	case KEY_printf:
4689	checkcomma(s,PL_tokenbuf,"filehandle");
4690	LOP(OP_PRTF,XREF);
4691
4692	case KEY_prototype:
4693	UNI(OP_PROTOTYPE);
4694
4695	case KEY_push:
4696	LOP(OP_PUSH,XTERM);
4697
4698	case KEY_pop:
4699	UNI(OP_POP);
4700
4701	case KEY_pos:
4702	UNI(OP_POS);
4703
4704	case KEY_pack:
4705	LOP(OP_PACK,XTERM);
4706
4707	case KEY_package:
4708	s = force_word(s,WORD,FALSE,TRUE,FALSE);
4709	OPERATOR(PACKAGE);
4710
4711	case KEY_pipe:
4712	LOP(OP_PIPE_OP,XTERM);
4713
4714	case KEY_q:
4715	s = scan_str(s,FALSE,FALSE);
4716	if (!s)
4717	missingterm((char*)0);
4718	yylval.ival = OP_CONST;
4719	TERM(sublex_start());
4720
4721	case KEY_quotemeta:
4722	UNI(OP_QUOTEMETA);
4723
4724	case KEY_qw:
4725	s = scan_str(s,FALSE,FALSE);
4726	if (!s)
4727	missingterm((char*)0);
4728	force_next(')');
4729	if (SvCUR(PL_lex_stuff)) {
4730	OP *words = Nullop;
4731	int warned = 0;
4732	d = SvPV_force(PL_lex_stuff, len);
4733	while (len) {
4734	SV *sv;
4735	for (; isSPACE(*d) && len; --len, ++d) ;
4736	if (len) {
4737	char *b = d;
4738	if (!warned && ckWARN(WARN_QW)) {
4739	for (; !isSPACE(*d) && len; --len, ++d) {
4740	if (*d == ',') {
4741	Perl_warner(aTHX_ packWARN(WARN_QW),
4742	"Possible attempt to separate words with commas");
4743	++warned;
4744	}
4745	else if (*d == '#') {
4746	Perl_warner(aTHX_ packWARN(WARN_QW),
4747	"Possible attempt to put comments in qw() list");
4748	++warned;
4749	}
4750	}
4751	}
4752	else {
4753	for (; !isSPACE(*d) && len; --len, ++d) ;
4754	}
4755	sv = newSVpvn(b, d-b);
4756	if (DO_UTF8(PL_lex_stuff))
4757	SvUTF8_on(sv);
4758	words = append_elem(OP_LIST, words,
4759	newSVOP(OP_CONST, 0, tokeq(sv)));
4760	}
4761	}
4762	if (words) {
4763	PL_nextval[PL_nexttoke].opval = words;
4764	force_next(THING);
4765	}
4766	}
4767	if (PL_lex_stuff) {
4768	SvREFCNT_dec(PL_lex_stuff);
4769	PL_lex_stuff = Nullsv;
4770	}
4771	PL_expect = XTERM;
4772	TOKEN('(');
4773
4774	case KEY_qq:
4775	s = scan_str(s,FALSE,FALSE);
4776	if (!s)
4777	missingterm((char*)0);
4778	yylval.ival = OP_STRINGIFY;
4779	if (SvIVX(PL_lex_stuff) == '\'')
4780	SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
4781	TERM(sublex_start());
4782
4783	case KEY_qr:
4784	s = scan_pat(s,OP_QR);
4785	TERM(sublex_start());
4786
4787	case KEY_qx:
4788	s = scan_str(s,FALSE,FALSE);
4789	if (!s)
4790	missingterm((char*)0);
4791	yylval.ival = OP_BACKTICK;
4792	set_csh();
4793	TERM(sublex_start());
4794
4795	case KEY_return:
4796	OLDLOP(OP_RETURN);
4797
4798	case KEY_require:
4799	s = skipspace(s);
4800	if (isDIGIT(*s)) {
4801	s = force_version(s, FALSE);
4802	}
4803	else if (*s != 'v' \|\| !isDIGIT(s[1])
4804	\|\| (s = force_version(s, TRUE), *s == 'v'))
4805	{
4806	*PL_tokenbuf = '\0';
4807	s = force_word(s,WORD,TRUE,TRUE,FALSE);
4808	if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
4809	gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
4810	else if (*s == '<')
4811	yyerror("<> should be quotes");
4812	}
4813	UNI(OP_REQUIRE);
4814
4815	case KEY_reset:
4816	UNI(OP_RESET);
4817
4818	case KEY_redo:
4819	s = force_word(s,WORD,TRUE,FALSE,FALSE);
4820	LOOPX(OP_REDO);
4821
4822	case KEY_rename:
4823	LOP(OP_RENAME,XTERM);
4824
4825	case KEY_rand:
4826	UNI(OP_RAND);
4827
4828	case KEY_rmdir:
4829	UNI(OP_RMDIR);
4830
4831	case KEY_rindex:
4832	LOP(OP_RINDEX,XTERM);
4833
4834	case KEY_read:
4835	LOP(OP_READ,XTERM);
4836
4837	case KEY_readdir:
4838	UNI(OP_READDIR);
4839
4840	case KEY_readline:
4841	set_csh();
4842	UNI(OP_READLINE);
4843
4844	case KEY_readpipe:
4845	set_csh();
4846	UNI(OP_BACKTICK);
4847
4848	case KEY_rewinddir:
4849	UNI(OP_REWINDDIR);
4850
4851	case KEY_recv:
4852	LOP(OP_RECV,XTERM);
4853
4854	case KEY_reverse:
4855	LOP(OP_REVERSE,XTERM);
4856
4857	case KEY_readlink:
4858	UNI(OP_READLINK);
4859
4860	case KEY_ref:
4861	UNI(OP_REF);
4862
4863	case KEY_s:
4864	s = scan_subst(s);
4865	if (yylval.opval)
4866	TERM(sublex_start());
4867	else
4868	TOKEN(1); /* force error */
4869
4870	case KEY_chomp:
4871	UNI(OP_CHOMP);
4872
4873	case KEY_scalar:
4874	UNI(OP_SCALAR);
4875
4876	case KEY_select:
4877	LOP(OP_SELECT,XTERM);
4878
4879	case KEY_seek:
4880	LOP(OP_SEEK,XTERM);
4881
4882	case KEY_semctl:
4883	LOP(OP_SEMCTL,XTERM);
4884
4885	case KEY_semget:
4886	LOP(OP_SEMGET,XTERM);
4887
4888	case KEY_semop:
4889	LOP(OP_SEMOP,XTERM);
4890
4891	case KEY_send:
4892	LOP(OP_SEND,XTERM);
4893
4894	case KEY_setpgrp:
4895	LOP(OP_SETPGRP,XTERM);
4896
4897	case KEY_setpriority:
4898	LOP(OP_SETPRIORITY,XTERM);
4899
4900	case KEY_sethostent:
4901	UNI(OP_SHOSTENT);
4902
4903	case KEY_setnetent:
4904	UNI(OP_SNETENT);
4905
4906	case KEY_setservent:
4907	UNI(OP_SSERVENT);
4908
4909	case KEY_setprotoent:
4910	UNI(OP_SPROTOENT);
4911
4912	case KEY_setpwent:
4913	FUN0(OP_SPWENT);
4914
4915	case KEY_setgrent:
4916	FUN0(OP_SGRENT);
4917
4918	case KEY_seekdir:
4919	LOP(OP_SEEKDIR,XTERM);
4920
4921	case KEY_setsockopt:
4922	LOP(OP_SSOCKOPT,XTERM);
4923
4924	case KEY_shift:
4925	UNI(OP_SHIFT);
4926
4927	case KEY_shmctl:
4928	LOP(OP_SHMCTL,XTERM);
4929
4930	case KEY_shmget:
4931	LOP(OP_SHMGET,XTERM);
4932
4933	case KEY_shmread:
4934	LOP(OP_SHMREAD,XTERM);
4935
4936	case KEY_shmwrite:
4937	LOP(OP_SHMWRITE,XTERM);
4938
4939	case KEY_shutdown:
4940	LOP(OP_SHUTDOWN,XTERM);
4941
4942	case KEY_sin:
4943	UNI(OP_SIN);
4944
4945	case KEY_sleep:
4946	UNI(OP_SLEEP);
4947
4948	case KEY_socket:
4949	LOP(OP_SOCKET,XTERM);
4950
4951	case KEY_socketpair:
4952	LOP(OP_SOCKPAIR,XTERM);
4953
4954	case KEY_sort:
4955	checkcomma(s,PL_tokenbuf,"subroutine name");
4956	s = skipspace(s);
4957	if (s == ';' \|\| s == ')') /* probably a close */
4958	Perl_croak(aTHX_ "sort is now a reserved word");
4959	PL_expect = XTERM;
4960	s = force_word(s,WORD,TRUE,TRUE,FALSE);
4961	LOP(OP_SORT,XREF);
4962
4963	case KEY_split:
4964	LOP(OP_SPLIT,XTERM);
4965
4966	case KEY_sprintf:
4967	LOP(OP_SPRINTF,XTERM);
4968
4969	case KEY_splice:
4970	LOP(OP_SPLICE,XTERM);
4971
4972	case KEY_sqrt:
4973	UNI(OP_SQRT);
4974
4975	case KEY_srand:
4976	UNI(OP_SRAND);
4977
4978	case KEY_stat:
4979	UNI(OP_STAT);
4980
4981	case KEY_study:
4982	UNI(OP_STUDY);
4983
4984	case KEY_substr:
4985	LOP(OP_SUBSTR,XTERM);
4986
4987	case KEY_format:
4988	case KEY_sub:
4989	really_sub:
4990	{
4991	char tmpbuf[sizeof PL_tokenbuf];
4992	SSize_t tboffset = 0;
4993	expectation attrful;
4994	bool have_name, have_proto, bad_proto;
4995	int key = tmp;
4996
4997	s = skipspace(s);
4998
4999	if (isIDFIRST_lazy_if(s,UTF) \|\| *s == '\'' \|\|
5000	(*s == ':' && s[1] == ':'))
5001	{
5002	PL_expect = XBLOCK;
5003	attrful = XATTRBLOCK;
5004	/* remember buffer pos'n for later force_word */
5005	tboffset = s - PL_oldbufptr;
5006	d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
5007	if (strchr(tmpbuf, ':'))
5008	sv_setpv(PL_subname, tmpbuf);
5009	else {
5010	sv_setsv(PL_subname,PL_curstname);
5011	sv_catpvn(PL_subname,"::",2);
5012	sv_catpvn(PL_subname,tmpbuf,len);
5013	}
5014	s = skipspace(d);
5015	have_name = TRUE;
5016	}
5017	else {
5018	if (key == KEY_my)
5019	Perl_croak(aTHX_ "Missing name in \"my sub\"");
5020	PL_expect = XTERMBLOCK;
5021	attrful = XATTRTERM;
5022	sv_setpv(PL_subname,"?");
5023	have_name = FALSE;
5024	}
5025
5026	if (key == KEY_format) {
5027	if (*s == '=')
5028	PL_lex_formbrack = PL_lex_brackets + 1;
5029	if (have_name)
5030	(void) force_word(PL_oldbufptr + tboffset, WORD,
5031	FALSE, TRUE, TRUE);
5032	OPERATOR(FORMAT);
5033	}
5034
5035	/* Look for a prototype */
5036	if (*s == '(') {
5037	char *p;
5038
5039	s = scan_str(s,FALSE,FALSE);
5040	if (!s)
5041	Perl_croak(aTHX_ "Prototype not terminated");
5042	/* strip spaces and check for bad characters */
5043	d = SvPVX(PL_lex_stuff);
5044	tmp = 0;
5045	bad_proto = FALSE;
5046	for (p = d; *p; ++p) {
5047	if (!isSPACE(*p)) {
5048	d[tmp++] = *p;
5049	if (!strchr("$@%;[]&\\", p))
5050	bad_proto = TRUE;
5051	}
5052	}
5053	d[tmp] = '\0';
5054	if (bad_proto && ckWARN(WARN_SYNTAX))
5055	Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5056	"Illegal character in prototype for %"SVf" : %s",
5057	PL_subname, d);
5058	SvCUR(PL_lex_stuff) = tmp;
5059	have_proto = TRUE;
5060
5061	s = skipspace(s);
5062	}
5063	else
5064	have_proto = FALSE;
5065
5066	if (*s == ':' && s[1] != ':')
5067	PL_expect = attrful;
5068	else if (!have_name && *s != '{' && key == KEY_sub)
5069	Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
5070
5071	if (have_proto) {
5072	PL_nextval[PL_nexttoke].opval =
5073	(OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
5074	PL_lex_stuff = Nullsv;
5075	force_next(THING);
5076	}
5077	if (!have_name) {
5078	sv_setpv(PL_subname,
5079	PL_curstash ? "__ANON__" : "__ANON__::__ANON__");
5080	TOKEN(ANONSUB);
5081	}
5082	(void) force_word(PL_oldbufptr + tboffset, WORD,
5083	FALSE, TRUE, TRUE);
5084	if (key == KEY_my)
5085	TOKEN(MYSUB);
5086	TOKEN(SUB);
5087	}
5088
5089	case KEY_system:
5090	set_csh();
5091	LOP(OP_SYSTEM,XREF);
5092
5093	case KEY_symlink:
5094	LOP(OP_SYMLINK,XTERM);
5095
5096	case KEY_syscall:
5097	LOP(OP_SYSCALL,XTERM);
5098
5099	case KEY_sysopen:
5100	LOP(OP_SYSOPEN,XTERM);
5101
5102	case KEY_sysseek:
5103	LOP(OP_SYSSEEK,XTERM);
5104
5105	case KEY_sysread:
5106	LOP(OP_SYSREAD,XTERM);
5107
5108	case KEY_syswrite:
5109	LOP(OP_SYSWRITE,XTERM);
5110
5111	case KEY_tr:
5112	s = scan_trans(s);
5113	TERM(sublex_start());
5114
5115	case KEY_tell:
5116	UNI(OP_TELL);
5117
5118	case KEY_telldir:
5119	UNI(OP_TELLDIR);
5120
5121	case KEY_tie:
5122	LOP(OP_TIE,XTERM);
5123
5124	case KEY_tied:
5125	UNI(OP_TIED);
5126
5127	case KEY_time:
5128	FUN0(OP_TIME);
5129
5130	case KEY_times:
5131	FUN0(OP_TMS);
5132
5133	case KEY_truncate:
5134	LOP(OP_TRUNCATE,XTERM);
5135
5136	case KEY_uc:
5137	UNI(OP_UC);
5138
5139	case KEY_ucfirst:
5140	UNI(OP_UCFIRST);
5141
5142	case KEY_untie:
5143	UNI(OP_UNTIE);
5144
5145	case KEY_until:
5146	yylval.ival = CopLINE(PL_curcop);
5147	OPERATOR(UNTIL);
5148
5149	case KEY_unless:
5150	yylval.ival = CopLINE(PL_curcop);
5151	OPERATOR(UNLESS);
5152
5153	case KEY_unlink:
5154	LOP(OP_UNLINK,XTERM);
5155
5156	case KEY_undef:
5157	UNI(OP_UNDEF);
5158
5159	case KEY_unpack:
5160	LOP(OP_UNPACK,XTERM);
5161
5162	case KEY_utime:
5163	LOP(OP_UTIME,XTERM);
5164
5165	case KEY_umask:
5166	UNI(OP_UMASK);
5167
5168	case KEY_unshift:
5169	LOP(OP_UNSHIFT,XTERM);
5170
5171	case KEY_use:
5172	if (PL_expect != XSTATE)
5173	yyerror("\"use\" not allowed in expression");
5174	s = skipspace(s);
5175	if (isDIGIT(s) \|\| (s == 'v' && isDIGIT(s[1]))) {
5176	s = force_version(s, TRUE);
5177	if (s == ';' \|\| (s = skipspace(s), s == ';')) {
5178	PL_nextval[PL_nexttoke].opval = Nullop;
5179	force_next(WORD);
5180	}
5181	else if (*s == 'v') {
5182	s = force_word(s,WORD,FALSE,TRUE,FALSE);
5183	s = force_version(s, FALSE);
5184	}
5185	}
5186	else {
5187	s = force_word(s,WORD,FALSE,TRUE,FALSE);
5188	s = force_version(s, FALSE);
5189	}
5190	yylval.ival = 1;
5191	OPERATOR(USE);
5192
5193	case KEY_values:
5194	UNI(OP_VALUES);
5195
5196	case KEY_vec:
5197	LOP(OP_VEC,XTERM);
5198
5199	case KEY_while:
5200	yylval.ival = CopLINE(PL_curcop);
5201	OPERATOR(WHILE);
5202
5203	case KEY_warn:
5204	PL_hints \|= HINT_BLOCK_SCOPE;
5205	LOP(OP_WARN,XTERM);
5206
5207	case KEY_wait:
5208	FUN0(OP_WAIT);
5209
5210	case KEY_waitpid:
5211	LOP(OP_WAITPID,XTERM);
5212
5213	case KEY_wantarray:
5214	FUN0(OP_WANTARRAY);
5215
5216	case KEY_write:
5217	#ifdef EBCDIC
5218	{
5219	char ctl_l[2];
5220	ctl_l[0] = toCTRL('L');
5221	ctl_l[1] = '\0';
5222	gv_fetchpv(ctl_l,TRUE, SVt_PV);
5223	}
5224	#else
5225	gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
5226	#endif
5227	UNI(OP_ENTERWRITE);
5228
5229	case KEY_x:
5230	if (PL_expect == XOPERATOR)
5231	Mop(OP_REPEAT);
5232	check_uni();
5233	goto just_a_word;
5234
5235	case KEY_xor:
5236	yylval.ival = OP_XOR;
5237	OPERATOR(OROP);
5238
5239	case KEY_y:
5240	s = scan_trans(s);
5241	TERM(sublex_start());
5242	}
5243	}}
5244	}
5245	#ifdef __SC__
5246	#pragma segment Main
5247	#endif
5248
5249	static int
5250	S_pending_ident(pTHX)
5251	{
5252	register char *d;
5253	register I32 tmp = 0;
5254	/* pit holds the identifier we read and pending_ident is reset */
5255	char pit = PL_pending_ident;
5256	PL_pending_ident = 0;
5257
5258	DEBUG_T({ PerlIO_printf(Perl_debug_log,
5259	"### Tokener saw identifier '%s'\n", PL_tokenbuf); });
5260
5261	/* if we're in a my(), we can't allow dynamics here.
5262	$foo'bar has already been turned into $foo::bar, so
5263	just check for colons.
5264
5265	if it's a legal name, the OP is a PADANY.
5266	*/
5267	if (PL_in_my) {
5268	if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
5269	if (strchr(PL_tokenbuf,':'))
5270	yyerror(Perl_form(aTHX_ "No package name allowed for "
5271	"variable %s in \"our\"",
5272	PL_tokenbuf));
5273	tmp = allocmy(PL_tokenbuf);
5274	}
5275	else {
5276	if (strchr(PL_tokenbuf,':'))
5277	yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
5278
5279	yylval.opval = newOP(OP_PADANY, 0);
5280	yylval.opval->op_targ = allocmy(PL_tokenbuf);
5281	return PRIVATEREF;
5282	}
5283	}
5284
5285	/*
5286	build the ops for accesses to a my() variable.
5287
5288	Deny my($a) or my($b) in a sort block, if $a or $b is
5289	then used in a comparison. This catches most, but not
5290	all cases. For instance, it catches
5291	sort { my($a); $a <=> $b }
5292	but not
5293	sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
5294	(although why you'd do that is anyone's guess).
5295	*/
5296
5297	if (!strchr(PL_tokenbuf,':')) {
5298	#ifdef USE_5005THREADS
5299	/* Check for single character per-thread SVs */
5300	if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
5301	&& !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
5302	&& (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
5303	{
5304	yylval.opval = newOP(OP_THREADSV, 0);
5305	yylval.opval->op_targ = tmp;
5306	return PRIVATEREF;
5307	}
5308	#endif /* USE_5005THREADS */
5309	if (!PL_in_my)
5310	tmp = pad_findmy(PL_tokenbuf);
5311	if (tmp != NOT_IN_PAD) {
5312	/* might be an "our" variable" */
5313	if (PAD_COMPNAME_FLAGS(tmp) & SVpad_OUR) {
5314	/* build ops for a bareword */
5315	SV *sym = newSVpv(HvNAME(PAD_COMPNAME_OURSTASH(tmp)), 0);
5316	sv_catpvn(sym, "::", 2);
5317	sv_catpv(sym, PL_tokenbuf+1);
5318	yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
5319	yylval.opval->op_private = OPpCONST_ENTERED;
5320	gv_fetchpv(SvPVX(sym),
5321	(PL_in_eval
5322	? (GV_ADDMULTI \| GV_ADDINEVAL)
5323	: GV_ADDMULTI
5324	),
5325	((PL_tokenbuf[0] == '$') ? SVt_PV
5326	: (PL_tokenbuf[0] == '@') ? SVt_PVAV
5327	: SVt_PVHV));
5328	return WORD;
5329	}
5330
5331	/* if it's a sort block and they're naming $a or $b */
5332	if (PL_last_lop_op == OP_SORT &&
5333	PL_tokenbuf[0] == '$' &&
5334	(PL_tokenbuf[1] == 'a' \|\| PL_tokenbuf[1] == 'b')
5335	&& !PL_tokenbuf[2])
5336	{
5337	for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
5338	d < PL_bufend && *d != '\n';
5339	d++)
5340	{
5341	if (strnEQ(d,"<=>",3) \|\| strnEQ(d,"cmp",3)) {
5342	Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
5343	PL_tokenbuf);
5344	}
5345	}
5346	}
5347
5348	yylval.opval = newOP(OP_PADANY, 0);
5349	yylval.opval->op_targ = tmp;
5350	return PRIVATEREF;
5351	}
5352	}
5353
5354	/*
5355	Whine if they've said @foo in a doublequoted string,
5356	and @foo isn't a variable we can find in the symbol
5357	table.
5358	*/
5359	if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
5360	GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
5361	if ((!gv \|\| ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
5362	&& ckWARN(WARN_AMBIGUOUS))
5363	{
5364	/* Downgraded from fatal to warning 20000522 mjd */
5365	Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5366	"Possible unintended interpolation of %s in string",
5367	PL_tokenbuf);
5368	}
5369	}
5370
5371	/* build ops for a bareword */
5372	yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
5373	yylval.opval->op_private = OPpCONST_ENTERED;
5374	gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI \| GV_ADDINEVAL) : TRUE,
5375	((PL_tokenbuf[0] == '$') ? SVt_PV
5376	: (PL_tokenbuf[0] == '@') ? SVt_PVAV
5377	: SVt_PVHV));
5378	return WORD;
5379	}
5380
5381	I32
5382	Perl_keyword(pTHX_ register char *d, I32 len)
5383	{
5384	switch (*d) {
5385	case '_':
5386	if (d[1] == '_') {
5387	if (strEQ(d,"__FILE__")) return -KEY___FILE__;
5388	if (strEQ(d,"__LINE__")) return -KEY___LINE__;
5389	if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
5390	if (strEQ(d,"__DATA__")) return KEY___DATA__;
5391	if (strEQ(d,"__END__")) return KEY___END__;
5392	}
5393	break;
5394	case 'A':
5395	if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
5396	break;
5397	case 'a':
5398	switch (len) {
5399	case 3:
5400	if (strEQ(d,"and")) return -KEY_and;
5401	if (strEQ(d,"abs")) return -KEY_abs;
5402	break;
5403	case 5:
5404	if (strEQ(d,"alarm")) return -KEY_alarm;
5405	if (strEQ(d,"atan2")) return -KEY_atan2;
5406	break;
5407	case 6:
5408	if (strEQ(d,"accept")) return -KEY_accept;
5409	break;
5410	}
5411	break;
5412	case 'B':
5413	if (strEQ(d,"BEGIN")) return KEY_BEGIN;
5414	break;
5415	case 'b':
5416	if (strEQ(d,"bless")) return -KEY_bless;
5417	if (strEQ(d,"bind")) return -KEY_bind;
5418	if (strEQ(d,"binmode")) return -KEY_binmode;
5419	break;
5420	case 'C':
5421	if (strEQ(d,"CORE")) return -KEY_CORE;
5422	if (strEQ(d,"CHECK")) return KEY_CHECK;
5423	break;
5424	case 'c':
5425	switch (len) {
5426	case 3:
5427	if (strEQ(d,"cmp")) return -KEY_cmp;
5428	if (strEQ(d,"chr")) return -KEY_chr;
5429	if (strEQ(d,"cos")) return -KEY_cos;
5430	break;
5431	case 4:
5432	if (strEQ(d,"chop")) return -KEY_chop;
5433	break;
5434	case 5:
5435	if (strEQ(d,"close")) return -KEY_close;
5436	if (strEQ(d,"chdir")) return -KEY_chdir;
5437	if (strEQ(d,"chomp")) return -KEY_chomp;
5438	if (strEQ(d,"chmod")) return -KEY_chmod;
5439	if (strEQ(d,"chown")) return -KEY_chown;
5440	if (strEQ(d,"crypt")) return -KEY_crypt;
5441	break;
5442	case 6:
5443	if (strEQ(d,"chroot")) return -KEY_chroot;
5444	if (strEQ(d,"caller")) return -KEY_caller;
5445	break;
5446	case 7:
5447	if (strEQ(d,"connect")) return -KEY_connect;
5448	break;
5449	case 8:
5450	if (strEQ(d,"closedir")) return -KEY_closedir;
5451	if (strEQ(d,"continue")) return -KEY_continue;
5452	break;
5453	}
5454	break;
5455	case 'D':
5456	if (strEQ(d,"DESTROY")) return KEY_DESTROY;
5457	break;
5458	case 'd':
5459	switch (len) {
5460	case 2:
5461	if (strEQ(d,"do")) return KEY_do;
5462	break;
5463	case 3:
5464	if (strEQ(d,"die")) return -KEY_die;
5465	break;
5466	case 4:
5467	if (strEQ(d,"dump")) return -KEY_dump;
5468	break;
5469	case 6:
5470	if (strEQ(d,"delete")) return KEY_delete;
5471	break;
5472	case 7:
5473	if (strEQ(d,"defined")) return KEY_defined;
5474	if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
5475	break;
5476	case 8:
5477	if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
5478	break;
5479	}
5480	break;
5481	case 'E':
5482	if (strEQ(d,"END")) return KEY_END;
5483	break;
5484	case 'e':
5485	switch (len) {
5486	case 2:
5487	if (strEQ(d,"eq")) return -KEY_eq;
5488	break;
5489	case 3:
5490	if (strEQ(d,"eof")) return -KEY_eof;
5491	if (strEQ(d,"exp")) return -KEY_exp;
5492	break;
5493	case 4:
5494	if (strEQ(d,"else")) return KEY_else;
5495	if (strEQ(d,"exit")) return -KEY_exit;
5496	if (strEQ(d,"eval")) return KEY_eval;
5497	if (strEQ(d,"exec")) return -KEY_exec;
5498	if (strEQ(d,"each")) return -KEY_each;
5499	break;
5500	case 5:
5501	if (strEQ(d,"elsif")) return KEY_elsif;
5502	break;
5503	case 6:
5504	if (strEQ(d,"exists")) return KEY_exists;
5505	if (strEQ(d,"elseif")) Perl_warn(aTHX_ "elseif should be elsif");
5506	break;
5507	case 8:
5508	if (strEQ(d,"endgrent")) return -KEY_endgrent;
5509	if (strEQ(d,"endpwent")) return -KEY_endpwent;
5510	break;
5511	case 9:
5512	if (strEQ(d,"endnetent")) return -KEY_endnetent;
5513	break;
5514	case 10:
5515	if (strEQ(d,"endhostent")) return -KEY_endhostent;
5516	if (strEQ(d,"endservent")) return -KEY_endservent;
5517	break;
5518	case 11:
5519	if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
5520	break;
5521	}
5522	break;
5523	case 'f':
5524	switch (len) {
5525	case 3:
5526	if (strEQ(d,"for")) return KEY_for;
5527	break;
5528	case 4:
5529	if (strEQ(d,"fork")) return -KEY_fork;
5530	break;
5531	case 5:
5532	if (strEQ(d,"fcntl")) return -KEY_fcntl;
5533	if (strEQ(d,"flock")) return -KEY_flock;
5534	break;
5535	case 6:
5536	if (strEQ(d,"format")) return KEY_format;
5537	if (strEQ(d,"fileno")) return -KEY_fileno;
5538	break;
5539	case 7:
5540	if (strEQ(d,"foreach")) return KEY_foreach;
5541	break;
5542	case 8:
5543	if (strEQ(d,"formline")) return -KEY_formline;
5544	break;
5545	}
5546	break;
5547	case 'g':
5548	if (strnEQ(d,"get",3)) {
5549	d += 3;
5550	if (*d == 'p') {
5551	switch (len) {
5552	case 7:
5553	if (strEQ(d,"ppid")) return -KEY_getppid;
5554	if (strEQ(d,"pgrp")) return -KEY_getpgrp;
5555	break;
5556	case 8:
5557	if (strEQ(d,"pwent")) return -KEY_getpwent;
5558	if (strEQ(d,"pwnam")) return -KEY_getpwnam;
5559	if (strEQ(d,"pwuid")) return -KEY_getpwuid;
5560	break;
5561	case 11:
5562	if (strEQ(d,"peername")) return -KEY_getpeername;
5563	if (strEQ(d,"protoent")) return -KEY_getprotoent;
5564	if (strEQ(d,"priority")) return -KEY_getpriority;
5565	break;
5566	case 14:
5567	if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
5568	break;
5569	case 16:
5570	if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
5571	break;
5572	}
5573	}
5574	else if (*d == 'h') {
5575	if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
5576	if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
5577	if (strEQ(d,"hostent")) return -KEY_gethostent;
5578	}
5579	else if (*d == 'n') {
5580	if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
5581	if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
5582	if (strEQ(d,"netent")) return -KEY_getnetent;
5583	}
5584	else if (*d == 's') {
5585	if (strEQ(d,"servbyname")) return -KEY_getservbyname;
5586	if (strEQ(d,"servbyport")) return -KEY_getservbyport;
5587	if (strEQ(d,"servent")) return -KEY_getservent;
5588	if (strEQ(d,"sockname")) return -KEY_getsockname;
5589	if (strEQ(d,"sockopt")) return -KEY_getsockopt;
5590	}
5591	else if (*d == 'g') {
5592	if (strEQ(d,"grent")) return -KEY_getgrent;
5593	if (strEQ(d,"grnam")) return -KEY_getgrnam;
5594	if (strEQ(d,"grgid")) return -KEY_getgrgid;
5595	}
5596	else if (*d == 'l') {
5597	if (strEQ(d,"login")) return -KEY_getlogin;
5598	}
5599	else if (strEQ(d,"c")) return -KEY_getc;
5600	break;
5601	}
5602	switch (len) {
5603	case 2:
5604	if (strEQ(d,"gt")) return -KEY_gt;
5605	if (strEQ(d,"ge")) return -KEY_ge;
5606	break;
5607	case 4:
5608	if (strEQ(d,"grep")) return KEY_grep;
5609	if (strEQ(d,"goto")) return KEY_goto;
5610	if (strEQ(d,"glob")) return KEY_glob;
5611	break;
5612	case 6:
5613	if (strEQ(d,"gmtime")) return -KEY_gmtime;
5614	break;
5615	}
5616	break;
5617	case 'h':
5618	if (strEQ(d,"hex")) return -KEY_hex;
5619	break;
5620	case 'I':
5621	if (strEQ(d,"INIT")) return KEY_INIT;
5622	break;
5623	case 'i':
5624	switch (len) {
5625	case 2:
5626	if (strEQ(d,"if")) return KEY_if;
5627	break;
5628	case 3:
5629	if (strEQ(d,"int")) return -KEY_int;
5630	break;
5631	case 5:
5632	if (strEQ(d,"index")) return -KEY_index;
5633	if (strEQ(d,"ioctl")) return -KEY_ioctl;
5634	break;
5635	}
5636	break;
5637	case 'j':
5638	if (strEQ(d,"join")) return -KEY_join;
5639	break;
5640	case 'k':
5641	if (len == 4) {
5642	if (strEQ(d,"keys")) return -KEY_keys;
5643	if (strEQ(d,"kill")) return -KEY_kill;
5644	}
5645	break;
5646	case 'l':
5647	switch (len) {
5648	case 2:
5649	if (strEQ(d,"lt")) return -KEY_lt;
5650	if (strEQ(d,"le")) return -KEY_le;
5651	if (strEQ(d,"lc")) return -KEY_lc;
5652	break;
5653	case 3:
5654	if (strEQ(d,"log")) return -KEY_log;
5655	break;
5656	case 4:
5657	if (strEQ(d,"last")) return KEY_last;
5658	if (strEQ(d,"link")) return -KEY_link;
5659	if (strEQ(d,"lock")) return -KEY_lock;
5660	break;
5661	case 5:
5662	if (strEQ(d,"local")) return KEY_local;
5663	if (strEQ(d,"lstat")) return -KEY_lstat;
5664	break;
5665	case 6:
5666	if (strEQ(d,"length")) return -KEY_length;
5667	if (strEQ(d,"listen")) return -KEY_listen;
5668	break;
5669	case 7:
5670	if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
5671	break;
5672	case 9:
5673	if (strEQ(d,"localtime")) return -KEY_localtime;
5674	break;
5675	}
5676	break;
5677	case 'm':
5678	switch (len) {
5679	case 1: return KEY_m;
5680	case 2:
5681	if (strEQ(d,"my")) return KEY_my;
5682	break;
5683	case 3:
5684	if (strEQ(d,"map")) return KEY_map;
5685	break;
5686	case 5:
5687	if (strEQ(d,"mkdir")) return -KEY_mkdir;
5688	break;
5689	case 6:
5690	if (strEQ(d,"msgctl")) return -KEY_msgctl;
5691	if (strEQ(d,"msgget")) return -KEY_msgget;
5692	if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
5693	if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
5694	break;
5695	}
5696	break;
5697	case 'n':
5698	if (strEQ(d,"next")) return KEY_next;
5699	if (strEQ(d,"ne")) return -KEY_ne;
5700	if (strEQ(d,"not")) return -KEY_not;
5701	if (strEQ(d,"no")) return KEY_no;
5702	break;
5703	case 'o':
5704	switch (len) {
5705	case 2:
5706	if (strEQ(d,"or")) return -KEY_or;
5707	break;
5708	case 3:
5709	if (strEQ(d,"ord")) return -KEY_ord;
5710	if (strEQ(d,"oct")) return -KEY_oct;
5711	if (strEQ(d,"our")) return KEY_our;
5712	break;
5713	case 4:
5714	if (strEQ(d,"open")) return -KEY_open;
5715	break;
5716	case 7:
5717	if (strEQ(d,"opendir")) return -KEY_opendir;
5718	break;
5719	}
5720	break;
5721	case 'p':
5722	switch (len) {
5723	case 3:
5724	if (strEQ(d,"pop")) return -KEY_pop;
5725	if (strEQ(d,"pos")) return KEY_pos;
5726	break;
5727	case 4:
5728	if (strEQ(d,"push")) return -KEY_push;
5729	if (strEQ(d,"pack")) return -KEY_pack;
5730	if (strEQ(d,"pipe")) return -KEY_pipe;
5731	break;
5732	case 5:
5733	if (strEQ(d,"print")) return KEY_print;
5734	break;
5735	case 6:
5736	if (strEQ(d,"printf")) return KEY_printf;
5737	break;
5738	case 7:
5739	if (strEQ(d,"package")) return KEY_package;
5740	break;
5741	case 9:
5742	if (strEQ(d,"prototype")) return KEY_prototype;
5743	}
5744	break;
5745	case 'q':
5746	if (len <= 2) {
5747	if (strEQ(d,"q")) return KEY_q;
5748	if (strEQ(d,"qr")) return KEY_qr;
5749	if (strEQ(d,"qq")) return KEY_qq;
5750	if (strEQ(d,"qw")) return KEY_qw;
5751	if (strEQ(d,"qx")) return KEY_qx;
5752	}
5753	else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
5754	break;
5755	case 'r':
5756	switch (len) {
5757	case 3:
5758	if (strEQ(d,"ref")) return -KEY_ref;
5759	break;
5760	case 4:
5761	if (strEQ(d,"read")) return -KEY_read;
5762	if (strEQ(d,"rand")) return -KEY_rand;
5763	if (strEQ(d,"recv")) return -KEY_recv;
5764	if (strEQ(d,"redo")) return KEY_redo;
5765	break;
5766	case 5:
5767	if (strEQ(d,"rmdir")) return -KEY_rmdir;
5768	if (strEQ(d,"reset")) return -KEY_reset;
5769	break;
5770	case 6:
5771	if (strEQ(d,"return")) return KEY_return;
5772	if (strEQ(d,"rename")) return -KEY_rename;
5773	if (strEQ(d,"rindex")) return -KEY_rindex;
5774	break;
5775	case 7:
5776	if (strEQ(d,"require")) return KEY_require;
5777	if (strEQ(d,"reverse")) return -KEY_reverse;
5778	if (strEQ(d,"readdir")) return -KEY_readdir;
5779	break;
5780	case 8:
5781	if (strEQ(d,"readlink")) return -KEY_readlink;
5782	if (strEQ(d,"readline")) return -KEY_readline;
5783	if (strEQ(d,"readpipe")) return -KEY_readpipe;
5784	break;
5785	case 9:
5786	if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
5787	break;
5788	}
5789	break;
5790	case 's':
5791	switch (d[1]) {
5792	case 0: return KEY_s;
5793	case 'c':
5794	if (strEQ(d,"scalar")) return KEY_scalar;
5795	break;
5796	case 'e':
5797	switch (len) {
5798	case 4:
5799	if (strEQ(d,"seek")) return -KEY_seek;
5800	if (strEQ(d,"send")) return -KEY_send;
5801	break;
5802	case 5:
5803	if (strEQ(d,"semop")) return -KEY_semop;
5804	break;
5805	case 6:
5806	if (strEQ(d,"select")) return -KEY_select;
5807	if (strEQ(d,"semctl")) return -KEY_semctl;
5808	if (strEQ(d,"semget")) return -KEY_semget;
5809	break;
5810	case 7:
5811	if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
5812	if (strEQ(d,"seekdir")) return -KEY_seekdir;
5813	break;
5814	case 8:
5815	if (strEQ(d,"setpwent")) return -KEY_setpwent;
5816	if (strEQ(d,"setgrent")) return -KEY_setgrent;
5817	break;
5818	case 9:
5819	if (strEQ(d,"setnetent")) return -KEY_setnetent;
5820	break;
5821	case 10:
5822	if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
5823	if (strEQ(d,"sethostent")) return -KEY_sethostent;
5824	if (strEQ(d,"setservent")) return -KEY_setservent;
5825	break;
5826	case 11:
5827	if (strEQ(d,"setpriority")) return -KEY_setpriority;
5828	if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
5829	break;
5830	}
5831	break;
5832	case 'h':
5833	switch (len) {
5834	case 5:
5835	if (strEQ(d,"shift")) return -KEY_shift;
5836	break;
5837	case 6:
5838	if (strEQ(d,"shmctl")) return -KEY_shmctl;
5839	if (strEQ(d,"shmget")) return -KEY_shmget;
5840	break;
5841	case 7:
5842	if (strEQ(d,"shmread")) return -KEY_shmread;
5843	break;
5844	case 8:
5845	if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
5846	if (strEQ(d,"shutdown")) return -KEY_shutdown;
5847	break;
5848	}
5849	break;
5850	case 'i':
5851	if (strEQ(d,"sin")) return -KEY_sin;
5852	break;
5853	case 'l':
5854	if (strEQ(d,"sleep")) return -KEY_sleep;
5855	break;
5856	case 'o':
5857	if (strEQ(d,"sort")) return KEY_sort;
5858	if (strEQ(d,"socket")) return -KEY_socket;
5859	if (strEQ(d,"socketpair")) return -KEY_socketpair;
5860	break;
5861	case 'p':
5862	if (strEQ(d,"split")) return KEY_split;
5863	if (strEQ(d,"sprintf")) return -KEY_sprintf;
5864	if (strEQ(d,"splice")) return -KEY_splice;
5865	break;
5866	case 'q':
5867	if (strEQ(d,"sqrt")) return -KEY_sqrt;
5868	break;
5869	case 'r':
5870	if (strEQ(d,"srand")) return -KEY_srand;
5871	break;
5872	case 't':
5873	if (strEQ(d,"stat")) return -KEY_stat;
5874	if (strEQ(d,"study")) return KEY_study;
5875	break;
5876	case 'u':
5877	if (strEQ(d,"substr")) return -KEY_substr;
5878	if (strEQ(d,"sub")) return KEY_sub;
5879	break;
5880	case 'y':
5881	switch (len) {
5882	case 6:
5883	if (strEQ(d,"system")) return -KEY_system;
5884	break;
5885	case 7:
5886	if (strEQ(d,"symlink")) return -KEY_symlink;
5887	if (strEQ(d,"syscall")) return -KEY_syscall;
5888	if (strEQ(d,"sysopen")) return -KEY_sysopen;
5889	if (strEQ(d,"sysread")) return -KEY_sysread;
5890	if (strEQ(d,"sysseek")) return -KEY_sysseek;
5891	break;
5892	case 8:
5893	if (strEQ(d,"syswrite")) return -KEY_syswrite;
5894	break;
5895	}
5896	break;
5897	}
5898	break;
5899	case 't':
5900	switch (len) {
5901	case 2:
5902	if (strEQ(d,"tr")) return KEY_tr;
5903	break;
5904	case 3:
5905	if (strEQ(d,"tie")) return KEY_tie;
5906	break;
5907	case 4:
5908	if (strEQ(d,"tell")) return -KEY_tell;
5909	if (strEQ(d,"tied")) return KEY_tied;
5910	if (strEQ(d,"time")) return -KEY_time;
5911	break;
5912	case 5:
5913	if (strEQ(d,"times")) return -KEY_times;
5914	break;
5915	case 7:
5916	if (strEQ(d,"telldir")) return -KEY_telldir;
5917	break;
5918	case 8:
5919	if (strEQ(d,"truncate")) return -KEY_truncate;
5920	break;
5921	}
5922	break;
5923	case 'u':
5924	switch (len) {
5925	case 2:
5926	if (strEQ(d,"uc")) return -KEY_uc;
5927	break;
5928	case 3:
5929	if (strEQ(d,"use")) return KEY_use;
5930	break;
5931	case 5:
5932	if (strEQ(d,"undef")) return KEY_undef;
5933	if (strEQ(d,"until")) return KEY_until;
5934	if (strEQ(d,"untie")) return KEY_untie;
5935	if (strEQ(d,"utime")) return -KEY_utime;
5936	if (strEQ(d,"umask")) return -KEY_umask;
5937	break;
5938	case 6:
5939	if (strEQ(d,"unless")) return KEY_unless;
5940	if (strEQ(d,"unpack")) return -KEY_unpack;
5941	if (strEQ(d,"unlink")) return -KEY_unlink;
5942	break;
5943	case 7:
5944	if (strEQ(d,"unshift")) return -KEY_unshift;
5945	if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
5946	break;
5947	}
5948	break;
5949	case 'v':
5950	if (strEQ(d,"values")) return -KEY_values;
5951	if (strEQ(d,"vec")) return -KEY_vec;
5952	break;
5953	case 'w':
5954	switch (len) {
5955	case 4:
5956	if (strEQ(d,"warn")) return -KEY_warn;
5957	if (strEQ(d,"wait")) return -KEY_wait;
5958	break;
5959	case 5:
5960	if (strEQ(d,"while")) return KEY_while;
5961	if (strEQ(d,"write")) return -KEY_write;
5962	break;
5963	case 7:
5964	if (strEQ(d,"waitpid")) return -KEY_waitpid;
5965	break;
5966	case 9:
5967	if (strEQ(d,"wantarray")) return -KEY_wantarray;
5968	break;
5969	}
5970	break;
5971	case 'x':
5972	if (len == 1) return -KEY_x;
5973	if (strEQ(d,"xor")) return -KEY_xor;
5974	break;
5975	case 'y':
5976	if (len == 1) return KEY_y;
5977	break;
5978	case 'z':
5979	break;
5980	}
5981	return 0;
5982	}
5983
5984	STATIC void
5985	S_checkcomma(pTHX_ register char s, char name, char *what)
5986	{
5987	char *w;
5988
5989	if (s == ' ' && s[1] == '(') { / XXX gotta be a better way */
5990	if (ckWARN(WARN_SYNTAX)) {
5991	int level = 1;
5992	for (w = s+2; *w && level; w++) {
5993	if (*w == '(')
5994	++level;
5995	else if (*w == ')')
5996	--level;
5997	}
5998	if (*w)
5999	for (; w && isSPACE(w); w++) ;
6000	if (!w \|\| !strchr(";\|})]oaiuw!=", w)) /* an advisory hack only... */
6001	Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6002	"%s (...) interpreted as function",name);
6003	}
6004	}
6005	while (s < PL_bufend && isSPACE(*s))
6006	s++;
6007	if (*s == '(')
6008	s++;
6009	while (s < PL_bufend && isSPACE(*s))
6010	s++;
6011	if (isIDFIRST_lazy_if(s,UTF)) {
6012	w = s++;
6013	while (isALNUM_lazy_if(s,UTF))
6014	s++;
6015	while (s < PL_bufend && isSPACE(*s))
6016	s++;
6017	if (*s == ',') {
6018	int kw;
6019	*s = '\0';
6020	kw = keyword(w, s - w) \|\| get_cv(w, FALSE) != 0;
6021	*s = ',';
6022	if (kw)
6023	return;
6024	Perl_croak(aTHX_ "No comma allowed after %s", what);
6025	}
6026	}
6027	}
6028
6029	/* Either returns sv, or mortalizes sv and returns a new SV*.
6030	Best used as sv=new_constant(..., sv, ...).
6031	If s, pv are NULL, calls subroutine with one argument,
6032	and type is used with error messages only. */
6033
6034	STATIC SV *
6035	S_new_constant(pTHX_ char s, STRLEN len, const char key, SV sv, SV pv,
6036	const char *type)
6037	{
6038	dSP;
6039	HV table = GvHV(PL_hintgv); / ^H */
6040	SV *res;
6041	SV **cvp;
6042	SV cv, typesv;
6043	const char why1, why2, *why3;
6044
6045	if (!table \|\| !(PL_hints & HINT_LOCALIZE_HH)) {
6046	SV *msg;
6047
6048	why2 = strEQ(key,"charnames")
6049	? "(possibly a missing \"use charnames ...\")"
6050	: "";
6051	msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
6052	(type ? type: "undef"), why2);
6053
6054	/* This is convoluted and evil ("goto considered harmful")
6055	* but I do not understand the intricacies of all the different
6056	* failure modes of %^H in here. The goal here is to make
6057	* the most probable error message user-friendly. --jhi */
6058
6059	goto msgdone;
6060
6061	report:
6062	msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
6063	(type ? type: "undef"), why1, why2, why3);
6064	msgdone:
6065	yyerror(SvPVX(msg));
6066	SvREFCNT_dec(msg);
6067	return sv;
6068	}
6069	cvp = hv_fetch(table, key, strlen(key), FALSE);
6070	if (!cvp \|\| !SvOK(*cvp)) {
6071	why1 = "$^H{";
6072	why2 = key;
6073	why3 = "} is not defined";
6074	goto report;
6075	}
6076	sv_2mortal(sv); /* Parent created it permanently */
6077	cv = *cvp;
6078	if (!pv && s)
6079	pv = sv_2mortal(newSVpvn(s, len));
6080	if (type && pv)
6081	typesv = sv_2mortal(newSVpv(type, 0));
6082	else
6083	typesv = &PL_sv_undef;
6084
6085	PUSHSTACKi(PERLSI_OVERLOAD);
6086	ENTER ;
6087	SAVETMPS;
6088
6089	PUSHMARK(SP) ;
6090	EXTEND(sp, 3);
6091	if (pv)
6092	PUSHs(pv);
6093	PUSHs(sv);
6094	if (pv)
6095	PUSHs(typesv);
6096	PUTBACK;
6097	call_sv(cv, G_SCALAR \| ( PL_in_eval ? 0 : G_EVAL));
6098
6099	SPAGAIN ;
6100
6101	/* Check the eval first */
6102	if (!PL_in_eval && SvTRUE(ERRSV)) {
6103	STRLEN n_a;
6104	sv_catpv(ERRSV, "Propagated");
6105	yyerror(SvPV(ERRSV, n_a)); /* Duplicates the message inside eval */
6106	(void)POPs;
6107	res = SvREFCNT_inc(sv);
6108	}
6109	else {
6110	res = POPs;
6111	(void)SvREFCNT_inc(res);
6112	}
6113
6114	PUTBACK ;
6115	FREETMPS ;
6116	LEAVE ;
6117	POPSTACK;
6118
6119	if (!SvOK(res)) {
6120	why1 = "Call to &{$^H{";
6121	why2 = key;
6122	why3 = "}} did not return a defined value";
6123	sv = res;
6124	goto report;
6125	}
6126
6127	return res;
6128	}
6129
6130	STATIC char *
6131	S_scan_word(pTHX_ register char s, char dest, STRLEN destlen, int allow_package, STRLEN *slp)
6132	{
6133	register char *d = dest;
6134	register char e = d + destlen - 3; / two-character token, ending NUL */
6135	for (;;) {
6136	if (d >= e)
6137	Perl_croak(aTHX_ ident_too_long);
6138	if (isALNUM(s)) / UTF handled below */
6139	d++ = s++;
6140	else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) {
6141	*d++ = ':';
6142	*d++ = ':';
6143	s++;
6144	}
6145	else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
6146	d++ = s++;
6147	d++ = s++;
6148	}
6149	else if (UTF && UTF8_IS_START(s) && isALNUM_utf8((U8)s)) {
6150	char *t = s + UTF8SKIP(s);
6151	while (UTF8_IS_CONTINUED(t) && is_utf8_mark((U8)t))
6152	t += UTF8SKIP(t);
6153	if (d + (t - s) > e)
6154	Perl_croak(aTHX_ ident_too_long);
6155	Copy(s, d, t - s, char);
6156	d += t - s;
6157	s = t;
6158	}
6159	else {
6160	*d = '\0';
6161	*slp = d - dest;
6162	return s;
6163	}
6164	}
6165	}
6166
6167	STATIC char *
6168	S_scan_ident(pTHX_ register char s, register char send, char *dest, STRLEN destlen, I32 ck_uni)
6169	{
6170	register char *d;
6171	register char *e;
6172	char *bracket = 0;
6173	char funny = *s++;
6174
6175	if (isSPACE(*s))
6176	s = skipspace(s);
6177	d = dest;
6178	e = d + destlen - 3; /* two-character token, ending NUL */
6179	if (isDIGIT(*s)) {
6180	while (isDIGIT(*s)) {
6181	if (d >= e)
6182	Perl_croak(aTHX_ ident_too_long);
6183	d++ = s++;
6184	}
6185	}
6186	else {
6187	for (;;) {
6188	if (d >= e)
6189	Perl_croak(aTHX_ ident_too_long);
6190	if (isALNUM(s)) / UTF handled below */
6191	d++ = s++;
6192	else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
6193	*d++ = ':';
6194	*d++ = ':';
6195	s++;
6196	}
6197	else if (*s == ':' && s[1] == ':') {
6198	d++ = s++;
6199	d++ = s++;
6200	}
6201	else if (UTF && UTF8_IS_START(s) && isALNUM_utf8((U8)s)) {
6202	char *t = s + UTF8SKIP(s);
6203	while (UTF8_IS_CONTINUED(t) && is_utf8_mark((U8)t))
6204	t += UTF8SKIP(t);
6205	if (d + (t - s) > e)
6206	Perl_croak(aTHX_ ident_too_long);
6207	Copy(s, d, t - s, char);
6208	d += t - s;
6209	s = t;
6210	}
6211	else
6212	break;
6213	}
6214	}
6215	*d = '\0';
6216	d = dest;
6217	if (*d) {
6218	if (PL_lex_state != LEX_NORMAL)
6219	PL_lex_state = LEX_INTERPENDMAYBE;
6220	return s;
6221	}
6222	if (*s == '$' && s[1] &&
6223	(isALNUM_lazy_if(s+1,UTF) \|\| strchr("${", s[1]) \|\| strnEQ(s+1,"::",2)) )
6224	{
6225	return s;
6226	}
6227	if (*s == '{') {
6228	bracket = s;
6229	s++;
6230	}
6231	else if (ck_uni)
6232	check_uni();
6233	if (s < send)
6234	d = s++;
6235	d[1] = '\0';
6236	if (d == '^' && s && isCONTROLVAR(*s)) {
6237	d = toCTRL(s);
6238	s++;
6239	}
6240	if (bracket) {
6241	if (isSPACE(s[-1])) {
6242	while (s < send) {
6243	char ch = *s++;
6244	if (!SPACE_OR_TAB(ch)) {
6245	*d = ch;
6246	break;
6247	}
6248	}
6249	}
6250	if (isIDFIRST_lazy_if(d,UTF)) {
6251	d++;
6252	if (UTF) {
6253	e = s;
6254	while ((e < send && isALNUM_lazy_if(e,UTF)) \|\| *e == ':') {
6255	e += UTF8SKIP(e);
6256	while (e < send && UTF8_IS_CONTINUED(e) && is_utf8_mark((U8)e))
6257	e += UTF8SKIP(e);
6258	}
6259	Copy(s, d, e - s, char);
6260	d += e - s;
6261	s = e;
6262	}
6263	else {
6264	while ((isALNUM(s) \|\| s == ':') && d < e)
6265	d++ = s++;
6266	if (d >= e)
6267	Perl_croak(aTHX_ ident_too_long);
6268	}
6269	*d = '\0';
6270	while (s < send && SPACE_OR_TAB(*s)) s++;
6271	if ((s == '[' \|\| (s == '{' && strNE(dest, "sub")))) {
6272	if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
6273	const char brack = s == '[' ? "[...]" : "{...}";
6274	Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
6275	"Ambiguous use of %c{%s%s} resolved to %c%s%s",
6276	funny, dest, brack, funny, dest, brack);
6277	}
6278	bracket++;
6279	PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR \| XFAKEBRACK);
6280	return s;
6281	}
6282	}
6283	/* Handle extended ${^Foo} variables
6284	* 1999-02-27 mjd-perl-patch@plover.com */
6285	else if (!isALNUM(d) && !isPRINT(d) /* isCTRL(d) */
6286	&& isALNUM(*s))
6287	{
6288	d++;
6289	while (isALNUM(*s) && d < e) {
6290	d++ = s++;
6291	}
6292	if (d >= e)
6293	Perl_croak(aTHX_ ident_too_long);
6294	*d = '\0';
6295	}
6296	if (*s == '}') {
6297	s++;
6298	if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
6299	PL_lex_state = LEX_INTERPEND;
6300	PL_expect = XREF;
6301	}
6302	if (funny == '#')
6303	funny = '@';
6304	if (PL_lex_state == LEX_NORMAL) {
6305	if (ckWARN(WARN_AMBIGUOUS) &&
6306	(keyword(dest, d - dest) \|\| get_cv(dest, FALSE)))
6307	{
6308	Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
6309	"Ambiguous use of %c{%s} resolved to %c%s",
6310	funny, dest, funny, dest);
6311	}
6312	}
6313	}
6314	else {
6315	s = bracket; /* let the parser handle it */
6316	*dest = '\0';
6317	}
6318	}
6319	else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
6320	PL_lex_state = LEX_INTERPEND;
6321	return s;
6322	}
6323
6324	void
6325	Perl_pmflag(pTHX_ U32* pmfl, int ch)
6326	{
6327	if (ch == 'i')
6328	*pmfl \|= PMf_FOLD;
6329	else if (ch == 'g')
6330	*pmfl \|= PMf_GLOBAL;
6331	else if (ch == 'c')
6332	*pmfl \|= PMf_CONTINUE;
6333	else if (ch == 'o')
6334	*pmfl \|= PMf_KEEP;
6335	else if (ch == 'm')
6336	*pmfl \|= PMf_MULTILINE;
6337	else if (ch == 's')
6338	*pmfl \|= PMf_SINGLELINE;
6339	else if (ch == 'x')
6340	*pmfl \|= PMf_EXTENDED;
6341	}
6342
6343	STATIC char *
6344	S_scan_pat(pTHX_ char *start, I32 type)
6345	{
6346	PMOP *pm;
6347	char *s;
6348
6349	s = scan_str(start,FALSE,FALSE);
6350	if (!s)
6351	Perl_croak(aTHX_ "Search pattern not terminated");
6352
6353	pm = (PMOP*)newPMOP(type, 0);
6354	if (PL_multi_open == '?')
6355	pm->op_pmflags \|= PMf_ONCE;
6356	if(type == OP_QR) {
6357	while (s && strchr("iomsx", s))
6358	pmflag(&pm->op_pmflags,*s++);
6359	}
6360	else {
6361	while (s && strchr("iogcmsx", s))
6362	pmflag(&pm->op_pmflags,*s++);
6363	}
6364	/* issue a warning if /c is specified,but /g is not */
6365	if (ckWARN(WARN_REGEXP) &&
6366	(pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL))
6367	{
6368	Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_without_g);
6369	}
6370
6371	pm->op_pmpermflags = pm->op_pmflags;
6372
6373	PL_lex_op = (OP*)pm;
6374	yylval.ival = OP_MATCH;
6375	return s;
6376	}
6377
6378	STATIC char *
6379	S_scan_subst(pTHX_ char *start)
6380	{
6381	register char *s;
6382	register PMOP *pm;
6383	I32 first_start;
6384	I32 es = 0;
6385
6386	yylval.ival = OP_NULL;
6387
6388	s = scan_str(start,FALSE,FALSE);
6389
6390	if (!s)
6391	Perl_croak(aTHX_ "Substitution pattern not terminated");
6392
6393	if (s[-1] == PL_multi_open)
6394	s--;
6395
6396	first_start = PL_multi_start;
6397	s = scan_str(s,FALSE,FALSE);
6398	if (!s) {
6399	if (PL_lex_stuff) {
6400	SvREFCNT_dec(PL_lex_stuff);
6401	PL_lex_stuff = Nullsv;
6402	}
6403	Perl_croak(aTHX_ "Substitution replacement not terminated");
6404	}
6405	PL_multi_start = first_start; /* so whole substitution is taken together */
6406
6407	pm = (PMOP*)newPMOP(OP_SUBST, 0);
6408	while (*s) {
6409	if (*s == 'e') {
6410	s++;
6411	es++;
6412	}
6413	else if (strchr("iogcmsx", *s))
6414	pmflag(&pm->op_pmflags,*s++);
6415	else
6416	break;
6417	}
6418
6419	/* /c is not meaningful with s/// */
6420	if (ckWARN(WARN_REGEXP) && (pm->op_pmflags & PMf_CONTINUE))
6421	{
6422	Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_in_subst);
6423	}
6424
6425	if (es) {
6426	SV *repl;
6427	PL_sublex_info.super_bufptr = s;
6428	PL_sublex_info.super_bufend = PL_bufend;
6429	PL_multi_end = 0;
6430	pm->op_pmflags \|= PMf_EVAL;
6431	repl = newSVpvn("",0);
6432	while (es-- > 0)
6433	sv_catpv(repl, es ? "eval " : "do ");
6434	sv_catpvn(repl, "{ ", 2);
6435	sv_catsv(repl, PL_lex_repl);
6436	sv_catpvn(repl, " };", 2);
6437	SvEVALED_on(repl);
6438	SvREFCNT_dec(PL_lex_repl);
6439	PL_lex_repl = repl;
6440	}
6441
6442	pm->op_pmpermflags = pm->op_pmflags;
6443	PL_lex_op = (OP*)pm;
6444	yylval.ival = OP_SUBST;
6445	return s;
6446	}
6447
6448	STATIC char *
6449	S_scan_trans(pTHX_ char *start)
6450	{
6451	register char* s;
6452	OP *o;
6453	short *tbl;
6454	I32 squash;
6455	I32 del;
6456	I32 complement;
6457
6458	yylval.ival = OP_NULL;
6459
6460	s = scan_str(start,FALSE,FALSE);
6461	if (!s)
6462	Perl_croak(aTHX_ "Transliteration pattern not terminated");
6463	if (s[-1] == PL_multi_open)
6464	s--;
6465
6466	s = scan_str(s,FALSE,FALSE);
6467	if (!s) {
6468	if (PL_lex_stuff) {
6469	SvREFCNT_dec(PL_lex_stuff);
6470	PL_lex_stuff = Nullsv;
6471	}
6472	Perl_croak(aTHX_ "Transliteration replacement not terminated");
6473	}
6474
6475	complement = del = squash = 0;
6476	while (strchr("cds", *s)) {
6477	if (*s == 'c')
6478	complement = OPpTRANS_COMPLEMENT;
6479	else if (*s == 'd')
6480	del = OPpTRANS_DELETE;
6481	else if (*s == 's')
6482	squash = OPpTRANS_SQUASH;
6483	s++;
6484	}
6485
6486	New(803, tbl, complement&&!del?258:256, short);
6487	o = newPVOP(OP_TRANS, 0, (char*)tbl);
6488	o->op_private = del\|squash\|complement\|
6489	(DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)\|
6490	(DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0);
6491
6492	PL_lex_op = o;
6493	yylval.ival = OP_TRANS;
6494	return s;
6495	}
6496
6497	STATIC char *
6498	S_scan_heredoc(pTHX_ register char *s)
6499	{
6500	SV *herewas;
6501	I32 op_type = OP_SCALAR;
6502	I32 len;
6503	SV *tmpstr;
6504	char term;
6505	register char *d;
6506	register char *e;
6507	char *peek;
6508	int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
6509
6510	s += 2;
6511	d = PL_tokenbuf;
6512	e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
6513	if (!outer)
6514	*d++ = '\n';
6515	for (peek = s; SPACE_OR_TAB(*peek); peek++) ;
6516	if (peek && strchr("`'\"",peek)) {
6517	s = peek;
6518	term = *s++;
6519	s = delimcpy(d, e, s, PL_bufend, term, &len);
6520	d += len;
6521	if (s < PL_bufend)
6522	s++;
6523	}
6524	else {
6525	if (*s == '\\')
6526	s++, term = '\'';
6527	else
6528	term = '"';
6529	if (!isALNUM_lazy_if(s,UTF))
6530	deprecate_old("bare << to mean <<\"\"");
6531	for (; isALNUM_lazy_if(s,UTF); s++) {
6532	if (d < e)
6533	d++ = s;
6534	}
6535	}
6536	if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
6537	Perl_croak(aTHX_ "Delimiter for here document is too long");
6538	*d++ = '\n';
6539	*d = '\0';
6540	len = d - PL_tokenbuf;
6541	#ifndef PERL_STRICT_CR
6542	d = strchr(s, '\r');
6543	if (d) {
6544	char *olds = s;
6545	s = d;
6546	while (s < PL_bufend) {
6547	if (*s == '\r') {
6548	*d++ = '\n';
6549	if (*++s == '\n')
6550	s++;
6551	}
6552	else if (s == '\n' && s[1] == '\r') { / \015\013 on a mac? */
6553	d++ = s++;
6554	s++;
6555	}
6556	else
6557	d++ = s++;
6558	}
6559	*d = '\0';
6560	PL_bufend = d;
6561	SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6562	s = olds;
6563	}
6564	#endif
6565	d = "\n";
6566	if (outer \|\| !(d=ninstr(s,PL_bufend,d,d+1)))
6567	herewas = newSVpvn(s,PL_bufend-s);
6568	else
6569	s--, herewas = newSVpvn(s,d-s);
6570	s += SvCUR(herewas);
6571
6572	tmpstr = NEWSV(87,79);
6573	sv_upgrade(tmpstr, SVt_PVIV);
6574	if (term == '\'') {
6575	op_type = OP_CONST;
6576	SvIVX(tmpstr) = -1;
6577	}
6578	else if (term == '`') {
6579	op_type = OP_BACKTICK;
6580	SvIVX(tmpstr) = '\\';
6581	}
6582
6583	CLINE;
6584	PL_multi_start = CopLINE(PL_curcop);
6585	PL_multi_open = PL_multi_close = '<';
6586	term = *PL_tokenbuf;
6587	if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
6588	char *bufptr = PL_sublex_info.super_bufptr;
6589	char *bufend = PL_sublex_info.super_bufend;
6590	char *olds = s - SvCUR(herewas);
6591	s = strchr(bufptr, '\n');
6592	if (!s)
6593	s = bufend;
6594	d = s;
6595	while (s < bufend &&
6596	(*s != term \|\| memNE(s,PL_tokenbuf,len)) ) {
6597	if (*s++ == '\n')
6598	CopLINE_inc(PL_curcop);
6599	}
6600	if (s >= bufend) {
6601	CopLINE_set(PL_curcop, (line_t)PL_multi_start);
6602	missingterm(PL_tokenbuf);
6603	}
6604	sv_setpvn(herewas,bufptr,d-bufptr+1);
6605	sv_setpvn(tmpstr,d+1,s-d);
6606	s += len - 1;
6607	sv_catpvn(herewas,s,bufend-s);
6608	(void)strcpy(bufptr,SvPVX(herewas));
6609
6610	s = olds;
6611	goto retval;
6612	}
6613	else if (!outer) {
6614	d = s;
6615	while (s < PL_bufend &&
6616	(*s != term \|\| memNE(s,PL_tokenbuf,len)) ) {
6617	if (*s++ == '\n')
6618	CopLINE_inc(PL_curcop);
6619	}
6620	if (s >= PL_bufend) {
6621	CopLINE_set(PL_curcop, (line_t)PL_multi_start);
6622	missingterm(PL_tokenbuf);
6623	}
6624	sv_setpvn(tmpstr,d+1,s-d);
6625	s += len - 1;
6626	CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
6627
6628	sv_catpvn(herewas,s,PL_bufend-s);
6629	sv_setsv(PL_linestr,herewas);
6630	PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
6631	PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6632	PL_last_lop = PL_last_uni = Nullch;
6633	}
6634	else
6635	sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
6636	while (s >= PL_bufend) { /* multiple line string? */
6637	if (!outer \|\|
6638	!(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6639	CopLINE_set(PL_curcop, (line_t)PL_multi_start);
6640	missingterm(PL_tokenbuf);
6641	}
6642	CopLINE_inc(PL_curcop);
6643	PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6644	PL_last_lop = PL_last_uni = Nullch;
6645	#ifndef PERL_STRICT_CR
6646	if (PL_bufend - PL_linestart >= 2) {
6647	if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') \|\|
6648	(PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
6649	{
6650	PL_bufend[-2] = '\n';
6651	PL_bufend--;
6652	SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6653	}
6654	else if (PL_bufend[-1] == '\r')
6655	PL_bufend[-1] = '\n';
6656	}
6657	else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
6658	PL_bufend[-1] = '\n';
6659	#endif
6660	if (PERLDB_LINE && PL_curstash != PL_debstash) {
6661	SV *sv = NEWSV(88,0);
6662
6663	sv_upgrade(sv, SVt_PVMG);
6664	sv_setsv(sv,PL_linestr);
6665	(void)SvIOK_on(sv);
6666	SvIVX(sv) = 0;
6667	av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop),sv);
6668	}
6669	if (*s == term && memEQ(s,PL_tokenbuf,len)) {
6670	s = PL_bufend - 1;
6671	*s = ' ';
6672	sv_catsv(PL_linestr,herewas);
6673	PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6674	}
6675	else {
6676	s = PL_bufend;
6677	sv_catsv(tmpstr,PL_linestr);
6678	}
6679	}
6680	s++;
6681	retval:
6682	PL_multi_end = CopLINE(PL_curcop);
6683	if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
6684	SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
6685	Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
6686	}
6687	SvREFCNT_dec(herewas);
6688	if (!IN_BYTES) {
6689	if (UTF && is_utf8_string((U8*)SvPVX(tmpstr), SvCUR(tmpstr)))
6690	SvUTF8_on(tmpstr);
6691	else if (PL_encoding)
6692	sv_recode_to_utf8(tmpstr, PL_encoding);
6693	}
6694	PL_lex_stuff = tmpstr;
6695	yylval.ival = op_type;
6696	return s;
6697	}
6698
6699	/* scan_inputsymbol
6700	takes: current position in input buffer
6701	returns: new position in input buffer
6702	side-effects: yylval and lex_op are set.
6703
6704	This code handles:
6705
6706	<> read from ARGV
6707	<FH> read from filehandle
6708	<pkg::FH> read from package qualified filehandle
6709	<pkg'FH> read from package qualified filehandle
6710	<$fh> read from filehandle in $fh
6711	<*.h> filename glob
6712
6713	*/
6714
6715	STATIC char *
6716	S_scan_inputsymbol(pTHX_ char *start)
6717	{
6718	register char s = start; / current position in buffer */
6719	register char *d;
6720	register char *e;
6721	char *end;
6722	I32 len;
6723
6724	d = PL_tokenbuf; /* start of temp holding space */
6725	e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
6726	end = strchr(s, '\n');
6727	if (!end)
6728	end = PL_bufend;
6729	s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
6730
6731	/* die if we didn't have space for the contents of the <>,
6732	or if it didn't end, or if we see a newline
6733	*/
6734
6735	if (len >= sizeof PL_tokenbuf)
6736	Perl_croak(aTHX_ "Excessively long <> operator");
6737	if (s >= end)
6738	Perl_croak(aTHX_ "Unterminated <> operator");
6739
6740	s++;
6741
6742	/* check for <$fh>
6743	Remember, only scalar variables are interpreted as filehandles by
6744	this code. Anything more complex (e.g., <$fh{$num}>) will be
6745	treated as a glob() call.
6746	This code makes use of the fact that except for the $ at the front,
6747	a scalar variable and a filehandle look the same.
6748	*/
6749	if (*d == '$' && d[1]) d++;
6750
6751	/* allow <Pkg'VALUE> or <Pkg::VALUE> */
6752	while (d && (isALNUM_lazy_if(d,UTF) \|\| d == '\'' \|\| *d == ':'))
6753	d++;
6754
6755	/* If we've tried to read what we allow filehandles to look like, and
6756	there's still text left, then it must be a glob() and not a getline.
6757	Use scan_str to pull out the stuff between the <> and treat it
6758	as nothing more than a string.
6759	*/
6760
6761	if (d - PL_tokenbuf != len) {
6762	yylval.ival = OP_GLOB;
6763	set_csh();
6764	s = scan_str(start,FALSE,FALSE);
6765	if (!s)
6766	Perl_croak(aTHX_ "Glob not terminated");
6767	return s;
6768	}
6769	else {
6770	bool readline_overriden = FALSE;
6771	GV *gv_readline = Nullgv;
6772	GV **gvp;
6773	/* we're in a filehandle read situation */
6774	d = PL_tokenbuf;
6775
6776	/* turn <> into <ARGV> */
6777	if (!len)
6778	(void)strcpy(d,"ARGV");
6779
6780	/* Check whether readline() is overriden */
6781	if (((gv_readline = gv_fetchpv("readline", FALSE, SVt_PVCV))
6782	&& GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
6783	\|\|
6784	((gvp = (GV**)hv_fetch(PL_globalstash, "readline", 8, FALSE))
6785	&& (gv_readline = gvp) != (GV)&PL_sv_undef
6786	&& GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
6787	readline_overriden = TRUE;
6788
6789	/* if <$fh>, create the ops to turn the variable into a
6790	filehandle
6791	*/
6792	if (*d == '$') {
6793	I32 tmp;
6794
6795	/* try to find it in the pad for this block, otherwise find
6796	add symbol table ops
6797	*/
6798	if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
6799	if (PAD_COMPNAME_FLAGS(tmp) & SVpad_OUR) {
6800	SV *sym = sv_2mortal(
6801	newSVpv(HvNAME(PAD_COMPNAME_OURSTASH(tmp)),0));
6802	sv_catpvn(sym, "::", 2);
6803	sv_catpv(sym, d+1);
6804	d = SvPVX(sym);
6805	goto intro_sym;
6806	}
6807	else {
6808	OP *o = newOP(OP_PADSV, 0);
6809	o->op_targ = tmp;
6810	PL_lex_op = readline_overriden
6811	? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
6812	append_elem(OP_LIST, o,
6813	newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
6814	: (OP*)newUNOP(OP_READLINE, 0, o);
6815	}
6816	}
6817	else {
6818	GV *gv;
6819	++d;
6820	intro_sym:
6821	gv = gv_fetchpv(d,
6822	(PL_in_eval
6823	? (GV_ADDMULTI \| GV_ADDINEVAL)
6824	: GV_ADDMULTI),
6825	SVt_PV);
6826	PL_lex_op = readline_overriden
6827	? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
6828	append_elem(OP_LIST,
6829	newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
6830	newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
6831	: (OP*)newUNOP(OP_READLINE, 0,
6832	newUNOP(OP_RV2SV, 0,
6833	newGVOP(OP_GV, 0, gv)));
6834	}
6835	if (!readline_overriden)
6836	PL_lex_op->op_flags \|= OPf_SPECIAL;
6837	/* we created the ops in PL_lex_op, so make yylval.ival a null op */
6838	yylval.ival = OP_NULL;
6839	}
6840
6841	/* If it's none of the above, it must be a literal filehandle
6842	(<Foo::BAR> or <FOO>) so build a simple readline OP */
6843	else {
6844	GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
6845	PL_lex_op = readline_overriden
6846	? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
6847	append_elem(OP_LIST,
6848	newGVOP(OP_GV, 0, gv),
6849	newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
6850	: (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
6851	yylval.ival = OP_NULL;
6852	}
6853	}
6854
6855	return s;
6856	}
6857
6858
6859	/* scan_str
6860	takes: start position in buffer
6861	keep_quoted preserve \ on the embedded delimiter(s)
6862	keep_delims preserve the delimiters around the string
6863	returns: position to continue reading from buffer
6864	side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
6865	updates the read buffer.
6866
6867	This subroutine pulls a string out of the input. It is called for:
6868	q single quotes q(literal text)
6869	' single quotes 'literal text'
6870	qq double quotes qq(interpolate $here please)
6871	" double quotes "interpolate $here please"
6872	qx backticks qx(/bin/ls -l)
6873	` backticks `/bin/ls -l`
6874	qw quote words @EXPORT_OK = qw( func() $spam )
6875	m// regexp match m/this/
6876	s/// regexp substitute s/this/that/
6877	tr/// string transliterate tr/this/that/
6878	y/// string transliterate y/this/that/
6879	($*@) sub prototypes sub foo ($)
6880	(stuff) sub attr parameters sub foo : attr(stuff)
6881	<> readline or globs <FOO>, <>, <$fh>, or <*.c>
6882
6883	In most of these cases (all but <>, patterns and transliterate)
6884	yylex() calls scan_str(). m// makes yylex() call scan_pat() which
6885	calls scan_str(). s/// makes yylex() call scan_subst() which calls
6886	scan_str(). tr/// and y/// make yylex() call scan_trans() which
6887	calls scan_str().
6888
6889	It skips whitespace before the string starts, and treats the first
6890	character as the delimiter. If the delimiter is one of ([{< then
6891	the corresponding "close" character )]}> is used as the closing
6892	delimiter. It allows quoting of delimiters, and if the string has
6893	balanced delimiters ([{<>}]) it allows nesting.
6894
6895	On success, the SV with the resulting string is put into lex_stuff or,
6896	if that is already non-NULL, into lex_repl. The second case occurs only
6897	when parsing the RHS of the special constructs s/// and tr/// (y///).
6898	For convenience, the terminating delimiter character is stuffed into
6899	SvIVX of the SV.
6900	*/
6901
6902	STATIC char *
6903	S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
6904	{
6905	SV sv; / scalar value: string */
6906	char tmps; / temp string, used for delimiter matching */
6907	register char s = start; / current position in the buffer */
6908	register char term; /* terminating character */
6909	register char to; / current position in the sv's data */
6910	I32 brackets = 1; /* bracket nesting level */
6911	bool has_utf8 = FALSE; /* is there any utf8 content? */
6912	I32 termcode; /* terminating char. code */
6913	U8 termstr[UTF8_MAXLEN]; /* terminating string */
6914	STRLEN termlen; /* length of terminating string */
6915	char last = NULL; / last position for nesting bracket */
6916
6917	/* skip space before the delimiter */
6918	if (isSPACE(*s))
6919	s = skipspace(s);
6920
6921	/* mark where we are, in case we need to report errors */
6922	CLINE;
6923
6924	/* after skipping whitespace, the next character is the terminator */
6925	term = *s;
6926	if (!UTF) {
6927	termcode = termstr[0] = term;
6928	termlen = 1;
6929	}
6930	else {
6931	termcode = utf8_to_uvchr((U8*)s, &termlen);
6932	Copy(s, termstr, termlen, U8);
6933	if (!UTF8_IS_INVARIANT(term))
6934	has_utf8 = TRUE;
6935	}
6936
6937	/* mark where we are */
6938	PL_multi_start = CopLINE(PL_curcop);
6939	PL_multi_open = term;
6940
6941	/* find corresponding closing delimiter */
6942	if (term && (tmps = strchr("([{< )]}> )]}>",term)))
6943	termcode = termstr[0] = term = tmps[5];
6944
6945	PL_multi_close = term;
6946
6947	/* create a new SV to hold the contents. 87 is leak category, I'm
6948	assuming. 79 is the SV's initial length. What a random number. */
6949	sv = NEWSV(87,79);
6950	sv_upgrade(sv, SVt_PVIV);
6951	SvIVX(sv) = termcode;
6952	(void)SvPOK_only(sv); /* validate pointer */
6953
6954	/* move past delimiter and try to read a complete string */
6955	if (keep_delims)
6956	sv_catpvn(sv, s, termlen);
6957	s += termlen;
6958	for (;;) {
6959	if (PL_encoding && !UTF) {
6960	bool cont = TRUE;
6961
6962	while (cont) {
6963	int offset = s - SvPVX(PL_linestr);
6964	bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
6965	&offset, (char*)termstr, termlen);
6966	char *ns = SvPVX(PL_linestr) + offset;
6967	char *svlast = SvEND(sv) - 1;
6968
6969	for (; s < ns; s++) {
6970	if (*s == '\n' && !PL_rsfp)
6971	CopLINE_inc(PL_curcop);
6972	}
6973	if (!found)
6974	goto read_more_line;
6975	else {
6976	/* handle quoted delimiters */
6977	if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
6978	char *t;
6979	for (t = svlast-2; t >= SvPVX(sv) && *t == '\\';)
6980	t--;
6981	if ((svlast-1 - t) % 2) {
6982	if (!keep_quoted) {
6983	*(svlast-1) = term;
6984	*svlast = '\0';
6985	SvCUR_set(sv, SvCUR(sv) - 1);
6986	}
6987	continue;
6988	}
6989	}
6990	if (PL_multi_open == PL_multi_close) {
6991	cont = FALSE;
6992	}
6993	else {
6994	char t, w;
6995	if (!last)
6996	last = SvPVX(sv);
6997	for (w = t = last; t < svlast; w++, t++) {
6998	/* At here, all closes are "was quoted" one,
6999	so we don't check PL_multi_close. */
7000	if (*t == '\\') {
7001	if (!keep_quoted && *(t+1) == PL_multi_open)
7002	t++;
7003	else
7004	w++ = t++;
7005	}
7006	else if (*t == PL_multi_open)
7007	brackets++;
7008
7009	w = t;
7010	}
7011	if (w < t) {
7012	*w++ = term;
7013	*w = '\0';
7014	SvCUR_set(sv, w - SvPVX(sv));
7015	}
7016	last = w;
7017	if (--brackets <= 0)
7018	cont = FALSE;
7019	}
7020	}
7021	}
7022	if (!keep_delims) {
7023	SvCUR_set(sv, SvCUR(sv) - 1);
7024	*SvEND(sv) = '\0';
7025	}
7026	break;
7027	}
7028
7029	/* extend sv if need be */
7030	SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
7031	/* set 'to' to the next character in the sv's string */
7032	to = SvPVX(sv)+SvCUR(sv);
7033
7034	/* if open delimiter is the close delimiter read unbridle */
7035	if (PL_multi_open == PL_multi_close) {
7036	for (; s < PL_bufend; s++,to++) {
7037	/* embedded newlines increment the current line number */
7038	if (*s == '\n' && !PL_rsfp)
7039	CopLINE_inc(PL_curcop);
7040	/* handle quoted delimiters */
7041	if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
7042	if (!keep_quoted && s[1] == term)
7043	s++;
7044	/* any other quotes are simply copied straight through */
7045	else
7046	to++ = s++;
7047	}
7048	/* terminate when run out of buffer (the for() condition), or
7049	have found the terminator */
7050	else if (*s == term) {
7051	if (termlen == 1)
7052	break;
7053	if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
7054	break;
7055	}
7056	else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
7057	has_utf8 = TRUE;
7058	to = s;
7059	}
7060	}
7061
7062	/* if the terminator isn't the same as the start character (e.g.,
7063	matched brackets), we have to allow more in the quoting, and
7064	be prepared for nested brackets.
7065	*/
7066	else {
7067	/* read until we run out of string, or we find the terminator */
7068	for (; s < PL_bufend; s++,to++) {
7069	/* embedded newlines increment the line count */
7070	if (*s == '\n' && !PL_rsfp)
7071	CopLINE_inc(PL_curcop);
7072	/* backslashes can escape the open or closing characters */
7073	if (*s == '\\' && s+1 < PL_bufend) {
7074	if (!keep_quoted &&
7075	((s[1] == PL_multi_open) \|\| (s[1] == PL_multi_close)))
7076	s++;
7077	else
7078	to++ = s++;
7079	}
7080	/* allow nested opens and closes */
7081	else if (*s == PL_multi_close && --brackets <= 0)
7082	break;
7083	else if (*s == PL_multi_open)
7084	brackets++;
7085	else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
7086	has_utf8 = TRUE;
7087	to = s;
7088	}
7089	}
7090	/* terminate the copied string and update the sv's end-of-string */
7091	*to = '\0';
7092	SvCUR_set(sv, to - SvPVX(sv));
7093
7094	/*
7095	* this next chunk reads more into the buffer if we're not done yet
7096	*/
7097
7098	if (s < PL_bufend)
7099	break; /* handle case where we are done yet :-) */
7100
7101	#ifndef PERL_STRICT_CR
7102	if (to - SvPVX(sv) >= 2) {
7103	if ((to[-2] == '\r' && to[-1] == '\n') \|\|
7104	(to[-2] == '\n' && to[-1] == '\r'))
7105	{
7106	to[-2] = '\n';
7107	to--;
7108	SvCUR_set(sv, to - SvPVX(sv));
7109	}
7110	else if (to[-1] == '\r')
7111	to[-1] = '\n';
7112	}
7113	else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
7114	to[-1] = '\n';
7115	#endif
7116
7117	read_more_line:
7118	/* if we're out of file, or a read fails, bail and reset the current
7119	line marker so we can report where the unterminated string began
7120	*/
7121	if (!PL_rsfp \|\|
7122	!(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
7123	sv_free(sv);
7124	CopLINE_set(PL_curcop, (line_t)PL_multi_start);
7125	return Nullch;
7126	}
7127	/* we read a line, so increment our line counter */
7128	CopLINE_inc(PL_curcop);
7129
7130	/* update debugger info */
7131	if (PERLDB_LINE && PL_curstash != PL_debstash) {
7132	SV *sv = NEWSV(88,0);
7133
7134	sv_upgrade(sv, SVt_PVMG);
7135	sv_setsv(sv,PL_linestr);
7136	(void)SvIOK_on(sv);
7137	SvIVX(sv) = 0;
7138	av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop), sv);
7139	}
7140
7141	/* having changed the buffer, we must update PL_bufend */
7142	PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7143	PL_last_lop = PL_last_uni = Nullch;
7144	}
7145
7146	/* at this point, we have successfully read the delimited string */
7147
7148	if (!PL_encoding \|\| UTF) {
7149	if (keep_delims)
7150	sv_catpvn(sv, s, termlen);
7151	s += termlen;
7152	}
7153	if (has_utf8 \|\| PL_encoding)
7154	SvUTF8_on(sv);
7155
7156	PL_multi_end = CopLINE(PL_curcop);
7157
7158	/* if we allocated too much space, give some back */
7159	if (SvCUR(sv) + 5 < SvLEN(sv)) {
7160	SvLEN_set(sv, SvCUR(sv) + 1);
7161	Renew(SvPVX(sv), SvLEN(sv), char);
7162	}
7163
7164	/* decide whether this is the first or second quoted string we've read
7165	for this op
7166	*/
7167
7168	if (PL_lex_stuff)
7169	PL_lex_repl = sv;
7170	else
7171	PL_lex_stuff = sv;
7172	return s;
7173	}
7174
7175	/*
7176	scan_num
7177	takes: pointer to position in buffer
7178	returns: pointer to new position in buffer
7179	side-effects: builds ops for the constant in yylval.op
7180
7181	Read a number in any of the formats that Perl accepts:
7182
7183	\d(_?\d)(\.(\d(_?\d))?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
7184	\.\d(_?\d)[Ee][\+\-]?(\d(_?\d)) .34
7185	0b[01](_?[01])*
7186	0[0-7](_?[0-7])*
7187	0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
7188
7189	Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
7190	thing it reads.
7191
7192	If it reads a number without a decimal point or an exponent, it will
7193	try converting the number to an integer and see if it can do so
7194	without loss of precision.
7195	*/
7196
7197	char *
7198	Perl_scan_num(pTHX_ char start, YYSTYPE lvalp)
7199	{
7200	register char s = start; / current position in buffer */
7201	register char d; / destination in temp buffer */
7202	register char e; / end of temp buffer */
7203	NV nv; /* number read, as a double */
7204	SV sv = Nullsv; / place to put the converted number */
7205	bool floatit; /* boolean: int or float? */
7206	char lastub = 0; / position of last underbar */
7207	static char number_too_long[] = "Number too long";
7208
7209	/* We use the first character to decide what type of number this is */
7210
7211	switch (*s) {
7212	default:
7213	Perl_croak(aTHX_ "panic: scan_num");
7214
7215	/* if it starts with a 0, it could be an octal number, a decimal in
7216	0.13 disguise, or a hexadecimal number, or a binary number. */
7217	case '0':
7218	{
7219	/* variables:
7220	u holds the "number so far"
7221	shift the power of 2 of the base
7222	(hex == 4, octal == 3, binary == 1)
7223	overflowed was the number more than we can hold?
7224
7225	Shift is used when we add a digit. It also serves as an "are
7226	we in octal/hex/binary?" indicator to disallow hex characters
7227	when in octal mode.
7228	*/
7229	NV n = 0.0;
7230	UV u = 0;
7231	I32 shift;
7232	bool overflowed = FALSE;
7233	static NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
7234	static char* bases[5] = { "", "binary", "", "octal",
7235	"hexadecimal" };
7236	static char* Bases[5] = { "", "Binary", "", "Octal",
7237	"Hexadecimal" };
7238	static char *maxima[5] = { "",
7239	"0b11111111111111111111111111111111",
7240	"",
7241	"037777777777",
7242	"0xffffffff" };
7243	char base, Base, *max;
7244
7245	/* check for hex */
7246	if (s[1] == 'x') {
7247	shift = 4;
7248	s += 2;
7249	} else if (s[1] == 'b') {
7250	shift = 1;
7251	s += 2;
7252	}
7253	/* check for a decimal in disguise */
7254	else if (s[1] == '.' \|\| s[1] == 'e' \|\| s[1] == 'E')
7255	goto decimal;
7256	/* so it must be octal */
7257	else {
7258	shift = 3;
7259	s++;
7260	}
7261
7262	if (*s == '_') {
7263	if (ckWARN(WARN_SYNTAX))
7264	Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7265	"Misplaced _ in number");
7266	lastub = s++;
7267	}
7268
7269	base = bases[shift];
7270	Base = Bases[shift];
7271	max = maxima[shift];
7272
7273	/* read the rest of the number */
7274	for (;;) {
7275	/* x is used in the overflow test,
7276	b is the digit we're adding on. */
7277	UV x, b;
7278
7279	switch (*s) {
7280
7281	/* if we don't mention it, we're done */
7282	default:
7283	goto out;
7284
7285	/* _ are ignored -- but warned about if consecutive */
7286	case '_':
7287	if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
7288	Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7289	"Misplaced _ in number");
7290	lastub = s++;
7291	break;
7292
7293	/* 8 and 9 are not octal */
7294	case '8': case '9':
7295	if (shift == 3)
7296	yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
7297	/* FALL THROUGH */
7298
7299	/* octal digits */
7300	case '2': case '3': case '4':
7301	case '5': case '6': case '7':
7302	if (shift == 1)
7303	yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
7304	/* FALL THROUGH */
7305
7306	case '0': case '1':
7307	b = s++ & 15; / ASCII digit -> value of digit */
7308	goto digit;
7309
7310	/* hex digits */
7311	case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
7312	case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
7313	/* make sure they said 0x */
7314	if (shift != 4)
7315	goto out;
7316	b = (*s++ & 7) + 9;
7317
7318	/* Prepare to put the digit we have onto the end
7319	of the number so far. We check for overflows.
7320	*/
7321
7322	digit:
7323	if (!overflowed) {
7324	x = u << shift; /* make room for the digit */
7325
7326	if ((x >> shift) != u
7327	&& !(PL_hints & HINT_NEW_BINARY)) {
7328	overflowed = TRUE;
7329	n = (NV) u;
7330	if (ckWARN_d(WARN_OVERFLOW))
7331	Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
7332	"Integer overflow in %s number",
7333	base);
7334	} else
7335	u = x \| b; /* add the digit to the end */
7336	}
7337	if (overflowed) {
7338	n *= nvshift[shift];
7339	/* If an NV has not enough bits in its
7340	* mantissa to represent an UV this summing of
7341	* small low-order numbers is a waste of time
7342	* (because the NV cannot preserve the
7343	* low-order bits anyway): we could just
7344	* remember when did we overflow and in the
7345	* end just multiply n by the right
7346	* amount. */
7347	n += (NV) b;
7348	}
7349	break;
7350	}
7351	}
7352
7353	/* if we get here, we had success: make a scalar value from
7354	the number.
7355	*/
7356	out:
7357
7358	/* final misplaced underbar check */
7359	if (s[-1] == '_') {
7360	if (ckWARN(WARN_SYNTAX))
7361	Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
7362	}
7363
7364	sv = NEWSV(92,0);
7365	if (overflowed) {
7366	if (ckWARN(WARN_PORTABLE) && n > 4294967295.0)
7367	Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
7368	"%s number > %s non-portable",
7369	Base, max);
7370	sv_setnv(sv, n);
7371	}
7372	else {
7373	#if UVSIZE > 4
7374	if (ckWARN(WARN_PORTABLE) && u > 0xffffffff)
7375	Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
7376	"%s number > %s non-portable",
7377	Base, max);
7378	#endif
7379	sv_setuv(sv, u);
7380	}
7381	if (PL_hints & HINT_NEW_BINARY)
7382	sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
7383	}
7384	break;
7385
7386	/*
7387	handle decimal numbers.
7388	we're also sent here when we read a 0 as the first digit
7389	*/
7390	case '1': case '2': case '3': case '4': case '5':
7391	case '6': case '7': case '8': case '9': case '.':
7392	decimal:
7393	d = PL_tokenbuf;
7394	e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
7395	floatit = FALSE;
7396
7397	/* read next group of digits and _ and copy into d */
7398	while (isDIGIT(s) \|\| s == '_') {
7399	/* skip underscores, checking for misplaced ones
7400	if -w is on
7401	*/
7402	if (*s == '_') {
7403	if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
7404	Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7405	"Misplaced _ in number");
7406	lastub = s++;
7407	}
7408	else {
7409	/* check for end of fixed-length buffer */
7410	if (d >= e)
7411	Perl_croak(aTHX_ number_too_long);
7412	/* if we're ok, copy the character */
7413	d++ = s++;
7414	}
7415	}
7416
7417	/* final misplaced underbar check */
7418	if (lastub && s == lastub + 1) {
7419	if (ckWARN(WARN_SYNTAX))
7420	Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
7421	}
7422
7423	/* read a decimal portion if there is one. avoid
7424	3..5 being interpreted as the number 3. followed
7425	by .5
7426	*/
7427	if (*s == '.' && s[1] != '.') {
7428	floatit = TRUE;
7429	d++ = s++;
7430
7431	if (*s == '_') {
7432	if (ckWARN(WARN_SYNTAX))
7433	Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7434	"Misplaced _ in number");
7435	lastub = s;
7436	}
7437
7438	/* copy, ignoring underbars, until we run out of digits.
7439	*/
7440	for (; isDIGIT(s) \|\| s == '_'; s++) {
7441	/* fixed length buffer check */
7442	if (d >= e)
7443	Perl_croak(aTHX_ number_too_long);
7444	if (*s == '_') {
7445	if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
7446	Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7447	"Misplaced _ in number");
7448	lastub = s;
7449	}
7450	else
7451	d++ = s;
7452	}
7453	/* fractional part ending in underbar? */
7454	if (s[-1] == '_') {
7455	if (ckWARN(WARN_SYNTAX))
7456	Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7457	"Misplaced _ in number");
7458	}
7459	if (*s == '.' && isDIGIT(s[1])) {
7460	/* oops, it's really a v-string, but without the "v" */
7461	s = start;
7462	goto vstring;
7463	}
7464	}
7465
7466	/* read exponent part, if present */
7467	if (s && strchr("eE",s) && strchr("+-0123456789_", s[1])) {
7468	floatit = TRUE;
7469	s++;
7470
7471	/* regardless of whether user said 3E5 or 3e5, use lower 'e' */
7472	d++ = 'e'; / At least some Mach atof()s don't grok 'E' */
7473
7474	/* stray preinitial _ */
7475	if (*s == '_') {
7476	if (ckWARN(WARN_SYNTAX))
7477	Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7478	"Misplaced _ in number");
7479	lastub = s++;
7480	}
7481
7482	/* allow positive or negative exponent */
7483	if (s == '+' \|\| s == '-')
7484	d++ = s++;
7485
7486	/* stray initial _ */
7487	if (*s == '_') {
7488	if (ckWARN(WARN_SYNTAX))
7489	Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7490	"Misplaced _ in number");
7491	lastub = s++;
7492	}
7493
7494	/* read digits of exponent */
7495	while (isDIGIT(s) \|\| s == '_') {
7496	if (isDIGIT(*s)) {
7497	if (d >= e)
7498	Perl_croak(aTHX_ number_too_long);
7499	d++ = s++;
7500	}
7501	else {
7502	if (ckWARN(WARN_SYNTAX) &&
7503	((lastub && s == lastub + 1) \|\|
7504	(!isDIGIT(s[1]) && s[1] != '_')))
7505	Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7506	"Misplaced _ in number");
7507	lastub = s++;
7508	}
7509	}
7510	}
7511
7512
7513	/* make an sv from the string */
7514	sv = NEWSV(92,0);
7515
7516	/*
7517	We try to do an integer conversion first if no characters
7518	indicating "float" have been found.
7519	*/
7520
7521	if (!floatit) {
7522	UV uv;
7523	int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
7524
7525	if (flags == IS_NUMBER_IN_UV) {
7526	if (uv <= IV_MAX)
7527	sv_setiv(sv, uv); /* Prefer IVs over UVs. */
7528	else
7529	sv_setuv(sv, uv);
7530	} else if (flags == (IS_NUMBER_IN_UV \| IS_NUMBER_NEG)) {
7531	if (uv <= (UV) IV_MIN)
7532	sv_setiv(sv, -(IV)uv);
7533	else
7534	floatit = TRUE;
7535	} else
7536	floatit = TRUE;
7537	}
7538	if (floatit) {
7539	/* terminate the string */
7540	*d = '\0';
7541	nv = Atof(PL_tokenbuf);
7542	sv_setnv(sv, nv);
7543	}
7544
7545	if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
7546	(PL_hints & HINT_NEW_INTEGER) )
7547	sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
7548	(floatit ? "float" : "integer"),
7549	sv, Nullsv, NULL);
7550	break;
7551
7552	/* if it starts with a v, it could be a v-string */
7553	case 'v':
7554	vstring:
7555	sv = NEWSV(92,5); /* preallocate storage space */
7556	s = scan_vstring(s,sv);
7557	DEBUG_T( { PerlIO_printf(Perl_debug_log,
7558	"### Saw v-string before '%s'\n", s);
7559	} );
7560	break;
7561	}
7562
7563	/* make the op for the constant and return */
7564
7565	if (sv)
7566	lvalp->opval = newSVOP(OP_CONST, 0, sv);
7567	else
7568	lvalp->opval = Nullop;
7569
7570	return s;
7571	}
7572
7573	STATIC char *
7574	S_scan_formline(pTHX_ register char *s)
7575	{
7576	register char *eol;
7577	register char *t;
7578	SV *stuff = newSVpvn("",0);
7579	bool needargs = FALSE;
7580
7581	while (!needargs) {
7582	if (s == '.' \|\| s == /{/'}') {
7583	/SUPPRESS 530/
7584	#ifdef PERL_STRICT_CR
7585	for (t = s+1;SPACE_OR_TAB(*t); t++) ;
7586	#else
7587	for (t = s+1;SPACE_OR_TAB(t) \|\| t == '\r'; t++) ;
7588	#endif
7589	if (*t == '\n' \|\| t == PL_bufend)
7590	break;
7591	}
7592	if (PL_in_eval && !PL_rsfp) {
7593	eol = strchr(s,'\n');
7594	if (!eol++)
7595	eol = PL_bufend;
7596	}
7597	else
7598	eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7599	if (*s != '#') {
7600	for (t = s; t < eol; t++) {
7601	if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
7602	needargs = FALSE;
7603	goto enough; /* ~~ must be first line in formline */
7604	}
7605	if (t == '@' \|\| t == '^')
7606	needargs = TRUE;
7607	}
7608	if (eol > s) {
7609	sv_catpvn(stuff, s, eol-s);
7610	#ifndef PERL_STRICT_CR
7611	if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
7612	char *end = SvPVX(stuff) + SvCUR(stuff);
7613	end[-2] = '\n';
7614	end[-1] = '\0';
7615	SvCUR(stuff)--;
7616	}
7617	#endif
7618	}
7619	else
7620	break;
7621	}
7622	s = eol;
7623	if (PL_rsfp) {
7624	s = filter_gets(PL_linestr, PL_rsfp, 0);
7625	PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
7626	PL_bufend = PL_bufptr + SvCUR(PL_linestr);
7627	PL_last_lop = PL_last_uni = Nullch;
7628	if (!s) {
7629	s = PL_bufptr;
7630	yyerror("Format not terminated");
7631	break;
7632	}
7633	}
7634	incline(s);
7635	}
7636	enough:
7637	if (SvCUR(stuff)) {
7638	PL_expect = XTERM;
7639	if (needargs) {
7640	PL_lex_state = LEX_NORMAL;
7641	PL_nextval[PL_nexttoke].ival = 0;
7642	force_next(',');
7643	}
7644	else
7645	PL_lex_state = LEX_FORMLINE;
7646	if (!IN_BYTES) {
7647	if (UTF && is_utf8_string((U8*)SvPVX(stuff), SvCUR(stuff)))
7648	SvUTF8_on(stuff);
7649	else if (PL_encoding)
7650	sv_recode_to_utf8(stuff, PL_encoding);
7651	}
7652	PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
7653	force_next(THING);
7654	PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
7655	force_next(LSTOP);
7656	}
7657	else {
7658	SvREFCNT_dec(stuff);
7659	PL_lex_formbrack = 0;
7660	PL_bufptr = s;
7661	}
7662	return s;
7663	}
7664
7665	STATIC void
7666	S_set_csh(pTHX)
7667	{
7668	#ifdef CSH
7669	if (!PL_cshlen)
7670	PL_cshlen = strlen(PL_cshname);
7671	#endif
7672	}
7673
7674	I32
7675	Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
7676	{
7677	I32 oldsavestack_ix = PL_savestack_ix;
7678	CV* outsidecv = PL_compcv;
7679
7680	if (PL_compcv) {
7681	assert(SvTYPE(PL_compcv) == SVt_PVCV);
7682	}
7683	SAVEI32(PL_subline);
7684	save_item(PL_subname);
7685	SAVESPTR(PL_compcv);
7686
7687	PL_compcv = (CV*)NEWSV(1104,0);
7688	sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
7689	CvFLAGS(PL_compcv) \|= flags;
7690
7691	PL_subline = CopLINE(PL_curcop);
7692	CvPADLIST(PL_compcv) = pad_new(padnew_SAVE\|padnew_SAVESUB);
7693	CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
7694	CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
7695	#ifdef USE_5005THREADS
7696	CvOWNER(PL_compcv) = 0;
7697	New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
7698	MUTEX_INIT(CvMUTEXP(PL_compcv));
7699	#endif /* USE_5005THREADS */
7700
7701	return oldsavestack_ix;
7702	}
7703
7704	#ifdef __SC__
7705	#pragma segment Perl_yylex
7706	#endif
7707	int
7708	Perl_yywarn(pTHX_ char *s)
7709	{
7710	PL_in_eval \|= EVAL_WARNONLY;
7711	yyerror(s);
7712	PL_in_eval &= ~EVAL_WARNONLY;
7713	return 0;
7714	}
7715
7716	int
7717	Perl_yyerror(pTHX_ char *s)
7718	{
7719	char *where = NULL;
7720	char *context = NULL;
7721	int contlen = -1;
7722	SV *msg;
7723
7724	if (!yychar \|\| (yychar == ';' && !PL_rsfp))
7725	where = "at EOF";
7726	else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
7727	PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
7728	/*
7729	Only for NetWare:
7730	The code below is removed for NetWare because it abends/crashes on NetWare
7731	when the script has error such as not having the closing quotes like:
7732	if ($var eq "value)
7733	Checking of white spaces is anyway done in NetWare code.
7734	*/
7735	#ifndef NETWARE
7736	while (isSPACE(*PL_oldoldbufptr))
7737	PL_oldoldbufptr++;
7738	#endif
7739	context = PL_oldoldbufptr;
7740	contlen = PL_bufptr - PL_oldoldbufptr;
7741	}
7742	else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
7743	PL_oldbufptr != PL_bufptr) {
7744	/*
7745	Only for NetWare:
7746	The code below is removed for NetWare because it abends/crashes on NetWare
7747	when the script has error such as not having the closing quotes like:
7748	if ($var eq "value)
7749	Checking of white spaces is anyway done in NetWare code.
7750	*/
7751	#ifndef NETWARE
7752	while (isSPACE(*PL_oldbufptr))
7753	PL_oldbufptr++;
7754	#endif
7755	context = PL_oldbufptr;
7756	contlen = PL_bufptr - PL_oldbufptr;
7757	}
7758	else if (yychar > 255)
7759	where = "next token ???";
7760	#ifdef USE_PURE_BISON
7761	/* GNU Bison sets the value -2 */
7762	else if (yychar == -2) {
7763	#else
7764	else if ((yychar & 127) == 127) {
7765	#endif
7766	if (PL_lex_state == LEX_NORMAL \|\|
7767	(PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
7768	where = "at end of line";
7769	else if (PL_lex_inpat)
7770	where = "within pattern";
7771	else
7772	where = "within string";
7773	}
7774	else {
7775	SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
7776	if (yychar < 32)
7777	Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
7778	else if (isPRINT_LC(yychar))
7779	Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
7780	else
7781	Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
7782	where = SvPVX(where_sv);
7783	}
7784	msg = sv_2mortal(newSVpv(s, 0));
7785	Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
7786	OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
7787	if (context)
7788	Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
7789	else
7790	Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
7791	if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
7792	Perl_sv_catpvf(aTHX_ msg,
7793	" (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
7794	(int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
7795	PL_multi_end = 0;
7796	}
7797	if (PL_in_eval & EVAL_WARNONLY)
7798	Perl_warn(aTHX_ "%"SVf, msg);
7799	else
7800	qerror(msg);
7801	if (PL_error_count >= 10) {
7802	if (PL_in_eval && SvCUR(ERRSV))
7803	Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
7804	ERRSV, OutCopFILE(PL_curcop));
7805	else
7806	Perl_croak(aTHX_ "%s has too many errors.\n",
7807	OutCopFILE(PL_curcop));
7808	}
7809	PL_in_my = 0;
7810	PL_in_my_stash = Nullhv;
7811	return 0;
7812	}
7813	#ifdef __SC__
7814	#pragma segment Main
7815	#endif
7816
7817	STATIC char*
7818	S_swallow_bom(pTHX_ U8 *s)
7819	{
7820	STRLEN slen;
7821	slen = SvCUR(PL_linestr);
7822	switch (*s) {
7823	case 0xFF:
7824	if (s[1] == 0xFE) {
7825	/* UTF-16 little-endian */
7826	if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
7827	Perl_croak(aTHX_ "Unsupported script encoding");
7828	#ifndef PERL_NO_UTF16_FILTER
7829	DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-LE script encoding\n"));
7830	s += 2;
7831	if (PL_bufend > (char*)s) {
7832	U8 *news;
7833	I32 newlen;
7834
7835	filter_add(utf16rev_textfilter, NULL);
7836	New(898, news, (PL_bufend - (char)s) 3 / 2 + 1, U8);
7837	PL_bufend = (char*)utf16_to_utf8_reversed(s, news,
7838	PL_bufend - (char*)s - 1,
7839	&newlen);
7840	Copy(news, s, newlen, U8);
7841	SvCUR_set(PL_linestr, newlen);
7842	PL_bufend = SvPVX(PL_linestr) + newlen;
7843	news[newlen++] = '\0';
7844	Safefree(news);
7845	}
7846	#else
7847	Perl_croak(aTHX_ "Unsupported script encoding");
7848	#endif
7849	}
7850	break;
7851	case 0xFE:
7852	if (s[1] == 0xFF) { /* UTF-16 big-endian */
7853	#ifndef PERL_NO_UTF16_FILTER
7854	DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding\n"));
7855	s += 2;
7856	if (PL_bufend > (char *)s) {
7857	U8 *news;
7858	I32 newlen;
7859
7860	filter_add(utf16_textfilter, NULL);
7861	New(898, news, (PL_bufend - (char)s) 3 / 2 + 1, U8);
7862	PL_bufend = (char*)utf16_to_utf8(s, news,
7863	PL_bufend - (char*)s,
7864	&newlen);
7865	Copy(news, s, newlen, U8);
7866	SvCUR_set(PL_linestr, newlen);
7867	PL_bufend = SvPVX(PL_linestr) + newlen;
7868	news[newlen++] = '\0';
7869	Safefree(news);
7870	}
7871	#else
7872	Perl_croak(aTHX_ "Unsupported script encoding");
7873	#endif
7874	}
7875	break;
7876	case 0xEF:
7877	if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
7878	DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-8 script encoding\n"));
7879	s += 3; /* UTF-8 */
7880	}
7881	break;
7882	case 0:
7883	if (slen > 3 && s[1] == 0 && /* UTF-32 big-endian */
7884	s[2] == 0xFE && s[3] == 0xFF)
7885	{
7886	Perl_croak(aTHX_ "Unsupported script encoding");
7887	}
7888	}
7889	return (char*)s;
7890	}
7891
7892	/*
7893	* restore_rsfp
7894	* Restore a source filter.
7895	*/
7896
7897	static void
7898	restore_rsfp(pTHX_ void *f)
7899	{
7900	PerlIO fp = (PerlIO)f;
7901
7902	if (PL_rsfp == PerlIO_stdin())
7903	PerlIO_clearerr(PL_rsfp);
7904	else if (PL_rsfp && (PL_rsfp != fp))
7905	PerlIO_close(PL_rsfp);
7906	PL_rsfp = fp;
7907	}
7908
7909	#ifndef PERL_NO_UTF16_FILTER
7910	static I32
7911	utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
7912	{
7913	I32 count = FILTER_READ(idx+1, sv, maxlen);
7914	if (count) {
7915	U8* tmps;
7916	U8* tend;
7917	I32 newlen;
7918	New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
7919	if (!*SvPV_nolen(sv))
7920	/* Game over, but don't feed an odd-length string to utf16_to_utf8 */
7921	return count;
7922
7923	tend = utf16_to_utf8((U8*)SvPVX(sv), tmps, SvCUR(sv), &newlen);
7924	sv_usepvn(sv, (char*)tmps, tend - tmps);
7925	}
7926	return count;
7927	}
7928
7929	static I32
7930	utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
7931	{
7932	I32 count = FILTER_READ(idx+1, sv, maxlen);
7933	if (count) {
7934	U8* tmps;
7935	U8* tend;
7936	I32 newlen;
7937	if (!*SvPV_nolen(sv))
7938	/* Game over, but don't feed an odd-length string to utf16_to_utf8 */
7939	return count;
7940
7941	New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
7942	tend = utf16_to_utf8_reversed((U8*)SvPVX(sv), tmps, SvCUR(sv), &newlen);
7943	sv_usepvn(sv, (char*)tmps, tend - tmps);
7944	}
7945	return count;
7946	}
7947	#endif
7948
7949	/*
7950	Returns a pointer to the next character after the parsed
7951	vstring, as well as updating the passed in sv.
7952
7953	Function must be called like
7954
7955	sv = NEWSV(92,5);
7956	s = scan_vstring(s,sv);
7957
7958	The sv should already be large enough to store the vstring
7959	passed in, for performance reasons.
7960
7961	*/
7962
7963	char *
7964	Perl_scan_vstring(pTHX_ char s, SV sv)
7965	{
7966	char *pos = s;
7967	char *start = s;
7968	if (pos == 'v') pos++; / get past 'v' */
7969	while (pos < PL_bufend && (isDIGIT(pos) \|\| pos == '_'))
7970	pos++;
7971	if ( *pos != '.') {
7972	/* this may not be a v-string if followed by => */
7973	char *next = pos;
7974	while (next < PL_bufend && isSPACE(*next))
7975	++next;
7976	if ((PL_bufend - next) >= 2 && *next == '=' && next[1] == '>' ) {
7977	/* return string not v-string */
7978	sv_setpvn(sv,(char *)s,pos-s);
7979	return pos;
7980	}
7981	}
7982
7983	if (!isALPHA(*pos)) {
7984	UV rev;
7985	U8 tmpbuf[UTF8_MAXLEN+1];
7986	U8 *tmpend;
7987
7988	if (s == 'v') s++; / get past 'v' */
7989
7990	sv_setpvn(sv, "", 0);
7991
7992	for (;;) {
7993	rev = 0;
7994	{
7995	/* this is atoi() that tolerates underscores */
7996	char *end = pos;
7997	UV mult = 1;
7998	while (--end >= s) {
7999	UV orev;
8000	if (*end == '_')
8001	continue;
8002	orev = rev;
8003	rev += (end - '0') mult;
8004	mult *= 10;
8005	if (orev > rev && ckWARN_d(WARN_OVERFLOW))
8006	Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
8007	"Integer overflow in decimal number");
8008	}
8009	}
8010	#ifdef EBCDIC
8011	if (rev > 0x7FFFFFFF)
8012	Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
8013	#endif
8014	/* Append native character for the rev point */
8015	tmpend = uvchr_to_utf8(tmpbuf, rev);
8016	sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
8017	if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
8018	SvUTF8_on(sv);
8019	if (pos + 1 < PL_bufend && *pos == '.' && isDIGIT(pos[1]))
8020	s = ++pos;
8021	else {
8022	s = pos;
8023	break;
8024	}
8025	while (pos < PL_bufend && (isDIGIT(pos) \|\| pos == '_'))
8026	pos++;
8027	}
8028	SvPOK_on(sv);
8029	sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
8030	SvRMAGICAL_on(sv);
8031	}
8032	return s;
8033	}
8034

Note: See TracBrowser for help on using the repository browser.

Context Navigation

source: trunk/third/perl/toke.c @ 20075

Download in other formats: