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
16 * This file is the tokenizer for Perl. It's closely linked to the
19 * The main routine is yylex(), which returns the next token.
23 #define PERL_IN_TOKE_C
26 #define yychar PL_yychar
27 #define yylval PL_yylval
29 static char ident_too_long[] = "Identifier too long";
31 static void restore_rsfp(pTHXo_ void *f);
32 static void restore_expect(pTHXo_ void *e);
33 static void restore_lex_expect(pTHXo_ void *e);
35 #define UTF (PL_hints & HINT_UTF8)
37 * Note: we try to be careful never to call the isXXX_utf8() functions
38 * unless we're pretty sure we've seen the beginning of a UTF-8 character
39 * (that is, the two high bits are set). Otherwise we risk loading in the
40 * heavy-duty SWASHINIT and SWASHGET routines unnecessarily.
42 #define isIDFIRST_lazy(p) ((!UTF || (*((U8*)p) < 0xc0)) \
44 : isIDFIRST_utf8((U8*)p))
45 #define isALNUM_lazy(p) ((!UTF || (*((U8*)p) < 0xc0)) \
47 : isALNUM_utf8((U8*)p))
49 /* In variables name $^X, these are the legal values for X.
50 * 1999-02-27 mjd-perl-patch@plover.com */
51 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
53 /* LEX_* are values for PL_lex_state, the state of the lexer.
54 * They are arranged oddly so that the guard on the switch statement
55 * can get by with a single comparison (if the compiler is smart enough).
58 /* #define LEX_NOTPARSING 11 is done in perl.h. */
61 #define LEX_INTERPNORMAL 9
62 #define LEX_INTERPCASEMOD 8
63 #define LEX_INTERPPUSH 7
64 #define LEX_INTERPSTART 6
65 #define LEX_INTERPEND 5
66 #define LEX_INTERPENDMAYBE 4
67 #define LEX_INTERPCONCAT 3
68 #define LEX_INTERPCONST 2
69 #define LEX_FORMLINE 1
70 #define LEX_KNOWNEXT 0
79 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
81 # include <unistd.h> /* Needed for execv() */
90 YYSTYPE* yylval_pointer = NULL;
91 int* yychar_pointer = NULL;
94 # define yylval (*yylval_pointer)
95 # define yychar (*yychar_pointer)
96 # define PERL_YYLEX_PARAM yylval_pointer,yychar_pointer
98 # define yylex() Perl_yylex(aTHX_ yylval_pointer, yychar_pointer)
101 #include "keywords.h"
103 /* CLINE is a macro that ensures PL_copline has a sane value */
108 #define CLINE (PL_copline = (PL_curcop->cop_line < PL_copline ? PL_curcop->cop_line : PL_copline))
111 * Convenience functions to return different tokens and prime the
112 * tokenizer for the next token. They all take an argument.
114 * TOKEN : generic token (used for '(', DOLSHARP, etc)
115 * OPERATOR : generic operator
116 * AOPERATOR : assignment operator
117 * PREBLOCK : beginning the block after an if, while, foreach, ...
118 * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
119 * PREREF : *EXPR where EXPR is not a simple identifier
120 * TERM : expression term
121 * LOOPX : loop exiting command (goto, last, dump, etc)
122 * FTST : file test operator
123 * FUN0 : zero-argument function
125 * BOop : bitwise or or xor
127 * SHop : shift operator
128 * PWop : power operator
129 * PMop : matching operator
130 * Aop : addition-level operator
131 * Mop : multiplication-level operator
132 * Eop : equality-testing operator
133 * Rop : relational operator <= != gt
135 * Also see LOP and lop() below.
138 #define TOKEN(retval) return (PL_bufptr = s,(int)retval)
139 #define OPERATOR(retval) return (PL_expect = XTERM,PL_bufptr = s,(int)retval)
140 #define AOPERATOR(retval) return ao((PL_expect = XTERM,PL_bufptr = s,(int)retval))
141 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s,(int)retval)
142 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval)
143 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s,(int)retval)
144 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR,PL_bufptr = s,(int)retval)
145 #define LOOPX(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX)
146 #define FTST(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)UNIOP)
147 #define FUN0(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0)
148 #define FUN1(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1)
149 #define BOop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITOROP))
150 #define BAop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP))
151 #define SHop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP))
152 #define PWop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)POWOP))
153 #define PMop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP)
154 #define Aop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)ADDOP))
155 #define Mop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MULOP))
156 #define Eop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)EQOP)
157 #define Rop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)RELOP)
159 /* This bit of chicanery makes a unary function followed by
160 * a parenthesis into a function with one argument, highest precedence.
162 #define UNI(f) return(yylval.ival = f, \
165 PL_last_uni = PL_oldbufptr, \
166 PL_last_lop_op = f, \
167 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
169 #define UNIBRACK(f) return(yylval.ival = f, \
171 PL_last_uni = PL_oldbufptr, \
172 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
174 /* grandfather return to old style */
175 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
180 * This subroutine detects &&= and ||= and turns an ANDAND or OROR
181 * into an OP_ANDASSIGN or OP_ORASSIGN
185 S_ao(pTHX_ int toketype)
187 if (*PL_bufptr == '=') {
189 if (toketype == ANDAND)
190 yylval.ival = OP_ANDASSIGN;
191 else if (toketype == OROR)
192 yylval.ival = OP_ORASSIGN;
200 * When Perl expects an operator and finds something else, no_op
201 * prints the warning. It always prints "<something> found where
202 * operator expected. It prints "Missing semicolon on previous line?"
203 * if the surprise occurs at the start of the line. "do you need to
204 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
205 * where the compiler doesn't know if foo is a method call or a function.
206 * It prints "Missing operator before end of line" if there's nothing
207 * after the missing operator, or "... before <...>" if there is something
208 * after the missing operator.
212 S_no_op(pTHX_ char *what, char *s)
214 char *oldbp = PL_bufptr;
215 bool is_first = (PL_oldbufptr == PL_linestart);
219 yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
221 Perl_warn(aTHX_ "\t(Missing semicolon on previous line?)\n");
222 else if (PL_oldoldbufptr && isIDFIRST_lazy(PL_oldoldbufptr)) {
224 for (t = PL_oldoldbufptr; *t && (isALNUM_lazy(t) || *t == ':'); t++) ;
225 if (t < PL_bufptr && isSPACE(*t))
226 Perl_warn(aTHX_ "\t(Do you need to predeclare %.*s?)\n",
227 t - PL_oldoldbufptr, PL_oldoldbufptr);
230 Perl_warn(aTHX_ "\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
236 * Complain about missing quote/regexp/heredoc terminator.
237 * If it's called with (char *)NULL then it cauterizes the line buffer.
238 * If we're in a delimited string and the delimiter is a control
239 * character, it's reformatted into a two-char sequence like ^C.
244 S_missingterm(pTHX_ char *s)
249 char *nl = strrchr(s,'\n');
255 iscntrl(PL_multi_close)
257 PL_multi_close < 32 || PL_multi_close == 127
261 tmpbuf[1] = toCTRL(PL_multi_close);
267 *tmpbuf = PL_multi_close;
271 q = strchr(s,'"') ? '\'' : '"';
272 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
277 * Warns that something is deprecated. Duh.
281 Perl_deprecate(pTHX_ char *s)
284 if (ckWARN(WARN_DEPRECATED))
285 Perl_warner(aTHX_ WARN_DEPRECATED, "Use of %s is deprecated", s);
290 * Deprecate a comma-less variable list. Called from three places
297 deprecate("comma-less variable list");
301 * text filters for win32 carriage-returns, utf16-to-utf8 and
302 * utf16-to-utf8-reversed, whatever that is.
308 S_win32_textfilter(pTHX_ int idx, SV *sv, int maxlen)
310 I32 count = FILTER_READ(idx+1, sv, maxlen);
311 if (count > 0 && !maxlen)
312 win32_strip_return(sv);
318 S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
320 I32 count = FILTER_READ(idx+1, sv, maxlen);
324 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
325 tend = utf16_to_utf8((U16*)SvPVX(sv), tmps, SvCUR(sv));
326 sv_usepvn(sv, (char*)tmps, tend - tmps);
333 S_utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
335 I32 count = FILTER_READ(idx+1, sv, maxlen);
339 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
340 tend = utf16_to_utf8_reversed((U16*)SvPVX(sv), tmps, SvCUR(sv));
341 sv_usepvn(sv, (char*)tmps, tend - tmps);
349 * Initialize variables. Called by perl.c. It uses the Perl stack
350 * to save its state (for recursive calls to the parser).
354 Perl_lex_start(pTHX_ SV *line)
360 SAVEI32(PL_lex_dojoin);
361 SAVEI32(PL_lex_brackets);
362 SAVEI32(PL_lex_fakebrack);
363 SAVEI32(PL_lex_casemods);
364 SAVEI32(PL_lex_starts);
365 SAVEI32(PL_lex_state);
366 SAVESPTR(PL_lex_inpat);
367 SAVEI32(PL_lex_inwhat);
368 SAVEI16(PL_curcop->cop_line);
371 SAVEPPTR(PL_oldbufptr);
372 SAVEPPTR(PL_oldoldbufptr);
373 SAVEPPTR(PL_linestart);
374 SAVESPTR(PL_linestr);
375 SAVEPPTR(PL_lex_brackstack);
376 SAVEPPTR(PL_lex_casestack);
377 SAVEDESTRUCTOR(restore_rsfp, PL_rsfp);
378 SAVESPTR(PL_lex_stuff);
379 SAVEI32(PL_lex_defer);
380 SAVESPTR(PL_lex_repl);
381 SAVEDESTRUCTOR(restore_expect, PL_tokenbuf + PL_expect); /* encode as pointer */
382 SAVEDESTRUCTOR(restore_lex_expect, PL_tokenbuf + PL_expect);
384 PL_lex_state = LEX_NORMAL;
388 PL_lex_fakebrack = 0;
389 New(899, PL_lex_brackstack, 120, char);
390 New(899, PL_lex_casestack, 12, char);
391 SAVEFREEPV(PL_lex_brackstack);
392 SAVEFREEPV(PL_lex_casestack);
394 *PL_lex_casestack = '\0';
397 PL_lex_stuff = Nullsv;
398 PL_lex_repl = Nullsv;
402 if (SvREADONLY(PL_linestr))
403 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
404 s = SvPV(PL_linestr, len);
405 if (len && s[len-1] != ';') {
406 if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
407 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
408 sv_catpvn(PL_linestr, "\n;", 2);
410 SvTEMP_off(PL_linestr);
411 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
412 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
414 PL_rs = newSVpvn("\n", 1);
420 * Tidy up. Called from pp_ctl.c in the sv_compile_2op(), doeval(),
421 * and pp_leaveeval() subroutines.
427 PL_doextract = FALSE;
432 * This subroutine has nothing to do with tilting, whether at windmills
433 * or pinball tables. Its name is short for "increment line". It
434 * increments the current line number in PL_curcop->cop_line and checks
435 * to see whether the line starts with a comment of the form
437 * If so, it sets the current line number to the number in the comment.
441 S_incline(pTHX_ char *s)
449 PL_curcop->cop_line++;
452 while (*s == ' ' || *s == '\t') s++;
453 if (strnEQ(s, "line ", 5)) {
462 while (*s == ' ' || *s == '\t')
464 if (*s == '"' && (t = strchr(s+1, '"')))
468 return; /* false alarm */
469 for (t = s; !isSPACE(*t); t++) ;
474 PL_curcop->cop_filegv = gv_fetchfile(s);
476 PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
478 PL_curcop->cop_line = atoi(n)-1;
483 * Called to gobble the appropriate amount and type of whitespace.
484 * Skips comments as well.
488 S_skipspace(pTHX_ register char *s)
491 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
492 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
498 while (s < PL_bufend && isSPACE(*s)) {
499 if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
504 if (s < PL_bufend && *s == '#') {
505 while (s < PL_bufend && *s != '\n')
509 if (PL_in_eval && !PL_rsfp) {
516 /* only continue to recharge the buffer if we're at the end
517 * of the buffer, we're not reading from a source filter, and
518 * we're in normal lexing mode
520 if (s < PL_bufend || !PL_rsfp || PL_lex_state != LEX_NORMAL)
523 /* try to recharge the buffer */
524 if ((s = filter_gets(PL_linestr, PL_rsfp, (prevlen = SvCUR(PL_linestr)))) == Nullch) {
525 /* end of file. Add on the -p or -n magic */
526 if (PL_minus_n || PL_minus_p) {
527 sv_setpv(PL_linestr,PL_minus_p ?
528 ";}continue{print or die qq(-p destination: $!\\n)" :
530 sv_catpv(PL_linestr,";}");
531 PL_minus_n = PL_minus_p = 0;
534 sv_setpv(PL_linestr,";");
536 /* reset variables for next time we lex */
537 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
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 tokenizer 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 make the current token be the next one. It will also set
679 * PL_nextval, and possibly PL_expect to ensure the lexer handles the
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" tokenizer 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 tokenizer 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 (through the gv_fetchpv
752 S_force_ident(pTHX_ register char *s, int kind)
755 OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
756 PL_nextval[PL_nexttoke].opval = o;
759 dTHR; /* just for in_eval */
760 o->op_private = OPpCONST_ENTERED;
761 /* XXX see note in pp_entereval() for why we forgo typo
762 warnings if the symbol must be introduced in an eval.
764 gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
765 kind == '$' ? SVt_PV :
766 kind == '@' ? SVt_PVAV :
767 kind == '%' ? SVt_PVHV :
776 * Forces the next token to be a version number.
780 S_force_version(pTHX_ char *s)
782 OP *version = Nullop;
786 /* default VERSION number -- GBARR */
791 for( d=s, c = 1; isDIGIT(*d) || *d == '_' || (*d == '.' && c--); d++);
792 if((*d == ';' || isSPACE(*d)) && *(skipspace(d)) != ',') {
794 /* real VERSION number -- GBARR */
795 version = yylval.opval;
799 /* NOTE: The parser sees the package name and the VERSION swapped */
800 PL_nextval[PL_nexttoke].opval = version;
808 * Tokenize a quoted string passed in as an SV. It finds the next
809 * chunk, up to end of string or a backslash. It may make a new
810 * SV containing that chunk (if HINT_NEW_STRING is on). It also
815 S_tokeq(pTHX_ SV *sv)
826 s = SvPV_force(sv, len);
830 while (s < send && *s != '\\')
835 if ( PL_hints & HINT_NEW_STRING )
836 pv = sv_2mortal(newSVpvn(SvPVX(pv), len));
839 if (s + 1 < send && (s[1] == '\\'))
840 s++; /* all that, just for this */
845 SvCUR_set(sv, d - SvPVX(sv));
847 if ( PL_hints & HINT_NEW_STRING )
848 return new_constant(NULL, 0, "q", sv, pv, "q");
853 * Now come three functions related to double-quote context,
854 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
855 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
856 * interact with PL_lex_state, and create fake ( ... ) argument lists
857 * to handle functions and concatenation.
858 * They assume that whoever calls them will be setting up a fake
859 * join call, because each subthing puts a ',' after it. This lets
862 * join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
864 * (I'm not sure whether the spurious commas at the end of lcfirst's
865 * arguments and join's arguments are created or not).
870 * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST).
872 * Pattern matching will set PL_lex_op to the pattern-matching op to
873 * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise).
875 * OP_CONST and OP_READLINE are easy--just make the new op and return.
877 * Everything else becomes a FUNC.
879 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
880 * had an OP_CONST or OP_READLINE). This just sets us up for a
881 * call to S_sublex_push().
887 register I32 op_type = yylval.ival;
889 if (op_type == OP_NULL) {
890 yylval.opval = PL_lex_op;
894 if (op_type == OP_CONST || op_type == OP_READLINE) {
895 SV *sv = tokeq(PL_lex_stuff);
897 if (SvTYPE(sv) == SVt_PVIV) {
898 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
904 nsv = newSVpvn(p, len);
908 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
909 PL_lex_stuff = Nullsv;
913 PL_sublex_info.super_state = PL_lex_state;
914 PL_sublex_info.sub_inwhat = op_type;
915 PL_sublex_info.sub_op = PL_lex_op;
916 PL_lex_state = LEX_INTERPPUSH;
920 yylval.opval = PL_lex_op;
930 * Create a new scope to save the lexing state. The scope will be
931 * ended in S_sublex_done. Returns a '(', starting the function arguments
932 * to the uc, lc, etc. found before.
933 * Sets PL_lex_state to LEX_INTERPCONCAT.
942 PL_lex_state = PL_sublex_info.super_state;
943 SAVEI32(PL_lex_dojoin);
944 SAVEI32(PL_lex_brackets);
945 SAVEI32(PL_lex_fakebrack);
946 SAVEI32(PL_lex_casemods);
947 SAVEI32(PL_lex_starts);
948 SAVEI32(PL_lex_state);
949 SAVESPTR(PL_lex_inpat);
950 SAVEI32(PL_lex_inwhat);
951 SAVEI16(PL_curcop->cop_line);
953 SAVEPPTR(PL_oldbufptr);
954 SAVEPPTR(PL_oldoldbufptr);
955 SAVEPPTR(PL_linestart);
956 SAVESPTR(PL_linestr);
957 SAVEPPTR(PL_lex_brackstack);
958 SAVEPPTR(PL_lex_casestack);
960 PL_linestr = PL_lex_stuff;
961 PL_lex_stuff = Nullsv;
963 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
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 ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF))
1132 /* leaveit is the 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); /* expand the sv -- there'll never be more'n 256 chars in a range for it to grow by */
1149 d = SvPVX(sv) + i; /* restore d after the grow potentially has changed the ptr */
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),
1440 * This is the one truly awful dwimmer necessary to conflate C and sed.
1442 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
1444 * ->[ and ->{ return TRUE
1445 * { and [ outside a pattern are always subscripts, so return TRUE
1446 * if we're outside a pattern and it's not { or [, then return FALSE
1447 * if we're in a pattern and the first char is a {
1448 * {4,5} (any digits around the comma) returns FALSE
1449 * if we're in a pattern and the first char is a [
1451 * [SOMETHING] has a funky algorithm to decide whether it's a
1452 * character class or not. It has to deal with things like
1453 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
1454 * anything else returns TRUE
1458 S_intuit_more(pTHX_ register char *s)
1460 if (PL_lex_brackets)
1462 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1464 if (*s != '{' && *s != '[')
1469 /* In a pattern, so maybe we have {n,m}. */
1486 /* On the other hand, maybe we have a character class */
1489 if (*s == ']' || *s == '^')
1492 /* this is terrifying, and it works */
1493 int weight = 2; /* let's weigh the evidence */
1495 unsigned char un_char = 255, last_un_char;
1496 char *send = strchr(s,']');
1497 char tmpbuf[sizeof PL_tokenbuf * 4];
1499 if (!send) /* has to be an expression */
1502 Zero(seen,256,char);
1505 else if (isDIGIT(*s)) {
1507 if (isDIGIT(s[1]) && s[2] == ']')
1513 for (; s < send; s++) {
1514 last_un_char = un_char;
1515 un_char = (unsigned char)*s;
1520 weight -= seen[un_char] * 10;
1521 if (isALNUM_lazy(s+1)) {
1522 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1523 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1528 else if (*s == '$' && s[1] &&
1529 strchr("[#!%*<>()-=",s[1])) {
1530 if (/*{*/ strchr("])} =",s[2]))
1539 if (strchr("wds]",s[1]))
1541 else if (seen['\''] || seen['"'])
1543 else if (strchr("rnftbxcav",s[1]))
1545 else if (isDIGIT(s[1])) {
1547 while (s[1] && isDIGIT(s[1]))
1557 if (strchr("aA01! ",last_un_char))
1559 if (strchr("zZ79~",s[1]))
1561 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1562 weight -= 5; /* cope with negative subscript */
1565 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1566 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1571 if (keyword(tmpbuf, d - tmpbuf))
1574 if (un_char == last_un_char + 1)
1576 weight -= seen[un_char];
1581 if (weight >= 0) /* probably a character class */
1591 * Does all the checking to disambiguate
1593 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
1594 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
1596 * First argument is the stuff after the first token, e.g. "bar".
1598 * Not a method if bar is a filehandle.
1599 * Not a method if foo is a subroutine prototyped to take a filehandle.
1600 * Not a method if it's really "Foo $bar"
1601 * Method if it's "foo $bar"
1602 * Not a method if it's really "print foo $bar"
1603 * Method if it's really "foo package::" (interpreted as package->foo)
1604 * Not a method if bar is known to be a subroutne ("sub bar; foo bar")
1605 * Not a method if bar is a filehandle or package, but is quotd with
1610 S_intuit_method(pTHX_ char *start, GV *gv)
1612 char *s = start + (*start == '$');
1613 char tmpbuf[sizeof PL_tokenbuf];
1621 if ((cv = GvCVu(gv))) {
1622 char *proto = SvPVX(cv);
1632 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1633 /* start is the beginning of the possible filehandle/object,
1634 * and s is the end of it
1635 * tmpbuf is a copy of it
1638 if (*start == '$') {
1639 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1644 return *s == '(' ? FUNCMETH : METHOD;
1646 if (!keyword(tmpbuf, len)) {
1647 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1652 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1653 if (indirgv && GvCVu(indirgv))
1655 /* filehandle or package name makes it a method */
1656 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1658 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1659 return 0; /* no assumptions -- "=>" quotes bearword */
1661 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1662 newSVpvn(tmpbuf,len));
1663 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1667 return *s == '(' ? FUNCMETH : METHOD;
1675 * Return a string of Perl code to load the debugger. If PERL5DB
1676 * is set, it will return the contents of that, otherwise a
1677 * compile-time require of perl5db.pl.
1684 char *pdb = PerlEnv_getenv("PERL5DB");
1688 SETERRNO(0,SS$_NORMAL);
1689 return "BEGIN { require 'perl5db.pl' }";
1695 /* Encoded script support. filter_add() effectively inserts a
1696 * 'pre-processing' function into the current source input stream.
1697 * Note that the filter function only applies to the current source file
1698 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1700 * The datasv parameter (which may be NULL) can be used to pass
1701 * private data to this instance of the filter. The filter function
1702 * can recover the SV using the FILTER_DATA macro and use it to
1703 * store private buffers and state information.
1705 * The supplied datasv parameter is upgraded to a PVIO type
1706 * and the IoDIRP field is used to store the function pointer.
1707 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1708 * private use must be set using malloc'd pointers.
1712 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
1714 if (!funcp){ /* temporary handy debugging hack to be deleted */
1715 PL_filter_debug = atoi((char*)datasv);
1718 if (!PL_rsfp_filters)
1719 PL_rsfp_filters = newAV();
1721 datasv = NEWSV(255,0);
1722 if (!SvUPGRADE(datasv, SVt_PVIO))
1723 Perl_die(aTHX_ "Can't upgrade filter_add data to SVt_PVIO");
1724 IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
1726 if (PL_filter_debug) {
1728 Perl_warn(aTHX_ "filter_add func %p (%s)", funcp, SvPV(datasv, n_a));
1730 #endif /* DEBUGGING */
1731 av_unshift(PL_rsfp_filters, 1);
1732 av_store(PL_rsfp_filters, 0, datasv) ;
1737 /* Delete most recently added instance of this filter function. */
1739 Perl_filter_del(pTHX_ filter_t funcp)
1742 if (PL_filter_debug)
1743 Perl_warn(aTHX_ "filter_del func %p", funcp);
1744 #endif /* DEBUGGING */
1745 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
1747 /* if filter is on top of stack (usual case) just pop it off */
1748 if (IoDIRP(FILTER_DATA(AvFILLp(PL_rsfp_filters))) == (DIR*)funcp){
1749 IoDIRP(FILTER_DATA(AvFILLp(PL_rsfp_filters))) = NULL;
1750 sv_free(av_pop(PL_rsfp_filters));
1754 /* we need to search for the correct entry and clear it */
1755 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
1759 /* Invoke the n'th filter function for the current rsfp. */
1761 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
1764 /* 0 = read one text line */
1769 if (!PL_rsfp_filters)
1771 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
1772 /* Provide a default input filter to make life easy. */
1773 /* Note that we append to the line. This is handy. */
1775 if (PL_filter_debug)
1776 Perl_warn(aTHX_ "filter_read %d: from rsfp\n", idx);
1777 #endif /* DEBUGGING */
1781 int old_len = SvCUR(buf_sv) ;
1783 /* ensure buf_sv is large enough */
1784 SvGROW(buf_sv, old_len + maxlen) ;
1785 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1786 if (PerlIO_error(PL_rsfp))
1787 return -1; /* error */
1789 return 0 ; /* end of file */
1791 SvCUR_set(buf_sv, old_len + len) ;
1794 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
1795 if (PerlIO_error(PL_rsfp))
1796 return -1; /* error */
1798 return 0 ; /* end of file */
1801 return SvCUR(buf_sv);
1803 /* Skip this filter slot if filter has been deleted */
1804 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
1806 if (PL_filter_debug)
1807 Perl_warn(aTHX_ "filter_read %d: skipped (filter deleted)\n", idx);
1808 #endif /* DEBUGGING */
1809 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1811 /* Get function pointer hidden within datasv */
1812 funcp = (filter_t)IoDIRP(datasv);
1814 if (PL_filter_debug) {
1816 Perl_warn(aTHX_ "filter_read %d: via function %p (%s)\n",
1817 idx, funcp, SvPV(datasv,n_a));
1819 #endif /* DEBUGGING */
1820 /* Call function. The function is expected to */
1821 /* call "FILTER_READ(idx+1, buf_sv)" first. */
1822 /* Return: <0:error, =0:eof, >0:not eof */
1823 return (*funcp)(aTHXo_ idx, buf_sv, maxlen);
1827 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
1830 if (!PL_rsfp_filters) {
1831 filter_add(win32_textfilter,NULL);
1834 if (PL_rsfp_filters) {
1837 SvCUR_set(sv, 0); /* start with empty line */
1838 if (FILTER_READ(0, sv, 0) > 0)
1839 return ( SvPVX(sv) ) ;
1844 return (sv_gets(sv, fp, append));
1849 static char* exp_name[] =
1850 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "TERMBLOCK" };
1856 Works out what to call the token just pulled out of the input
1857 stream. The yacc parser takes care of taking the ops we return and
1858 stitching them into a tree.
1864 if read an identifier
1865 if we're in a my declaration
1866 croak if they tried to say my($foo::bar)
1867 build the ops for a my() declaration
1868 if it's an access to a my() variable
1869 are we in a sort block?
1870 croak if my($a); $a <=> $b
1871 build ops for access to a my() variable
1872 if in a dq string, and they've said @foo and we can't find @foo
1874 build ops for a bareword
1875 if we already built the token before, use it.
1879 #ifdef USE_PURE_BISON
1880 Perl_yylex(pTHX_ YYSTYPE *lvalp, int *lcharp)
1893 #ifdef USE_PURE_BISON
1894 yylval_pointer = lvalp;
1895 yychar_pointer = lcharp;
1898 /* check if there's an identifier for us to look at */
1899 if (PL_pending_ident) {
1900 /* pit holds the identifier we read and pending_ident is reset */
1901 char pit = PL_pending_ident;
1902 PL_pending_ident = 0;
1904 /* if we're in a my(), we can't allow dynamics here.
1905 $foo'bar has already been turned into $foo::bar, so
1906 just check for colons.
1908 if it's a legal name, the OP is a PADANY.
1911 if (strchr(PL_tokenbuf,':'))
1912 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
1914 yylval.opval = newOP(OP_PADANY, 0);
1915 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
1920 build the ops for accesses to a my() variable.
1922 Deny my($a) or my($b) in a sort block, *if* $a or $b is
1923 then used in a comparison. This catches most, but not
1924 all cases. For instance, it catches
1925 sort { my($a); $a <=> $b }
1927 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
1928 (although why you'd do that is anyone's guess).
1931 if (!strchr(PL_tokenbuf,':')) {
1933 /* Check for single character per-thread SVs */
1934 if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
1935 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
1936 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
1938 yylval.opval = newOP(OP_THREADSV, 0);
1939 yylval.opval->op_targ = tmp;
1942 #endif /* USE_THREADS */
1943 if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
1944 /* if it's a sort block and they're naming $a or $b */
1945 if (PL_last_lop_op == OP_SORT &&
1946 PL_tokenbuf[0] == '$' &&
1947 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
1950 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
1951 d < PL_bufend && *d != '\n';
1954 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
1955 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
1961 yylval.opval = newOP(OP_PADANY, 0);
1962 yylval.opval->op_targ = tmp;
1968 Whine if they've said @foo in a doublequoted string,
1969 and @foo isn't a variable we can find in the symbol
1972 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
1973 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
1974 if (!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
1975 yyerror(Perl_form(aTHX_ "In string, %s now must be written as \\%s",
1976 PL_tokenbuf, PL_tokenbuf));
1979 /* build ops for a bareword */
1980 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
1981 yylval.opval->op_private = OPpCONST_ENTERED;
1982 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
1983 ((PL_tokenbuf[0] == '$') ? SVt_PV
1984 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
1989 /* no identifier pending identification */
1991 switch (PL_lex_state) {
1993 case LEX_NORMAL: /* Some compilers will produce faster */
1994 case LEX_INTERPNORMAL: /* code if we comment these out. */
1998 /* when we're already built the next token, just pull it out the queue */
2001 yylval = PL_nextval[PL_nexttoke];
2003 PL_lex_state = PL_lex_defer;
2004 PL_expect = PL_lex_expect;
2005 PL_lex_defer = LEX_NORMAL;
2007 return(PL_nexttype[PL_nexttoke]);
2009 /* interpolated case modifiers like \L \U, including \Q and \E.
2010 when we get here, PL_bufptr is at the \
2012 case LEX_INTERPCASEMOD:
2014 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
2015 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
2017 /* handle \E or end of string */
2018 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
2022 if (PL_lex_casemods) {
2023 oldmod = PL_lex_casestack[--PL_lex_casemods];
2024 PL_lex_casestack[PL_lex_casemods] = '\0';
2026 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
2028 PL_lex_state = LEX_INTERPCONCAT;
2032 if (PL_bufptr != PL_bufend)
2034 PL_lex_state = LEX_INTERPCONCAT;
2039 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
2040 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
2041 if (strchr("LU", *s) &&
2042 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
2044 PL_lex_casestack[--PL_lex_casemods] = '\0';
2047 if (PL_lex_casemods > 10) {
2048 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
2049 if (newlb != PL_lex_casestack) {
2051 PL_lex_casestack = newlb;
2054 PL_lex_casestack[PL_lex_casemods++] = *s;
2055 PL_lex_casestack[PL_lex_casemods] = '\0';
2056 PL_lex_state = LEX_INTERPCONCAT;
2057 PL_nextval[PL_nexttoke].ival = 0;
2060 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
2062 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
2064 PL_nextval[PL_nexttoke].ival = OP_LC;
2066 PL_nextval[PL_nexttoke].ival = OP_UC;
2068 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
2070 Perl_croak(aTHX_ "panic: yylex");
2073 if (PL_lex_starts) {
2082 case LEX_INTERPPUSH:
2083 return sublex_push();
2085 case LEX_INTERPSTART:
2086 if (PL_bufptr == PL_bufend)
2087 return sublex_done();
2089 PL_lex_dojoin = (*PL_bufptr == '@');
2090 PL_lex_state = LEX_INTERPNORMAL;
2091 if (PL_lex_dojoin) {
2092 PL_nextval[PL_nexttoke].ival = 0;
2095 PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
2096 PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
2097 force_next(PRIVATEREF);
2099 force_ident("\"", '$');
2100 #endif /* USE_THREADS */
2101 PL_nextval[PL_nexttoke].ival = 0;
2103 PL_nextval[PL_nexttoke].ival = 0;
2105 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
2108 if (PL_lex_starts++) {
2114 case LEX_INTERPENDMAYBE:
2115 if (intuit_more(PL_bufptr)) {
2116 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
2122 if (PL_lex_dojoin) {
2123 PL_lex_dojoin = FALSE;
2124 PL_lex_state = LEX_INTERPCONCAT;
2127 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
2128 && SvEVALED(PL_lex_repl))
2130 if (PL_bufptr != PL_bufend)
2131 Perl_croak(aTHX_ "Bad evalled substitution pattern");
2132 PL_lex_repl = Nullsv;
2135 case LEX_INTERPCONCAT:
2137 if (PL_lex_brackets)
2138 Perl_croak(aTHX_ "panic: INTERPCONCAT");
2140 if (PL_bufptr == PL_bufend)
2141 return sublex_done();
2143 if (SvIVX(PL_linestr) == '\'') {
2144 SV *sv = newSVsv(PL_linestr);
2147 else if ( PL_hints & HINT_NEW_RE )
2148 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
2149 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2153 s = scan_const(PL_bufptr);
2155 PL_lex_state = LEX_INTERPCASEMOD;
2157 PL_lex_state = LEX_INTERPSTART;
2160 if (s != PL_bufptr) {
2161 PL_nextval[PL_nexttoke] = yylval;
2164 if (PL_lex_starts++)
2174 PL_lex_state = LEX_NORMAL;
2175 s = scan_formline(PL_bufptr);
2176 if (!PL_lex_formbrack)
2182 PL_oldoldbufptr = PL_oldbufptr;
2185 PerlIO_printf(PerlIO_stderr(), "### Tokener expecting %s at %s\n", exp_name[PL_expect], s);
2191 if (isIDFIRST_lazy(s))
2193 Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
2196 goto fake_eof; /* emulate EOF on ^D or ^Z */
2201 if (PL_lex_brackets)
2202 yyerror("Missing right curly or square bracket");
2205 if (s++ < PL_bufend)
2206 goto retry; /* ignore stray nulls */
2209 if (!PL_in_eval && !PL_preambled) {
2210 PL_preambled = TRUE;
2211 sv_setpv(PL_linestr,incl_perldb());
2212 if (SvCUR(PL_linestr))
2213 sv_catpv(PL_linestr,";");
2215 while(AvFILLp(PL_preambleav) >= 0) {
2216 SV *tmpsv = av_shift(PL_preambleav);
2217 sv_catsv(PL_linestr, tmpsv);
2218 sv_catpv(PL_linestr, ";");
2221 sv_free((SV*)PL_preambleav);
2222 PL_preambleav = NULL;
2224 if (PL_minus_n || PL_minus_p) {
2225 sv_catpv(PL_linestr, "LINE: while (<>) {");
2227 sv_catpv(PL_linestr,"chomp;");
2229 GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
2231 GvIMPORTED_AV_on(gv);
2233 if (strchr("/'\"", *PL_splitstr)
2234 && strchr(PL_splitstr + 1, *PL_splitstr))
2235 Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s);", PL_splitstr);
2238 s = "'~#\200\1'"; /* surely one char is unused...*/
2239 while (s[1] && strchr(PL_splitstr, *s)) s++;
2241 Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s%c",
2242 "q" + (delim == '\''), delim);
2243 for (s = PL_splitstr; *s; s++) {
2245 sv_catpvn(PL_linestr, "\\", 1);
2246 sv_catpvn(PL_linestr, s, 1);
2248 Perl_sv_catpvf(aTHX_ PL_linestr, "%c);", delim);
2252 sv_catpv(PL_linestr,"@F=split(' ');");
2255 sv_catpv(PL_linestr, "\n");
2256 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2257 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2258 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2259 SV *sv = NEWSV(85,0);
2261 sv_upgrade(sv, SVt_PVMG);
2262 sv_setsv(sv,PL_linestr);
2263 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
2268 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
2271 if (PL_preprocess && !PL_in_eval)
2272 (void)PerlProc_pclose(PL_rsfp);
2273 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2274 PerlIO_clearerr(PL_rsfp);
2276 (void)PerlIO_close(PL_rsfp);
2278 PL_doextract = FALSE;
2280 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2281 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
2282 sv_catpv(PL_linestr,";}");
2283 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2284 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2285 PL_minus_n = PL_minus_p = 0;
2288 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2289 sv_setpv(PL_linestr,"");
2290 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
2293 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
2294 PL_doextract = FALSE;
2296 /* Incest with pod. */
2297 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2298 sv_setpv(PL_linestr, "");
2299 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2300 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2301 PL_doextract = FALSE;
2305 } while (PL_doextract);
2306 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2307 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2308 SV *sv = NEWSV(85,0);
2310 sv_upgrade(sv, SVt_PVMG);
2311 sv_setsv(sv,PL_linestr);
2312 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
2314 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2315 if (PL_curcop->cop_line == 1) {
2316 while (s < PL_bufend && isSPACE(*s))
2318 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2322 if (*s == '#' && *(s+1) == '!')
2324 #ifdef ALTERNATE_SHEBANG
2326 static char as[] = ALTERNATE_SHEBANG;
2327 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2328 d = s + (sizeof(as) - 1);
2330 #endif /* ALTERNATE_SHEBANG */
2339 while (*d && !isSPACE(*d))
2343 #ifdef ARG_ZERO_IS_SCRIPT
2344 if (ipathend > ipath) {
2346 * HP-UX (at least) sets argv[0] to the script name,
2347 * which makes $^X incorrect. And Digital UNIX and Linux,
2348 * at least, set argv[0] to the basename of the Perl
2349 * interpreter. So, having found "#!", we'll set it right.
2351 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
2352 assert(SvPOK(x) || SvGMAGICAL(x));
2353 if (sv_eq(x, GvSV(PL_curcop->cop_filegv))) {
2354 sv_setpvn(x, ipath, ipathend - ipath);
2357 TAINT_NOT; /* $^X is always tainted, but that's OK */
2359 #endif /* ARG_ZERO_IS_SCRIPT */
2364 d = instr(s,"perl -");
2366 d = instr(s,"perl");
2367 #ifdef ALTERNATE_SHEBANG
2369 * If the ALTERNATE_SHEBANG on this system starts with a
2370 * character that can be part of a Perl expression, then if
2371 * we see it but not "perl", we're probably looking at the
2372 * start of Perl code, not a request to hand off to some
2373 * other interpreter. Similarly, if "perl" is there, but
2374 * not in the first 'word' of the line, we assume the line
2375 * contains the start of the Perl program.
2377 if (d && *s != '#') {
2379 while (*c && !strchr("; \t\r\n\f\v#", *c))
2382 d = Nullch; /* "perl" not in first word; ignore */
2384 *s = '#'; /* Don't try to parse shebang line */
2386 #endif /* ALTERNATE_SHEBANG */
2391 !instr(s,"indir") &&
2392 instr(PL_origargv[0],"perl"))
2398 while (s < PL_bufend && isSPACE(*s))
2400 if (s < PL_bufend) {
2401 Newz(899,newargv,PL_origargc+3,char*);
2403 while (s < PL_bufend && !isSPACE(*s))
2406 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2409 newargv = PL_origargv;
2411 PerlProc_execv(ipath, newargv);
2412 Perl_croak(aTHX_ "Can't exec %s", ipath);
2415 U32 oldpdb = PL_perldb;
2416 bool oldn = PL_minus_n;
2417 bool oldp = PL_minus_p;
2419 while (*d && !isSPACE(*d)) d++;
2420 while (*d == ' ' || *d == '\t') d++;
2424 if (*d == 'M' || *d == 'm') {
2426 while (*d && !isSPACE(*d)) d++;
2427 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2430 d = moreswitches(d);
2432 if (PERLDB_LINE && !oldpdb ||
2433 ( PL_minus_n || PL_minus_p ) && !(oldn || oldp) )
2434 /* if we have already added "LINE: while (<>) {",
2435 we must not do it again */
2437 sv_setpv(PL_linestr, "");
2438 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2439 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2440 PL_preambled = FALSE;
2442 (void)gv_fetchfile(PL_origfilename);
2449 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2451 PL_lex_state = LEX_FORMLINE;
2456 #ifdef PERL_STRICT_CR
2457 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2459 "(Maybe you didn't strip carriage returns after a network transfer?)\n");
2461 case ' ': case '\t': case '\f': case 013:
2466 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2468 while (s < d && *s != '\n')
2473 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2475 PL_lex_state = LEX_FORMLINE;
2485 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2490 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2493 if (strnEQ(s,"=>",2)) {
2494 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2495 OPERATOR('-'); /* unary minus */
2497 PL_last_uni = PL_oldbufptr;
2498 PL_last_lop_op = OP_FTEREAD; /* good enough */
2500 case 'r': FTST(OP_FTEREAD);
2501 case 'w': FTST(OP_FTEWRITE);
2502 case 'x': FTST(OP_FTEEXEC);
2503 case 'o': FTST(OP_FTEOWNED);
2504 case 'R': FTST(OP_FTRREAD);
2505 case 'W': FTST(OP_FTRWRITE);
2506 case 'X': FTST(OP_FTREXEC);
2507 case 'O': FTST(OP_FTROWNED);
2508 case 'e': FTST(OP_FTIS);
2509 case 'z': FTST(OP_FTZERO);
2510 case 's': FTST(OP_FTSIZE);
2511 case 'f': FTST(OP_FTFILE);
2512 case 'd': FTST(OP_FTDIR);
2513 case 'l': FTST(OP_FTLINK);
2514 case 'p': FTST(OP_FTPIPE);
2515 case 'S': FTST(OP_FTSOCK);
2516 case 'u': FTST(OP_FTSUID);
2517 case 'g': FTST(OP_FTSGID);
2518 case 'k': FTST(OP_FTSVTX);
2519 case 'b': FTST(OP_FTBLK);
2520 case 'c': FTST(OP_FTCHR);
2521 case 't': FTST(OP_FTTTY);
2522 case 'T': FTST(OP_FTTEXT);
2523 case 'B': FTST(OP_FTBINARY);
2524 case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2525 case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2526 case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
2528 Perl_croak(aTHX_ "Unrecognized file test: -%c", (int)tmp);
2535 if (PL_expect == XOPERATOR)
2540 else if (*s == '>') {
2543 if (isIDFIRST_lazy(s)) {
2544 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2552 if (PL_expect == XOPERATOR)
2555 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2557 OPERATOR('-'); /* unary minus */
2564 if (PL_expect == XOPERATOR)
2569 if (PL_expect == XOPERATOR)
2572 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2578 if (PL_expect != XOPERATOR) {
2579 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2580 PL_expect = XOPERATOR;
2581 force_ident(PL_tokenbuf, '*');
2594 if (PL_expect == XOPERATOR) {
2598 PL_tokenbuf[0] = '%';
2599 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2600 if (!PL_tokenbuf[1]) {
2602 yyerror("Final % should be \\% or %name");
2605 PL_pending_ident = '%';
2627 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
2628 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
2633 if (PL_curcop->cop_line < PL_copline)
2634 PL_copline = PL_curcop->cop_line;
2645 if (PL_lex_brackets <= 0)
2646 yyerror("Unmatched right square bracket");
2649 if (PL_lex_state == LEX_INTERPNORMAL) {
2650 if (PL_lex_brackets == 0) {
2651 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
2652 PL_lex_state = LEX_INTERPEND;
2659 if (PL_lex_brackets > 100) {
2660 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
2661 if (newlb != PL_lex_brackstack) {
2663 PL_lex_brackstack = newlb;
2666 switch (PL_expect) {
2668 if (PL_lex_formbrack) {
2672 if (PL_oldoldbufptr == PL_last_lop)
2673 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2675 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2676 OPERATOR(HASHBRACK);
2678 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2681 PL_tokenbuf[0] = '\0';
2682 if (d < PL_bufend && *d == '-') {
2683 PL_tokenbuf[0] = '-';
2685 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2688 if (d < PL_bufend && isIDFIRST_lazy(d)) {
2689 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2691 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2694 char minus = (PL_tokenbuf[0] == '-');
2695 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2702 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
2706 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2711 if (PL_oldoldbufptr == PL_last_lop)
2712 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2714 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2717 OPERATOR(HASHBRACK);
2718 /* This hack serves to disambiguate a pair of curlies
2719 * as being a block or an anon hash. Normally, expectation
2720 * determines that, but in cases where we're not in a
2721 * position to expect anything in particular (like inside
2722 * eval"") we have to resolve the ambiguity. This code
2723 * covers the case where the first term in the curlies is a
2724 * quoted string. Most other cases need to be explicitly
2725 * disambiguated by prepending a `+' before the opening
2726 * curly in order to force resolution as an anon hash.
2728 * XXX should probably propagate the outer expectation
2729 * into eval"" to rely less on this hack, but that could
2730 * potentially break current behavior of eval"".
2734 if (*s == '\'' || *s == '"' || *s == '`') {
2735 /* common case: get past first string, handling escapes */
2736 for (t++; t < PL_bufend && *t != *s;)
2737 if (*t++ == '\\' && (*t == '\\' || *t == *s))
2741 else if (*s == 'q') {
2744 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
2745 && !isALNUM(*t)))) {
2747 char open, close, term;
2750 while (t < PL_bufend && isSPACE(*t))
2754 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
2758 for (t++; t < PL_bufend; t++) {
2759 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
2761 else if (*t == open)
2765 for (t++; t < PL_bufend; t++) {
2766 if (*t == '\\' && t+1 < PL_bufend)
2768 else if (*t == close && --brackets <= 0)
2770 else if (*t == open)
2776 else if (isIDFIRST_lazy(s)) {
2777 for (t++; t < PL_bufend && isALNUM_lazy(t); t++) ;
2779 while (t < PL_bufend && isSPACE(*t))
2781 /* if comma follows first term, call it an anon hash */
2782 /* XXX it could be a comma expression with loop modifiers */
2783 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
2784 || (*t == '=' && t[1] == '>')))
2785 OPERATOR(HASHBRACK);
2786 if (PL_expect == XREF)
2789 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
2795 yylval.ival = PL_curcop->cop_line;
2796 if (isSPACE(*s) || *s == '#')
2797 PL_copline = NOLINE; /* invalidate current command line number */
2802 if (PL_lex_brackets <= 0)
2803 yyerror("Unmatched right curly bracket");
2805 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
2806 if (PL_lex_brackets < PL_lex_formbrack)
2807 PL_lex_formbrack = 0;
2808 if (PL_lex_state == LEX_INTERPNORMAL) {
2809 if (PL_lex_brackets == 0) {
2810 if (PL_lex_fakebrack) {
2811 PL_lex_state = LEX_INTERPEND;
2813 return yylex(); /* ignore fake brackets */
2815 if (*s == '-' && s[1] == '>')
2816 PL_lex_state = LEX_INTERPENDMAYBE;
2817 else if (*s != '[' && *s != '{')
2818 PL_lex_state = LEX_INTERPEND;
2821 if (PL_lex_brackets < PL_lex_fakebrack) {
2823 PL_lex_fakebrack = 0;
2824 return yylex(); /* ignore fake brackets */
2834 if (PL_expect == XOPERATOR) {
2835 if (ckWARN(WARN_SEMICOLON) && isIDFIRST_lazy(s) && PL_bufptr == PL_linestart) {
2836 PL_curcop->cop_line--;
2837 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
2838 PL_curcop->cop_line++;
2843 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2845 PL_expect = XOPERATOR;
2846 force_ident(PL_tokenbuf, '&');
2850 yylval.ival = (OPpENTERSUB_AMPER<<8);
2869 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
2870 Perl_warner(aTHX_ WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
2872 if (PL_expect == XSTATE && isALPHA(tmp) &&
2873 (s == PL_linestart+1 || s[-2] == '\n') )
2875 if (PL_in_eval && !PL_rsfp) {
2880 if (strnEQ(s,"=cut",4)) {
2894 PL_doextract = TRUE;
2897 if (PL_lex_brackets < PL_lex_formbrack) {
2899 #ifdef PERL_STRICT_CR
2900 for (t = s; *t == ' ' || *t == '\t'; t++) ;
2902 for (t = s; *t == ' ' || *t == '\t' || *t == '\r'; t++) ;
2904 if (*t == '\n' || *t == '#') {
2922 if (PL_expect != XOPERATOR) {
2923 if (s[1] != '<' && !strchr(s,'>'))
2926 s = scan_heredoc(s);
2928 s = scan_inputsymbol(s);
2929 TERM(sublex_start());
2934 SHop(OP_LEFT_SHIFT);
2948 SHop(OP_RIGHT_SHIFT);
2957 if (PL_expect == XOPERATOR) {
2958 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2961 return ','; /* grandfather non-comma-format format */
2965 if (s[1] == '#' && (isIDFIRST_lazy(s+2) || strchr("{$:+-", s[2]))) {
2966 PL_tokenbuf[0] = '@';
2967 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
2968 sizeof PL_tokenbuf - 1, FALSE);
2969 if (PL_expect == XOPERATOR)
2970 no_op("Array length", s);
2971 if (!PL_tokenbuf[1])
2973 PL_expect = XOPERATOR;
2974 PL_pending_ident = '#';
2978 PL_tokenbuf[0] = '$';
2979 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
2980 sizeof PL_tokenbuf - 1, FALSE);
2981 if (PL_expect == XOPERATOR)
2983 if (!PL_tokenbuf[1]) {
2985 yyerror("Final $ should be \\$ or $name");
2989 /* This kludge not intended to be bulletproof. */
2990 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
2991 yylval.opval = newSVOP(OP_CONST, 0,
2992 newSViv((IV)PL_compiling.cop_arybase));
2993 yylval.opval->op_private = OPpCONST_ARYBASE;
2999 if (PL_lex_state == LEX_NORMAL)
3002 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3005 PL_tokenbuf[0] = '@';
3006 if (ckWARN(WARN_SYNTAX)) {
3008 isSPACE(*t) || isALNUM_lazy(t) || *t == '$';
3011 PL_bufptr = skipspace(PL_bufptr);
3012 while (t < PL_bufend && *t != ']')
3014 Perl_warner(aTHX_ WARN_SYNTAX,
3015 "Multidimensional syntax %.*s not supported",
3016 (t - PL_bufptr) + 1, PL_bufptr);
3020 else if (*s == '{') {
3021 PL_tokenbuf[0] = '%';
3022 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
3023 (t = strchr(s, '}')) && (t = strchr(t, '=')))
3025 char tmpbuf[sizeof PL_tokenbuf];
3027 for (t++; isSPACE(*t); t++) ;
3028 if (isIDFIRST_lazy(t)) {
3029 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
3030 for (; isSPACE(*t); t++) ;
3031 if (*t == ';' && get_cv(tmpbuf, FALSE))
3032 Perl_warner(aTHX_ WARN_SYNTAX,
3033 "You need to quote \"%s\"", tmpbuf);
3039 PL_expect = XOPERATOR;
3040 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3041 bool islop = (PL_last_lop == PL_oldoldbufptr);
3042 if (!islop || PL_last_lop_op == OP_GREPSTART)
3043 PL_expect = XOPERATOR;
3044 else if (strchr("$@\"'`q", *s))
3045 PL_expect = XTERM; /* e.g. print $fh "foo" */
3046 else if (strchr("&*<%", *s) && isIDFIRST_lazy(s+1))
3047 PL_expect = XTERM; /* e.g. print $fh &sub */
3048 else if (isIDFIRST_lazy(s)) {
3049 char tmpbuf[sizeof PL_tokenbuf];
3050 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3051 if (tmp = keyword(tmpbuf, len)) {
3052 /* binary operators exclude handle interpretations */
3064 PL_expect = XTERM; /* e.g. print $fh length() */
3069 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
3070 if (gv && GvCVu(gv))
3071 PL_expect = XTERM; /* e.g. print $fh subr() */
3074 else if (isDIGIT(*s))
3075 PL_expect = XTERM; /* e.g. print $fh 3 */
3076 else if (*s == '.' && isDIGIT(s[1]))
3077 PL_expect = XTERM; /* e.g. print $fh .3 */
3078 else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
3079 PL_expect = XTERM; /* e.g. print $fh -1 */
3080 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3081 PL_expect = XTERM; /* print $fh <<"EOF" */
3083 PL_pending_ident = '$';
3087 if (PL_expect == XOPERATOR)
3089 PL_tokenbuf[0] = '@';
3090 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3091 if (!PL_tokenbuf[1]) {
3093 yyerror("Final @ should be \\@ or @name");
3096 if (PL_lex_state == LEX_NORMAL)
3098 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3100 PL_tokenbuf[0] = '%';
3102 /* Warn about @ where they meant $. */
3103 if (ckWARN(WARN_SYNTAX)) {
3104 if (*s == '[' || *s == '{') {
3106 while (*t && (isALNUM_lazy(t) || strchr(" \t$#+-'\"", *t)))
3108 if (*t == '}' || *t == ']') {
3110 PL_bufptr = skipspace(PL_bufptr);
3111 Perl_warner(aTHX_ WARN_SYNTAX,
3112 "Scalar value %.*s better written as $%.*s",
3113 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
3118 PL_pending_ident = '@';
3121 case '/': /* may either be division or pattern */
3122 case '?': /* may either be conditional or pattern */
3123 if (PL_expect != XOPERATOR) {
3124 /* Disable warning on "study /blah/" */
3125 if (PL_oldoldbufptr == PL_last_uni
3126 && (*PL_last_uni != 's' || s - PL_last_uni < 5
3127 || memNE(PL_last_uni, "study", 5) || isALNUM_lazy(PL_last_uni+5)))
3129 s = scan_pat(s,OP_MATCH);
3130 TERM(sublex_start());
3138 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3139 #ifdef PERL_STRICT_CR
3142 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3144 && (s == PL_linestart || s[-1] == '\n') )
3146 PL_lex_formbrack = 0;
3150 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
3156 yylval.ival = OPf_SPECIAL;
3162 if (PL_expect != XOPERATOR)
3167 case '0': case '1': case '2': case '3': case '4':
3168 case '5': case '6': case '7': case '8': case '9':
3170 if (PL_expect == XOPERATOR)
3176 if (PL_expect == XOPERATOR) {
3177 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3180 return ','; /* grandfather non-comma-format format */
3186 missingterm((char*)0);
3187 yylval.ival = OP_CONST;
3188 TERM(sublex_start());
3192 if (PL_expect == XOPERATOR) {
3193 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3196 return ','; /* grandfather non-comma-format format */
3202 missingterm((char*)0);
3203 yylval.ival = OP_CONST;
3204 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
3205 if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
3206 yylval.ival = OP_STRINGIFY;
3210 TERM(sublex_start());
3214 if (PL_expect == XOPERATOR)
3215 no_op("Backticks",s);
3217 missingterm((char*)0);
3218 yylval.ival = OP_BACKTICK;
3220 TERM(sublex_start());
3224 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
3225 Perl_warner(aTHX_ WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
3227 if (PL_expect == XOPERATOR)
3228 no_op("Backslash",s);
3232 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
3272 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3274 /* Some keywords can be followed by any delimiter, including ':' */
3275 tmp = (len == 1 && strchr("msyq", PL_tokenbuf[0]) ||
3276 len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
3277 (PL_tokenbuf[0] == 'q' &&
3278 strchr("qwxr", PL_tokenbuf[1]))));
3280 /* x::* is just a word, unless x is "CORE" */
3281 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
3285 while (d < PL_bufend && isSPACE(*d))
3286 d++; /* no comments skipped here, or s### is misparsed */
3288 /* Is this a label? */
3289 if (!tmp && PL_expect == XSTATE
3290 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
3292 yylval.pval = savepv(PL_tokenbuf);
3297 /* Check for keywords */
3298 tmp = keyword(PL_tokenbuf, len);
3300 /* Is this a word before a => operator? */
3301 if (strnEQ(d,"=>",2)) {
3303 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
3304 yylval.opval->op_private = OPpCONST_BARE;
3308 if (tmp < 0) { /* second-class keyword? */
3309 GV *ogv = Nullgv; /* override (winner) */
3310 GV *hgv = Nullgv; /* hidden (loser) */
3311 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3313 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3316 if (GvIMPORTED_CV(gv))
3318 else if (! CvMETHOD(cv))
3322 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3323 (gv = *gvp) != (GV*)&PL_sv_undef &&
3324 GvCVu(gv) && GvIMPORTED_CV(gv))
3330 tmp = 0; /* overridden by import or by GLOBAL */
3333 && -tmp==KEY_lock /* XXX generalizable kludge */
3334 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3336 tmp = 0; /* any sub overrides "weak" keyword */
3338 else { /* no override */
3342 if (ckWARN(WARN_AMBIGUOUS) && hgv
3343 && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3344 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3345 "Ambiguous call resolved as CORE::%s(), %s",
3346 GvENAME(hgv), "qualify as such or use &");
3353 default: /* not a keyword */
3356 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3358 /* Get the rest if it looks like a package qualifier */
3360 if (*s == '\'' || *s == ':' && s[1] == ':') {
3362 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3365 Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
3366 *s == '\'' ? "'" : "::");
3370 if (PL_expect == XOPERATOR) {
3371 if (PL_bufptr == PL_linestart) {
3372 PL_curcop->cop_line--;
3373 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3374 PL_curcop->cop_line++;
3377 no_op("Bareword",s);
3380 /* Look for a subroutine with this name in current package,
3381 unless name is "Foo::", in which case Foo is a bearword
3382 (and a package name). */
3385 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3387 if (ckWARN(WARN_UNSAFE) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3388 Perl_warner(aTHX_ WARN_UNSAFE,
3389 "Bareword \"%s\" refers to nonexistent package",
3392 PL_tokenbuf[len] = '\0';
3399 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3402 /* if we saw a global override before, get the right name */
3405 sv = newSVpvn("CORE::GLOBAL::",14);
3406 sv_catpv(sv,PL_tokenbuf);
3409 sv = newSVpv(PL_tokenbuf,0);
3411 /* Presume this is going to be a bareword of some sort. */
3414 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3415 yylval.opval->op_private = OPpCONST_BARE;
3417 /* And if "Foo::", then that's what it certainly is. */
3422 /* See if it's the indirect object for a list operator. */
3424 if (PL_oldoldbufptr &&
3425 PL_oldoldbufptr < PL_bufptr &&
3426 (PL_oldoldbufptr == PL_last_lop || PL_oldoldbufptr == PL_last_uni) &&
3427 /* NO SKIPSPACE BEFORE HERE! */
3428 (PL_expect == XREF ||
3429 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
3431 bool immediate_paren = *s == '(';
3433 /* (Now we can afford to cross potential line boundary.) */
3436 /* Two barewords in a row may indicate method call. */
3438 if ((isIDFIRST_lazy(s) || *s == '$') && (tmp=intuit_method(s,gv)))
3441 /* If not a declared subroutine, it's an indirect object. */
3442 /* (But it's an indir obj regardless for sort.) */
3444 if ((PL_last_lop_op == OP_SORT ||
3445 (!immediate_paren && (!gv || !GvCVu(gv)))) &&
3446 (PL_last_lop_op != OP_MAPSTART &&
3447 PL_last_lop_op != OP_GREPSTART))
3449 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3454 /* If followed by a paren, it's certainly a subroutine. */
3456 PL_expect = XOPERATOR;
3460 if (gv && GvCVu(gv)) {
3461 for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
3462 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
3467 PL_nextval[PL_nexttoke].opval = yylval.opval;
3468 PL_expect = XOPERATOR;
3474 /* If followed by var or block, call it a method (unless sub) */
3476 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3477 PL_last_lop = PL_oldbufptr;
3478 PL_last_lop_op = OP_METHOD;
3482 /* If followed by a bareword, see if it looks like indir obj. */
3484 if ((isIDFIRST_lazy(s) || *s == '$') && (tmp = intuit_method(s,gv)))
3487 /* Not a method, so call it a subroutine (if defined) */
3489 if (gv && GvCVu(gv)) {
3491 if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
3492 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3493 "Ambiguous use of -%s resolved as -&%s()",
3494 PL_tokenbuf, PL_tokenbuf);
3495 /* Check for a constant sub */
3497 if ((sv = cv_const_sv(cv))) {
3499 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3500 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3501 yylval.opval->op_private = 0;
3505 /* Resolve to GV now. */
3506 op_free(yylval.opval);
3507 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3508 yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
3509 PL_last_lop = PL_oldbufptr;
3510 PL_last_lop_op = OP_ENTERSUB;
3511 /* Is there a prototype? */
3514 char *proto = SvPV((SV*)cv, len);
3517 if (strEQ(proto, "$"))
3519 if (*proto == '&' && *s == '{') {
3520 sv_setpv(PL_subname,"__ANON__");
3524 PL_nextval[PL_nexttoke].opval = yylval.opval;
3530 /* Call it a bare word */
3532 if (PL_hints & HINT_STRICT_SUBS)
3533 yylval.opval->op_private |= OPpCONST_STRICT;
3536 if (ckWARN(WARN_RESERVED)) {
3537 if (lastchar != '-') {
3538 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3540 Perl_warner(aTHX_ WARN_RESERVED, PL_warn_reserved,
3547 if (lastchar && strchr("*%&", lastchar) && ckWARN_d(WARN_AMBIGUOUS)) {
3548 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3549 "Operator or semicolon missing before %c%s",
3550 lastchar, PL_tokenbuf);
3551 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3552 "Ambiguous use of %c resolved as operator %c",
3553 lastchar, lastchar);
3559 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3560 newSVsv(GvSV(PL_curcop->cop_filegv)));
3564 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3565 Perl_newSVpvf(aTHX_ "%ld", (long)PL_curcop->cop_line));
3568 case KEY___PACKAGE__:
3569 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3571 ? newSVsv(PL_curstname)
3580 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3581 char *pname = "main";
3582 if (PL_tokenbuf[2] == 'D')
3583 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3584 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
3587 GvIOp(gv) = newIO();
3588 IoIFP(GvIOp(gv)) = PL_rsfp;
3589 #if defined(HAS_FCNTL) && defined(F_SETFD)
3591 int fd = PerlIO_fileno(PL_rsfp);
3592 fcntl(fd,F_SETFD,fd >= 3);
3595 /* Mark this internal pseudo-handle as clean */
3596 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3598 IoTYPE(GvIOp(gv)) = '|';
3599 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
3600 IoTYPE(GvIOp(gv)) = '-';
3602 IoTYPE(GvIOp(gv)) = '<';
3613 if (PL_expect == XSTATE) {
3620 if (*s == ':' && s[1] == ':') {
3623 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3624 tmp = keyword(PL_tokenbuf, len);
3638 LOP(OP_ACCEPT,XTERM);
3644 LOP(OP_ATAN2,XTERM);
3653 LOP(OP_BLESS,XTERM);
3662 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
3679 if (!PL_cryptseen++)
3682 LOP(OP_CRYPT,XTERM);
3685 if (ckWARN(WARN_OCTAL)) {
3686 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
3687 if (*d != '0' && isDIGIT(*d))
3688 yywarn("chmod: mode argument is missing initial 0");
3690 LOP(OP_CHMOD,XTERM);
3693 LOP(OP_CHOWN,XTERM);
3696 LOP(OP_CONNECT,XTERM);
3712 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3716 PL_hints |= HINT_BLOCK_SCOPE;
3726 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3727 LOP(OP_DBMOPEN,XTERM);
3733 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3740 yylval.ival = PL_curcop->cop_line;
3754 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
3755 UNIBRACK(OP_ENTEREVAL);
3770 case KEY_endhostent:
3776 case KEY_endservent:
3779 case KEY_endprotoent:
3790 yylval.ival = PL_curcop->cop_line;
3792 if (PL_expect == XSTATE && isIDFIRST_lazy(s)) {
3794 if ((PL_bufend - p) >= 3 &&
3795 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3798 if (isIDFIRST_lazy(p))
3799 Perl_croak(aTHX_ "Missing $ on loop variable");
3804 LOP(OP_FORMLINE,XTERM);
3810 LOP(OP_FCNTL,XTERM);
3816 LOP(OP_FLOCK,XTERM);
3825 LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
3828 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3843 case KEY_getpriority:
3844 LOP(OP_GETPRIORITY,XTERM);
3846 case KEY_getprotobyname:
3849 case KEY_getprotobynumber:
3850 LOP(OP_GPBYNUMBER,XTERM);
3852 case KEY_getprotoent:
3864 case KEY_getpeername:
3865 UNI(OP_GETPEERNAME);
3867 case KEY_gethostbyname:
3870 case KEY_gethostbyaddr:
3871 LOP(OP_GHBYADDR,XTERM);
3873 case KEY_gethostent:
3876 case KEY_getnetbyname:
3879 case KEY_getnetbyaddr:
3880 LOP(OP_GNBYADDR,XTERM);
3885 case KEY_getservbyname:
3886 LOP(OP_GSBYNAME,XTERM);
3888 case KEY_getservbyport:
3889 LOP(OP_GSBYPORT,XTERM);
3891 case KEY_getservent:
3894 case KEY_getsockname:
3895 UNI(OP_GETSOCKNAME);
3897 case KEY_getsockopt:
3898 LOP(OP_GSOCKOPT,XTERM);
3920 yylval.ival = PL_curcop->cop_line;
3924 LOP(OP_INDEX,XTERM);
3930 LOP(OP_IOCTL,XTERM);
3942 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3973 LOP(OP_LISTEN,XTERM);
3982 s = scan_pat(s,OP_MATCH);
3983 TERM(sublex_start());
3986 LOP(OP_MAPSTART, *s == '(' ? XTERM : XREF);
3989 LOP(OP_MKDIR,XTERM);
3992 LOP(OP_MSGCTL,XTERM);
3995 LOP(OP_MSGGET,XTERM);
3998 LOP(OP_MSGRCV,XTERM);
4001 LOP(OP_MSGSND,XTERM);
4006 if (isIDFIRST_lazy(s)) {
4007 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
4008 PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
4009 if (!PL_in_my_stash) {
4012 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
4019 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4026 if (PL_expect != XSTATE)
4027 yyerror("\"no\" not allowed in expression");
4028 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4029 s = force_version(s);
4038 if (isIDFIRST_lazy(s)) {
4040 for (d = s; isALNUM_lazy(d); d++) ;
4042 if (strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_AMBIGUOUS))
4043 Perl_warner(aTHX_ WARN_AMBIGUOUS,
4044 "Precedence problem: open %.*s should be open(%.*s)",
4050 yylval.ival = OP_OR;
4060 LOP(OP_OPEN_DIR,XTERM);
4063 checkcomma(s,PL_tokenbuf,"filehandle");
4067 checkcomma(s,PL_tokenbuf,"filehandle");
4086 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4090 LOP(OP_PIPE_OP,XTERM);
4095 missingterm((char*)0);
4096 yylval.ival = OP_CONST;
4097 TERM(sublex_start());
4105 missingterm((char*)0);
4107 if (SvCUR(PL_lex_stuff)) {
4110 d = SvPV_force(PL_lex_stuff, len);
4112 for (; isSPACE(*d) && len; --len, ++d) ;
4115 if (!warned && ckWARN(WARN_SYNTAX)) {
4116 for (; !isSPACE(*d) && len; --len, ++d) {
4118 Perl_warner(aTHX_ WARN_SYNTAX,
4119 "Possible attempt to separate words with commas");
4122 else if (*d == '#') {
4123 Perl_warner(aTHX_ WARN_SYNTAX,
4124 "Possible attempt to put comments in qw() list");
4130 for (; !isSPACE(*d) && len; --len, ++d) ;
4132 words = append_elem(OP_LIST, words,
4133 newSVOP(OP_CONST, 0, newSVpvn(b, d-b)));
4137 PL_nextval[PL_nexttoke].opval = words;
4142 SvREFCNT_dec(PL_lex_stuff);
4143 PL_lex_stuff = Nullsv;
4150 missingterm((char*)0);
4151 yylval.ival = OP_STRINGIFY;
4152 if (SvIVX(PL_lex_stuff) == '\'')
4153 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
4154 TERM(sublex_start());
4157 s = scan_pat(s,OP_QR);
4158 TERM(sublex_start());
4163 missingterm((char*)0);
4164 yylval.ival = OP_BACKTICK;
4166 TERM(sublex_start());
4172 *PL_tokenbuf = '\0';
4173 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4174 if (isIDFIRST_lazy(PL_tokenbuf))
4175 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
4177 yyerror("<> should be quotes");
4184 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4188 LOP(OP_RENAME,XTERM);
4197 LOP(OP_RINDEX,XTERM);
4220 LOP(OP_REVERSE,XTERM);
4231 TERM(sublex_start());
4233 TOKEN(1); /* force error */
4242 LOP(OP_SELECT,XTERM);
4248 LOP(OP_SEMCTL,XTERM);
4251 LOP(OP_SEMGET,XTERM);
4254 LOP(OP_SEMOP,XTERM);
4260 LOP(OP_SETPGRP,XTERM);
4262 case KEY_setpriority:
4263 LOP(OP_SETPRIORITY,XTERM);
4265 case KEY_sethostent:
4271 case KEY_setservent:
4274 case KEY_setprotoent:
4284 LOP(OP_SEEKDIR,XTERM);
4286 case KEY_setsockopt:
4287 LOP(OP_SSOCKOPT,XTERM);
4293 LOP(OP_SHMCTL,XTERM);
4296 LOP(OP_SHMGET,XTERM);
4299 LOP(OP_SHMREAD,XTERM);
4302 LOP(OP_SHMWRITE,XTERM);
4305 LOP(OP_SHUTDOWN,XTERM);
4314 LOP(OP_SOCKET,XTERM);
4316 case KEY_socketpair:
4317 LOP(OP_SOCKPAIR,XTERM);
4320 checkcomma(s,PL_tokenbuf,"subroutine name");
4322 if (*s == ';' || *s == ')') /* probably a close */
4323 Perl_croak(aTHX_ "sort is now a reserved word");
4325 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4329 LOP(OP_SPLIT,XTERM);
4332 LOP(OP_SPRINTF,XTERM);
4335 LOP(OP_SPLICE,XTERM);
4351 LOP(OP_SUBSTR,XTERM);
4358 if (isIDFIRST_lazy(s) || *s == '\'' || *s == ':') {
4359 char tmpbuf[sizeof PL_tokenbuf];
4361 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4362 if (strchr(tmpbuf, ':'))
4363 sv_setpv(PL_subname, tmpbuf);
4365 sv_setsv(PL_subname,PL_curstname);
4366 sv_catpvn(PL_subname,"::",2);
4367 sv_catpvn(PL_subname,tmpbuf,len);
4369 s = force_word(s,WORD,FALSE,TRUE,TRUE);
4373 PL_expect = XTERMBLOCK;
4374 sv_setpv(PL_subname,"?");
4377 if (tmp == KEY_format) {
4380 PL_lex_formbrack = PL_lex_brackets + 1;
4384 /* Look for a prototype */
4391 SvREFCNT_dec(PL_lex_stuff);
4392 PL_lex_stuff = Nullsv;
4393 Perl_croak(aTHX_ "Prototype not terminated");
4396 d = SvPVX(PL_lex_stuff);
4398 for (p = d; *p; ++p) {
4403 SvCUR(PL_lex_stuff) = tmp;
4406 PL_nextval[1] = PL_nextval[0];
4407 PL_nexttype[1] = PL_nexttype[0];
4408 PL_nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4409 PL_nexttype[0] = THING;
4410 if (PL_nexttoke == 1) {
4411 PL_lex_defer = PL_lex_state;
4412 PL_lex_expect = PL_expect;
4413 PL_lex_state = LEX_KNOWNEXT;
4415 PL_lex_stuff = Nullsv;
4418 if (*SvPV(PL_subname,n_a) == '?') {
4419 sv_setpv(PL_subname,"__ANON__");
4426 LOP(OP_SYSTEM,XREF);
4429 LOP(OP_SYMLINK,XTERM);
4432 LOP(OP_SYSCALL,XTERM);
4435 LOP(OP_SYSOPEN,XTERM);
4438 LOP(OP_SYSSEEK,XTERM);
4441 LOP(OP_SYSREAD,XTERM);
4444 LOP(OP_SYSWRITE,XTERM);
4448 TERM(sublex_start());
4469 LOP(OP_TRUNCATE,XTERM);
4481 yylval.ival = PL_curcop->cop_line;
4485 yylval.ival = PL_curcop->cop_line;
4489 LOP(OP_UNLINK,XTERM);
4495 LOP(OP_UNPACK,XTERM);
4498 LOP(OP_UTIME,XTERM);
4501 if (ckWARN(WARN_OCTAL)) {
4502 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4503 if (*d != '0' && isDIGIT(*d))
4504 yywarn("umask: argument is missing initial 0");
4509 LOP(OP_UNSHIFT,XTERM);
4512 if (PL_expect != XSTATE)
4513 yyerror("\"use\" not allowed in expression");
4516 s = force_version(s);
4517 if(*s == ';' || (s = skipspace(s), *s == ';')) {
4518 PL_nextval[PL_nexttoke].opval = Nullop;
4523 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4524 s = force_version(s);
4537 yylval.ival = PL_curcop->cop_line;
4541 PL_hints |= HINT_BLOCK_SCOPE;
4548 LOP(OP_WAITPID,XTERM);
4556 static char ctl_l[2];
4558 if (ctl_l[0] == '\0')
4559 ctl_l[0] = toCTRL('L');
4560 gv_fetchpv(ctl_l,TRUE, SVt_PV);
4563 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
4568 if (PL_expect == XOPERATOR)
4574 yylval.ival = OP_XOR;
4579 TERM(sublex_start());
4585 Perl_keyword(pTHX_ register char *d, I32 len)
4590 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
4591 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
4592 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
4593 if (strEQ(d,"__DATA__")) return KEY___DATA__;
4594 if (strEQ(d,"__END__")) return KEY___END__;
4598 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
4603 if (strEQ(d,"and")) return -KEY_and;
4604 if (strEQ(d,"abs")) return -KEY_abs;
4607 if (strEQ(d,"alarm")) return -KEY_alarm;
4608 if (strEQ(d,"atan2")) return -KEY_atan2;
4611 if (strEQ(d,"accept")) return -KEY_accept;
4616 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
4619 if (strEQ(d,"bless")) return -KEY_bless;
4620 if (strEQ(d,"bind")) return -KEY_bind;
4621 if (strEQ(d,"binmode")) return -KEY_binmode;
4624 if (strEQ(d,"CORE")) return -KEY_CORE;
4629 if (strEQ(d,"cmp")) return -KEY_cmp;
4630 if (strEQ(d,"chr")) return -KEY_chr;
4631 if (strEQ(d,"cos")) return -KEY_cos;
4634 if (strEQ(d,"chop")) return KEY_chop;
4637 if (strEQ(d,"close")) return -KEY_close;
4638 if (strEQ(d,"chdir")) return -KEY_chdir;
4639 if (strEQ(d,"chomp")) return KEY_chomp;
4640 if (strEQ(d,"chmod")) return -KEY_chmod;
4641 if (strEQ(d,"chown")) return -KEY_chown;
4642 if (strEQ(d,"crypt")) return -KEY_crypt;
4645 if (strEQ(d,"chroot")) return -KEY_chroot;
4646 if (strEQ(d,"caller")) return -KEY_caller;
4649 if (strEQ(d,"connect")) return -KEY_connect;
4652 if (strEQ(d,"closedir")) return -KEY_closedir;
4653 if (strEQ(d,"continue")) return -KEY_continue;
4658 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
4663 if (strEQ(d,"do")) return KEY_do;
4666 if (strEQ(d,"die")) return -KEY_die;
4669 if (strEQ(d,"dump")) return -KEY_dump;
4672 if (strEQ(d,"delete")) return KEY_delete;
4675 if (strEQ(d,"defined")) return KEY_defined;
4676 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
4679 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
4684 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
4685 if (strEQ(d,"END")) return KEY_END;
4690 if (strEQ(d,"eq")) return -KEY_eq;
4693 if (strEQ(d,"eof")) return -KEY_eof;
4694 if (strEQ(d,"exp")) return -KEY_exp;
4697 if (strEQ(d,"else")) return KEY_else;
4698 if (strEQ(d,"exit")) return -KEY_exit;
4699 if (strEQ(d,"eval")) return KEY_eval;
4700 if (strEQ(d,"exec")) return -KEY_exec;
4701 if (strEQ(d,"each")) return KEY_each;
4704 if (strEQ(d,"elsif")) return KEY_elsif;
4707 if (strEQ(d,"exists")) return KEY_exists;
4708 if (strEQ(d,"elseif")) Perl_warn(aTHX_ "elseif should be elsif");
4711 if (strEQ(d,"endgrent")) return -KEY_endgrent;
4712 if (strEQ(d,"endpwent")) return -KEY_endpwent;
4715 if (strEQ(d,"endnetent")) return -KEY_endnetent;
4718 if (strEQ(d,"endhostent")) return -KEY_endhostent;
4719 if (strEQ(d,"endservent")) return -KEY_endservent;
4722 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
4729 if (strEQ(d,"for")) return KEY_for;
4732 if (strEQ(d,"fork")) return -KEY_fork;
4735 if (strEQ(d,"fcntl")) return -KEY_fcntl;
4736 if (strEQ(d,"flock")) return -KEY_flock;
4739 if (strEQ(d,"format")) return KEY_format;
4740 if (strEQ(d,"fileno")) return -KEY_fileno;
4743 if (strEQ(d,"foreach")) return KEY_foreach;
4746 if (strEQ(d,"formline")) return -KEY_formline;
4752 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
4753 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
4757 if (strnEQ(d,"get",3)) {
4762 if (strEQ(d,"ppid")) return -KEY_getppid;
4763 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
4766 if (strEQ(d,"pwent")) return -KEY_getpwent;
4767 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
4768 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
4771 if (strEQ(d,"peername")) return -KEY_getpeername;
4772 if (strEQ(d,"protoent")) return -KEY_getprotoent;
4773 if (strEQ(d,"priority")) return -KEY_getpriority;
4776 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
4779 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
4783 else if (*d == 'h') {
4784 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
4785 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
4786 if (strEQ(d,"hostent")) return -KEY_gethostent;
4788 else if (*d == 'n') {
4789 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
4790 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
4791 if (strEQ(d,"netent")) return -KEY_getnetent;
4793 else if (*d == 's') {
4794 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
4795 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
4796 if (strEQ(d,"servent")) return -KEY_getservent;
4797 if (strEQ(d,"sockname")) return -KEY_getsockname;
4798 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
4800 else if (*d == 'g') {
4801 if (strEQ(d,"grent")) return -KEY_getgrent;
4802 if (strEQ(d,"grnam")) return -KEY_getgrnam;
4803 if (strEQ(d,"grgid")) return -KEY_getgrgid;
4805 else if (*d == 'l') {
4806 if (strEQ(d,"login")) return -KEY_getlogin;
4808 else if (strEQ(d,"c")) return -KEY_getc;
4813 if (strEQ(d,"gt")) return -KEY_gt;
4814 if (strEQ(d,"ge")) return -KEY_ge;
4817 if (strEQ(d,"grep")) return KEY_grep;
4818 if (strEQ(d,"goto")) return KEY_goto;
4819 if (strEQ(d,"glob")) return KEY_glob;
4822 if (strEQ(d,"gmtime")) return -KEY_gmtime;
4827 if (strEQ(d,"hex")) return -KEY_hex;
4830 if (strEQ(d,"INIT")) return KEY_INIT;
4835 if (strEQ(d,"if")) return KEY_if;
4838 if (strEQ(d,"int")) return -KEY_int;
4841 if (strEQ(d,"index")) return -KEY_index;
4842 if (strEQ(d,"ioctl")) return -KEY_ioctl;
4847 if (strEQ(d,"join")) return -KEY_join;
4851 if (strEQ(d,"keys")) return KEY_keys;
4852 if (strEQ(d,"kill")) return -KEY_kill;
4857 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
4858 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
4864 if (strEQ(d,"lt")) return -KEY_lt;
4865 if (strEQ(d,"le")) return -KEY_le;
4866 if (strEQ(d,"lc")) return -KEY_lc;
4869 if (strEQ(d,"log")) return -KEY_log;
4872 if (strEQ(d,"last")) return KEY_last;
4873 if (strEQ(d,"link")) return -KEY_link;
4874 if (strEQ(d,"lock")) return -KEY_lock;
4877 if (strEQ(d,"local")) return KEY_local;
4878 if (strEQ(d,"lstat")) return -KEY_lstat;
4881 if (strEQ(d,"length")) return -KEY_length;
4882 if (strEQ(d,"listen")) return -KEY_listen;
4885 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
4888 if (strEQ(d,"localtime")) return -KEY_localtime;
4894 case 1: return KEY_m;
4896 if (strEQ(d,"my")) return KEY_my;
4899 if (strEQ(d,"map")) return KEY_map;
4902 if (strEQ(d,"mkdir")) return -KEY_mkdir;
4905 if (strEQ(d,"msgctl")) return -KEY_msgctl;
4906 if (strEQ(d,"msgget")) return -KEY_msgget;
4907 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
4908 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
4913 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
4916 if (strEQ(d,"next")) return KEY_next;
4917 if (strEQ(d,"ne")) return -KEY_ne;
4918 if (strEQ(d,"not")) return -KEY_not;
4919 if (strEQ(d,"no")) return KEY_no;
4924 if (strEQ(d,"or")) return -KEY_or;
4927 if (strEQ(d,"ord")) return -KEY_ord;
4928 if (strEQ(d,"oct")) return -KEY_oct;
4929 if (strEQ(d,"our")) { deprecate("reserved word \"our\"");
4933 if (strEQ(d,"open")) return -KEY_open;
4936 if (strEQ(d,"opendir")) return -KEY_opendir;
4943 if (strEQ(d,"pop")) return KEY_pop;
4944 if (strEQ(d,"pos")) return KEY_pos;
4947 if (strEQ(d,"push")) return KEY_push;
4948 if (strEQ(d,"pack")) return -KEY_pack;
4949 if (strEQ(d,"pipe")) return -KEY_pipe;
4952 if (strEQ(d,"print")) return KEY_print;
4955 if (strEQ(d,"printf")) return KEY_printf;
4958 if (strEQ(d,"package")) return KEY_package;
4961 if (strEQ(d,"prototype")) return KEY_prototype;
4966 if (strEQ(d,"q")) return KEY_q;
4967 if (strEQ(d,"qr")) return KEY_qr;
4968 if (strEQ(d,"qq")) return KEY_qq;
4969 if (strEQ(d,"qw")) return KEY_qw;
4970 if (strEQ(d,"qx")) return KEY_qx;
4972 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
4977 if (strEQ(d,"ref")) return -KEY_ref;
4980 if (strEQ(d,"read")) return -KEY_read;
4981 if (strEQ(d,"rand")) return -KEY_rand;
4982 if (strEQ(d,"recv")) return -KEY_recv;
4983 if (strEQ(d,"redo")) return KEY_redo;
4986 if (strEQ(d,"rmdir")) return -KEY_rmdir;
4987 if (strEQ(d,"reset")) return -KEY_reset;
4990 if (strEQ(d,"return")) return KEY_return;
4991 if (strEQ(d,"rename")) return -KEY_rename;
4992 if (strEQ(d,"rindex")) return -KEY_rindex;
4995 if (strEQ(d,"require")) return -KEY_require;
4996 if (strEQ(d,"reverse")) return -KEY_reverse;
4997 if (strEQ(d,"readdir")) return -KEY_readdir;
5000 if (strEQ(d,"readlink")) return -KEY_readlink;
5001 if (strEQ(d,"readline")) return -KEY_readline;
5002 if (strEQ(d,"readpipe")) return -KEY_readpipe;
5005 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
5011 case 0: return KEY_s;
5013 if (strEQ(d,"scalar")) return KEY_scalar;
5018 if (strEQ(d,"seek")) return -KEY_seek;
5019 if (strEQ(d,"send")) return -KEY_send;
5022 if (strEQ(d,"semop")) return -KEY_semop;
5025 if (strEQ(d,"select")) return -KEY_select;
5026 if (strEQ(d,"semctl")) return -KEY_semctl;
5027 if (strEQ(d,"semget")) return -KEY_semget;
5030 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
5031 if (strEQ(d,"seekdir")) return -KEY_seekdir;
5034 if (strEQ(d,"setpwent")) return -KEY_setpwent;
5035 if (strEQ(d,"setgrent")) return -KEY_setgrent;
5038 if (strEQ(d,"setnetent")) return -KEY_setnetent;
5041 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
5042 if (strEQ(d,"sethostent")) return -KEY_sethostent;
5043 if (strEQ(d,"setservent")) return -KEY_setservent;
5046 if (strEQ(d,"setpriority")) return -KEY_setpriority;
5047 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
5054 if (strEQ(d,"shift")) return KEY_shift;
5057 if (strEQ(d,"shmctl")) return -KEY_shmctl;
5058 if (strEQ(d,"shmget")) return -KEY_shmget;
5061 if (strEQ(d,"shmread")) return -KEY_shmread;
5064 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
5065 if (strEQ(d,"shutdown")) return -KEY_shutdown;
5070 if (strEQ(d,"sin")) return -KEY_sin;
5073 if (strEQ(d,"sleep")) return -KEY_sleep;
5076 if (strEQ(d,"sort")) return KEY_sort;
5077 if (strEQ(d,"socket")) return -KEY_socket;
5078 if (strEQ(d,"socketpair")) return -KEY_socketpair;
5081 if (strEQ(d,"split")) return KEY_split;
5082 if (strEQ(d,"sprintf")) return -KEY_sprintf;
5083 if (strEQ(d,"splice")) return KEY_splice;
5086 if (strEQ(d,"sqrt")) return -KEY_sqrt;
5089 if (strEQ(d,"srand")) return -KEY_srand;
5092 if (strEQ(d,"stat")) return -KEY_stat;
5093 if (strEQ(d,"study")) return KEY_study;
5096 if (strEQ(d,"substr")) return -KEY_substr;
5097 if (strEQ(d,"sub")) return KEY_sub;
5102 if (strEQ(d,"system")) return -KEY_system;
5105 if (strEQ(d,"symlink")) return -KEY_symlink;
5106 if (strEQ(d,"syscall")) return -KEY_syscall;
5107 if (strEQ(d,"sysopen")) return -KEY_sysopen;
5108 if (strEQ(d,"sysread")) return -KEY_sysread;
5109 if (strEQ(d,"sysseek")) return -KEY_sysseek;
5112 if (strEQ(d,"syswrite")) return -KEY_syswrite;
5121 if (strEQ(d,"tr")) return KEY_tr;
5124 if (strEQ(d,"tie")) return KEY_tie;
5127 if (strEQ(d,"tell")) return -KEY_tell;
5128 if (strEQ(d,"tied")) return KEY_tied;
5129 if (strEQ(d,"time")) return -KEY_time;
5132 if (strEQ(d,"times")) return -KEY_times;
5135 if (strEQ(d,"telldir")) return -KEY_telldir;
5138 if (strEQ(d,"truncate")) return -KEY_truncate;
5145 if (strEQ(d,"uc")) return -KEY_uc;
5148 if (strEQ(d,"use")) return KEY_use;
5151 if (strEQ(d,"undef")) return KEY_undef;
5152 if (strEQ(d,"until")) return KEY_until;
5153 if (strEQ(d,"untie")) return KEY_untie;
5154 if (strEQ(d,"utime")) return -KEY_utime;
5155 if (strEQ(d,"umask")) return -KEY_umask;
5158 if (strEQ(d,"unless")) return KEY_unless;
5159 if (strEQ(d,"unpack")) return -KEY_unpack;
5160 if (strEQ(d,"unlink")) return -KEY_unlink;
5163 if (strEQ(d,"unshift")) return KEY_unshift;
5164 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
5169 if (strEQ(d,"values")) return -KEY_values;
5170 if (strEQ(d,"vec")) return -KEY_vec;
5175 if (strEQ(d,"warn")) return -KEY_warn;
5176 if (strEQ(d,"wait")) return -KEY_wait;
5179 if (strEQ(d,"while")) return KEY_while;
5180 if (strEQ(d,"write")) return -KEY_write;
5183 if (strEQ(d,"waitpid")) return -KEY_waitpid;
5186 if (strEQ(d,"wantarray")) return -KEY_wantarray;
5191 if (len == 1) return -KEY_x;
5192 if (strEQ(d,"xor")) return -KEY_xor;
5195 if (len == 1) return KEY_y;
5204 S_checkcomma(pTHX_ register char *s, char *name, char *what)
5208 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
5209 dTHR; /* only for ckWARN */
5210 if (ckWARN(WARN_SYNTAX)) {
5212 for (w = s+2; *w && level; w++) {
5219 for (; *w && isSPACE(*w); w++) ;
5220 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
5221 Perl_warner(aTHX_ WARN_SYNTAX, "%s (...) interpreted as function",name);
5224 while (s < PL_bufend && isSPACE(*s))
5228 while (s < PL_bufend && isSPACE(*s))
5230 if (isIDFIRST_lazy(s)) {
5232 while (isALNUM_lazy(s))
5234 while (s < PL_bufend && isSPACE(*s))
5239 kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
5243 Perl_croak(aTHX_ "No comma allowed after %s", what);
5249 S_new_constant(pTHX_ char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)
5252 HV *table = GvHV(PL_hintgv); /* ^H */
5255 bool oldcatch = CATCH_GET;
5260 yyerror("%^H is not defined");
5263 cvp = hv_fetch(table, key, strlen(key), FALSE);
5264 if (!cvp || !SvOK(*cvp)) {
5266 sprintf(buf,"$^H{%s} is not defined", key);
5270 sv_2mortal(sv); /* Parent created it permanently */
5273 pv = sv_2mortal(newSVpvn(s, len));
5275 typesv = sv_2mortal(newSVpv(type, 0));
5277 typesv = &PL_sv_undef;
5279 Zero(&myop, 1, BINOP);
5280 myop.op_last = (OP *) &myop;
5281 myop.op_next = Nullop;
5282 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
5284 PUSHSTACKi(PERLSI_OVERLOAD);
5287 PL_op = (OP *) &myop;
5288 if (PERLDB_SUB && PL_curstash != PL_debstash)
5289 PL_op->op_private |= OPpENTERSUB_DB;
5291 Perl_pp_pushmark(aTHX);
5300 if (PL_op = Perl_pp_entersub(aTHX))
5307 CATCH_SET(oldcatch);
5312 sprintf(buf,"Call to &{$^H{%s}} did not return a defined value", key);
5315 return SvREFCNT_inc(res);
5319 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
5321 register char *d = dest;
5322 register char *e = d + destlen - 3; /* two-character token, ending NUL */
5325 Perl_croak(aTHX_ ident_too_long);
5326 if (isALNUM(*s)) /* UTF handled below */
5328 else if (*s == '\'' && allow_package && isIDFIRST_lazy(s+1)) {
5333 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
5337 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5338 char *t = s + UTF8SKIP(s);
5339 while (*t & 0x80 && is_utf8_mark((U8*)t))
5341 if (d + (t - s) > e)
5342 Perl_croak(aTHX_ ident_too_long);
5343 Copy(s, d, t - s, char);
5356 S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
5363 if (PL_lex_brackets == 0)
5364 PL_lex_fakebrack = 0;
5368 e = d + destlen - 3; /* two-character token, ending NUL */
5370 while (isDIGIT(*s)) {
5372 Perl_croak(aTHX_ ident_too_long);
5379 Perl_croak(aTHX_ ident_too_long);
5380 if (isALNUM(*s)) /* UTF handled below */
5382 else if (*s == '\'' && isIDFIRST_lazy(s+1)) {
5387 else if (*s == ':' && s[1] == ':') {
5391 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5392 char *t = s + UTF8SKIP(s);
5393 while (*t & 0x80 && is_utf8_mark((U8*)t))
5395 if (d + (t - s) > e)
5396 Perl_croak(aTHX_ ident_too_long);
5397 Copy(s, d, t - s, char);
5408 if (PL_lex_state != LEX_NORMAL)
5409 PL_lex_state = LEX_INTERPENDMAYBE;
5412 if (*s == '$' && s[1] &&
5413 (isALNUM_lazy(s+1) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
5426 if (*d == '^' && *s && isCONTROLVAR(*s)) {
5431 if (isSPACE(s[-1])) {
5434 if (ch != ' ' && ch != '\t') {
5440 if (isIDFIRST_lazy(d)) {
5444 while (e < send && isALNUM_lazy(e) || *e == ':') {
5446 while (e < send && *e & 0x80 && is_utf8_mark((U8*)e))
5449 Copy(s, d, e - s, char);
5454 while ((isALNUM(*s) || *s == ':') && d < e)
5457 Perl_croak(aTHX_ ident_too_long);
5460 while (s < send && (*s == ' ' || *s == '\t')) s++;
5461 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
5462 dTHR; /* only for ckWARN */
5463 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
5464 char *brack = *s == '[' ? "[...]" : "{...}";
5465 Perl_warner(aTHX_ WARN_AMBIGUOUS,
5466 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
5467 funny, dest, brack, funny, dest, brack);
5469 PL_lex_fakebrack = PL_lex_brackets+1;
5471 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5475 /* Handle extended ${^Foo} variables
5476 * 1999-02-27 mjd-perl-patch@plover.com */
5477 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
5481 while (isALNUM(*s) && d < e) {
5485 Perl_croak(aTHX_ ident_too_long);
5490 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
5491 PL_lex_state = LEX_INTERPEND;
5494 if (PL_lex_state == LEX_NORMAL) {
5495 dTHR; /* only for ckWARN */
5496 if (ckWARN(WARN_AMBIGUOUS) &&
5497 (keyword(dest, d - dest) || get_cv(dest, FALSE)))
5499 Perl_warner(aTHX_ WARN_AMBIGUOUS,
5500 "Ambiguous use of %c{%s} resolved to %c%s",
5501 funny, dest, funny, dest);
5506 s = bracket; /* let the parser handle it */
5510 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
5511 PL_lex_state = LEX_INTERPEND;
5516 Perl_pmflag(pTHX_ U16 *pmfl, int ch)
5521 *pmfl |= PMf_GLOBAL;
5523 *pmfl |= PMf_CONTINUE;
5527 *pmfl |= PMf_MULTILINE;
5529 *pmfl |= PMf_SINGLELINE;
5531 *pmfl |= PMf_EXTENDED;
5535 S_scan_pat(pTHX_ char *start, I32 type)
5540 s = scan_str(start);
5543 SvREFCNT_dec(PL_lex_stuff);
5544 PL_lex_stuff = Nullsv;
5545 Perl_croak(aTHX_ "Search pattern not terminated");
5548 pm = (PMOP*)newPMOP(type, 0);
5549 if (PL_multi_open == '?')
5550 pm->op_pmflags |= PMf_ONCE;
5552 while (*s && strchr("iomsx", *s))
5553 pmflag(&pm->op_pmflags,*s++);
5556 while (*s && strchr("iogcmsx", *s))
5557 pmflag(&pm->op_pmflags,*s++);
5559 pm->op_pmpermflags = pm->op_pmflags;
5561 PL_lex_op = (OP*)pm;
5562 yylval.ival = OP_MATCH;
5567 S_scan_subst(pTHX_ char *start)
5574 yylval.ival = OP_NULL;
5576 s = scan_str(start);
5580 SvREFCNT_dec(PL_lex_stuff);
5581 PL_lex_stuff = Nullsv;
5582 Perl_croak(aTHX_ "Substitution pattern not terminated");
5585 if (s[-1] == PL_multi_open)
5588 first_start = PL_multi_start;
5592 SvREFCNT_dec(PL_lex_stuff);
5593 PL_lex_stuff = Nullsv;
5595 SvREFCNT_dec(PL_lex_repl);
5596 PL_lex_repl = Nullsv;
5597 Perl_croak(aTHX_ "Substitution replacement not terminated");
5599 PL_multi_start = first_start; /* so whole substitution is taken together */
5601 pm = (PMOP*)newPMOP(OP_SUBST, 0);
5607 else if (strchr("iogcmsx", *s))
5608 pmflag(&pm->op_pmflags,*s++);
5615 PL_sublex_info.super_bufptr = s;
5616 PL_sublex_info.super_bufend = PL_bufend;
5618 pm->op_pmflags |= PMf_EVAL;
5619 repl = newSVpvn("",0);
5621 sv_catpv(repl, es ? "eval " : "do ");
5622 sv_catpvn(repl, "{ ", 2);
5623 sv_catsv(repl, PL_lex_repl);
5624 sv_catpvn(repl, " };", 2);
5626 SvREFCNT_dec(PL_lex_repl);
5630 pm->op_pmpermflags = pm->op_pmflags;
5631 PL_lex_op = (OP*)pm;
5632 yylval.ival = OP_SUBST;
5637 S_scan_trans(pTHX_ char *start)
5648 yylval.ival = OP_NULL;
5650 s = scan_str(start);
5653 SvREFCNT_dec(PL_lex_stuff);
5654 PL_lex_stuff = Nullsv;
5655 Perl_croak(aTHX_ "Transliteration pattern not terminated");
5657 if (s[-1] == PL_multi_open)
5663 SvREFCNT_dec(PL_lex_stuff);
5664 PL_lex_stuff = Nullsv;
5666 SvREFCNT_dec(PL_lex_repl);
5667 PL_lex_repl = Nullsv;
5668 Perl_croak(aTHX_ "Transliteration replacement not terminated");
5672 o = newSVOP(OP_TRANS, 0, 0);
5673 utf8 = OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF;
5676 New(803,tbl,256,short);
5677 o = newPVOP(OP_TRANS, 0, (char*)tbl);
5681 complement = del = squash = 0;
5682 while (strchr("cdsCU", *s)) {
5684 complement = OPpTRANS_COMPLEMENT;
5686 del = OPpTRANS_DELETE;
5688 squash = OPpTRANS_SQUASH;
5693 utf8 &= ~OPpTRANS_FROM_UTF;
5695 utf8 |= OPpTRANS_FROM_UTF;
5699 utf8 &= ~OPpTRANS_TO_UTF;
5701 utf8 |= OPpTRANS_TO_UTF;
5704 Perl_croak(aTHX_ "Too many /C and /U options");
5709 o->op_private = del|squash|complement|utf8;
5712 yylval.ival = OP_TRANS;
5717 S_scan_heredoc(pTHX_ register char *s)
5721 I32 op_type = OP_SCALAR;
5728 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
5732 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
5735 for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5736 if (*peek && strchr("`'\"",*peek)) {
5739 s = delimcpy(d, e, s, PL_bufend, term, &len);
5749 if (!isALNUM_lazy(s))
5750 deprecate("bare << to mean <<\"\"");
5751 for (; isALNUM_lazy(s); s++) {
5756 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
5757 Perl_croak(aTHX_ "Delimiter for here document is too long");
5760 len = d - PL_tokenbuf;
5761 #ifndef PERL_STRICT_CR
5762 d = strchr(s, '\r');
5766 while (s < PL_bufend) {
5772 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
5781 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5786 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
5787 herewas = newSVpvn(s,PL_bufend-s);
5789 s--, herewas = newSVpvn(s,d-s);
5790 s += SvCUR(herewas);
5792 tmpstr = NEWSV(87,79);
5793 sv_upgrade(tmpstr, SVt_PVIV);
5798 else if (term == '`') {
5799 op_type = OP_BACKTICK;
5800 SvIVX(tmpstr) = '\\';
5804 PL_multi_start = PL_curcop->cop_line;
5805 PL_multi_open = PL_multi_close = '<';
5806 term = *PL_tokenbuf;
5807 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
5808 char *bufptr = PL_sublex_info.super_bufptr;
5809 char *bufend = PL_sublex_info.super_bufend;
5810 char *olds = s - SvCUR(herewas);
5811 s = strchr(bufptr, '\n');
5815 while (s < bufend &&
5816 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
5818 PL_curcop->cop_line++;
5821 PL_curcop->cop_line = PL_multi_start;
5822 missingterm(PL_tokenbuf);
5824 sv_setpvn(herewas,bufptr,d-bufptr+1);
5825 sv_setpvn(tmpstr,d+1,s-d);
5827 sv_catpvn(herewas,s,bufend-s);
5828 (void)strcpy(bufptr,SvPVX(herewas));
5835 while (s < PL_bufend &&
5836 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
5838 PL_curcop->cop_line++;
5840 if (s >= PL_bufend) {
5841 PL_curcop->cop_line = PL_multi_start;
5842 missingterm(PL_tokenbuf);
5844 sv_setpvn(tmpstr,d+1,s-d);
5846 PL_curcop->cop_line++; /* the preceding stmt passes a newline */
5848 sv_catpvn(herewas,s,PL_bufend-s);
5849 sv_setsv(PL_linestr,herewas);
5850 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
5851 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5854 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
5855 while (s >= PL_bufend) { /* multiple line string? */
5857 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5858 PL_curcop->cop_line = PL_multi_start;
5859 missingterm(PL_tokenbuf);
5861 PL_curcop->cop_line++;
5862 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5863 #ifndef PERL_STRICT_CR
5864 if (PL_bufend - PL_linestart >= 2) {
5865 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
5866 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
5868 PL_bufend[-2] = '\n';
5870 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5872 else if (PL_bufend[-1] == '\r')
5873 PL_bufend[-1] = '\n';
5875 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
5876 PL_bufend[-1] = '\n';
5878 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5879 SV *sv = NEWSV(88,0);
5881 sv_upgrade(sv, SVt_PVMG);
5882 sv_setsv(sv,PL_linestr);
5883 av_store(GvAV(PL_curcop->cop_filegv),
5884 (I32)PL_curcop->cop_line,sv);
5886 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
5889 sv_catsv(PL_linestr,herewas);
5890 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5894 sv_catsv(tmpstr,PL_linestr);
5899 PL_multi_end = PL_curcop->cop_line;
5900 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
5901 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
5902 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
5904 SvREFCNT_dec(herewas);
5905 PL_lex_stuff = tmpstr;
5906 yylval.ival = op_type;
5911 takes: current position in input buffer
5912 returns: new position in input buffer
5913 side-effects: yylval and lex_op are set.
5918 <FH> read from filehandle
5919 <pkg::FH> read from package qualified filehandle
5920 <pkg'FH> read from package qualified filehandle
5921 <$fh> read from filehandle in $fh
5927 S_scan_inputsymbol(pTHX_ char *start)
5929 register char *s = start; /* current position in buffer */
5935 d = PL_tokenbuf; /* start of temp holding space */
5936 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
5937 end = strchr(s, '\n');
5940 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
5942 /* die if we didn't have space for the contents of the <>,
5943 or if it didn't end, or if we see a newline
5946 if (len >= sizeof PL_tokenbuf)
5947 Perl_croak(aTHX_ "Excessively long <> operator");
5949 Perl_croak(aTHX_ "Unterminated <> operator");
5954 Remember, only scalar variables are interpreted as filehandles by
5955 this code. Anything more complex (e.g., <$fh{$num}>) will be
5956 treated as a glob() call.
5957 This code makes use of the fact that except for the $ at the front,
5958 a scalar variable and a filehandle look the same.
5960 if (*d == '$' && d[1]) d++;
5962 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
5963 while (*d && (isALNUM_lazy(d) || *d == '\'' || *d == ':'))
5966 /* If we've tried to read what we allow filehandles to look like, and
5967 there's still text left, then it must be a glob() and not a getline.
5968 Use scan_str to pull out the stuff between the <> and treat it
5969 as nothing more than a string.
5972 if (d - PL_tokenbuf != len) {
5973 yylval.ival = OP_GLOB;
5975 s = scan_str(start);
5977 Perl_croak(aTHX_ "Glob not terminated");
5981 /* we're in a filehandle read situation */
5984 /* turn <> into <ARGV> */
5986 (void)strcpy(d,"ARGV");
5988 /* if <$fh>, create the ops to turn the variable into a
5994 /* try to find it in the pad for this block, otherwise find
5995 add symbol table ops
5997 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
5998 OP *o = newOP(OP_PADSV, 0);
6000 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, o);
6003 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
6004 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
6005 newUNOP(OP_RV2SV, 0,
6006 newGVOP(OP_GV, 0, gv)));
6008 PL_lex_op->op_flags |= OPf_SPECIAL;
6009 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
6010 yylval.ival = OP_NULL;
6013 /* If it's none of the above, it must be a literal filehandle
6014 (<Foo::BAR> or <FOO>) so build a simple readline OP */
6016 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
6017 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
6018 yylval.ival = OP_NULL;
6027 takes: start position in buffer
6028 returns: position to continue reading from buffer
6029 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
6030 updates the read buffer.
6032 This subroutine pulls a string out of the input. It is called for:
6033 q single quotes q(literal text)
6034 ' single quotes 'literal text'
6035 qq double quotes qq(interpolate $here please)
6036 " double quotes "interpolate $here please"
6037 qx backticks qx(/bin/ls -l)
6038 ` backticks `/bin/ls -l`
6039 qw quote words @EXPORT_OK = qw( func() $spam )
6040 m// regexp match m/this/
6041 s/// regexp substitute s/this/that/
6042 tr/// string transliterate tr/this/that/
6043 y/// string transliterate y/this/that/
6044 ($*@) sub prototypes sub foo ($)
6045 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
6047 In most of these cases (all but <>, patterns and transliterate)
6048 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
6049 calls scan_str(). s/// makes yylex() call scan_subst() which calls
6050 scan_str(). tr/// and y/// make yylex() call scan_trans() which
6053 It skips whitespace before the string starts, and treats the first
6054 character as the delimiter. If the delimiter is one of ([{< then
6055 the corresponding "close" character )]}> is used as the closing
6056 delimiter. It allows quoting of delimiters, and if the string has
6057 balanced delimiters ([{<>}]) it allows nesting.
6059 The lexer always reads these strings into lex_stuff, except in the
6060 case of the operators which take *two* arguments (s/// and tr///)
6061 when it checks to see if lex_stuff is full (presumably with the 1st
6062 arg to s or tr) and if so puts the string into lex_repl.
6067 S_scan_str(pTHX_ char *start)
6070 SV *sv; /* scalar value: string */
6071 char *tmps; /* temp string, used for delimiter matching */
6072 register char *s = start; /* current position in the buffer */
6073 register char term; /* terminating character */
6074 register char *to; /* current position in the sv's data */
6075 I32 brackets = 1; /* bracket nesting level */
6077 /* skip space before the delimiter */
6081 /* mark where we are, in case we need to report errors */
6084 /* after skipping whitespace, the next character is the terminator */
6086 /* mark where we are */
6087 PL_multi_start = PL_curcop->cop_line;
6088 PL_multi_open = term;
6090 /* find corresponding closing delimiter */
6091 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
6093 PL_multi_close = term;
6095 /* create a new SV to hold the contents. 87 is leak category, I'm
6096 assuming. 79 is the SV's initial length. What a random number. */
6098 sv_upgrade(sv, SVt_PVIV);
6100 (void)SvPOK_only(sv); /* validate pointer */
6102 /* move past delimiter and try to read a complete string */
6105 /* extend sv if need be */
6106 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
6107 /* set 'to' to the next character in the sv's string */
6108 to = SvPVX(sv)+SvCUR(sv);
6110 /* if open delimiter is the close delimiter read unbridle */
6111 if (PL_multi_open == PL_multi_close) {
6112 for (; s < PL_bufend; s++,to++) {
6113 /* embedded newlines increment the current line number */
6114 if (*s == '\n' && !PL_rsfp)
6115 PL_curcop->cop_line++;
6116 /* handle quoted delimiters */
6117 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
6120 /* any other quotes are simply copied straight through */
6124 /* terminate when run out of buffer (the for() condition), or
6125 have found the terminator */
6126 else if (*s == term)
6132 /* if the terminator isn't the same as the start character (e.g.,
6133 matched brackets), we have to allow more in the quoting, and
6134 be prepared for nested brackets.
6137 /* read until we run out of string, or we find the terminator */
6138 for (; s < PL_bufend; s++,to++) {
6139 /* embedded newlines increment the line count */
6140 if (*s == '\n' && !PL_rsfp)
6141 PL_curcop->cop_line++;
6142 /* backslashes can escape the open or closing characters */
6143 if (*s == '\\' && s+1 < PL_bufend) {
6144 if ((s[1] == PL_multi_open) || (s[1] == PL_multi_close))
6149 /* allow nested opens and closes */
6150 else if (*s == PL_multi_close && --brackets <= 0)
6152 else if (*s == PL_multi_open)
6157 /* terminate the copied string and update the sv's end-of-string */
6159 SvCUR_set(sv, to - SvPVX(sv));
6162 * this next chunk reads more into the buffer if we're not done yet
6165 if (s < PL_bufend) break; /* handle case where we are done yet :-) */
6167 #ifndef PERL_STRICT_CR
6168 if (to - SvPVX(sv) >= 2) {
6169 if ((to[-2] == '\r' && to[-1] == '\n') ||
6170 (to[-2] == '\n' && to[-1] == '\r'))
6174 SvCUR_set(sv, to - SvPVX(sv));
6176 else if (to[-1] == '\r')
6179 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
6183 /* if we're out of file, or a read fails, bail and reset the current
6184 line marker so we can report where the unterminated string began
6187 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6189 PL_curcop->cop_line = PL_multi_start;
6192 /* we read a line, so increment our line counter */
6193 PL_curcop->cop_line++;
6195 /* update debugger info */
6196 if (PERLDB_LINE && PL_curstash != PL_debstash) {
6197 SV *sv = NEWSV(88,0);
6199 sv_upgrade(sv, SVt_PVMG);
6200 sv_setsv(sv,PL_linestr);
6201 av_store(GvAV(PL_curcop->cop_filegv),
6202 (I32)PL_curcop->cop_line, sv);
6205 /* having changed the buffer, we must update PL_bufend */
6206 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6209 /* at this point, we have successfully read the delimited string */
6211 PL_multi_end = PL_curcop->cop_line;
6214 /* if we allocated too much space, give some back */
6215 if (SvCUR(sv) + 5 < SvLEN(sv)) {
6216 SvLEN_set(sv, SvCUR(sv) + 1);
6217 Renew(SvPVX(sv), SvLEN(sv), char);
6220 /* decide whether this is the first or second quoted string we've read
6233 takes: pointer to position in buffer
6234 returns: pointer to new position in buffer
6235 side-effects: builds ops for the constant in yylval.op
6237 Read a number in any of the formats that Perl accepts:
6239 0(x[0-7A-F]+)|([0-7]+)|(b[01])
6240 [\d_]+(\.[\d_]*)?[Ee](\d+)
6242 Underbars (_) are allowed in decimal numbers. If -w is on,
6243 underbars before a decimal point must be at three digit intervals.
6245 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
6248 If it reads a number without a decimal point or an exponent, it will
6249 try converting the number to an integer and see if it can do so
6250 without loss of precision.
6254 Perl_scan_num(pTHX_ char *start)
6256 register char *s = start; /* current position in buffer */
6257 register char *d; /* destination in temp buffer */
6258 register char *e; /* end of temp buffer */
6259 I32 tryiv; /* used to see if it can be an int */
6260 NV value; /* number read, as a double */
6261 SV *sv; /* place to put the converted number */
6262 I32 floatit; /* boolean: int or float? */
6263 char *lastub = 0; /* position of last underbar */
6264 static char number_too_long[] = "Number too long";
6266 /* We use the first character to decide what type of number this is */
6270 Perl_croak(aTHX_ "panic: scan_num");
6272 /* if it starts with a 0, it could be an octal number, a decimal in
6273 0.13 disguise, or a hexadecimal number, or a binary number.
6278 u holds the "number so far"
6279 shift the power of 2 of the base
6280 (hex == 4, octal == 3, binary == 1)
6281 overflowed was the number more than we can hold?
6283 Shift is used when we add a digit. It also serves as an "are
6284 we in octal/hex/binary?" indicator to disallow hex characters
6291 bool overflowed = FALSE;
6292 static NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
6293 static char* bases[5] = { "", "binary", "", "octal",
6295 static char* Bases[5] = { "", "Binary", "", "Octal",
6297 static char *maxima[5] = { "",
6298 "0b11111111111111111111111111111111",
6302 char *base, *Base, *max;
6308 } else if (s[1] == 'b') {
6312 /* check for a decimal in disguise */
6313 else if (s[1] == '.')
6315 /* so it must be octal */
6319 base = bases[shift];
6320 Base = Bases[shift];
6321 max = maxima[shift];
6323 /* read the rest of the number */
6325 /* x is used in the overflow test,
6326 b is the digit we're adding on */
6331 /* if we don't mention it, we're done */
6340 /* 8 and 9 are not octal */
6343 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
6346 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
6350 case '2': case '3': case '4':
6351 case '5': case '6': case '7':
6353 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
6357 b = *s++ & 15; /* ASCII digit -> value of digit */
6361 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
6362 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
6363 /* make sure they said 0x */
6368 /* Prepare to put the digit we have onto the end
6369 of the number so far. We check for overflows.
6374 x = u << shift; /* make room for the digit */
6376 if ((x >> shift) != u
6377 && !(PL_hints & HINT_NEW_BINARY)) {
6381 if (ckWARN_d(WARN_UNSAFE))
6382 Perl_warner(aTHX_ ((shift == 3) ?
6383 WARN_OCTAL : WARN_UNSAFE),
6384 "Integer overflow in %s number",
6387 u = x | b; /* add the digit to the end */
6390 n *= nvshift[shift];
6391 /* If an NV has not enough bits in its
6392 * mantissa to represent an UV this summing of
6393 * small low-order numbers is a waste of time
6394 * (because the NV cannot preserve the
6395 * low-order bits anyway): we could just
6396 * remember when did we overflow and in the
6397 * end just multiply n by the right
6405 /* if we get here, we had success: make a scalar value from
6412 if (ckWARN(WARN_UNSAFE) && (double) n > 4294967295.0)
6413 Perl_warner(aTHX_ WARN_UNSAFE,
6414 "%s number > %s non-portable",
6420 if (ckWARN(WARN_UNSAFE) && u > 4294967295)
6421 Perl_warner(aTHX_ WARN_UNSAFE,
6422 "%s number > %s non-portable",
6426 if ( PL_hints & HINT_NEW_BINARY)
6427 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
6432 handle decimal numbers.
6433 we're also sent here when we read a 0 as the first digit
6435 case '1': case '2': case '3': case '4': case '5':
6436 case '6': case '7': case '8': case '9': case '.':
6439 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
6442 /* read next group of digits and _ and copy into d */
6443 while (isDIGIT(*s) || *s == '_') {
6444 /* skip underscores, checking for misplaced ones
6448 dTHR; /* only for ckWARN */
6449 if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
6450 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
6454 /* check for end of fixed-length buffer */
6456 Perl_croak(aTHX_ number_too_long);
6457 /* if we're ok, copy the character */
6462 /* final misplaced underbar check */
6463 if (lastub && s - lastub != 3) {
6465 if (ckWARN(WARN_SYNTAX))
6466 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
6469 /* read a decimal portion if there is one. avoid
6470 3..5 being interpreted as the number 3. followed
6473 if (*s == '.' && s[1] != '.') {
6477 /* copy, ignoring underbars, until we run out of
6478 digits. Note: no misplaced underbar checks!
6480 for (; isDIGIT(*s) || *s == '_'; s++) {
6481 /* fixed length buffer check */
6483 Perl_croak(aTHX_ number_too_long);
6489 /* read exponent part, if present */
6490 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
6494 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
6495 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
6497 /* allow positive or negative exponent */
6498 if (*s == '+' || *s == '-')
6501 /* read digits of exponent (no underbars :-) */
6502 while (isDIGIT(*s)) {
6504 Perl_croak(aTHX_ number_too_long);
6509 /* terminate the string */
6512 /* make an sv from the string */
6515 value = Atof(PL_tokenbuf);
6518 See if we can make do with an integer value without loss of
6519 precision. We use I_V to cast to an int, because some
6520 compilers have issues. Then we try casting it back and see
6521 if it was the same. We only do this if we know we
6522 specifically read an integer.
6524 Note: if floatit is true, then we don't need to do the
6528 if (!floatit && (NV)tryiv == value)
6529 sv_setiv(sv, tryiv);
6531 sv_setnv(sv, value);
6532 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) )
6533 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
6534 (floatit ? "float" : "integer"), sv, Nullsv, NULL);
6538 /* make the op for the constant and return */
6540 yylval.opval = newSVOP(OP_CONST, 0, sv);
6546 S_scan_formline(pTHX_ register char *s)
6551 SV *stuff = newSVpvn("",0);
6552 bool needargs = FALSE;
6555 if (*s == '.' || *s == '}') {
6557 #ifdef PERL_STRICT_CR
6558 for (t = s+1;*t == ' ' || *t == '\t'; t++) ;
6560 for (t = s+1;*t == ' ' || *t == '\t' || *t == '\r'; t++) ;
6562 if (*t == '\n' || t == PL_bufend)
6565 if (PL_in_eval && !PL_rsfp) {
6566 eol = strchr(s,'\n');
6571 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6573 for (t = s; t < eol; t++) {
6574 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
6576 goto enough; /* ~~ must be first line in formline */
6578 if (*t == '@' || *t == '^')
6581 sv_catpvn(stuff, s, eol-s);
6585 s = filter_gets(PL_linestr, PL_rsfp, 0);
6586 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
6587 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
6590 yyerror("Format not terminated");
6600 PL_lex_state = LEX_NORMAL;
6601 PL_nextval[PL_nexttoke].ival = 0;
6605 PL_lex_state = LEX_FORMLINE;
6606 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
6608 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
6612 SvREFCNT_dec(stuff);
6613 PL_lex_formbrack = 0;
6624 PL_cshlen = strlen(PL_cshname);
6629 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
6632 I32 oldsavestack_ix = PL_savestack_ix;
6633 CV* outsidecv = PL_compcv;
6637 assert(SvTYPE(PL_compcv) == SVt_PVCV);
6639 save_I32(&PL_subline);
6640 save_item(PL_subname);
6642 SAVESPTR(PL_curpad);
6643 SAVESPTR(PL_comppad);
6644 SAVESPTR(PL_comppad_name);
6645 SAVESPTR(PL_compcv);
6646 SAVEI32(PL_comppad_name_fill);
6647 SAVEI32(PL_min_intro_pending);
6648 SAVEI32(PL_max_intro_pending);
6649 SAVEI32(PL_pad_reset_pending);
6651 PL_compcv = (CV*)NEWSV(1104,0);
6652 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
6653 CvFLAGS(PL_compcv) |= flags;
6655 PL_comppad = newAV();
6656 av_push(PL_comppad, Nullsv);
6657 PL_curpad = AvARRAY(PL_comppad);
6658 PL_comppad_name = newAV();
6659 PL_comppad_name_fill = 0;
6660 PL_min_intro_pending = 0;
6662 PL_subline = PL_curcop->cop_line;
6664 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
6665 PL_curpad[0] = (SV*)newAV();
6666 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
6667 #endif /* USE_THREADS */
6669 comppadlist = newAV();
6670 AvREAL_off(comppadlist);
6671 av_store(comppadlist, 0, (SV*)PL_comppad_name);
6672 av_store(comppadlist, 1, (SV*)PL_comppad);
6674 CvPADLIST(PL_compcv) = comppadlist;
6675 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
6677 CvOWNER(PL_compcv) = 0;
6678 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
6679 MUTEX_INIT(CvMUTEXP(PL_compcv));
6680 #endif /* USE_THREADS */
6682 return oldsavestack_ix;
6686 Perl_yywarn(pTHX_ char *s)
6690 PL_in_eval |= EVAL_WARNONLY;
6692 PL_in_eval &= ~EVAL_WARNONLY;
6697 Perl_yyerror(pTHX_ char *s)
6701 char *context = NULL;
6705 if (!yychar || (yychar == ';' && !PL_rsfp))
6707 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
6708 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
6709 while (isSPACE(*PL_oldoldbufptr))
6711 context = PL_oldoldbufptr;
6712 contlen = PL_bufptr - PL_oldoldbufptr;
6714 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
6715 PL_oldbufptr != PL_bufptr) {
6716 while (isSPACE(*PL_oldbufptr))
6718 context = PL_oldbufptr;
6719 contlen = PL_bufptr - PL_oldbufptr;
6721 else if (yychar > 255)
6722 where = "next token ???";
6723 else if ((yychar & 127) == 127) {
6724 if (PL_lex_state == LEX_NORMAL ||
6725 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
6726 where = "at end of line";
6727 else if (PL_lex_inpat)
6728 where = "within pattern";
6730 where = "within string";
6733 SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
6735 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
6736 else if (isPRINT_LC(yychar))
6737 Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
6739 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
6740 where = SvPVX(where_sv);
6742 msg = sv_2mortal(newSVpv(s, 0));
6743 Perl_sv_catpvf(aTHX_ msg, " at %_ line %ld, ",
6744 GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line);
6746 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
6748 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
6749 if (PL_multi_start < PL_multi_end && (U32)(PL_curcop->cop_line - PL_multi_end) <= 1) {
6750 Perl_sv_catpvf(aTHX_ msg,
6751 " (Might be a runaway multi-line %c%c string starting on line %ld)\n",
6752 (int)PL_multi_open,(int)PL_multi_close,(long)PL_multi_start);
6755 if (PL_in_eval & EVAL_WARNONLY)
6756 Perl_warn(aTHX_ "%_", msg);
6757 else if (PL_in_eval)
6758 sv_catsv(ERRSV, msg);
6760 PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
6761 if (++PL_error_count >= 10)
6762 Perl_croak(aTHX_ "%_ has too many errors.\n", GvSV(PL_curcop->cop_filegv));
6764 PL_in_my_stash = Nullhv;
6776 * Restore a source filter.
6780 restore_rsfp(pTHXo_ void *f)
6782 PerlIO *fp = (PerlIO*)f;
6784 if (PL_rsfp == PerlIO_stdin())
6785 PerlIO_clearerr(PL_rsfp);
6786 else if (PL_rsfp && (PL_rsfp != fp))
6787 PerlIO_close(PL_rsfp);
6793 * Restores the state of PL_expect when the lexing that begun with a
6794 * start_lex() call has ended.
6798 restore_expect(pTHXo_ void *e)
6800 /* a safe way to store a small integer in a pointer */
6801 PL_expect = (expectation)((char *)e - PL_tokenbuf);
6805 * restore_lex_expect
6806 * Restores the state of PL_lex_expect when the lexing that begun with a
6807 * start_lex() call has ended.
6811 restore_lex_expect(pTHXo_ void *e)
6813 /* a safe way to store a small integer in a pointer */
6814 PL_lex_expect = (expectation)((char *)e - PL_tokenbuf);