3 * Copyright (c) 1991-1999, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "It all comes from here, the stench and the peril." --Frodo
15 * This file is the lexer for Perl. It's closely linked to the
18 * The main routine is yylex(), which returns the next token.
22 #define PERL_IN_TOKE_C
25 #define yychar PL_yychar
26 #define yylval PL_yylval
28 static char ident_too_long[] = "Identifier too long";
30 static void restore_rsfp(pTHXo_ void *f);
31 static void restore_expect(pTHXo_ void *e);
32 static void restore_lex_expect(pTHXo_ void *e);
34 #define UTF (PL_hints & HINT_UTF8)
36 * Note: we try to be careful never to call the isXXX_utf8() functions
37 * unless we're pretty sure we've seen the beginning of a UTF-8 character
38 * (that is, the two high bits are set). Otherwise we risk loading in the
39 * heavy-duty SWASHINIT and SWASHGET routines unnecessarily.
41 #define isIDFIRST_lazy(p) ((!UTF || (*((U8*)p) < 0xc0)) \
43 : isIDFIRST_utf8((U8*)p))
44 #define isALNUM_lazy(p) ((!UTF || (*((U8*)p) < 0xc0)) \
46 : isALNUM_utf8((U8*)p))
48 /* In variables name $^X, these are the legal values for X.
49 * 1999-02-27 mjd-perl-patch@plover.com */
50 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
52 /* LEX_* are values for PL_lex_state, the state of the lexer.
53 * They are arranged oddly so that the guard on the switch statement
54 * can get by with a single comparison (if the compiler is smart enough).
57 /* #define LEX_NOTPARSING 11 is done in perl.h. */
60 #define LEX_INTERPNORMAL 9
61 #define LEX_INTERPCASEMOD 8
62 #define LEX_INTERPPUSH 7
63 #define LEX_INTERPSTART 6
64 #define LEX_INTERPEND 5
65 #define LEX_INTERPENDMAYBE 4
66 #define LEX_INTERPCONCAT 3
67 #define LEX_INTERPCONST 2
68 #define LEX_FORMLINE 1
69 #define LEX_KNOWNEXT 0
78 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
80 # include <unistd.h> /* Needed for execv() */
89 YYSTYPE* yylval_pointer = NULL;
90 int* yychar_pointer = NULL;
93 # define yylval (*yylval_pointer)
94 # define yychar (*yychar_pointer)
95 # define PERL_YYLEX_PARAM yylval_pointer,yychar_pointer
97 # define yylex() Perl_yylex(aTHX_ yylval_pointer, yychar_pointer)
100 #include "keywords.h"
102 /* CLINE is a macro that ensures PL_copline has a sane value */
107 #define CLINE (PL_copline = (PL_curcop->cop_line < PL_copline ? PL_curcop->cop_line : PL_copline))
110 * Convenience functions to return different tokens and prime the
111 * lexer for the next token. They all take an argument.
113 * TOKEN : generic token (used for '(', DOLSHARP, etc)
114 * OPERATOR : generic operator
115 * AOPERATOR : assignment operator
116 * PREBLOCK : beginning the block after an if, while, foreach, ...
117 * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
118 * PREREF : *EXPR where EXPR is not a simple identifier
119 * TERM : expression term
120 * LOOPX : loop exiting command (goto, last, dump, etc)
121 * FTST : file test operator
122 * FUN0 : zero-argument function
124 * BOop : bitwise or or xor
126 * SHop : shift operator
127 * PWop : power operator
128 * PMop : pattern-matching operator
129 * Aop : addition-level operator
130 * Mop : multiplication-level operator
131 * Eop : equality-testing operator
132 * Rop : relational operator <= != gt
134 * Also see LOP and lop() below.
137 #define TOKEN(retval) return (PL_bufptr = s,(int)retval)
138 #define OPERATOR(retval) return (PL_expect = XTERM,PL_bufptr = s,(int)retval)
139 #define AOPERATOR(retval) return ao((PL_expect = XTERM,PL_bufptr = s,(int)retval))
140 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s,(int)retval)
141 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval)
142 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s,(int)retval)
143 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR,PL_bufptr = s,(int)retval)
144 #define LOOPX(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX)
145 #define FTST(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)UNIOP)
146 #define FUN0(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0)
147 #define FUN1(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1)
148 #define BOop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITOROP))
149 #define BAop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP))
150 #define SHop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP))
151 #define PWop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)POWOP))
152 #define PMop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP)
153 #define Aop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)ADDOP))
154 #define Mop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MULOP))
155 #define Eop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)EQOP)
156 #define Rop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)RELOP)
158 /* This bit of chicanery makes a unary function followed by
159 * a parenthesis into a function with one argument, highest precedence.
161 #define UNI(f) return(yylval.ival = f, \
164 PL_last_uni = PL_oldbufptr, \
165 PL_last_lop_op = f, \
166 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
168 #define UNIBRACK(f) return(yylval.ival = f, \
170 PL_last_uni = PL_oldbufptr, \
171 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
173 /* grandfather return to old style */
174 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
179 * This subroutine detects &&= and ||= and turns an ANDAND or OROR
180 * into an OP_ANDASSIGN or OP_ORASSIGN
184 S_ao(pTHX_ int toketype)
186 if (*PL_bufptr == '=') {
188 if (toketype == ANDAND)
189 yylval.ival = OP_ANDASSIGN;
190 else if (toketype == OROR)
191 yylval.ival = OP_ORASSIGN;
199 * When Perl expects an operator and finds something else, no_op
200 * prints the warning. It always prints "<something> found where
201 * operator expected. It prints "Missing semicolon on previous line?"
202 * if the surprise occurs at the start of the line. "do you need to
203 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
204 * where the compiler doesn't know if foo is a method call or a function.
205 * It prints "Missing operator before end of line" if there's nothing
206 * after the missing operator, or "... before <...>" if there is something
207 * after the missing operator.
211 S_no_op(pTHX_ char *what, char *s)
213 char *oldbp = PL_bufptr;
214 bool is_first = (PL_oldbufptr == PL_linestart);
218 yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
220 Perl_warn(aTHX_ "\t(Missing semicolon on previous line?)\n");
221 else if (PL_oldoldbufptr && isIDFIRST_lazy(PL_oldoldbufptr)) {
223 for (t = PL_oldoldbufptr; *t && (isALNUM_lazy(t) || *t == ':'); t++) ;
224 if (t < PL_bufptr && isSPACE(*t))
225 Perl_warn(aTHX_ "\t(Do you need to predeclare %.*s?)\n",
226 t - PL_oldoldbufptr, PL_oldoldbufptr);
229 Perl_warn(aTHX_ "\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
235 * Complain about missing quote/regexp/heredoc terminator.
236 * If it's called with (char *)NULL then it cauterizes the line buffer.
237 * If we're in a delimited string and the delimiter is a control
238 * character, it's reformatted into a two-char sequence like ^C.
243 S_missingterm(pTHX_ char *s)
248 char *nl = strrchr(s,'\n');
254 iscntrl(PL_multi_close)
256 PL_multi_close < 32 || PL_multi_close == 127
260 tmpbuf[1] = toCTRL(PL_multi_close);
266 *tmpbuf = PL_multi_close;
270 q = strchr(s,'"') ? '\'' : '"';
271 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
279 Perl_deprecate(pTHX_ char *s)
282 if (ckWARN(WARN_DEPRECATED))
283 Perl_warner(aTHX_ WARN_DEPRECATED, "Use of %s is deprecated", s);
288 * Deprecate a comma-less variable list.
294 deprecate("comma-less variable list");
298 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
299 * utf16-to-utf8-reversed.
305 S_win32_textfilter(pTHX_ int idx, SV *sv, int maxlen)
307 I32 count = FILTER_READ(idx+1, sv, maxlen);
308 if (count > 0 && !maxlen)
309 win32_strip_return(sv);
315 S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
317 I32 count = FILTER_READ(idx+1, sv, maxlen);
321 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
322 tend = utf16_to_utf8((U16*)SvPVX(sv), tmps, SvCUR(sv));
323 sv_usepvn(sv, (char*)tmps, tend - tmps);
330 S_utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
332 I32 count = FILTER_READ(idx+1, sv, maxlen);
336 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
337 tend = utf16_to_utf8_reversed((U16*)SvPVX(sv), tmps, SvCUR(sv));
338 sv_usepvn(sv, (char*)tmps, tend - tmps);
346 * Initialize variables. Uses the Perl save_stack to save its state (for
347 * recursive calls to the parser).
351 Perl_lex_start(pTHX_ SV *line)
357 SAVEI32(PL_lex_dojoin);
358 SAVEI32(PL_lex_brackets);
359 SAVEI32(PL_lex_fakebrack);
360 SAVEI32(PL_lex_casemods);
361 SAVEI32(PL_lex_starts);
362 SAVEI32(PL_lex_state);
363 SAVESPTR(PL_lex_inpat);
364 SAVEI32(PL_lex_inwhat);
365 SAVEI16(PL_curcop->cop_line);
368 SAVEPPTR(PL_oldbufptr);
369 SAVEPPTR(PL_oldoldbufptr);
370 SAVEPPTR(PL_linestart);
371 SAVESPTR(PL_linestr);
372 SAVEPPTR(PL_lex_brackstack);
373 SAVEPPTR(PL_lex_casestack);
374 SAVEDESTRUCTOR(restore_rsfp, PL_rsfp);
375 SAVESPTR(PL_lex_stuff);
376 SAVEI32(PL_lex_defer);
377 SAVESPTR(PL_lex_repl);
378 SAVEDESTRUCTOR(restore_expect, PL_tokenbuf + PL_expect); /* encode as pointer */
379 SAVEDESTRUCTOR(restore_lex_expect, PL_tokenbuf + PL_expect);
381 PL_lex_state = LEX_NORMAL;
385 PL_lex_fakebrack = 0;
386 New(899, PL_lex_brackstack, 120, char);
387 New(899, PL_lex_casestack, 12, char);
388 SAVEFREEPV(PL_lex_brackstack);
389 SAVEFREEPV(PL_lex_casestack);
391 *PL_lex_casestack = '\0';
394 PL_lex_stuff = Nullsv;
395 PL_lex_repl = Nullsv;
399 if (SvREADONLY(PL_linestr))
400 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
401 s = SvPV(PL_linestr, len);
402 if (len && s[len-1] != ';') {
403 if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
404 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
405 sv_catpvn(PL_linestr, "\n;", 2);
407 SvTEMP_off(PL_linestr);
408 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
409 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
411 PL_rs = newSVpvn("\n", 1);
417 * Finalizer for lexing operations. Must be called when the parser is
418 * done with the lexer.
424 PL_doextract = FALSE;
429 * This subroutine has nothing to do with tilting, whether at windmills
430 * or pinball tables. Its name is short for "increment line". It
431 * increments the current line number in PL_curcop->cop_line and checks
432 * to see whether the line starts with a comment of the form
433 * # line 500 "foo.pm"
434 * If so, it sets the current line number and file to the values in the comment.
438 S_incline(pTHX_ char *s)
446 PL_curcop->cop_line++;
449 while (*s == ' ' || *s == '\t') s++;
450 if (strnEQ(s, "line ", 5)) {
459 while (*s == ' ' || *s == '\t')
461 if (*s == '"' && (t = strchr(s+1, '"')))
465 return; /* false alarm */
466 for (t = s; !isSPACE(*t); t++) ;
471 PL_curcop->cop_filegv = gv_fetchfile(s);
473 PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
475 PL_curcop->cop_line = atoi(n)-1;
480 * Called to gobble the appropriate amount and type of whitespace.
481 * Skips comments as well.
485 S_skipspace(pTHX_ register char *s)
488 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
489 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
495 while (s < PL_bufend && isSPACE(*s)) {
496 if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
501 if (s < PL_bufend && *s == '#') {
502 while (s < PL_bufend && *s != '\n')
506 if (PL_in_eval && !PL_rsfp) {
513 /* only continue to recharge the buffer if we're at the end
514 * of the buffer, we're not reading from a source filter, and
515 * we're in normal lexing mode
517 if (s < PL_bufend || !PL_rsfp || PL_lex_state != LEX_NORMAL)
520 /* try to recharge the buffer */
521 if ((s = filter_gets(PL_linestr, PL_rsfp,
522 (prevlen = SvCUR(PL_linestr)))) == Nullch)
524 /* end of file. Add on the -p or -n magic */
525 if (PL_minus_n || PL_minus_p) {
526 sv_setpv(PL_linestr,PL_minus_p ?
527 ";}continue{print or die qq(-p destination: $!\\n)" :
529 sv_catpv(PL_linestr,";}");
530 PL_minus_n = PL_minus_p = 0;
533 sv_setpv(PL_linestr,";");
535 /* reset variables for next time we lex */
536 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
538 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
540 /* Close the filehandle. Could be from -P preprocessor,
541 * STDIN, or a regular file. If we were reading code from
542 * STDIN (because the commandline held no -e or filename)
543 * then we don't close it, we reset it so the code can
544 * read from STDIN too.
547 if (PL_preprocess && !PL_in_eval)
548 (void)PerlProc_pclose(PL_rsfp);
549 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
550 PerlIO_clearerr(PL_rsfp);
552 (void)PerlIO_close(PL_rsfp);
557 /* not at end of file, so we only read another line */
558 PL_linestart = PL_bufptr = s + prevlen;
559 PL_bufend = s + SvCUR(PL_linestr);
563 /* debugger active and we're not compiling the debugger code,
564 * so store the line into the debugger's array of lines
566 if (PERLDB_LINE && PL_curstash != PL_debstash) {
567 SV *sv = NEWSV(85,0);
569 sv_upgrade(sv, SVt_PVMG);
570 sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
571 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
578 * Check the unary operators to ensure there's no ambiguity in how they're
579 * used. An ambiguous piece of code would be:
581 * This doesn't mean rand() + 5. Because rand() is a unary operator,
582 * the +5 is its argument.
592 if (PL_oldoldbufptr != PL_last_uni)
594 while (isSPACE(*PL_last_uni))
596 for (s = PL_last_uni; isALNUM_lazy(s) || *s == '-'; s++) ;
597 if ((t = strchr(s, '(')) && t < PL_bufptr)
599 if (ckWARN_d(WARN_AMBIGUOUS)){
602 Perl_warner(aTHX_ WARN_AMBIGUOUS,
603 "Warning: Use of \"%s\" without parens is ambiguous",
609 /* workaround to replace the UNI() macro with a function. Only the
610 * hints/uts.sh file mentions this. Other comments elsewhere in the
611 * source indicate Microport Unix might need it too.
617 #define UNI(f) return uni(f,s)
620 S_uni(pTHX_ I32 f, char *s)
625 PL_last_uni = PL_oldbufptr;
636 #endif /* CRIPPLED_CC */
639 * LOP : macro to build a list operator. Its behaviour has been replaced
640 * with a subroutine, S_lop() for which LOP is just another name.
643 #define LOP(f,x) return lop(f,x,s)
647 * Build a list operator (or something that might be one). The rules:
648 * - if we have a next token, then it's a list operator [why?]
649 * - if the next thing is an opening paren, then it's a function
650 * - else it's a list operator
654 S_lop(pTHX_ I32 f, expectation x, char *s)
661 PL_last_lop = PL_oldbufptr;
676 * When the lexer realizes it knows the next token (for instance,
677 * it is reordering tokens for the parser) then it can call S_force_next
678 * to know what token to return the next time the lexer is called. Caller
679 * will need to set PL_nextval[], and possibly PL_expect to ensure the lexer
680 * handles the token correctly.
684 S_force_next(pTHX_ I32 type)
686 PL_nexttype[PL_nexttoke] = type;
688 if (PL_lex_state != LEX_KNOWNEXT) {
689 PL_lex_defer = PL_lex_state;
690 PL_lex_expect = PL_expect;
691 PL_lex_state = LEX_KNOWNEXT;
697 * When the lexer knows the next thing is a word (for instance, it has
698 * just seen -> and it knows that the next char is a word char, then
699 * it calls S_force_word to stick the next word into the PL_next lookahead.
702 * char *start : start of the buffer
703 * int token : PL_next will be this type of bare word (e.g., METHOD,WORD)
704 * int check_keyword : if true, Perl checks to make sure the word isn't
705 * a keyword (do this if the word is a label, e.g. goto FOO)
706 * int allow_pack : if true, : characters will also be allowed (require,
708 * int allow_initial_tick : used by the "sub" lexer only.
712 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
717 start = skipspace(start);
719 if (isIDFIRST_lazy(s) ||
720 (allow_pack && *s == ':') ||
721 (allow_initial_tick && *s == '\'') )
723 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
724 if (check_keyword && keyword(PL_tokenbuf, len))
726 if (token == METHOD) {
731 PL_expect = XOPERATOR;
734 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(PL_tokenbuf,0));
735 PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
743 * Called when the lexer wants $foo *foo &foo etc, but the program
744 * text only contains the "foo" portion. The first argument is a pointer
745 * to the "foo", and the second argument is the type symbol to prefix.
746 * Forces the next token to be a "WORD".
747 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
751 S_force_ident(pTHX_ register char *s, int kind)
754 OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
755 PL_nextval[PL_nexttoke].opval = o;
758 dTHR; /* just for in_eval */
759 o->op_private = OPpCONST_ENTERED;
760 /* XXX see note in pp_entereval() for why we forgo typo
761 warnings if the symbol must be introduced in an eval.
763 gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
764 kind == '$' ? SVt_PV :
765 kind == '@' ? SVt_PVAV :
766 kind == '%' ? SVt_PVHV :
775 * Forces the next token to be a version number.
779 S_force_version(pTHX_ char *s)
781 OP *version = Nullop;
785 /* default VERSION number -- GBARR */
790 for( d=s, c = 1; isDIGIT(*d) || *d == '_' || (*d == '.' && c--); d++);
791 if((*d == ';' || isSPACE(*d)) && *(skipspace(d)) != ',') {
793 /* real VERSION number -- GBARR */
794 version = yylval.opval;
798 /* NOTE: The parser sees the package name and the VERSION swapped */
799 PL_nextval[PL_nexttoke].opval = version;
807 * Tokenize a quoted string passed in as an SV. It finds the next
808 * chunk, up to end of string or a backslash. It may make a new
809 * SV containing that chunk (if HINT_NEW_STRING is on). It also
814 S_tokeq(pTHX_ SV *sv)
825 s = SvPV_force(sv, len);
829 while (s < send && *s != '\\')
834 if ( PL_hints & HINT_NEW_STRING )
835 pv = sv_2mortal(newSVpvn(SvPVX(pv), len));
838 if (s + 1 < send && (s[1] == '\\'))
839 s++; /* all that, just for this */
844 SvCUR_set(sv, d - SvPVX(sv));
846 if ( PL_hints & HINT_NEW_STRING )
847 return new_constant(NULL, 0, "q", sv, pv, "q");
852 * Now come three functions related to double-quote context,
853 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
854 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
855 * interact with PL_lex_state, and create fake ( ... ) argument lists
856 * to handle functions and concatenation.
857 * They assume that whoever calls them will be setting up a fake
858 * join call, because each subthing puts a ',' after it. This lets
861 * join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
863 * (I'm not sure whether the spurious commas at the end of lcfirst's
864 * arguments and join's arguments are created or not).
869 * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST).
871 * Pattern matching will set PL_lex_op to the pattern-matching op to
872 * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise).
874 * OP_CONST and OP_READLINE are easy--just make the new op and return.
876 * Everything else becomes a FUNC.
878 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
879 * had an OP_CONST or OP_READLINE). This just sets us up for a
880 * call to S_sublex_push().
886 register I32 op_type = yylval.ival;
888 if (op_type == OP_NULL) {
889 yylval.opval = PL_lex_op;
893 if (op_type == OP_CONST || op_type == OP_READLINE) {
894 SV *sv = tokeq(PL_lex_stuff);
896 if (SvTYPE(sv) == SVt_PVIV) {
897 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
903 nsv = newSVpvn(p, len);
907 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
908 PL_lex_stuff = Nullsv;
912 PL_sublex_info.super_state = PL_lex_state;
913 PL_sublex_info.sub_inwhat = op_type;
914 PL_sublex_info.sub_op = PL_lex_op;
915 PL_lex_state = LEX_INTERPPUSH;
919 yylval.opval = PL_lex_op;
929 * Create a new scope to save the lexing state. The scope will be
930 * ended in S_sublex_done. Returns a '(', starting the function arguments
931 * to the uc, lc, etc. found before.
932 * Sets PL_lex_state to LEX_INTERPCONCAT.
941 PL_lex_state = PL_sublex_info.super_state;
942 SAVEI32(PL_lex_dojoin);
943 SAVEI32(PL_lex_brackets);
944 SAVEI32(PL_lex_fakebrack);
945 SAVEI32(PL_lex_casemods);
946 SAVEI32(PL_lex_starts);
947 SAVEI32(PL_lex_state);
948 SAVESPTR(PL_lex_inpat);
949 SAVEI32(PL_lex_inwhat);
950 SAVEI16(PL_curcop->cop_line);
952 SAVEPPTR(PL_oldbufptr);
953 SAVEPPTR(PL_oldoldbufptr);
954 SAVEPPTR(PL_linestart);
955 SAVESPTR(PL_linestr);
956 SAVEPPTR(PL_lex_brackstack);
957 SAVEPPTR(PL_lex_casestack);
959 PL_linestr = PL_lex_stuff;
960 PL_lex_stuff = Nullsv;
962 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
964 PL_bufend += SvCUR(PL_linestr);
965 SAVEFREESV(PL_linestr);
967 PL_lex_dojoin = FALSE;
969 PL_lex_fakebrack = 0;
970 New(899, PL_lex_brackstack, 120, char);
971 New(899, PL_lex_casestack, 12, char);
972 SAVEFREEPV(PL_lex_brackstack);
973 SAVEFREEPV(PL_lex_casestack);
975 *PL_lex_casestack = '\0';
977 PL_lex_state = LEX_INTERPCONCAT;
978 PL_curcop->cop_line = PL_multi_start;
980 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
981 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
982 PL_lex_inpat = PL_sublex_info.sub_op;
984 PL_lex_inpat = Nullop;
991 * Restores lexer state after a S_sublex_push.
997 if (!PL_lex_starts++) {
998 PL_expect = XOPERATOR;
999 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpvn("",0));
1003 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
1004 PL_lex_state = LEX_INTERPCASEMOD;
1008 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1009 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1010 PL_linestr = PL_lex_repl;
1012 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1013 PL_bufend += SvCUR(PL_linestr);
1014 SAVEFREESV(PL_linestr);
1015 PL_lex_dojoin = FALSE;
1016 PL_lex_brackets = 0;
1017 PL_lex_fakebrack = 0;
1018 PL_lex_casemods = 0;
1019 *PL_lex_casestack = '\0';
1021 if (SvEVALED(PL_lex_repl)) {
1022 PL_lex_state = LEX_INTERPNORMAL;
1024 /* we don't clear PL_lex_repl here, so that we can check later
1025 whether this is an evalled subst; that means we rely on the
1026 logic to ensure sublex_done() is called again only via the
1027 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1030 PL_lex_state = LEX_INTERPCONCAT;
1031 PL_lex_repl = Nullsv;
1037 PL_bufend = SvPVX(PL_linestr);
1038 PL_bufend += SvCUR(PL_linestr);
1039 PL_expect = XOPERATOR;
1047 Extracts a pattern, double-quoted string, or transliteration. This
1050 It looks at lex_inwhat and PL_lex_inpat to find out whether it's
1051 processing a pattern (PL_lex_inpat is true), a transliteration
1052 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
1054 Returns a pointer to the character scanned up to. Iff this is
1055 advanced from the start pointer supplied (ie if anything was
1056 successfully parsed), will leave an OP for the substring scanned
1057 in yylval. Caller must intuit reason for not parsing further
1058 by looking at the next characters herself.
1062 double-quoted style: \r and \n
1063 regexp special ones: \D \s
1065 backrefs: \1 (deprecated in substitution replacements)
1066 case and quoting: \U \Q \E
1067 stops on @ and $, but not for $ as tail anchor
1069 In transliterations:
1070 characters are VERY literal, except for - not at the start or end
1071 of the string, which indicates a range. scan_const expands the
1072 range to the full set of intermediate characters.
1074 In double-quoted strings:
1076 double-quoted style: \r and \n
1078 backrefs: \1 (deprecated)
1079 case and quoting: \U \Q \E
1082 scan_const does *not* construct ops to handle interpolated strings.
1083 It stops processing as soon as it finds an embedded $ or @ variable
1084 and leaves it to the caller to work out what's going on.
1086 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
1088 $ in pattern could be $foo or could be tail anchor. Assumption:
1089 it's a tail anchor if $ is the last thing in the string, or if it's
1090 followed by one of ")| \n\t"
1092 \1 (backreferences) are turned into $1
1094 The structure of the code is
1095 while (there's a character to process) {
1096 handle transliteration ranges
1097 skip regexp comments
1098 skip # initiated comments in //x patterns
1099 check for embedded @foo
1100 check for embedded scalars
1102 leave intact backslashes from leave (below)
1103 deprecate \1 in strings and sub replacements
1104 handle string-changing backslashes \l \U \Q \E, etc.
1105 switch (what was escaped) {
1106 handle - in a transliteration (becomes a literal -)
1107 handle \132 octal characters
1108 handle 0x15 hex characters
1109 handle \cV (control V)
1110 handle printf backslashes (\f, \r, \n, etc)
1112 } (end if backslash)
1113 } (end while character to read)
1118 S_scan_const(pTHX_ char *start)
1120 register char *send = PL_bufend; /* end of the constant */
1121 SV *sv = NEWSV(93, send - start); /* sv for the constant */
1122 register char *s = start; /* start of the constant */
1123 register char *d = SvPVX(sv); /* destination for copies */
1124 bool dorange = FALSE; /* are we in a translit range? */
1126 I32 utf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op)
1127 ? (PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
1129 I32 thisutf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op)
1130 ? (PL_sublex_info.sub_op->op_private & (PL_lex_repl ?
1131 OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF))
1133 char *leaveit = /* set of acceptably-backslashed characters */
1135 ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
1138 while (s < send || dorange) {
1139 /* get transliterations out of the way (they're most literal) */
1140 if (PL_lex_inwhat == OP_TRANS) {
1141 /* expand a range A-Z to the full set of characters. AIE! */
1143 I32 i; /* current expanded character */
1144 I32 min; /* first character in range */
1145 I32 max; /* last character in range */
1147 i = d - SvPVX(sv); /* remember current offset */
1148 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
1149 d = SvPVX(sv) + i; /* refresh d after realloc */
1150 d -= 2; /* eat the first char and the - */
1152 min = (U8)*d; /* first char in range */
1153 max = (U8)d[1]; /* last char in range */
1156 if ((isLOWER(min) && isLOWER(max)) ||
1157 (isUPPER(min) && isUPPER(max))) {
1159 for (i = min; i <= max; i++)
1163 for (i = min; i <= max; i++)
1170 for (i = min; i <= max; i++)
1173 /* mark the range as done, and continue */
1178 /* range begins (ignore - as first or last char) */
1179 else if (*s == '-' && s+1 < send && s != start) {
1181 *d++ = (char)0xff; /* use illegal utf8 byte--see pmtrans */
1190 /* if we get here, we're not doing a transliteration */
1192 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
1193 except for the last char, which will be done separately. */
1194 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
1196 while (s < send && *s != ')')
1198 } else if (s[2] == '{'
1199 || s[2] == 'p' && s[3] == '{') { /* This should march regcomp.c */
1201 char *regparse = s + (s[2] == '{' ? 3 : 4);
1204 while (count && (c = *regparse)) {
1205 if (c == '\\' && regparse[1])
1213 if (*regparse != ')') {
1214 regparse--; /* Leave one char for continuation. */
1215 yyerror("Sequence (?{...}) not terminated or not {}-balanced");
1217 while (s < regparse)
1222 /* likewise skip #-initiated comments in //x patterns */
1223 else if (*s == '#' && PL_lex_inpat &&
1224 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
1225 while (s+1 < send && *s != '\n')
1229 /* check for embedded arrays (@foo, @:foo, @'foo, @{foo}, @$foo) */
1230 else if (*s == '@' && s[1] && (isALNUM_lazy(s+1) || strchr(":'{$", s[1])))
1233 /* check for embedded scalars. only stop if we're sure it's a
1236 else if (*s == '$') {
1237 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
1239 if (s + 1 < send && !strchr("()| \n\t", s[1]))
1240 break; /* in regexp, $ might be tail anchor */
1243 /* (now in tr/// code again) */
1245 if (*s & 0x80 && thisutf) {
1246 dTHR; /* only for ckWARN */
1247 if (ckWARN(WARN_UTF8)) {
1248 (void)utf8_to_uv((U8*)s, &len); /* could cvt latin-1 to utf8 here... */
1258 if (*s == '\\' && s+1 < send) {
1261 /* some backslashes we leave behind */
1262 if (*leaveit && *s && strchr(leaveit, *s)) {
1268 /* deprecate \1 in strings and substitution replacements */
1269 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1270 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1272 dTHR; /* only for ckWARN */
1273 if (ckWARN(WARN_SYNTAX))
1274 Perl_warner(aTHX_ WARN_SYNTAX, "\\%c better written as $%c", *s, *s);
1279 /* string-change backslash escapes */
1280 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1285 /* if we get here, it's either a quoted -, or a digit */
1288 /* quoted - in transliterations */
1290 if (PL_lex_inwhat == OP_TRANS) {
1298 if (ckWARN(WARN_UNSAFE) && isALPHA(*s))
1299 Perl_warner(aTHX_ WARN_UNSAFE,
1300 "Unrecognized escape \\%c passed through",
1302 /* default action is to copy the quoted character */
1307 /* \132 indicates an octal constant */
1308 case '0': case '1': case '2': case '3':
1309 case '4': case '5': case '6': case '7':
1310 *d++ = scan_oct(s, 3, &len);
1314 /* \x24 indicates a hex constant */
1318 char* e = strchr(s, '}');
1321 yyerror("Missing right brace on \\x{}");
1326 if (ckWARN(WARN_UTF8))
1327 Perl_warner(aTHX_ WARN_UTF8,
1328 "Use of \\x{} without utf8 declaration");
1330 /* note: utf always shorter than hex */
1331 d = (char*)uv_to_utf8((U8*)d,
1332 scan_hex(s + 1, e - s - 1, &len));
1336 UV uv = (UV)scan_hex(s, 2, &len);
1337 if (utf && PL_lex_inwhat == OP_TRANS &&
1338 utf != (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
1340 d = (char*)uv_to_utf8((U8*)d, uv); /* doing a CU or UC */
1343 if (uv >= 127 && UTF) {
1345 if (ckWARN(WARN_UTF8))
1346 Perl_warner(aTHX_ WARN_UTF8,
1347 "\\x%.*s will produce malformed UTF-8 character; use \\x{%.*s} for that",
1356 /* \c is a control character */
1370 /* printf-style backslashes, formfeeds, newlines, etc */
1388 *d++ = '\047'; /* CP 1047 */
1391 *d++ = '\057'; /* CP 1047 */
1405 } /* end if (backslash) */
1408 } /* while loop to process each character */
1410 /* terminate the string and set up the sv */
1412 SvCUR_set(sv, d - SvPVX(sv));
1415 /* shrink the sv if we allocated more than we used */
1416 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1417 SvLEN_set(sv, SvCUR(sv) + 1);
1418 Renew(SvPVX(sv), SvLEN(sv), char);
1421 /* return the substring (via yylval) only if we parsed anything */
1422 if (s > PL_bufptr) {
1423 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1424 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1426 ( PL_lex_inwhat == OP_TRANS
1428 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1431 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1438 * Returns TRUE if there's more to the expression (e.g., a subscript),
1441 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
1443 * ->[ and ->{ return TRUE
1444 * { and [ outside a pattern are always subscripts, so return TRUE
1445 * if we're outside a pattern and it's not { or [, then return FALSE
1446 * if we're in a pattern and the first char is a {
1447 * {4,5} (any digits around the comma) returns FALSE
1448 * if we're in a pattern and the first char is a [
1450 * [SOMETHING] has a funky algorithm to decide whether it's a
1451 * character class or not. It has to deal with things like
1452 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
1453 * anything else returns TRUE
1456 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1459 S_intuit_more(pTHX_ register char *s)
1461 if (PL_lex_brackets)
1463 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1465 if (*s != '{' && *s != '[')
1470 /* In a pattern, so maybe we have {n,m}. */
1487 /* On the other hand, maybe we have a character class */
1490 if (*s == ']' || *s == '^')
1493 /* this is terrifying, and it works */
1494 int weight = 2; /* let's weigh the evidence */
1496 unsigned char un_char = 255, last_un_char;
1497 char *send = strchr(s,']');
1498 char tmpbuf[sizeof PL_tokenbuf * 4];
1500 if (!send) /* has to be an expression */
1503 Zero(seen,256,char);
1506 else if (isDIGIT(*s)) {
1508 if (isDIGIT(s[1]) && s[2] == ']')
1514 for (; s < send; s++) {
1515 last_un_char = un_char;
1516 un_char = (unsigned char)*s;
1521 weight -= seen[un_char] * 10;
1522 if (isALNUM_lazy(s+1)) {
1523 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1524 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1529 else if (*s == '$' && s[1] &&
1530 strchr("[#!%*<>()-=",s[1])) {
1531 if (/*{*/ strchr("])} =",s[2]))
1540 if (strchr("wds]",s[1]))
1542 else if (seen['\''] || seen['"'])
1544 else if (strchr("rnftbxcav",s[1]))
1546 else if (isDIGIT(s[1])) {
1548 while (s[1] && isDIGIT(s[1]))
1558 if (strchr("aA01! ",last_un_char))
1560 if (strchr("zZ79~",s[1]))
1562 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1563 weight -= 5; /* cope with negative subscript */
1566 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1567 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1572 if (keyword(tmpbuf, d - tmpbuf))
1575 if (un_char == last_un_char + 1)
1577 weight -= seen[un_char];
1582 if (weight >= 0) /* probably a character class */
1592 * Does all the checking to disambiguate
1594 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
1595 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
1597 * First argument is the stuff after the first token, e.g. "bar".
1599 * Not a method if bar is a filehandle.
1600 * Not a method if foo is a subroutine prototyped to take a filehandle.
1601 * Not a method if it's really "Foo $bar"
1602 * Method if it's "foo $bar"
1603 * Not a method if it's really "print foo $bar"
1604 * Method if it's really "foo package::" (interpreted as package->foo)
1605 * Not a method if bar is known to be a subroutne ("sub bar; foo bar")
1606 * Not a method if bar is a filehandle or package, but is quotd with
1611 S_intuit_method(pTHX_ char *start, GV *gv)
1613 char *s = start + (*start == '$');
1614 char tmpbuf[sizeof PL_tokenbuf];
1622 if ((cv = GvCVu(gv))) {
1623 char *proto = SvPVX(cv);
1633 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1634 /* start is the beginning of the possible filehandle/object,
1635 * and s is the end of it
1636 * tmpbuf is a copy of it
1639 if (*start == '$') {
1640 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1645 return *s == '(' ? FUNCMETH : METHOD;
1647 if (!keyword(tmpbuf, len)) {
1648 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1653 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1654 if (indirgv && GvCVu(indirgv))
1656 /* filehandle or package name makes it a method */
1657 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1659 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1660 return 0; /* no assumptions -- "=>" quotes bearword */
1662 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1663 newSVpvn(tmpbuf,len));
1664 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1668 return *s == '(' ? FUNCMETH : METHOD;
1676 * Return a string of Perl code to load the debugger. If PERL5DB
1677 * is set, it will return the contents of that, otherwise a
1678 * compile-time require of perl5db.pl.
1685 char *pdb = PerlEnv_getenv("PERL5DB");
1689 SETERRNO(0,SS$_NORMAL);
1690 return "BEGIN { require 'perl5db.pl' }";
1696 /* Encoded script support. filter_add() effectively inserts a
1697 * 'pre-processing' function into the current source input stream.
1698 * Note that the filter function only applies to the current source file
1699 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1701 * The datasv parameter (which may be NULL) can be used to pass
1702 * private data to this instance of the filter. The filter function
1703 * can recover the SV using the FILTER_DATA macro and use it to
1704 * store private buffers and state information.
1706 * The supplied datasv parameter is upgraded to a PVIO type
1707 * and the IoDIRP field is used to store the function pointer.
1708 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1709 * private use must be set using malloc'd pointers.
1713 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
1715 if (!funcp){ /* temporary handy debugging hack to be deleted */
1716 PL_filter_debug = atoi((char*)datasv);
1719 if (!PL_rsfp_filters)
1720 PL_rsfp_filters = newAV();
1722 datasv = NEWSV(255,0);
1723 if (!SvUPGRADE(datasv, SVt_PVIO))
1724 Perl_die(aTHX_ "Can't upgrade filter_add data to SVt_PVIO");
1725 IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
1727 if (PL_filter_debug) {
1729 Perl_warn(aTHX_ "filter_add func %p (%s)", funcp, SvPV(datasv, n_a));
1731 #endif /* DEBUGGING */
1732 av_unshift(PL_rsfp_filters, 1);
1733 av_store(PL_rsfp_filters, 0, datasv) ;
1738 /* Delete most recently added instance of this filter function. */
1740 Perl_filter_del(pTHX_ filter_t funcp)
1743 if (PL_filter_debug)
1744 Perl_warn(aTHX_ "filter_del func %p", funcp);
1745 #endif /* DEBUGGING */
1746 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
1748 /* if filter is on top of stack (usual case) just pop it off */
1749 if (IoDIRP(FILTER_DATA(AvFILLp(PL_rsfp_filters))) == (DIR*)funcp){
1750 IoDIRP(FILTER_DATA(AvFILLp(PL_rsfp_filters))) = NULL;
1751 sv_free(av_pop(PL_rsfp_filters));
1755 /* we need to search for the correct entry and clear it */
1756 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
1760 /* Invoke the n'th filter function for the current rsfp. */
1762 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
1765 /* 0 = read one text line */
1770 if (!PL_rsfp_filters)
1772 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
1773 /* Provide a default input filter to make life easy. */
1774 /* Note that we append to the line. This is handy. */
1776 if (PL_filter_debug)
1777 Perl_warn(aTHX_ "filter_read %d: from rsfp\n", idx);
1778 #endif /* DEBUGGING */
1782 int old_len = SvCUR(buf_sv) ;
1784 /* ensure buf_sv is large enough */
1785 SvGROW(buf_sv, old_len + maxlen) ;
1786 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1787 if (PerlIO_error(PL_rsfp))
1788 return -1; /* error */
1790 return 0 ; /* end of file */
1792 SvCUR_set(buf_sv, old_len + len) ;
1795 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
1796 if (PerlIO_error(PL_rsfp))
1797 return -1; /* error */
1799 return 0 ; /* end of file */
1802 return SvCUR(buf_sv);
1804 /* Skip this filter slot if filter has been deleted */
1805 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
1807 if (PL_filter_debug)
1808 Perl_warn(aTHX_ "filter_read %d: skipped (filter deleted)\n", idx);
1809 #endif /* DEBUGGING */
1810 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1812 /* Get function pointer hidden within datasv */
1813 funcp = (filter_t)IoDIRP(datasv);
1815 if (PL_filter_debug) {
1817 Perl_warn(aTHX_ "filter_read %d: via function %p (%s)\n",
1818 idx, funcp, SvPV(datasv,n_a));
1820 #endif /* DEBUGGING */
1821 /* Call function. The function is expected to */
1822 /* call "FILTER_READ(idx+1, buf_sv)" first. */
1823 /* Return: <0:error, =0:eof, >0:not eof */
1824 return (*funcp)(aTHXo_ idx, buf_sv, maxlen);
1828 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
1831 if (!PL_rsfp_filters) {
1832 filter_add(win32_textfilter,NULL);
1835 if (PL_rsfp_filters) {
1838 SvCUR_set(sv, 0); /* start with empty line */
1839 if (FILTER_READ(0, sv, 0) > 0)
1840 return ( SvPVX(sv) ) ;
1845 return (sv_gets(sv, fp, append));
1850 static char* exp_name[] =
1851 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "TERMBLOCK" };
1857 Works out what to call the token just pulled out of the input
1858 stream. The yacc parser takes care of taking the ops we return and
1859 stitching them into a tree.
1865 if read an identifier
1866 if we're in a my declaration
1867 croak if they tried to say my($foo::bar)
1868 build the ops for a my() declaration
1869 if it's an access to a my() variable
1870 are we in a sort block?
1871 croak if my($a); $a <=> $b
1872 build ops for access to a my() variable
1873 if in a dq string, and they've said @foo and we can't find @foo
1875 build ops for a bareword
1876 if we already built the token before, use it.
1880 #ifdef USE_PURE_BISON
1881 Perl_yylex(pTHX_ YYSTYPE *lvalp, int *lcharp)
1894 #ifdef USE_PURE_BISON
1895 yylval_pointer = lvalp;
1896 yychar_pointer = lcharp;
1899 /* check if there's an identifier for us to look at */
1900 if (PL_pending_ident) {
1901 /* pit holds the identifier we read and pending_ident is reset */
1902 char pit = PL_pending_ident;
1903 PL_pending_ident = 0;
1905 /* if we're in a my(), we can't allow dynamics here.
1906 $foo'bar has already been turned into $foo::bar, so
1907 just check for colons.
1909 if it's a legal name, the OP is a PADANY.
1912 if (strchr(PL_tokenbuf,':'))
1913 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
1915 yylval.opval = newOP(OP_PADANY, 0);
1916 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
1921 build the ops for accesses to a my() variable.
1923 Deny my($a) or my($b) in a sort block, *if* $a or $b is
1924 then used in a comparison. This catches most, but not
1925 all cases. For instance, it catches
1926 sort { my($a); $a <=> $b }
1928 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
1929 (although why you'd do that is anyone's guess).
1932 if (!strchr(PL_tokenbuf,':')) {
1934 /* Check for single character per-thread SVs */
1935 if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
1936 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
1937 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
1939 yylval.opval = newOP(OP_THREADSV, 0);
1940 yylval.opval->op_targ = tmp;
1943 #endif /* USE_THREADS */
1944 if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
1945 /* if it's a sort block and they're naming $a or $b */
1946 if (PL_last_lop_op == OP_SORT &&
1947 PL_tokenbuf[0] == '$' &&
1948 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
1951 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
1952 d < PL_bufend && *d != '\n';
1955 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
1956 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
1962 yylval.opval = newOP(OP_PADANY, 0);
1963 yylval.opval->op_targ = tmp;
1969 Whine if they've said @foo in a doublequoted string,
1970 and @foo isn't a variable we can find in the symbol
1973 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
1974 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
1975 if (!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
1976 yyerror(Perl_form(aTHX_ "In string, %s now must be written as \\%s",
1977 PL_tokenbuf, PL_tokenbuf));
1980 /* build ops for a bareword */
1981 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
1982 yylval.opval->op_private = OPpCONST_ENTERED;
1983 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
1984 ((PL_tokenbuf[0] == '$') ? SVt_PV
1985 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
1990 /* no identifier pending identification */
1992 switch (PL_lex_state) {
1994 case LEX_NORMAL: /* Some compilers will produce faster */
1995 case LEX_INTERPNORMAL: /* code if we comment these out. */
1999 /* when we're already built the next token, just pull it out the queue */
2002 yylval = PL_nextval[PL_nexttoke];
2004 PL_lex_state = PL_lex_defer;
2005 PL_expect = PL_lex_expect;
2006 PL_lex_defer = LEX_NORMAL;
2008 return(PL_nexttype[PL_nexttoke]);
2010 /* interpolated case modifiers like \L \U, including \Q and \E.
2011 when we get here, PL_bufptr is at the \
2013 case LEX_INTERPCASEMOD:
2015 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
2016 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
2018 /* handle \E or end of string */
2019 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
2023 if (PL_lex_casemods) {
2024 oldmod = PL_lex_casestack[--PL_lex_casemods];
2025 PL_lex_casestack[PL_lex_casemods] = '\0';
2027 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
2029 PL_lex_state = LEX_INTERPCONCAT;
2033 if (PL_bufptr != PL_bufend)
2035 PL_lex_state = LEX_INTERPCONCAT;
2040 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
2041 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
2042 if (strchr("LU", *s) &&
2043 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
2045 PL_lex_casestack[--PL_lex_casemods] = '\0';
2048 if (PL_lex_casemods > 10) {
2049 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
2050 if (newlb != PL_lex_casestack) {
2052 PL_lex_casestack = newlb;
2055 PL_lex_casestack[PL_lex_casemods++] = *s;
2056 PL_lex_casestack[PL_lex_casemods] = '\0';
2057 PL_lex_state = LEX_INTERPCONCAT;
2058 PL_nextval[PL_nexttoke].ival = 0;
2061 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
2063 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
2065 PL_nextval[PL_nexttoke].ival = OP_LC;
2067 PL_nextval[PL_nexttoke].ival = OP_UC;
2069 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
2071 Perl_croak(aTHX_ "panic: yylex");
2074 if (PL_lex_starts) {
2083 case LEX_INTERPPUSH:
2084 return sublex_push();
2086 case LEX_INTERPSTART:
2087 if (PL_bufptr == PL_bufend)
2088 return sublex_done();
2090 PL_lex_dojoin = (*PL_bufptr == '@');
2091 PL_lex_state = LEX_INTERPNORMAL;
2092 if (PL_lex_dojoin) {
2093 PL_nextval[PL_nexttoke].ival = 0;
2096 PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
2097 PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
2098 force_next(PRIVATEREF);
2100 force_ident("\"", '$');
2101 #endif /* USE_THREADS */
2102 PL_nextval[PL_nexttoke].ival = 0;
2104 PL_nextval[PL_nexttoke].ival = 0;
2106 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
2109 if (PL_lex_starts++) {
2115 case LEX_INTERPENDMAYBE:
2116 if (intuit_more(PL_bufptr)) {
2117 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
2123 if (PL_lex_dojoin) {
2124 PL_lex_dojoin = FALSE;
2125 PL_lex_state = LEX_INTERPCONCAT;
2128 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
2129 && SvEVALED(PL_lex_repl))
2131 if (PL_bufptr != PL_bufend)
2132 Perl_croak(aTHX_ "Bad evalled substitution pattern");
2133 PL_lex_repl = Nullsv;
2136 case LEX_INTERPCONCAT:
2138 if (PL_lex_brackets)
2139 Perl_croak(aTHX_ "panic: INTERPCONCAT");
2141 if (PL_bufptr == PL_bufend)
2142 return sublex_done();
2144 if (SvIVX(PL_linestr) == '\'') {
2145 SV *sv = newSVsv(PL_linestr);
2148 else if ( PL_hints & HINT_NEW_RE )
2149 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
2150 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2154 s = scan_const(PL_bufptr);
2156 PL_lex_state = LEX_INTERPCASEMOD;
2158 PL_lex_state = LEX_INTERPSTART;
2161 if (s != PL_bufptr) {
2162 PL_nextval[PL_nexttoke] = yylval;
2165 if (PL_lex_starts++)
2175 PL_lex_state = LEX_NORMAL;
2176 s = scan_formline(PL_bufptr);
2177 if (!PL_lex_formbrack)
2183 PL_oldoldbufptr = PL_oldbufptr;
2186 PerlIO_printf(PerlIO_stderr(), "### Tokener expecting %s at %s\n", exp_name[PL_expect], s);
2192 if (isIDFIRST_lazy(s))
2194 Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
2197 goto fake_eof; /* emulate EOF on ^D or ^Z */
2202 if (PL_lex_brackets)
2203 yyerror("Missing right curly or square bracket");
2206 if (s++ < PL_bufend)
2207 goto retry; /* ignore stray nulls */
2210 if (!PL_in_eval && !PL_preambled) {
2211 PL_preambled = TRUE;
2212 sv_setpv(PL_linestr,incl_perldb());
2213 if (SvCUR(PL_linestr))
2214 sv_catpv(PL_linestr,";");
2216 while(AvFILLp(PL_preambleav) >= 0) {
2217 SV *tmpsv = av_shift(PL_preambleav);
2218 sv_catsv(PL_linestr, tmpsv);
2219 sv_catpv(PL_linestr, ";");
2222 sv_free((SV*)PL_preambleav);
2223 PL_preambleav = NULL;
2225 if (PL_minus_n || PL_minus_p) {
2226 sv_catpv(PL_linestr, "LINE: while (<>) {");
2228 sv_catpv(PL_linestr,"chomp;");
2230 GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
2232 GvIMPORTED_AV_on(gv);
2234 if (strchr("/'\"", *PL_splitstr)
2235 && strchr(PL_splitstr + 1, *PL_splitstr))
2236 Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s);", PL_splitstr);
2239 s = "'~#\200\1'"; /* surely one char is unused...*/
2240 while (s[1] && strchr(PL_splitstr, *s)) s++;
2242 Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s%c",
2243 "q" + (delim == '\''), delim);
2244 for (s = PL_splitstr; *s; s++) {
2246 sv_catpvn(PL_linestr, "\\", 1);
2247 sv_catpvn(PL_linestr, s, 1);
2249 Perl_sv_catpvf(aTHX_ PL_linestr, "%c);", delim);
2253 sv_catpv(PL_linestr,"@F=split(' ');");
2256 sv_catpv(PL_linestr, "\n");
2257 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2258 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2259 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2260 SV *sv = NEWSV(85,0);
2262 sv_upgrade(sv, SVt_PVMG);
2263 sv_setsv(sv,PL_linestr);
2264 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
2269 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
2272 if (PL_preprocess && !PL_in_eval)
2273 (void)PerlProc_pclose(PL_rsfp);
2274 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2275 PerlIO_clearerr(PL_rsfp);
2277 (void)PerlIO_close(PL_rsfp);
2279 PL_doextract = FALSE;
2281 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2282 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
2283 sv_catpv(PL_linestr,";}");
2284 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2285 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2286 PL_minus_n = PL_minus_p = 0;
2289 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2290 sv_setpv(PL_linestr,"");
2291 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
2294 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
2295 PL_doextract = FALSE;
2297 /* Incest with pod. */
2298 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2299 sv_setpv(PL_linestr, "");
2300 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2301 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2302 PL_doextract = FALSE;
2306 } while (PL_doextract);
2307 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2308 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2309 SV *sv = NEWSV(85,0);
2311 sv_upgrade(sv, SVt_PVMG);
2312 sv_setsv(sv,PL_linestr);
2313 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
2315 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2316 if (PL_curcop->cop_line == 1) {
2317 while (s < PL_bufend && isSPACE(*s))
2319 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2323 if (*s == '#' && *(s+1) == '!')
2325 #ifdef ALTERNATE_SHEBANG
2327 static char as[] = ALTERNATE_SHEBANG;
2328 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2329 d = s + (sizeof(as) - 1);
2331 #endif /* ALTERNATE_SHEBANG */
2340 while (*d && !isSPACE(*d))
2344 #ifdef ARG_ZERO_IS_SCRIPT
2345 if (ipathend > ipath) {
2347 * HP-UX (at least) sets argv[0] to the script name,
2348 * which makes $^X incorrect. And Digital UNIX and Linux,
2349 * at least, set argv[0] to the basename of the Perl
2350 * interpreter. So, having found "#!", we'll set it right.
2352 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
2353 assert(SvPOK(x) || SvGMAGICAL(x));
2354 if (sv_eq(x, GvSV(PL_curcop->cop_filegv))) {
2355 sv_setpvn(x, ipath, ipathend - ipath);
2358 TAINT_NOT; /* $^X is always tainted, but that's OK */
2360 #endif /* ARG_ZERO_IS_SCRIPT */
2365 d = instr(s,"perl -");
2367 d = instr(s,"perl");
2368 #ifdef ALTERNATE_SHEBANG
2370 * If the ALTERNATE_SHEBANG on this system starts with a
2371 * character that can be part of a Perl expression, then if
2372 * we see it but not "perl", we're probably looking at the
2373 * start of Perl code, not a request to hand off to some
2374 * other interpreter. Similarly, if "perl" is there, but
2375 * not in the first 'word' of the line, we assume the line
2376 * contains the start of the Perl program.
2378 if (d && *s != '#') {
2380 while (*c && !strchr("; \t\r\n\f\v#", *c))
2383 d = Nullch; /* "perl" not in first word; ignore */
2385 *s = '#'; /* Don't try to parse shebang line */
2387 #endif /* ALTERNATE_SHEBANG */
2392 !instr(s,"indir") &&
2393 instr(PL_origargv[0],"perl"))
2399 while (s < PL_bufend && isSPACE(*s))
2401 if (s < PL_bufend) {
2402 Newz(899,newargv,PL_origargc+3,char*);
2404 while (s < PL_bufend && !isSPACE(*s))
2407 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2410 newargv = PL_origargv;
2412 PerlProc_execv(ipath, newargv);
2413 Perl_croak(aTHX_ "Can't exec %s", ipath);
2416 U32 oldpdb = PL_perldb;
2417 bool oldn = PL_minus_n;
2418 bool oldp = PL_minus_p;
2420 while (*d && !isSPACE(*d)) d++;
2421 while (*d == ' ' || *d == '\t') d++;
2425 if (*d == 'M' || *d == 'm') {
2427 while (*d && !isSPACE(*d)) d++;
2428 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2431 d = moreswitches(d);
2433 if (PERLDB_LINE && !oldpdb ||
2434 ( PL_minus_n || PL_minus_p ) && !(oldn || oldp) )
2435 /* if we have already added "LINE: while (<>) {",
2436 we must not do it again */
2438 sv_setpv(PL_linestr, "");
2439 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2440 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2441 PL_preambled = FALSE;
2443 (void)gv_fetchfile(PL_origfilename);
2450 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2452 PL_lex_state = LEX_FORMLINE;
2457 #ifdef PERL_STRICT_CR
2458 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2460 "(Maybe you didn't strip carriage returns after a network transfer?)\n");
2462 case ' ': case '\t': case '\f': case 013:
2467 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2469 while (s < d && *s != '\n')
2474 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2476 PL_lex_state = LEX_FORMLINE;
2486 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2491 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2494 if (strnEQ(s,"=>",2)) {
2495 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2496 OPERATOR('-'); /* unary minus */
2498 PL_last_uni = PL_oldbufptr;
2499 PL_last_lop_op = OP_FTEREAD; /* good enough */
2501 case 'r': FTST(OP_FTEREAD);
2502 case 'w': FTST(OP_FTEWRITE);
2503 case 'x': FTST(OP_FTEEXEC);
2504 case 'o': FTST(OP_FTEOWNED);
2505 case 'R': FTST(OP_FTRREAD);
2506 case 'W': FTST(OP_FTRWRITE);
2507 case 'X': FTST(OP_FTREXEC);
2508 case 'O': FTST(OP_FTROWNED);
2509 case 'e': FTST(OP_FTIS);
2510 case 'z': FTST(OP_FTZERO);
2511 case 's': FTST(OP_FTSIZE);
2512 case 'f': FTST(OP_FTFILE);
2513 case 'd': FTST(OP_FTDIR);
2514 case 'l': FTST(OP_FTLINK);
2515 case 'p': FTST(OP_FTPIPE);
2516 case 'S': FTST(OP_FTSOCK);
2517 case 'u': FTST(OP_FTSUID);
2518 case 'g': FTST(OP_FTSGID);
2519 case 'k': FTST(OP_FTSVTX);
2520 case 'b': FTST(OP_FTBLK);
2521 case 'c': FTST(OP_FTCHR);
2522 case 't': FTST(OP_FTTTY);
2523 case 'T': FTST(OP_FTTEXT);
2524 case 'B': FTST(OP_FTBINARY);
2525 case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2526 case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2527 case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
2529 Perl_croak(aTHX_ "Unrecognized file test: -%c", (int)tmp);
2536 if (PL_expect == XOPERATOR)
2541 else if (*s == '>') {
2544 if (isIDFIRST_lazy(s)) {
2545 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2553 if (PL_expect == XOPERATOR)
2556 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2558 OPERATOR('-'); /* unary minus */
2565 if (PL_expect == XOPERATOR)
2570 if (PL_expect == XOPERATOR)
2573 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2579 if (PL_expect != XOPERATOR) {
2580 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2581 PL_expect = XOPERATOR;
2582 force_ident(PL_tokenbuf, '*');
2595 if (PL_expect == XOPERATOR) {
2599 PL_tokenbuf[0] = '%';
2600 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2601 if (!PL_tokenbuf[1]) {
2603 yyerror("Final % should be \\% or %name");
2606 PL_pending_ident = '%';
2628 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
2629 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
2634 if (PL_curcop->cop_line < PL_copline)
2635 PL_copline = PL_curcop->cop_line;
2646 if (PL_lex_brackets <= 0)
2647 yyerror("Unmatched right square bracket");
2650 if (PL_lex_state == LEX_INTERPNORMAL) {
2651 if (PL_lex_brackets == 0) {
2652 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
2653 PL_lex_state = LEX_INTERPEND;
2660 if (PL_lex_brackets > 100) {
2661 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
2662 if (newlb != PL_lex_brackstack) {
2664 PL_lex_brackstack = newlb;
2667 switch (PL_expect) {
2669 if (PL_lex_formbrack) {
2673 if (PL_oldoldbufptr == PL_last_lop)
2674 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2676 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2677 OPERATOR(HASHBRACK);
2679 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2682 PL_tokenbuf[0] = '\0';
2683 if (d < PL_bufend && *d == '-') {
2684 PL_tokenbuf[0] = '-';
2686 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2689 if (d < PL_bufend && isIDFIRST_lazy(d)) {
2690 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2692 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2695 char minus = (PL_tokenbuf[0] == '-');
2696 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2703 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
2707 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2712 if (PL_oldoldbufptr == PL_last_lop)
2713 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2715 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2718 OPERATOR(HASHBRACK);
2719 /* This hack serves to disambiguate a pair of curlies
2720 * as being a block or an anon hash. Normally, expectation
2721 * determines that, but in cases where we're not in a
2722 * position to expect anything in particular (like inside
2723 * eval"") we have to resolve the ambiguity. This code
2724 * covers the case where the first term in the curlies is a
2725 * quoted string. Most other cases need to be explicitly
2726 * disambiguated by prepending a `+' before the opening
2727 * curly in order to force resolution as an anon hash.
2729 * XXX should probably propagate the outer expectation
2730 * into eval"" to rely less on this hack, but that could
2731 * potentially break current behavior of eval"".
2735 if (*s == '\'' || *s == '"' || *s == '`') {
2736 /* common case: get past first string, handling escapes */
2737 for (t++; t < PL_bufend && *t != *s;)
2738 if (*t++ == '\\' && (*t == '\\' || *t == *s))
2742 else if (*s == 'q') {
2745 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
2746 && !isALNUM(*t)))) {
2748 char open, close, term;
2751 while (t < PL_bufend && isSPACE(*t))
2755 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
2759 for (t++; t < PL_bufend; t++) {
2760 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
2762 else if (*t == open)
2766 for (t++; t < PL_bufend; t++) {
2767 if (*t == '\\' && t+1 < PL_bufend)
2769 else if (*t == close && --brackets <= 0)
2771 else if (*t == open)
2777 else if (isIDFIRST_lazy(s)) {
2778 for (t++; t < PL_bufend && isALNUM_lazy(t); t++) ;
2780 while (t < PL_bufend && isSPACE(*t))
2782 /* if comma follows first term, call it an anon hash */
2783 /* XXX it could be a comma expression with loop modifiers */
2784 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
2785 || (*t == '=' && t[1] == '>')))
2786 OPERATOR(HASHBRACK);
2787 if (PL_expect == XREF)
2790 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
2796 yylval.ival = PL_curcop->cop_line;
2797 if (isSPACE(*s) || *s == '#')
2798 PL_copline = NOLINE; /* invalidate current command line number */
2803 if (PL_lex_brackets <= 0)
2804 yyerror("Unmatched right curly bracket");
2806 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
2807 if (PL_lex_brackets < PL_lex_formbrack)
2808 PL_lex_formbrack = 0;
2809 if (PL_lex_state == LEX_INTERPNORMAL) {
2810 if (PL_lex_brackets == 0) {
2811 if (PL_lex_fakebrack) {
2812 PL_lex_state = LEX_INTERPEND;
2814 return yylex(); /* ignore fake brackets */
2816 if (*s == '-' && s[1] == '>')
2817 PL_lex_state = LEX_INTERPENDMAYBE;
2818 else if (*s != '[' && *s != '{')
2819 PL_lex_state = LEX_INTERPEND;
2822 if (PL_lex_brackets < PL_lex_fakebrack) {
2824 PL_lex_fakebrack = 0;
2825 return yylex(); /* ignore fake brackets */
2835 if (PL_expect == XOPERATOR) {
2836 if (ckWARN(WARN_SEMICOLON) && isIDFIRST_lazy(s) && PL_bufptr == PL_linestart) {
2837 PL_curcop->cop_line--;
2838 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
2839 PL_curcop->cop_line++;
2844 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2846 PL_expect = XOPERATOR;
2847 force_ident(PL_tokenbuf, '&');
2851 yylval.ival = (OPpENTERSUB_AMPER<<8);
2870 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
2871 Perl_warner(aTHX_ WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
2873 if (PL_expect == XSTATE && isALPHA(tmp) &&
2874 (s == PL_linestart+1 || s[-2] == '\n') )
2876 if (PL_in_eval && !PL_rsfp) {
2881 if (strnEQ(s,"=cut",4)) {
2895 PL_doextract = TRUE;
2898 if (PL_lex_brackets < PL_lex_formbrack) {
2900 #ifdef PERL_STRICT_CR
2901 for (t = s; *t == ' ' || *t == '\t'; t++) ;
2903 for (t = s; *t == ' ' || *t == '\t' || *t == '\r'; t++) ;
2905 if (*t == '\n' || *t == '#') {
2923 if (PL_expect != XOPERATOR) {
2924 if (s[1] != '<' && !strchr(s,'>'))
2927 s = scan_heredoc(s);
2929 s = scan_inputsymbol(s);
2930 TERM(sublex_start());
2935 SHop(OP_LEFT_SHIFT);
2949 SHop(OP_RIGHT_SHIFT);
2958 if (PL_expect == XOPERATOR) {
2959 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2962 return ','; /* grandfather non-comma-format format */
2966 if (s[1] == '#' && (isIDFIRST_lazy(s+2) || strchr("{$:+-", s[2]))) {
2967 PL_tokenbuf[0] = '@';
2968 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
2969 sizeof PL_tokenbuf - 1, FALSE);
2970 if (PL_expect == XOPERATOR)
2971 no_op("Array length", s);
2972 if (!PL_tokenbuf[1])
2974 PL_expect = XOPERATOR;
2975 PL_pending_ident = '#';
2979 PL_tokenbuf[0] = '$';
2980 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
2981 sizeof PL_tokenbuf - 1, FALSE);
2982 if (PL_expect == XOPERATOR)
2984 if (!PL_tokenbuf[1]) {
2986 yyerror("Final $ should be \\$ or $name");
2990 /* This kludge not intended to be bulletproof. */
2991 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
2992 yylval.opval = newSVOP(OP_CONST, 0,
2993 newSViv((IV)PL_compiling.cop_arybase));
2994 yylval.opval->op_private = OPpCONST_ARYBASE;
3000 if (PL_lex_state == LEX_NORMAL)
3003 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3006 PL_tokenbuf[0] = '@';
3007 if (ckWARN(WARN_SYNTAX)) {
3009 isSPACE(*t) || isALNUM_lazy(t) || *t == '$';
3012 PL_bufptr = skipspace(PL_bufptr);
3013 while (t < PL_bufend && *t != ']')
3015 Perl_warner(aTHX_ WARN_SYNTAX,
3016 "Multidimensional syntax %.*s not supported",
3017 (t - PL_bufptr) + 1, PL_bufptr);
3021 else if (*s == '{') {
3022 PL_tokenbuf[0] = '%';
3023 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
3024 (t = strchr(s, '}')) && (t = strchr(t, '=')))
3026 char tmpbuf[sizeof PL_tokenbuf];
3028 for (t++; isSPACE(*t); t++) ;
3029 if (isIDFIRST_lazy(t)) {
3030 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
3031 for (; isSPACE(*t); t++) ;
3032 if (*t == ';' && get_cv(tmpbuf, FALSE))
3033 Perl_warner(aTHX_ WARN_SYNTAX,
3034 "You need to quote \"%s\"", tmpbuf);
3040 PL_expect = XOPERATOR;
3041 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3042 bool islop = (PL_last_lop == PL_oldoldbufptr);
3043 if (!islop || PL_last_lop_op == OP_GREPSTART)
3044 PL_expect = XOPERATOR;
3045 else if (strchr("$@\"'`q", *s))
3046 PL_expect = XTERM; /* e.g. print $fh "foo" */
3047 else if (strchr("&*<%", *s) && isIDFIRST_lazy(s+1))
3048 PL_expect = XTERM; /* e.g. print $fh &sub */
3049 else if (isIDFIRST_lazy(s)) {
3050 char tmpbuf[sizeof PL_tokenbuf];
3051 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3052 if (tmp = keyword(tmpbuf, len)) {
3053 /* binary operators exclude handle interpretations */
3065 PL_expect = XTERM; /* e.g. print $fh length() */
3070 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
3071 if (gv && GvCVu(gv))
3072 PL_expect = XTERM; /* e.g. print $fh subr() */
3075 else if (isDIGIT(*s))
3076 PL_expect = XTERM; /* e.g. print $fh 3 */
3077 else if (*s == '.' && isDIGIT(s[1]))
3078 PL_expect = XTERM; /* e.g. print $fh .3 */
3079 else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
3080 PL_expect = XTERM; /* e.g. print $fh -1 */
3081 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3082 PL_expect = XTERM; /* print $fh <<"EOF" */
3084 PL_pending_ident = '$';
3088 if (PL_expect == XOPERATOR)
3090 PL_tokenbuf[0] = '@';
3091 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3092 if (!PL_tokenbuf[1]) {
3094 yyerror("Final @ should be \\@ or @name");
3097 if (PL_lex_state == LEX_NORMAL)
3099 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3101 PL_tokenbuf[0] = '%';
3103 /* Warn about @ where they meant $. */
3104 if (ckWARN(WARN_SYNTAX)) {
3105 if (*s == '[' || *s == '{') {
3107 while (*t && (isALNUM_lazy(t) || strchr(" \t$#+-'\"", *t)))
3109 if (*t == '}' || *t == ']') {
3111 PL_bufptr = skipspace(PL_bufptr);
3112 Perl_warner(aTHX_ WARN_SYNTAX,
3113 "Scalar value %.*s better written as $%.*s",
3114 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
3119 PL_pending_ident = '@';
3122 case '/': /* may either be division or pattern */
3123 case '?': /* may either be conditional or pattern */
3124 if (PL_expect != XOPERATOR) {
3125 /* Disable warning on "study /blah/" */
3126 if (PL_oldoldbufptr == PL_last_uni
3127 && (*PL_last_uni != 's' || s - PL_last_uni < 5
3128 || memNE(PL_last_uni, "study", 5) || isALNUM_lazy(PL_last_uni+5)))
3130 s = scan_pat(s,OP_MATCH);
3131 TERM(sublex_start());
3139 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3140 #ifdef PERL_STRICT_CR
3143 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3145 && (s == PL_linestart || s[-1] == '\n') )
3147 PL_lex_formbrack = 0;
3151 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
3157 yylval.ival = OPf_SPECIAL;
3163 if (PL_expect != XOPERATOR)
3168 case '0': case '1': case '2': case '3': case '4':
3169 case '5': case '6': case '7': case '8': case '9':
3171 if (PL_expect == XOPERATOR)
3177 if (PL_expect == XOPERATOR) {
3178 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3181 return ','; /* grandfather non-comma-format format */
3187 missingterm((char*)0);
3188 yylval.ival = OP_CONST;
3189 TERM(sublex_start());
3193 if (PL_expect == XOPERATOR) {
3194 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3197 return ','; /* grandfather non-comma-format format */
3203 missingterm((char*)0);
3204 yylval.ival = OP_CONST;
3205 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
3206 if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
3207 yylval.ival = OP_STRINGIFY;
3211 TERM(sublex_start());
3215 if (PL_expect == XOPERATOR)
3216 no_op("Backticks",s);
3218 missingterm((char*)0);
3219 yylval.ival = OP_BACKTICK;
3221 TERM(sublex_start());
3225 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
3226 Perl_warner(aTHX_ WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
3228 if (PL_expect == XOPERATOR)
3229 no_op("Backslash",s);
3233 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
3273 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3275 /* Some keywords can be followed by any delimiter, including ':' */
3276 tmp = (len == 1 && strchr("msyq", PL_tokenbuf[0]) ||
3277 len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
3278 (PL_tokenbuf[0] == 'q' &&
3279 strchr("qwxr", PL_tokenbuf[1]))));
3281 /* x::* is just a word, unless x is "CORE" */
3282 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
3286 while (d < PL_bufend && isSPACE(*d))
3287 d++; /* no comments skipped here, or s### is misparsed */
3289 /* Is this a label? */
3290 if (!tmp && PL_expect == XSTATE
3291 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
3293 yylval.pval = savepv(PL_tokenbuf);
3298 /* Check for keywords */
3299 tmp = keyword(PL_tokenbuf, len);
3301 /* Is this a word before a => operator? */
3302 if (strnEQ(d,"=>",2)) {
3304 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
3305 yylval.opval->op_private = OPpCONST_BARE;
3309 if (tmp < 0) { /* second-class keyword? */
3310 GV *ogv = Nullgv; /* override (winner) */
3311 GV *hgv = Nullgv; /* hidden (loser) */
3312 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3314 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3317 if (GvIMPORTED_CV(gv))
3319 else if (! CvMETHOD(cv))
3323 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3324 (gv = *gvp) != (GV*)&PL_sv_undef &&
3325 GvCVu(gv) && GvIMPORTED_CV(gv))
3331 tmp = 0; /* overridden by import or by GLOBAL */
3334 && -tmp==KEY_lock /* XXX generalizable kludge */
3335 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3337 tmp = 0; /* any sub overrides "weak" keyword */
3339 else { /* no override */
3343 if (ckWARN(WARN_AMBIGUOUS) && hgv
3344 && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3345 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3346 "Ambiguous call resolved as CORE::%s(), %s",
3347 GvENAME(hgv), "qualify as such or use &");
3354 default: /* not a keyword */
3357 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3359 /* Get the rest if it looks like a package qualifier */
3361 if (*s == '\'' || *s == ':' && s[1] == ':') {
3363 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3366 Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
3367 *s == '\'' ? "'" : "::");
3371 if (PL_expect == XOPERATOR) {
3372 if (PL_bufptr == PL_linestart) {
3373 PL_curcop->cop_line--;
3374 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3375 PL_curcop->cop_line++;
3378 no_op("Bareword",s);
3381 /* Look for a subroutine with this name in current package,
3382 unless name is "Foo::", in which case Foo is a bearword
3383 (and a package name). */
3386 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3388 if (ckWARN(WARN_UNSAFE) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3389 Perl_warner(aTHX_ WARN_UNSAFE,
3390 "Bareword \"%s\" refers to nonexistent package",
3393 PL_tokenbuf[len] = '\0';
3400 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3403 /* if we saw a global override before, get the right name */
3406 sv = newSVpvn("CORE::GLOBAL::",14);
3407 sv_catpv(sv,PL_tokenbuf);
3410 sv = newSVpv(PL_tokenbuf,0);
3412 /* Presume this is going to be a bareword of some sort. */
3415 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3416 yylval.opval->op_private = OPpCONST_BARE;
3418 /* And if "Foo::", then that's what it certainly is. */
3423 /* See if it's the indirect object for a list operator. */
3425 if (PL_oldoldbufptr &&
3426 PL_oldoldbufptr < PL_bufptr &&
3427 (PL_oldoldbufptr == PL_last_lop || PL_oldoldbufptr == PL_last_uni) &&
3428 /* NO SKIPSPACE BEFORE HERE! */
3429 (PL_expect == XREF ||
3430 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
3432 bool immediate_paren = *s == '(';
3434 /* (Now we can afford to cross potential line boundary.) */
3437 /* Two barewords in a row may indicate method call. */
3439 if ((isIDFIRST_lazy(s) || *s == '$') && (tmp=intuit_method(s,gv)))
3442 /* If not a declared subroutine, it's an indirect object. */
3443 /* (But it's an indir obj regardless for sort.) */
3445 if ((PL_last_lop_op == OP_SORT ||
3446 (!immediate_paren && (!gv || !GvCVu(gv)))) &&
3447 (PL_last_lop_op != OP_MAPSTART &&
3448 PL_last_lop_op != OP_GREPSTART))
3450 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3455 /* If followed by a paren, it's certainly a subroutine. */
3457 PL_expect = XOPERATOR;
3461 if (gv && GvCVu(gv)) {
3462 for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
3463 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
3468 PL_nextval[PL_nexttoke].opval = yylval.opval;
3469 PL_expect = XOPERATOR;
3475 /* If followed by var or block, call it a method (unless sub) */
3477 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3478 PL_last_lop = PL_oldbufptr;
3479 PL_last_lop_op = OP_METHOD;
3483 /* If followed by a bareword, see if it looks like indir obj. */
3485 if ((isIDFIRST_lazy(s) || *s == '$') && (tmp = intuit_method(s,gv)))
3488 /* Not a method, so call it a subroutine (if defined) */
3490 if (gv && GvCVu(gv)) {
3492 if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
3493 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3494 "Ambiguous use of -%s resolved as -&%s()",
3495 PL_tokenbuf, PL_tokenbuf);
3496 /* Check for a constant sub */
3498 if ((sv = cv_const_sv(cv))) {
3500 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3501 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3502 yylval.opval->op_private = 0;
3506 /* Resolve to GV now. */
3507 op_free(yylval.opval);
3508 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3509 yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
3510 PL_last_lop = PL_oldbufptr;
3511 PL_last_lop_op = OP_ENTERSUB;
3512 /* Is there a prototype? */
3515 char *proto = SvPV((SV*)cv, len);
3518 if (strEQ(proto, "$"))
3520 if (*proto == '&' && *s == '{') {
3521 sv_setpv(PL_subname,"__ANON__");
3525 PL_nextval[PL_nexttoke].opval = yylval.opval;
3531 /* Call it a bare word */
3533 if (PL_hints & HINT_STRICT_SUBS)
3534 yylval.opval->op_private |= OPpCONST_STRICT;
3537 if (ckWARN(WARN_RESERVED)) {
3538 if (lastchar != '-') {
3539 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3541 Perl_warner(aTHX_ WARN_RESERVED, PL_warn_reserved,
3548 if (lastchar && strchr("*%&", lastchar) && ckWARN_d(WARN_AMBIGUOUS)) {
3549 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3550 "Operator or semicolon missing before %c%s",
3551 lastchar, PL_tokenbuf);
3552 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3553 "Ambiguous use of %c resolved as operator %c",
3554 lastchar, lastchar);
3560 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3561 newSVsv(GvSV(PL_curcop->cop_filegv)));
3565 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3566 Perl_newSVpvf(aTHX_ "%ld", (long)PL_curcop->cop_line));
3569 case KEY___PACKAGE__:
3570 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3572 ? newSVsv(PL_curstname)
3581 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3582 char *pname = "main";
3583 if (PL_tokenbuf[2] == 'D')
3584 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3585 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
3588 GvIOp(gv) = newIO();
3589 IoIFP(GvIOp(gv)) = PL_rsfp;
3590 #if defined(HAS_FCNTL) && defined(F_SETFD)
3592 int fd = PerlIO_fileno(PL_rsfp);
3593 fcntl(fd,F_SETFD,fd >= 3);
3596 /* Mark this internal pseudo-handle as clean */
3597 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3599 IoTYPE(GvIOp(gv)) = '|';
3600 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
3601 IoTYPE(GvIOp(gv)) = '-';
3603 IoTYPE(GvIOp(gv)) = '<';
3614 if (PL_expect == XSTATE) {
3621 if (*s == ':' && s[1] == ':') {
3624 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3625 tmp = keyword(PL_tokenbuf, len);
3639 LOP(OP_ACCEPT,XTERM);
3645 LOP(OP_ATAN2,XTERM);
3654 LOP(OP_BLESS,XTERM);
3663 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
3680 if (!PL_cryptseen++)
3683 LOP(OP_CRYPT,XTERM);
3686 if (ckWARN(WARN_OCTAL)) {
3687 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
3688 if (*d != '0' && isDIGIT(*d))
3689 yywarn("chmod: mode argument is missing initial 0");
3691 LOP(OP_CHMOD,XTERM);
3694 LOP(OP_CHOWN,XTERM);
3697 LOP(OP_CONNECT,XTERM);
3713 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3717 PL_hints |= HINT_BLOCK_SCOPE;
3727 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3728 LOP(OP_DBMOPEN,XTERM);
3734 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3741 yylval.ival = PL_curcop->cop_line;
3755 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
3756 UNIBRACK(OP_ENTEREVAL);
3771 case KEY_endhostent:
3777 case KEY_endservent:
3780 case KEY_endprotoent:
3791 yylval.ival = PL_curcop->cop_line;
3793 if (PL_expect == XSTATE && isIDFIRST_lazy(s)) {
3795 if ((PL_bufend - p) >= 3 &&
3796 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3799 if (isIDFIRST_lazy(p))
3800 Perl_croak(aTHX_ "Missing $ on loop variable");
3805 LOP(OP_FORMLINE,XTERM);
3811 LOP(OP_FCNTL,XTERM);
3817 LOP(OP_FLOCK,XTERM);
3826 LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
3829 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3844 case KEY_getpriority:
3845 LOP(OP_GETPRIORITY,XTERM);
3847 case KEY_getprotobyname:
3850 case KEY_getprotobynumber:
3851 LOP(OP_GPBYNUMBER,XTERM);
3853 case KEY_getprotoent:
3865 case KEY_getpeername:
3866 UNI(OP_GETPEERNAME);
3868 case KEY_gethostbyname:
3871 case KEY_gethostbyaddr:
3872 LOP(OP_GHBYADDR,XTERM);
3874 case KEY_gethostent:
3877 case KEY_getnetbyname:
3880 case KEY_getnetbyaddr:
3881 LOP(OP_GNBYADDR,XTERM);
3886 case KEY_getservbyname:
3887 LOP(OP_GSBYNAME,XTERM);
3889 case KEY_getservbyport:
3890 LOP(OP_GSBYPORT,XTERM);
3892 case KEY_getservent:
3895 case KEY_getsockname:
3896 UNI(OP_GETSOCKNAME);
3898 case KEY_getsockopt:
3899 LOP(OP_GSOCKOPT,XTERM);
3921 yylval.ival = PL_curcop->cop_line;
3925 LOP(OP_INDEX,XTERM);
3931 LOP(OP_IOCTL,XTERM);
3943 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3974 LOP(OP_LISTEN,XTERM);
3983 s = scan_pat(s,OP_MATCH);
3984 TERM(sublex_start());
3987 LOP(OP_MAPSTART, *s == '(' ? XTERM : XREF);
3990 LOP(OP_MKDIR,XTERM);
3993 LOP(OP_MSGCTL,XTERM);
3996 LOP(OP_MSGGET,XTERM);
3999 LOP(OP_MSGRCV,XTERM);
4002 LOP(OP_MSGSND,XTERM);
4007 if (isIDFIRST_lazy(s)) {
4008 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
4009 PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
4010 if (!PL_in_my_stash) {
4013 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
4020 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4027 if (PL_expect != XSTATE)
4028 yyerror("\"no\" not allowed in expression");
4029 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4030 s = force_version(s);
4039 if (isIDFIRST_lazy(s)) {
4041 for (d = s; isALNUM_lazy(d); d++) ;
4043 if (strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_AMBIGUOUS))
4044 Perl_warner(aTHX_ WARN_AMBIGUOUS,
4045 "Precedence problem: open %.*s should be open(%.*s)",
4051 yylval.ival = OP_OR;
4061 LOP(OP_OPEN_DIR,XTERM);
4064 checkcomma(s,PL_tokenbuf,"filehandle");
4068 checkcomma(s,PL_tokenbuf,"filehandle");
4087 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4091 LOP(OP_PIPE_OP,XTERM);
4096 missingterm((char*)0);
4097 yylval.ival = OP_CONST;
4098 TERM(sublex_start());
4106 missingterm((char*)0);
4108 if (SvCUR(PL_lex_stuff)) {
4111 d = SvPV_force(PL_lex_stuff, len);
4113 for (; isSPACE(*d) && len; --len, ++d) ;
4116 if (!warned && ckWARN(WARN_SYNTAX)) {
4117 for (; !isSPACE(*d) && len; --len, ++d) {
4119 Perl_warner(aTHX_ WARN_SYNTAX,
4120 "Possible attempt to separate words with commas");
4123 else if (*d == '#') {
4124 Perl_warner(aTHX_ WARN_SYNTAX,
4125 "Possible attempt to put comments in qw() list");
4131 for (; !isSPACE(*d) && len; --len, ++d) ;
4133 words = append_elem(OP_LIST, words,
4134 newSVOP(OP_CONST, 0, newSVpvn(b, d-b)));
4138 PL_nextval[PL_nexttoke].opval = words;
4143 SvREFCNT_dec(PL_lex_stuff);
4144 PL_lex_stuff = Nullsv;
4151 missingterm((char*)0);
4152 yylval.ival = OP_STRINGIFY;
4153 if (SvIVX(PL_lex_stuff) == '\'')
4154 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
4155 TERM(sublex_start());
4158 s = scan_pat(s,OP_QR);
4159 TERM(sublex_start());
4164 missingterm((char*)0);
4165 yylval.ival = OP_BACKTICK;
4167 TERM(sublex_start());
4173 *PL_tokenbuf = '\0';
4174 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4175 if (isIDFIRST_lazy(PL_tokenbuf))
4176 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
4178 yyerror("<> should be quotes");
4185 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4189 LOP(OP_RENAME,XTERM);
4198 LOP(OP_RINDEX,XTERM);
4221 LOP(OP_REVERSE,XTERM);
4232 TERM(sublex_start());
4234 TOKEN(1); /* force error */
4243 LOP(OP_SELECT,XTERM);
4249 LOP(OP_SEMCTL,XTERM);
4252 LOP(OP_SEMGET,XTERM);
4255 LOP(OP_SEMOP,XTERM);
4261 LOP(OP_SETPGRP,XTERM);
4263 case KEY_setpriority:
4264 LOP(OP_SETPRIORITY,XTERM);
4266 case KEY_sethostent:
4272 case KEY_setservent:
4275 case KEY_setprotoent:
4285 LOP(OP_SEEKDIR,XTERM);
4287 case KEY_setsockopt:
4288 LOP(OP_SSOCKOPT,XTERM);
4294 LOP(OP_SHMCTL,XTERM);
4297 LOP(OP_SHMGET,XTERM);
4300 LOP(OP_SHMREAD,XTERM);
4303 LOP(OP_SHMWRITE,XTERM);
4306 LOP(OP_SHUTDOWN,XTERM);
4315 LOP(OP_SOCKET,XTERM);
4317 case KEY_socketpair:
4318 LOP(OP_SOCKPAIR,XTERM);
4321 checkcomma(s,PL_tokenbuf,"subroutine name");
4323 if (*s == ';' || *s == ')') /* probably a close */
4324 Perl_croak(aTHX_ "sort is now a reserved word");
4326 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4330 LOP(OP_SPLIT,XTERM);
4333 LOP(OP_SPRINTF,XTERM);
4336 LOP(OP_SPLICE,XTERM);
4352 LOP(OP_SUBSTR,XTERM);
4359 if (isIDFIRST_lazy(s) || *s == '\'' || *s == ':') {
4360 char tmpbuf[sizeof PL_tokenbuf];
4362 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4363 if (strchr(tmpbuf, ':'))
4364 sv_setpv(PL_subname, tmpbuf);
4366 sv_setsv(PL_subname,PL_curstname);
4367 sv_catpvn(PL_subname,"::",2);
4368 sv_catpvn(PL_subname,tmpbuf,len);
4370 s = force_word(s,WORD,FALSE,TRUE,TRUE);
4374 PL_expect = XTERMBLOCK;
4375 sv_setpv(PL_subname,"?");
4378 if (tmp == KEY_format) {
4381 PL_lex_formbrack = PL_lex_brackets + 1;
4385 /* Look for a prototype */
4392 SvREFCNT_dec(PL_lex_stuff);
4393 PL_lex_stuff = Nullsv;
4394 Perl_croak(aTHX_ "Prototype not terminated");
4397 d = SvPVX(PL_lex_stuff);
4399 for (p = d; *p; ++p) {
4404 SvCUR(PL_lex_stuff) = tmp;
4407 PL_nextval[1] = PL_nextval[0];
4408 PL_nexttype[1] = PL_nexttype[0];
4409 PL_nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4410 PL_nexttype[0] = THING;
4411 if (PL_nexttoke == 1) {
4412 PL_lex_defer = PL_lex_state;
4413 PL_lex_expect = PL_expect;
4414 PL_lex_state = LEX_KNOWNEXT;
4416 PL_lex_stuff = Nullsv;
4419 if (*SvPV(PL_subname,n_a) == '?') {
4420 sv_setpv(PL_subname,"__ANON__");
4427 LOP(OP_SYSTEM,XREF);
4430 LOP(OP_SYMLINK,XTERM);
4433 LOP(OP_SYSCALL,XTERM);
4436 LOP(OP_SYSOPEN,XTERM);
4439 LOP(OP_SYSSEEK,XTERM);
4442 LOP(OP_SYSREAD,XTERM);
4445 LOP(OP_SYSWRITE,XTERM);
4449 TERM(sublex_start());
4470 LOP(OP_TRUNCATE,XTERM);
4482 yylval.ival = PL_curcop->cop_line;
4486 yylval.ival = PL_curcop->cop_line;
4490 LOP(OP_UNLINK,XTERM);
4496 LOP(OP_UNPACK,XTERM);
4499 LOP(OP_UTIME,XTERM);
4502 if (ckWARN(WARN_OCTAL)) {
4503 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4504 if (*d != '0' && isDIGIT(*d))
4505 yywarn("umask: argument is missing initial 0");
4510 LOP(OP_UNSHIFT,XTERM);
4513 if (PL_expect != XSTATE)
4514 yyerror("\"use\" not allowed in expression");
4517 s = force_version(s);
4518 if(*s == ';' || (s = skipspace(s), *s == ';')) {
4519 PL_nextval[PL_nexttoke].opval = Nullop;
4524 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4525 s = force_version(s);
4538 yylval.ival = PL_curcop->cop_line;
4542 PL_hints |= HINT_BLOCK_SCOPE;
4549 LOP(OP_WAITPID,XTERM);
4557 static char ctl_l[2];
4559 if (ctl_l[0] == '\0')
4560 ctl_l[0] = toCTRL('L');
4561 gv_fetchpv(ctl_l,TRUE, SVt_PV);
4564 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
4569 if (PL_expect == XOPERATOR)
4575 yylval.ival = OP_XOR;
4580 TERM(sublex_start());
4586 Perl_keyword(pTHX_ register char *d, I32 len)
4591 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
4592 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
4593 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
4594 if (strEQ(d,"__DATA__")) return KEY___DATA__;
4595 if (strEQ(d,"__END__")) return KEY___END__;
4599 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
4604 if (strEQ(d,"and")) return -KEY_and;
4605 if (strEQ(d,"abs")) return -KEY_abs;
4608 if (strEQ(d,"alarm")) return -KEY_alarm;
4609 if (strEQ(d,"atan2")) return -KEY_atan2;
4612 if (strEQ(d,"accept")) return -KEY_accept;
4617 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
4620 if (strEQ(d,"bless")) return -KEY_bless;
4621 if (strEQ(d,"bind")) return -KEY_bind;
4622 if (strEQ(d,"binmode")) return -KEY_binmode;
4625 if (strEQ(d,"CORE")) return -KEY_CORE;
4630 if (strEQ(d,"cmp")) return -KEY_cmp;
4631 if (strEQ(d,"chr")) return -KEY_chr;
4632 if (strEQ(d,"cos")) return -KEY_cos;
4635 if (strEQ(d,"chop")) return KEY_chop;
4638 if (strEQ(d,"close")) return -KEY_close;
4639 if (strEQ(d,"chdir")) return -KEY_chdir;
4640 if (strEQ(d,"chomp")) return KEY_chomp;
4641 if (strEQ(d,"chmod")) return -KEY_chmod;
4642 if (strEQ(d,"chown")) return -KEY_chown;
4643 if (strEQ(d,"crypt")) return -KEY_crypt;
4646 if (strEQ(d,"chroot")) return -KEY_chroot;
4647 if (strEQ(d,"caller")) return -KEY_caller;
4650 if (strEQ(d,"connect")) return -KEY_connect;
4653 if (strEQ(d,"closedir")) return -KEY_closedir;
4654 if (strEQ(d,"continue")) return -KEY_continue;
4659 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
4664 if (strEQ(d,"do")) return KEY_do;
4667 if (strEQ(d,"die")) return -KEY_die;
4670 if (strEQ(d,"dump")) return -KEY_dump;
4673 if (strEQ(d,"delete")) return KEY_delete;
4676 if (strEQ(d,"defined")) return KEY_defined;
4677 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
4680 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
4685 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
4686 if (strEQ(d,"END")) return KEY_END;
4691 if (strEQ(d,"eq")) return -KEY_eq;
4694 if (strEQ(d,"eof")) return -KEY_eof;
4695 if (strEQ(d,"exp")) return -KEY_exp;
4698 if (strEQ(d,"else")) return KEY_else;
4699 if (strEQ(d,"exit")) return -KEY_exit;
4700 if (strEQ(d,"eval")) return KEY_eval;
4701 if (strEQ(d,"exec")) return -KEY_exec;
4702 if (strEQ(d,"each")) return KEY_each;
4705 if (strEQ(d,"elsif")) return KEY_elsif;
4708 if (strEQ(d,"exists")) return KEY_exists;
4709 if (strEQ(d,"elseif")) Perl_warn(aTHX_ "elseif should be elsif");
4712 if (strEQ(d,"endgrent")) return -KEY_endgrent;
4713 if (strEQ(d,"endpwent")) return -KEY_endpwent;
4716 if (strEQ(d,"endnetent")) return -KEY_endnetent;
4719 if (strEQ(d,"endhostent")) return -KEY_endhostent;
4720 if (strEQ(d,"endservent")) return -KEY_endservent;
4723 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
4730 if (strEQ(d,"for")) return KEY_for;
4733 if (strEQ(d,"fork")) return -KEY_fork;
4736 if (strEQ(d,"fcntl")) return -KEY_fcntl;
4737 if (strEQ(d,"flock")) return -KEY_flock;
4740 if (strEQ(d,"format")) return KEY_format;
4741 if (strEQ(d,"fileno")) return -KEY_fileno;
4744 if (strEQ(d,"foreach")) return KEY_foreach;
4747 if (strEQ(d,"formline")) return -KEY_formline;
4753 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
4754 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
4758 if (strnEQ(d,"get",3)) {
4763 if (strEQ(d,"ppid")) return -KEY_getppid;
4764 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
4767 if (strEQ(d,"pwent")) return -KEY_getpwent;
4768 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
4769 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
4772 if (strEQ(d,"peername")) return -KEY_getpeername;
4773 if (strEQ(d,"protoent")) return -KEY_getprotoent;
4774 if (strEQ(d,"priority")) return -KEY_getpriority;
4777 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
4780 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
4784 else if (*d == 'h') {
4785 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
4786 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
4787 if (strEQ(d,"hostent")) return -KEY_gethostent;
4789 else if (*d == 'n') {
4790 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
4791 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
4792 if (strEQ(d,"netent")) return -KEY_getnetent;
4794 else if (*d == 's') {
4795 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
4796 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
4797 if (strEQ(d,"servent")) return -KEY_getservent;
4798 if (strEQ(d,"sockname")) return -KEY_getsockname;
4799 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
4801 else if (*d == 'g') {
4802 if (strEQ(d,"grent")) return -KEY_getgrent;
4803 if (strEQ(d,"grnam")) return -KEY_getgrnam;
4804 if (strEQ(d,"grgid")) return -KEY_getgrgid;
4806 else if (*d == 'l') {
4807 if (strEQ(d,"login")) return -KEY_getlogin;
4809 else if (strEQ(d,"c")) return -KEY_getc;
4814 if (strEQ(d,"gt")) return -KEY_gt;
4815 if (strEQ(d,"ge")) return -KEY_ge;
4818 if (strEQ(d,"grep")) return KEY_grep;
4819 if (strEQ(d,"goto")) return KEY_goto;
4820 if (strEQ(d,"glob")) return KEY_glob;
4823 if (strEQ(d,"gmtime")) return -KEY_gmtime;
4828 if (strEQ(d,"hex")) return -KEY_hex;
4831 if (strEQ(d,"INIT")) return KEY_INIT;
4836 if (strEQ(d,"if")) return KEY_if;
4839 if (strEQ(d,"int")) return -KEY_int;
4842 if (strEQ(d,"index")) return -KEY_index;
4843 if (strEQ(d,"ioctl")) return -KEY_ioctl;
4848 if (strEQ(d,"join")) return -KEY_join;
4852 if (strEQ(d,"keys")) return KEY_keys;
4853 if (strEQ(d,"kill")) return -KEY_kill;
4858 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
4859 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
4865 if (strEQ(d,"lt")) return -KEY_lt;
4866 if (strEQ(d,"le")) return -KEY_le;
4867 if (strEQ(d,"lc")) return -KEY_lc;
4870 if (strEQ(d,"log")) return -KEY_log;
4873 if (strEQ(d,"last")) return KEY_last;
4874 if (strEQ(d,"link")) return -KEY_link;
4875 if (strEQ(d,"lock")) return -KEY_lock;
4878 if (strEQ(d,"local")) return KEY_local;
4879 if (strEQ(d,"lstat")) return -KEY_lstat;
4882 if (strEQ(d,"length")) return -KEY_length;
4883 if (strEQ(d,"listen")) return -KEY_listen;
4886 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
4889 if (strEQ(d,"localtime")) return -KEY_localtime;
4895 case 1: return KEY_m;
4897 if (strEQ(d,"my")) return KEY_my;
4900 if (strEQ(d,"map")) return KEY_map;
4903 if (strEQ(d,"mkdir")) return -KEY_mkdir;
4906 if (strEQ(d,"msgctl")) return -KEY_msgctl;
4907 if (strEQ(d,"msgget")) return -KEY_msgget;
4908 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
4909 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
4914 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
4917 if (strEQ(d,"next")) return KEY_next;
4918 if (strEQ(d,"ne")) return -KEY_ne;
4919 if (strEQ(d,"not")) return -KEY_not;
4920 if (strEQ(d,"no")) return KEY_no;
4925 if (strEQ(d,"or")) return -KEY_or;
4928 if (strEQ(d,"ord")) return -KEY_ord;
4929 if (strEQ(d,"oct")) return -KEY_oct;
4930 if (strEQ(d,"our")) { deprecate("reserved word \"our\"");
4934 if (strEQ(d,"open")) return -KEY_open;
4937 if (strEQ(d,"opendir")) return -KEY_opendir;
4944 if (strEQ(d,"pop")) return KEY_pop;
4945 if (strEQ(d,"pos")) return KEY_pos;
4948 if (strEQ(d,"push")) return KEY_push;
4949 if (strEQ(d,"pack")) return -KEY_pack;
4950 if (strEQ(d,"pipe")) return -KEY_pipe;
4953 if (strEQ(d,"print")) return KEY_print;
4956 if (strEQ(d,"printf")) return KEY_printf;
4959 if (strEQ(d,"package")) return KEY_package;
4962 if (strEQ(d,"prototype")) return KEY_prototype;
4967 if (strEQ(d,"q")) return KEY_q;
4968 if (strEQ(d,"qr")) return KEY_qr;
4969 if (strEQ(d,"qq")) return KEY_qq;
4970 if (strEQ(d,"qw")) return KEY_qw;
4971 if (strEQ(d,"qx")) return KEY_qx;
4973 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
4978 if (strEQ(d,"ref")) return -KEY_ref;
4981 if (strEQ(d,"read")) return -KEY_read;
4982 if (strEQ(d,"rand")) return -KEY_rand;
4983 if (strEQ(d,"recv")) return -KEY_recv;
4984 if (strEQ(d,"redo")) return KEY_redo;
4987 if (strEQ(d,"rmdir")) return -KEY_rmdir;
4988 if (strEQ(d,"reset")) return -KEY_reset;
4991 if (strEQ(d,"return")) return KEY_return;
4992 if (strEQ(d,"rename")) return -KEY_rename;
4993 if (strEQ(d,"rindex")) return -KEY_rindex;
4996 if (strEQ(d,"require")) return -KEY_require;
4997 if (strEQ(d,"reverse")) return -KEY_reverse;
4998 if (strEQ(d,"readdir")) return -KEY_readdir;
5001 if (strEQ(d,"readlink")) return -KEY_readlink;
5002 if (strEQ(d,"readline")) return -KEY_readline;
5003 if (strEQ(d,"readpipe")) return -KEY_readpipe;
5006 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
5012 case 0: return KEY_s;
5014 if (strEQ(d,"scalar")) return KEY_scalar;
5019 if (strEQ(d,"seek")) return -KEY_seek;
5020 if (strEQ(d,"send")) return -KEY_send;
5023 if (strEQ(d,"semop")) return -KEY_semop;
5026 if (strEQ(d,"select")) return -KEY_select;
5027 if (strEQ(d,"semctl")) return -KEY_semctl;
5028 if (strEQ(d,"semget")) return -KEY_semget;
5031 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
5032 if (strEQ(d,"seekdir")) return -KEY_seekdir;
5035 if (strEQ(d,"setpwent")) return -KEY_setpwent;
5036 if (strEQ(d,"setgrent")) return -KEY_setgrent;
5039 if (strEQ(d,"setnetent")) return -KEY_setnetent;
5042 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
5043 if (strEQ(d,"sethostent")) return -KEY_sethostent;
5044 if (strEQ(d,"setservent")) return -KEY_setservent;
5047 if (strEQ(d,"setpriority")) return -KEY_setpriority;
5048 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
5055 if (strEQ(d,"shift")) return KEY_shift;
5058 if (strEQ(d,"shmctl")) return -KEY_shmctl;
5059 if (strEQ(d,"shmget")) return -KEY_shmget;
5062 if (strEQ(d,"shmread")) return -KEY_shmread;
5065 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
5066 if (strEQ(d,"shutdown")) return -KEY_shutdown;
5071 if (strEQ(d,"sin")) return -KEY_sin;
5074 if (strEQ(d,"sleep")) return -KEY_sleep;
5077 if (strEQ(d,"sort")) return KEY_sort;
5078 if (strEQ(d,"socket")) return -KEY_socket;
5079 if (strEQ(d,"socketpair")) return -KEY_socketpair;
5082 if (strEQ(d,"split")) return KEY_split;
5083 if (strEQ(d,"sprintf")) return -KEY_sprintf;
5084 if (strEQ(d,"splice")) return KEY_splice;
5087 if (strEQ(d,"sqrt")) return -KEY_sqrt;
5090 if (strEQ(d,"srand")) return -KEY_srand;
5093 if (strEQ(d,"stat")) return -KEY_stat;
5094 if (strEQ(d,"study")) return KEY_study;
5097 if (strEQ(d,"substr")) return -KEY_substr;
5098 if (strEQ(d,"sub")) return KEY_sub;
5103 if (strEQ(d,"system")) return -KEY_system;
5106 if (strEQ(d,"symlink")) return -KEY_symlink;
5107 if (strEQ(d,"syscall")) return -KEY_syscall;
5108 if (strEQ(d,"sysopen")) return -KEY_sysopen;
5109 if (strEQ(d,"sysread")) return -KEY_sysread;
5110 if (strEQ(d,"sysseek")) return -KEY_sysseek;
5113 if (strEQ(d,"syswrite")) return -KEY_syswrite;
5122 if (strEQ(d,"tr")) return KEY_tr;
5125 if (strEQ(d,"tie")) return KEY_tie;
5128 if (strEQ(d,"tell")) return -KEY_tell;
5129 if (strEQ(d,"tied")) return KEY_tied;
5130 if (strEQ(d,"time")) return -KEY_time;
5133 if (strEQ(d,"times")) return -KEY_times;
5136 if (strEQ(d,"telldir")) return -KEY_telldir;
5139 if (strEQ(d,"truncate")) return -KEY_truncate;
5146 if (strEQ(d,"uc")) return -KEY_uc;
5149 if (strEQ(d,"use")) return KEY_use;
5152 if (strEQ(d,"undef")) return KEY_undef;
5153 if (strEQ(d,"until")) return KEY_until;
5154 if (strEQ(d,"untie")) return KEY_untie;
5155 if (strEQ(d,"utime")) return -KEY_utime;
5156 if (strEQ(d,"umask")) return -KEY_umask;
5159 if (strEQ(d,"unless")) return KEY_unless;
5160 if (strEQ(d,"unpack")) return -KEY_unpack;
5161 if (strEQ(d,"unlink")) return -KEY_unlink;
5164 if (strEQ(d,"unshift")) return KEY_unshift;
5165 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
5170 if (strEQ(d,"values")) return -KEY_values;
5171 if (strEQ(d,"vec")) return -KEY_vec;
5176 if (strEQ(d,"warn")) return -KEY_warn;
5177 if (strEQ(d,"wait")) return -KEY_wait;
5180 if (strEQ(d,"while")) return KEY_while;
5181 if (strEQ(d,"write")) return -KEY_write;
5184 if (strEQ(d,"waitpid")) return -KEY_waitpid;
5187 if (strEQ(d,"wantarray")) return -KEY_wantarray;
5192 if (len == 1) return -KEY_x;
5193 if (strEQ(d,"xor")) return -KEY_xor;
5196 if (len == 1) return KEY_y;
5205 S_checkcomma(pTHX_ register char *s, char *name, char *what)
5209 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
5210 dTHR; /* only for ckWARN */
5211 if (ckWARN(WARN_SYNTAX)) {
5213 for (w = s+2; *w && level; w++) {
5220 for (; *w && isSPACE(*w); w++) ;
5221 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
5222 Perl_warner(aTHX_ WARN_SYNTAX, "%s (...) interpreted as function",name);
5225 while (s < PL_bufend && isSPACE(*s))
5229 while (s < PL_bufend && isSPACE(*s))
5231 if (isIDFIRST_lazy(s)) {
5233 while (isALNUM_lazy(s))
5235 while (s < PL_bufend && isSPACE(*s))
5240 kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
5244 Perl_croak(aTHX_ "No comma allowed after %s", what);
5250 S_new_constant(pTHX_ char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)
5253 HV *table = GvHV(PL_hintgv); /* ^H */
5256 bool oldcatch = CATCH_GET;
5261 yyerror("%^H is not defined");
5264 cvp = hv_fetch(table, key, strlen(key), FALSE);
5265 if (!cvp || !SvOK(*cvp)) {
5267 sprintf(buf,"$^H{%s} is not defined", key);
5271 sv_2mortal(sv); /* Parent created it permanently */
5274 pv = sv_2mortal(newSVpvn(s, len));
5276 typesv = sv_2mortal(newSVpv(type, 0));
5278 typesv = &PL_sv_undef;
5280 Zero(&myop, 1, BINOP);
5281 myop.op_last = (OP *) &myop;
5282 myop.op_next = Nullop;
5283 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
5285 PUSHSTACKi(PERLSI_OVERLOAD);
5288 PL_op = (OP *) &myop;
5289 if (PERLDB_SUB && PL_curstash != PL_debstash)
5290 PL_op->op_private |= OPpENTERSUB_DB;
5292 Perl_pp_pushmark(aTHX);
5301 if (PL_op = Perl_pp_entersub(aTHX))
5308 CATCH_SET(oldcatch);
5313 sprintf(buf,"Call to &{$^H{%s}} did not return a defined value", key);
5316 return SvREFCNT_inc(res);
5320 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
5322 register char *d = dest;
5323 register char *e = d + destlen - 3; /* two-character token, ending NUL */
5326 Perl_croak(aTHX_ ident_too_long);
5327 if (isALNUM(*s)) /* UTF handled below */
5329 else if (*s == '\'' && allow_package && isIDFIRST_lazy(s+1)) {
5334 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
5338 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5339 char *t = s + UTF8SKIP(s);
5340 while (*t & 0x80 && is_utf8_mark((U8*)t))
5342 if (d + (t - s) > e)
5343 Perl_croak(aTHX_ ident_too_long);
5344 Copy(s, d, t - s, char);
5357 S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
5364 if (PL_lex_brackets == 0)
5365 PL_lex_fakebrack = 0;
5369 e = d + destlen - 3; /* two-character token, ending NUL */
5371 while (isDIGIT(*s)) {
5373 Perl_croak(aTHX_ ident_too_long);
5380 Perl_croak(aTHX_ ident_too_long);
5381 if (isALNUM(*s)) /* UTF handled below */
5383 else if (*s == '\'' && isIDFIRST_lazy(s+1)) {
5388 else if (*s == ':' && s[1] == ':') {
5392 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5393 char *t = s + UTF8SKIP(s);
5394 while (*t & 0x80 && is_utf8_mark((U8*)t))
5396 if (d + (t - s) > e)
5397 Perl_croak(aTHX_ ident_too_long);
5398 Copy(s, d, t - s, char);
5409 if (PL_lex_state != LEX_NORMAL)
5410 PL_lex_state = LEX_INTERPENDMAYBE;
5413 if (*s == '$' && s[1] &&
5414 (isALNUM_lazy(s+1) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
5427 if (*d == '^' && *s && isCONTROLVAR(*s)) {
5432 if (isSPACE(s[-1])) {
5435 if (ch != ' ' && ch != '\t') {
5441 if (isIDFIRST_lazy(d)) {
5445 while (e < send && isALNUM_lazy(e) || *e == ':') {
5447 while (e < send && *e & 0x80 && is_utf8_mark((U8*)e))
5450 Copy(s, d, e - s, char);
5455 while ((isALNUM(*s) || *s == ':') && d < e)
5458 Perl_croak(aTHX_ ident_too_long);
5461 while (s < send && (*s == ' ' || *s == '\t')) s++;
5462 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
5463 dTHR; /* only for ckWARN */
5464 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
5465 char *brack = *s == '[' ? "[...]" : "{...}";
5466 Perl_warner(aTHX_ WARN_AMBIGUOUS,
5467 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
5468 funny, dest, brack, funny, dest, brack);
5470 PL_lex_fakebrack = PL_lex_brackets+1;
5472 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5476 /* Handle extended ${^Foo} variables
5477 * 1999-02-27 mjd-perl-patch@plover.com */
5478 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
5482 while (isALNUM(*s) && d < e) {
5486 Perl_croak(aTHX_ ident_too_long);
5491 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
5492 PL_lex_state = LEX_INTERPEND;
5495 if (PL_lex_state == LEX_NORMAL) {
5496 dTHR; /* only for ckWARN */
5497 if (ckWARN(WARN_AMBIGUOUS) &&
5498 (keyword(dest, d - dest) || get_cv(dest, FALSE)))
5500 Perl_warner(aTHX_ WARN_AMBIGUOUS,
5501 "Ambiguous use of %c{%s} resolved to %c%s",
5502 funny, dest, funny, dest);
5507 s = bracket; /* let the parser handle it */
5511 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
5512 PL_lex_state = LEX_INTERPEND;
5517 Perl_pmflag(pTHX_ U16 *pmfl, int ch)
5522 *pmfl |= PMf_GLOBAL;
5524 *pmfl |= PMf_CONTINUE;
5528 *pmfl |= PMf_MULTILINE;
5530 *pmfl |= PMf_SINGLELINE;
5532 *pmfl |= PMf_EXTENDED;
5536 S_scan_pat(pTHX_ char *start, I32 type)
5541 s = scan_str(start);
5544 SvREFCNT_dec(PL_lex_stuff);
5545 PL_lex_stuff = Nullsv;
5546 Perl_croak(aTHX_ "Search pattern not terminated");
5549 pm = (PMOP*)newPMOP(type, 0);
5550 if (PL_multi_open == '?')
5551 pm->op_pmflags |= PMf_ONCE;
5553 while (*s && strchr("iomsx", *s))
5554 pmflag(&pm->op_pmflags,*s++);
5557 while (*s && strchr("iogcmsx", *s))
5558 pmflag(&pm->op_pmflags,*s++);
5560 pm->op_pmpermflags = pm->op_pmflags;
5562 PL_lex_op = (OP*)pm;
5563 yylval.ival = OP_MATCH;
5568 S_scan_subst(pTHX_ char *start)
5575 yylval.ival = OP_NULL;
5577 s = scan_str(start);
5581 SvREFCNT_dec(PL_lex_stuff);
5582 PL_lex_stuff = Nullsv;
5583 Perl_croak(aTHX_ "Substitution pattern not terminated");
5586 if (s[-1] == PL_multi_open)
5589 first_start = PL_multi_start;
5593 SvREFCNT_dec(PL_lex_stuff);
5594 PL_lex_stuff = Nullsv;
5596 SvREFCNT_dec(PL_lex_repl);
5597 PL_lex_repl = Nullsv;
5598 Perl_croak(aTHX_ "Substitution replacement not terminated");
5600 PL_multi_start = first_start; /* so whole substitution is taken together */
5602 pm = (PMOP*)newPMOP(OP_SUBST, 0);
5608 else if (strchr("iogcmsx", *s))
5609 pmflag(&pm->op_pmflags,*s++);
5616 PL_sublex_info.super_bufptr = s;
5617 PL_sublex_info.super_bufend = PL_bufend;
5619 pm->op_pmflags |= PMf_EVAL;
5620 repl = newSVpvn("",0);
5622 sv_catpv(repl, es ? "eval " : "do ");
5623 sv_catpvn(repl, "{ ", 2);
5624 sv_catsv(repl, PL_lex_repl);
5625 sv_catpvn(repl, " };", 2);
5627 SvREFCNT_dec(PL_lex_repl);
5631 pm->op_pmpermflags = pm->op_pmflags;
5632 PL_lex_op = (OP*)pm;
5633 yylval.ival = OP_SUBST;
5638 S_scan_trans(pTHX_ char *start)
5649 yylval.ival = OP_NULL;
5651 s = scan_str(start);
5654 SvREFCNT_dec(PL_lex_stuff);
5655 PL_lex_stuff = Nullsv;
5656 Perl_croak(aTHX_ "Transliteration pattern not terminated");
5658 if (s[-1] == PL_multi_open)
5664 SvREFCNT_dec(PL_lex_stuff);
5665 PL_lex_stuff = Nullsv;
5667 SvREFCNT_dec(PL_lex_repl);
5668 PL_lex_repl = Nullsv;
5669 Perl_croak(aTHX_ "Transliteration replacement not terminated");
5673 o = newSVOP(OP_TRANS, 0, 0);
5674 utf8 = OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF;
5677 New(803,tbl,256,short);
5678 o = newPVOP(OP_TRANS, 0, (char*)tbl);
5682 complement = del = squash = 0;
5683 while (strchr("cdsCU", *s)) {
5685 complement = OPpTRANS_COMPLEMENT;
5687 del = OPpTRANS_DELETE;
5689 squash = OPpTRANS_SQUASH;
5694 utf8 &= ~OPpTRANS_FROM_UTF;
5696 utf8 |= OPpTRANS_FROM_UTF;
5700 utf8 &= ~OPpTRANS_TO_UTF;
5702 utf8 |= OPpTRANS_TO_UTF;
5705 Perl_croak(aTHX_ "Too many /C and /U options");
5710 o->op_private = del|squash|complement|utf8;
5713 yylval.ival = OP_TRANS;
5718 S_scan_heredoc(pTHX_ register char *s)
5722 I32 op_type = OP_SCALAR;
5729 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
5733 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
5736 for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5737 if (*peek && strchr("`'\"",*peek)) {
5740 s = delimcpy(d, e, s, PL_bufend, term, &len);
5750 if (!isALNUM_lazy(s))
5751 deprecate("bare << to mean <<\"\"");
5752 for (; isALNUM_lazy(s); s++) {
5757 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
5758 Perl_croak(aTHX_ "Delimiter for here document is too long");
5761 len = d - PL_tokenbuf;
5762 #ifndef PERL_STRICT_CR
5763 d = strchr(s, '\r');
5767 while (s < PL_bufend) {
5773 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
5782 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5787 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
5788 herewas = newSVpvn(s,PL_bufend-s);
5790 s--, herewas = newSVpvn(s,d-s);
5791 s += SvCUR(herewas);
5793 tmpstr = NEWSV(87,79);
5794 sv_upgrade(tmpstr, SVt_PVIV);
5799 else if (term == '`') {
5800 op_type = OP_BACKTICK;
5801 SvIVX(tmpstr) = '\\';
5805 PL_multi_start = PL_curcop->cop_line;
5806 PL_multi_open = PL_multi_close = '<';
5807 term = *PL_tokenbuf;
5808 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
5809 char *bufptr = PL_sublex_info.super_bufptr;
5810 char *bufend = PL_sublex_info.super_bufend;
5811 char *olds = s - SvCUR(herewas);
5812 s = strchr(bufptr, '\n');
5816 while (s < bufend &&
5817 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
5819 PL_curcop->cop_line++;
5822 PL_curcop->cop_line = PL_multi_start;
5823 missingterm(PL_tokenbuf);
5825 sv_setpvn(herewas,bufptr,d-bufptr+1);
5826 sv_setpvn(tmpstr,d+1,s-d);
5828 sv_catpvn(herewas,s,bufend-s);
5829 (void)strcpy(bufptr,SvPVX(herewas));
5836 while (s < PL_bufend &&
5837 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
5839 PL_curcop->cop_line++;
5841 if (s >= PL_bufend) {
5842 PL_curcop->cop_line = PL_multi_start;
5843 missingterm(PL_tokenbuf);
5845 sv_setpvn(tmpstr,d+1,s-d);
5847 PL_curcop->cop_line++; /* the preceding stmt passes a newline */
5849 sv_catpvn(herewas,s,PL_bufend-s);
5850 sv_setsv(PL_linestr,herewas);
5851 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
5852 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5855 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
5856 while (s >= PL_bufend) { /* multiple line string? */
5858 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5859 PL_curcop->cop_line = PL_multi_start;
5860 missingterm(PL_tokenbuf);
5862 PL_curcop->cop_line++;
5863 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5864 #ifndef PERL_STRICT_CR
5865 if (PL_bufend - PL_linestart >= 2) {
5866 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
5867 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
5869 PL_bufend[-2] = '\n';
5871 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5873 else if (PL_bufend[-1] == '\r')
5874 PL_bufend[-1] = '\n';
5876 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
5877 PL_bufend[-1] = '\n';
5879 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5880 SV *sv = NEWSV(88,0);
5882 sv_upgrade(sv, SVt_PVMG);
5883 sv_setsv(sv,PL_linestr);
5884 av_store(GvAV(PL_curcop->cop_filegv),
5885 (I32)PL_curcop->cop_line,sv);
5887 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
5890 sv_catsv(PL_linestr,herewas);
5891 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5895 sv_catsv(tmpstr,PL_linestr);
5900 PL_multi_end = PL_curcop->cop_line;
5901 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
5902 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
5903 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
5905 SvREFCNT_dec(herewas);
5906 PL_lex_stuff = tmpstr;
5907 yylval.ival = op_type;
5912 takes: current position in input buffer
5913 returns: new position in input buffer
5914 side-effects: yylval and lex_op are set.
5919 <FH> read from filehandle
5920 <pkg::FH> read from package qualified filehandle
5921 <pkg'FH> read from package qualified filehandle
5922 <$fh> read from filehandle in $fh
5928 S_scan_inputsymbol(pTHX_ char *start)
5930 register char *s = start; /* current position in buffer */
5936 d = PL_tokenbuf; /* start of temp holding space */
5937 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
5938 end = strchr(s, '\n');
5941 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
5943 /* die if we didn't have space for the contents of the <>,
5944 or if it didn't end, or if we see a newline
5947 if (len >= sizeof PL_tokenbuf)
5948 Perl_croak(aTHX_ "Excessively long <> operator");
5950 Perl_croak(aTHX_ "Unterminated <> operator");
5955 Remember, only scalar variables are interpreted as filehandles by
5956 this code. Anything more complex (e.g., <$fh{$num}>) will be
5957 treated as a glob() call.
5958 This code makes use of the fact that except for the $ at the front,
5959 a scalar variable and a filehandle look the same.
5961 if (*d == '$' && d[1]) d++;
5963 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
5964 while (*d && (isALNUM_lazy(d) || *d == '\'' || *d == ':'))
5967 /* If we've tried to read what we allow filehandles to look like, and
5968 there's still text left, then it must be a glob() and not a getline.
5969 Use scan_str to pull out the stuff between the <> and treat it
5970 as nothing more than a string.
5973 if (d - PL_tokenbuf != len) {
5974 yylval.ival = OP_GLOB;
5976 s = scan_str(start);
5978 Perl_croak(aTHX_ "Glob not terminated");
5982 /* we're in a filehandle read situation */
5985 /* turn <> into <ARGV> */
5987 (void)strcpy(d,"ARGV");
5989 /* if <$fh>, create the ops to turn the variable into a
5995 /* try to find it in the pad for this block, otherwise find
5996 add symbol table ops
5998 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
5999 OP *o = newOP(OP_PADSV, 0);
6001 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, o);
6004 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
6005 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
6006 newUNOP(OP_RV2SV, 0,
6007 newGVOP(OP_GV, 0, gv)));
6009 PL_lex_op->op_flags |= OPf_SPECIAL;
6010 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
6011 yylval.ival = OP_NULL;
6014 /* If it's none of the above, it must be a literal filehandle
6015 (<Foo::BAR> or <FOO>) so build a simple readline OP */
6017 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
6018 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
6019 yylval.ival = OP_NULL;
6028 takes: start position in buffer
6029 returns: position to continue reading from buffer
6030 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
6031 updates the read buffer.
6033 This subroutine pulls a string out of the input. It is called for:
6034 q single quotes q(literal text)
6035 ' single quotes 'literal text'
6036 qq double quotes qq(interpolate $here please)
6037 " double quotes "interpolate $here please"
6038 qx backticks qx(/bin/ls -l)
6039 ` backticks `/bin/ls -l`
6040 qw quote words @EXPORT_OK = qw( func() $spam )
6041 m// regexp match m/this/
6042 s/// regexp substitute s/this/that/
6043 tr/// string transliterate tr/this/that/
6044 y/// string transliterate y/this/that/
6045 ($*@) sub prototypes sub foo ($)
6046 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
6048 In most of these cases (all but <>, patterns and transliterate)
6049 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
6050 calls scan_str(). s/// makes yylex() call scan_subst() which calls
6051 scan_str(). tr/// and y/// make yylex() call scan_trans() which
6054 It skips whitespace before the string starts, and treats the first
6055 character as the delimiter. If the delimiter is one of ([{< then
6056 the corresponding "close" character )]}> is used as the closing
6057 delimiter. It allows quoting of delimiters, and if the string has
6058 balanced delimiters ([{<>}]) it allows nesting.
6060 The lexer always reads these strings into lex_stuff, except in the
6061 case of the operators which take *two* arguments (s/// and tr///)
6062 when it checks to see if lex_stuff is full (presumably with the 1st
6063 arg to s or tr) and if so puts the string into lex_repl.
6068 S_scan_str(pTHX_ char *start)
6071 SV *sv; /* scalar value: string */
6072 char *tmps; /* temp string, used for delimiter matching */
6073 register char *s = start; /* current position in the buffer */
6074 register char term; /* terminating character */
6075 register char *to; /* current position in the sv's data */
6076 I32 brackets = 1; /* bracket nesting level */
6078 /* skip space before the delimiter */
6082 /* mark where we are, in case we need to report errors */
6085 /* after skipping whitespace, the next character is the terminator */
6087 /* mark where we are */
6088 PL_multi_start = PL_curcop->cop_line;
6089 PL_multi_open = term;
6091 /* find corresponding closing delimiter */
6092 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
6094 PL_multi_close = term;
6096 /* create a new SV to hold the contents. 87 is leak category, I'm
6097 assuming. 79 is the SV's initial length. What a random number. */
6099 sv_upgrade(sv, SVt_PVIV);
6101 (void)SvPOK_only(sv); /* validate pointer */
6103 /* move past delimiter and try to read a complete string */
6106 /* extend sv if need be */
6107 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
6108 /* set 'to' to the next character in the sv's string */
6109 to = SvPVX(sv)+SvCUR(sv);
6111 /* if open delimiter is the close delimiter read unbridle */
6112 if (PL_multi_open == PL_multi_close) {
6113 for (; s < PL_bufend; s++,to++) {
6114 /* embedded newlines increment the current line number */
6115 if (*s == '\n' && !PL_rsfp)
6116 PL_curcop->cop_line++;
6117 /* handle quoted delimiters */
6118 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
6121 /* any other quotes are simply copied straight through */
6125 /* terminate when run out of buffer (the for() condition), or
6126 have found the terminator */
6127 else if (*s == term)
6133 /* if the terminator isn't the same as the start character (e.g.,
6134 matched brackets), we have to allow more in the quoting, and
6135 be prepared for nested brackets.
6138 /* read until we run out of string, or we find the terminator */
6139 for (; s < PL_bufend; s++,to++) {
6140 /* embedded newlines increment the line count */
6141 if (*s == '\n' && !PL_rsfp)
6142 PL_curcop->cop_line++;
6143 /* backslashes can escape the open or closing characters */
6144 if (*s == '\\' && s+1 < PL_bufend) {
6145 if ((s[1] == PL_multi_open) || (s[1] == PL_multi_close))
6150 /* allow nested opens and closes */
6151 else if (*s == PL_multi_close && --brackets <= 0)
6153 else if (*s == PL_multi_open)
6158 /* terminate the copied string and update the sv's end-of-string */
6160 SvCUR_set(sv, to - SvPVX(sv));
6163 * this next chunk reads more into the buffer if we're not done yet
6166 if (s < PL_bufend) break; /* handle case where we are done yet :-) */
6168 #ifndef PERL_STRICT_CR
6169 if (to - SvPVX(sv) >= 2) {
6170 if ((to[-2] == '\r' && to[-1] == '\n') ||
6171 (to[-2] == '\n' && to[-1] == '\r'))
6175 SvCUR_set(sv, to - SvPVX(sv));
6177 else if (to[-1] == '\r')
6180 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
6184 /* if we're out of file, or a read fails, bail and reset the current
6185 line marker so we can report where the unterminated string began
6188 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6190 PL_curcop->cop_line = PL_multi_start;
6193 /* we read a line, so increment our line counter */
6194 PL_curcop->cop_line++;
6196 /* update debugger info */
6197 if (PERLDB_LINE && PL_curstash != PL_debstash) {
6198 SV *sv = NEWSV(88,0);
6200 sv_upgrade(sv, SVt_PVMG);
6201 sv_setsv(sv,PL_linestr);
6202 av_store(GvAV(PL_curcop->cop_filegv),
6203 (I32)PL_curcop->cop_line, sv);
6206 /* having changed the buffer, we must update PL_bufend */
6207 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6210 /* at this point, we have successfully read the delimited string */
6212 PL_multi_end = PL_curcop->cop_line;
6215 /* if we allocated too much space, give some back */
6216 if (SvCUR(sv) + 5 < SvLEN(sv)) {
6217 SvLEN_set(sv, SvCUR(sv) + 1);
6218 Renew(SvPVX(sv), SvLEN(sv), char);
6221 /* decide whether this is the first or second quoted string we've read
6234 takes: pointer to position in buffer
6235 returns: pointer to new position in buffer
6236 side-effects: builds ops for the constant in yylval.op
6238 Read a number in any of the formats that Perl accepts:
6240 0(x[0-7A-F]+)|([0-7]+)|(b[01])
6241 [\d_]+(\.[\d_]*)?[Ee](\d+)
6243 Underbars (_) are allowed in decimal numbers. If -w is on,
6244 underbars before a decimal point must be at three digit intervals.
6246 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
6249 If it reads a number without a decimal point or an exponent, it will
6250 try converting the number to an integer and see if it can do so
6251 without loss of precision.
6255 Perl_scan_num(pTHX_ char *start)
6257 register char *s = start; /* current position in buffer */
6258 register char *d; /* destination in temp buffer */
6259 register char *e; /* end of temp buffer */
6260 IV tryiv; /* used to see if it can be an IV */
6261 NV value; /* number read, as a double */
6262 SV *sv; /* place to put the converted number */
6263 bool floatit; /* boolean: int or float? */
6264 char *lastub = 0; /* position of last underbar */
6265 static char number_too_long[] = "Number too long";
6267 /* We use the first character to decide what type of number this is */
6271 Perl_croak(aTHX_ "panic: scan_num");
6273 /* if it starts with a 0, it could be an octal number, a decimal in
6274 0.13 disguise, or a hexadecimal number, or a binary number.
6279 u holds the "number so far"
6280 shift the power of 2 of the base
6281 (hex == 4, octal == 3, binary == 1)
6282 overflowed was the number more than we can hold?
6284 Shift is used when we add a digit. It also serves as an "are
6285 we in octal/hex/binary?" indicator to disallow hex characters
6292 bool overflowed = FALSE;
6293 static NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
6294 static char* bases[5] = { "", "binary", "", "octal",
6296 static char* Bases[5] = { "", "Binary", "", "Octal",
6298 static char *maxima[5] = { "",
6299 "0b11111111111111111111111111111111",
6303 char *base, *Base, *max;
6309 } else if (s[1] == 'b') {
6313 /* check for a decimal in disguise */
6314 else if (s[1] == '.')
6316 /* so it must be octal */
6320 base = bases[shift];
6321 Base = Bases[shift];
6322 max = maxima[shift];
6324 /* read the rest of the number */
6326 /* x is used in the overflow test,
6327 b is the digit we're adding on. */
6332 /* if we don't mention it, we're done */
6341 /* 8 and 9 are not octal */
6344 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
6347 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
6351 case '2': case '3': case '4':
6352 case '5': case '6': case '7':
6354 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
6358 b = *s++ & 15; /* ASCII digit -> value of digit */
6362 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
6363 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
6364 /* make sure they said 0x */
6369 /* Prepare to put the digit we have onto the end
6370 of the number so far. We check for overflows.
6375 x = u << shift; /* make room for the digit */
6377 if ((x >> shift) != u
6378 && !(PL_hints & HINT_NEW_BINARY)) {
6382 if (ckWARN_d(WARN_UNSAFE))
6383 Perl_warner(aTHX_ ((shift == 3) ?
6384 WARN_OCTAL : WARN_UNSAFE),
6385 "Integer overflow in %s number",
6388 u = x | b; /* add the digit to the end */
6391 n *= nvshift[shift];
6392 /* If an NV has not enough bits in its
6393 * mantissa to represent an UV this summing of
6394 * small low-order numbers is a waste of time
6395 * (because the NV cannot preserve the
6396 * low-order bits anyway): we could just
6397 * remember when did we overflow and in the
6398 * end just multiply n by the right
6406 /* if we get here, we had success: make a scalar value from
6413 if (ckWARN(WARN_UNSAFE) && n > 4294967295.0)
6414 Perl_warner(aTHX_ WARN_UNSAFE,
6415 "%s number > %s non-portable",
6422 if (ckWARN(WARN_UNSAFE) && u > 0xffffffff)
6423 Perl_warner(aTHX_ WARN_UNSAFE,
6424 "%s number > %s non-portable",
6429 if (PL_hints & HINT_NEW_BINARY)
6430 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
6435 handle decimal numbers.
6436 we're also sent here when we read a 0 as the first digit
6438 case '1': case '2': case '3': case '4': case '5':
6439 case '6': case '7': case '8': case '9': case '.':
6442 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
6445 /* read next group of digits and _ and copy into d */
6446 while (isDIGIT(*s) || *s == '_') {
6447 /* skip underscores, checking for misplaced ones
6451 dTHR; /* only for ckWARN */
6452 if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
6453 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
6457 /* check for end of fixed-length buffer */
6459 Perl_croak(aTHX_ number_too_long);
6460 /* if we're ok, copy the character */
6465 /* final misplaced underbar check */
6466 if (lastub && s - lastub != 3) {
6468 if (ckWARN(WARN_SYNTAX))
6469 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
6472 /* read a decimal portion if there is one. avoid
6473 3..5 being interpreted as the number 3. followed
6476 if (*s == '.' && s[1] != '.') {
6480 /* copy, ignoring underbars, until we run out of
6481 digits. Note: no misplaced underbar checks!
6483 for (; isDIGIT(*s) || *s == '_'; s++) {
6484 /* fixed length buffer check */
6486 Perl_croak(aTHX_ number_too_long);
6492 /* read exponent part, if present */
6493 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
6497 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
6498 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
6500 /* allow positive or negative exponent */
6501 if (*s == '+' || *s == '-')
6504 /* read digits of exponent (no underbars :-) */
6505 while (isDIGIT(*s)) {
6507 Perl_croak(aTHX_ number_too_long);
6512 /* terminate the string */
6515 /* make an sv from the string */
6518 value = Atof(PL_tokenbuf);
6521 See if we can make do with an integer value without loss of
6522 precision. We use I_V to cast to an int, because some
6523 compilers have issues. Then we try casting it back and see
6524 if it was the same. We only do this if we know we
6525 specifically read an integer.
6527 Note: if floatit is true, then we don't need to do the
6531 if (!floatit && (NV)tryiv == value)
6532 sv_setiv(sv, tryiv);
6534 sv_setnv(sv, value);
6535 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
6536 (PL_hints & HINT_NEW_INTEGER) )
6537 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
6538 (floatit ? "float" : "integer"),
6543 /* make the op for the constant and return */
6545 yylval.opval = newSVOP(OP_CONST, 0, sv);
6551 S_scan_formline(pTHX_ register char *s)
6556 SV *stuff = newSVpvn("",0);
6557 bool needargs = FALSE;
6560 if (*s == '.' || *s == '}') {
6562 #ifdef PERL_STRICT_CR
6563 for (t = s+1;*t == ' ' || *t == '\t'; t++) ;
6565 for (t = s+1;*t == ' ' || *t == '\t' || *t == '\r'; t++) ;
6567 if (*t == '\n' || t == PL_bufend)
6570 if (PL_in_eval && !PL_rsfp) {
6571 eol = strchr(s,'\n');
6576 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6578 for (t = s; t < eol; t++) {
6579 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
6581 goto enough; /* ~~ must be first line in formline */
6583 if (*t == '@' || *t == '^')
6586 sv_catpvn(stuff, s, eol-s);
6590 s = filter_gets(PL_linestr, PL_rsfp, 0);
6591 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
6592 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
6595 yyerror("Format not terminated");
6605 PL_lex_state = LEX_NORMAL;
6606 PL_nextval[PL_nexttoke].ival = 0;
6610 PL_lex_state = LEX_FORMLINE;
6611 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
6613 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
6617 SvREFCNT_dec(stuff);
6618 PL_lex_formbrack = 0;
6629 PL_cshlen = strlen(PL_cshname);
6634 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
6637 I32 oldsavestack_ix = PL_savestack_ix;
6638 CV* outsidecv = PL_compcv;
6642 assert(SvTYPE(PL_compcv) == SVt_PVCV);
6644 save_I32(&PL_subline);
6645 save_item(PL_subname);
6647 SAVESPTR(PL_curpad);
6648 SAVESPTR(PL_comppad);
6649 SAVESPTR(PL_comppad_name);
6650 SAVESPTR(PL_compcv);
6651 SAVEI32(PL_comppad_name_fill);
6652 SAVEI32(PL_min_intro_pending);
6653 SAVEI32(PL_max_intro_pending);
6654 SAVEI32(PL_pad_reset_pending);
6656 PL_compcv = (CV*)NEWSV(1104,0);
6657 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
6658 CvFLAGS(PL_compcv) |= flags;
6660 PL_comppad = newAV();
6661 av_push(PL_comppad, Nullsv);
6662 PL_curpad = AvARRAY(PL_comppad);
6663 PL_comppad_name = newAV();
6664 PL_comppad_name_fill = 0;
6665 PL_min_intro_pending = 0;
6667 PL_subline = PL_curcop->cop_line;
6669 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
6670 PL_curpad[0] = (SV*)newAV();
6671 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
6672 #endif /* USE_THREADS */
6674 comppadlist = newAV();
6675 AvREAL_off(comppadlist);
6676 av_store(comppadlist, 0, (SV*)PL_comppad_name);
6677 av_store(comppadlist, 1, (SV*)PL_comppad);
6679 CvPADLIST(PL_compcv) = comppadlist;
6680 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
6682 CvOWNER(PL_compcv) = 0;
6683 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
6684 MUTEX_INIT(CvMUTEXP(PL_compcv));
6685 #endif /* USE_THREADS */
6687 return oldsavestack_ix;
6691 Perl_yywarn(pTHX_ char *s)
6695 PL_in_eval |= EVAL_WARNONLY;
6697 PL_in_eval &= ~EVAL_WARNONLY;
6702 Perl_yyerror(pTHX_ char *s)
6706 char *context = NULL;
6710 if (!yychar || (yychar == ';' && !PL_rsfp))
6712 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
6713 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
6714 while (isSPACE(*PL_oldoldbufptr))
6716 context = PL_oldoldbufptr;
6717 contlen = PL_bufptr - PL_oldoldbufptr;
6719 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
6720 PL_oldbufptr != PL_bufptr) {
6721 while (isSPACE(*PL_oldbufptr))
6723 context = PL_oldbufptr;
6724 contlen = PL_bufptr - PL_oldbufptr;
6726 else if (yychar > 255)
6727 where = "next token ???";
6728 else if ((yychar & 127) == 127) {
6729 if (PL_lex_state == LEX_NORMAL ||
6730 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
6731 where = "at end of line";
6732 else if (PL_lex_inpat)
6733 where = "within pattern";
6735 where = "within string";
6738 SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
6740 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
6741 else if (isPRINT_LC(yychar))
6742 Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
6744 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
6745 where = SvPVX(where_sv);
6747 msg = sv_2mortal(newSVpv(s, 0));
6748 Perl_sv_catpvf(aTHX_ msg, " at %_ line %ld, ",
6749 GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line);
6751 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
6753 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
6754 if (PL_multi_start < PL_multi_end && (U32)(PL_curcop->cop_line - PL_multi_end) <= 1) {
6755 Perl_sv_catpvf(aTHX_ msg,
6756 " (Might be a runaway multi-line %c%c string starting on line %ld)\n",
6757 (int)PL_multi_open,(int)PL_multi_close,(long)PL_multi_start);
6760 if (PL_in_eval & EVAL_WARNONLY)
6761 Perl_warn(aTHX_ "%_", msg);
6762 else if (PL_in_eval)
6763 sv_catsv(ERRSV, msg);
6765 PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
6766 if (++PL_error_count >= 10)
6767 Perl_croak(aTHX_ "%_ has too many errors.\n", GvSV(PL_curcop->cop_filegv));
6769 PL_in_my_stash = Nullhv;
6781 * Restore a source filter.
6785 restore_rsfp(pTHXo_ void *f)
6787 PerlIO *fp = (PerlIO*)f;
6789 if (PL_rsfp == PerlIO_stdin())
6790 PerlIO_clearerr(PL_rsfp);
6791 else if (PL_rsfp && (PL_rsfp != fp))
6792 PerlIO_close(PL_rsfp);
6798 * Restores the state of PL_expect when the lexing that begun with a
6799 * start_lex() call has ended.
6803 restore_expect(pTHXo_ void *e)
6805 /* a safe way to store a small integer in a pointer */
6806 PL_expect = (expectation)((char *)e - PL_tokenbuf);
6810 * restore_lex_expect
6811 * Restores the state of PL_lex_expect when the lexing that begun with a
6812 * start_lex() call has ended.
6816 restore_lex_expect(pTHXo_ void *e)
6818 /* a safe way to store a small integer in a pointer */
6819 PL_lex_expect = (expectation)((char *)e - PL_tokenbuf);