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 ? "\\.^$@AGZdDwWsSbBpPXO+*?|()-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{latin small letter a} is a named character */
1360 char* e = strchr(s, '}');
1369 yyerror("Missing right brace on \\C{}");
1373 res = newSVpvn(s + 1, e - s - 1);
1374 res = new_constant( Nullch, 0, "charnames",
1375 res, Nullsv, "\\C{...}" );
1376 str = SvPV(res,len);
1377 if (len > e - s + 4) {
1378 char *odest = SvPVX(sv);
1380 SvGROW(sv, (SvCUR(sv) + len - (e - s + 4)));
1381 d = SvPVX(sv) + (d - odest);
1383 Copy(str, d, len, char);
1390 yyerror("Missing braces on \\C{}");
1393 /* \c is a control character */
1407 /* printf-style backslashes, formfeeds, newlines, etc */
1425 *d++ = '\047'; /* CP 1047 */
1428 *d++ = '\057'; /* CP 1047 */
1442 } /* end if (backslash) */
1445 } /* while loop to process each character */
1447 /* terminate the string and set up the sv */
1449 SvCUR_set(sv, d - SvPVX(sv));
1452 /* shrink the sv if we allocated more than we used */
1453 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1454 SvLEN_set(sv, SvCUR(sv) + 1);
1455 Renew(SvPVX(sv), SvLEN(sv), char);
1458 /* return the substring (via yylval) only if we parsed anything */
1459 if (s > PL_bufptr) {
1460 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1461 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1463 ( PL_lex_inwhat == OP_TRANS
1465 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1468 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1475 * Returns TRUE if there's more to the expression (e.g., a subscript),
1478 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
1480 * ->[ and ->{ return TRUE
1481 * { and [ outside a pattern are always subscripts, so return TRUE
1482 * if we're outside a pattern and it's not { or [, then return FALSE
1483 * if we're in a pattern and the first char is a {
1484 * {4,5} (any digits around the comma) returns FALSE
1485 * if we're in a pattern and the first char is a [
1487 * [SOMETHING] has a funky algorithm to decide whether it's a
1488 * character class or not. It has to deal with things like
1489 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
1490 * anything else returns TRUE
1493 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1496 S_intuit_more(pTHX_ register char *s)
1498 if (PL_lex_brackets)
1500 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1502 if (*s != '{' && *s != '[')
1507 /* In a pattern, so maybe we have {n,m}. */
1524 /* On the other hand, maybe we have a character class */
1527 if (*s == ']' || *s == '^')
1530 /* this is terrifying, and it works */
1531 int weight = 2; /* let's weigh the evidence */
1533 unsigned char un_char = 255, last_un_char;
1534 char *send = strchr(s,']');
1535 char tmpbuf[sizeof PL_tokenbuf * 4];
1537 if (!send) /* has to be an expression */
1540 Zero(seen,256,char);
1543 else if (isDIGIT(*s)) {
1545 if (isDIGIT(s[1]) && s[2] == ']')
1551 for (; s < send; s++) {
1552 last_un_char = un_char;
1553 un_char = (unsigned char)*s;
1558 weight -= seen[un_char] * 10;
1559 if (isALNUM_lazy(s+1)) {
1560 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1561 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1566 else if (*s == '$' && s[1] &&
1567 strchr("[#!%*<>()-=",s[1])) {
1568 if (/*{*/ strchr("])} =",s[2]))
1577 if (strchr("wds]",s[1]))
1579 else if (seen['\''] || seen['"'])
1581 else if (strchr("rnftbxcav",s[1]))
1583 else if (isDIGIT(s[1])) {
1585 while (s[1] && isDIGIT(s[1]))
1595 if (strchr("aA01! ",last_un_char))
1597 if (strchr("zZ79~",s[1]))
1599 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1600 weight -= 5; /* cope with negative subscript */
1603 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1604 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1609 if (keyword(tmpbuf, d - tmpbuf))
1612 if (un_char == last_un_char + 1)
1614 weight -= seen[un_char];
1619 if (weight >= 0) /* probably a character class */
1629 * Does all the checking to disambiguate
1631 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
1632 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
1634 * First argument is the stuff after the first token, e.g. "bar".
1636 * Not a method if bar is a filehandle.
1637 * Not a method if foo is a subroutine prototyped to take a filehandle.
1638 * Not a method if it's really "Foo $bar"
1639 * Method if it's "foo $bar"
1640 * Not a method if it's really "print foo $bar"
1641 * Method if it's really "foo package::" (interpreted as package->foo)
1642 * Not a method if bar is known to be a subroutne ("sub bar; foo bar")
1643 * Not a method if bar is a filehandle or package, but is quotd with
1648 S_intuit_method(pTHX_ char *start, GV *gv)
1650 char *s = start + (*start == '$');
1651 char tmpbuf[sizeof PL_tokenbuf];
1659 if ((cv = GvCVu(gv))) {
1660 char *proto = SvPVX(cv);
1670 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1671 /* start is the beginning of the possible filehandle/object,
1672 * and s is the end of it
1673 * tmpbuf is a copy of it
1676 if (*start == '$') {
1677 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1682 return *s == '(' ? FUNCMETH : METHOD;
1684 if (!keyword(tmpbuf, len)) {
1685 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1690 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1691 if (indirgv && GvCVu(indirgv))
1693 /* filehandle or package name makes it a method */
1694 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1696 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1697 return 0; /* no assumptions -- "=>" quotes bearword */
1699 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1700 newSVpvn(tmpbuf,len));
1701 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1705 return *s == '(' ? FUNCMETH : METHOD;
1713 * Return a string of Perl code to load the debugger. If PERL5DB
1714 * is set, it will return the contents of that, otherwise a
1715 * compile-time require of perl5db.pl.
1722 char *pdb = PerlEnv_getenv("PERL5DB");
1726 SETERRNO(0,SS$_NORMAL);
1727 return "BEGIN { require 'perl5db.pl' }";
1733 /* Encoded script support. filter_add() effectively inserts a
1734 * 'pre-processing' function into the current source input stream.
1735 * Note that the filter function only applies to the current source file
1736 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1738 * The datasv parameter (which may be NULL) can be used to pass
1739 * private data to this instance of the filter. The filter function
1740 * can recover the SV using the FILTER_DATA macro and use it to
1741 * store private buffers and state information.
1743 * The supplied datasv parameter is upgraded to a PVIO type
1744 * and the IoDIRP field is used to store the function pointer.
1745 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1746 * private use must be set using malloc'd pointers.
1750 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
1752 if (!funcp){ /* temporary handy debugging hack to be deleted */
1753 PL_filter_debug = atoi((char*)datasv);
1756 if (!PL_rsfp_filters)
1757 PL_rsfp_filters = newAV();
1759 datasv = NEWSV(255,0);
1760 if (!SvUPGRADE(datasv, SVt_PVIO))
1761 Perl_die(aTHX_ "Can't upgrade filter_add data to SVt_PVIO");
1762 IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
1764 if (PL_filter_debug) {
1766 Perl_warn(aTHX_ "filter_add func %p (%s)", funcp, SvPV(datasv, n_a));
1768 #endif /* DEBUGGING */
1769 av_unshift(PL_rsfp_filters, 1);
1770 av_store(PL_rsfp_filters, 0, datasv) ;
1775 /* Delete most recently added instance of this filter function. */
1777 Perl_filter_del(pTHX_ filter_t funcp)
1780 if (PL_filter_debug)
1781 Perl_warn(aTHX_ "filter_del func %p", funcp);
1782 #endif /* DEBUGGING */
1783 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
1785 /* if filter is on top of stack (usual case) just pop it off */
1786 if (IoDIRP(FILTER_DATA(AvFILLp(PL_rsfp_filters))) == (DIR*)funcp){
1787 IoDIRP(FILTER_DATA(AvFILLp(PL_rsfp_filters))) = NULL;
1788 sv_free(av_pop(PL_rsfp_filters));
1792 /* we need to search for the correct entry and clear it */
1793 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
1797 /* Invoke the n'th filter function for the current rsfp. */
1799 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
1802 /* 0 = read one text line */
1807 if (!PL_rsfp_filters)
1809 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
1810 /* Provide a default input filter to make life easy. */
1811 /* Note that we append to the line. This is handy. */
1813 if (PL_filter_debug)
1814 Perl_warn(aTHX_ "filter_read %d: from rsfp\n", idx);
1815 #endif /* DEBUGGING */
1819 int old_len = SvCUR(buf_sv) ;
1821 /* ensure buf_sv is large enough */
1822 SvGROW(buf_sv, old_len + maxlen) ;
1823 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1824 if (PerlIO_error(PL_rsfp))
1825 return -1; /* error */
1827 return 0 ; /* end of file */
1829 SvCUR_set(buf_sv, old_len + len) ;
1832 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
1833 if (PerlIO_error(PL_rsfp))
1834 return -1; /* error */
1836 return 0 ; /* end of file */
1839 return SvCUR(buf_sv);
1841 /* Skip this filter slot if filter has been deleted */
1842 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
1844 if (PL_filter_debug)
1845 Perl_warn(aTHX_ "filter_read %d: skipped (filter deleted)\n", idx);
1846 #endif /* DEBUGGING */
1847 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1849 /* Get function pointer hidden within datasv */
1850 funcp = (filter_t)IoDIRP(datasv);
1852 if (PL_filter_debug) {
1854 Perl_warn(aTHX_ "filter_read %d: via function %p (%s)\n",
1855 idx, funcp, SvPV(datasv,n_a));
1857 #endif /* DEBUGGING */
1858 /* Call function. The function is expected to */
1859 /* call "FILTER_READ(idx+1, buf_sv)" first. */
1860 /* Return: <0:error, =0:eof, >0:not eof */
1861 return (*funcp)(aTHXo_ idx, buf_sv, maxlen);
1865 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
1868 if (!PL_rsfp_filters) {
1869 filter_add(win32_textfilter,NULL);
1872 if (PL_rsfp_filters) {
1875 SvCUR_set(sv, 0); /* start with empty line */
1876 if (FILTER_READ(0, sv, 0) > 0)
1877 return ( SvPVX(sv) ) ;
1882 return (sv_gets(sv, fp, append));
1887 static char* exp_name[] =
1888 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "TERMBLOCK" };
1894 Works out what to call the token just pulled out of the input
1895 stream. The yacc parser takes care of taking the ops we return and
1896 stitching them into a tree.
1902 if read an identifier
1903 if we're in a my declaration
1904 croak if they tried to say my($foo::bar)
1905 build the ops for a my() declaration
1906 if it's an access to a my() variable
1907 are we in a sort block?
1908 croak if my($a); $a <=> $b
1909 build ops for access to a my() variable
1910 if in a dq string, and they've said @foo and we can't find @foo
1912 build ops for a bareword
1913 if we already built the token before, use it.
1917 #ifdef USE_PURE_BISON
1918 Perl_yylex(pTHX_ YYSTYPE *lvalp, int *lcharp)
1931 #ifdef USE_PURE_BISON
1932 yylval_pointer = lvalp;
1933 yychar_pointer = lcharp;
1936 /* check if there's an identifier for us to look at */
1937 if (PL_pending_ident) {
1938 /* pit holds the identifier we read and pending_ident is reset */
1939 char pit = PL_pending_ident;
1940 PL_pending_ident = 0;
1942 /* if we're in a my(), we can't allow dynamics here.
1943 $foo'bar has already been turned into $foo::bar, so
1944 just check for colons.
1946 if it's a legal name, the OP is a PADANY.
1949 if (strchr(PL_tokenbuf,':'))
1950 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
1952 yylval.opval = newOP(OP_PADANY, 0);
1953 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
1958 build the ops for accesses to a my() variable.
1960 Deny my($a) or my($b) in a sort block, *if* $a or $b is
1961 then used in a comparison. This catches most, but not
1962 all cases. For instance, it catches
1963 sort { my($a); $a <=> $b }
1965 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
1966 (although why you'd do that is anyone's guess).
1969 if (!strchr(PL_tokenbuf,':')) {
1971 /* Check for single character per-thread SVs */
1972 if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
1973 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
1974 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
1976 yylval.opval = newOP(OP_THREADSV, 0);
1977 yylval.opval->op_targ = tmp;
1980 #endif /* USE_THREADS */
1981 if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
1982 /* if it's a sort block and they're naming $a or $b */
1983 if (PL_last_lop_op == OP_SORT &&
1984 PL_tokenbuf[0] == '$' &&
1985 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
1988 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
1989 d < PL_bufend && *d != '\n';
1992 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
1993 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
1999 yylval.opval = newOP(OP_PADANY, 0);
2000 yylval.opval->op_targ = tmp;
2006 Whine if they've said @foo in a doublequoted string,
2007 and @foo isn't a variable we can find in the symbol
2010 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
2011 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
2012 if (!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
2013 yyerror(Perl_form(aTHX_ "In string, %s now must be written as \\%s",
2014 PL_tokenbuf, PL_tokenbuf));
2017 /* build ops for a bareword */
2018 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
2019 yylval.opval->op_private = OPpCONST_ENTERED;
2020 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
2021 ((PL_tokenbuf[0] == '$') ? SVt_PV
2022 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
2027 /* no identifier pending identification */
2029 switch (PL_lex_state) {
2031 case LEX_NORMAL: /* Some compilers will produce faster */
2032 case LEX_INTERPNORMAL: /* code if we comment these out. */
2036 /* when we're already built the next token, just pull it out the queue */
2039 yylval = PL_nextval[PL_nexttoke];
2041 PL_lex_state = PL_lex_defer;
2042 PL_expect = PL_lex_expect;
2043 PL_lex_defer = LEX_NORMAL;
2045 return(PL_nexttype[PL_nexttoke]);
2047 /* interpolated case modifiers like \L \U, including \Q and \E.
2048 when we get here, PL_bufptr is at the \
2050 case LEX_INTERPCASEMOD:
2052 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
2053 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
2055 /* handle \E or end of string */
2056 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
2060 if (PL_lex_casemods) {
2061 oldmod = PL_lex_casestack[--PL_lex_casemods];
2062 PL_lex_casestack[PL_lex_casemods] = '\0';
2064 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
2066 PL_lex_state = LEX_INTERPCONCAT;
2070 if (PL_bufptr != PL_bufend)
2072 PL_lex_state = LEX_INTERPCONCAT;
2077 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
2078 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
2079 if (strchr("LU", *s) &&
2080 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
2082 PL_lex_casestack[--PL_lex_casemods] = '\0';
2085 if (PL_lex_casemods > 10) {
2086 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
2087 if (newlb != PL_lex_casestack) {
2089 PL_lex_casestack = newlb;
2092 PL_lex_casestack[PL_lex_casemods++] = *s;
2093 PL_lex_casestack[PL_lex_casemods] = '\0';
2094 PL_lex_state = LEX_INTERPCONCAT;
2095 PL_nextval[PL_nexttoke].ival = 0;
2098 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
2100 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
2102 PL_nextval[PL_nexttoke].ival = OP_LC;
2104 PL_nextval[PL_nexttoke].ival = OP_UC;
2106 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
2108 Perl_croak(aTHX_ "panic: yylex");
2111 if (PL_lex_starts) {
2120 case LEX_INTERPPUSH:
2121 return sublex_push();
2123 case LEX_INTERPSTART:
2124 if (PL_bufptr == PL_bufend)
2125 return sublex_done();
2127 PL_lex_dojoin = (*PL_bufptr == '@');
2128 PL_lex_state = LEX_INTERPNORMAL;
2129 if (PL_lex_dojoin) {
2130 PL_nextval[PL_nexttoke].ival = 0;
2133 PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
2134 PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
2135 force_next(PRIVATEREF);
2137 force_ident("\"", '$');
2138 #endif /* USE_THREADS */
2139 PL_nextval[PL_nexttoke].ival = 0;
2141 PL_nextval[PL_nexttoke].ival = 0;
2143 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
2146 if (PL_lex_starts++) {
2152 case LEX_INTERPENDMAYBE:
2153 if (intuit_more(PL_bufptr)) {
2154 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
2160 if (PL_lex_dojoin) {
2161 PL_lex_dojoin = FALSE;
2162 PL_lex_state = LEX_INTERPCONCAT;
2165 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
2166 && SvEVALED(PL_lex_repl))
2168 if (PL_bufptr != PL_bufend)
2169 Perl_croak(aTHX_ "Bad evalled substitution pattern");
2170 PL_lex_repl = Nullsv;
2173 case LEX_INTERPCONCAT:
2175 if (PL_lex_brackets)
2176 Perl_croak(aTHX_ "panic: INTERPCONCAT");
2178 if (PL_bufptr == PL_bufend)
2179 return sublex_done();
2181 if (SvIVX(PL_linestr) == '\'') {
2182 SV *sv = newSVsv(PL_linestr);
2185 else if ( PL_hints & HINT_NEW_RE )
2186 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
2187 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2191 s = scan_const(PL_bufptr);
2193 PL_lex_state = LEX_INTERPCASEMOD;
2195 PL_lex_state = LEX_INTERPSTART;
2198 if (s != PL_bufptr) {
2199 PL_nextval[PL_nexttoke] = yylval;
2202 if (PL_lex_starts++)
2212 PL_lex_state = LEX_NORMAL;
2213 s = scan_formline(PL_bufptr);
2214 if (!PL_lex_formbrack)
2220 PL_oldoldbufptr = PL_oldbufptr;
2223 PerlIO_printf(PerlIO_stderr(), "### Tokener expecting %s at %s\n", exp_name[PL_expect], s);
2229 if (isIDFIRST_lazy(s))
2231 Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
2234 goto fake_eof; /* emulate EOF on ^D or ^Z */
2239 if (PL_lex_brackets)
2240 yyerror("Missing right curly or square bracket");
2243 if (s++ < PL_bufend)
2244 goto retry; /* ignore stray nulls */
2247 if (!PL_in_eval && !PL_preambled) {
2248 PL_preambled = TRUE;
2249 sv_setpv(PL_linestr,incl_perldb());
2250 if (SvCUR(PL_linestr))
2251 sv_catpv(PL_linestr,";");
2253 while(AvFILLp(PL_preambleav) >= 0) {
2254 SV *tmpsv = av_shift(PL_preambleav);
2255 sv_catsv(PL_linestr, tmpsv);
2256 sv_catpv(PL_linestr, ";");
2259 sv_free((SV*)PL_preambleav);
2260 PL_preambleav = NULL;
2262 if (PL_minus_n || PL_minus_p) {
2263 sv_catpv(PL_linestr, "LINE: while (<>) {");
2265 sv_catpv(PL_linestr,"chomp;");
2267 GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
2269 GvIMPORTED_AV_on(gv);
2271 if (strchr("/'\"", *PL_splitstr)
2272 && strchr(PL_splitstr + 1, *PL_splitstr))
2273 Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s);", PL_splitstr);
2276 s = "'~#\200\1'"; /* surely one char is unused...*/
2277 while (s[1] && strchr(PL_splitstr, *s)) s++;
2279 Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s%c",
2280 "q" + (delim == '\''), delim);
2281 for (s = PL_splitstr; *s; s++) {
2283 sv_catpvn(PL_linestr, "\\", 1);
2284 sv_catpvn(PL_linestr, s, 1);
2286 Perl_sv_catpvf(aTHX_ PL_linestr, "%c);", delim);
2290 sv_catpv(PL_linestr,"@F=split(' ');");
2293 sv_catpv(PL_linestr, "\n");
2294 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2295 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2296 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2297 SV *sv = NEWSV(85,0);
2299 sv_upgrade(sv, SVt_PVMG);
2300 sv_setsv(sv,PL_linestr);
2301 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
2306 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
2309 if (PL_preprocess && !PL_in_eval)
2310 (void)PerlProc_pclose(PL_rsfp);
2311 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2312 PerlIO_clearerr(PL_rsfp);
2314 (void)PerlIO_close(PL_rsfp);
2316 PL_doextract = FALSE;
2318 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2319 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
2320 sv_catpv(PL_linestr,";}");
2321 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2322 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2323 PL_minus_n = PL_minus_p = 0;
2326 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2327 sv_setpv(PL_linestr,"");
2328 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
2331 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
2332 PL_doextract = FALSE;
2334 /* Incest with pod. */
2335 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2336 sv_setpv(PL_linestr, "");
2337 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2338 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2339 PL_doextract = FALSE;
2343 } while (PL_doextract);
2344 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2345 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2346 SV *sv = NEWSV(85,0);
2348 sv_upgrade(sv, SVt_PVMG);
2349 sv_setsv(sv,PL_linestr);
2350 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
2352 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2353 if (PL_curcop->cop_line == 1) {
2354 while (s < PL_bufend && isSPACE(*s))
2356 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2360 if (*s == '#' && *(s+1) == '!')
2362 #ifdef ALTERNATE_SHEBANG
2364 static char as[] = ALTERNATE_SHEBANG;
2365 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2366 d = s + (sizeof(as) - 1);
2368 #endif /* ALTERNATE_SHEBANG */
2377 while (*d && !isSPACE(*d))
2381 #ifdef ARG_ZERO_IS_SCRIPT
2382 if (ipathend > ipath) {
2384 * HP-UX (at least) sets argv[0] to the script name,
2385 * which makes $^X incorrect. And Digital UNIX and Linux,
2386 * at least, set argv[0] to the basename of the Perl
2387 * interpreter. So, having found "#!", we'll set it right.
2389 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
2390 assert(SvPOK(x) || SvGMAGICAL(x));
2391 if (sv_eq(x, GvSV(PL_curcop->cop_filegv))) {
2392 sv_setpvn(x, ipath, ipathend - ipath);
2395 TAINT_NOT; /* $^X is always tainted, but that's OK */
2397 #endif /* ARG_ZERO_IS_SCRIPT */
2402 d = instr(s,"perl -");
2404 d = instr(s,"perl");
2405 #ifdef ALTERNATE_SHEBANG
2407 * If the ALTERNATE_SHEBANG on this system starts with a
2408 * character that can be part of a Perl expression, then if
2409 * we see it but not "perl", we're probably looking at the
2410 * start of Perl code, not a request to hand off to some
2411 * other interpreter. Similarly, if "perl" is there, but
2412 * not in the first 'word' of the line, we assume the line
2413 * contains the start of the Perl program.
2415 if (d && *s != '#') {
2417 while (*c && !strchr("; \t\r\n\f\v#", *c))
2420 d = Nullch; /* "perl" not in first word; ignore */
2422 *s = '#'; /* Don't try to parse shebang line */
2424 #endif /* ALTERNATE_SHEBANG */
2429 !instr(s,"indir") &&
2430 instr(PL_origargv[0],"perl"))
2436 while (s < PL_bufend && isSPACE(*s))
2438 if (s < PL_bufend) {
2439 Newz(899,newargv,PL_origargc+3,char*);
2441 while (s < PL_bufend && !isSPACE(*s))
2444 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2447 newargv = PL_origargv;
2449 PerlProc_execv(ipath, newargv);
2450 Perl_croak(aTHX_ "Can't exec %s", ipath);
2453 U32 oldpdb = PL_perldb;
2454 bool oldn = PL_minus_n;
2455 bool oldp = PL_minus_p;
2457 while (*d && !isSPACE(*d)) d++;
2458 while (*d == ' ' || *d == '\t') d++;
2462 if (*d == 'M' || *d == 'm') {
2464 while (*d && !isSPACE(*d)) d++;
2465 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2468 d = moreswitches(d);
2470 if (PERLDB_LINE && !oldpdb ||
2471 ( PL_minus_n || PL_minus_p ) && !(oldn || oldp) )
2472 /* if we have already added "LINE: while (<>) {",
2473 we must not do it again */
2475 sv_setpv(PL_linestr, "");
2476 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2477 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2478 PL_preambled = FALSE;
2480 (void)gv_fetchfile(PL_origfilename);
2487 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2489 PL_lex_state = LEX_FORMLINE;
2494 #ifdef PERL_STRICT_CR
2495 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2497 "(Maybe you didn't strip carriage returns after a network transfer?)\n");
2499 case ' ': case '\t': case '\f': case 013:
2504 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2506 while (s < d && *s != '\n')
2511 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2513 PL_lex_state = LEX_FORMLINE;
2523 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2528 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2531 if (strnEQ(s,"=>",2)) {
2532 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2533 OPERATOR('-'); /* unary minus */
2535 PL_last_uni = PL_oldbufptr;
2536 PL_last_lop_op = OP_FTEREAD; /* good enough */
2538 case 'r': FTST(OP_FTEREAD);
2539 case 'w': FTST(OP_FTEWRITE);
2540 case 'x': FTST(OP_FTEEXEC);
2541 case 'o': FTST(OP_FTEOWNED);
2542 case 'R': FTST(OP_FTRREAD);
2543 case 'W': FTST(OP_FTRWRITE);
2544 case 'X': FTST(OP_FTREXEC);
2545 case 'O': FTST(OP_FTROWNED);
2546 case 'e': FTST(OP_FTIS);
2547 case 'z': FTST(OP_FTZERO);
2548 case 's': FTST(OP_FTSIZE);
2549 case 'f': FTST(OP_FTFILE);
2550 case 'd': FTST(OP_FTDIR);
2551 case 'l': FTST(OP_FTLINK);
2552 case 'p': FTST(OP_FTPIPE);
2553 case 'S': FTST(OP_FTSOCK);
2554 case 'u': FTST(OP_FTSUID);
2555 case 'g': FTST(OP_FTSGID);
2556 case 'k': FTST(OP_FTSVTX);
2557 case 'b': FTST(OP_FTBLK);
2558 case 'c': FTST(OP_FTCHR);
2559 case 't': FTST(OP_FTTTY);
2560 case 'T': FTST(OP_FTTEXT);
2561 case 'B': FTST(OP_FTBINARY);
2562 case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2563 case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2564 case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
2566 Perl_croak(aTHX_ "Unrecognized file test: -%c", (int)tmp);
2573 if (PL_expect == XOPERATOR)
2578 else if (*s == '>') {
2581 if (isIDFIRST_lazy(s)) {
2582 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2590 if (PL_expect == XOPERATOR)
2593 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2595 OPERATOR('-'); /* unary minus */
2602 if (PL_expect == XOPERATOR)
2607 if (PL_expect == XOPERATOR)
2610 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2616 if (PL_expect != XOPERATOR) {
2617 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2618 PL_expect = XOPERATOR;
2619 force_ident(PL_tokenbuf, '*');
2632 if (PL_expect == XOPERATOR) {
2636 PL_tokenbuf[0] = '%';
2637 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2638 if (!PL_tokenbuf[1]) {
2640 yyerror("Final % should be \\% or %name");
2643 PL_pending_ident = '%';
2665 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
2666 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
2671 if (PL_curcop->cop_line < PL_copline)
2672 PL_copline = PL_curcop->cop_line;
2683 if (PL_lex_brackets <= 0)
2684 yyerror("Unmatched right square bracket");
2687 if (PL_lex_state == LEX_INTERPNORMAL) {
2688 if (PL_lex_brackets == 0) {
2689 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
2690 PL_lex_state = LEX_INTERPEND;
2697 if (PL_lex_brackets > 100) {
2698 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
2699 if (newlb != PL_lex_brackstack) {
2701 PL_lex_brackstack = newlb;
2704 switch (PL_expect) {
2706 if (PL_lex_formbrack) {
2710 if (PL_oldoldbufptr == PL_last_lop)
2711 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2713 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2714 OPERATOR(HASHBRACK);
2716 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2719 PL_tokenbuf[0] = '\0';
2720 if (d < PL_bufend && *d == '-') {
2721 PL_tokenbuf[0] = '-';
2723 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2726 if (d < PL_bufend && isIDFIRST_lazy(d)) {
2727 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2729 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2732 char minus = (PL_tokenbuf[0] == '-');
2733 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2740 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
2744 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2749 if (PL_oldoldbufptr == PL_last_lop)
2750 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2752 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2755 OPERATOR(HASHBRACK);
2756 /* This hack serves to disambiguate a pair of curlies
2757 * as being a block or an anon hash. Normally, expectation
2758 * determines that, but in cases where we're not in a
2759 * position to expect anything in particular (like inside
2760 * eval"") we have to resolve the ambiguity. This code
2761 * covers the case where the first term in the curlies is a
2762 * quoted string. Most other cases need to be explicitly
2763 * disambiguated by prepending a `+' before the opening
2764 * curly in order to force resolution as an anon hash.
2766 * XXX should probably propagate the outer expectation
2767 * into eval"" to rely less on this hack, but that could
2768 * potentially break current behavior of eval"".
2772 if (*s == '\'' || *s == '"' || *s == '`') {
2773 /* common case: get past first string, handling escapes */
2774 for (t++; t < PL_bufend && *t != *s;)
2775 if (*t++ == '\\' && (*t == '\\' || *t == *s))
2779 else if (*s == 'q') {
2782 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
2783 && !isALNUM(*t)))) {
2785 char open, close, term;
2788 while (t < PL_bufend && isSPACE(*t))
2792 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
2796 for (t++; t < PL_bufend; t++) {
2797 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
2799 else if (*t == open)
2803 for (t++; t < PL_bufend; t++) {
2804 if (*t == '\\' && t+1 < PL_bufend)
2806 else if (*t == close && --brackets <= 0)
2808 else if (*t == open)
2814 else if (isIDFIRST_lazy(s)) {
2815 for (t++; t < PL_bufend && isALNUM_lazy(t); t++) ;
2817 while (t < PL_bufend && isSPACE(*t))
2819 /* if comma follows first term, call it an anon hash */
2820 /* XXX it could be a comma expression with loop modifiers */
2821 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
2822 || (*t == '=' && t[1] == '>')))
2823 OPERATOR(HASHBRACK);
2824 if (PL_expect == XREF)
2827 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
2833 yylval.ival = PL_curcop->cop_line;
2834 if (isSPACE(*s) || *s == '#')
2835 PL_copline = NOLINE; /* invalidate current command line number */
2840 if (PL_lex_brackets <= 0)
2841 yyerror("Unmatched right curly bracket");
2843 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
2844 if (PL_lex_brackets < PL_lex_formbrack)
2845 PL_lex_formbrack = 0;
2846 if (PL_lex_state == LEX_INTERPNORMAL) {
2847 if (PL_lex_brackets == 0) {
2848 if (PL_lex_fakebrack) {
2849 PL_lex_state = LEX_INTERPEND;
2851 return yylex(); /* ignore fake brackets */
2853 if (*s == '-' && s[1] == '>')
2854 PL_lex_state = LEX_INTERPENDMAYBE;
2855 else if (*s != '[' && *s != '{')
2856 PL_lex_state = LEX_INTERPEND;
2859 if (PL_lex_brackets < PL_lex_fakebrack) {
2861 PL_lex_fakebrack = 0;
2862 return yylex(); /* ignore fake brackets */
2872 if (PL_expect == XOPERATOR) {
2873 if (ckWARN(WARN_SEMICOLON) && isIDFIRST_lazy(s) && PL_bufptr == PL_linestart) {
2874 PL_curcop->cop_line--;
2875 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
2876 PL_curcop->cop_line++;
2881 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2883 PL_expect = XOPERATOR;
2884 force_ident(PL_tokenbuf, '&');
2888 yylval.ival = (OPpENTERSUB_AMPER<<8);
2907 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
2908 Perl_warner(aTHX_ WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
2910 if (PL_expect == XSTATE && isALPHA(tmp) &&
2911 (s == PL_linestart+1 || s[-2] == '\n') )
2913 if (PL_in_eval && !PL_rsfp) {
2918 if (strnEQ(s,"=cut",4)) {
2932 PL_doextract = TRUE;
2935 if (PL_lex_brackets < PL_lex_formbrack) {
2937 #ifdef PERL_STRICT_CR
2938 for (t = s; *t == ' ' || *t == '\t'; t++) ;
2940 for (t = s; *t == ' ' || *t == '\t' || *t == '\r'; t++) ;
2942 if (*t == '\n' || *t == '#') {
2960 if (PL_expect != XOPERATOR) {
2961 if (s[1] != '<' && !strchr(s,'>'))
2964 s = scan_heredoc(s);
2966 s = scan_inputsymbol(s);
2967 TERM(sublex_start());
2972 SHop(OP_LEFT_SHIFT);
2986 SHop(OP_RIGHT_SHIFT);
2995 if (PL_expect == XOPERATOR) {
2996 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2999 return ','; /* grandfather non-comma-format format */
3003 if (s[1] == '#' && (isIDFIRST_lazy(s+2) || strchr("{$:+-", s[2]))) {
3004 PL_tokenbuf[0] = '@';
3005 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3006 sizeof PL_tokenbuf - 1, FALSE);
3007 if (PL_expect == XOPERATOR)
3008 no_op("Array length", s);
3009 if (!PL_tokenbuf[1])
3011 PL_expect = XOPERATOR;
3012 PL_pending_ident = '#';
3016 PL_tokenbuf[0] = '$';
3017 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3018 sizeof PL_tokenbuf - 1, FALSE);
3019 if (PL_expect == XOPERATOR)
3021 if (!PL_tokenbuf[1]) {
3023 yyerror("Final $ should be \\$ or $name");
3027 /* This kludge not intended to be bulletproof. */
3028 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
3029 yylval.opval = newSVOP(OP_CONST, 0,
3030 newSViv((IV)PL_compiling.cop_arybase));
3031 yylval.opval->op_private = OPpCONST_ARYBASE;
3037 if (PL_lex_state == LEX_NORMAL)
3040 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3043 PL_tokenbuf[0] = '@';
3044 if (ckWARN(WARN_SYNTAX)) {
3046 isSPACE(*t) || isALNUM_lazy(t) || *t == '$';
3049 PL_bufptr = skipspace(PL_bufptr);
3050 while (t < PL_bufend && *t != ']')
3052 Perl_warner(aTHX_ WARN_SYNTAX,
3053 "Multidimensional syntax %.*s not supported",
3054 (t - PL_bufptr) + 1, PL_bufptr);
3058 else if (*s == '{') {
3059 PL_tokenbuf[0] = '%';
3060 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
3061 (t = strchr(s, '}')) && (t = strchr(t, '=')))
3063 char tmpbuf[sizeof PL_tokenbuf];
3065 for (t++; isSPACE(*t); t++) ;
3066 if (isIDFIRST_lazy(t)) {
3067 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
3068 for (; isSPACE(*t); t++) ;
3069 if (*t == ';' && get_cv(tmpbuf, FALSE))
3070 Perl_warner(aTHX_ WARN_SYNTAX,
3071 "You need to quote \"%s\"", tmpbuf);
3077 PL_expect = XOPERATOR;
3078 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3079 bool islop = (PL_last_lop == PL_oldoldbufptr);
3080 if (!islop || PL_last_lop_op == OP_GREPSTART)
3081 PL_expect = XOPERATOR;
3082 else if (strchr("$@\"'`q", *s))
3083 PL_expect = XTERM; /* e.g. print $fh "foo" */
3084 else if (strchr("&*<%", *s) && isIDFIRST_lazy(s+1))
3085 PL_expect = XTERM; /* e.g. print $fh &sub */
3086 else if (isIDFIRST_lazy(s)) {
3087 char tmpbuf[sizeof PL_tokenbuf];
3088 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3089 if (tmp = keyword(tmpbuf, len)) {
3090 /* binary operators exclude handle interpretations */
3102 PL_expect = XTERM; /* e.g. print $fh length() */
3107 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
3108 if (gv && GvCVu(gv))
3109 PL_expect = XTERM; /* e.g. print $fh subr() */
3112 else if (isDIGIT(*s))
3113 PL_expect = XTERM; /* e.g. print $fh 3 */
3114 else if (*s == '.' && isDIGIT(s[1]))
3115 PL_expect = XTERM; /* e.g. print $fh .3 */
3116 else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
3117 PL_expect = XTERM; /* e.g. print $fh -1 */
3118 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3119 PL_expect = XTERM; /* print $fh <<"EOF" */
3121 PL_pending_ident = '$';
3125 if (PL_expect == XOPERATOR)
3127 PL_tokenbuf[0] = '@';
3128 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3129 if (!PL_tokenbuf[1]) {
3131 yyerror("Final @ should be \\@ or @name");
3134 if (PL_lex_state == LEX_NORMAL)
3136 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3138 PL_tokenbuf[0] = '%';
3140 /* Warn about @ where they meant $. */
3141 if (ckWARN(WARN_SYNTAX)) {
3142 if (*s == '[' || *s == '{') {
3144 while (*t && (isALNUM_lazy(t) || strchr(" \t$#+-'\"", *t)))
3146 if (*t == '}' || *t == ']') {
3148 PL_bufptr = skipspace(PL_bufptr);
3149 Perl_warner(aTHX_ WARN_SYNTAX,
3150 "Scalar value %.*s better written as $%.*s",
3151 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
3156 PL_pending_ident = '@';
3159 case '/': /* may either be division or pattern */
3160 case '?': /* may either be conditional or pattern */
3161 if (PL_expect != XOPERATOR) {
3162 /* Disable warning on "study /blah/" */
3163 if (PL_oldoldbufptr == PL_last_uni
3164 && (*PL_last_uni != 's' || s - PL_last_uni < 5
3165 || memNE(PL_last_uni, "study", 5) || isALNUM_lazy(PL_last_uni+5)))
3167 s = scan_pat(s,OP_MATCH);
3168 TERM(sublex_start());
3176 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3177 #ifdef PERL_STRICT_CR
3180 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3182 && (s == PL_linestart || s[-1] == '\n') )
3184 PL_lex_formbrack = 0;
3188 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
3194 yylval.ival = OPf_SPECIAL;
3200 if (PL_expect != XOPERATOR)
3205 case '0': case '1': case '2': case '3': case '4':
3206 case '5': case '6': case '7': case '8': case '9':
3208 if (PL_expect == XOPERATOR)
3214 if (PL_expect == XOPERATOR) {
3215 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3218 return ','; /* grandfather non-comma-format format */
3224 missingterm((char*)0);
3225 yylval.ival = OP_CONST;
3226 TERM(sublex_start());
3230 if (PL_expect == XOPERATOR) {
3231 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3234 return ','; /* grandfather non-comma-format format */
3240 missingterm((char*)0);
3241 yylval.ival = OP_CONST;
3242 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
3243 if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
3244 yylval.ival = OP_STRINGIFY;
3248 TERM(sublex_start());
3252 if (PL_expect == XOPERATOR)
3253 no_op("Backticks",s);
3255 missingterm((char*)0);
3256 yylval.ival = OP_BACKTICK;
3258 TERM(sublex_start());
3262 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
3263 Perl_warner(aTHX_ WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
3265 if (PL_expect == XOPERATOR)
3266 no_op("Backslash",s);
3270 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
3310 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3312 /* Some keywords can be followed by any delimiter, including ':' */
3313 tmp = (len == 1 && strchr("msyq", PL_tokenbuf[0]) ||
3314 len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
3315 (PL_tokenbuf[0] == 'q' &&
3316 strchr("qwxr", PL_tokenbuf[1]))));
3318 /* x::* is just a word, unless x is "CORE" */
3319 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
3323 while (d < PL_bufend && isSPACE(*d))
3324 d++; /* no comments skipped here, or s### is misparsed */
3326 /* Is this a label? */
3327 if (!tmp && PL_expect == XSTATE
3328 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
3330 yylval.pval = savepv(PL_tokenbuf);
3335 /* Check for keywords */
3336 tmp = keyword(PL_tokenbuf, len);
3338 /* Is this a word before a => operator? */
3339 if (strnEQ(d,"=>",2)) {
3341 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
3342 yylval.opval->op_private = OPpCONST_BARE;
3346 if (tmp < 0) { /* second-class keyword? */
3347 GV *ogv = Nullgv; /* override (winner) */
3348 GV *hgv = Nullgv; /* hidden (loser) */
3349 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3351 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3354 if (GvIMPORTED_CV(gv))
3356 else if (! CvMETHOD(cv))
3360 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3361 (gv = *gvp) != (GV*)&PL_sv_undef &&
3362 GvCVu(gv) && GvIMPORTED_CV(gv))
3368 tmp = 0; /* overridden by import or by GLOBAL */
3371 && -tmp==KEY_lock /* XXX generalizable kludge */
3372 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3374 tmp = 0; /* any sub overrides "weak" keyword */
3376 else { /* no override */
3380 if (ckWARN(WARN_AMBIGUOUS) && hgv
3381 && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3382 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3383 "Ambiguous call resolved as CORE::%s(), %s",
3384 GvENAME(hgv), "qualify as such or use &");
3391 default: /* not a keyword */
3394 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3396 /* Get the rest if it looks like a package qualifier */
3398 if (*s == '\'' || *s == ':' && s[1] == ':') {
3400 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3403 Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
3404 *s == '\'' ? "'" : "::");
3408 if (PL_expect == XOPERATOR) {
3409 if (PL_bufptr == PL_linestart) {
3410 PL_curcop->cop_line--;
3411 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3412 PL_curcop->cop_line++;
3415 no_op("Bareword",s);
3418 /* Look for a subroutine with this name in current package,
3419 unless name is "Foo::", in which case Foo is a bearword
3420 (and a package name). */
3423 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3425 if (ckWARN(WARN_UNSAFE) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3426 Perl_warner(aTHX_ WARN_UNSAFE,
3427 "Bareword \"%s\" refers to nonexistent package",
3430 PL_tokenbuf[len] = '\0';
3437 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3440 /* if we saw a global override before, get the right name */
3443 sv = newSVpvn("CORE::GLOBAL::",14);
3444 sv_catpv(sv,PL_tokenbuf);
3447 sv = newSVpv(PL_tokenbuf,0);
3449 /* Presume this is going to be a bareword of some sort. */
3452 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3453 yylval.opval->op_private = OPpCONST_BARE;
3455 /* And if "Foo::", then that's what it certainly is. */
3460 /* See if it's the indirect object for a list operator. */
3462 if (PL_oldoldbufptr &&
3463 PL_oldoldbufptr < PL_bufptr &&
3464 (PL_oldoldbufptr == PL_last_lop || PL_oldoldbufptr == PL_last_uni) &&
3465 /* NO SKIPSPACE BEFORE HERE! */
3466 (PL_expect == XREF ||
3467 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
3469 bool immediate_paren = *s == '(';
3471 /* (Now we can afford to cross potential line boundary.) */
3474 /* Two barewords in a row may indicate method call. */
3476 if ((isIDFIRST_lazy(s) || *s == '$') && (tmp=intuit_method(s,gv)))
3479 /* If not a declared subroutine, it's an indirect object. */
3480 /* (But it's an indir obj regardless for sort.) */
3482 if ((PL_last_lop_op == OP_SORT ||
3483 (!immediate_paren && (!gv || !GvCVu(gv)))) &&
3484 (PL_last_lop_op != OP_MAPSTART &&
3485 PL_last_lop_op != OP_GREPSTART))
3487 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3492 /* If followed by a paren, it's certainly a subroutine. */
3494 PL_expect = XOPERATOR;
3498 if (gv && GvCVu(gv)) {
3499 for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
3500 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
3505 PL_nextval[PL_nexttoke].opval = yylval.opval;
3506 PL_expect = XOPERATOR;
3512 /* If followed by var or block, call it a method (unless sub) */
3514 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3515 PL_last_lop = PL_oldbufptr;
3516 PL_last_lop_op = OP_METHOD;
3520 /* If followed by a bareword, see if it looks like indir obj. */
3522 if ((isIDFIRST_lazy(s) || *s == '$') && (tmp = intuit_method(s,gv)))
3525 /* Not a method, so call it a subroutine (if defined) */
3527 if (gv && GvCVu(gv)) {
3529 if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
3530 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3531 "Ambiguous use of -%s resolved as -&%s()",
3532 PL_tokenbuf, PL_tokenbuf);
3533 /* Check for a constant sub */
3535 if ((sv = cv_const_sv(cv))) {
3537 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3538 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3539 yylval.opval->op_private = 0;
3543 /* Resolve to GV now. */
3544 op_free(yylval.opval);
3545 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3546 yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
3547 PL_last_lop = PL_oldbufptr;
3548 PL_last_lop_op = OP_ENTERSUB;
3549 /* Is there a prototype? */
3552 char *proto = SvPV((SV*)cv, len);
3555 if (strEQ(proto, "$"))
3557 if (*proto == '&' && *s == '{') {
3558 sv_setpv(PL_subname,"__ANON__");
3562 PL_nextval[PL_nexttoke].opval = yylval.opval;
3568 /* Call it a bare word */
3570 if (PL_hints & HINT_STRICT_SUBS)
3571 yylval.opval->op_private |= OPpCONST_STRICT;
3574 if (ckWARN(WARN_RESERVED)) {
3575 if (lastchar != '-') {
3576 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3578 Perl_warner(aTHX_ WARN_RESERVED, PL_warn_reserved,
3585 if (lastchar && strchr("*%&", lastchar) && ckWARN_d(WARN_AMBIGUOUS)) {
3586 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3587 "Operator or semicolon missing before %c%s",
3588 lastchar, PL_tokenbuf);
3589 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3590 "Ambiguous use of %c resolved as operator %c",
3591 lastchar, lastchar);
3597 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3598 newSVsv(GvSV(PL_curcop->cop_filegv)));
3603 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3604 Perl_newSVpvf(aTHX_ "%" PERL_PRId64, (IV)PL_curcop->cop_line));
3606 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3607 Perl_newSVpvf(aTHX_ "%ld", (long)PL_curcop->cop_line));
3611 case KEY___PACKAGE__:
3612 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3614 ? newSVsv(PL_curstname)
3623 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3624 char *pname = "main";
3625 if (PL_tokenbuf[2] == 'D')
3626 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3627 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
3630 GvIOp(gv) = newIO();
3631 IoIFP(GvIOp(gv)) = PL_rsfp;
3632 #if defined(HAS_FCNTL) && defined(F_SETFD)
3634 int fd = PerlIO_fileno(PL_rsfp);
3635 fcntl(fd,F_SETFD,fd >= 3);
3638 /* Mark this internal pseudo-handle as clean */
3639 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3641 IoTYPE(GvIOp(gv)) = '|';
3642 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
3643 IoTYPE(GvIOp(gv)) = '-';
3645 IoTYPE(GvIOp(gv)) = '<';
3656 if (PL_expect == XSTATE) {
3663 if (*s == ':' && s[1] == ':') {
3666 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3667 tmp = keyword(PL_tokenbuf, len);
3681 LOP(OP_ACCEPT,XTERM);
3687 LOP(OP_ATAN2,XTERM);
3696 LOP(OP_BLESS,XTERM);
3705 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
3722 if (!PL_cryptseen++)
3725 LOP(OP_CRYPT,XTERM);
3728 if (ckWARN(WARN_OCTAL)) {
3729 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
3730 if (*d != '0' && isDIGIT(*d))
3731 yywarn("chmod: mode argument is missing initial 0");
3733 LOP(OP_CHMOD,XTERM);
3736 LOP(OP_CHOWN,XTERM);
3739 LOP(OP_CONNECT,XTERM);
3755 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3759 PL_hints |= HINT_BLOCK_SCOPE;
3769 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3770 LOP(OP_DBMOPEN,XTERM);
3776 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3783 yylval.ival = PL_curcop->cop_line;
3797 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
3798 UNIBRACK(OP_ENTEREVAL);
3813 case KEY_endhostent:
3819 case KEY_endservent:
3822 case KEY_endprotoent:
3833 yylval.ival = PL_curcop->cop_line;
3835 if (PL_expect == XSTATE && isIDFIRST_lazy(s)) {
3837 if ((PL_bufend - p) >= 3 &&
3838 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3841 if (isIDFIRST_lazy(p))
3842 Perl_croak(aTHX_ "Missing $ on loop variable");
3847 LOP(OP_FORMLINE,XTERM);
3853 LOP(OP_FCNTL,XTERM);
3859 LOP(OP_FLOCK,XTERM);
3868 LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
3871 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3886 case KEY_getpriority:
3887 LOP(OP_GETPRIORITY,XTERM);
3889 case KEY_getprotobyname:
3892 case KEY_getprotobynumber:
3893 LOP(OP_GPBYNUMBER,XTERM);
3895 case KEY_getprotoent:
3907 case KEY_getpeername:
3908 UNI(OP_GETPEERNAME);
3910 case KEY_gethostbyname:
3913 case KEY_gethostbyaddr:
3914 LOP(OP_GHBYADDR,XTERM);
3916 case KEY_gethostent:
3919 case KEY_getnetbyname:
3922 case KEY_getnetbyaddr:
3923 LOP(OP_GNBYADDR,XTERM);
3928 case KEY_getservbyname:
3929 LOP(OP_GSBYNAME,XTERM);
3931 case KEY_getservbyport:
3932 LOP(OP_GSBYPORT,XTERM);
3934 case KEY_getservent:
3937 case KEY_getsockname:
3938 UNI(OP_GETSOCKNAME);
3940 case KEY_getsockopt:
3941 LOP(OP_GSOCKOPT,XTERM);
3963 yylval.ival = PL_curcop->cop_line;
3967 LOP(OP_INDEX,XTERM);
3973 LOP(OP_IOCTL,XTERM);
3985 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4016 LOP(OP_LISTEN,XTERM);
4025 s = scan_pat(s,OP_MATCH);
4026 TERM(sublex_start());
4029 LOP(OP_MAPSTART, *s == '(' ? XTERM : XREF);
4032 LOP(OP_MKDIR,XTERM);
4035 LOP(OP_MSGCTL,XTERM);
4038 LOP(OP_MSGGET,XTERM);
4041 LOP(OP_MSGRCV,XTERM);
4044 LOP(OP_MSGSND,XTERM);
4049 if (isIDFIRST_lazy(s)) {
4050 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
4051 PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
4052 if (!PL_in_my_stash) {
4055 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
4062 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4069 if (PL_expect != XSTATE)
4070 yyerror("\"no\" not allowed in expression");
4071 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4072 s = force_version(s);
4081 if (isIDFIRST_lazy(s)) {
4083 for (d = s; isALNUM_lazy(d); d++) ;
4085 if (strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_AMBIGUOUS))
4086 Perl_warner(aTHX_ WARN_AMBIGUOUS,
4087 "Precedence problem: open %.*s should be open(%.*s)",
4093 yylval.ival = OP_OR;
4103 LOP(OP_OPEN_DIR,XTERM);
4106 checkcomma(s,PL_tokenbuf,"filehandle");
4110 checkcomma(s,PL_tokenbuf,"filehandle");
4129 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4133 LOP(OP_PIPE_OP,XTERM);
4138 missingterm((char*)0);
4139 yylval.ival = OP_CONST;
4140 TERM(sublex_start());
4148 missingterm((char*)0);
4150 if (SvCUR(PL_lex_stuff)) {
4153 d = SvPV_force(PL_lex_stuff, len);
4155 for (; isSPACE(*d) && len; --len, ++d) ;
4158 if (!warned && ckWARN(WARN_SYNTAX)) {
4159 for (; !isSPACE(*d) && len; --len, ++d) {
4161 Perl_warner(aTHX_ WARN_SYNTAX,
4162 "Possible attempt to separate words with commas");
4165 else if (*d == '#') {
4166 Perl_warner(aTHX_ WARN_SYNTAX,
4167 "Possible attempt to put comments in qw() list");
4173 for (; !isSPACE(*d) && len; --len, ++d) ;
4175 words = append_elem(OP_LIST, words,
4176 newSVOP(OP_CONST, 0, newSVpvn(b, d-b)));
4180 PL_nextval[PL_nexttoke].opval = words;
4185 SvREFCNT_dec(PL_lex_stuff);
4186 PL_lex_stuff = Nullsv;
4193 missingterm((char*)0);
4194 yylval.ival = OP_STRINGIFY;
4195 if (SvIVX(PL_lex_stuff) == '\'')
4196 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
4197 TERM(sublex_start());
4200 s = scan_pat(s,OP_QR);
4201 TERM(sublex_start());
4206 missingterm((char*)0);
4207 yylval.ival = OP_BACKTICK;
4209 TERM(sublex_start());
4215 *PL_tokenbuf = '\0';
4216 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4217 if (isIDFIRST_lazy(PL_tokenbuf))
4218 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
4220 yyerror("<> should be quotes");
4227 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4231 LOP(OP_RENAME,XTERM);
4240 LOP(OP_RINDEX,XTERM);
4263 LOP(OP_REVERSE,XTERM);
4274 TERM(sublex_start());
4276 TOKEN(1); /* force error */
4285 LOP(OP_SELECT,XTERM);
4291 LOP(OP_SEMCTL,XTERM);
4294 LOP(OP_SEMGET,XTERM);
4297 LOP(OP_SEMOP,XTERM);
4303 LOP(OP_SETPGRP,XTERM);
4305 case KEY_setpriority:
4306 LOP(OP_SETPRIORITY,XTERM);
4308 case KEY_sethostent:
4314 case KEY_setservent:
4317 case KEY_setprotoent:
4327 LOP(OP_SEEKDIR,XTERM);
4329 case KEY_setsockopt:
4330 LOP(OP_SSOCKOPT,XTERM);
4336 LOP(OP_SHMCTL,XTERM);
4339 LOP(OP_SHMGET,XTERM);
4342 LOP(OP_SHMREAD,XTERM);
4345 LOP(OP_SHMWRITE,XTERM);
4348 LOP(OP_SHUTDOWN,XTERM);
4357 LOP(OP_SOCKET,XTERM);
4359 case KEY_socketpair:
4360 LOP(OP_SOCKPAIR,XTERM);
4363 checkcomma(s,PL_tokenbuf,"subroutine name");
4365 if (*s == ';' || *s == ')') /* probably a close */
4366 Perl_croak(aTHX_ "sort is now a reserved word");
4368 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4372 LOP(OP_SPLIT,XTERM);
4375 LOP(OP_SPRINTF,XTERM);
4378 LOP(OP_SPLICE,XTERM);
4394 LOP(OP_SUBSTR,XTERM);
4401 if (isIDFIRST_lazy(s) || *s == '\'' || *s == ':') {
4402 char tmpbuf[sizeof PL_tokenbuf];
4404 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4405 if (strchr(tmpbuf, ':'))
4406 sv_setpv(PL_subname, tmpbuf);
4408 sv_setsv(PL_subname,PL_curstname);
4409 sv_catpvn(PL_subname,"::",2);
4410 sv_catpvn(PL_subname,tmpbuf,len);
4412 s = force_word(s,WORD,FALSE,TRUE,TRUE);
4416 PL_expect = XTERMBLOCK;
4417 sv_setpv(PL_subname,"?");
4420 if (tmp == KEY_format) {
4423 PL_lex_formbrack = PL_lex_brackets + 1;
4427 /* Look for a prototype */
4434 SvREFCNT_dec(PL_lex_stuff);
4435 PL_lex_stuff = Nullsv;
4436 Perl_croak(aTHX_ "Prototype not terminated");
4439 d = SvPVX(PL_lex_stuff);
4441 for (p = d; *p; ++p) {
4446 SvCUR(PL_lex_stuff) = tmp;
4449 PL_nextval[1] = PL_nextval[0];
4450 PL_nexttype[1] = PL_nexttype[0];
4451 PL_nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4452 PL_nexttype[0] = THING;
4453 if (PL_nexttoke == 1) {
4454 PL_lex_defer = PL_lex_state;
4455 PL_lex_expect = PL_expect;
4456 PL_lex_state = LEX_KNOWNEXT;
4458 PL_lex_stuff = Nullsv;
4461 if (*SvPV(PL_subname,n_a) == '?') {
4462 sv_setpv(PL_subname,"__ANON__");
4469 LOP(OP_SYSTEM,XREF);
4472 LOP(OP_SYMLINK,XTERM);
4475 LOP(OP_SYSCALL,XTERM);
4478 LOP(OP_SYSOPEN,XTERM);
4481 LOP(OP_SYSSEEK,XTERM);
4484 LOP(OP_SYSREAD,XTERM);
4487 LOP(OP_SYSWRITE,XTERM);
4491 TERM(sublex_start());
4512 LOP(OP_TRUNCATE,XTERM);
4524 yylval.ival = PL_curcop->cop_line;
4528 yylval.ival = PL_curcop->cop_line;
4532 LOP(OP_UNLINK,XTERM);
4538 LOP(OP_UNPACK,XTERM);
4541 LOP(OP_UTIME,XTERM);
4544 if (ckWARN(WARN_OCTAL)) {
4545 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4546 if (*d != '0' && isDIGIT(*d))
4547 yywarn("umask: argument is missing initial 0");
4552 LOP(OP_UNSHIFT,XTERM);
4555 if (PL_expect != XSTATE)
4556 yyerror("\"use\" not allowed in expression");
4559 s = force_version(s);
4560 if(*s == ';' || (s = skipspace(s), *s == ';')) {
4561 PL_nextval[PL_nexttoke].opval = Nullop;
4566 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4567 s = force_version(s);
4580 yylval.ival = PL_curcop->cop_line;
4584 PL_hints |= HINT_BLOCK_SCOPE;
4591 LOP(OP_WAITPID,XTERM);
4599 static char ctl_l[2];
4601 if (ctl_l[0] == '\0')
4602 ctl_l[0] = toCTRL('L');
4603 gv_fetchpv(ctl_l,TRUE, SVt_PV);
4606 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
4611 if (PL_expect == XOPERATOR)
4617 yylval.ival = OP_XOR;
4622 TERM(sublex_start());
4628 Perl_keyword(pTHX_ register char *d, I32 len)
4633 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
4634 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
4635 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
4636 if (strEQ(d,"__DATA__")) return KEY___DATA__;
4637 if (strEQ(d,"__END__")) return KEY___END__;
4641 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
4646 if (strEQ(d,"and")) return -KEY_and;
4647 if (strEQ(d,"abs")) return -KEY_abs;
4650 if (strEQ(d,"alarm")) return -KEY_alarm;
4651 if (strEQ(d,"atan2")) return -KEY_atan2;
4654 if (strEQ(d,"accept")) return -KEY_accept;
4659 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
4662 if (strEQ(d,"bless")) return -KEY_bless;
4663 if (strEQ(d,"bind")) return -KEY_bind;
4664 if (strEQ(d,"binmode")) return -KEY_binmode;
4667 if (strEQ(d,"CORE")) return -KEY_CORE;
4672 if (strEQ(d,"cmp")) return -KEY_cmp;
4673 if (strEQ(d,"chr")) return -KEY_chr;
4674 if (strEQ(d,"cos")) return -KEY_cos;
4677 if (strEQ(d,"chop")) return KEY_chop;
4680 if (strEQ(d,"close")) return -KEY_close;
4681 if (strEQ(d,"chdir")) return -KEY_chdir;
4682 if (strEQ(d,"chomp")) return KEY_chomp;
4683 if (strEQ(d,"chmod")) return -KEY_chmod;
4684 if (strEQ(d,"chown")) return -KEY_chown;
4685 if (strEQ(d,"crypt")) return -KEY_crypt;
4688 if (strEQ(d,"chroot")) return -KEY_chroot;
4689 if (strEQ(d,"caller")) return -KEY_caller;
4692 if (strEQ(d,"connect")) return -KEY_connect;
4695 if (strEQ(d,"closedir")) return -KEY_closedir;
4696 if (strEQ(d,"continue")) return -KEY_continue;
4701 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
4706 if (strEQ(d,"do")) return KEY_do;
4709 if (strEQ(d,"die")) return -KEY_die;
4712 if (strEQ(d,"dump")) return -KEY_dump;
4715 if (strEQ(d,"delete")) return KEY_delete;
4718 if (strEQ(d,"defined")) return KEY_defined;
4719 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
4722 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
4727 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
4728 if (strEQ(d,"END")) return KEY_END;
4733 if (strEQ(d,"eq")) return -KEY_eq;
4736 if (strEQ(d,"eof")) return -KEY_eof;
4737 if (strEQ(d,"exp")) return -KEY_exp;
4740 if (strEQ(d,"else")) return KEY_else;
4741 if (strEQ(d,"exit")) return -KEY_exit;
4742 if (strEQ(d,"eval")) return KEY_eval;
4743 if (strEQ(d,"exec")) return -KEY_exec;
4744 if (strEQ(d,"each")) return KEY_each;
4747 if (strEQ(d,"elsif")) return KEY_elsif;
4750 if (strEQ(d,"exists")) return KEY_exists;
4751 if (strEQ(d,"elseif")) Perl_warn(aTHX_ "elseif should be elsif");
4754 if (strEQ(d,"endgrent")) return -KEY_endgrent;
4755 if (strEQ(d,"endpwent")) return -KEY_endpwent;
4758 if (strEQ(d,"endnetent")) return -KEY_endnetent;
4761 if (strEQ(d,"endhostent")) return -KEY_endhostent;
4762 if (strEQ(d,"endservent")) return -KEY_endservent;
4765 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
4772 if (strEQ(d,"for")) return KEY_for;
4775 if (strEQ(d,"fork")) return -KEY_fork;
4778 if (strEQ(d,"fcntl")) return -KEY_fcntl;
4779 if (strEQ(d,"flock")) return -KEY_flock;
4782 if (strEQ(d,"format")) return KEY_format;
4783 if (strEQ(d,"fileno")) return -KEY_fileno;
4786 if (strEQ(d,"foreach")) return KEY_foreach;
4789 if (strEQ(d,"formline")) return -KEY_formline;
4795 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
4796 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
4800 if (strnEQ(d,"get",3)) {
4805 if (strEQ(d,"ppid")) return -KEY_getppid;
4806 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
4809 if (strEQ(d,"pwent")) return -KEY_getpwent;
4810 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
4811 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
4814 if (strEQ(d,"peername")) return -KEY_getpeername;
4815 if (strEQ(d,"protoent")) return -KEY_getprotoent;
4816 if (strEQ(d,"priority")) return -KEY_getpriority;
4819 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
4822 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
4826 else if (*d == 'h') {
4827 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
4828 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
4829 if (strEQ(d,"hostent")) return -KEY_gethostent;
4831 else if (*d == 'n') {
4832 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
4833 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
4834 if (strEQ(d,"netent")) return -KEY_getnetent;
4836 else if (*d == 's') {
4837 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
4838 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
4839 if (strEQ(d,"servent")) return -KEY_getservent;
4840 if (strEQ(d,"sockname")) return -KEY_getsockname;
4841 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
4843 else if (*d == 'g') {
4844 if (strEQ(d,"grent")) return -KEY_getgrent;
4845 if (strEQ(d,"grnam")) return -KEY_getgrnam;
4846 if (strEQ(d,"grgid")) return -KEY_getgrgid;
4848 else if (*d == 'l') {
4849 if (strEQ(d,"login")) return -KEY_getlogin;
4851 else if (strEQ(d,"c")) return -KEY_getc;
4856 if (strEQ(d,"gt")) return -KEY_gt;
4857 if (strEQ(d,"ge")) return -KEY_ge;
4860 if (strEQ(d,"grep")) return KEY_grep;
4861 if (strEQ(d,"goto")) return KEY_goto;
4862 if (strEQ(d,"glob")) return KEY_glob;
4865 if (strEQ(d,"gmtime")) return -KEY_gmtime;
4870 if (strEQ(d,"hex")) return -KEY_hex;
4873 if (strEQ(d,"INIT")) return KEY_INIT;
4878 if (strEQ(d,"if")) return KEY_if;
4881 if (strEQ(d,"int")) return -KEY_int;
4884 if (strEQ(d,"index")) return -KEY_index;
4885 if (strEQ(d,"ioctl")) return -KEY_ioctl;
4890 if (strEQ(d,"join")) return -KEY_join;
4894 if (strEQ(d,"keys")) return KEY_keys;
4895 if (strEQ(d,"kill")) return -KEY_kill;
4900 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
4901 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
4907 if (strEQ(d,"lt")) return -KEY_lt;
4908 if (strEQ(d,"le")) return -KEY_le;
4909 if (strEQ(d,"lc")) return -KEY_lc;
4912 if (strEQ(d,"log")) return -KEY_log;
4915 if (strEQ(d,"last")) return KEY_last;
4916 if (strEQ(d,"link")) return -KEY_link;
4917 if (strEQ(d,"lock")) return -KEY_lock;
4920 if (strEQ(d,"local")) return KEY_local;
4921 if (strEQ(d,"lstat")) return -KEY_lstat;
4924 if (strEQ(d,"length")) return -KEY_length;
4925 if (strEQ(d,"listen")) return -KEY_listen;
4928 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
4931 if (strEQ(d,"localtime")) return -KEY_localtime;
4937 case 1: return KEY_m;
4939 if (strEQ(d,"my")) return KEY_my;
4942 if (strEQ(d,"map")) return KEY_map;
4945 if (strEQ(d,"mkdir")) return -KEY_mkdir;
4948 if (strEQ(d,"msgctl")) return -KEY_msgctl;
4949 if (strEQ(d,"msgget")) return -KEY_msgget;
4950 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
4951 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
4956 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
4959 if (strEQ(d,"next")) return KEY_next;
4960 if (strEQ(d,"ne")) return -KEY_ne;
4961 if (strEQ(d,"not")) return -KEY_not;
4962 if (strEQ(d,"no")) return KEY_no;
4967 if (strEQ(d,"or")) return -KEY_or;
4970 if (strEQ(d,"ord")) return -KEY_ord;
4971 if (strEQ(d,"oct")) return -KEY_oct;
4972 if (strEQ(d,"our")) { deprecate("reserved word \"our\"");
4976 if (strEQ(d,"open")) return -KEY_open;
4979 if (strEQ(d,"opendir")) return -KEY_opendir;
4986 if (strEQ(d,"pop")) return KEY_pop;
4987 if (strEQ(d,"pos")) return KEY_pos;
4990 if (strEQ(d,"push")) return KEY_push;
4991 if (strEQ(d,"pack")) return -KEY_pack;
4992 if (strEQ(d,"pipe")) return -KEY_pipe;
4995 if (strEQ(d,"print")) return KEY_print;
4998 if (strEQ(d,"printf")) return KEY_printf;
5001 if (strEQ(d,"package")) return KEY_package;
5004 if (strEQ(d,"prototype")) return KEY_prototype;
5009 if (strEQ(d,"q")) return KEY_q;
5010 if (strEQ(d,"qr")) return KEY_qr;
5011 if (strEQ(d,"qq")) return KEY_qq;
5012 if (strEQ(d,"qw")) return KEY_qw;
5013 if (strEQ(d,"qx")) return KEY_qx;
5015 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
5020 if (strEQ(d,"ref")) return -KEY_ref;
5023 if (strEQ(d,"read")) return -KEY_read;
5024 if (strEQ(d,"rand")) return -KEY_rand;
5025 if (strEQ(d,"recv")) return -KEY_recv;
5026 if (strEQ(d,"redo")) return KEY_redo;
5029 if (strEQ(d,"rmdir")) return -KEY_rmdir;
5030 if (strEQ(d,"reset")) return -KEY_reset;
5033 if (strEQ(d,"return")) return KEY_return;
5034 if (strEQ(d,"rename")) return -KEY_rename;
5035 if (strEQ(d,"rindex")) return -KEY_rindex;
5038 if (strEQ(d,"require")) return -KEY_require;
5039 if (strEQ(d,"reverse")) return -KEY_reverse;
5040 if (strEQ(d,"readdir")) return -KEY_readdir;
5043 if (strEQ(d,"readlink")) return -KEY_readlink;
5044 if (strEQ(d,"readline")) return -KEY_readline;
5045 if (strEQ(d,"readpipe")) return -KEY_readpipe;
5048 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
5054 case 0: return KEY_s;
5056 if (strEQ(d,"scalar")) return KEY_scalar;
5061 if (strEQ(d,"seek")) return -KEY_seek;
5062 if (strEQ(d,"send")) return -KEY_send;
5065 if (strEQ(d,"semop")) return -KEY_semop;
5068 if (strEQ(d,"select")) return -KEY_select;
5069 if (strEQ(d,"semctl")) return -KEY_semctl;
5070 if (strEQ(d,"semget")) return -KEY_semget;
5073 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
5074 if (strEQ(d,"seekdir")) return -KEY_seekdir;
5077 if (strEQ(d,"setpwent")) return -KEY_setpwent;
5078 if (strEQ(d,"setgrent")) return -KEY_setgrent;
5081 if (strEQ(d,"setnetent")) return -KEY_setnetent;
5084 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
5085 if (strEQ(d,"sethostent")) return -KEY_sethostent;
5086 if (strEQ(d,"setservent")) return -KEY_setservent;
5089 if (strEQ(d,"setpriority")) return -KEY_setpriority;
5090 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
5097 if (strEQ(d,"shift")) return KEY_shift;
5100 if (strEQ(d,"shmctl")) return -KEY_shmctl;
5101 if (strEQ(d,"shmget")) return -KEY_shmget;
5104 if (strEQ(d,"shmread")) return -KEY_shmread;
5107 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
5108 if (strEQ(d,"shutdown")) return -KEY_shutdown;
5113 if (strEQ(d,"sin")) return -KEY_sin;
5116 if (strEQ(d,"sleep")) return -KEY_sleep;
5119 if (strEQ(d,"sort")) return KEY_sort;
5120 if (strEQ(d,"socket")) return -KEY_socket;
5121 if (strEQ(d,"socketpair")) return -KEY_socketpair;
5124 if (strEQ(d,"split")) return KEY_split;
5125 if (strEQ(d,"sprintf")) return -KEY_sprintf;
5126 if (strEQ(d,"splice")) return KEY_splice;
5129 if (strEQ(d,"sqrt")) return -KEY_sqrt;
5132 if (strEQ(d,"srand")) return -KEY_srand;
5135 if (strEQ(d,"stat")) return -KEY_stat;
5136 if (strEQ(d,"study")) return KEY_study;
5139 if (strEQ(d,"substr")) return -KEY_substr;
5140 if (strEQ(d,"sub")) return KEY_sub;
5145 if (strEQ(d,"system")) return -KEY_system;
5148 if (strEQ(d,"symlink")) return -KEY_symlink;
5149 if (strEQ(d,"syscall")) return -KEY_syscall;
5150 if (strEQ(d,"sysopen")) return -KEY_sysopen;
5151 if (strEQ(d,"sysread")) return -KEY_sysread;
5152 if (strEQ(d,"sysseek")) return -KEY_sysseek;
5155 if (strEQ(d,"syswrite")) return -KEY_syswrite;
5164 if (strEQ(d,"tr")) return KEY_tr;
5167 if (strEQ(d,"tie")) return KEY_tie;
5170 if (strEQ(d,"tell")) return -KEY_tell;
5171 if (strEQ(d,"tied")) return KEY_tied;
5172 if (strEQ(d,"time")) return -KEY_time;
5175 if (strEQ(d,"times")) return -KEY_times;
5178 if (strEQ(d,"telldir")) return -KEY_telldir;
5181 if (strEQ(d,"truncate")) return -KEY_truncate;
5188 if (strEQ(d,"uc")) return -KEY_uc;
5191 if (strEQ(d,"use")) return KEY_use;
5194 if (strEQ(d,"undef")) return KEY_undef;
5195 if (strEQ(d,"until")) return KEY_until;
5196 if (strEQ(d,"untie")) return KEY_untie;
5197 if (strEQ(d,"utime")) return -KEY_utime;
5198 if (strEQ(d,"umask")) return -KEY_umask;
5201 if (strEQ(d,"unless")) return KEY_unless;
5202 if (strEQ(d,"unpack")) return -KEY_unpack;
5203 if (strEQ(d,"unlink")) return -KEY_unlink;
5206 if (strEQ(d,"unshift")) return KEY_unshift;
5207 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
5212 if (strEQ(d,"values")) return -KEY_values;
5213 if (strEQ(d,"vec")) return -KEY_vec;
5218 if (strEQ(d,"warn")) return -KEY_warn;
5219 if (strEQ(d,"wait")) return -KEY_wait;
5222 if (strEQ(d,"while")) return KEY_while;
5223 if (strEQ(d,"write")) return -KEY_write;
5226 if (strEQ(d,"waitpid")) return -KEY_waitpid;
5229 if (strEQ(d,"wantarray")) return -KEY_wantarray;
5234 if (len == 1) return -KEY_x;
5235 if (strEQ(d,"xor")) return -KEY_xor;
5238 if (len == 1) return KEY_y;
5247 S_checkcomma(pTHX_ register char *s, char *name, char *what)
5251 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
5252 dTHR; /* only for ckWARN */
5253 if (ckWARN(WARN_SYNTAX)) {
5255 for (w = s+2; *w && level; w++) {
5262 for (; *w && isSPACE(*w); w++) ;
5263 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
5264 Perl_warner(aTHX_ WARN_SYNTAX, "%s (...) interpreted as function",name);
5267 while (s < PL_bufend && isSPACE(*s))
5271 while (s < PL_bufend && isSPACE(*s))
5273 if (isIDFIRST_lazy(s)) {
5275 while (isALNUM_lazy(s))
5277 while (s < PL_bufend && isSPACE(*s))
5282 kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
5286 Perl_croak(aTHX_ "No comma allowed after %s", what);
5291 /* Either returns sv, or mortalizes sv and returns a new SV*.
5292 Best used as sv=new_constant(..., sv, ...).
5293 If s, pv are NULL, calls subroutine with one argument,
5294 and type is used with error messages only. */
5297 S_new_constant(pTHX_ char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)
5300 HV *table = GvHV(PL_hintgv); /* ^H */
5304 char *why, *why1, *why2;
5306 if (!(PL_hints & HINT_LOCALIZE_HH)) {
5309 why = "%^H is not localized";
5313 msg = Perl_newSVpvf(aTHX_ "constant(%s): %s%s%s",
5314 (type ? type: "undef"), why1, why2, why);
5315 yyerror(SvPVX(msg));
5320 why = "%^H is not defined";
5323 cvp = hv_fetch(table, key, strlen(key), FALSE);
5324 if (!cvp || !SvOK(*cvp)) {
5325 why = "} is not defined";
5330 sv_2mortal(sv); /* Parent created it permanently */
5333 pv = sv_2mortal(newSVpvn(s, len));
5335 typesv = sv_2mortal(newSVpv(type, 0));
5337 typesv = &PL_sv_undef;
5339 PUSHSTACKi(PERLSI_OVERLOAD);
5352 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
5356 /* Check the eval first */
5357 if (!PL_in_eval && SvTRUE(ERRSV))
5360 sv_catpv(ERRSV, "Propagated");
5361 yyerror(SvPV(ERRSV, n_a)); /* Duplicates the message inside eval */
5363 res = SvREFCNT_inc(sv);
5376 why = "}} did not return a defined value";
5377 why1 = "Call to &{$^H{";
5387 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
5389 register char *d = dest;
5390 register char *e = d + destlen - 3; /* two-character token, ending NUL */
5393 Perl_croak(aTHX_ ident_too_long);
5394 if (isALNUM(*s)) /* UTF handled below */
5396 else if (*s == '\'' && allow_package && isIDFIRST_lazy(s+1)) {
5401 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
5405 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5406 char *t = s + UTF8SKIP(s);
5407 while (*t & 0x80 && is_utf8_mark((U8*)t))
5409 if (d + (t - s) > e)
5410 Perl_croak(aTHX_ ident_too_long);
5411 Copy(s, d, t - s, char);
5424 S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
5431 if (PL_lex_brackets == 0)
5432 PL_lex_fakebrack = 0;
5436 e = d + destlen - 3; /* two-character token, ending NUL */
5438 while (isDIGIT(*s)) {
5440 Perl_croak(aTHX_ ident_too_long);
5447 Perl_croak(aTHX_ ident_too_long);
5448 if (isALNUM(*s)) /* UTF handled below */
5450 else if (*s == '\'' && isIDFIRST_lazy(s+1)) {
5455 else if (*s == ':' && s[1] == ':') {
5459 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5460 char *t = s + UTF8SKIP(s);
5461 while (*t & 0x80 && is_utf8_mark((U8*)t))
5463 if (d + (t - s) > e)
5464 Perl_croak(aTHX_ ident_too_long);
5465 Copy(s, d, t - s, char);
5476 if (PL_lex_state != LEX_NORMAL)
5477 PL_lex_state = LEX_INTERPENDMAYBE;
5480 if (*s == '$' && s[1] &&
5481 (isALNUM_lazy(s+1) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
5494 if (*d == '^' && *s && isCONTROLVAR(*s)) {
5499 if (isSPACE(s[-1])) {
5502 if (ch != ' ' && ch != '\t') {
5508 if (isIDFIRST_lazy(d)) {
5512 while (e < send && isALNUM_lazy(e) || *e == ':') {
5514 while (e < send && *e & 0x80 && is_utf8_mark((U8*)e))
5517 Copy(s, d, e - s, char);
5522 while ((isALNUM(*s) || *s == ':') && d < e)
5525 Perl_croak(aTHX_ ident_too_long);
5528 while (s < send && (*s == ' ' || *s == '\t')) s++;
5529 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
5530 dTHR; /* only for ckWARN */
5531 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
5532 char *brack = *s == '[' ? "[...]" : "{...}";
5533 Perl_warner(aTHX_ WARN_AMBIGUOUS,
5534 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
5535 funny, dest, brack, funny, dest, brack);
5537 PL_lex_fakebrack = PL_lex_brackets+1;
5539 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5543 /* Handle extended ${^Foo} variables
5544 * 1999-02-27 mjd-perl-patch@plover.com */
5545 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
5549 while (isALNUM(*s) && d < e) {
5553 Perl_croak(aTHX_ ident_too_long);
5558 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
5559 PL_lex_state = LEX_INTERPEND;
5562 if (PL_lex_state == LEX_NORMAL) {
5563 dTHR; /* only for ckWARN */
5564 if (ckWARN(WARN_AMBIGUOUS) &&
5565 (keyword(dest, d - dest) || get_cv(dest, FALSE)))
5567 Perl_warner(aTHX_ WARN_AMBIGUOUS,
5568 "Ambiguous use of %c{%s} resolved to %c%s",
5569 funny, dest, funny, dest);
5574 s = bracket; /* let the parser handle it */
5578 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
5579 PL_lex_state = LEX_INTERPEND;
5584 Perl_pmflag(pTHX_ U16 *pmfl, int ch)
5589 *pmfl |= PMf_GLOBAL;
5591 *pmfl |= PMf_CONTINUE;
5595 *pmfl |= PMf_MULTILINE;
5597 *pmfl |= PMf_SINGLELINE;
5599 *pmfl |= PMf_EXTENDED;
5603 S_scan_pat(pTHX_ char *start, I32 type)
5608 s = scan_str(start);
5611 SvREFCNT_dec(PL_lex_stuff);
5612 PL_lex_stuff = Nullsv;
5613 Perl_croak(aTHX_ "Search pattern not terminated");
5616 pm = (PMOP*)newPMOP(type, 0);
5617 if (PL_multi_open == '?')
5618 pm->op_pmflags |= PMf_ONCE;
5620 while (*s && strchr("iomsx", *s))
5621 pmflag(&pm->op_pmflags,*s++);
5624 while (*s && strchr("iogcmsx", *s))
5625 pmflag(&pm->op_pmflags,*s++);
5627 pm->op_pmpermflags = pm->op_pmflags;
5629 PL_lex_op = (OP*)pm;
5630 yylval.ival = OP_MATCH;
5635 S_scan_subst(pTHX_ char *start)
5642 yylval.ival = OP_NULL;
5644 s = scan_str(start);
5648 SvREFCNT_dec(PL_lex_stuff);
5649 PL_lex_stuff = Nullsv;
5650 Perl_croak(aTHX_ "Substitution pattern not terminated");
5653 if (s[-1] == PL_multi_open)
5656 first_start = PL_multi_start;
5660 SvREFCNT_dec(PL_lex_stuff);
5661 PL_lex_stuff = Nullsv;
5663 SvREFCNT_dec(PL_lex_repl);
5664 PL_lex_repl = Nullsv;
5665 Perl_croak(aTHX_ "Substitution replacement not terminated");
5667 PL_multi_start = first_start; /* so whole substitution is taken together */
5669 pm = (PMOP*)newPMOP(OP_SUBST, 0);
5675 else if (strchr("iogcmsx", *s))
5676 pmflag(&pm->op_pmflags,*s++);
5683 PL_sublex_info.super_bufptr = s;
5684 PL_sublex_info.super_bufend = PL_bufend;
5686 pm->op_pmflags |= PMf_EVAL;
5687 repl = newSVpvn("",0);
5689 sv_catpv(repl, es ? "eval " : "do ");
5690 sv_catpvn(repl, "{ ", 2);
5691 sv_catsv(repl, PL_lex_repl);
5692 sv_catpvn(repl, " };", 2);
5694 SvREFCNT_dec(PL_lex_repl);
5698 pm->op_pmpermflags = pm->op_pmflags;
5699 PL_lex_op = (OP*)pm;
5700 yylval.ival = OP_SUBST;
5705 S_scan_trans(pTHX_ char *start)
5716 yylval.ival = OP_NULL;
5718 s = scan_str(start);
5721 SvREFCNT_dec(PL_lex_stuff);
5722 PL_lex_stuff = Nullsv;
5723 Perl_croak(aTHX_ "Transliteration pattern not terminated");
5725 if (s[-1] == PL_multi_open)
5731 SvREFCNT_dec(PL_lex_stuff);
5732 PL_lex_stuff = Nullsv;
5734 SvREFCNT_dec(PL_lex_repl);
5735 PL_lex_repl = Nullsv;
5736 Perl_croak(aTHX_ "Transliteration replacement not terminated");
5740 o = newSVOP(OP_TRANS, 0, 0);
5741 utf8 = OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF;
5744 New(803,tbl,256,short);
5745 o = newPVOP(OP_TRANS, 0, (char*)tbl);
5749 complement = del = squash = 0;
5750 while (strchr("cdsCU", *s)) {
5752 complement = OPpTRANS_COMPLEMENT;
5754 del = OPpTRANS_DELETE;
5756 squash = OPpTRANS_SQUASH;
5761 utf8 &= ~OPpTRANS_FROM_UTF;
5763 utf8 |= OPpTRANS_FROM_UTF;
5767 utf8 &= ~OPpTRANS_TO_UTF;
5769 utf8 |= OPpTRANS_TO_UTF;
5772 Perl_croak(aTHX_ "Too many /C and /U options");
5777 o->op_private = del|squash|complement|utf8;
5780 yylval.ival = OP_TRANS;
5785 S_scan_heredoc(pTHX_ register char *s)
5789 I32 op_type = OP_SCALAR;
5796 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
5800 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
5803 for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5804 if (*peek && strchr("`'\"",*peek)) {
5807 s = delimcpy(d, e, s, PL_bufend, term, &len);
5817 if (!isALNUM_lazy(s))
5818 deprecate("bare << to mean <<\"\"");
5819 for (; isALNUM_lazy(s); s++) {
5824 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
5825 Perl_croak(aTHX_ "Delimiter for here document is too long");
5828 len = d - PL_tokenbuf;
5829 #ifndef PERL_STRICT_CR
5830 d = strchr(s, '\r');
5834 while (s < PL_bufend) {
5840 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
5849 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5854 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
5855 herewas = newSVpvn(s,PL_bufend-s);
5857 s--, herewas = newSVpvn(s,d-s);
5858 s += SvCUR(herewas);
5860 tmpstr = NEWSV(87,79);
5861 sv_upgrade(tmpstr, SVt_PVIV);
5866 else if (term == '`') {
5867 op_type = OP_BACKTICK;
5868 SvIVX(tmpstr) = '\\';
5872 PL_multi_start = PL_curcop->cop_line;
5873 PL_multi_open = PL_multi_close = '<';
5874 term = *PL_tokenbuf;
5875 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
5876 char *bufptr = PL_sublex_info.super_bufptr;
5877 char *bufend = PL_sublex_info.super_bufend;
5878 char *olds = s - SvCUR(herewas);
5879 s = strchr(bufptr, '\n');
5883 while (s < bufend &&
5884 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
5886 PL_curcop->cop_line++;
5889 PL_curcop->cop_line = PL_multi_start;
5890 missingterm(PL_tokenbuf);
5892 sv_setpvn(herewas,bufptr,d-bufptr+1);
5893 sv_setpvn(tmpstr,d+1,s-d);
5895 sv_catpvn(herewas,s,bufend-s);
5896 (void)strcpy(bufptr,SvPVX(herewas));
5903 while (s < PL_bufend &&
5904 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
5906 PL_curcop->cop_line++;
5908 if (s >= PL_bufend) {
5909 PL_curcop->cop_line = PL_multi_start;
5910 missingterm(PL_tokenbuf);
5912 sv_setpvn(tmpstr,d+1,s-d);
5914 PL_curcop->cop_line++; /* the preceding stmt passes a newline */
5916 sv_catpvn(herewas,s,PL_bufend-s);
5917 sv_setsv(PL_linestr,herewas);
5918 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
5919 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5922 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
5923 while (s >= PL_bufend) { /* multiple line string? */
5925 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5926 PL_curcop->cop_line = PL_multi_start;
5927 missingterm(PL_tokenbuf);
5929 PL_curcop->cop_line++;
5930 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5931 #ifndef PERL_STRICT_CR
5932 if (PL_bufend - PL_linestart >= 2) {
5933 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
5934 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
5936 PL_bufend[-2] = '\n';
5938 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5940 else if (PL_bufend[-1] == '\r')
5941 PL_bufend[-1] = '\n';
5943 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
5944 PL_bufend[-1] = '\n';
5946 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5947 SV *sv = NEWSV(88,0);
5949 sv_upgrade(sv, SVt_PVMG);
5950 sv_setsv(sv,PL_linestr);
5951 av_store(GvAV(PL_curcop->cop_filegv),
5952 (I32)PL_curcop->cop_line,sv);
5954 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
5957 sv_catsv(PL_linestr,herewas);
5958 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5962 sv_catsv(tmpstr,PL_linestr);
5967 PL_multi_end = PL_curcop->cop_line;
5968 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
5969 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
5970 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
5972 SvREFCNT_dec(herewas);
5973 PL_lex_stuff = tmpstr;
5974 yylval.ival = op_type;
5979 takes: current position in input buffer
5980 returns: new position in input buffer
5981 side-effects: yylval and lex_op are set.
5986 <FH> read from filehandle
5987 <pkg::FH> read from package qualified filehandle
5988 <pkg'FH> read from package qualified filehandle
5989 <$fh> read from filehandle in $fh
5995 S_scan_inputsymbol(pTHX_ char *start)
5997 register char *s = start; /* current position in buffer */
6003 d = PL_tokenbuf; /* start of temp holding space */
6004 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
6005 end = strchr(s, '\n');
6008 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
6010 /* die if we didn't have space for the contents of the <>,
6011 or if it didn't end, or if we see a newline
6014 if (len >= sizeof PL_tokenbuf)
6015 Perl_croak(aTHX_ "Excessively long <> operator");
6017 Perl_croak(aTHX_ "Unterminated <> operator");
6022 Remember, only scalar variables are interpreted as filehandles by
6023 this code. Anything more complex (e.g., <$fh{$num}>) will be
6024 treated as a glob() call.
6025 This code makes use of the fact that except for the $ at the front,
6026 a scalar variable and a filehandle look the same.
6028 if (*d == '$' && d[1]) d++;
6030 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
6031 while (*d && (isALNUM_lazy(d) || *d == '\'' || *d == ':'))
6034 /* If we've tried to read what we allow filehandles to look like, and
6035 there's still text left, then it must be a glob() and not a getline.
6036 Use scan_str to pull out the stuff between the <> and treat it
6037 as nothing more than a string.
6040 if (d - PL_tokenbuf != len) {
6041 yylval.ival = OP_GLOB;
6043 s = scan_str(start);
6045 Perl_croak(aTHX_ "Glob not terminated");
6049 /* we're in a filehandle read situation */
6052 /* turn <> into <ARGV> */
6054 (void)strcpy(d,"ARGV");
6056 /* if <$fh>, create the ops to turn the variable into a
6062 /* try to find it in the pad for this block, otherwise find
6063 add symbol table ops
6065 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
6066 OP *o = newOP(OP_PADSV, 0);
6068 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, o);
6071 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
6072 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
6073 newUNOP(OP_RV2SV, 0,
6074 newGVOP(OP_GV, 0, gv)));
6076 PL_lex_op->op_flags |= OPf_SPECIAL;
6077 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
6078 yylval.ival = OP_NULL;
6081 /* If it's none of the above, it must be a literal filehandle
6082 (<Foo::BAR> or <FOO>) so build a simple readline OP */
6084 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
6085 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
6086 yylval.ival = OP_NULL;
6095 takes: start position in buffer
6096 returns: position to continue reading from buffer
6097 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
6098 updates the read buffer.
6100 This subroutine pulls a string out of the input. It is called for:
6101 q single quotes q(literal text)
6102 ' single quotes 'literal text'
6103 qq double quotes qq(interpolate $here please)
6104 " double quotes "interpolate $here please"
6105 qx backticks qx(/bin/ls -l)
6106 ` backticks `/bin/ls -l`
6107 qw quote words @EXPORT_OK = qw( func() $spam )
6108 m// regexp match m/this/
6109 s/// regexp substitute s/this/that/
6110 tr/// string transliterate tr/this/that/
6111 y/// string transliterate y/this/that/
6112 ($*@) sub prototypes sub foo ($)
6113 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
6115 In most of these cases (all but <>, patterns and transliterate)
6116 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
6117 calls scan_str(). s/// makes yylex() call scan_subst() which calls
6118 scan_str(). tr/// and y/// make yylex() call scan_trans() which
6121 It skips whitespace before the string starts, and treats the first
6122 character as the delimiter. If the delimiter is one of ([{< then
6123 the corresponding "close" character )]}> is used as the closing
6124 delimiter. It allows quoting of delimiters, and if the string has
6125 balanced delimiters ([{<>}]) it allows nesting.
6127 The lexer always reads these strings into lex_stuff, except in the
6128 case of the operators which take *two* arguments (s/// and tr///)
6129 when it checks to see if lex_stuff is full (presumably with the 1st
6130 arg to s or tr) and if so puts the string into lex_repl.
6135 S_scan_str(pTHX_ char *start)
6138 SV *sv; /* scalar value: string */
6139 char *tmps; /* temp string, used for delimiter matching */
6140 register char *s = start; /* current position in the buffer */
6141 register char term; /* terminating character */
6142 register char *to; /* current position in the sv's data */
6143 I32 brackets = 1; /* bracket nesting level */
6145 /* skip space before the delimiter */
6149 /* mark where we are, in case we need to report errors */
6152 /* after skipping whitespace, the next character is the terminator */
6154 /* mark where we are */
6155 PL_multi_start = PL_curcop->cop_line;
6156 PL_multi_open = term;
6158 /* find corresponding closing delimiter */
6159 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
6161 PL_multi_close = term;
6163 /* create a new SV to hold the contents. 87 is leak category, I'm
6164 assuming. 79 is the SV's initial length. What a random number. */
6166 sv_upgrade(sv, SVt_PVIV);
6168 (void)SvPOK_only(sv); /* validate pointer */
6170 /* move past delimiter and try to read a complete string */
6173 /* extend sv if need be */
6174 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
6175 /* set 'to' to the next character in the sv's string */
6176 to = SvPVX(sv)+SvCUR(sv);
6178 /* if open delimiter is the close delimiter read unbridle */
6179 if (PL_multi_open == PL_multi_close) {
6180 for (; s < PL_bufend; s++,to++) {
6181 /* embedded newlines increment the current line number */
6182 if (*s == '\n' && !PL_rsfp)
6183 PL_curcop->cop_line++;
6184 /* handle quoted delimiters */
6185 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
6188 /* any other quotes are simply copied straight through */
6192 /* terminate when run out of buffer (the for() condition), or
6193 have found the terminator */
6194 else if (*s == term)
6200 /* if the terminator isn't the same as the start character (e.g.,
6201 matched brackets), we have to allow more in the quoting, and
6202 be prepared for nested brackets.
6205 /* read until we run out of string, or we find the terminator */
6206 for (; s < PL_bufend; s++,to++) {
6207 /* embedded newlines increment the line count */
6208 if (*s == '\n' && !PL_rsfp)
6209 PL_curcop->cop_line++;
6210 /* backslashes can escape the open or closing characters */
6211 if (*s == '\\' && s+1 < PL_bufend) {
6212 if ((s[1] == PL_multi_open) || (s[1] == PL_multi_close))
6217 /* allow nested opens and closes */
6218 else if (*s == PL_multi_close && --brackets <= 0)
6220 else if (*s == PL_multi_open)
6225 /* terminate the copied string and update the sv's end-of-string */
6227 SvCUR_set(sv, to - SvPVX(sv));
6230 * this next chunk reads more into the buffer if we're not done yet
6233 if (s < PL_bufend) break; /* handle case where we are done yet :-) */
6235 #ifndef PERL_STRICT_CR
6236 if (to - SvPVX(sv) >= 2) {
6237 if ((to[-2] == '\r' && to[-1] == '\n') ||
6238 (to[-2] == '\n' && to[-1] == '\r'))
6242 SvCUR_set(sv, to - SvPVX(sv));
6244 else if (to[-1] == '\r')
6247 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
6251 /* if we're out of file, or a read fails, bail and reset the current
6252 line marker so we can report where the unterminated string began
6255 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6257 PL_curcop->cop_line = PL_multi_start;
6260 /* we read a line, so increment our line counter */
6261 PL_curcop->cop_line++;
6263 /* update debugger info */
6264 if (PERLDB_LINE && PL_curstash != PL_debstash) {
6265 SV *sv = NEWSV(88,0);
6267 sv_upgrade(sv, SVt_PVMG);
6268 sv_setsv(sv,PL_linestr);
6269 av_store(GvAV(PL_curcop->cop_filegv),
6270 (I32)PL_curcop->cop_line, sv);
6273 /* having changed the buffer, we must update PL_bufend */
6274 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6277 /* at this point, we have successfully read the delimited string */
6279 PL_multi_end = PL_curcop->cop_line;
6282 /* if we allocated too much space, give some back */
6283 if (SvCUR(sv) + 5 < SvLEN(sv)) {
6284 SvLEN_set(sv, SvCUR(sv) + 1);
6285 Renew(SvPVX(sv), SvLEN(sv), char);
6288 /* decide whether this is the first or second quoted string we've read
6301 takes: pointer to position in buffer
6302 returns: pointer to new position in buffer
6303 side-effects: builds ops for the constant in yylval.op
6305 Read a number in any of the formats that Perl accepts:
6307 0(x[0-7A-F]+)|([0-7]+)|(b[01])
6308 [\d_]+(\.[\d_]*)?[Ee](\d+)
6310 Underbars (_) are allowed in decimal numbers. If -w is on,
6311 underbars before a decimal point must be at three digit intervals.
6313 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
6316 If it reads a number without a decimal point or an exponent, it will
6317 try converting the number to an integer and see if it can do so
6318 without loss of precision.
6322 Perl_scan_num(pTHX_ char *start)
6324 register char *s = start; /* current position in buffer */
6325 register char *d; /* destination in temp buffer */
6326 register char *e; /* end of temp buffer */
6327 IV tryiv; /* used to see if it can be an IV */
6328 NV value; /* number read, as a double */
6329 SV *sv; /* place to put the converted number */
6330 bool floatit; /* boolean: int or float? */
6331 char *lastub = 0; /* position of last underbar */
6332 static char number_too_long[] = "Number too long";
6334 /* We use the first character to decide what type of number this is */
6338 Perl_croak(aTHX_ "panic: scan_num");
6340 /* if it starts with a 0, it could be an octal number, a decimal in
6341 0.13 disguise, or a hexadecimal number, or a binary number.
6346 u holds the "number so far"
6347 shift the power of 2 of the base
6348 (hex == 4, octal == 3, binary == 1)
6349 overflowed was the number more than we can hold?
6351 Shift is used when we add a digit. It also serves as an "are
6352 we in octal/hex/binary?" indicator to disallow hex characters
6359 bool overflowed = FALSE;
6360 static NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
6361 static char* bases[5] = { "", "binary", "", "octal",
6363 static char* Bases[5] = { "", "Binary", "", "Octal",
6365 static char *maxima[5] = { "",
6366 "0b11111111111111111111111111111111",
6370 char *base, *Base, *max;
6376 } else if (s[1] == 'b') {
6380 /* check for a decimal in disguise */
6381 else if (s[1] == '.')
6383 /* so it must be octal */
6387 base = bases[shift];
6388 Base = Bases[shift];
6389 max = maxima[shift];
6391 /* read the rest of the number */
6393 /* x is used in the overflow test,
6394 b is the digit we're adding on. */
6399 /* if we don't mention it, we're done */
6408 /* 8 and 9 are not octal */
6411 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
6414 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
6418 case '2': case '3': case '4':
6419 case '5': case '6': case '7':
6421 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
6425 b = *s++ & 15; /* ASCII digit -> value of digit */
6429 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
6430 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
6431 /* make sure they said 0x */
6436 /* Prepare to put the digit we have onto the end
6437 of the number so far. We check for overflows.
6442 x = u << shift; /* make room for the digit */
6444 if ((x >> shift) != u
6445 && !(PL_hints & HINT_NEW_BINARY)) {
6449 if (ckWARN_d(WARN_UNSAFE))
6450 Perl_warner(aTHX_ ((shift == 3) ?
6451 WARN_OCTAL : WARN_UNSAFE),
6452 "Integer overflow in %s number",
6455 u = x | b; /* add the digit to the end */
6458 n *= nvshift[shift];
6459 /* If an NV has not enough bits in its
6460 * mantissa to represent an UV this summing of
6461 * small low-order numbers is a waste of time
6462 * (because the NV cannot preserve the
6463 * low-order bits anyway): we could just
6464 * remember when did we overflow and in the
6465 * end just multiply n by the right
6473 /* if we get here, we had success: make a scalar value from
6480 if (ckWARN(WARN_UNSAFE) && n > 4294967295.0)
6481 Perl_warner(aTHX_ WARN_UNSAFE,
6482 "%s number > %s non-portable",
6489 if (ckWARN(WARN_UNSAFE) && u > 0xffffffff)
6490 Perl_warner(aTHX_ WARN_UNSAFE,
6491 "%s number > %s non-portable",
6496 if (PL_hints & HINT_NEW_BINARY)
6497 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
6502 handle decimal numbers.
6503 we're also sent here when we read a 0 as the first digit
6505 case '1': case '2': case '3': case '4': case '5':
6506 case '6': case '7': case '8': case '9': case '.':
6509 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
6512 /* read next group of digits and _ and copy into d */
6513 while (isDIGIT(*s) || *s == '_') {
6514 /* skip underscores, checking for misplaced ones
6518 dTHR; /* only for ckWARN */
6519 if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
6520 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
6524 /* check for end of fixed-length buffer */
6526 Perl_croak(aTHX_ number_too_long);
6527 /* if we're ok, copy the character */
6532 /* final misplaced underbar check */
6533 if (lastub && s - lastub != 3) {
6535 if (ckWARN(WARN_SYNTAX))
6536 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
6539 /* read a decimal portion if there is one. avoid
6540 3..5 being interpreted as the number 3. followed
6543 if (*s == '.' && s[1] != '.') {
6547 /* copy, ignoring underbars, until we run out of
6548 digits. Note: no misplaced underbar checks!
6550 for (; isDIGIT(*s) || *s == '_'; s++) {
6551 /* fixed length buffer check */
6553 Perl_croak(aTHX_ number_too_long);
6559 /* read exponent part, if present */
6560 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
6564 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
6565 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
6567 /* allow positive or negative exponent */
6568 if (*s == '+' || *s == '-')
6571 /* read digits of exponent (no underbars :-) */
6572 while (isDIGIT(*s)) {
6574 Perl_croak(aTHX_ number_too_long);
6579 /* terminate the string */
6582 /* make an sv from the string */
6585 value = Atof(PL_tokenbuf);
6588 See if we can make do with an integer value without loss of
6589 precision. We use I_V to cast to an int, because some
6590 compilers have issues. Then we try casting it back and see
6591 if it was the same. We only do this if we know we
6592 specifically read an integer.
6594 Note: if floatit is true, then we don't need to do the
6598 if (!floatit && (NV)tryiv == value)
6599 sv_setiv(sv, tryiv);
6601 sv_setnv(sv, value);
6602 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
6603 (PL_hints & HINT_NEW_INTEGER) )
6604 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
6605 (floatit ? "float" : "integer"),
6610 /* make the op for the constant and return */
6612 yylval.opval = newSVOP(OP_CONST, 0, sv);
6618 S_scan_formline(pTHX_ register char *s)
6623 SV *stuff = newSVpvn("",0);
6624 bool needargs = FALSE;
6627 if (*s == '.' || *s == '}') {
6629 #ifdef PERL_STRICT_CR
6630 for (t = s+1;*t == ' ' || *t == '\t'; t++) ;
6632 for (t = s+1;*t == ' ' || *t == '\t' || *t == '\r'; t++) ;
6634 if (*t == '\n' || t == PL_bufend)
6637 if (PL_in_eval && !PL_rsfp) {
6638 eol = strchr(s,'\n');
6643 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6645 for (t = s; t < eol; t++) {
6646 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
6648 goto enough; /* ~~ must be first line in formline */
6650 if (*t == '@' || *t == '^')
6653 sv_catpvn(stuff, s, eol-s);
6657 s = filter_gets(PL_linestr, PL_rsfp, 0);
6658 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
6659 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
6662 yyerror("Format not terminated");
6672 PL_lex_state = LEX_NORMAL;
6673 PL_nextval[PL_nexttoke].ival = 0;
6677 PL_lex_state = LEX_FORMLINE;
6678 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
6680 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
6684 SvREFCNT_dec(stuff);
6685 PL_lex_formbrack = 0;
6696 PL_cshlen = strlen(PL_cshname);
6701 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
6704 I32 oldsavestack_ix = PL_savestack_ix;
6705 CV* outsidecv = PL_compcv;
6709 assert(SvTYPE(PL_compcv) == SVt_PVCV);
6711 save_I32(&PL_subline);
6712 save_item(PL_subname);
6714 SAVESPTR(PL_curpad);
6715 SAVESPTR(PL_comppad);
6716 SAVESPTR(PL_comppad_name);
6717 SAVESPTR(PL_compcv);
6718 SAVEI32(PL_comppad_name_fill);
6719 SAVEI32(PL_min_intro_pending);
6720 SAVEI32(PL_max_intro_pending);
6721 SAVEI32(PL_pad_reset_pending);
6723 PL_compcv = (CV*)NEWSV(1104,0);
6724 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
6725 CvFLAGS(PL_compcv) |= flags;
6727 PL_comppad = newAV();
6728 av_push(PL_comppad, Nullsv);
6729 PL_curpad = AvARRAY(PL_comppad);
6730 PL_comppad_name = newAV();
6731 PL_comppad_name_fill = 0;
6732 PL_min_intro_pending = 0;
6734 PL_subline = PL_curcop->cop_line;
6736 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
6737 PL_curpad[0] = (SV*)newAV();
6738 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
6739 #endif /* USE_THREADS */
6741 comppadlist = newAV();
6742 AvREAL_off(comppadlist);
6743 av_store(comppadlist, 0, (SV*)PL_comppad_name);
6744 av_store(comppadlist, 1, (SV*)PL_comppad);
6746 CvPADLIST(PL_compcv) = comppadlist;
6747 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
6749 CvOWNER(PL_compcv) = 0;
6750 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
6751 MUTEX_INIT(CvMUTEXP(PL_compcv));
6752 #endif /* USE_THREADS */
6754 return oldsavestack_ix;
6758 Perl_yywarn(pTHX_ char *s)
6762 PL_in_eval |= EVAL_WARNONLY;
6764 PL_in_eval &= ~EVAL_WARNONLY;
6769 Perl_yyerror(pTHX_ char *s)
6773 char *context = NULL;
6777 if (!yychar || (yychar == ';' && !PL_rsfp))
6779 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
6780 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
6781 while (isSPACE(*PL_oldoldbufptr))
6783 context = PL_oldoldbufptr;
6784 contlen = PL_bufptr - PL_oldoldbufptr;
6786 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
6787 PL_oldbufptr != PL_bufptr) {
6788 while (isSPACE(*PL_oldbufptr))
6790 context = PL_oldbufptr;
6791 contlen = PL_bufptr - PL_oldbufptr;
6793 else if (yychar > 255)
6794 where = "next token ???";
6795 else if ((yychar & 127) == 127) {
6796 if (PL_lex_state == LEX_NORMAL ||
6797 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
6798 where = "at end of line";
6799 else if (PL_lex_inpat)
6800 where = "within pattern";
6802 where = "within string";
6805 SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
6807 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
6808 else if (isPRINT_LC(yychar))
6809 Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
6811 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
6812 where = SvPVX(where_sv);
6814 msg = sv_2mortal(newSVpv(s, 0));
6816 Perl_sv_catpvf(aTHX_ msg, " at %_ line %" PERL_PRId64 ", ",
6817 GvSV(PL_curcop->cop_filegv), (IV)PL_curcop->cop_line);
6819 Perl_sv_catpvf(aTHX_ msg, " at %_ line %ld, ",
6820 GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line);
6823 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
6825 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
6826 if (PL_multi_start < PL_multi_end && (U32)(PL_curcop->cop_line - PL_multi_end) <= 1) {
6828 Perl_sv_catpvf(aTHX_ msg,
6829 " (Might be a runaway multi-line %c%c string starting on line %" PERL_\
6831 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
6833 Perl_sv_catpvf(aTHX_ msg,
6834 " (Might be a runaway multi-line %c%c string starting on line %ld)\n",
6835 (int)PL_multi_open,(int)PL_multi_close,(long)PL_multi_start);
6839 if (PL_in_eval & EVAL_WARNONLY)
6840 Perl_warn(aTHX_ "%_", msg);
6841 else if (PL_in_eval)
6842 sv_catsv(ERRSV, msg);
6844 PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
6845 if (++PL_error_count >= 10)
6846 Perl_croak(aTHX_ "%_ has too many errors.\n", GvSV(PL_curcop->cop_filegv));
6848 PL_in_my_stash = Nullhv;
6860 * Restore a source filter.
6864 restore_rsfp(pTHXo_ void *f)
6866 PerlIO *fp = (PerlIO*)f;
6868 if (PL_rsfp == PerlIO_stdin())
6869 PerlIO_clearerr(PL_rsfp);
6870 else if (PL_rsfp && (PL_rsfp != fp))
6871 PerlIO_close(PL_rsfp);
6877 * Restores the state of PL_expect when the lexing that begun with a
6878 * start_lex() call has ended.
6882 restore_expect(pTHXo_ void *e)
6884 /* a safe way to store a small integer in a pointer */
6885 PL_expect = (expectation)((char *)e - PL_tokenbuf);
6889 * restore_lex_expect
6890 * Restores the state of PL_lex_expect when the lexing that begun with a
6891 * start_lex() call has ended.
6895 restore_lex_expect(pTHXo_ void *e)
6897 /* a safe way to store a small integer in a pointer */
6898 PL_lex_expect = (expectation)((char *)e - PL_tokenbuf);