3 * Copyright (c) 1991-1999, Larry Wall
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.
11 * "It all comes from here, the stench and the peril." --Frodo
15 * This file is the lexer for Perl. It's closely linked to the
18 * The main routine is yylex(), which returns the next token.
22 #define PERL_IN_TOKE_C
25 #define yychar PL_yychar
26 #define yylval PL_yylval
28 static char ident_too_long[] = "Identifier too long";
30 static void restore_rsfp(pTHXo_ void *f);
31 static void restore_expect(pTHXo_ void *e);
32 static void restore_lex_expect(pTHXo_ void *e);
34 #define UTF (PL_hints & HINT_UTF8)
36 * Note: we try to be careful never to call the isXXX_utf8() functions
37 * unless we're pretty sure we've seen the beginning of a UTF-8 character
38 * (that is, the two high bits are set). Otherwise we risk loading in the
39 * heavy-duty SWASHINIT and SWASHGET routines unnecessarily.
41 #define isIDFIRST_lazy(p) ((!UTF || (*((U8*)p) < 0xc0)) \
43 : isIDFIRST_utf8((U8*)p))
44 #define isALNUM_lazy(p) ((!UTF || (*((U8*)p) < 0xc0)) \
46 : isALNUM_utf8((U8*)p))
48 /* In variables name $^X, these are the legal values for X.
49 * 1999-02-27 mjd-perl-patch@plover.com */
50 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
52 /* LEX_* are values for PL_lex_state, the state of the lexer.
53 * They are arranged oddly so that the guard on the switch statement
54 * can get by with a single comparison (if the compiler is smart enough).
57 /* #define LEX_NOTPARSING 11 is done in perl.h. */
60 #define LEX_INTERPNORMAL 9
61 #define LEX_INTERPCASEMOD 8
62 #define LEX_INTERPPUSH 7
63 #define LEX_INTERPSTART 6
64 #define LEX_INTERPEND 5
65 #define LEX_INTERPENDMAYBE 4
66 #define LEX_INTERPCONCAT 3
67 #define LEX_INTERPCONST 2
68 #define LEX_FORMLINE 1
69 #define LEX_KNOWNEXT 0
78 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
80 # include <unistd.h> /* Needed for execv() */
89 YYSTYPE* yylval_pointer = NULL;
90 int* yychar_pointer = NULL;
93 # define yylval (*yylval_pointer)
94 # define yychar (*yychar_pointer)
95 # define PERL_YYLEX_PARAM yylval_pointer,yychar_pointer
97 # define yylex() Perl_yylex(aTHX_ yylval_pointer, yychar_pointer)
100 #include "keywords.h"
102 /* CLINE is a macro that ensures PL_copline has a sane value */
107 #define CLINE (PL_copline = (PL_curcop->cop_line < PL_copline ? PL_curcop->cop_line : PL_copline))
110 * Convenience functions to return different tokens and prime the
111 * lexer for the next token. They all take an argument.
113 * TOKEN : generic token (used for '(', DOLSHARP, etc)
114 * OPERATOR : generic operator
115 * AOPERATOR : assignment operator
116 * PREBLOCK : beginning the block after an if, while, foreach, ...
117 * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
118 * PREREF : *EXPR where EXPR is not a simple identifier
119 * TERM : expression term
120 * LOOPX : loop exiting command (goto, last, dump, etc)
121 * FTST : file test operator
122 * FUN0 : zero-argument function
124 * BOop : bitwise or or xor
126 * SHop : shift operator
127 * PWop : power operator
128 * PMop : pattern-matching operator
129 * Aop : addition-level operator
130 * Mop : multiplication-level operator
131 * Eop : equality-testing operator
132 * Rop : relational operator <= != gt
134 * Also see LOP and lop() below.
137 #define TOKEN(retval) return (PL_bufptr = s,(int)retval)
138 #define OPERATOR(retval) return (PL_expect = XTERM,PL_bufptr = s,(int)retval)
139 #define AOPERATOR(retval) return ao((PL_expect = XTERM,PL_bufptr = s,(int)retval))
140 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s,(int)retval)
141 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval)
142 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s,(int)retval)
143 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR,PL_bufptr = s,(int)retval)
144 #define LOOPX(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX)
145 #define FTST(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)UNIOP)
146 #define FUN0(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0)
147 #define FUN1(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1)
148 #define BOop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITOROP))
149 #define BAop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP))
150 #define SHop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP))
151 #define PWop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)POWOP))
152 #define PMop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP)
153 #define Aop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)ADDOP))
154 #define Mop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MULOP))
155 #define Eop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)EQOP)
156 #define Rop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)RELOP)
158 /* This bit of chicanery makes a unary function followed by
159 * a parenthesis into a function with one argument, highest precedence.
161 #define UNI(f) return(yylval.ival = f, \
164 PL_last_uni = PL_oldbufptr, \
165 PL_last_lop_op = f, \
166 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
168 #define UNIBRACK(f) return(yylval.ival = f, \
170 PL_last_uni = PL_oldbufptr, \
171 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
173 /* grandfather return to old style */
174 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
179 * This subroutine detects &&= and ||= and turns an ANDAND or OROR
180 * into an OP_ANDASSIGN or OP_ORASSIGN
184 S_ao(pTHX_ int toketype)
186 if (*PL_bufptr == '=') {
188 if (toketype == ANDAND)
189 yylval.ival = OP_ANDASSIGN;
190 else if (toketype == OROR)
191 yylval.ival = OP_ORASSIGN;
199 * When Perl expects an operator and finds something else, no_op
200 * prints the warning. It always prints "<something> found where
201 * operator expected. It prints "Missing semicolon on previous line?"
202 * if the surprise occurs at the start of the line. "do you need to
203 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
204 * where the compiler doesn't know if foo is a method call or a function.
205 * It prints "Missing operator before end of line" if there's nothing
206 * after the missing operator, or "... before <...>" if there is something
207 * after the missing operator.
211 S_no_op(pTHX_ char *what, char *s)
213 char *oldbp = PL_bufptr;
214 bool is_first = (PL_oldbufptr == PL_linestart);
218 yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
220 Perl_warn(aTHX_ "\t(Missing semicolon on previous line?)\n");
221 else if (PL_oldoldbufptr && isIDFIRST_lazy(PL_oldoldbufptr)) {
223 for (t = PL_oldoldbufptr; *t && (isALNUM_lazy(t) || *t == ':'); t++) ;
224 if (t < PL_bufptr && isSPACE(*t))
225 Perl_warn(aTHX_ "\t(Do you need to predeclare %.*s?)\n",
226 t - PL_oldoldbufptr, PL_oldoldbufptr);
229 Perl_warn(aTHX_ "\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
235 * Complain about missing quote/regexp/heredoc terminator.
236 * If it's called with (char *)NULL then it cauterizes the line buffer.
237 * If we're in a delimited string and the delimiter is a control
238 * character, it's reformatted into a two-char sequence like ^C.
243 S_missingterm(pTHX_ char *s)
248 char *nl = strrchr(s,'\n');
254 iscntrl(PL_multi_close)
256 PL_multi_close < 32 || PL_multi_close == 127
260 tmpbuf[1] = toCTRL(PL_multi_close);
266 *tmpbuf = PL_multi_close;
270 q = strchr(s,'"') ? '\'' : '"';
271 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
279 Perl_deprecate(pTHX_ char *s)
282 if (ckWARN(WARN_DEPRECATED))
283 Perl_warner(aTHX_ WARN_DEPRECATED, "Use of %s is deprecated", s);
288 * Deprecate a comma-less variable list.
294 deprecate("comma-less variable list");
298 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
299 * utf16-to-utf8-reversed.
305 S_win32_textfilter(pTHX_ int idx, SV *sv, int maxlen)
307 I32 count = FILTER_READ(idx+1, sv, maxlen);
308 if (count > 0 && !maxlen)
309 win32_strip_return(sv);
315 S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
317 I32 count = FILTER_READ(idx+1, sv, maxlen);
321 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
322 tend = utf16_to_utf8((U16*)SvPVX(sv), tmps, SvCUR(sv));
323 sv_usepvn(sv, (char*)tmps, tend - tmps);
330 S_utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
332 I32 count = FILTER_READ(idx+1, sv, maxlen);
336 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
337 tend = utf16_to_utf8_reversed((U16*)SvPVX(sv), tmps, SvCUR(sv));
338 sv_usepvn(sv, (char*)tmps, tend - tmps);
346 * Initialize variables. Uses the Perl save_stack to save its state (for
347 * recursive calls to the parser).
351 Perl_lex_start(pTHX_ SV *line)
357 SAVEI32(PL_lex_dojoin);
358 SAVEI32(PL_lex_brackets);
359 SAVEI32(PL_lex_fakebrack);
360 SAVEI32(PL_lex_casemods);
361 SAVEI32(PL_lex_starts);
362 SAVEI32(PL_lex_state);
363 SAVESPTR(PL_lex_inpat);
364 SAVEI32(PL_lex_inwhat);
365 SAVEI16(PL_curcop->cop_line);
368 SAVEPPTR(PL_oldbufptr);
369 SAVEPPTR(PL_oldoldbufptr);
370 SAVEPPTR(PL_linestart);
371 SAVESPTR(PL_linestr);
372 SAVEPPTR(PL_lex_brackstack);
373 SAVEPPTR(PL_lex_casestack);
374 SAVEDESTRUCTOR(restore_rsfp, PL_rsfp);
375 SAVESPTR(PL_lex_stuff);
376 SAVEI32(PL_lex_defer);
377 SAVESPTR(PL_lex_repl);
378 SAVEDESTRUCTOR(restore_expect, PL_tokenbuf + PL_expect); /* encode as pointer */
379 SAVEDESTRUCTOR(restore_lex_expect, PL_tokenbuf + PL_expect);
381 PL_lex_state = LEX_NORMAL;
385 PL_lex_fakebrack = 0;
386 New(899, PL_lex_brackstack, 120, char);
387 New(899, PL_lex_casestack, 12, char);
388 SAVEFREEPV(PL_lex_brackstack);
389 SAVEFREEPV(PL_lex_casestack);
391 *PL_lex_casestack = '\0';
394 PL_lex_stuff = Nullsv;
395 PL_lex_repl = Nullsv;
399 if (SvREADONLY(PL_linestr))
400 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
401 s = SvPV(PL_linestr, len);
402 if (len && s[len-1] != ';') {
403 if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
404 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
405 sv_catpvn(PL_linestr, "\n;", 2);
407 SvTEMP_off(PL_linestr);
408 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
409 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
411 PL_rs = newSVpvn("\n", 1);
417 * Finalizer for lexing operations. Must be called when the parser is
418 * done with the lexer.
424 PL_doextract = FALSE;
429 * This subroutine has nothing to do with tilting, whether at windmills
430 * or pinball tables. Its name is short for "increment line". It
431 * increments the current line number in PL_curcop->cop_line and checks
432 * to see whether the line starts with a comment of the form
433 * # line 500 "foo.pm"
434 * If so, it sets the current line number and file to the values in the comment.
438 S_incline(pTHX_ char *s)
446 PL_curcop->cop_line++;
449 while (*s == ' ' || *s == '\t') s++;
450 if (strnEQ(s, "line ", 5)) {
459 while (*s == ' ' || *s == '\t')
461 if (*s == '"' && (t = strchr(s+1, '"')))
465 return; /* false alarm */
466 for (t = s; !isSPACE(*t); t++) ;
471 PL_curcop->cop_filegv = gv_fetchfile(s);
473 PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
475 PL_curcop->cop_line = atoi(n)-1;
480 * Called to gobble the appropriate amount and type of whitespace.
481 * Skips comments as well.
485 S_skipspace(pTHX_ register char *s)
488 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
489 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
495 while (s < PL_bufend && isSPACE(*s)) {
496 if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
501 if (s < PL_bufend && *s == '#') {
502 while (s < PL_bufend && *s != '\n')
506 if (PL_in_eval && !PL_rsfp) {
513 /* only continue to recharge the buffer if we're at the end
514 * of the buffer, we're not reading from a source filter, and
515 * we're in normal lexing mode
517 if (s < PL_bufend || !PL_rsfp || PL_lex_state != LEX_NORMAL)
520 /* try to recharge the buffer */
521 if ((s = filter_gets(PL_linestr, PL_rsfp,
522 (prevlen = SvCUR(PL_linestr)))) == Nullch)
524 /* end of file. Add on the -p or -n magic */
525 if (PL_minus_n || PL_minus_p) {
526 sv_setpv(PL_linestr,PL_minus_p ?
527 ";}continue{print or die qq(-p destination: $!\\n)" :
529 sv_catpv(PL_linestr,";}");
530 PL_minus_n = PL_minus_p = 0;
533 sv_setpv(PL_linestr,";");
535 /* reset variables for next time we lex */
536 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
538 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
540 /* Close the filehandle. Could be from -P preprocessor,
541 * STDIN, or a regular file. If we were reading code from
542 * STDIN (because the commandline held no -e or filename)
543 * then we don't close it, we reset it so the code can
544 * read from STDIN too.
547 if (PL_preprocess && !PL_in_eval)
548 (void)PerlProc_pclose(PL_rsfp);
549 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
550 PerlIO_clearerr(PL_rsfp);
552 (void)PerlIO_close(PL_rsfp);
557 /* not at end of file, so we only read another line */
558 PL_linestart = PL_bufptr = s + prevlen;
559 PL_bufend = s + SvCUR(PL_linestr);
563 /* debugger active and we're not compiling the debugger code,
564 * so store the line into the debugger's array of lines
566 if (PERLDB_LINE && PL_curstash != PL_debstash) {
567 SV *sv = NEWSV(85,0);
569 sv_upgrade(sv, SVt_PVMG);
570 sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
571 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
578 * Check the unary operators to ensure there's no ambiguity in how they're
579 * used. An ambiguous piece of code would be:
581 * This doesn't mean rand() + 5. Because rand() is a unary operator,
582 * the +5 is its argument.
592 if (PL_oldoldbufptr != PL_last_uni)
594 while (isSPACE(*PL_last_uni))
596 for (s = PL_last_uni; isALNUM_lazy(s) || *s == '-'; s++) ;
597 if ((t = strchr(s, '(')) && t < PL_bufptr)
599 if (ckWARN_d(WARN_AMBIGUOUS)){
602 Perl_warner(aTHX_ WARN_AMBIGUOUS,
603 "Warning: Use of \"%s\" without parens is ambiguous",
609 /* workaround to replace the UNI() macro with a function. Only the
610 * hints/uts.sh file mentions this. Other comments elsewhere in the
611 * source indicate Microport Unix might need it too.
617 #define UNI(f) return uni(f,s)
620 S_uni(pTHX_ I32 f, char *s)
625 PL_last_uni = PL_oldbufptr;
636 #endif /* CRIPPLED_CC */
639 * LOP : macro to build a list operator. Its behaviour has been replaced
640 * with a subroutine, S_lop() for which LOP is just another name.
643 #define LOP(f,x) return lop(f,x,s)
647 * Build a list operator (or something that might be one). The rules:
648 * - if we have a next token, then it's a list operator [why?]
649 * - if the next thing is an opening paren, then it's a function
650 * - else it's a list operator
654 S_lop(pTHX_ I32 f, expectation x, char *s)
661 PL_last_lop = PL_oldbufptr;
676 * When the lexer realizes it knows the next token (for instance,
677 * it is reordering tokens for the parser) then it can call S_force_next
678 * to know what token to return the next time the lexer is called. Caller
679 * will need to set PL_nextval[], and possibly PL_expect to ensure the lexer
680 * handles the token correctly.
684 S_force_next(pTHX_ I32 type)
686 PL_nexttype[PL_nexttoke] = type;
688 if (PL_lex_state != LEX_KNOWNEXT) {
689 PL_lex_defer = PL_lex_state;
690 PL_lex_expect = PL_expect;
691 PL_lex_state = LEX_KNOWNEXT;
697 * When the lexer knows the next thing is a word (for instance, it has
698 * just seen -> and it knows that the next char is a word char, then
699 * it calls S_force_word to stick the next word into the PL_next lookahead.
702 * char *start : start of the buffer
703 * int token : PL_next will be this type of bare word (e.g., METHOD,WORD)
704 * int check_keyword : if true, Perl checks to make sure the word isn't
705 * a keyword (do this if the word is a label, e.g. goto FOO)
706 * int allow_pack : if true, : characters will also be allowed (require,
708 * int allow_initial_tick : used by the "sub" lexer only.
712 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
717 start = skipspace(start);
719 if (isIDFIRST_lazy(s) ||
720 (allow_pack && *s == ':') ||
721 (allow_initial_tick && *s == '\'') )
723 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
724 if (check_keyword && keyword(PL_tokenbuf, len))
726 if (token == METHOD) {
731 PL_expect = XOPERATOR;
734 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(PL_tokenbuf,0));
735 PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
743 * Called when the lexer wants $foo *foo &foo etc, but the program
744 * text only contains the "foo" portion. The first argument is a pointer
745 * to the "foo", and the second argument is the type symbol to prefix.
746 * Forces the next token to be a "WORD".
747 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
751 S_force_ident(pTHX_ register char *s, int kind)
754 OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
755 PL_nextval[PL_nexttoke].opval = o;
758 dTHR; /* just for in_eval */
759 o->op_private = OPpCONST_ENTERED;
760 /* XXX see note in pp_entereval() for why we forgo typo
761 warnings if the symbol must be introduced in an eval.
763 gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
764 kind == '$' ? SVt_PV :
765 kind == '@' ? SVt_PVAV :
766 kind == '%' ? SVt_PVHV :
775 * Forces the next token to be a version number.
779 S_force_version(pTHX_ char *s)
781 OP *version = Nullop;
785 /* default VERSION number -- GBARR */
790 for( d=s, c = 1; isDIGIT(*d) || *d == '_' || (*d == '.' && c--); d++);
791 if((*d == ';' || isSPACE(*d)) && *(skipspace(d)) != ',') {
793 /* real VERSION number -- GBARR */
794 version = yylval.opval;
798 /* NOTE: The parser sees the package name and the VERSION swapped */
799 PL_nextval[PL_nexttoke].opval = version;
807 * Tokenize a quoted string passed in as an SV. It finds the next
808 * chunk, up to end of string or a backslash. It may make a new
809 * SV containing that chunk (if HINT_NEW_STRING is on). It also
814 S_tokeq(pTHX_ SV *sv)
825 s = SvPV_force(sv, len);
829 while (s < send && *s != '\\')
834 if ( PL_hints & HINT_NEW_STRING )
835 pv = sv_2mortal(newSVpvn(SvPVX(pv), len));
838 if (s + 1 < send && (s[1] == '\\'))
839 s++; /* all that, just for this */
844 SvCUR_set(sv, d - SvPVX(sv));
846 if ( PL_hints & HINT_NEW_STRING )
847 return new_constant(NULL, 0, "q", sv, pv, "q");
852 * Now come three functions related to double-quote context,
853 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
854 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
855 * interact with PL_lex_state, and create fake ( ... ) argument lists
856 * to handle functions and concatenation.
857 * They assume that whoever calls them will be setting up a fake
858 * join call, because each subthing puts a ',' after it. This lets
861 * join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
863 * (I'm not sure whether the spurious commas at the end of lcfirst's
864 * arguments and join's arguments are created or not).
869 * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST).
871 * Pattern matching will set PL_lex_op to the pattern-matching op to
872 * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise).
874 * OP_CONST and OP_READLINE are easy--just make the new op and return.
876 * Everything else becomes a FUNC.
878 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
879 * had an OP_CONST or OP_READLINE). This just sets us up for a
880 * call to S_sublex_push().
886 register I32 op_type = yylval.ival;
888 if (op_type == OP_NULL) {
889 yylval.opval = PL_lex_op;
893 if (op_type == OP_CONST || op_type == OP_READLINE) {
894 SV *sv = tokeq(PL_lex_stuff);
896 if (SvTYPE(sv) == SVt_PVIV) {
897 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
903 nsv = newSVpvn(p, len);
907 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
908 PL_lex_stuff = Nullsv;
912 PL_sublex_info.super_state = PL_lex_state;
913 PL_sublex_info.sub_inwhat = op_type;
914 PL_sublex_info.sub_op = PL_lex_op;
915 PL_lex_state = LEX_INTERPPUSH;
919 yylval.opval = PL_lex_op;
929 * Create a new scope to save the lexing state. The scope will be
930 * ended in S_sublex_done. Returns a '(', starting the function arguments
931 * to the uc, lc, etc. found before.
932 * Sets PL_lex_state to LEX_INTERPCONCAT.
941 PL_lex_state = PL_sublex_info.super_state;
942 SAVEI32(PL_lex_dojoin);
943 SAVEI32(PL_lex_brackets);
944 SAVEI32(PL_lex_fakebrack);
945 SAVEI32(PL_lex_casemods);
946 SAVEI32(PL_lex_starts);
947 SAVEI32(PL_lex_state);
948 SAVESPTR(PL_lex_inpat);
949 SAVEI32(PL_lex_inwhat);
950 SAVEI16(PL_curcop->cop_line);
952 SAVEPPTR(PL_oldbufptr);
953 SAVEPPTR(PL_oldoldbufptr);
954 SAVEPPTR(PL_linestart);
955 SAVESPTR(PL_linestr);
956 SAVEPPTR(PL_lex_brackstack);
957 SAVEPPTR(PL_lex_casestack);
959 PL_linestr = PL_lex_stuff;
960 PL_lex_stuff = Nullsv;
962 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
964 PL_bufend += SvCUR(PL_linestr);
965 SAVEFREESV(PL_linestr);
967 PL_lex_dojoin = FALSE;
969 PL_lex_fakebrack = 0;
970 New(899, PL_lex_brackstack, 120, char);
971 New(899, PL_lex_casestack, 12, char);
972 SAVEFREEPV(PL_lex_brackstack);
973 SAVEFREEPV(PL_lex_casestack);
975 *PL_lex_casestack = '\0';
977 PL_lex_state = LEX_INTERPCONCAT;
978 PL_curcop->cop_line = PL_multi_start;
980 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
981 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
982 PL_lex_inpat = PL_sublex_info.sub_op;
984 PL_lex_inpat = Nullop;
991 * Restores lexer state after a S_sublex_push.
997 if (!PL_lex_starts++) {
998 PL_expect = XOPERATOR;
999 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpvn("",0));
1003 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
1004 PL_lex_state = LEX_INTERPCASEMOD;
1008 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1009 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1010 PL_linestr = PL_lex_repl;
1012 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1013 PL_bufend += SvCUR(PL_linestr);
1014 SAVEFREESV(PL_linestr);
1015 PL_lex_dojoin = FALSE;
1016 PL_lex_brackets = 0;
1017 PL_lex_fakebrack = 0;
1018 PL_lex_casemods = 0;
1019 *PL_lex_casestack = '\0';
1021 if (SvEVALED(PL_lex_repl)) {
1022 PL_lex_state = LEX_INTERPNORMAL;
1024 /* we don't clear PL_lex_repl here, so that we can check later
1025 whether this is an evalled subst; that means we rely on the
1026 logic to ensure sublex_done() is called again only via the
1027 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1030 PL_lex_state = LEX_INTERPCONCAT;
1031 PL_lex_repl = Nullsv;
1037 PL_bufend = SvPVX(PL_linestr);
1038 PL_bufend += SvCUR(PL_linestr);
1039 PL_expect = XOPERATOR;
1047 Extracts a pattern, double-quoted string, or transliteration. This
1050 It looks at lex_inwhat and PL_lex_inpat to find out whether it's
1051 processing a pattern (PL_lex_inpat is true), a transliteration
1052 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
1054 Returns a pointer to the character scanned up to. Iff this is
1055 advanced from the start pointer supplied (ie if anything was
1056 successfully parsed), will leave an OP for the substring scanned
1057 in yylval. Caller must intuit reason for not parsing further
1058 by looking at the next characters herself.
1062 double-quoted style: \r and \n
1063 regexp special ones: \D \s
1065 backrefs: \1 (deprecated in substitution replacements)
1066 case and quoting: \U \Q \E
1067 stops on @ and $, but not for $ as tail anchor
1069 In transliterations:
1070 characters are VERY literal, except for - not at the start or end
1071 of the string, which indicates a range. scan_const expands the
1072 range to the full set of intermediate characters.
1074 In double-quoted strings:
1076 double-quoted style: \r and \n
1078 backrefs: \1 (deprecated)
1079 case and quoting: \U \Q \E
1082 scan_const does *not* construct ops to handle interpolated strings.
1083 It stops processing as soon as it finds an embedded $ or @ variable
1084 and leaves it to the caller to work out what's going on.
1086 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
1088 $ in pattern could be $foo or could be tail anchor. Assumption:
1089 it's a tail anchor if $ is the last thing in the string, or if it's
1090 followed by one of ")| \n\t"
1092 \1 (backreferences) are turned into $1
1094 The structure of the code is
1095 while (there's a character to process) {
1096 handle transliteration ranges
1097 skip regexp comments
1098 skip # initiated comments in //x patterns
1099 check for embedded @foo
1100 check for embedded scalars
1102 leave intact backslashes from leave (below)
1103 deprecate \1 in strings and sub replacements
1104 handle string-changing backslashes \l \U \Q \E, etc.
1105 switch (what was escaped) {
1106 handle - in a transliteration (becomes a literal -)
1107 handle \132 octal characters
1108 handle 0x15 hex characters
1109 handle \cV (control V)
1110 handle printf backslashes (\f, \r, \n, etc)
1112 } (end if backslash)
1113 } (end while character to read)
1118 S_scan_const(pTHX_ char *start)
1120 register char *send = PL_bufend; /* end of the constant */
1121 SV *sv = NEWSV(93, send - start); /* sv for the constant */
1122 register char *s = start; /* start of the constant */
1123 register char *d = SvPVX(sv); /* destination for copies */
1124 bool dorange = FALSE; /* are we in a translit range? */
1126 I32 utf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op)
1127 ? (PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
1129 I32 thisutf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op)
1130 ? (PL_sublex_info.sub_op->op_private & (PL_lex_repl ?
1131 OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF))
1133 char *leaveit = /* set of acceptably-backslashed characters */
1135 ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
1138 while (s < send || dorange) {
1139 /* get transliterations out of the way (they're most literal) */
1140 if (PL_lex_inwhat == OP_TRANS) {
1141 /* expand a range A-Z to the full set of characters. AIE! */
1143 I32 i; /* current expanded character */
1144 I32 min; /* first character in range */
1145 I32 max; /* last character in range */
1147 i = d - SvPVX(sv); /* remember current offset */
1148 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
1149 d = SvPVX(sv) + i; /* refresh d after realloc */
1150 d -= 2; /* eat the first char and the - */
1152 min = (U8)*d; /* first char in range */
1153 max = (U8)d[1]; /* last char in range */
1156 if ((isLOWER(min) && isLOWER(max)) ||
1157 (isUPPER(min) && isUPPER(max))) {
1159 for (i = min; i <= max; i++)
1163 for (i = min; i <= max; i++)
1170 for (i = min; i <= max; i++)
1173 /* mark the range as done, and continue */
1178 /* range begins (ignore - as first or last char) */
1179 else if (*s == '-' && s+1 < send && s != start) {
1181 *d++ = (char)0xff; /* use illegal utf8 byte--see pmtrans */
1190 /* if we get here, we're not doing a transliteration */
1192 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
1193 except for the last char, which will be done separately. */
1194 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
1196 while (s < send && *s != ')')
1198 } else if (s[2] == '{'
1199 || s[2] == 'p' && s[3] == '{') { /* This should march regcomp.c */
1201 char *regparse = s + (s[2] == '{' ? 3 : 4);
1204 while (count && (c = *regparse)) {
1205 if (c == '\\' && regparse[1])
1213 if (*regparse != ')') {
1214 regparse--; /* Leave one char for continuation. */
1215 yyerror("Sequence (?{...}) not terminated or not {}-balanced");
1217 while (s < regparse)
1222 /* likewise skip #-initiated comments in //x patterns */
1223 else if (*s == '#' && PL_lex_inpat &&
1224 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
1225 while (s+1 < send && *s != '\n')
1229 /* check for embedded arrays (@foo, @:foo, @'foo, @{foo}, @$foo) */
1230 else if (*s == '@' && s[1] && (isALNUM_lazy(s+1) || strchr(":'{$", s[1])))
1233 /* check for embedded scalars. only stop if we're sure it's a
1236 else if (*s == '$') {
1237 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
1239 if (s + 1 < send && !strchr("()| \n\t", s[1]))
1240 break; /* in regexp, $ might be tail anchor */
1243 /* (now in tr/// code again) */
1245 if (*s & 0x80 && thisutf) {
1246 dTHR; /* only for ckWARN */
1247 if (ckWARN(WARN_UTF8)) {
1248 (void)utf8_to_uv((U8*)s, &len); /* could cvt latin-1 to utf8 here... */
1258 if (*s == '\\' && s+1 < send) {
1261 /* some backslashes we leave behind */
1262 if (*leaveit && *s && strchr(leaveit, *s)) {
1268 /* deprecate \1 in strings and substitution replacements */
1269 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1270 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1272 dTHR; /* only for ckWARN */
1273 if (ckWARN(WARN_SYNTAX))
1274 Perl_warner(aTHX_ WARN_SYNTAX, "\\%c better written as $%c", *s, *s);
1279 /* string-change backslash escapes */
1280 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1285 /* if we get here, it's either a quoted -, or a digit */
1288 /* quoted - in transliterations */
1290 if (PL_lex_inwhat == OP_TRANS) {
1298 if (ckWARN(WARN_UNSAFE) && isALPHA(*s))
1299 Perl_warner(aTHX_ WARN_UNSAFE,
1300 "Unrecognized escape \\%c passed through",
1302 /* default action is to copy the quoted character */
1307 /* \132 indicates an octal constant */
1308 case '0': case '1': case '2': case '3':
1309 case '4': case '5': case '6': case '7':
1310 *d++ = scan_oct(s, 3, &len);
1314 /* \x24 indicates a hex constant */
1318 char* e = strchr(s, '}');
1321 yyerror("Missing right brace on \\x{}");
1326 if (ckWARN(WARN_UTF8))
1327 Perl_warner(aTHX_ WARN_UTF8,
1328 "Use of \\x{} without utf8 declaration");
1330 /* note: utf always shorter than hex */
1331 d = (char*)uv_to_utf8((U8*)d,
1332 scan_hex(s + 1, e - s - 1, &len));
1336 UV uv = (UV)scan_hex(s, 2, &len);
1337 if (utf && PL_lex_inwhat == OP_TRANS &&
1338 utf != (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
1340 d = (char*)uv_to_utf8((U8*)d, uv); /* doing a CU or UC */
1343 if (uv >= 127 && UTF) {
1345 if (ckWARN(WARN_UTF8))
1346 Perl_warner(aTHX_ WARN_UTF8,
1347 "\\x%.*s will produce malformed UTF-8 character; use \\x{%.*s} for that",
1356 /* \c is a control character */
1370 /* printf-style backslashes, formfeeds, newlines, etc */
1388 *d++ = '\047'; /* CP 1047 */
1391 *d++ = '\057'; /* CP 1047 */
1405 } /* end if (backslash) */
1408 } /* while loop to process each character */
1410 /* terminate the string and set up the sv */
1412 SvCUR_set(sv, d - SvPVX(sv));
1415 /* shrink the sv if we allocated more than we used */
1416 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1417 SvLEN_set(sv, SvCUR(sv) + 1);
1418 Renew(SvPVX(sv), SvLEN(sv), char);
1421 /* return the substring (via yylval) only if we parsed anything */
1422 if (s > PL_bufptr) {
1423 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1424 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1426 ( PL_lex_inwhat == OP_TRANS
1428 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1431 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1438 * Returns TRUE if there's more to the expression (e.g., a subscript),
1441 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
1443 * ->[ and ->{ return TRUE
1444 * { and [ outside a pattern are always subscripts, so return TRUE
1445 * if we're outside a pattern and it's not { or [, then return FALSE
1446 * if we're in a pattern and the first char is a {
1447 * {4,5} (any digits around the comma) returns FALSE
1448 * if we're in a pattern and the first char is a [
1450 * [SOMETHING] has a funky algorithm to decide whether it's a
1451 * character class or not. It has to deal with things like
1452 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
1453 * anything else returns TRUE
1456 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1459 S_intuit_more(pTHX_ register char *s)
1461 if (PL_lex_brackets)
1463 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1465 if (*s != '{' && *s != '[')
1470 /* In a pattern, so maybe we have {n,m}. */
1487 /* On the other hand, maybe we have a character class */
1490 if (*s == ']' || *s == '^')
1493 /* this is terrifying, and it works */
1494 int weight = 2; /* let's weigh the evidence */
1496 unsigned char un_char = 255, last_un_char;
1497 char *send = strchr(s,']');
1498 char tmpbuf[sizeof PL_tokenbuf * 4];
1500 if (!send) /* has to be an expression */
1503 Zero(seen,256,char);
1506 else if (isDIGIT(*s)) {
1508 if (isDIGIT(s[1]) && s[2] == ']')
1514 for (; s < send; s++) {
1515 last_un_char = un_char;
1516 un_char = (unsigned char)*s;
1521 weight -= seen[un_char] * 10;
1522 if (isALNUM_lazy(s+1)) {
1523 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1524 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1529 else if (*s == '$' && s[1] &&
1530 strchr("[#!%*<>()-=",s[1])) {
1531 if (/*{*/ strchr("])} =",s[2]))
1540 if (strchr("wds]",s[1]))
1542 else if (seen['\''] || seen['"'])
1544 else if (strchr("rnftbxcav",s[1]))
1546 else if (isDIGIT(s[1])) {
1548 while (s[1] && isDIGIT(s[1]))
1558 if (strchr("aA01! ",last_un_char))
1560 if (strchr("zZ79~",s[1]))
1562 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1563 weight -= 5; /* cope with negative subscript */
1566 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1567 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1572 if (keyword(tmpbuf, d - tmpbuf))
1575 if (un_char == last_un_char + 1)
1577 weight -= seen[un_char];
1582 if (weight >= 0) /* probably a character class */
1592 * Does all the checking to disambiguate
1594 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
1595 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
1597 * First argument is the stuff after the first token, e.g. "bar".
1599 * Not a method if bar is a filehandle.
1600 * Not a method if foo is a subroutine prototyped to take a filehandle.
1601 * Not a method if it's really "Foo $bar"
1602 * Method if it's "foo $bar"
1603 * Not a method if it's really "print foo $bar"
1604 * Method if it's really "foo package::" (interpreted as package->foo)
1605 * Not a method if bar is known to be a subroutne ("sub bar; foo bar")
1606 * Not a method if bar is a filehandle or package, but is quotd with
1611 S_intuit_method(pTHX_ char *start, GV *gv)
1613 char *s = start + (*start == '$');
1614 char tmpbuf[sizeof PL_tokenbuf];
1622 if ((cv = GvCVu(gv))) {
1623 char *proto = SvPVX(cv);
1633 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1634 /* start is the beginning of the possible filehandle/object,
1635 * and s is the end of it
1636 * tmpbuf is a copy of it
1639 if (*start == '$') {
1640 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1645 return *s == '(' ? FUNCMETH : METHOD;
1647 if (!keyword(tmpbuf, len)) {
1648 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1653 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1654 if (indirgv && GvCVu(indirgv))
1656 /* filehandle or package name makes it a method */
1657 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1659 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1660 return 0; /* no assumptions -- "=>" quotes bearword */
1662 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1663 newSVpvn(tmpbuf,len));
1664 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1668 return *s == '(' ? FUNCMETH : METHOD;
1676 * Return a string of Perl code to load the debugger. If PERL5DB
1677 * is set, it will return the contents of that, otherwise a
1678 * compile-time require of perl5db.pl.
1685 char *pdb = PerlEnv_getenv("PERL5DB");
1689 SETERRNO(0,SS$_NORMAL);
1690 return "BEGIN { require 'perl5db.pl' }";
1696 /* Encoded script support. filter_add() effectively inserts a
1697 * 'pre-processing' function into the current source input stream.
1698 * Note that the filter function only applies to the current source file
1699 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1701 * The datasv parameter (which may be NULL) can be used to pass
1702 * private data to this instance of the filter. The filter function
1703 * can recover the SV using the FILTER_DATA macro and use it to
1704 * store private buffers and state information.
1706 * The supplied datasv parameter is upgraded to a PVIO type
1707 * and the IoDIRP field is used to store the function pointer.
1708 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1709 * private use must be set using malloc'd pointers.
1713 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
1715 if (!funcp){ /* temporary handy debugging hack to be deleted */
1716 PL_filter_debug = atoi((char*)datasv);
1719 if (!PL_rsfp_filters)
1720 PL_rsfp_filters = newAV();
1722 datasv = NEWSV(255,0);
1723 if (!SvUPGRADE(datasv, SVt_PVIO))
1724 Perl_die(aTHX_ "Can't upgrade filter_add data to SVt_PVIO");
1725 IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
1727 if (PL_filter_debug) {
1729 Perl_warn(aTHX_ "filter_add func %p (%s)", funcp, SvPV(datasv, n_a));
1731 #endif /* DEBUGGING */
1732 av_unshift(PL_rsfp_filters, 1);
1733 av_store(PL_rsfp_filters, 0, datasv) ;
1738 /* Delete most recently added instance of this filter function. */
1740 Perl_filter_del(pTHX_ filter_t funcp)
1743 if (PL_filter_debug)
1744 Perl_warn(aTHX_ "filter_del func %p", funcp);
1745 #endif /* DEBUGGING */
1746 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
1748 /* if filter is on top of stack (usual case) just pop it off */
1749 if (IoDIRP(FILTER_DATA(AvFILLp(PL_rsfp_filters))) == (DIR*)funcp){
1750 IoDIRP(FILTER_DATA(AvFILLp(PL_rsfp_filters))) = NULL;
1751 sv_free(av_pop(PL_rsfp_filters));
1755 /* we need to search for the correct entry and clear it */
1756 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
1760 /* Invoke the n'th filter function for the current rsfp. */
1762 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
1765 /* 0 = read one text line */
1770 if (!PL_rsfp_filters)
1772 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
1773 /* Provide a default input filter to make life easy. */
1774 /* Note that we append to the line. This is handy. */
1776 if (PL_filter_debug)
1777 Perl_warn(aTHX_ "filter_read %d: from rsfp\n", idx);
1778 #endif /* DEBUGGING */
1782 int old_len = SvCUR(buf_sv) ;
1784 /* ensure buf_sv is large enough */
1785 SvGROW(buf_sv, old_len + maxlen) ;
1786 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1787 if (PerlIO_error(PL_rsfp))
1788 return -1; /* error */
1790 return 0 ; /* end of file */
1792 SvCUR_set(buf_sv, old_len + len) ;
1795 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
1796 if (PerlIO_error(PL_rsfp))
1797 return -1; /* error */
1799 return 0 ; /* end of file */
1802 return SvCUR(buf_sv);
1804 /* Skip this filter slot if filter has been deleted */
1805 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
1807 if (PL_filter_debug)
1808 Perl_warn(aTHX_ "filter_read %d: skipped (filter deleted)\n", idx);
1809 #endif /* DEBUGGING */
1810 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1812 /* Get function pointer hidden within datasv */
1813 funcp = (filter_t)IoDIRP(datasv);
1815 if (PL_filter_debug) {
1817 Perl_warn(aTHX_ "filter_read %d: via function %p (%s)\n",
1818 idx, funcp, SvPV(datasv,n_a));
1820 #endif /* DEBUGGING */
1821 /* Call function. The function is expected to */
1822 /* call "FILTER_READ(idx+1, buf_sv)" first. */
1823 /* Return: <0:error, =0:eof, >0:not eof */
1824 return (*funcp)(aTHXo_ idx, buf_sv, maxlen);
1828 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
1831 if (!PL_rsfp_filters) {
1832 filter_add(win32_textfilter,NULL);
1835 if (PL_rsfp_filters) {
1838 SvCUR_set(sv, 0); /* start with empty line */
1839 if (FILTER_READ(0, sv, 0) > 0)
1840 return ( SvPVX(sv) ) ;
1845 return (sv_gets(sv, fp, append));
1850 static char* exp_name[] =
1851 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "TERMBLOCK" };
1857 Works out what to call the token just pulled out of the input
1858 stream. The yacc parser takes care of taking the ops we return and
1859 stitching them into a tree.
1865 if read an identifier
1866 if we're in a my declaration
1867 croak if they tried to say my($foo::bar)
1868 build the ops for a my() declaration
1869 if it's an access to a my() variable
1870 are we in a sort block?
1871 croak if my($a); $a <=> $b
1872 build ops for access to a my() variable
1873 if in a dq string, and they've said @foo and we can't find @foo
1875 build ops for a bareword
1876 if we already built the token before, use it.
1880 #ifdef USE_PURE_BISON
1881 Perl_yylex(pTHX_ YYSTYPE *lvalp, int *lcharp)
1894 #ifdef USE_PURE_BISON
1895 yylval_pointer = lvalp;
1896 yychar_pointer = lcharp;
1899 /* check if there's an identifier for us to look at */
1900 if (PL_pending_ident) {
1901 /* pit holds the identifier we read and pending_ident is reset */
1902 char pit = PL_pending_ident;
1903 PL_pending_ident = 0;
1905 /* if we're in a my(), we can't allow dynamics here.
1906 $foo'bar has already been turned into $foo::bar, so
1907 just check for colons.
1909 if it's a legal name, the OP is a PADANY.
1912 if (strchr(PL_tokenbuf,':'))
1913 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
1915 yylval.opval = newOP(OP_PADANY, 0);
1916 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
1921 build the ops for accesses to a my() variable.
1923 Deny my($a) or my($b) in a sort block, *if* $a or $b is
1924 then used in a comparison. This catches most, but not
1925 all cases. For instance, it catches
1926 sort { my($a); $a <=> $b }
1928 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
1929 (although why you'd do that is anyone's guess).
1932 if (!strchr(PL_tokenbuf,':')) {
1934 /* Check for single character per-thread SVs */
1935 if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
1936 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
1937 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
1939 yylval.opval = newOP(OP_THREADSV, 0);
1940 yylval.opval->op_targ = tmp;
1943 #endif /* USE_THREADS */
1944 if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
1945 /* if it's a sort block and they're naming $a or $b */
1946 if (PL_last_lop_op == OP_SORT &&
1947 PL_tokenbuf[0] == '$' &&
1948 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
1951 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
1952 d < PL_bufend && *d != '\n';
1955 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
1956 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
1962 yylval.opval = newOP(OP_PADANY, 0);
1963 yylval.opval->op_targ = tmp;
1969 Whine if they've said @foo in a doublequoted string,
1970 and @foo isn't a variable we can find in the symbol
1973 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
1974 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
1975 if (!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
1976 yyerror(Perl_form(aTHX_ "In string, %s now must be written as \\%s",
1977 PL_tokenbuf, PL_tokenbuf));
1980 /* build ops for a bareword */
1981 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
1982 yylval.opval->op_private = OPpCONST_ENTERED;
1983 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
1984 ((PL_tokenbuf[0] == '$') ? SVt_PV
1985 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
1990 /* no identifier pending identification */
1992 switch (PL_lex_state) {
1994 case LEX_NORMAL: /* Some compilers will produce faster */
1995 case LEX_INTERPNORMAL: /* code if we comment these out. */
1999 /* when we're already built the next token, just pull it out the queue */
2002 yylval = PL_nextval[PL_nexttoke];
2004 PL_lex_state = PL_lex_defer;
2005 PL_expect = PL_lex_expect;
2006 PL_lex_defer = LEX_NORMAL;
2008 return(PL_nexttype[PL_nexttoke]);
2010 /* interpolated case modifiers like \L \U, including \Q and \E.
2011 when we get here, PL_bufptr is at the \
2013 case LEX_INTERPCASEMOD:
2015 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
2016 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
2018 /* handle \E or end of string */
2019 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
2023 if (PL_lex_casemods) {
2024 oldmod = PL_lex_casestack[--PL_lex_casemods];
2025 PL_lex_casestack[PL_lex_casemods] = '\0';
2027 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
2029 PL_lex_state = LEX_INTERPCONCAT;
2033 if (PL_bufptr != PL_bufend)
2035 PL_lex_state = LEX_INTERPCONCAT;
2040 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
2041 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
2042 if (strchr("LU", *s) &&
2043 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
2045 PL_lex_casestack[--PL_lex_casemods] = '\0';
2048 if (PL_lex_casemods > 10) {
2049 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
2050 if (newlb != PL_lex_casestack) {
2052 PL_lex_casestack = newlb;
2055 PL_lex_casestack[PL_lex_casemods++] = *s;
2056 PL_lex_casestack[PL_lex_casemods] = '\0';
2057 PL_lex_state = LEX_INTERPCONCAT;
2058 PL_nextval[PL_nexttoke].ival = 0;
2061 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
2063 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
2065 PL_nextval[PL_nexttoke].ival = OP_LC;
2067 PL_nextval[PL_nexttoke].ival = OP_UC;
2069 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
2071 Perl_croak(aTHX_ "panic: yylex");
2074 if (PL_lex_starts) {
2083 case LEX_INTERPPUSH:
2084 return sublex_push();
2086 case LEX_INTERPSTART:
2087 if (PL_bufptr == PL_bufend)
2088 return sublex_done();
2090 PL_lex_dojoin = (*PL_bufptr == '@');
2091 PL_lex_state = LEX_INTERPNORMAL;
2092 if (PL_lex_dojoin) {
2093 PL_nextval[PL_nexttoke].ival = 0;
2096 PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
2097 PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
2098 force_next(PRIVATEREF);
2100 force_ident("\"", '$');
2101 #endif /* USE_THREADS */
2102 PL_nextval[PL_nexttoke].ival = 0;
2104 PL_nextval[PL_nexttoke].ival = 0;
2106 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
2109 if (PL_lex_starts++) {
2115 case LEX_INTERPENDMAYBE:
2116 if (intuit_more(PL_bufptr)) {
2117 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
2123 if (PL_lex_dojoin) {
2124 PL_lex_dojoin = FALSE;
2125 PL_lex_state = LEX_INTERPCONCAT;
2128 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
2129 && SvEVALED(PL_lex_repl))
2131 if (PL_bufptr != PL_bufend)
2132 Perl_croak(aTHX_ "Bad evalled substitution pattern");
2133 PL_lex_repl = Nullsv;
2136 case LEX_INTERPCONCAT:
2138 if (PL_lex_brackets)
2139 Perl_croak(aTHX_ "panic: INTERPCONCAT");
2141 if (PL_bufptr == PL_bufend)
2142 return sublex_done();
2144 if (SvIVX(PL_linestr) == '\'') {
2145 SV *sv = newSVsv(PL_linestr);
2148 else if ( PL_hints & HINT_NEW_RE )
2149 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
2150 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2154 s = scan_const(PL_bufptr);
2156 PL_lex_state = LEX_INTERPCASEMOD;
2158 PL_lex_state = LEX_INTERPSTART;
2161 if (s != PL_bufptr) {
2162 PL_nextval[PL_nexttoke] = yylval;
2165 if (PL_lex_starts++)
2175 PL_lex_state = LEX_NORMAL;
2176 s = scan_formline(PL_bufptr);
2177 if (!PL_lex_formbrack)
2183 PL_oldoldbufptr = PL_oldbufptr;
2186 PerlIO_printf(PerlIO_stderr(), "### Tokener expecting %s at %s\n", exp_name[PL_expect], s);
2192 if (isIDFIRST_lazy(s))
2194 Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
2197 goto fake_eof; /* emulate EOF on ^D or ^Z */
2202 if (PL_lex_brackets)
2203 yyerror("Missing right curly or square bracket");
2206 if (s++ < PL_bufend)
2207 goto retry; /* ignore stray nulls */
2210 if (!PL_in_eval && !PL_preambled) {
2211 PL_preambled = TRUE;
2212 sv_setpv(PL_linestr,incl_perldb());
2213 if (SvCUR(PL_linestr))
2214 sv_catpv(PL_linestr,";");
2216 while(AvFILLp(PL_preambleav) >= 0) {
2217 SV *tmpsv = av_shift(PL_preambleav);
2218 sv_catsv(PL_linestr, tmpsv);
2219 sv_catpv(PL_linestr, ";");
2222 sv_free((SV*)PL_preambleav);
2223 PL_preambleav = NULL;
2225 if (PL_minus_n || PL_minus_p) {
2226 sv_catpv(PL_linestr, "LINE: while (<>) {");
2228 sv_catpv(PL_linestr,"chomp;");
2230 GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
2232 GvIMPORTED_AV_on(gv);
2234 if (strchr("/'\"", *PL_splitstr)
2235 && strchr(PL_splitstr + 1, *PL_splitstr))
2236 Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s);", PL_splitstr);
2239 s = "'~#\200\1'"; /* surely one char is unused...*/
2240 while (s[1] && strchr(PL_splitstr, *s)) s++;
2242 Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s%c",
2243 "q" + (delim == '\''), delim);
2244 for (s = PL_splitstr; *s; s++) {
2246 sv_catpvn(PL_linestr, "\\", 1);
2247 sv_catpvn(PL_linestr, s, 1);
2249 Perl_sv_catpvf(aTHX_ PL_linestr, "%c);", delim);
2253 sv_catpv(PL_linestr,"@F=split(' ');");
2256 sv_catpv(PL_linestr, "\n");
2257 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2258 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2259 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2260 SV *sv = NEWSV(85,0);
2262 sv_upgrade(sv, SVt_PVMG);
2263 sv_setsv(sv,PL_linestr);
2264 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
2269 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
2272 if (PL_preprocess && !PL_in_eval)
2273 (void)PerlProc_pclose(PL_rsfp);
2274 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2275 PerlIO_clearerr(PL_rsfp);
2277 (void)PerlIO_close(PL_rsfp);
2279 PL_doextract = FALSE;
2281 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2282 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
2283 sv_catpv(PL_linestr,";}");
2284 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2285 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2286 PL_minus_n = PL_minus_p = 0;
2289 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2290 sv_setpv(PL_linestr,"");
2291 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
2294 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
2295 PL_doextract = FALSE;
2297 /* Incest with pod. */
2298 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2299 sv_setpv(PL_linestr, "");
2300 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2301 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2302 PL_doextract = FALSE;
2306 } while (PL_doextract);
2307 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2308 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2309 SV *sv = NEWSV(85,0);
2311 sv_upgrade(sv, SVt_PVMG);
2312 sv_setsv(sv,PL_linestr);
2313 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
2315 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2316 if (PL_curcop->cop_line == 1) {
2317 while (s < PL_bufend && isSPACE(*s))
2319 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2323 if (*s == '#' && *(s+1) == '!')
2325 #ifdef ALTERNATE_SHEBANG
2327 static char as[] = ALTERNATE_SHEBANG;
2328 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2329 d = s + (sizeof(as) - 1);
2331 #endif /* ALTERNATE_SHEBANG */
2340 while (*d && !isSPACE(*d))
2344 #ifdef ARG_ZERO_IS_SCRIPT
2345 if (ipathend > ipath) {
2347 * HP-UX (at least) sets argv[0] to the script name,
2348 * which makes $^X incorrect. And Digital UNIX and Linux,
2349 * at least, set argv[0] to the basename of the Perl
2350 * interpreter. So, having found "#!", we'll set it right.
2352 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
2353 assert(SvPOK(x) || SvGMAGICAL(x));
2354 if (sv_eq(x, GvSV(PL_curcop->cop_filegv))) {
2355 sv_setpvn(x, ipath, ipathend - ipath);
2358 TAINT_NOT; /* $^X is always tainted, but that's OK */
2360 #endif /* ARG_ZERO_IS_SCRIPT */
2365 d = instr(s,"perl -");
2367 d = instr(s,"perl");
2368 #ifdef ALTERNATE_SHEBANG
2370 * If the ALTERNATE_SHEBANG on this system starts with a
2371 * character that can be part of a Perl expression, then if
2372 * we see it but not "perl", we're probably looking at the
2373 * start of Perl code, not a request to hand off to some
2374 * other interpreter. Similarly, if "perl" is there, but
2375 * not in the first 'word' of the line, we assume the line
2376 * contains the start of the Perl program.
2378 if (d && *s != '#') {
2380 while (*c && !strchr("; \t\r\n\f\v#", *c))
2383 d = Nullch; /* "perl" not in first word; ignore */
2385 *s = '#'; /* Don't try to parse shebang line */
2387 #endif /* ALTERNATE_SHEBANG */
2392 !instr(s,"indir") &&
2393 instr(PL_origargv[0],"perl"))
2399 while (s < PL_bufend && isSPACE(*s))
2401 if (s < PL_bufend) {
2402 Newz(899,newargv,PL_origargc+3,char*);
2404 while (s < PL_bufend && !isSPACE(*s))
2407 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2410 newargv = PL_origargv;
2412 PerlProc_execv(ipath, newargv);
2413 Perl_croak(aTHX_ "Can't exec %s", ipath);
2416 U32 oldpdb = PL_perldb;
2417 bool oldn = PL_minus_n;
2418 bool oldp = PL_minus_p;
2420 while (*d && !isSPACE(*d)) d++;
2421 while (*d == ' ' || *d == '\t') d++;
2425 if (*d == 'M' || *d == 'm') {
2427 while (*d && !isSPACE(*d)) d++;
2428 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2431 d = moreswitches(d);
2433 if (PERLDB_LINE && !oldpdb ||
2434 ( PL_minus_n || PL_minus_p ) && !(oldn || oldp) )
2435 /* if we have already added "LINE: while (<>) {",
2436 we must not do it again */
2438 sv_setpv(PL_linestr, "");
2439 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2440 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2441 PL_preambled = FALSE;
2443 (void)gv_fetchfile(PL_origfilename);
2450 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2452 PL_lex_state = LEX_FORMLINE;
2457 #ifdef PERL_STRICT_CR
2458 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2460 "(Maybe you didn't strip carriage returns after a network transfer?)\n");
2462 case ' ': case '\t': case '\f': case 013:
2467 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2469 while (s < d && *s != '\n')
2474 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2476 PL_lex_state = LEX_FORMLINE;
2486 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2491 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2494 if (strnEQ(s,"=>",2)) {
2495 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2496 OPERATOR('-'); /* unary minus */
2498 PL_last_uni = PL_oldbufptr;
2499 PL_last_lop_op = OP_FTEREAD; /* good enough */
2501 case 'r': FTST(OP_FTEREAD);
2502 case 'w': FTST(OP_FTEWRITE);
2503 case 'x': FTST(OP_FTEEXEC);
2504 case 'o': FTST(OP_FTEOWNED);
2505 case 'R': FTST(OP_FTRREAD);
2506 case 'W': FTST(OP_FTRWRITE);
2507 case 'X': FTST(OP_FTREXEC);
2508 case 'O': FTST(OP_FTROWNED);
2509 case 'e': FTST(OP_FTIS);
2510 case 'z': FTST(OP_FTZERO);
2511 case 's': FTST(OP_FTSIZE);
2512 case 'f': FTST(OP_FTFILE);
2513 case 'd': FTST(OP_FTDIR);
2514 case 'l': FTST(OP_FTLINK);
2515 case 'p': FTST(OP_FTPIPE);
2516 case 'S': FTST(OP_FTSOCK);
2517 case 'u': FTST(OP_FTSUID);
2518 case 'g': FTST(OP_FTSGID);
2519 case 'k': FTST(OP_FTSVTX);
2520 case 'b': FTST(OP_FTBLK);
2521 case 'c': FTST(OP_FTCHR);
2522 case 't': FTST(OP_FTTTY);
2523 case 'T': FTST(OP_FTTEXT);
2524 case 'B': FTST(OP_FTBINARY);
2525 case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2526 case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2527 case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
2529 Perl_croak(aTHX_ "Unrecognized file test: -%c", (int)tmp);
2536 if (PL_expect == XOPERATOR)
2541 else if (*s == '>') {
2544 if (isIDFIRST_lazy(s)) {
2545 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2553 if (PL_expect == XOPERATOR)
2556 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2558 OPERATOR('-'); /* unary minus */
2565 if (PL_expect == XOPERATOR)
2570 if (PL_expect == XOPERATOR)
2573 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2579 if (PL_expect != XOPERATOR) {
2580 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2581 PL_expect = XOPERATOR;
2582 force_ident(PL_tokenbuf, '*');
2595 if (PL_expect == XOPERATOR) {
2599 PL_tokenbuf[0] = '%';
2600 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2601 if (!PL_tokenbuf[1]) {
2603 yyerror("Final % should be \\% or %name");
2606 PL_pending_ident = '%';
2628 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
2629 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
2634 if (PL_curcop->cop_line < PL_copline)
2635 PL_copline = PL_curcop->cop_line;
2646 if (PL_lex_brackets <= 0)
2647 yyerror("Unmatched right square bracket");
2650 if (PL_lex_state == LEX_INTERPNORMAL) {
2651 if (PL_lex_brackets == 0) {
2652 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
2653 PL_lex_state = LEX_INTERPEND;
2660 if (PL_lex_brackets > 100) {
2661 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
2662 if (newlb != PL_lex_brackstack) {
2664 PL_lex_brackstack = newlb;
2667 switch (PL_expect) {
2669 if (PL_lex_formbrack) {
2673 if (PL_oldoldbufptr == PL_last_lop)
2674 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2676 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2677 OPERATOR(HASHBRACK);
2679 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2682 PL_tokenbuf[0] = '\0';
2683 if (d < PL_bufend && *d == '-') {
2684 PL_tokenbuf[0] = '-';
2686 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2689 if (d < PL_bufend && isIDFIRST_lazy(d)) {
2690 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2692 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2695 char minus = (PL_tokenbuf[0] == '-');
2696 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2703 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
2707 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2712 if (PL_oldoldbufptr == PL_last_lop)
2713 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2715 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2718 OPERATOR(HASHBRACK);
2719 /* This hack serves to disambiguate a pair of curlies
2720 * as being a block or an anon hash. Normally, expectation
2721 * determines that, but in cases where we're not in a
2722 * position to expect anything in particular (like inside
2723 * eval"") we have to resolve the ambiguity. This code
2724 * covers the case where the first term in the curlies is a
2725 * quoted string. Most other cases need to be explicitly
2726 * disambiguated by prepending a `+' before the opening
2727 * curly in order to force resolution as an anon hash.
2729 * XXX should probably propagate the outer expectation
2730 * into eval"" to rely less on this hack, but that could
2731 * potentially break current behavior of eval"".
2735 if (*s == '\'' || *s == '"' || *s == '`') {
2736 /* common case: get past first string, handling escapes */
2737 for (t++; t < PL_bufend && *t != *s;)
2738 if (*t++ == '\\' && (*t == '\\' || *t == *s))
2742 else if (*s == 'q') {
2745 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
2746 && !isALNUM(*t)))) {
2748 char open, close, term;
2751 while (t < PL_bufend && isSPACE(*t))
2755 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
2759 for (t++; t < PL_bufend; t++) {
2760 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
2762 else if (*t == open)
2766 for (t++; t < PL_bufend; t++) {
2767 if (*t == '\\' && t+1 < PL_bufend)
2769 else if (*t == close && --brackets <= 0)
2771 else if (*t == open)
2777 else if (isIDFIRST_lazy(s)) {
2778 for (t++; t < PL_bufend && isALNUM_lazy(t); t++) ;
2780 while (t < PL_bufend && isSPACE(*t))
2782 /* if comma follows first term, call it an anon hash */
2783 /* XXX it could be a comma expression with loop modifiers */
2784 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
2785 || (*t == '=' && t[1] == '>')))
2786 OPERATOR(HASHBRACK);
2787 if (PL_expect == XREF)
2790 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
2796 yylval.ival = PL_curcop->cop_line;
2797 if (isSPACE(*s) || *s == '#')
2798 PL_copline = NOLINE; /* invalidate current command line number */
2803 if (PL_lex_brackets <= 0)
2804 yyerror("Unmatched right curly bracket");
2806 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
2807 if (PL_lex_brackets < PL_lex_formbrack)
2808 PL_lex_formbrack = 0;
2809 if (PL_lex_state == LEX_INTERPNORMAL) {
2810 if (PL_lex_brackets == 0) {
2811 if (PL_lex_fakebrack) {
2812 PL_lex_state = LEX_INTERPEND;
2814 return yylex(); /* ignore fake brackets */
2816 if (*s == '-' && s[1] == '>')
2817 PL_lex_state = LEX_INTERPENDMAYBE;
2818 else if (*s != '[' && *s != '{')
2819 PL_lex_state = LEX_INTERPEND;
2822 if (PL_lex_brackets < PL_lex_fakebrack) {
2824 PL_lex_fakebrack = 0;
2825 return yylex(); /* ignore fake brackets */
2835 if (PL_expect == XOPERATOR) {
2836 if (ckWARN(WARN_SEMICOLON) && isIDFIRST_lazy(s) && PL_bufptr == PL_linestart) {
2837 PL_curcop->cop_line--;
2838 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
2839 PL_curcop->cop_line++;
2844 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2846 PL_expect = XOPERATOR;
2847 force_ident(PL_tokenbuf, '&');
2851 yylval.ival = (OPpENTERSUB_AMPER<<8);
2870 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
2871 Perl_warner(aTHX_ WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
2873 if (PL_expect == XSTATE && isALPHA(tmp) &&
2874 (s == PL_linestart+1 || s[-2] == '\n') )
2876 if (PL_in_eval && !PL_rsfp) {
2881 if (strnEQ(s,"=cut",4)) {
2895 PL_doextract = TRUE;
2898 if (PL_lex_brackets < PL_lex_formbrack) {
2900 #ifdef PERL_STRICT_CR
2901 for (t = s; *t == ' ' || *t == '\t'; t++) ;
2903 for (t = s; *t == ' ' || *t == '\t' || *t == '\r'; t++) ;
2905 if (*t == '\n' || *t == '#') {
2923 if (PL_expect != XOPERATOR) {
2924 if (s[1] != '<' && !strchr(s,'>'))
2927 s = scan_heredoc(s);
2929 s = scan_inputsymbol(s);
2930 TERM(sublex_start());
2935 SHop(OP_LEFT_SHIFT);
2949 SHop(OP_RIGHT_SHIFT);
2958 if (PL_expect == XOPERATOR) {
2959 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2962 return ','; /* grandfather non-comma-format format */
2966 if (s[1] == '#' && (isIDFIRST_lazy(s+2) || strchr("{$:+-", s[2]))) {
2967 PL_tokenbuf[0] = '@';
2968 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
2969 sizeof PL_tokenbuf - 1, FALSE);
2970 if (PL_expect == XOPERATOR)
2971 no_op("Array length", s);
2972 if (!PL_tokenbuf[1])
2974 PL_expect = XOPERATOR;
2975 PL_pending_ident = '#';
2979 PL_tokenbuf[0] = '$';
2980 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
2981 sizeof PL_tokenbuf - 1, FALSE);
2982 if (PL_expect == XOPERATOR)
2984 if (!PL_tokenbuf[1]) {
2986 yyerror("Final $ should be \\$ or $name");
2990 /* This kludge not intended to be bulletproof. */
2991 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
2992 yylval.opval = newSVOP(OP_CONST, 0,
2993 newSViv((IV)PL_compiling.cop_arybase));
2994 yylval.opval->op_private = OPpCONST_ARYBASE;
3000 if (PL_lex_state == LEX_NORMAL)
3003 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3006 PL_tokenbuf[0] = '@';
3007 if (ckWARN(WARN_SYNTAX)) {
3009 isSPACE(*t) || isALNUM_lazy(t) || *t == '$';
3012 PL_bufptr = skipspace(PL_bufptr);
3013 while (t < PL_bufend && *t != ']')
3015 Perl_warner(aTHX_ WARN_SYNTAX,
3016 "Multidimensional syntax %.*s not supported",
3017 (t - PL_bufptr) + 1, PL_bufptr);
3021 else if (*s == '{') {
3022 PL_tokenbuf[0] = '%';
3023 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
3024 (t = strchr(s, '}')) && (t = strchr(t, '=')))
3026 char tmpbuf[sizeof PL_tokenbuf];
3028 for (t++; isSPACE(*t); t++) ;
3029 if (isIDFIRST_lazy(t)) {
3030 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
3031 for (; isSPACE(*t); t++) ;
3032 if (*t == ';' && get_cv(tmpbuf, FALSE))
3033 Perl_warner(aTHX_ WARN_SYNTAX,
3034 "You need to quote \"%s\"", tmpbuf);
3040 PL_expect = XOPERATOR;
3041 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3042 bool islop = (PL_last_lop == PL_oldoldbufptr);
3043 if (!islop || PL_last_lop_op == OP_GREPSTART)
3044 PL_expect = XOPERATOR;
3045 else if (strchr("$@\"'`q", *s))
3046 PL_expect = XTERM; /* e.g. print $fh "foo" */
3047 else if (strchr("&*<%", *s) && isIDFIRST_lazy(s+1))
3048 PL_expect = XTERM; /* e.g. print $fh &sub */
3049 else if (isIDFIRST_lazy(s)) {
3050 char tmpbuf[sizeof PL_tokenbuf];
3051 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3052 if (tmp = keyword(tmpbuf, len)) {
3053 /* binary operators exclude handle interpretations */
3065 PL_expect = XTERM; /* e.g. print $fh length() */
3070 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
3071 if (gv && GvCVu(gv))
3072 PL_expect = XTERM; /* e.g. print $fh subr() */
3075 else if (isDIGIT(*s))
3076 PL_expect = XTERM; /* e.g. print $fh 3 */
3077 else if (*s == '.' && isDIGIT(s[1]))
3078 PL_expect = XTERM; /* e.g. print $fh .3 */
3079 else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
3080 PL_expect = XTERM; /* e.g. print $fh -1 */
3081 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3082 PL_expect = XTERM; /* print $fh <<"EOF" */
3084 PL_pending_ident = '$';
3088 if (PL_expect == XOPERATOR)
3090 PL_tokenbuf[0] = '@';
3091 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3092 if (!PL_tokenbuf[1]) {
3094 yyerror("Final @ should be \\@ or @name");
3097 if (PL_lex_state == LEX_NORMAL)
3099 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3101 PL_tokenbuf[0] = '%';
3103 /* Warn about @ where they meant $. */
3104 if (ckWARN(WARN_SYNTAX)) {
3105 if (*s == '[' || *s == '{') {
3107 while (*t && (isALNUM_lazy(t) || strchr(" \t$#+-'\"", *t)))
3109 if (*t == '}' || *t == ']') {
3111 PL_bufptr = skipspace(PL_bufptr);
3112 Perl_warner(aTHX_ WARN_SYNTAX,
3113 "Scalar value %.*s better written as $%.*s",
3114 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
3119 PL_pending_ident = '@';
3122 case '/': /* may either be division or pattern */
3123 case '?': /* may either be conditional or pattern */
3124 if (PL_expect != XOPERATOR) {
3125 /* Disable warning on "study /blah/" */
3126 if (PL_oldoldbufptr == PL_last_uni
3127 && (*PL_last_uni != 's' || s - PL_last_uni < 5
3128 || memNE(PL_last_uni, "study", 5) || isALNUM_lazy(PL_last_uni+5)))
3130 s = scan_pat(s,OP_MATCH);
3131 TERM(sublex_start());
3139 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3140 #ifdef PERL_STRICT_CR
3143 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3145 && (s == PL_linestart || s[-1] == '\n') )
3147 PL_lex_formbrack = 0;
3151 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
3157 yylval.ival = OPf_SPECIAL;
3163 if (PL_expect != XOPERATOR)
3168 case '0': case '1': case '2': case '3': case '4':
3169 case '5': case '6': case '7': case '8': case '9':
3171 if (PL_expect == XOPERATOR)
3177 if (PL_expect == XOPERATOR) {
3178 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3181 return ','; /* grandfather non-comma-format format */
3187 missingterm((char*)0);
3188 yylval.ival = OP_CONST;
3189 TERM(sublex_start());
3193 if (PL_expect == XOPERATOR) {
3194 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3197 return ','; /* grandfather non-comma-format format */
3203 missingterm((char*)0);
3204 yylval.ival = OP_CONST;
3205 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
3206 if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
3207 yylval.ival = OP_STRINGIFY;
3211 TERM(sublex_start());
3215 if (PL_expect == XOPERATOR)
3216 no_op("Backticks",s);
3218 missingterm((char*)0);
3219 yylval.ival = OP_BACKTICK;
3221 TERM(sublex_start());
3225 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
3226 Perl_warner(aTHX_ WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
3228 if (PL_expect == XOPERATOR)
3229 no_op("Backslash",s);
3233 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
3273 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3275 /* Some keywords can be followed by any delimiter, including ':' */
3276 tmp = (len == 1 && strchr("msyq", PL_tokenbuf[0]) ||
3277 len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
3278 (PL_tokenbuf[0] == 'q' &&
3279 strchr("qwxr", PL_tokenbuf[1]))));
3281 /* x::* is just a word, unless x is "CORE" */
3282 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
3286 while (d < PL_bufend && isSPACE(*d))
3287 d++; /* no comments skipped here, or s### is misparsed */
3289 /* Is this a label? */
3290 if (!tmp && PL_expect == XSTATE
3291 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
3293 yylval.pval = savepv(PL_tokenbuf);
3298 /* Check for keywords */
3299 tmp = keyword(PL_tokenbuf, len);
3301 /* Is this a word before a => operator? */
3302 if (strnEQ(d,"=>",2)) {
3304 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
3305 yylval.opval->op_private = OPpCONST_BARE;
3309 if (tmp < 0) { /* second-class keyword? */
3310 GV *ogv = Nullgv; /* override (winner) */
3311 GV *hgv = Nullgv; /* hidden (loser) */
3312 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3314 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3317 if (GvIMPORTED_CV(gv))
3319 else if (! CvMETHOD(cv))
3323 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3324 (gv = *gvp) != (GV*)&PL_sv_undef &&
3325 GvCVu(gv) && GvIMPORTED_CV(gv))
3331 tmp = 0; /* overridden by import or by GLOBAL */
3334 && -tmp==KEY_lock /* XXX generalizable kludge */
3335 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3337 tmp = 0; /* any sub overrides "weak" keyword */
3339 else { /* no override */
3343 if (ckWARN(WARN_AMBIGUOUS) && hgv
3344 && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3345 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3346 "Ambiguous call resolved as CORE::%s(), %s",
3347 GvENAME(hgv), "qualify as such or use &");
3354 default: /* not a keyword */
3357 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3359 /* Get the rest if it looks like a package qualifier */
3361 if (*s == '\'' || *s == ':' && s[1] == ':') {
3363 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3366 Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
3367 *s == '\'' ? "'" : "::");
3371 if (PL_expect == XOPERATOR) {
3372 if (PL_bufptr == PL_linestart) {
3373 PL_curcop->cop_line--;
3374 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3375 PL_curcop->cop_line++;
3378 no_op("Bareword",s);
3381 /* Look for a subroutine with this name in current package,
3382 unless name is "Foo::", in which case Foo is a bearword
3383 (and a package name). */
3386 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3388 if (ckWARN(WARN_UNSAFE) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3389 Perl_warner(aTHX_ WARN_UNSAFE,
3390 "Bareword \"%s\" refers to nonexistent package",
3393 PL_tokenbuf[len] = '\0';
3400 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3403 /* if we saw a global override before, get the right name */
3406 sv = newSVpvn("CORE::GLOBAL::",14);
3407 sv_catpv(sv,PL_tokenbuf);
3410 sv = newSVpv(PL_tokenbuf,0);
3412 /* Presume this is going to be a bareword of some sort. */
3415 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3416 yylval.opval->op_private = OPpCONST_BARE;
3418 /* And if "Foo::", then that's what it certainly is. */
3423 /* See if it's the indirect object for a list operator. */
3425 if (PL_oldoldbufptr &&
3426 PL_oldoldbufptr < PL_bufptr &&
3427 (PL_oldoldbufptr == PL_last_lop || PL_oldoldbufptr == PL_last_uni) &&
3428 /* NO SKIPSPACE BEFORE HERE! */
3429 (PL_expect == XREF ||
3430 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
3432 bool immediate_paren = *s == '(';
3434 /* (Now we can afford to cross potential line boundary.) */
3437 /* Two barewords in a row may indicate method call. */
3439 if ((isIDFIRST_lazy(s) || *s == '$') && (tmp=intuit_method(s,gv)))
3442 /* If not a declared subroutine, it's an indirect object. */
3443 /* (But it's an indir obj regardless for sort.) */
3445 if ((PL_last_lop_op == OP_SORT ||
3446 (!immediate_paren && (!gv || !GvCVu(gv)))) &&
3447 (PL_last_lop_op != OP_MAPSTART &&
3448 PL_last_lop_op != OP_GREPSTART))
3450 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3455 /* If followed by a paren, it's certainly a subroutine. */
3457 PL_expect = XOPERATOR;
3461 if (gv && GvCVu(gv)) {
3462 for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
3463 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
3468 PL_nextval[PL_nexttoke].opval = yylval.opval;
3469 PL_expect = XOPERATOR;
3475 /* If followed by var or block, call it a method (unless sub) */
3477 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3478 PL_last_lop = PL_oldbufptr;
3479 PL_last_lop_op = OP_METHOD;
3483 /* If followed by a bareword, see if it looks like indir obj. */
3485 if ((isIDFIRST_lazy(s) || *s == '$') && (tmp = intuit_method(s,gv)))
3488 /* Not a method, so call it a subroutine (if defined) */
3490 if (gv && GvCVu(gv)) {
3492 if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
3493 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3494 "Ambiguous use of -%s resolved as -&%s()",
3495 PL_tokenbuf, PL_tokenbuf);
3496 /* Check for a constant sub */
3498 if ((sv = cv_const_sv(cv))) {
3500 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3501 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3502 yylval.opval->op_private = 0;
3506 /* Resolve to GV now. */
3507 op_free(yylval.opval);
3508 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3509 yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
3510 PL_last_lop = PL_oldbufptr;
3511 PL_last_lop_op = OP_ENTERSUB;
3512 /* Is there a prototype? */
3515 char *proto = SvPV((SV*)cv, len);
3518 if (strEQ(proto, "$"))
3520 if (*proto == '&' && *s == '{') {
3521 sv_setpv(PL_subname,"__ANON__");
3525 PL_nextval[PL_nexttoke].opval = yylval.opval;
3531 /* Call it a bare word */
3533 if (PL_hints & HINT_STRICT_SUBS)
3534 yylval.opval->op_private |= OPpCONST_STRICT;
3537 if (ckWARN(WARN_RESERVED)) {
3538 if (lastchar != '-') {
3539 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3541 Perl_warner(aTHX_ WARN_RESERVED, PL_warn_reserved,
3548 if (lastchar && strchr("*%&", lastchar) && ckWARN_d(WARN_AMBIGUOUS)) {
3549 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3550 "Operator or semicolon missing before %c%s",
3551 lastchar, PL_tokenbuf);
3552 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3553 "Ambiguous use of %c resolved as operator %c",
3554 lastchar, lastchar);
3560 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3561 newSVsv(GvSV(PL_curcop->cop_filegv)));
3566 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3567 Perl_newSVpvf(aTHX_ "%" PERL_PRId64, (IV)PL_curcop->cop_line));
3569 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3570 Perl_newSVpvf(aTHX_ "%ld", (long)PL_curcop->cop_line));
3574 case KEY___PACKAGE__:
3575 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3577 ? newSVsv(PL_curstname)
3586 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3587 char *pname = "main";
3588 if (PL_tokenbuf[2] == 'D')
3589 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3590 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
3593 GvIOp(gv) = newIO();
3594 IoIFP(GvIOp(gv)) = PL_rsfp;
3595 #if defined(HAS_FCNTL) && defined(F_SETFD)
3597 int fd = PerlIO_fileno(PL_rsfp);
3598 fcntl(fd,F_SETFD,fd >= 3);
3601 /* Mark this internal pseudo-handle as clean */
3602 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3604 IoTYPE(GvIOp(gv)) = '|';
3605 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
3606 IoTYPE(GvIOp(gv)) = '-';
3608 IoTYPE(GvIOp(gv)) = '<';
3619 if (PL_expect == XSTATE) {
3626 if (*s == ':' && s[1] == ':') {
3629 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3630 tmp = keyword(PL_tokenbuf, len);
3644 LOP(OP_ACCEPT,XTERM);
3650 LOP(OP_ATAN2,XTERM);
3659 LOP(OP_BLESS,XTERM);
3668 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
3685 if (!PL_cryptseen++)
3688 LOP(OP_CRYPT,XTERM);
3691 if (ckWARN(WARN_OCTAL)) {
3692 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
3693 if (*d != '0' && isDIGIT(*d))
3694 yywarn("chmod: mode argument is missing initial 0");
3696 LOP(OP_CHMOD,XTERM);
3699 LOP(OP_CHOWN,XTERM);
3702 LOP(OP_CONNECT,XTERM);
3718 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3722 PL_hints |= HINT_BLOCK_SCOPE;
3732 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3733 LOP(OP_DBMOPEN,XTERM);
3739 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3746 yylval.ival = PL_curcop->cop_line;
3760 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
3761 UNIBRACK(OP_ENTEREVAL);
3776 case KEY_endhostent:
3782 case KEY_endservent:
3785 case KEY_endprotoent:
3796 yylval.ival = PL_curcop->cop_line;
3798 if (PL_expect == XSTATE && isIDFIRST_lazy(s)) {
3800 if ((PL_bufend - p) >= 3 &&
3801 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3804 if (isIDFIRST_lazy(p))
3805 Perl_croak(aTHX_ "Missing $ on loop variable");
3810 LOP(OP_FORMLINE,XTERM);
3816 LOP(OP_FCNTL,XTERM);
3822 LOP(OP_FLOCK,XTERM);
3831 LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
3834 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3849 case KEY_getpriority:
3850 LOP(OP_GETPRIORITY,XTERM);
3852 case KEY_getprotobyname:
3855 case KEY_getprotobynumber:
3856 LOP(OP_GPBYNUMBER,XTERM);
3858 case KEY_getprotoent:
3870 case KEY_getpeername:
3871 UNI(OP_GETPEERNAME);
3873 case KEY_gethostbyname:
3876 case KEY_gethostbyaddr:
3877 LOP(OP_GHBYADDR,XTERM);
3879 case KEY_gethostent:
3882 case KEY_getnetbyname:
3885 case KEY_getnetbyaddr:
3886 LOP(OP_GNBYADDR,XTERM);
3891 case KEY_getservbyname:
3892 LOP(OP_GSBYNAME,XTERM);
3894 case KEY_getservbyport:
3895 LOP(OP_GSBYPORT,XTERM);
3897 case KEY_getservent:
3900 case KEY_getsockname:
3901 UNI(OP_GETSOCKNAME);
3903 case KEY_getsockopt:
3904 LOP(OP_GSOCKOPT,XTERM);
3926 yylval.ival = PL_curcop->cop_line;
3930 LOP(OP_INDEX,XTERM);
3936 LOP(OP_IOCTL,XTERM);
3948 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3979 LOP(OP_LISTEN,XTERM);
3988 s = scan_pat(s,OP_MATCH);
3989 TERM(sublex_start());
3992 LOP(OP_MAPSTART, *s == '(' ? XTERM : XREF);
3995 LOP(OP_MKDIR,XTERM);
3998 LOP(OP_MSGCTL,XTERM);
4001 LOP(OP_MSGGET,XTERM);
4004 LOP(OP_MSGRCV,XTERM);
4007 LOP(OP_MSGSND,XTERM);
4012 if (isIDFIRST_lazy(s)) {
4013 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
4014 PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
4015 if (!PL_in_my_stash) {
4018 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
4025 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4032 if (PL_expect != XSTATE)
4033 yyerror("\"no\" not allowed in expression");
4034 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4035 s = force_version(s);
4044 if (isIDFIRST_lazy(s)) {
4046 for (d = s; isALNUM_lazy(d); d++) ;
4048 if (strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_AMBIGUOUS))
4049 Perl_warner(aTHX_ WARN_AMBIGUOUS,
4050 "Precedence problem: open %.*s should be open(%.*s)",
4056 yylval.ival = OP_OR;
4066 LOP(OP_OPEN_DIR,XTERM);
4069 checkcomma(s,PL_tokenbuf,"filehandle");
4073 checkcomma(s,PL_tokenbuf,"filehandle");
4092 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4096 LOP(OP_PIPE_OP,XTERM);
4101 missingterm((char*)0);
4102 yylval.ival = OP_CONST;
4103 TERM(sublex_start());
4111 missingterm((char*)0);
4113 if (SvCUR(PL_lex_stuff)) {
4116 d = SvPV_force(PL_lex_stuff, len);
4118 for (; isSPACE(*d) && len; --len, ++d) ;
4121 if (!warned && ckWARN(WARN_SYNTAX)) {
4122 for (; !isSPACE(*d) && len; --len, ++d) {
4124 Perl_warner(aTHX_ WARN_SYNTAX,
4125 "Possible attempt to separate words with commas");
4128 else if (*d == '#') {
4129 Perl_warner(aTHX_ WARN_SYNTAX,
4130 "Possible attempt to put comments in qw() list");
4136 for (; !isSPACE(*d) && len; --len, ++d) ;
4138 words = append_elem(OP_LIST, words,
4139 newSVOP(OP_CONST, 0, newSVpvn(b, d-b)));
4143 PL_nextval[PL_nexttoke].opval = words;
4148 SvREFCNT_dec(PL_lex_stuff);
4149 PL_lex_stuff = Nullsv;
4156 missingterm((char*)0);
4157 yylval.ival = OP_STRINGIFY;
4158 if (SvIVX(PL_lex_stuff) == '\'')
4159 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
4160 TERM(sublex_start());
4163 s = scan_pat(s,OP_QR);
4164 TERM(sublex_start());
4169 missingterm((char*)0);
4170 yylval.ival = OP_BACKTICK;
4172 TERM(sublex_start());
4178 *PL_tokenbuf = '\0';
4179 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4180 if (isIDFIRST_lazy(PL_tokenbuf))
4181 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
4183 yyerror("<> should be quotes");
4190 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4194 LOP(OP_RENAME,XTERM);
4203 LOP(OP_RINDEX,XTERM);
4226 LOP(OP_REVERSE,XTERM);
4237 TERM(sublex_start());
4239 TOKEN(1); /* force error */
4248 LOP(OP_SELECT,XTERM);
4254 LOP(OP_SEMCTL,XTERM);
4257 LOP(OP_SEMGET,XTERM);
4260 LOP(OP_SEMOP,XTERM);
4266 LOP(OP_SETPGRP,XTERM);
4268 case KEY_setpriority:
4269 LOP(OP_SETPRIORITY,XTERM);
4271 case KEY_sethostent:
4277 case KEY_setservent:
4280 case KEY_setprotoent:
4290 LOP(OP_SEEKDIR,XTERM);
4292 case KEY_setsockopt:
4293 LOP(OP_SSOCKOPT,XTERM);
4299 LOP(OP_SHMCTL,XTERM);
4302 LOP(OP_SHMGET,XTERM);
4305 LOP(OP_SHMREAD,XTERM);
4308 LOP(OP_SHMWRITE,XTERM);
4311 LOP(OP_SHUTDOWN,XTERM);
4320 LOP(OP_SOCKET,XTERM);
4322 case KEY_socketpair:
4323 LOP(OP_SOCKPAIR,XTERM);
4326 checkcomma(s,PL_tokenbuf,"subroutine name");
4328 if (*s == ';' || *s == ')') /* probably a close */
4329 Perl_croak(aTHX_ "sort is now a reserved word");
4331 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4335 LOP(OP_SPLIT,XTERM);
4338 LOP(OP_SPRINTF,XTERM);
4341 LOP(OP_SPLICE,XTERM);
4357 LOP(OP_SUBSTR,XTERM);
4364 if (isIDFIRST_lazy(s) || *s == '\'' || *s == ':') {
4365 char tmpbuf[sizeof PL_tokenbuf];
4367 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4368 if (strchr(tmpbuf, ':'))
4369 sv_setpv(PL_subname, tmpbuf);
4371 sv_setsv(PL_subname,PL_curstname);
4372 sv_catpvn(PL_subname,"::",2);
4373 sv_catpvn(PL_subname,tmpbuf,len);
4375 s = force_word(s,WORD,FALSE,TRUE,TRUE);
4379 PL_expect = XTERMBLOCK;
4380 sv_setpv(PL_subname,"?");
4383 if (tmp == KEY_format) {
4386 PL_lex_formbrack = PL_lex_brackets + 1;
4390 /* Look for a prototype */
4397 SvREFCNT_dec(PL_lex_stuff);
4398 PL_lex_stuff = Nullsv;
4399 Perl_croak(aTHX_ "Prototype not terminated");
4402 d = SvPVX(PL_lex_stuff);
4404 for (p = d; *p; ++p) {
4409 SvCUR(PL_lex_stuff) = tmp;
4412 PL_nextval[1] = PL_nextval[0];
4413 PL_nexttype[1] = PL_nexttype[0];
4414 PL_nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4415 PL_nexttype[0] = THING;
4416 if (PL_nexttoke == 1) {
4417 PL_lex_defer = PL_lex_state;
4418 PL_lex_expect = PL_expect;
4419 PL_lex_state = LEX_KNOWNEXT;
4421 PL_lex_stuff = Nullsv;
4424 if (*SvPV(PL_subname,n_a) == '?') {
4425 sv_setpv(PL_subname,"__ANON__");
4432 LOP(OP_SYSTEM,XREF);
4435 LOP(OP_SYMLINK,XTERM);
4438 LOP(OP_SYSCALL,XTERM);
4441 LOP(OP_SYSOPEN,XTERM);
4444 LOP(OP_SYSSEEK,XTERM);
4447 LOP(OP_SYSREAD,XTERM);
4450 LOP(OP_SYSWRITE,XTERM);
4454 TERM(sublex_start());
4475 LOP(OP_TRUNCATE,XTERM);
4487 yylval.ival = PL_curcop->cop_line;
4491 yylval.ival = PL_curcop->cop_line;
4495 LOP(OP_UNLINK,XTERM);
4501 LOP(OP_UNPACK,XTERM);
4504 LOP(OP_UTIME,XTERM);
4507 if (ckWARN(WARN_OCTAL)) {
4508 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4509 if (*d != '0' && isDIGIT(*d))
4510 yywarn("umask: argument is missing initial 0");
4515 LOP(OP_UNSHIFT,XTERM);
4518 if (PL_expect != XSTATE)
4519 yyerror("\"use\" not allowed in expression");
4522 s = force_version(s);
4523 if(*s == ';' || (s = skipspace(s), *s == ';')) {
4524 PL_nextval[PL_nexttoke].opval = Nullop;
4529 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4530 s = force_version(s);
4543 yylval.ival = PL_curcop->cop_line;
4547 PL_hints |= HINT_BLOCK_SCOPE;
4554 LOP(OP_WAITPID,XTERM);
4562 static char ctl_l[2];
4564 if (ctl_l[0] == '\0')
4565 ctl_l[0] = toCTRL('L');
4566 gv_fetchpv(ctl_l,TRUE, SVt_PV);
4569 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
4574 if (PL_expect == XOPERATOR)
4580 yylval.ival = OP_XOR;
4585 TERM(sublex_start());
4591 Perl_keyword(pTHX_ register char *d, I32 len)
4596 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
4597 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
4598 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
4599 if (strEQ(d,"__DATA__")) return KEY___DATA__;
4600 if (strEQ(d,"__END__")) return KEY___END__;
4604 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
4609 if (strEQ(d,"and")) return -KEY_and;
4610 if (strEQ(d,"abs")) return -KEY_abs;
4613 if (strEQ(d,"alarm")) return -KEY_alarm;
4614 if (strEQ(d,"atan2")) return -KEY_atan2;
4617 if (strEQ(d,"accept")) return -KEY_accept;
4622 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
4625 if (strEQ(d,"bless")) return -KEY_bless;
4626 if (strEQ(d,"bind")) return -KEY_bind;
4627 if (strEQ(d,"binmode")) return -KEY_binmode;
4630 if (strEQ(d,"CORE")) return -KEY_CORE;
4635 if (strEQ(d,"cmp")) return -KEY_cmp;
4636 if (strEQ(d,"chr")) return -KEY_chr;
4637 if (strEQ(d,"cos")) return -KEY_cos;
4640 if (strEQ(d,"chop")) return KEY_chop;
4643 if (strEQ(d,"close")) return -KEY_close;
4644 if (strEQ(d,"chdir")) return -KEY_chdir;
4645 if (strEQ(d,"chomp")) return KEY_chomp;
4646 if (strEQ(d,"chmod")) return -KEY_chmod;
4647 if (strEQ(d,"chown")) return -KEY_chown;
4648 if (strEQ(d,"crypt")) return -KEY_crypt;
4651 if (strEQ(d,"chroot")) return -KEY_chroot;
4652 if (strEQ(d,"caller")) return -KEY_caller;
4655 if (strEQ(d,"connect")) return -KEY_connect;
4658 if (strEQ(d,"closedir")) return -KEY_closedir;
4659 if (strEQ(d,"continue")) return -KEY_continue;
4664 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
4669 if (strEQ(d,"do")) return KEY_do;
4672 if (strEQ(d,"die")) return -KEY_die;
4675 if (strEQ(d,"dump")) return -KEY_dump;
4678 if (strEQ(d,"delete")) return KEY_delete;
4681 if (strEQ(d,"defined")) return KEY_defined;
4682 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
4685 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
4690 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
4691 if (strEQ(d,"END")) return KEY_END;
4696 if (strEQ(d,"eq")) return -KEY_eq;
4699 if (strEQ(d,"eof")) return -KEY_eof;
4700 if (strEQ(d,"exp")) return -KEY_exp;
4703 if (strEQ(d,"else")) return KEY_else;
4704 if (strEQ(d,"exit")) return -KEY_exit;
4705 if (strEQ(d,"eval")) return KEY_eval;
4706 if (strEQ(d,"exec")) return -KEY_exec;
4707 if (strEQ(d,"each")) return KEY_each;
4710 if (strEQ(d,"elsif")) return KEY_elsif;
4713 if (strEQ(d,"exists")) return KEY_exists;
4714 if (strEQ(d,"elseif")) Perl_warn(aTHX_ "elseif should be elsif");
4717 if (strEQ(d,"endgrent")) return -KEY_endgrent;
4718 if (strEQ(d,"endpwent")) return -KEY_endpwent;
4721 if (strEQ(d,"endnetent")) return -KEY_endnetent;
4724 if (strEQ(d,"endhostent")) return -KEY_endhostent;
4725 if (strEQ(d,"endservent")) return -KEY_endservent;
4728 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
4735 if (strEQ(d,"for")) return KEY_for;
4738 if (strEQ(d,"fork")) return -KEY_fork;
4741 if (strEQ(d,"fcntl")) return -KEY_fcntl;
4742 if (strEQ(d,"flock")) return -KEY_flock;
4745 if (strEQ(d,"format")) return KEY_format;
4746 if (strEQ(d,"fileno")) return -KEY_fileno;
4749 if (strEQ(d,"foreach")) return KEY_foreach;
4752 if (strEQ(d,"formline")) return -KEY_formline;
4758 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
4759 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
4763 if (strnEQ(d,"get",3)) {
4768 if (strEQ(d,"ppid")) return -KEY_getppid;
4769 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
4772 if (strEQ(d,"pwent")) return -KEY_getpwent;
4773 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
4774 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
4777 if (strEQ(d,"peername")) return -KEY_getpeername;
4778 if (strEQ(d,"protoent")) return -KEY_getprotoent;
4779 if (strEQ(d,"priority")) return -KEY_getpriority;
4782 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
4785 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
4789 else if (*d == 'h') {
4790 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
4791 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
4792 if (strEQ(d,"hostent")) return -KEY_gethostent;
4794 else if (*d == 'n') {
4795 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
4796 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
4797 if (strEQ(d,"netent")) return -KEY_getnetent;
4799 else if (*d == 's') {
4800 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
4801 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
4802 if (strEQ(d,"servent")) return -KEY_getservent;
4803 if (strEQ(d,"sockname")) return -KEY_getsockname;
4804 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
4806 else if (*d == 'g') {
4807 if (strEQ(d,"grent")) return -KEY_getgrent;
4808 if (strEQ(d,"grnam")) return -KEY_getgrnam;
4809 if (strEQ(d,"grgid")) return -KEY_getgrgid;
4811 else if (*d == 'l') {
4812 if (strEQ(d,"login")) return -KEY_getlogin;
4814 else if (strEQ(d,"c")) return -KEY_getc;
4819 if (strEQ(d,"gt")) return -KEY_gt;
4820 if (strEQ(d,"ge")) return -KEY_ge;
4823 if (strEQ(d,"grep")) return KEY_grep;
4824 if (strEQ(d,"goto")) return KEY_goto;
4825 if (strEQ(d,"glob")) return KEY_glob;
4828 if (strEQ(d,"gmtime")) return -KEY_gmtime;
4833 if (strEQ(d,"hex")) return -KEY_hex;
4836 if (strEQ(d,"INIT")) return KEY_INIT;
4841 if (strEQ(d,"if")) return KEY_if;
4844 if (strEQ(d,"int")) return -KEY_int;
4847 if (strEQ(d,"index")) return -KEY_index;
4848 if (strEQ(d,"ioctl")) return -KEY_ioctl;
4853 if (strEQ(d,"join")) return -KEY_join;
4857 if (strEQ(d,"keys")) return KEY_keys;
4858 if (strEQ(d,"kill")) return -KEY_kill;
4863 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
4864 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
4870 if (strEQ(d,"lt")) return -KEY_lt;
4871 if (strEQ(d,"le")) return -KEY_le;
4872 if (strEQ(d,"lc")) return -KEY_lc;
4875 if (strEQ(d,"log")) return -KEY_log;
4878 if (strEQ(d,"last")) return KEY_last;
4879 if (strEQ(d,"link")) return -KEY_link;
4880 if (strEQ(d,"lock")) return -KEY_lock;
4883 if (strEQ(d,"local")) return KEY_local;
4884 if (strEQ(d,"lstat")) return -KEY_lstat;
4887 if (strEQ(d,"length")) return -KEY_length;
4888 if (strEQ(d,"listen")) return -KEY_listen;
4891 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
4894 if (strEQ(d,"localtime")) return -KEY_localtime;
4900 case 1: return KEY_m;
4902 if (strEQ(d,"my")) return KEY_my;
4905 if (strEQ(d,"map")) return KEY_map;
4908 if (strEQ(d,"mkdir")) return -KEY_mkdir;
4911 if (strEQ(d,"msgctl")) return -KEY_msgctl;
4912 if (strEQ(d,"msgget")) return -KEY_msgget;
4913 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
4914 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
4919 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
4922 if (strEQ(d,"next")) return KEY_next;
4923 if (strEQ(d,"ne")) return -KEY_ne;
4924 if (strEQ(d,"not")) return -KEY_not;
4925 if (strEQ(d,"no")) return KEY_no;
4930 if (strEQ(d,"or")) return -KEY_or;
4933 if (strEQ(d,"ord")) return -KEY_ord;
4934 if (strEQ(d,"oct")) return -KEY_oct;
4935 if (strEQ(d,"our")) { deprecate("reserved word \"our\"");
4939 if (strEQ(d,"open")) return -KEY_open;
4942 if (strEQ(d,"opendir")) return -KEY_opendir;
4949 if (strEQ(d,"pop")) return KEY_pop;
4950 if (strEQ(d,"pos")) return KEY_pos;
4953 if (strEQ(d,"push")) return KEY_push;
4954 if (strEQ(d,"pack")) return -KEY_pack;
4955 if (strEQ(d,"pipe")) return -KEY_pipe;
4958 if (strEQ(d,"print")) return KEY_print;
4961 if (strEQ(d,"printf")) return KEY_printf;
4964 if (strEQ(d,"package")) return KEY_package;
4967 if (strEQ(d,"prototype")) return KEY_prototype;
4972 if (strEQ(d,"q")) return KEY_q;
4973 if (strEQ(d,"qr")) return KEY_qr;
4974 if (strEQ(d,"qq")) return KEY_qq;
4975 if (strEQ(d,"qw")) return KEY_qw;
4976 if (strEQ(d,"qx")) return KEY_qx;
4978 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
4983 if (strEQ(d,"ref")) return -KEY_ref;
4986 if (strEQ(d,"read")) return -KEY_read;
4987 if (strEQ(d,"rand")) return -KEY_rand;
4988 if (strEQ(d,"recv")) return -KEY_recv;
4989 if (strEQ(d,"redo")) return KEY_redo;
4992 if (strEQ(d,"rmdir")) return -KEY_rmdir;
4993 if (strEQ(d,"reset")) return -KEY_reset;
4996 if (strEQ(d,"return")) return KEY_return;
4997 if (strEQ(d,"rename")) return -KEY_rename;
4998 if (strEQ(d,"rindex")) return -KEY_rindex;
5001 if (strEQ(d,"require")) return -KEY_require;
5002 if (strEQ(d,"reverse")) return -KEY_reverse;
5003 if (strEQ(d,"readdir")) return -KEY_readdir;
5006 if (strEQ(d,"readlink")) return -KEY_readlink;
5007 if (strEQ(d,"readline")) return -KEY_readline;
5008 if (strEQ(d,"readpipe")) return -KEY_readpipe;
5011 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
5017 case 0: return KEY_s;
5019 if (strEQ(d,"scalar")) return KEY_scalar;
5024 if (strEQ(d,"seek")) return -KEY_seek;
5025 if (strEQ(d,"send")) return -KEY_send;
5028 if (strEQ(d,"semop")) return -KEY_semop;
5031 if (strEQ(d,"select")) return -KEY_select;
5032 if (strEQ(d,"semctl")) return -KEY_semctl;
5033 if (strEQ(d,"semget")) return -KEY_semget;
5036 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
5037 if (strEQ(d,"seekdir")) return -KEY_seekdir;
5040 if (strEQ(d,"setpwent")) return -KEY_setpwent;
5041 if (strEQ(d,"setgrent")) return -KEY_setgrent;
5044 if (strEQ(d,"setnetent")) return -KEY_setnetent;
5047 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
5048 if (strEQ(d,"sethostent")) return -KEY_sethostent;
5049 if (strEQ(d,"setservent")) return -KEY_setservent;
5052 if (strEQ(d,"setpriority")) return -KEY_setpriority;
5053 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
5060 if (strEQ(d,"shift")) return KEY_shift;
5063 if (strEQ(d,"shmctl")) return -KEY_shmctl;
5064 if (strEQ(d,"shmget")) return -KEY_shmget;
5067 if (strEQ(d,"shmread")) return -KEY_shmread;
5070 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
5071 if (strEQ(d,"shutdown")) return -KEY_shutdown;
5076 if (strEQ(d,"sin")) return -KEY_sin;
5079 if (strEQ(d,"sleep")) return -KEY_sleep;
5082 if (strEQ(d,"sort")) return KEY_sort;
5083 if (strEQ(d,"socket")) return -KEY_socket;
5084 if (strEQ(d,"socketpair")) return -KEY_socketpair;
5087 if (strEQ(d,"split")) return KEY_split;
5088 if (strEQ(d,"sprintf")) return -KEY_sprintf;
5089 if (strEQ(d,"splice")) return KEY_splice;
5092 if (strEQ(d,"sqrt")) return -KEY_sqrt;
5095 if (strEQ(d,"srand")) return -KEY_srand;
5098 if (strEQ(d,"stat")) return -KEY_stat;
5099 if (strEQ(d,"study")) return KEY_study;
5102 if (strEQ(d,"substr")) return -KEY_substr;
5103 if (strEQ(d,"sub")) return KEY_sub;
5108 if (strEQ(d,"system")) return -KEY_system;
5111 if (strEQ(d,"symlink")) return -KEY_symlink;
5112 if (strEQ(d,"syscall")) return -KEY_syscall;
5113 if (strEQ(d,"sysopen")) return -KEY_sysopen;
5114 if (strEQ(d,"sysread")) return -KEY_sysread;
5115 if (strEQ(d,"sysseek")) return -KEY_sysseek;
5118 if (strEQ(d,"syswrite")) return -KEY_syswrite;
5127 if (strEQ(d,"tr")) return KEY_tr;
5130 if (strEQ(d,"tie")) return KEY_tie;
5133 if (strEQ(d,"tell")) return -KEY_tell;
5134 if (strEQ(d,"tied")) return KEY_tied;
5135 if (strEQ(d,"time")) return -KEY_time;
5138 if (strEQ(d,"times")) return -KEY_times;
5141 if (strEQ(d,"telldir")) return -KEY_telldir;
5144 if (strEQ(d,"truncate")) return -KEY_truncate;
5151 if (strEQ(d,"uc")) return -KEY_uc;
5154 if (strEQ(d,"use")) return KEY_use;
5157 if (strEQ(d,"undef")) return KEY_undef;
5158 if (strEQ(d,"until")) return KEY_until;
5159 if (strEQ(d,"untie")) return KEY_untie;
5160 if (strEQ(d,"utime")) return -KEY_utime;
5161 if (strEQ(d,"umask")) return -KEY_umask;
5164 if (strEQ(d,"unless")) return KEY_unless;
5165 if (strEQ(d,"unpack")) return -KEY_unpack;
5166 if (strEQ(d,"unlink")) return -KEY_unlink;
5169 if (strEQ(d,"unshift")) return KEY_unshift;
5170 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
5175 if (strEQ(d,"values")) return -KEY_values;
5176 if (strEQ(d,"vec")) return -KEY_vec;
5181 if (strEQ(d,"warn")) return -KEY_warn;
5182 if (strEQ(d,"wait")) return -KEY_wait;
5185 if (strEQ(d,"while")) return KEY_while;
5186 if (strEQ(d,"write")) return -KEY_write;
5189 if (strEQ(d,"waitpid")) return -KEY_waitpid;
5192 if (strEQ(d,"wantarray")) return -KEY_wantarray;
5197 if (len == 1) return -KEY_x;
5198 if (strEQ(d,"xor")) return -KEY_xor;
5201 if (len == 1) return KEY_y;
5210 S_checkcomma(pTHX_ register char *s, char *name, char *what)
5214 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
5215 dTHR; /* only for ckWARN */
5216 if (ckWARN(WARN_SYNTAX)) {
5218 for (w = s+2; *w && level; w++) {
5225 for (; *w && isSPACE(*w); w++) ;
5226 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
5227 Perl_warner(aTHX_ WARN_SYNTAX, "%s (...) interpreted as function",name);
5230 while (s < PL_bufend && isSPACE(*s))
5234 while (s < PL_bufend && isSPACE(*s))
5236 if (isIDFIRST_lazy(s)) {
5238 while (isALNUM_lazy(s))
5240 while (s < PL_bufend && isSPACE(*s))
5245 kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
5249 Perl_croak(aTHX_ "No comma allowed after %s", what);
5255 S_new_constant(pTHX_ char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)
5258 HV *table = GvHV(PL_hintgv); /* ^H */
5261 bool oldcatch = CATCH_GET;
5266 yyerror("%^H is not defined");
5269 cvp = hv_fetch(table, key, strlen(key), FALSE);
5270 if (!cvp || !SvOK(*cvp)) {
5272 sprintf(buf,"$^H{%s} is not defined", key);
5276 sv_2mortal(sv); /* Parent created it permanently */
5279 pv = sv_2mortal(newSVpvn(s, len));
5281 typesv = sv_2mortal(newSVpv(type, 0));
5283 typesv = &PL_sv_undef;
5285 Zero(&myop, 1, BINOP);
5286 myop.op_last = (OP *) &myop;
5287 myop.op_next = Nullop;
5288 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
5290 PUSHSTACKi(PERLSI_OVERLOAD);
5293 PL_op = (OP *) &myop;
5294 if (PERLDB_SUB && PL_curstash != PL_debstash)
5295 PL_op->op_private |= OPpENTERSUB_DB;
5297 Perl_pp_pushmark(aTHX);
5306 if (PL_op = Perl_pp_entersub(aTHX))
5313 CATCH_SET(oldcatch);
5318 sprintf(buf,"Call to &{$^H{%s}} did not return a defined value", key);
5321 return SvREFCNT_inc(res);
5325 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
5327 register char *d = dest;
5328 register char *e = d + destlen - 3; /* two-character token, ending NUL */
5331 Perl_croak(aTHX_ ident_too_long);
5332 if (isALNUM(*s)) /* UTF handled below */
5334 else if (*s == '\'' && allow_package && isIDFIRST_lazy(s+1)) {
5339 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
5343 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5344 char *t = s + UTF8SKIP(s);
5345 while (*t & 0x80 && is_utf8_mark((U8*)t))
5347 if (d + (t - s) > e)
5348 Perl_croak(aTHX_ ident_too_long);
5349 Copy(s, d, t - s, char);
5362 S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
5369 if (PL_lex_brackets == 0)
5370 PL_lex_fakebrack = 0;
5374 e = d + destlen - 3; /* two-character token, ending NUL */
5376 while (isDIGIT(*s)) {
5378 Perl_croak(aTHX_ ident_too_long);
5385 Perl_croak(aTHX_ ident_too_long);
5386 if (isALNUM(*s)) /* UTF handled below */
5388 else if (*s == '\'' && isIDFIRST_lazy(s+1)) {
5393 else if (*s == ':' && s[1] == ':') {
5397 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5398 char *t = s + UTF8SKIP(s);
5399 while (*t & 0x80 && is_utf8_mark((U8*)t))
5401 if (d + (t - s) > e)
5402 Perl_croak(aTHX_ ident_too_long);
5403 Copy(s, d, t - s, char);
5414 if (PL_lex_state != LEX_NORMAL)
5415 PL_lex_state = LEX_INTERPENDMAYBE;
5418 if (*s == '$' && s[1] &&
5419 (isALNUM_lazy(s+1) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
5432 if (*d == '^' && *s && isCONTROLVAR(*s)) {
5437 if (isSPACE(s[-1])) {
5440 if (ch != ' ' && ch != '\t') {
5446 if (isIDFIRST_lazy(d)) {
5450 while (e < send && isALNUM_lazy(e) || *e == ':') {
5452 while (e < send && *e & 0x80 && is_utf8_mark((U8*)e))
5455 Copy(s, d, e - s, char);
5460 while ((isALNUM(*s) || *s == ':') && d < e)
5463 Perl_croak(aTHX_ ident_too_long);
5466 while (s < send && (*s == ' ' || *s == '\t')) s++;
5467 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
5468 dTHR; /* only for ckWARN */
5469 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
5470 char *brack = *s == '[' ? "[...]" : "{...}";
5471 Perl_warner(aTHX_ WARN_AMBIGUOUS,
5472 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
5473 funny, dest, brack, funny, dest, brack);
5475 PL_lex_fakebrack = PL_lex_brackets+1;
5477 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5481 /* Handle extended ${^Foo} variables
5482 * 1999-02-27 mjd-perl-patch@plover.com */
5483 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
5487 while (isALNUM(*s) && d < e) {
5491 Perl_croak(aTHX_ ident_too_long);
5496 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
5497 PL_lex_state = LEX_INTERPEND;
5500 if (PL_lex_state == LEX_NORMAL) {
5501 dTHR; /* only for ckWARN */
5502 if (ckWARN(WARN_AMBIGUOUS) &&
5503 (keyword(dest, d - dest) || get_cv(dest, FALSE)))
5505 Perl_warner(aTHX_ WARN_AMBIGUOUS,
5506 "Ambiguous use of %c{%s} resolved to %c%s",
5507 funny, dest, funny, dest);
5512 s = bracket; /* let the parser handle it */
5516 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
5517 PL_lex_state = LEX_INTERPEND;
5522 Perl_pmflag(pTHX_ U16 *pmfl, int ch)
5527 *pmfl |= PMf_GLOBAL;
5529 *pmfl |= PMf_CONTINUE;
5533 *pmfl |= PMf_MULTILINE;
5535 *pmfl |= PMf_SINGLELINE;
5537 *pmfl |= PMf_EXTENDED;
5541 S_scan_pat(pTHX_ char *start, I32 type)
5546 s = scan_str(start);
5549 SvREFCNT_dec(PL_lex_stuff);
5550 PL_lex_stuff = Nullsv;
5551 Perl_croak(aTHX_ "Search pattern not terminated");
5554 pm = (PMOP*)newPMOP(type, 0);
5555 if (PL_multi_open == '?')
5556 pm->op_pmflags |= PMf_ONCE;
5558 while (*s && strchr("iomsx", *s))
5559 pmflag(&pm->op_pmflags,*s++);
5562 while (*s && strchr("iogcmsx", *s))
5563 pmflag(&pm->op_pmflags,*s++);
5565 pm->op_pmpermflags = pm->op_pmflags;
5567 PL_lex_op = (OP*)pm;
5568 yylval.ival = OP_MATCH;
5573 S_scan_subst(pTHX_ char *start)
5580 yylval.ival = OP_NULL;
5582 s = scan_str(start);
5586 SvREFCNT_dec(PL_lex_stuff);
5587 PL_lex_stuff = Nullsv;
5588 Perl_croak(aTHX_ "Substitution pattern not terminated");
5591 if (s[-1] == PL_multi_open)
5594 first_start = PL_multi_start;
5598 SvREFCNT_dec(PL_lex_stuff);
5599 PL_lex_stuff = Nullsv;
5601 SvREFCNT_dec(PL_lex_repl);
5602 PL_lex_repl = Nullsv;
5603 Perl_croak(aTHX_ "Substitution replacement not terminated");
5605 PL_multi_start = first_start; /* so whole substitution is taken together */
5607 pm = (PMOP*)newPMOP(OP_SUBST, 0);
5613 else if (strchr("iogcmsx", *s))
5614 pmflag(&pm->op_pmflags,*s++);
5621 PL_sublex_info.super_bufptr = s;
5622 PL_sublex_info.super_bufend = PL_bufend;
5624 pm->op_pmflags |= PMf_EVAL;
5625 repl = newSVpvn("",0);
5627 sv_catpv(repl, es ? "eval " : "do ");
5628 sv_catpvn(repl, "{ ", 2);
5629 sv_catsv(repl, PL_lex_repl);
5630 sv_catpvn(repl, " };", 2);
5632 SvREFCNT_dec(PL_lex_repl);
5636 pm->op_pmpermflags = pm->op_pmflags;
5637 PL_lex_op = (OP*)pm;
5638 yylval.ival = OP_SUBST;
5643 S_scan_trans(pTHX_ char *start)
5654 yylval.ival = OP_NULL;
5656 s = scan_str(start);
5659 SvREFCNT_dec(PL_lex_stuff);
5660 PL_lex_stuff = Nullsv;
5661 Perl_croak(aTHX_ "Transliteration pattern not terminated");
5663 if (s[-1] == PL_multi_open)
5669 SvREFCNT_dec(PL_lex_stuff);
5670 PL_lex_stuff = Nullsv;
5672 SvREFCNT_dec(PL_lex_repl);
5673 PL_lex_repl = Nullsv;
5674 Perl_croak(aTHX_ "Transliteration replacement not terminated");
5678 o = newSVOP(OP_TRANS, 0, 0);
5679 utf8 = OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF;
5682 New(803,tbl,256,short);
5683 o = newPVOP(OP_TRANS, 0, (char*)tbl);
5687 complement = del = squash = 0;
5688 while (strchr("cdsCU", *s)) {
5690 complement = OPpTRANS_COMPLEMENT;
5692 del = OPpTRANS_DELETE;
5694 squash = OPpTRANS_SQUASH;
5699 utf8 &= ~OPpTRANS_FROM_UTF;
5701 utf8 |= OPpTRANS_FROM_UTF;
5705 utf8 &= ~OPpTRANS_TO_UTF;
5707 utf8 |= OPpTRANS_TO_UTF;
5710 Perl_croak(aTHX_ "Too many /C and /U options");
5715 o->op_private = del|squash|complement|utf8;
5718 yylval.ival = OP_TRANS;
5723 S_scan_heredoc(pTHX_ register char *s)
5727 I32 op_type = OP_SCALAR;
5734 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
5738 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
5741 for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5742 if (*peek && strchr("`'\"",*peek)) {
5745 s = delimcpy(d, e, s, PL_bufend, term, &len);
5755 if (!isALNUM_lazy(s))
5756 deprecate("bare << to mean <<\"\"");
5757 for (; isALNUM_lazy(s); s++) {
5762 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
5763 Perl_croak(aTHX_ "Delimiter for here document is too long");
5766 len = d - PL_tokenbuf;
5767 #ifndef PERL_STRICT_CR
5768 d = strchr(s, '\r');
5772 while (s < PL_bufend) {
5778 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
5787 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5792 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
5793 herewas = newSVpvn(s,PL_bufend-s);
5795 s--, herewas = newSVpvn(s,d-s);
5796 s += SvCUR(herewas);
5798 tmpstr = NEWSV(87,79);
5799 sv_upgrade(tmpstr, SVt_PVIV);
5804 else if (term == '`') {
5805 op_type = OP_BACKTICK;
5806 SvIVX(tmpstr) = '\\';
5810 PL_multi_start = PL_curcop->cop_line;
5811 PL_multi_open = PL_multi_close = '<';
5812 term = *PL_tokenbuf;
5813 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
5814 char *bufptr = PL_sublex_info.super_bufptr;
5815 char *bufend = PL_sublex_info.super_bufend;
5816 char *olds = s - SvCUR(herewas);
5817 s = strchr(bufptr, '\n');
5821 while (s < bufend &&
5822 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
5824 PL_curcop->cop_line++;
5827 PL_curcop->cop_line = PL_multi_start;
5828 missingterm(PL_tokenbuf);
5830 sv_setpvn(herewas,bufptr,d-bufptr+1);
5831 sv_setpvn(tmpstr,d+1,s-d);
5833 sv_catpvn(herewas,s,bufend-s);
5834 (void)strcpy(bufptr,SvPVX(herewas));
5841 while (s < PL_bufend &&
5842 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
5844 PL_curcop->cop_line++;
5846 if (s >= PL_bufend) {
5847 PL_curcop->cop_line = PL_multi_start;
5848 missingterm(PL_tokenbuf);
5850 sv_setpvn(tmpstr,d+1,s-d);
5852 PL_curcop->cop_line++; /* the preceding stmt passes a newline */
5854 sv_catpvn(herewas,s,PL_bufend-s);
5855 sv_setsv(PL_linestr,herewas);
5856 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
5857 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5860 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
5861 while (s >= PL_bufend) { /* multiple line string? */
5863 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5864 PL_curcop->cop_line = PL_multi_start;
5865 missingterm(PL_tokenbuf);
5867 PL_curcop->cop_line++;
5868 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5869 #ifndef PERL_STRICT_CR
5870 if (PL_bufend - PL_linestart >= 2) {
5871 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
5872 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
5874 PL_bufend[-2] = '\n';
5876 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5878 else if (PL_bufend[-1] == '\r')
5879 PL_bufend[-1] = '\n';
5881 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
5882 PL_bufend[-1] = '\n';
5884 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5885 SV *sv = NEWSV(88,0);
5887 sv_upgrade(sv, SVt_PVMG);
5888 sv_setsv(sv,PL_linestr);
5889 av_store(GvAV(PL_curcop->cop_filegv),
5890 (I32)PL_curcop->cop_line,sv);
5892 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
5895 sv_catsv(PL_linestr,herewas);
5896 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5900 sv_catsv(tmpstr,PL_linestr);
5905 PL_multi_end = PL_curcop->cop_line;
5906 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
5907 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
5908 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
5910 SvREFCNT_dec(herewas);
5911 PL_lex_stuff = tmpstr;
5912 yylval.ival = op_type;
5917 takes: current position in input buffer
5918 returns: new position in input buffer
5919 side-effects: yylval and lex_op are set.
5924 <FH> read from filehandle
5925 <pkg::FH> read from package qualified filehandle
5926 <pkg'FH> read from package qualified filehandle
5927 <$fh> read from filehandle in $fh
5933 S_scan_inputsymbol(pTHX_ char *start)
5935 register char *s = start; /* current position in buffer */
5941 d = PL_tokenbuf; /* start of temp holding space */
5942 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
5943 end = strchr(s, '\n');
5946 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
5948 /* die if we didn't have space for the contents of the <>,
5949 or if it didn't end, or if we see a newline
5952 if (len >= sizeof PL_tokenbuf)
5953 Perl_croak(aTHX_ "Excessively long <> operator");
5955 Perl_croak(aTHX_ "Unterminated <> operator");
5960 Remember, only scalar variables are interpreted as filehandles by
5961 this code. Anything more complex (e.g., <$fh{$num}>) will be
5962 treated as a glob() call.
5963 This code makes use of the fact that except for the $ at the front,
5964 a scalar variable and a filehandle look the same.
5966 if (*d == '$' && d[1]) d++;
5968 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
5969 while (*d && (isALNUM_lazy(d) || *d == '\'' || *d == ':'))
5972 /* If we've tried to read what we allow filehandles to look like, and
5973 there's still text left, then it must be a glob() and not a getline.
5974 Use scan_str to pull out the stuff between the <> and treat it
5975 as nothing more than a string.
5978 if (d - PL_tokenbuf != len) {
5979 yylval.ival = OP_GLOB;
5981 s = scan_str(start);
5983 Perl_croak(aTHX_ "Glob not terminated");
5987 /* we're in a filehandle read situation */
5990 /* turn <> into <ARGV> */
5992 (void)strcpy(d,"ARGV");
5994 /* if <$fh>, create the ops to turn the variable into a
6000 /* try to find it in the pad for this block, otherwise find
6001 add symbol table ops
6003 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
6004 OP *o = newOP(OP_PADSV, 0);
6006 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, o);
6009 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
6010 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
6011 newUNOP(OP_RV2SV, 0,
6012 newGVOP(OP_GV, 0, gv)));
6014 PL_lex_op->op_flags |= OPf_SPECIAL;
6015 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
6016 yylval.ival = OP_NULL;
6019 /* If it's none of the above, it must be a literal filehandle
6020 (<Foo::BAR> or <FOO>) so build a simple readline OP */
6022 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
6023 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
6024 yylval.ival = OP_NULL;
6033 takes: start position in buffer
6034 returns: position to continue reading from buffer
6035 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
6036 updates the read buffer.
6038 This subroutine pulls a string out of the input. It is called for:
6039 q single quotes q(literal text)
6040 ' single quotes 'literal text'
6041 qq double quotes qq(interpolate $here please)
6042 " double quotes "interpolate $here please"
6043 qx backticks qx(/bin/ls -l)
6044 ` backticks `/bin/ls -l`
6045 qw quote words @EXPORT_OK = qw( func() $spam )
6046 m// regexp match m/this/
6047 s/// regexp substitute s/this/that/
6048 tr/// string transliterate tr/this/that/
6049 y/// string transliterate y/this/that/
6050 ($*@) sub prototypes sub foo ($)
6051 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
6053 In most of these cases (all but <>, patterns and transliterate)
6054 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
6055 calls scan_str(). s/// makes yylex() call scan_subst() which calls
6056 scan_str(). tr/// and y/// make yylex() call scan_trans() which
6059 It skips whitespace before the string starts, and treats the first
6060 character as the delimiter. If the delimiter is one of ([{< then
6061 the corresponding "close" character )]}> is used as the closing
6062 delimiter. It allows quoting of delimiters, and if the string has
6063 balanced delimiters ([{<>}]) it allows nesting.
6065 The lexer always reads these strings into lex_stuff, except in the
6066 case of the operators which take *two* arguments (s/// and tr///)
6067 when it checks to see if lex_stuff is full (presumably with the 1st
6068 arg to s or tr) and if so puts the string into lex_repl.
6073 S_scan_str(pTHX_ char *start)
6076 SV *sv; /* scalar value: string */
6077 char *tmps; /* temp string, used for delimiter matching */
6078 register char *s = start; /* current position in the buffer */
6079 register char term; /* terminating character */
6080 register char *to; /* current position in the sv's data */
6081 I32 brackets = 1; /* bracket nesting level */
6083 /* skip space before the delimiter */
6087 /* mark where we are, in case we need to report errors */
6090 /* after skipping whitespace, the next character is the terminator */
6092 /* mark where we are */
6093 PL_multi_start = PL_curcop->cop_line;
6094 PL_multi_open = term;
6096 /* find corresponding closing delimiter */
6097 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
6099 PL_multi_close = term;
6101 /* create a new SV to hold the contents. 87 is leak category, I'm
6102 assuming. 79 is the SV's initial length. What a random number. */
6104 sv_upgrade(sv, SVt_PVIV);
6106 (void)SvPOK_only(sv); /* validate pointer */
6108 /* move past delimiter and try to read a complete string */
6111 /* extend sv if need be */
6112 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
6113 /* set 'to' to the next character in the sv's string */
6114 to = SvPVX(sv)+SvCUR(sv);
6116 /* if open delimiter is the close delimiter read unbridle */
6117 if (PL_multi_open == PL_multi_close) {
6118 for (; s < PL_bufend; s++,to++) {
6119 /* embedded newlines increment the current line number */
6120 if (*s == '\n' && !PL_rsfp)
6121 PL_curcop->cop_line++;
6122 /* handle quoted delimiters */
6123 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
6126 /* any other quotes are simply copied straight through */
6130 /* terminate when run out of buffer (the for() condition), or
6131 have found the terminator */
6132 else if (*s == term)
6138 /* if the terminator isn't the same as the start character (e.g.,
6139 matched brackets), we have to allow more in the quoting, and
6140 be prepared for nested brackets.
6143 /* read until we run out of string, or we find the terminator */
6144 for (; s < PL_bufend; s++,to++) {
6145 /* embedded newlines increment the line count */
6146 if (*s == '\n' && !PL_rsfp)
6147 PL_curcop->cop_line++;
6148 /* backslashes can escape the open or closing characters */
6149 if (*s == '\\' && s+1 < PL_bufend) {
6150 if ((s[1] == PL_multi_open) || (s[1] == PL_multi_close))
6155 /* allow nested opens and closes */
6156 else if (*s == PL_multi_close && --brackets <= 0)
6158 else if (*s == PL_multi_open)
6163 /* terminate the copied string and update the sv's end-of-string */
6165 SvCUR_set(sv, to - SvPVX(sv));
6168 * this next chunk reads more into the buffer if we're not done yet
6171 if (s < PL_bufend) break; /* handle case where we are done yet :-) */
6173 #ifndef PERL_STRICT_CR
6174 if (to - SvPVX(sv) >= 2) {
6175 if ((to[-2] == '\r' && to[-1] == '\n') ||
6176 (to[-2] == '\n' && to[-1] == '\r'))
6180 SvCUR_set(sv, to - SvPVX(sv));
6182 else if (to[-1] == '\r')
6185 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
6189 /* if we're out of file, or a read fails, bail and reset the current
6190 line marker so we can report where the unterminated string began
6193 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6195 PL_curcop->cop_line = PL_multi_start;
6198 /* we read a line, so increment our line counter */
6199 PL_curcop->cop_line++;
6201 /* update debugger info */
6202 if (PERLDB_LINE && PL_curstash != PL_debstash) {
6203 SV *sv = NEWSV(88,0);
6205 sv_upgrade(sv, SVt_PVMG);
6206 sv_setsv(sv,PL_linestr);
6207 av_store(GvAV(PL_curcop->cop_filegv),
6208 (I32)PL_curcop->cop_line, sv);
6211 /* having changed the buffer, we must update PL_bufend */
6212 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6215 /* at this point, we have successfully read the delimited string */
6217 PL_multi_end = PL_curcop->cop_line;
6220 /* if we allocated too much space, give some back */
6221 if (SvCUR(sv) + 5 < SvLEN(sv)) {
6222 SvLEN_set(sv, SvCUR(sv) + 1);
6223 Renew(SvPVX(sv), SvLEN(sv), char);
6226 /* decide whether this is the first or second quoted string we've read
6239 takes: pointer to position in buffer
6240 returns: pointer to new position in buffer
6241 side-effects: builds ops for the constant in yylval.op
6243 Read a number in any of the formats that Perl accepts:
6245 0(x[0-7A-F]+)|([0-7]+)|(b[01])
6246 [\d_]+(\.[\d_]*)?[Ee](\d+)
6248 Underbars (_) are allowed in decimal numbers. If -w is on,
6249 underbars before a decimal point must be at three digit intervals.
6251 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
6254 If it reads a number without a decimal point or an exponent, it will
6255 try converting the number to an integer and see if it can do so
6256 without loss of precision.
6260 Perl_scan_num(pTHX_ char *start)
6262 register char *s = start; /* current position in buffer */
6263 register char *d; /* destination in temp buffer */
6264 register char *e; /* end of temp buffer */
6265 IV tryiv; /* used to see if it can be an IV */
6266 NV value; /* number read, as a double */
6267 SV *sv; /* place to put the converted number */
6268 bool floatit; /* boolean: int or float? */
6269 char *lastub = 0; /* position of last underbar */
6270 static char number_too_long[] = "Number too long";
6272 /* We use the first character to decide what type of number this is */
6276 Perl_croak(aTHX_ "panic: scan_num");
6278 /* if it starts with a 0, it could be an octal number, a decimal in
6279 0.13 disguise, or a hexadecimal number, or a binary number.
6284 u holds the "number so far"
6285 shift the power of 2 of the base
6286 (hex == 4, octal == 3, binary == 1)
6287 overflowed was the number more than we can hold?
6289 Shift is used when we add a digit. It also serves as an "are
6290 we in octal/hex/binary?" indicator to disallow hex characters
6297 bool overflowed = FALSE;
6298 static NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
6299 static char* bases[5] = { "", "binary", "", "octal",
6301 static char* Bases[5] = { "", "Binary", "", "Octal",
6303 static char *maxima[5] = { "",
6304 "0b11111111111111111111111111111111",
6308 char *base, *Base, *max;
6314 } else if (s[1] == 'b') {
6318 /* check for a decimal in disguise */
6319 else if (s[1] == '.')
6321 /* so it must be octal */
6325 base = bases[shift];
6326 Base = Bases[shift];
6327 max = maxima[shift];
6329 /* read the rest of the number */
6331 /* x is used in the overflow test,
6332 b is the digit we're adding on. */
6337 /* if we don't mention it, we're done */
6346 /* 8 and 9 are not octal */
6349 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
6352 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
6356 case '2': case '3': case '4':
6357 case '5': case '6': case '7':
6359 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
6363 b = *s++ & 15; /* ASCII digit -> value of digit */
6367 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
6368 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
6369 /* make sure they said 0x */
6374 /* Prepare to put the digit we have onto the end
6375 of the number so far. We check for overflows.
6380 x = u << shift; /* make room for the digit */
6382 if ((x >> shift) != u
6383 && !(PL_hints & HINT_NEW_BINARY)) {
6387 if (ckWARN_d(WARN_UNSAFE))
6388 Perl_warner(aTHX_ ((shift == 3) ?
6389 WARN_OCTAL : WARN_UNSAFE),
6390 "Integer overflow in %s number",
6393 u = x | b; /* add the digit to the end */
6396 n *= nvshift[shift];
6397 /* If an NV has not enough bits in its
6398 * mantissa to represent an UV this summing of
6399 * small low-order numbers is a waste of time
6400 * (because the NV cannot preserve the
6401 * low-order bits anyway): we could just
6402 * remember when did we overflow and in the
6403 * end just multiply n by the right
6411 /* if we get here, we had success: make a scalar value from
6418 if (ckWARN(WARN_UNSAFE) && n > 4294967295.0)
6419 Perl_warner(aTHX_ WARN_UNSAFE,
6420 "%s number > %s non-portable",
6427 if (ckWARN(WARN_UNSAFE) && u > 0xffffffff)
6428 Perl_warner(aTHX_ WARN_UNSAFE,
6429 "%s number > %s non-portable",
6434 if (PL_hints & HINT_NEW_BINARY)
6435 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
6440 handle decimal numbers.
6441 we're also sent here when we read a 0 as the first digit
6443 case '1': case '2': case '3': case '4': case '5':
6444 case '6': case '7': case '8': case '9': case '.':
6447 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
6450 /* read next group of digits and _ and copy into d */
6451 while (isDIGIT(*s) || *s == '_') {
6452 /* skip underscores, checking for misplaced ones
6456 dTHR; /* only for ckWARN */
6457 if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
6458 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
6462 /* check for end of fixed-length buffer */
6464 Perl_croak(aTHX_ number_too_long);
6465 /* if we're ok, copy the character */
6470 /* final misplaced underbar check */
6471 if (lastub && s - lastub != 3) {
6473 if (ckWARN(WARN_SYNTAX))
6474 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
6477 /* read a decimal portion if there is one. avoid
6478 3..5 being interpreted as the number 3. followed
6481 if (*s == '.' && s[1] != '.') {
6485 /* copy, ignoring underbars, until we run out of
6486 digits. Note: no misplaced underbar checks!
6488 for (; isDIGIT(*s) || *s == '_'; s++) {
6489 /* fixed length buffer check */
6491 Perl_croak(aTHX_ number_too_long);
6497 /* read exponent part, if present */
6498 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
6502 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
6503 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
6505 /* allow positive or negative exponent */
6506 if (*s == '+' || *s == '-')
6509 /* read digits of exponent (no underbars :-) */
6510 while (isDIGIT(*s)) {
6512 Perl_croak(aTHX_ number_too_long);
6517 /* terminate the string */
6520 /* make an sv from the string */
6523 value = Atof(PL_tokenbuf);
6526 See if we can make do with an integer value without loss of
6527 precision. We use I_V to cast to an int, because some
6528 compilers have issues. Then we try casting it back and see
6529 if it was the same. We only do this if we know we
6530 specifically read an integer.
6532 Note: if floatit is true, then we don't need to do the
6536 if (!floatit && (NV)tryiv == value)
6537 sv_setiv(sv, tryiv);
6539 sv_setnv(sv, value);
6540 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
6541 (PL_hints & HINT_NEW_INTEGER) )
6542 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
6543 (floatit ? "float" : "integer"),
6548 /* make the op for the constant and return */
6550 yylval.opval = newSVOP(OP_CONST, 0, sv);
6556 S_scan_formline(pTHX_ register char *s)
6561 SV *stuff = newSVpvn("",0);
6562 bool needargs = FALSE;
6565 if (*s == '.' || *s == '}') {
6567 #ifdef PERL_STRICT_CR
6568 for (t = s+1;*t == ' ' || *t == '\t'; t++) ;
6570 for (t = s+1;*t == ' ' || *t == '\t' || *t == '\r'; t++) ;
6572 if (*t == '\n' || t == PL_bufend)
6575 if (PL_in_eval && !PL_rsfp) {
6576 eol = strchr(s,'\n');
6581 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6583 for (t = s; t < eol; t++) {
6584 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
6586 goto enough; /* ~~ must be first line in formline */
6588 if (*t == '@' || *t == '^')
6591 sv_catpvn(stuff, s, eol-s);
6595 s = filter_gets(PL_linestr, PL_rsfp, 0);
6596 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
6597 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
6600 yyerror("Format not terminated");
6610 PL_lex_state = LEX_NORMAL;
6611 PL_nextval[PL_nexttoke].ival = 0;
6615 PL_lex_state = LEX_FORMLINE;
6616 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
6618 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
6622 SvREFCNT_dec(stuff);
6623 PL_lex_formbrack = 0;
6634 PL_cshlen = strlen(PL_cshname);
6639 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
6642 I32 oldsavestack_ix = PL_savestack_ix;
6643 CV* outsidecv = PL_compcv;
6647 assert(SvTYPE(PL_compcv) == SVt_PVCV);
6649 save_I32(&PL_subline);
6650 save_item(PL_subname);
6652 SAVESPTR(PL_curpad);
6653 SAVESPTR(PL_comppad);
6654 SAVESPTR(PL_comppad_name);
6655 SAVESPTR(PL_compcv);
6656 SAVEI32(PL_comppad_name_fill);
6657 SAVEI32(PL_min_intro_pending);
6658 SAVEI32(PL_max_intro_pending);
6659 SAVEI32(PL_pad_reset_pending);
6661 PL_compcv = (CV*)NEWSV(1104,0);
6662 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
6663 CvFLAGS(PL_compcv) |= flags;
6665 PL_comppad = newAV();
6666 av_push(PL_comppad, Nullsv);
6667 PL_curpad = AvARRAY(PL_comppad);
6668 PL_comppad_name = newAV();
6669 PL_comppad_name_fill = 0;
6670 PL_min_intro_pending = 0;
6672 PL_subline = PL_curcop->cop_line;
6674 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
6675 PL_curpad[0] = (SV*)newAV();
6676 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
6677 #endif /* USE_THREADS */
6679 comppadlist = newAV();
6680 AvREAL_off(comppadlist);
6681 av_store(comppadlist, 0, (SV*)PL_comppad_name);
6682 av_store(comppadlist, 1, (SV*)PL_comppad);
6684 CvPADLIST(PL_compcv) = comppadlist;
6685 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
6687 CvOWNER(PL_compcv) = 0;
6688 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
6689 MUTEX_INIT(CvMUTEXP(PL_compcv));
6690 #endif /* USE_THREADS */
6692 return oldsavestack_ix;
6696 Perl_yywarn(pTHX_ char *s)
6700 PL_in_eval |= EVAL_WARNONLY;
6702 PL_in_eval &= ~EVAL_WARNONLY;
6707 Perl_yyerror(pTHX_ char *s)
6711 char *context = NULL;
6715 if (!yychar || (yychar == ';' && !PL_rsfp))
6717 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
6718 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
6719 while (isSPACE(*PL_oldoldbufptr))
6721 context = PL_oldoldbufptr;
6722 contlen = PL_bufptr - PL_oldoldbufptr;
6724 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
6725 PL_oldbufptr != PL_bufptr) {
6726 while (isSPACE(*PL_oldbufptr))
6728 context = PL_oldbufptr;
6729 contlen = PL_bufptr - PL_oldbufptr;
6731 else if (yychar > 255)
6732 where = "next token ???";
6733 else if ((yychar & 127) == 127) {
6734 if (PL_lex_state == LEX_NORMAL ||
6735 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
6736 where = "at end of line";
6737 else if (PL_lex_inpat)
6738 where = "within pattern";
6740 where = "within string";
6743 SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
6745 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
6746 else if (isPRINT_LC(yychar))
6747 Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
6749 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
6750 where = SvPVX(where_sv);
6752 msg = sv_2mortal(newSVpv(s, 0));
6754 Perl_sv_catpvf(aTHX_ msg, " at %_ line %" PERL_PRId64 ", ",
6755 GvSV(PL_curcop->cop_filegv), (IV)PL_curcop->cop_line);
6757 Perl_sv_catpvf(aTHX_ msg, " at %_ line %ld, ",
6758 GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line);
6761 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
6763 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
6764 if (PL_multi_start < PL_multi_end && (U32)(PL_curcop->cop_line - PL_multi_end) <= 1) {
6766 Perl_sv_catpvf(aTHX_ msg,
6767 " (Might be a runaway multi-line %c%c string starting on line %" PERL_\
6769 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
6771 Perl_sv_catpvf(aTHX_ msg,
6772 " (Might be a runaway multi-line %c%c string starting on line %ld)\n",
6773 (int)PL_multi_open,(int)PL_multi_close,(long)PL_multi_start);
6777 if (PL_in_eval & EVAL_WARNONLY)
6778 Perl_warn(aTHX_ "%_", msg);
6779 else if (PL_in_eval)
6780 sv_catsv(ERRSV, msg);
6782 PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
6783 if (++PL_error_count >= 10)
6784 Perl_croak(aTHX_ "%_ has too many errors.\n", GvSV(PL_curcop->cop_filegv));
6786 PL_in_my_stash = Nullhv;
6798 * Restore a source filter.
6802 restore_rsfp(pTHXo_ void *f)
6804 PerlIO *fp = (PerlIO*)f;
6806 if (PL_rsfp == PerlIO_stdin())
6807 PerlIO_clearerr(PL_rsfp);
6808 else if (PL_rsfp && (PL_rsfp != fp))
6809 PerlIO_close(PL_rsfp);
6815 * Restores the state of PL_expect when the lexing that begun with a
6816 * start_lex() call has ended.
6820 restore_expect(pTHXo_ void *e)
6822 /* a safe way to store a small integer in a pointer */
6823 PL_expect = (expectation)((char *)e - PL_tokenbuf);
6827 * restore_lex_expect
6828 * Restores the state of PL_lex_expect when the lexing that begun with a
6829 * start_lex() call has ended.
6833 restore_lex_expect(pTHXo_ void *e)
6835 /* a safe way to store a small integer in a pointer */
6836 PL_lex_expect = (expectation)((char *)e - PL_tokenbuf);