Context Navigation

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

Visit:

Revision 14545, 178.2 KB checked in by ghudson, 25 years ago (diff)
This commit was generated by cvs2svn to compensate for changes in r14544, which included commits to RCS files with non-trunk default branches.

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

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

Download in other formats: