3 * Copyright (c) 1991-1999, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "It all comes from here, the stench and the peril." --Frodo
15 * This file is the lexer for Perl. It's closely linked to the
18 * The main routine is yylex(), which returns the next token.
22 #define PERL_IN_TOKE_C
25 #define yychar PL_yychar
26 #define yylval PL_yylval
28 static char ident_too_long[] = "Identifier too long";
30 static void restore_rsfp(pTHXo_ void *f);
31 static void restore_expect(pTHXo_ void *e);
32 static void restore_lex_expect(pTHXo_ void *e);
34 #define UTF (PL_hints & HINT_UTF8)
36 * Note: we try to be careful never to call the isXXX_utf8() functions
37 * unless we're pretty sure we've seen the beginning of a UTF-8 character
38 * (that is, the two high bits are set). Otherwise we risk loading in the
39 * heavy-duty SWASHINIT and SWASHGET routines unnecessarily.
41 #define isIDFIRST_lazy(p) ((!UTF || (*((U8*)p) < 0xc0)) \
43 : isIDFIRST_utf8((U8*)p))
44 #define isALNUM_lazy(p) ((!UTF || (*((U8*)p) < 0xc0)) \
46 : isALNUM_utf8((U8*)p))
48 /* In variables name $^X, these are the legal values for X.
49 * 1999-02-27 mjd-perl-patch@plover.com */
50 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
52 /* LEX_* are values for PL_lex_state, the state of the lexer.
53 * They are arranged oddly so that the guard on the switch statement
54 * can get by with a single comparison (if the compiler is smart enough).
57 /* #define LEX_NOTPARSING 11 is done in perl.h. */
60 #define LEX_INTERPNORMAL 9
61 #define LEX_INTERPCASEMOD 8
62 #define LEX_INTERPPUSH 7
63 #define LEX_INTERPSTART 6
64 #define LEX_INTERPEND 5
65 #define LEX_INTERPENDMAYBE 4
66 #define LEX_INTERPCONCAT 3
67 #define LEX_INTERPCONST 2
68 #define LEX_FORMLINE 1
69 #define LEX_KNOWNEXT 0
78 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
80 # include <unistd.h> /* Needed for execv() */
89 YYSTYPE* yylval_pointer = NULL;
90 int* yychar_pointer = NULL;
93 # define yylval (*yylval_pointer)
94 # define yychar (*yychar_pointer)
95 # define PERL_YYLEX_PARAM yylval_pointer,yychar_pointer
97 # define yylex() Perl_yylex(aTHX_ yylval_pointer, yychar_pointer)
100 #include "keywords.h"
102 /* CLINE is a macro that ensures PL_copline has a sane value */
107 #define CLINE (PL_copline = (PL_curcop->cop_line < PL_copline ? PL_curcop->cop_line : PL_copline))
110 * Convenience functions to return different tokens and prime the
111 * lexer for the next token. They all take an argument.
113 * TOKEN : generic token (used for '(', DOLSHARP, etc)
114 * OPERATOR : generic operator
115 * AOPERATOR : assignment operator
116 * PREBLOCK : beginning the block after an if, while, foreach, ...
117 * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
118 * PREREF : *EXPR where EXPR is not a simple identifier
119 * TERM : expression term
120 * LOOPX : loop exiting command (goto, last, dump, etc)
121 * FTST : file test operator
122 * FUN0 : zero-argument function
124 * BOop : bitwise or or xor
126 * SHop : shift operator
127 * PWop : power operator
128 * PMop : pattern-matching operator
129 * Aop : addition-level operator
130 * Mop : multiplication-level operator
131 * Eop : equality-testing operator
132 * Rop : relational operator <= != gt
134 * Also see LOP and lop() below.
137 #define TOKEN(retval) return (PL_bufptr = s,(int)retval)
138 #define OPERATOR(retval) return (PL_expect = XTERM,PL_bufptr = s,(int)retval)
139 #define AOPERATOR(retval) return ao((PL_expect = XTERM,PL_bufptr = s,(int)retval))
140 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s,(int)retval)
141 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval)
142 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s,(int)retval)
143 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR,PL_bufptr = s,(int)retval)
144 #define LOOPX(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX)
145 #define FTST(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)UNIOP)
146 #define FUN0(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0)
147 #define FUN1(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1)
148 #define BOop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITOROP))
149 #define BAop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP))
150 #define SHop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP))
151 #define PWop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)POWOP))
152 #define PMop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP)
153 #define Aop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)ADDOP))
154 #define Mop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MULOP))
155 #define Eop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)EQOP)
156 #define Rop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)RELOP)
158 /* This bit of chicanery makes a unary function followed by
159 * a parenthesis into a function with one argument, highest precedence.
161 #define UNI(f) return(yylval.ival = f, \
164 PL_last_uni = PL_oldbufptr, \
165 PL_last_lop_op = f, \
166 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
168 #define UNIBRACK(f) return(yylval.ival = f, \
170 PL_last_uni = PL_oldbufptr, \
171 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
173 /* grandfather return to old style */
174 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
179 * This subroutine detects &&= and ||= and turns an ANDAND or OROR
180 * into an OP_ANDASSIGN or OP_ORASSIGN
184 S_ao(pTHX_ int toketype)
186 if (*PL_bufptr == '=') {
188 if (toketype == ANDAND)
189 yylval.ival = OP_ANDASSIGN;
190 else if (toketype == OROR)
191 yylval.ival = OP_ORASSIGN;
199 * When Perl expects an operator and finds something else, no_op
200 * prints the warning. It always prints "<something> found where
201 * operator expected. It prints "Missing semicolon on previous line?"
202 * if the surprise occurs at the start of the line. "do you need to
203 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
204 * where the compiler doesn't know if foo is a method call or a function.
205 * It prints "Missing operator before end of line" if there's nothing
206 * after the missing operator, or "... before <...>" if there is something
207 * after the missing operator.
211 S_no_op(pTHX_ char *what, char *s)
213 char *oldbp = PL_bufptr;
214 bool is_first = (PL_oldbufptr == PL_linestart);
218 yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
220 Perl_warn(aTHX_ "\t(Missing semicolon on previous line?)\n");
221 else if (PL_oldoldbufptr && isIDFIRST_lazy(PL_oldoldbufptr)) {
223 for (t = PL_oldoldbufptr; *t && (isALNUM_lazy(t) || *t == ':'); t++) ;
224 if (t < PL_bufptr && isSPACE(*t))
225 Perl_warn(aTHX_ "\t(Do you need to predeclare %.*s?)\n",
226 t - PL_oldoldbufptr, PL_oldoldbufptr);
229 Perl_warn(aTHX_ "\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
235 * Complain about missing quote/regexp/heredoc terminator.
236 * If it's called with (char *)NULL then it cauterizes the line buffer.
237 * If we're in a delimited string and the delimiter is a control
238 * character, it's reformatted into a two-char sequence like ^C.
243 S_missingterm(pTHX_ char *s)
248 char *nl = strrchr(s,'\n');
254 iscntrl(PL_multi_close)
256 PL_multi_close < 32 || PL_multi_close == 127
260 tmpbuf[1] = toCTRL(PL_multi_close);
266 *tmpbuf = PL_multi_close;
270 q = strchr(s,'"') ? '\'' : '"';
271 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
279 Perl_deprecate(pTHX_ char *s)
282 if (ckWARN(WARN_DEPRECATED))
283 Perl_warner(aTHX_ WARN_DEPRECATED, "Use of %s is deprecated", s);
288 * Deprecate a comma-less variable list.
294 deprecate("comma-less variable list");
298 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
299 * utf16-to-utf8-reversed.
305 S_win32_textfilter(pTHX_ int idx, SV *sv, int maxlen)
307 I32 count = FILTER_READ(idx+1, sv, maxlen);
308 if (count > 0 && !maxlen)
309 win32_strip_return(sv);
315 S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
317 I32 count = FILTER_READ(idx+1, sv, maxlen);
321 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
322 tend = utf16_to_utf8((U16*)SvPVX(sv), tmps, SvCUR(sv));
323 sv_usepvn(sv, (char*)tmps, tend - tmps);
330 S_utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
332 I32 count = FILTER_READ(idx+1, sv, maxlen);
336 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
337 tend = utf16_to_utf8_reversed((U16*)SvPVX(sv), tmps, SvCUR(sv));
338 sv_usepvn(sv, (char*)tmps, tend - tmps);
346 * Initialize variables. Uses the Perl save_stack to save its state (for
347 * recursive calls to the parser).
351 Perl_lex_start(pTHX_ SV *line)
357 SAVEI32(PL_lex_dojoin);
358 SAVEI32(PL_lex_brackets);
359 SAVEI32(PL_lex_fakebrack);
360 SAVEI32(PL_lex_casemods);
361 SAVEI32(PL_lex_starts);
362 SAVEI32(PL_lex_state);
363 SAVESPTR(PL_lex_inpat);
364 SAVEI32(PL_lex_inwhat);
365 SAVEI16(PL_curcop->cop_line);
368 SAVEPPTR(PL_oldbufptr);
369 SAVEPPTR(PL_oldoldbufptr);
370 SAVEPPTR(PL_linestart);
371 SAVESPTR(PL_linestr);
372 SAVEPPTR(PL_lex_brackstack);
373 SAVEPPTR(PL_lex_casestack);
374 SAVEDESTRUCTOR(restore_rsfp, PL_rsfp);
375 SAVESPTR(PL_lex_stuff);
376 SAVEI32(PL_lex_defer);
377 SAVEI32(PL_sublex_info.sub_inwhat);
378 SAVESPTR(PL_lex_repl);
379 SAVEDESTRUCTOR(restore_expect, PL_tokenbuf + PL_expect); /* encode as pointer */
380 SAVEDESTRUCTOR(restore_lex_expect, PL_tokenbuf + PL_expect);
382 PL_lex_state = LEX_NORMAL;
386 PL_lex_fakebrack = 0;
387 New(899, PL_lex_brackstack, 120, char);
388 New(899, PL_lex_casestack, 12, char);
389 SAVEFREEPV(PL_lex_brackstack);
390 SAVEFREEPV(PL_lex_casestack);
392 *PL_lex_casestack = '\0';
395 PL_lex_stuff = Nullsv;
396 PL_lex_repl = Nullsv;
399 PL_sublex_info.sub_inwhat = 0;
401 if (SvREADONLY(PL_linestr))
402 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
403 s = SvPV(PL_linestr, len);
404 if (len && s[len-1] != ';') {
405 if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
406 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
407 sv_catpvn(PL_linestr, "\n;", 2);
409 SvTEMP_off(PL_linestr);
410 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
411 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
413 PL_rs = newSVpvn("\n", 1);
419 * Finalizer for lexing operations. Must be called when the parser is
420 * done with the lexer.
426 PL_doextract = FALSE;
431 * This subroutine has nothing to do with tilting, whether at windmills
432 * or pinball tables. Its name is short for "increment line". It
433 * increments the current line number in PL_curcop->cop_line and checks
434 * to see whether the line starts with a comment of the form
435 * # line 500 "foo.pm"
436 * If so, it sets the current line number and file to the values in the comment.
440 S_incline(pTHX_ char *s)
448 PL_curcop->cop_line++;
451 while (*s == ' ' || *s == '\t') s++;
452 if (strnEQ(s, "line ", 5)) {
461 while (*s == ' ' || *s == '\t')
463 if (*s == '"' && (t = strchr(s+1, '"')))
467 return; /* false alarm */
468 for (t = s; !isSPACE(*t); t++) ;
473 PL_curcop->cop_filegv = gv_fetchfile(s);
475 PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
477 PL_curcop->cop_line = atoi(n)-1;
482 * Called to gobble the appropriate amount and type of whitespace.
483 * Skips comments as well.
487 S_skipspace(pTHX_ register char *s)
490 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
491 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
497 SSize_t oldprevlen, oldoldprevlen;
498 SSize_t oldloplen, oldunilen;
499 while (s < PL_bufend && isSPACE(*s)) {
500 if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
505 if (s < PL_bufend && *s == '#') {
506 while (s < PL_bufend && *s != '\n')
510 if (PL_in_eval && !PL_rsfp) {
517 /* only continue to recharge the buffer if we're at the end
518 * of the buffer, we're not reading from a source filter, and
519 * we're in normal lexing mode
521 if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat ||
522 PL_lex_state == LEX_FORMLINE)
525 /* try to recharge the buffer */
526 if ((s = filter_gets(PL_linestr, PL_rsfp,
527 (prevlen = SvCUR(PL_linestr)))) == Nullch)
529 /* end of file. Add on the -p or -n magic */
530 if (PL_minus_n || PL_minus_p) {
531 sv_setpv(PL_linestr,PL_minus_p ?
532 ";}continue{print or die qq(-p destination: $!\\n)" :
534 sv_catpv(PL_linestr,";}");
535 PL_minus_n = PL_minus_p = 0;
538 sv_setpv(PL_linestr,";");
540 /* reset variables for next time we lex */
541 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
543 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
545 /* Close the filehandle. Could be from -P preprocessor,
546 * STDIN, or a regular file. If we were reading code from
547 * STDIN (because the commandline held no -e or filename)
548 * then we don't close it, we reset it so the code can
549 * read from STDIN too.
552 if (PL_preprocess && !PL_in_eval)
553 (void)PerlProc_pclose(PL_rsfp);
554 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
555 PerlIO_clearerr(PL_rsfp);
557 (void)PerlIO_close(PL_rsfp);
562 /* not at end of file, so we only read another line */
563 /* make corresponding updates to old pointers, for yyerror() */
564 oldprevlen = PL_oldbufptr - PL_bufend;
565 oldoldprevlen = PL_oldoldbufptr - PL_bufend;
567 oldunilen = PL_last_uni - PL_bufend;
569 oldloplen = PL_last_lop - PL_bufend;
570 PL_linestart = PL_bufptr = s + prevlen;
571 PL_bufend = s + SvCUR(PL_linestr);
573 PL_oldbufptr = s + oldprevlen;
574 PL_oldoldbufptr = s + oldoldprevlen;
576 PL_last_uni = s + oldunilen;
578 PL_last_lop = s + oldloplen;
581 /* debugger active and we're not compiling the debugger code,
582 * so store the line into the debugger's array of lines
584 if (PERLDB_LINE && PL_curstash != PL_debstash) {
585 SV *sv = NEWSV(85,0);
587 sv_upgrade(sv, SVt_PVMG);
588 sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
589 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
596 * Check the unary operators to ensure there's no ambiguity in how they're
597 * used. An ambiguous piece of code would be:
599 * This doesn't mean rand() + 5. Because rand() is a unary operator,
600 * the +5 is its argument.
610 if (PL_oldoldbufptr != PL_last_uni)
612 while (isSPACE(*PL_last_uni))
614 for (s = PL_last_uni; isALNUM_lazy(s) || *s == '-'; s++) ;
615 if ((t = strchr(s, '(')) && t < PL_bufptr)
617 if (ckWARN_d(WARN_AMBIGUOUS)){
620 Perl_warner(aTHX_ WARN_AMBIGUOUS,
621 "Warning: Use of \"%s\" without parens is ambiguous",
627 /* workaround to replace the UNI() macro with a function. Only the
628 * hints/uts.sh file mentions this. Other comments elsewhere in the
629 * source indicate Microport Unix might need it too.
635 #define UNI(f) return uni(f,s)
638 S_uni(pTHX_ I32 f, char *s)
643 PL_last_uni = PL_oldbufptr;
654 #endif /* CRIPPLED_CC */
657 * LOP : macro to build a list operator. Its behaviour has been replaced
658 * with a subroutine, S_lop() for which LOP is just another name.
661 #define LOP(f,x) return lop(f,x,s)
665 * Build a list operator (or something that might be one). The rules:
666 * - if we have a next token, then it's a list operator [why?]
667 * - if the next thing is an opening paren, then it's a function
668 * - else it's a list operator
672 S_lop(pTHX_ I32 f, expectation x, char *s)
679 PL_last_lop = PL_oldbufptr;
694 * When the lexer realizes it knows the next token (for instance,
695 * it is reordering tokens for the parser) then it can call S_force_next
696 * to know what token to return the next time the lexer is called. Caller
697 * will need to set PL_nextval[], and possibly PL_expect to ensure the lexer
698 * handles the token correctly.
702 S_force_next(pTHX_ I32 type)
704 PL_nexttype[PL_nexttoke] = type;
706 if (PL_lex_state != LEX_KNOWNEXT) {
707 PL_lex_defer = PL_lex_state;
708 PL_lex_expect = PL_expect;
709 PL_lex_state = LEX_KNOWNEXT;
715 * When the lexer knows the next thing is a word (for instance, it has
716 * just seen -> and it knows that the next char is a word char, then
717 * it calls S_force_word to stick the next word into the PL_next lookahead.
720 * char *start : start of the buffer
721 * int token : PL_next will be this type of bare word (e.g., METHOD,WORD)
722 * int check_keyword : if true, Perl checks to make sure the word isn't
723 * a keyword (do this if the word is a label, e.g. goto FOO)
724 * int allow_pack : if true, : characters will also be allowed (require,
726 * int allow_initial_tick : used by the "sub" lexer only.
730 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
735 start = skipspace(start);
737 if (isIDFIRST_lazy(s) ||
738 (allow_pack && *s == ':') ||
739 (allow_initial_tick && *s == '\'') )
741 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
742 if (check_keyword && keyword(PL_tokenbuf, len))
744 if (token == METHOD) {
749 PL_expect = XOPERATOR;
752 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(PL_tokenbuf,0));
753 PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
761 * Called when the lexer wants $foo *foo &foo etc, but the program
762 * text only contains the "foo" portion. The first argument is a pointer
763 * to the "foo", and the second argument is the type symbol to prefix.
764 * Forces the next token to be a "WORD".
765 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
769 S_force_ident(pTHX_ register char *s, int kind)
772 OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
773 PL_nextval[PL_nexttoke].opval = o;
776 dTHR; /* just for in_eval */
777 o->op_private = OPpCONST_ENTERED;
778 /* XXX see note in pp_entereval() for why we forgo typo
779 warnings if the symbol must be introduced in an eval.
781 gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
782 kind == '$' ? SVt_PV :
783 kind == '@' ? SVt_PVAV :
784 kind == '%' ? SVt_PVHV :
793 * Forces the next token to be a version number.
797 S_force_version(pTHX_ char *s)
799 OP *version = Nullop;
803 /* default VERSION number -- GBARR */
808 for( d=s, c = 1; isDIGIT(*d) || *d == '_' || (*d == '.' && c--); d++);
809 if((*d == ';' || isSPACE(*d)) && *(skipspace(d)) != ',') {
811 /* real VERSION number -- GBARR */
812 version = yylval.opval;
816 /* NOTE: The parser sees the package name and the VERSION swapped */
817 PL_nextval[PL_nexttoke].opval = version;
825 * Tokenize a quoted string passed in as an SV. It finds the next
826 * chunk, up to end of string or a backslash. It may make a new
827 * SV containing that chunk (if HINT_NEW_STRING is on). It also
832 S_tokeq(pTHX_ SV *sv)
843 s = SvPV_force(sv, len);
847 while (s < send && *s != '\\')
852 if ( PL_hints & HINT_NEW_STRING )
853 pv = sv_2mortal(newSVpvn(SvPVX(pv), len));
856 if (s + 1 < send && (s[1] == '\\'))
857 s++; /* all that, just for this */
862 SvCUR_set(sv, d - SvPVX(sv));
864 if ( PL_hints & HINT_NEW_STRING )
865 return new_constant(NULL, 0, "q", sv, pv, "q");
870 * Now come three functions related to double-quote context,
871 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
872 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
873 * interact with PL_lex_state, and create fake ( ... ) argument lists
874 * to handle functions and concatenation.
875 * They assume that whoever calls them will be setting up a fake
876 * join call, because each subthing puts a ',' after it. This lets
879 * join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
881 * (I'm not sure whether the spurious commas at the end of lcfirst's
882 * arguments and join's arguments are created or not).
887 * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST).
889 * Pattern matching will set PL_lex_op to the pattern-matching op to
890 * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise).
892 * OP_CONST and OP_READLINE are easy--just make the new op and return.
894 * Everything else becomes a FUNC.
896 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
897 * had an OP_CONST or OP_READLINE). This just sets us up for a
898 * call to S_sublex_push().
904 register I32 op_type = yylval.ival;
906 if (op_type == OP_NULL) {
907 yylval.opval = PL_lex_op;
911 if (op_type == OP_CONST || op_type == OP_READLINE) {
912 SV *sv = tokeq(PL_lex_stuff);
914 if (SvTYPE(sv) == SVt_PVIV) {
915 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
921 nsv = newSVpvn(p, len);
925 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
926 PL_lex_stuff = Nullsv;
930 PL_sublex_info.super_state = PL_lex_state;
931 PL_sublex_info.sub_inwhat = op_type;
932 PL_sublex_info.sub_op = PL_lex_op;
933 PL_lex_state = LEX_INTERPPUSH;
937 yylval.opval = PL_lex_op;
947 * Create a new scope to save the lexing state. The scope will be
948 * ended in S_sublex_done. Returns a '(', starting the function arguments
949 * to the uc, lc, etc. found before.
950 * Sets PL_lex_state to LEX_INTERPCONCAT.
959 PL_lex_state = PL_sublex_info.super_state;
960 SAVEI32(PL_lex_dojoin);
961 SAVEI32(PL_lex_brackets);
962 SAVEI32(PL_lex_fakebrack);
963 SAVEI32(PL_lex_casemods);
964 SAVEI32(PL_lex_starts);
965 SAVEI32(PL_lex_state);
966 SAVESPTR(PL_lex_inpat);
967 SAVEI32(PL_lex_inwhat);
968 SAVEI16(PL_curcop->cop_line);
970 SAVEPPTR(PL_oldbufptr);
971 SAVEPPTR(PL_oldoldbufptr);
972 SAVEPPTR(PL_linestart);
973 SAVESPTR(PL_linestr);
974 SAVEPPTR(PL_lex_brackstack);
975 SAVEPPTR(PL_lex_casestack);
977 PL_linestr = PL_lex_stuff;
978 PL_lex_stuff = Nullsv;
980 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
982 PL_bufend += SvCUR(PL_linestr);
983 SAVEFREESV(PL_linestr);
985 PL_lex_dojoin = FALSE;
987 PL_lex_fakebrack = 0;
988 New(899, PL_lex_brackstack, 120, char);
989 New(899, PL_lex_casestack, 12, char);
990 SAVEFREEPV(PL_lex_brackstack);
991 SAVEFREEPV(PL_lex_casestack);
993 *PL_lex_casestack = '\0';
995 PL_lex_state = LEX_INTERPCONCAT;
996 PL_curcop->cop_line = PL_multi_start;
998 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
999 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1000 PL_lex_inpat = PL_sublex_info.sub_op;
1002 PL_lex_inpat = Nullop;
1009 * Restores lexer state after a S_sublex_push.
1015 if (!PL_lex_starts++) {
1016 PL_expect = XOPERATOR;
1017 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpvn("",0));
1021 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
1022 PL_lex_state = LEX_INTERPCASEMOD;
1026 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1027 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1028 PL_linestr = PL_lex_repl;
1030 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1031 PL_bufend += SvCUR(PL_linestr);
1032 SAVEFREESV(PL_linestr);
1033 PL_lex_dojoin = FALSE;
1034 PL_lex_brackets = 0;
1035 PL_lex_fakebrack = 0;
1036 PL_lex_casemods = 0;
1037 *PL_lex_casestack = '\0';
1039 if (SvEVALED(PL_lex_repl)) {
1040 PL_lex_state = LEX_INTERPNORMAL;
1042 /* we don't clear PL_lex_repl here, so that we can check later
1043 whether this is an evalled subst; that means we rely on the
1044 logic to ensure sublex_done() is called again only via the
1045 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1048 PL_lex_state = LEX_INTERPCONCAT;
1049 PL_lex_repl = Nullsv;
1055 PL_bufend = SvPVX(PL_linestr);
1056 PL_bufend += SvCUR(PL_linestr);
1057 PL_expect = XOPERATOR;
1058 PL_sublex_info.sub_inwhat = 0;
1066 Extracts a pattern, double-quoted string, or transliteration. This
1069 It looks at lex_inwhat and PL_lex_inpat to find out whether it's
1070 processing a pattern (PL_lex_inpat is true), a transliteration
1071 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
1073 Returns a pointer to the character scanned up to. Iff this is
1074 advanced from the start pointer supplied (ie if anything was
1075 successfully parsed), will leave an OP for the substring scanned
1076 in yylval. Caller must intuit reason for not parsing further
1077 by looking at the next characters herself.
1081 double-quoted style: \r and \n
1082 regexp special ones: \D \s
1084 backrefs: \1 (deprecated in substitution replacements)
1085 case and quoting: \U \Q \E
1086 stops on @ and $, but not for $ as tail anchor
1088 In transliterations:
1089 characters are VERY literal, except for - not at the start or end
1090 of the string, which indicates a range. scan_const expands the
1091 range to the full set of intermediate characters.
1093 In double-quoted strings:
1095 double-quoted style: \r and \n
1097 backrefs: \1 (deprecated)
1098 case and quoting: \U \Q \E
1101 scan_const does *not* construct ops to handle interpolated strings.
1102 It stops processing as soon as it finds an embedded $ or @ variable
1103 and leaves it to the caller to work out what's going on.
1105 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
1107 $ in pattern could be $foo or could be tail anchor. Assumption:
1108 it's a tail anchor if $ is the last thing in the string, or if it's
1109 followed by one of ")| \n\t"
1111 \1 (backreferences) are turned into $1
1113 The structure of the code is
1114 while (there's a character to process) {
1115 handle transliteration ranges
1116 skip regexp comments
1117 skip # initiated comments in //x patterns
1118 check for embedded @foo
1119 check for embedded scalars
1121 leave intact backslashes from leave (below)
1122 deprecate \1 in strings and sub replacements
1123 handle string-changing backslashes \l \U \Q \E, etc.
1124 switch (what was escaped) {
1125 handle - in a transliteration (becomes a literal -)
1126 handle \132 octal characters
1127 handle 0x15 hex characters
1128 handle \cV (control V)
1129 handle printf backslashes (\f, \r, \n, etc)
1131 } (end if backslash)
1132 } (end while character to read)
1137 S_scan_const(pTHX_ char *start)
1139 register char *send = PL_bufend; /* end of the constant */
1140 SV *sv = NEWSV(93, send - start); /* sv for the constant */
1141 register char *s = start; /* start of the constant */
1142 register char *d = SvPVX(sv); /* destination for copies */
1143 bool dorange = FALSE; /* are we in a translit range? */
1145 I32 utf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op)
1146 ? (PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
1148 I32 thisutf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op)
1149 ? (PL_sublex_info.sub_op->op_private & (PL_lex_repl ?
1150 OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF))
1152 char *leaveit = /* set of acceptably-backslashed characters */
1154 ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
1157 while (s < send || dorange) {
1158 /* get transliterations out of the way (they're most literal) */
1159 if (PL_lex_inwhat == OP_TRANS) {
1160 /* expand a range A-Z to the full set of characters. AIE! */
1162 I32 i; /* current expanded character */
1163 I32 min; /* first character in range */
1164 I32 max; /* last character in range */
1166 i = d - SvPVX(sv); /* remember current offset */
1167 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
1168 d = SvPVX(sv) + i; /* refresh d after realloc */
1169 d -= 2; /* eat the first char and the - */
1171 min = (U8)*d; /* first char in range */
1172 max = (U8)d[1]; /* last char in range */
1175 if ((isLOWER(min) && isLOWER(max)) ||
1176 (isUPPER(min) && isUPPER(max))) {
1178 for (i = min; i <= max; i++)
1182 for (i = min; i <= max; i++)
1189 for (i = min; i <= max; i++)
1192 /* mark the range as done, and continue */
1197 /* range begins (ignore - as first or last char) */
1198 else if (*s == '-' && s+1 < send && s != start) {
1200 *d++ = (char)0xff; /* use illegal utf8 byte--see pmtrans */
1209 /* if we get here, we're not doing a transliteration */
1211 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
1212 except for the last char, which will be done separately. */
1213 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
1215 while (s < send && *s != ')')
1217 } else if (s[2] == '{'
1218 || s[2] == 'p' && s[3] == '{') { /* This should march regcomp.c */
1220 char *regparse = s + (s[2] == '{' ? 3 : 4);
1223 while (count && (c = *regparse)) {
1224 if (c == '\\' && regparse[1])
1232 if (*regparse != ')') {
1233 regparse--; /* Leave one char for continuation. */
1234 yyerror("Sequence (?{...}) not terminated or not {}-balanced");
1236 while (s < regparse)
1241 /* likewise skip #-initiated comments in //x patterns */
1242 else if (*s == '#' && PL_lex_inpat &&
1243 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
1244 while (s+1 < send && *s != '\n')
1248 /* check for embedded arrays (@foo, @:foo, @'foo, @{foo}, @$foo) */
1249 else if (*s == '@' && s[1] && (isALNUM_lazy(s+1) || strchr(":'{$", s[1])))
1252 /* check for embedded scalars. only stop if we're sure it's a
1255 else if (*s == '$') {
1256 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
1258 if (s + 1 < send && !strchr("()| \n\t", s[1]))
1259 break; /* in regexp, $ might be tail anchor */
1262 /* (now in tr/// code again) */
1264 if (*s & 0x80 && thisutf) {
1265 dTHR; /* only for ckWARN */
1266 if (ckWARN(WARN_UTF8)) {
1267 (void)utf8_to_uv((U8*)s, &len); /* could cvt latin-1 to utf8 here... */
1277 if (*s == '\\' && s+1 < send) {
1280 /* some backslashes we leave behind */
1281 if (*leaveit && *s && strchr(leaveit, *s)) {
1287 /* deprecate \1 in strings and substitution replacements */
1288 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1289 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1291 dTHR; /* only for ckWARN */
1292 if (ckWARN(WARN_SYNTAX))
1293 Perl_warner(aTHX_ WARN_SYNTAX, "\\%c better written as $%c", *s, *s);
1298 /* string-change backslash escapes */
1299 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1304 /* if we get here, it's either a quoted -, or a digit */
1307 /* quoted - in transliterations */
1309 if (PL_lex_inwhat == OP_TRANS) {
1317 if (ckWARN(WARN_UNSAFE) && isALPHA(*s))
1318 Perl_warner(aTHX_ WARN_UNSAFE,
1319 "Unrecognized escape \\%c passed through",
1321 /* default action is to copy the quoted character */
1326 /* \132 indicates an octal constant */
1327 case '0': case '1': case '2': case '3':
1328 case '4': case '5': case '6': case '7':
1329 *d++ = scan_oct(s, 3, &len);
1333 /* \x24 indicates a hex constant */
1337 char* e = strchr(s, '}');
1340 yyerror("Missing right brace on \\x{}");
1345 if (ckWARN(WARN_UTF8))
1346 Perl_warner(aTHX_ WARN_UTF8,
1347 "Use of \\x{} without utf8 declaration");
1349 /* note: utf always shorter than hex */
1350 d = (char*)uv_to_utf8((U8*)d,
1351 scan_hex(s + 1, e - s - 1, &len));
1355 UV uv = (UV)scan_hex(s, 2, &len);
1356 if (utf && PL_lex_inwhat == OP_TRANS &&
1357 utf != (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
1359 d = (char*)uv_to_utf8((U8*)d, uv); /* doing a CU or UC */
1362 if (uv >= 127 && UTF) {
1364 if (ckWARN(WARN_UTF8))
1365 Perl_warner(aTHX_ WARN_UTF8,
1366 "\\x%.*s will produce malformed UTF-8 character; use \\x{%.*s} for that",
1375 /* \N{latin small letter a} is a named character */
1379 char* e = strchr(s, '}');
1388 yyerror("Missing right brace on \\N{}");
1392 res = newSVpvn(s + 1, e - s - 1);
1393 res = new_constant( Nullch, 0, "charnames",
1394 res, Nullsv, "\\N{...}" );
1395 str = SvPV(res,len);
1396 if (len > e - s + 4) {
1397 char *odest = SvPVX(sv);
1399 SvGROW(sv, (SvCUR(sv) + len - (e - s + 4)));
1400 d = SvPVX(sv) + (d - odest);
1402 Copy(str, d, len, char);
1409 yyerror("Missing braces on \\N{}");
1412 /* \c is a control character */
1426 /* printf-style backslashes, formfeeds, newlines, etc */
1444 *d++ = '\047'; /* CP 1047 */
1447 *d++ = '\057'; /* CP 1047 */
1461 } /* end if (backslash) */
1464 } /* while loop to process each character */
1466 /* terminate the string and set up the sv */
1468 SvCUR_set(sv, d - SvPVX(sv));
1471 /* shrink the sv if we allocated more than we used */
1472 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1473 SvLEN_set(sv, SvCUR(sv) + 1);
1474 Renew(SvPVX(sv), SvLEN(sv), char);
1477 /* return the substring (via yylval) only if we parsed anything */
1478 if (s > PL_bufptr) {
1479 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1480 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1482 ( PL_lex_inwhat == OP_TRANS
1484 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1487 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1494 * Returns TRUE if there's more to the expression (e.g., a subscript),
1497 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
1499 * ->[ and ->{ return TRUE
1500 * { and [ outside a pattern are always subscripts, so return TRUE
1501 * if we're outside a pattern and it's not { or [, then return FALSE
1502 * if we're in a pattern and the first char is a {
1503 * {4,5} (any digits around the comma) returns FALSE
1504 * if we're in a pattern and the first char is a [
1506 * [SOMETHING] has a funky algorithm to decide whether it's a
1507 * character class or not. It has to deal with things like
1508 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
1509 * anything else returns TRUE
1512 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1515 S_intuit_more(pTHX_ register char *s)
1517 if (PL_lex_brackets)
1519 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1521 if (*s != '{' && *s != '[')
1526 /* In a pattern, so maybe we have {n,m}. */
1543 /* On the other hand, maybe we have a character class */
1546 if (*s == ']' || *s == '^')
1549 /* this is terrifying, and it works */
1550 int weight = 2; /* let's weigh the evidence */
1552 unsigned char un_char = 255, last_un_char;
1553 char *send = strchr(s,']');
1554 char tmpbuf[sizeof PL_tokenbuf * 4];
1556 if (!send) /* has to be an expression */
1559 Zero(seen,256,char);
1562 else if (isDIGIT(*s)) {
1564 if (isDIGIT(s[1]) && s[2] == ']')
1570 for (; s < send; s++) {
1571 last_un_char = un_char;
1572 un_char = (unsigned char)*s;
1577 weight -= seen[un_char] * 10;
1578 if (isALNUM_lazy(s+1)) {
1579 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1580 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1585 else if (*s == '$' && s[1] &&
1586 strchr("[#!%*<>()-=",s[1])) {
1587 if (/*{*/ strchr("])} =",s[2]))
1596 if (strchr("wds]",s[1]))
1598 else if (seen['\''] || seen['"'])
1600 else if (strchr("rnftbxcav",s[1]))
1602 else if (isDIGIT(s[1])) {
1604 while (s[1] && isDIGIT(s[1]))
1614 if (strchr("aA01! ",last_un_char))
1616 if (strchr("zZ79~",s[1]))
1618 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1619 weight -= 5; /* cope with negative subscript */
1622 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1623 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1628 if (keyword(tmpbuf, d - tmpbuf))
1631 if (un_char == last_un_char + 1)
1633 weight -= seen[un_char];
1638 if (weight >= 0) /* probably a character class */
1648 * Does all the checking to disambiguate
1650 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
1651 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
1653 * First argument is the stuff after the first token, e.g. "bar".
1655 * Not a method if bar is a filehandle.
1656 * Not a method if foo is a subroutine prototyped to take a filehandle.
1657 * Not a method if it's really "Foo $bar"
1658 * Method if it's "foo $bar"
1659 * Not a method if it's really "print foo $bar"
1660 * Method if it's really "foo package::" (interpreted as package->foo)
1661 * Not a method if bar is known to be a subroutne ("sub bar; foo bar")
1662 * Not a method if bar is a filehandle or package, but is quotd with
1667 S_intuit_method(pTHX_ char *start, GV *gv)
1669 char *s = start + (*start == '$');
1670 char tmpbuf[sizeof PL_tokenbuf];
1678 if ((cv = GvCVu(gv))) {
1679 char *proto = SvPVX(cv);
1689 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1690 /* start is the beginning of the possible filehandle/object,
1691 * and s is the end of it
1692 * tmpbuf is a copy of it
1695 if (*start == '$') {
1696 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1701 return *s == '(' ? FUNCMETH : METHOD;
1703 if (!keyword(tmpbuf, len)) {
1704 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1709 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1710 if (indirgv && GvCVu(indirgv))
1712 /* filehandle or package name makes it a method */
1713 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1715 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1716 return 0; /* no assumptions -- "=>" quotes bearword */
1718 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1719 newSVpvn(tmpbuf,len));
1720 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1724 return *s == '(' ? FUNCMETH : METHOD;
1732 * Return a string of Perl code to load the debugger. If PERL5DB
1733 * is set, it will return the contents of that, otherwise a
1734 * compile-time require of perl5db.pl.
1741 char *pdb = PerlEnv_getenv("PERL5DB");
1745 SETERRNO(0,SS$_NORMAL);
1746 return "BEGIN { require 'perl5db.pl' }";
1752 /* Encoded script support. filter_add() effectively inserts a
1753 * 'pre-processing' function into the current source input stream.
1754 * Note that the filter function only applies to the current source file
1755 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1757 * The datasv parameter (which may be NULL) can be used to pass
1758 * private data to this instance of the filter. The filter function
1759 * can recover the SV using the FILTER_DATA macro and use it to
1760 * store private buffers and state information.
1762 * The supplied datasv parameter is upgraded to a PVIO type
1763 * and the IoDIRP field is used to store the function pointer.
1764 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1765 * private use must be set using malloc'd pointers.
1769 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
1771 if (!funcp){ /* temporary handy debugging hack to be deleted */
1772 PL_filter_debug = atoi((char*)datasv);
1775 if (!PL_rsfp_filters)
1776 PL_rsfp_filters = newAV();
1778 datasv = NEWSV(255,0);
1779 if (!SvUPGRADE(datasv, SVt_PVIO))
1780 Perl_die(aTHX_ "Can't upgrade filter_add data to SVt_PVIO");
1781 IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
1783 if (PL_filter_debug) {
1785 Perl_warn(aTHX_ "filter_add func %p (%s)", funcp, SvPV(datasv, n_a));
1787 #endif /* DEBUGGING */
1788 av_unshift(PL_rsfp_filters, 1);
1789 av_store(PL_rsfp_filters, 0, datasv) ;
1794 /* Delete most recently added instance of this filter function. */
1796 Perl_filter_del(pTHX_ filter_t funcp)
1799 if (PL_filter_debug)
1800 Perl_warn(aTHX_ "filter_del func %p", funcp);
1801 #endif /* DEBUGGING */
1802 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
1804 /* if filter is on top of stack (usual case) just pop it off */
1805 if (IoDIRP(FILTER_DATA(AvFILLp(PL_rsfp_filters))) == (DIR*)funcp){
1806 IoDIRP(FILTER_DATA(AvFILLp(PL_rsfp_filters))) = NULL;
1807 sv_free(av_pop(PL_rsfp_filters));
1811 /* we need to search for the correct entry and clear it */
1812 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
1816 /* Invoke the n'th filter function for the current rsfp. */
1818 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
1821 /* 0 = read one text line */
1826 if (!PL_rsfp_filters)
1828 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
1829 /* Provide a default input filter to make life easy. */
1830 /* Note that we append to the line. This is handy. */
1832 if (PL_filter_debug)
1833 Perl_warn(aTHX_ "filter_read %d: from rsfp\n", idx);
1834 #endif /* DEBUGGING */
1838 int old_len = SvCUR(buf_sv) ;
1840 /* ensure buf_sv is large enough */
1841 SvGROW(buf_sv, old_len + maxlen) ;
1842 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1843 if (PerlIO_error(PL_rsfp))
1844 return -1; /* error */
1846 return 0 ; /* end of file */
1848 SvCUR_set(buf_sv, old_len + len) ;
1851 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
1852 if (PerlIO_error(PL_rsfp))
1853 return -1; /* error */
1855 return 0 ; /* end of file */
1858 return SvCUR(buf_sv);
1860 /* Skip this filter slot if filter has been deleted */
1861 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
1863 if (PL_filter_debug)
1864 Perl_warn(aTHX_ "filter_read %d: skipped (filter deleted)\n", idx);
1865 #endif /* DEBUGGING */
1866 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1868 /* Get function pointer hidden within datasv */
1869 funcp = (filter_t)IoDIRP(datasv);
1871 if (PL_filter_debug) {
1873 Perl_warn(aTHX_ "filter_read %d: via function %p (%s)\n",
1874 idx, funcp, SvPV(datasv,n_a));
1876 #endif /* DEBUGGING */
1877 /* Call function. The function is expected to */
1878 /* call "FILTER_READ(idx+1, buf_sv)" first. */
1879 /* Return: <0:error, =0:eof, >0:not eof */
1880 return (*funcp)(aTHXo_ idx, buf_sv, maxlen);
1884 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
1887 if (!PL_rsfp_filters) {
1888 filter_add(win32_textfilter,NULL);
1891 if (PL_rsfp_filters) {
1894 SvCUR_set(sv, 0); /* start with empty line */
1895 if (FILTER_READ(0, sv, 0) > 0)
1896 return ( SvPVX(sv) ) ;
1901 return (sv_gets(sv, fp, append));
1906 static char* exp_name[] =
1907 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
1908 "ATTRTERM", "TERMBLOCK"
1915 Works out what to call the token just pulled out of the input
1916 stream. The yacc parser takes care of taking the ops we return and
1917 stitching them into a tree.
1923 if read an identifier
1924 if we're in a my declaration
1925 croak if they tried to say my($foo::bar)
1926 build the ops for a my() declaration
1927 if it's an access to a my() variable
1928 are we in a sort block?
1929 croak if my($a); $a <=> $b
1930 build ops for access to a my() variable
1931 if in a dq string, and they've said @foo and we can't find @foo
1933 build ops for a bareword
1934 if we already built the token before, use it.
1938 #ifdef USE_PURE_BISON
1939 Perl_yylex(pTHX_ YYSTYPE *lvalp, int *lcharp)
1952 #ifdef USE_PURE_BISON
1953 yylval_pointer = lvalp;
1954 yychar_pointer = lcharp;
1957 /* check if there's an identifier for us to look at */
1958 if (PL_pending_ident) {
1959 /* pit holds the identifier we read and pending_ident is reset */
1960 char pit = PL_pending_ident;
1961 PL_pending_ident = 0;
1963 /* if we're in a my(), we can't allow dynamics here.
1964 $foo'bar has already been turned into $foo::bar, so
1965 just check for colons.
1967 if it's a legal name, the OP is a PADANY.
1970 if (strchr(PL_tokenbuf,':'))
1971 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
1973 yylval.opval = newOP(OP_PADANY, 0);
1974 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
1979 build the ops for accesses to a my() variable.
1981 Deny my($a) or my($b) in a sort block, *if* $a or $b is
1982 then used in a comparison. This catches most, but not
1983 all cases. For instance, it catches
1984 sort { my($a); $a <=> $b }
1986 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
1987 (although why you'd do that is anyone's guess).
1990 if (!strchr(PL_tokenbuf,':')) {
1992 /* Check for single character per-thread SVs */
1993 if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
1994 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
1995 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
1997 yylval.opval = newOP(OP_THREADSV, 0);
1998 yylval.opval->op_targ = tmp;
2001 #endif /* USE_THREADS */
2002 if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
2003 /* if it's a sort block and they're naming $a or $b */
2004 if (PL_last_lop_op == OP_SORT &&
2005 PL_tokenbuf[0] == '$' &&
2006 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
2009 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
2010 d < PL_bufend && *d != '\n';
2013 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
2014 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
2020 yylval.opval = newOP(OP_PADANY, 0);
2021 yylval.opval->op_targ = tmp;
2027 Whine if they've said @foo in a doublequoted string,
2028 and @foo isn't a variable we can find in the symbol
2031 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
2032 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
2033 if (!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
2034 yyerror(Perl_form(aTHX_ "In string, %s now must be written as \\%s",
2035 PL_tokenbuf, PL_tokenbuf));
2038 /* build ops for a bareword */
2039 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
2040 yylval.opval->op_private = OPpCONST_ENTERED;
2041 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
2042 ((PL_tokenbuf[0] == '$') ? SVt_PV
2043 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
2048 /* no identifier pending identification */
2050 switch (PL_lex_state) {
2052 case LEX_NORMAL: /* Some compilers will produce faster */
2053 case LEX_INTERPNORMAL: /* code if we comment these out. */
2057 /* when we've already built the next token, just pull it out of the queue */
2060 yylval = PL_nextval[PL_nexttoke];
2062 PL_lex_state = PL_lex_defer;
2063 PL_expect = PL_lex_expect;
2064 PL_lex_defer = LEX_NORMAL;
2066 return(PL_nexttype[PL_nexttoke]);
2068 /* interpolated case modifiers like \L \U, including \Q and \E.
2069 when we get here, PL_bufptr is at the \
2071 case LEX_INTERPCASEMOD:
2073 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
2074 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
2076 /* handle \E or end of string */
2077 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
2081 if (PL_lex_casemods) {
2082 oldmod = PL_lex_casestack[--PL_lex_casemods];
2083 PL_lex_casestack[PL_lex_casemods] = '\0';
2085 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
2087 PL_lex_state = LEX_INTERPCONCAT;
2091 if (PL_bufptr != PL_bufend)
2093 PL_lex_state = LEX_INTERPCONCAT;
2098 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
2099 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
2100 if (strchr("LU", *s) &&
2101 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
2103 PL_lex_casestack[--PL_lex_casemods] = '\0';
2106 if (PL_lex_casemods > 10) {
2107 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
2108 if (newlb != PL_lex_casestack) {
2110 PL_lex_casestack = newlb;
2113 PL_lex_casestack[PL_lex_casemods++] = *s;
2114 PL_lex_casestack[PL_lex_casemods] = '\0';
2115 PL_lex_state = LEX_INTERPCONCAT;
2116 PL_nextval[PL_nexttoke].ival = 0;
2119 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
2121 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
2123 PL_nextval[PL_nexttoke].ival = OP_LC;
2125 PL_nextval[PL_nexttoke].ival = OP_UC;
2127 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
2129 Perl_croak(aTHX_ "panic: yylex");
2132 if (PL_lex_starts) {
2141 case LEX_INTERPPUSH:
2142 return sublex_push();
2144 case LEX_INTERPSTART:
2145 if (PL_bufptr == PL_bufend)
2146 return sublex_done();
2148 PL_lex_dojoin = (*PL_bufptr == '@');
2149 PL_lex_state = LEX_INTERPNORMAL;
2150 if (PL_lex_dojoin) {
2151 PL_nextval[PL_nexttoke].ival = 0;
2154 PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
2155 PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
2156 force_next(PRIVATEREF);
2158 force_ident("\"", '$');
2159 #endif /* USE_THREADS */
2160 PL_nextval[PL_nexttoke].ival = 0;
2162 PL_nextval[PL_nexttoke].ival = 0;
2164 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
2167 if (PL_lex_starts++) {
2173 case LEX_INTERPENDMAYBE:
2174 if (intuit_more(PL_bufptr)) {
2175 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
2181 if (PL_lex_dojoin) {
2182 PL_lex_dojoin = FALSE;
2183 PL_lex_state = LEX_INTERPCONCAT;
2186 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
2187 && SvEVALED(PL_lex_repl))
2189 if (PL_bufptr != PL_bufend)
2190 Perl_croak(aTHX_ "Bad evalled substitution pattern");
2191 PL_lex_repl = Nullsv;
2194 case LEX_INTERPCONCAT:
2196 if (PL_lex_brackets)
2197 Perl_croak(aTHX_ "panic: INTERPCONCAT");
2199 if (PL_bufptr == PL_bufend)
2200 return sublex_done();
2202 if (SvIVX(PL_linestr) == '\'') {
2203 SV *sv = newSVsv(PL_linestr);
2206 else if ( PL_hints & HINT_NEW_RE )
2207 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
2208 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2212 s = scan_const(PL_bufptr);
2214 PL_lex_state = LEX_INTERPCASEMOD;
2216 PL_lex_state = LEX_INTERPSTART;
2219 if (s != PL_bufptr) {
2220 PL_nextval[PL_nexttoke] = yylval;
2223 if (PL_lex_starts++)
2233 PL_lex_state = LEX_NORMAL;
2234 s = scan_formline(PL_bufptr);
2235 if (!PL_lex_formbrack)
2241 PL_oldoldbufptr = PL_oldbufptr;
2244 PerlIO_printf(PerlIO_stderr(), "### Tokener expecting %s at %s\n", exp_name[PL_expect], s);
2250 if (isIDFIRST_lazy(s))
2252 Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
2255 goto fake_eof; /* emulate EOF on ^D or ^Z */
2260 if (PL_lex_brackets)
2261 yyerror("Missing right curly or square bracket");
2264 if (s++ < PL_bufend)
2265 goto retry; /* ignore stray nulls */
2268 if (!PL_in_eval && !PL_preambled) {
2269 PL_preambled = TRUE;
2270 sv_setpv(PL_linestr,incl_perldb());
2271 if (SvCUR(PL_linestr))
2272 sv_catpv(PL_linestr,";");
2274 while(AvFILLp(PL_preambleav) >= 0) {
2275 SV *tmpsv = av_shift(PL_preambleav);
2276 sv_catsv(PL_linestr, tmpsv);
2277 sv_catpv(PL_linestr, ";");
2280 sv_free((SV*)PL_preambleav);
2281 PL_preambleav = NULL;
2283 if (PL_minus_n || PL_minus_p) {
2284 sv_catpv(PL_linestr, "LINE: while (<>) {");
2286 sv_catpv(PL_linestr,"chomp;");
2288 GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
2290 GvIMPORTED_AV_on(gv);
2292 if (strchr("/'\"", *PL_splitstr)
2293 && strchr(PL_splitstr + 1, *PL_splitstr))
2294 Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s);", PL_splitstr);
2297 s = "'~#\200\1'"; /* surely one char is unused...*/
2298 while (s[1] && strchr(PL_splitstr, *s)) s++;
2300 Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s%c",
2301 "q" + (delim == '\''), delim);
2302 for (s = PL_splitstr; *s; s++) {
2304 sv_catpvn(PL_linestr, "\\", 1);
2305 sv_catpvn(PL_linestr, s, 1);
2307 Perl_sv_catpvf(aTHX_ PL_linestr, "%c);", delim);
2311 sv_catpv(PL_linestr,"@F=split(' ');");
2314 sv_catpv(PL_linestr, "\n");
2315 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2316 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2317 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2318 SV *sv = NEWSV(85,0);
2320 sv_upgrade(sv, SVt_PVMG);
2321 sv_setsv(sv,PL_linestr);
2322 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
2327 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
2330 if (PL_preprocess && !PL_in_eval)
2331 (void)PerlProc_pclose(PL_rsfp);
2332 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2333 PerlIO_clearerr(PL_rsfp);
2335 (void)PerlIO_close(PL_rsfp);
2337 PL_doextract = FALSE;
2339 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2340 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
2341 sv_catpv(PL_linestr,";}");
2342 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2343 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2344 PL_minus_n = PL_minus_p = 0;
2347 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2348 sv_setpv(PL_linestr,"");
2349 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
2352 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
2353 PL_doextract = FALSE;
2355 /* Incest with pod. */
2356 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2357 sv_setpv(PL_linestr, "");
2358 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2359 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2360 PL_doextract = FALSE;
2364 } while (PL_doextract);
2365 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2366 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2367 SV *sv = NEWSV(85,0);
2369 sv_upgrade(sv, SVt_PVMG);
2370 sv_setsv(sv,PL_linestr);
2371 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
2373 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2374 if (PL_curcop->cop_line == 1) {
2375 while (s < PL_bufend && isSPACE(*s))
2377 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2381 if (*s == '#' && *(s+1) == '!')
2383 #ifdef ALTERNATE_SHEBANG
2385 static char as[] = ALTERNATE_SHEBANG;
2386 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2387 d = s + (sizeof(as) - 1);
2389 #endif /* ALTERNATE_SHEBANG */
2398 while (*d && !isSPACE(*d))
2402 #ifdef ARG_ZERO_IS_SCRIPT
2403 if (ipathend > ipath) {
2405 * HP-UX (at least) sets argv[0] to the script name,
2406 * which makes $^X incorrect. And Digital UNIX and Linux,
2407 * at least, set argv[0] to the basename of the Perl
2408 * interpreter. So, having found "#!", we'll set it right.
2410 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
2411 assert(SvPOK(x) || SvGMAGICAL(x));
2412 if (sv_eq(x, GvSV(PL_curcop->cop_filegv))) {
2413 sv_setpvn(x, ipath, ipathend - ipath);
2416 TAINT_NOT; /* $^X is always tainted, but that's OK */
2418 #endif /* ARG_ZERO_IS_SCRIPT */
2423 d = instr(s,"perl -");
2425 d = instr(s,"perl");
2426 #ifdef ALTERNATE_SHEBANG
2428 * If the ALTERNATE_SHEBANG on this system starts with a
2429 * character that can be part of a Perl expression, then if
2430 * we see it but not "perl", we're probably looking at the
2431 * start of Perl code, not a request to hand off to some
2432 * other interpreter. Similarly, if "perl" is there, but
2433 * not in the first 'word' of the line, we assume the line
2434 * contains the start of the Perl program.
2436 if (d && *s != '#') {
2438 while (*c && !strchr("; \t\r\n\f\v#", *c))
2441 d = Nullch; /* "perl" not in first word; ignore */
2443 *s = '#'; /* Don't try to parse shebang line */
2445 #endif /* ALTERNATE_SHEBANG */
2450 !instr(s,"indir") &&
2451 instr(PL_origargv[0],"perl"))
2457 while (s < PL_bufend && isSPACE(*s))
2459 if (s < PL_bufend) {
2460 Newz(899,newargv,PL_origargc+3,char*);
2462 while (s < PL_bufend && !isSPACE(*s))
2465 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2468 newargv = PL_origargv;
2470 PerlProc_execv(ipath, newargv);
2471 Perl_croak(aTHX_ "Can't exec %s", ipath);
2474 U32 oldpdb = PL_perldb;
2475 bool oldn = PL_minus_n;
2476 bool oldp = PL_minus_p;
2478 while (*d && !isSPACE(*d)) d++;
2479 while (*d == ' ' || *d == '\t') d++;
2483 if (*d == 'M' || *d == 'm') {
2485 while (*d && !isSPACE(*d)) d++;
2486 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2489 d = moreswitches(d);
2491 if (PERLDB_LINE && !oldpdb ||
2492 ( PL_minus_n || PL_minus_p ) && !(oldn || oldp) )
2493 /* if we have already added "LINE: while (<>) {",
2494 we must not do it again */
2496 sv_setpv(PL_linestr, "");
2497 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2498 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2499 PL_preambled = FALSE;
2501 (void)gv_fetchfile(PL_origfilename);
2508 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2510 PL_lex_state = LEX_FORMLINE;
2515 #ifdef PERL_STRICT_CR
2516 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2518 "(Maybe you didn't strip carriage returns after a network transfer?)\n");
2520 case ' ': case '\t': case '\f': case 013:
2525 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2527 while (s < d && *s != '\n')
2532 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2534 PL_lex_state = LEX_FORMLINE;
2544 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2549 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2552 if (strnEQ(s,"=>",2)) {
2553 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2554 OPERATOR('-'); /* unary minus */
2556 PL_last_uni = PL_oldbufptr;
2557 PL_last_lop_op = OP_FTEREAD; /* good enough */
2559 case 'r': FTST(OP_FTEREAD);
2560 case 'w': FTST(OP_FTEWRITE);
2561 case 'x': FTST(OP_FTEEXEC);
2562 case 'o': FTST(OP_FTEOWNED);
2563 case 'R': FTST(OP_FTRREAD);
2564 case 'W': FTST(OP_FTRWRITE);
2565 case 'X': FTST(OP_FTREXEC);
2566 case 'O': FTST(OP_FTROWNED);
2567 case 'e': FTST(OP_FTIS);
2568 case 'z': FTST(OP_FTZERO);
2569 case 's': FTST(OP_FTSIZE);
2570 case 'f': FTST(OP_FTFILE);
2571 case 'd': FTST(OP_FTDIR);
2572 case 'l': FTST(OP_FTLINK);
2573 case 'p': FTST(OP_FTPIPE);
2574 case 'S': FTST(OP_FTSOCK);
2575 case 'u': FTST(OP_FTSUID);
2576 case 'g': FTST(OP_FTSGID);
2577 case 'k': FTST(OP_FTSVTX);
2578 case 'b': FTST(OP_FTBLK);
2579 case 'c': FTST(OP_FTCHR);
2580 case 't': FTST(OP_FTTTY);
2581 case 'T': FTST(OP_FTTEXT);
2582 case 'B': FTST(OP_FTBINARY);
2583 case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2584 case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2585 case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
2587 Perl_croak(aTHX_ "Unrecognized file test: -%c", (int)tmp);
2594 if (PL_expect == XOPERATOR)
2599 else if (*s == '>') {
2602 if (isIDFIRST_lazy(s)) {
2603 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2611 if (PL_expect == XOPERATOR)
2614 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2616 OPERATOR('-'); /* unary minus */
2623 if (PL_expect == XOPERATOR)
2628 if (PL_expect == XOPERATOR)
2631 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2637 if (PL_expect != XOPERATOR) {
2638 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2639 PL_expect = XOPERATOR;
2640 force_ident(PL_tokenbuf, '*');
2653 if (PL_expect == XOPERATOR) {
2657 PL_tokenbuf[0] = '%';
2658 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2659 if (!PL_tokenbuf[1]) {
2661 yyerror("Final % should be \\% or %name");
2664 PL_pending_ident = '%';
2683 switch (PL_expect) {
2686 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
2688 PL_bufptr = s; /* update in case we back off */
2694 PL_expect = XTERMBLOCK;
2698 while (isIDFIRST_lazy(s)) {
2699 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2701 d = scan_str(d,TRUE,TRUE);
2704 SvREFCNT_dec(PL_lex_stuff);
2705 PL_lex_stuff = Nullsv;
2707 /* MUST advance bufptr here to avoid bogus
2708 "at end of line" context messages from yyerror().
2710 PL_bufptr = s + len;
2711 yyerror("Unterminated attribute parameter in attribute list");
2714 return 0; /* EOF indicator */
2718 SV *sv = newSVpvn(s, len);
2719 sv_catsv(sv, PL_lex_stuff);
2720 attrs = append_elem(OP_LIST, attrs,
2721 newSVOP(OP_CONST, 0, sv));
2722 SvREFCNT_dec(PL_lex_stuff);
2723 PL_lex_stuff = Nullsv;
2726 attrs = append_elem(OP_LIST, attrs,
2727 newSVOP(OP_CONST, 0,
2734 tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}' for vi */
2735 if (*s != ';' && *s != tmp) {
2736 char q = ((*s == '\'') ? '"' : '\'');
2737 /* If here for an expression, and parsed no attrs, back off. */
2738 if (tmp == '=' && !attrs) {
2742 /* MUST advance bufptr here to avoid bogus "at end of line"
2743 context messages from yyerror().
2747 yyerror("Unterminated attribute list");
2749 yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list",
2756 PL_nextval[PL_nexttoke].opval = attrs;
2764 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
2765 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
2770 if (PL_curcop->cop_line < PL_copline)
2771 PL_copline = PL_curcop->cop_line;
2782 if (PL_lex_brackets <= 0)
2783 yyerror("Unmatched right square bracket");
2786 if (PL_lex_state == LEX_INTERPNORMAL) {
2787 if (PL_lex_brackets == 0) {
2788 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
2789 PL_lex_state = LEX_INTERPEND;
2796 if (PL_lex_brackets > 100) {
2797 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
2798 if (newlb != PL_lex_brackstack) {
2800 PL_lex_brackstack = newlb;
2803 switch (PL_expect) {
2805 if (PL_lex_formbrack) {
2809 if (PL_oldoldbufptr == PL_last_lop)
2810 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2812 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2813 OPERATOR(HASHBRACK);
2815 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2818 PL_tokenbuf[0] = '\0';
2819 if (d < PL_bufend && *d == '-') {
2820 PL_tokenbuf[0] = '-';
2822 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2825 if (d < PL_bufend && isIDFIRST_lazy(d)) {
2826 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2828 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2831 char minus = (PL_tokenbuf[0] == '-');
2832 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2840 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
2845 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2850 if (PL_oldoldbufptr == PL_last_lop)
2851 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2853 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2856 OPERATOR(HASHBRACK);
2857 /* This hack serves to disambiguate a pair of curlies
2858 * as being a block or an anon hash. Normally, expectation
2859 * determines that, but in cases where we're not in a
2860 * position to expect anything in particular (like inside
2861 * eval"") we have to resolve the ambiguity. This code
2862 * covers the case where the first term in the curlies is a
2863 * quoted string. Most other cases need to be explicitly
2864 * disambiguated by prepending a `+' before the opening
2865 * curly in order to force resolution as an anon hash.
2867 * XXX should probably propagate the outer expectation
2868 * into eval"" to rely less on this hack, but that could
2869 * potentially break current behavior of eval"".
2873 if (*s == '\'' || *s == '"' || *s == '`') {
2874 /* common case: get past first string, handling escapes */
2875 for (t++; t < PL_bufend && *t != *s;)
2876 if (*t++ == '\\' && (*t == '\\' || *t == *s))
2880 else if (*s == 'q') {
2883 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
2884 && !isALNUM(*t)))) {
2886 char open, close, term;
2889 while (t < PL_bufend && isSPACE(*t))
2893 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
2897 for (t++; t < PL_bufend; t++) {
2898 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
2900 else if (*t == open)
2904 for (t++; t < PL_bufend; t++) {
2905 if (*t == '\\' && t+1 < PL_bufend)
2907 else if (*t == close && --brackets <= 0)
2909 else if (*t == open)
2915 else if (isIDFIRST_lazy(s)) {
2916 for (t++; t < PL_bufend && isALNUM_lazy(t); t++) ;
2918 while (t < PL_bufend && isSPACE(*t))
2920 /* if comma follows first term, call it an anon hash */
2921 /* XXX it could be a comma expression with loop modifiers */
2922 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
2923 || (*t == '=' && t[1] == '>')))
2924 OPERATOR(HASHBRACK);
2925 if (PL_expect == XREF)
2928 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
2934 yylval.ival = PL_curcop->cop_line;
2935 if (isSPACE(*s) || *s == '#')
2936 PL_copline = NOLINE; /* invalidate current command line number */
2941 if (PL_lex_brackets <= 0)
2942 yyerror("Unmatched right curly bracket");
2944 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
2945 if (PL_lex_brackets < PL_lex_formbrack)
2946 PL_lex_formbrack = 0;
2947 if (PL_lex_state == LEX_INTERPNORMAL) {
2948 if (PL_lex_brackets == 0) {
2949 if (PL_lex_fakebrack) {
2950 PL_lex_state = LEX_INTERPEND;
2952 return yylex(); /* ignore fake brackets */
2954 if (*s == '-' && s[1] == '>')
2955 PL_lex_state = LEX_INTERPENDMAYBE;
2956 else if (*s != '[' && *s != '{')
2957 PL_lex_state = LEX_INTERPEND;
2960 if (PL_lex_brackets < PL_lex_fakebrack) {
2962 PL_lex_fakebrack = 0;
2963 return yylex(); /* ignore fake brackets */
2973 if (PL_expect == XOPERATOR) {
2974 if (ckWARN(WARN_SEMICOLON) && isIDFIRST_lazy(s) && PL_bufptr == PL_linestart) {
2975 PL_curcop->cop_line--;
2976 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
2977 PL_curcop->cop_line++;
2982 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2984 PL_expect = XOPERATOR;
2985 force_ident(PL_tokenbuf, '&');
2989 yylval.ival = (OPpENTERSUB_AMPER<<8);
3008 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
3009 Perl_warner(aTHX_ WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
3011 if (PL_expect == XSTATE && isALPHA(tmp) &&
3012 (s == PL_linestart+1 || s[-2] == '\n') )
3014 if (PL_in_eval && !PL_rsfp) {
3019 if (strnEQ(s,"=cut",4)) {
3033 PL_doextract = TRUE;
3036 if (PL_lex_brackets < PL_lex_formbrack) {
3038 #ifdef PERL_STRICT_CR
3039 for (t = s; *t == ' ' || *t == '\t'; t++) ;
3041 for (t = s; *t == ' ' || *t == '\t' || *t == '\r'; t++) ;
3043 if (*t == '\n' || *t == '#') {
3061 if (PL_expect != XOPERATOR) {
3062 if (s[1] != '<' && !strchr(s,'>'))
3065 s = scan_heredoc(s);
3067 s = scan_inputsymbol(s);
3068 TERM(sublex_start());
3073 SHop(OP_LEFT_SHIFT);
3087 SHop(OP_RIGHT_SHIFT);
3096 if (PL_expect == XOPERATOR) {
3097 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3100 return ','; /* grandfather non-comma-format format */
3104 if (s[1] == '#' && (isIDFIRST_lazy(s+2) || strchr("{$:+-", s[2]))) {
3105 PL_tokenbuf[0] = '@';
3106 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3107 sizeof PL_tokenbuf - 1, FALSE);
3108 if (PL_expect == XOPERATOR)
3109 no_op("Array length", s);
3110 if (!PL_tokenbuf[1])
3112 PL_expect = XOPERATOR;
3113 PL_pending_ident = '#';
3117 PL_tokenbuf[0] = '$';
3118 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3119 sizeof PL_tokenbuf - 1, FALSE);
3120 if (PL_expect == XOPERATOR)
3122 if (!PL_tokenbuf[1]) {
3124 yyerror("Final $ should be \\$ or $name");
3128 /* This kludge not intended to be bulletproof. */
3129 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
3130 yylval.opval = newSVOP(OP_CONST, 0,
3131 newSViv((IV)PL_compiling.cop_arybase));
3132 yylval.opval->op_private = OPpCONST_ARYBASE;
3138 if (PL_lex_state == LEX_NORMAL)
3141 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3144 PL_tokenbuf[0] = '@';
3145 if (ckWARN(WARN_SYNTAX)) {
3147 isSPACE(*t) || isALNUM_lazy(t) || *t == '$';
3150 PL_bufptr = skipspace(PL_bufptr);
3151 while (t < PL_bufend && *t != ']')
3153 Perl_warner(aTHX_ WARN_SYNTAX,
3154 "Multidimensional syntax %.*s not supported",
3155 (t - PL_bufptr) + 1, PL_bufptr);
3159 else if (*s == '{') {
3160 PL_tokenbuf[0] = '%';
3161 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
3162 (t = strchr(s, '}')) && (t = strchr(t, '=')))
3164 char tmpbuf[sizeof PL_tokenbuf];
3166 for (t++; isSPACE(*t); t++) ;
3167 if (isIDFIRST_lazy(t)) {
3168 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
3169 for (; isSPACE(*t); t++) ;
3170 if (*t == ';' && get_cv(tmpbuf, FALSE))
3171 Perl_warner(aTHX_ WARN_SYNTAX,
3172 "You need to quote \"%s\"", tmpbuf);
3178 PL_expect = XOPERATOR;
3179 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3180 bool islop = (PL_last_lop == PL_oldoldbufptr);
3181 if (!islop || PL_last_lop_op == OP_GREPSTART)
3182 PL_expect = XOPERATOR;
3183 else if (strchr("$@\"'`q", *s))
3184 PL_expect = XTERM; /* e.g. print $fh "foo" */
3185 else if (strchr("&*<%", *s) && isIDFIRST_lazy(s+1))
3186 PL_expect = XTERM; /* e.g. print $fh &sub */
3187 else if (isIDFIRST_lazy(s)) {
3188 char tmpbuf[sizeof PL_tokenbuf];
3189 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3190 if (tmp = keyword(tmpbuf, len)) {
3191 /* binary operators exclude handle interpretations */
3203 PL_expect = XTERM; /* e.g. print $fh length() */
3208 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
3209 if (gv && GvCVu(gv))
3210 PL_expect = XTERM; /* e.g. print $fh subr() */
3213 else if (isDIGIT(*s))
3214 PL_expect = XTERM; /* e.g. print $fh 3 */
3215 else if (*s == '.' && isDIGIT(s[1]))
3216 PL_expect = XTERM; /* e.g. print $fh .3 */
3217 else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
3218 PL_expect = XTERM; /* e.g. print $fh -1 */
3219 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3220 PL_expect = XTERM; /* print $fh <<"EOF" */
3222 PL_pending_ident = '$';
3226 if (PL_expect == XOPERATOR)
3228 PL_tokenbuf[0] = '@';
3229 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3230 if (!PL_tokenbuf[1]) {
3232 yyerror("Final @ should be \\@ or @name");
3235 if (PL_lex_state == LEX_NORMAL)
3237 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3239 PL_tokenbuf[0] = '%';
3241 /* Warn about @ where they meant $. */
3242 if (ckWARN(WARN_SYNTAX)) {
3243 if (*s == '[' || *s == '{') {
3245 while (*t && (isALNUM_lazy(t) || strchr(" \t$#+-'\"", *t)))
3247 if (*t == '}' || *t == ']') {
3249 PL_bufptr = skipspace(PL_bufptr);
3250 Perl_warner(aTHX_ WARN_SYNTAX,
3251 "Scalar value %.*s better written as $%.*s",
3252 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
3257 PL_pending_ident = '@';
3260 case '/': /* may either be division or pattern */
3261 case '?': /* may either be conditional or pattern */
3262 if (PL_expect != XOPERATOR) {
3263 /* Disable warning on "study /blah/" */
3264 if (PL_oldoldbufptr == PL_last_uni
3265 && (*PL_last_uni != 's' || s - PL_last_uni < 5
3266 || memNE(PL_last_uni, "study", 5) || isALNUM_lazy(PL_last_uni+5)))
3268 s = scan_pat(s,OP_MATCH);
3269 TERM(sublex_start());
3277 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3278 #ifdef PERL_STRICT_CR
3281 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3283 && (s == PL_linestart || s[-1] == '\n') )
3285 PL_lex_formbrack = 0;
3289 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
3295 yylval.ival = OPf_SPECIAL;
3301 if (PL_expect != XOPERATOR)
3306 case '0': case '1': case '2': case '3': case '4':
3307 case '5': case '6': case '7': case '8': case '9':
3309 if (PL_expect == XOPERATOR)
3314 s = scan_str(s,FALSE,FALSE);
3315 if (PL_expect == XOPERATOR) {
3316 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3319 return ','; /* grandfather non-comma-format format */
3325 missingterm((char*)0);
3326 yylval.ival = OP_CONST;
3327 TERM(sublex_start());
3330 s = scan_str(s,FALSE,FALSE);
3331 if (PL_expect == XOPERATOR) {
3332 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3335 return ','; /* grandfather non-comma-format format */
3341 missingterm((char*)0);
3342 yylval.ival = OP_CONST;
3343 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
3344 if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
3345 yylval.ival = OP_STRINGIFY;
3349 TERM(sublex_start());
3352 s = scan_str(s,FALSE,FALSE);
3353 if (PL_expect == XOPERATOR)
3354 no_op("Backticks",s);
3356 missingterm((char*)0);
3357 yylval.ival = OP_BACKTICK;
3359 TERM(sublex_start());
3363 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
3364 Perl_warner(aTHX_ WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
3366 if (PL_expect == XOPERATOR)
3367 no_op("Backslash",s);
3371 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
3411 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3413 /* Some keywords can be followed by any delimiter, including ':' */
3414 tmp = (len == 1 && strchr("msyq", PL_tokenbuf[0]) ||
3415 len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
3416 (PL_tokenbuf[0] == 'q' &&
3417 strchr("qwxr", PL_tokenbuf[1]))));
3419 /* x::* is just a word, unless x is "CORE" */
3420 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
3424 while (d < PL_bufend && isSPACE(*d))
3425 d++; /* no comments skipped here, or s### is misparsed */
3427 /* Is this a label? */
3428 if (!tmp && PL_expect == XSTATE
3429 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
3431 yylval.pval = savepv(PL_tokenbuf);
3436 /* Check for keywords */
3437 tmp = keyword(PL_tokenbuf, len);
3439 /* Is this a word before a => operator? */
3440 if (strnEQ(d,"=>",2)) {
3442 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
3443 yylval.opval->op_private = OPpCONST_BARE;
3447 if (tmp < 0) { /* second-class keyword? */
3448 GV *ogv = Nullgv; /* override (winner) */
3449 GV *hgv = Nullgv; /* hidden (loser) */
3450 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3452 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3455 if (GvIMPORTED_CV(gv))
3457 else if (! CvMETHOD(cv))
3461 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3462 (gv = *gvp) != (GV*)&PL_sv_undef &&
3463 GvCVu(gv) && GvIMPORTED_CV(gv))
3469 tmp = 0; /* overridden by import or by GLOBAL */
3472 && -tmp==KEY_lock /* XXX generalizable kludge */
3473 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3475 tmp = 0; /* any sub overrides "weak" keyword */
3477 else { /* no override */
3481 if (ckWARN(WARN_AMBIGUOUS) && hgv
3482 && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3483 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3484 "Ambiguous call resolved as CORE::%s(), %s",
3485 GvENAME(hgv), "qualify as such or use &");
3492 default: /* not a keyword */
3495 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3497 /* Get the rest if it looks like a package qualifier */
3499 if (*s == '\'' || *s == ':' && s[1] == ':') {
3501 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3504 Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
3505 *s == '\'' ? "'" : "::");
3509 if (PL_expect == XOPERATOR) {
3510 if (PL_bufptr == PL_linestart) {
3511 PL_curcop->cop_line--;
3512 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3513 PL_curcop->cop_line++;
3516 no_op("Bareword",s);
3519 /* Look for a subroutine with this name in current package,
3520 unless name is "Foo::", in which case Foo is a bearword
3521 (and a package name). */
3524 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3526 if (ckWARN(WARN_UNSAFE) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3527 Perl_warner(aTHX_ WARN_UNSAFE,
3528 "Bareword \"%s\" refers to nonexistent package",
3531 PL_tokenbuf[len] = '\0';
3538 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3541 /* if we saw a global override before, get the right name */
3544 sv = newSVpvn("CORE::GLOBAL::",14);
3545 sv_catpv(sv,PL_tokenbuf);
3548 sv = newSVpv(PL_tokenbuf,0);
3550 /* Presume this is going to be a bareword of some sort. */
3553 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3554 yylval.opval->op_private = OPpCONST_BARE;
3556 /* And if "Foo::", then that's what it certainly is. */
3561 /* See if it's the indirect object for a list operator. */
3563 if (PL_oldoldbufptr &&
3564 PL_oldoldbufptr < PL_bufptr &&
3565 (PL_oldoldbufptr == PL_last_lop || PL_oldoldbufptr == PL_last_uni) &&
3566 /* NO SKIPSPACE BEFORE HERE! */
3567 (PL_expect == XREF ||
3568 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
3570 bool immediate_paren = *s == '(';
3572 /* (Now we can afford to cross potential line boundary.) */
3575 /* Two barewords in a row may indicate method call. */
3577 if ((isIDFIRST_lazy(s) || *s == '$') && (tmp=intuit_method(s,gv)))
3580 /* If not a declared subroutine, it's an indirect object. */
3581 /* (But it's an indir obj regardless for sort.) */
3583 if ((PL_last_lop_op == OP_SORT ||
3584 (!immediate_paren && (!gv || !GvCVu(gv)))) &&
3585 (PL_last_lop_op != OP_MAPSTART &&
3586 PL_last_lop_op != OP_GREPSTART))
3588 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3593 /* If followed by a paren, it's certainly a subroutine. */
3595 PL_expect = XOPERATOR;
3599 if (gv && GvCVu(gv)) {
3600 for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
3601 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
3606 PL_nextval[PL_nexttoke].opval = yylval.opval;
3607 PL_expect = XOPERATOR;
3613 /* If followed by var or block, call it a method (unless sub) */
3615 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3616 PL_last_lop = PL_oldbufptr;
3617 PL_last_lop_op = OP_METHOD;
3621 /* If followed by a bareword, see if it looks like indir obj. */
3623 if ((isIDFIRST_lazy(s) || *s == '$') && (tmp = intuit_method(s,gv)))
3626 /* Not a method, so call it a subroutine (if defined) */
3628 if (gv && GvCVu(gv)) {
3630 if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
3631 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3632 "Ambiguous use of -%s resolved as -&%s()",
3633 PL_tokenbuf, PL_tokenbuf);
3634 /* Check for a constant sub */
3636 if ((sv = cv_const_sv(cv))) {
3638 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3639 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3640 yylval.opval->op_private = 0;
3644 /* Resolve to GV now. */
3645 op_free(yylval.opval);
3646 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3647 yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
3648 PL_last_lop = PL_oldbufptr;
3649 PL_last_lop_op = OP_ENTERSUB;
3650 /* Is there a prototype? */
3653 char *proto = SvPV((SV*)cv, len);
3656 if (strEQ(proto, "$"))
3658 if (*proto == '&' && *s == '{') {
3659 sv_setpv(PL_subname,"__ANON__");
3663 PL_nextval[PL_nexttoke].opval = yylval.opval;
3669 /* Call it a bare word */
3671 if (PL_hints & HINT_STRICT_SUBS)
3672 yylval.opval->op_private |= OPpCONST_STRICT;
3675 if (ckWARN(WARN_RESERVED)) {
3676 if (lastchar != '-') {
3677 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3679 Perl_warner(aTHX_ WARN_RESERVED, PL_warn_reserved,
3686 if (lastchar && strchr("*%&", lastchar) && ckWARN_d(WARN_AMBIGUOUS)) {
3687 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3688 "Operator or semicolon missing before %c%s",
3689 lastchar, PL_tokenbuf);
3690 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3691 "Ambiguous use of %c resolved as operator %c",
3692 lastchar, lastchar);
3698 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3699 newSVsv(GvSV(PL_curcop->cop_filegv)));
3704 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3705 Perl_newSVpvf(aTHX_ "%" PERL_PRId64, (IV)PL_curcop->cop_line));
3707 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3708 Perl_newSVpvf(aTHX_ "%ld", (long)PL_curcop->cop_line));
3712 case KEY___PACKAGE__:
3713 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3715 ? newSVsv(PL_curstname)
3724 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3725 char *pname = "main";
3726 if (PL_tokenbuf[2] == 'D')
3727 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3728 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
3731 GvIOp(gv) = newIO();
3732 IoIFP(GvIOp(gv)) = PL_rsfp;
3733 #if defined(HAS_FCNTL) && defined(F_SETFD)
3735 int fd = PerlIO_fileno(PL_rsfp);
3736 fcntl(fd,F_SETFD,fd >= 3);
3739 /* Mark this internal pseudo-handle as clean */
3740 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3742 IoTYPE(GvIOp(gv)) = '|';
3743 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
3744 IoTYPE(GvIOp(gv)) = '-';
3746 IoTYPE(GvIOp(gv)) = '<';
3757 if (PL_expect == XSTATE) {
3764 if (*s == ':' && s[1] == ':') {
3767 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3768 tmp = keyword(PL_tokenbuf, len);
3782 LOP(OP_ACCEPT,XTERM);
3788 LOP(OP_ATAN2,XTERM);
3797 LOP(OP_BLESS,XTERM);
3806 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
3823 if (!PL_cryptseen++)
3826 LOP(OP_CRYPT,XTERM);
3829 if (ckWARN(WARN_OCTAL)) {
3830 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
3831 if (*d != '0' && isDIGIT(*d))
3832 Perl_warner(aTHX_ WARN_OCTAL,
3833 "chmod: mode argument is missing initial 0");
3835 LOP(OP_CHMOD,XTERM);
3838 LOP(OP_CHOWN,XTERM);
3841 LOP(OP_CONNECT,XTERM);
3857 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3861 PL_hints |= HINT_BLOCK_SCOPE;
3871 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3872 LOP(OP_DBMOPEN,XTERM);
3878 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3885 yylval.ival = PL_curcop->cop_line;
3899 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
3900 UNIBRACK(OP_ENTEREVAL);
3915 case KEY_endhostent:
3921 case KEY_endservent:
3924 case KEY_endprotoent:
3935 yylval.ival = PL_curcop->cop_line;
3937 if (PL_expect == XSTATE && isIDFIRST_lazy(s)) {
3939 if ((PL_bufend - p) >= 3 &&
3940 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3943 if (isIDFIRST_lazy(p))
3944 Perl_croak(aTHX_ "Missing $ on loop variable");
3949 LOP(OP_FORMLINE,XTERM);
3955 LOP(OP_FCNTL,XTERM);
3961 LOP(OP_FLOCK,XTERM);
3970 LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
3973 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3988 case KEY_getpriority:
3989 LOP(OP_GETPRIORITY,XTERM);
3991 case KEY_getprotobyname:
3994 case KEY_getprotobynumber:
3995 LOP(OP_GPBYNUMBER,XTERM);
3997 case KEY_getprotoent:
4009 case KEY_getpeername:
4010 UNI(OP_GETPEERNAME);
4012 case KEY_gethostbyname:
4015 case KEY_gethostbyaddr:
4016 LOP(OP_GHBYADDR,XTERM);
4018 case KEY_gethostent:
4021 case KEY_getnetbyname:
4024 case KEY_getnetbyaddr:
4025 LOP(OP_GNBYADDR,XTERM);
4030 case KEY_getservbyname:
4031 LOP(OP_GSBYNAME,XTERM);
4033 case KEY_getservbyport:
4034 LOP(OP_GSBYPORT,XTERM);
4036 case KEY_getservent:
4039 case KEY_getsockname:
4040 UNI(OP_GETSOCKNAME);
4042 case KEY_getsockopt:
4043 LOP(OP_GSOCKOPT,XTERM);
4065 yylval.ival = PL_curcop->cop_line;
4069 LOP(OP_INDEX,XTERM);
4075 LOP(OP_IOCTL,XTERM);
4087 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4119 LOP(OP_LISTEN,XTERM);
4128 s = scan_pat(s,OP_MATCH);
4129 TERM(sublex_start());
4132 LOP(OP_MAPSTART, *s == '(' ? XTERM : XREF);
4135 LOP(OP_MKDIR,XTERM);
4138 LOP(OP_MSGCTL,XTERM);
4141 LOP(OP_MSGGET,XTERM);
4144 LOP(OP_MSGRCV,XTERM);
4147 LOP(OP_MSGSND,XTERM);
4152 if (isIDFIRST_lazy(s)) {
4153 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
4154 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
4156 PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
4157 if (!PL_in_my_stash) {
4160 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
4168 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4175 if (PL_expect != XSTATE)
4176 yyerror("\"no\" not allowed in expression");
4177 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4178 s = force_version(s);
4187 if (isIDFIRST_lazy(s)) {
4189 for (d = s; isALNUM_lazy(d); d++) ;
4191 if (strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_AMBIGUOUS))
4192 Perl_warner(aTHX_ WARN_AMBIGUOUS,
4193 "Precedence problem: open %.*s should be open(%.*s)",
4199 yylval.ival = OP_OR;
4209 LOP(OP_OPEN_DIR,XTERM);
4212 checkcomma(s,PL_tokenbuf,"filehandle");
4216 checkcomma(s,PL_tokenbuf,"filehandle");
4235 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4239 LOP(OP_PIPE_OP,XTERM);
4242 s = scan_str(s,FALSE,FALSE);
4244 missingterm((char*)0);
4245 yylval.ival = OP_CONST;
4246 TERM(sublex_start());
4252 s = scan_str(s,FALSE,FALSE);
4254 missingterm((char*)0);
4256 if (SvCUR(PL_lex_stuff)) {
4259 d = SvPV_force(PL_lex_stuff, len);
4261 for (; isSPACE(*d) && len; --len, ++d) ;
4264 if (!warned && ckWARN(WARN_SYNTAX)) {
4265 for (; !isSPACE(*d) && len; --len, ++d) {
4267 Perl_warner(aTHX_ WARN_SYNTAX,
4268 "Possible attempt to separate words with commas");
4271 else if (*d == '#') {
4272 Perl_warner(aTHX_ WARN_SYNTAX,
4273 "Possible attempt to put comments in qw() list");
4279 for (; !isSPACE(*d) && len; --len, ++d) ;
4281 words = append_elem(OP_LIST, words,
4282 newSVOP(OP_CONST, 0, newSVpvn(b, d-b)));
4286 PL_nextval[PL_nexttoke].opval = words;
4291 SvREFCNT_dec(PL_lex_stuff);
4292 PL_lex_stuff = Nullsv;
4297 s = scan_str(s,FALSE,FALSE);
4299 missingterm((char*)0);
4300 yylval.ival = OP_STRINGIFY;
4301 if (SvIVX(PL_lex_stuff) == '\'')
4302 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
4303 TERM(sublex_start());
4306 s = scan_pat(s,OP_QR);
4307 TERM(sublex_start());
4310 s = scan_str(s,FALSE,FALSE);
4312 missingterm((char*)0);
4313 yylval.ival = OP_BACKTICK;
4315 TERM(sublex_start());
4321 *PL_tokenbuf = '\0';
4322 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4323 if (isIDFIRST_lazy(PL_tokenbuf))
4324 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
4326 yyerror("<> should be quotes");
4333 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4337 LOP(OP_RENAME,XTERM);
4346 LOP(OP_RINDEX,XTERM);
4369 LOP(OP_REVERSE,XTERM);
4380 TERM(sublex_start());
4382 TOKEN(1); /* force error */
4391 LOP(OP_SELECT,XTERM);
4397 LOP(OP_SEMCTL,XTERM);
4400 LOP(OP_SEMGET,XTERM);
4403 LOP(OP_SEMOP,XTERM);
4409 LOP(OP_SETPGRP,XTERM);
4411 case KEY_setpriority:
4412 LOP(OP_SETPRIORITY,XTERM);
4414 case KEY_sethostent:
4420 case KEY_setservent:
4423 case KEY_setprotoent:
4433 LOP(OP_SEEKDIR,XTERM);
4435 case KEY_setsockopt:
4436 LOP(OP_SSOCKOPT,XTERM);
4442 LOP(OP_SHMCTL,XTERM);
4445 LOP(OP_SHMGET,XTERM);
4448 LOP(OP_SHMREAD,XTERM);
4451 LOP(OP_SHMWRITE,XTERM);
4454 LOP(OP_SHUTDOWN,XTERM);
4463 LOP(OP_SOCKET,XTERM);
4465 case KEY_socketpair:
4466 LOP(OP_SOCKPAIR,XTERM);
4469 checkcomma(s,PL_tokenbuf,"subroutine name");
4471 if (*s == ';' || *s == ')') /* probably a close */
4472 Perl_croak(aTHX_ "sort is now a reserved word");
4474 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4478 LOP(OP_SPLIT,XTERM);
4481 LOP(OP_SPRINTF,XTERM);
4484 LOP(OP_SPLICE,XTERM);
4500 LOP(OP_SUBSTR,XTERM);
4506 char tmpbuf[sizeof PL_tokenbuf];
4507 expectation attrful;
4508 bool have_name, have_proto;
4513 if (isIDFIRST_lazy(s) || *s == '\'' ||
4514 (*s == ':' && s[1] == ':'))
4517 attrful = XATTRBLOCK;
4518 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4519 if (strchr(tmpbuf, ':'))
4520 sv_setpv(PL_subname, tmpbuf);
4522 sv_setsv(PL_subname,PL_curstname);
4523 sv_catpvn(PL_subname,"::",2);
4524 sv_catpvn(PL_subname,tmpbuf,len);
4531 Perl_croak(aTHX_ "Missing name in \"my sub\"");
4532 PL_expect = XTERMBLOCK;
4533 attrful = XATTRTERM;
4534 sv_setpv(PL_subname,"?");
4538 if (key == KEY_format) {
4540 PL_lex_formbrack = PL_lex_brackets + 1;
4542 (void) force_word(tmpbuf, WORD, FALSE, TRUE, TRUE);
4546 /* Look for a prototype */
4550 s = scan_str(s,FALSE,FALSE);
4553 SvREFCNT_dec(PL_lex_stuff);
4554 PL_lex_stuff = Nullsv;
4555 Perl_croak(aTHX_ "Prototype not terminated");
4558 d = SvPVX(PL_lex_stuff);
4560 for (p = d; *p; ++p) {
4565 SvCUR(PL_lex_stuff) = tmp;
4573 if (*s == ':' && s[1] != ':')
4574 PL_expect = attrful;
4577 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4578 PL_lex_stuff = Nullsv;
4582 sv_setpv(PL_subname,"__ANON__");
4585 (void) force_word(tmpbuf, WORD, FALSE, TRUE, TRUE);
4593 LOP(OP_SYSTEM,XREF);
4596 LOP(OP_SYMLINK,XTERM);
4599 LOP(OP_SYSCALL,XTERM);
4602 LOP(OP_SYSOPEN,XTERM);
4605 LOP(OP_SYSSEEK,XTERM);
4608 LOP(OP_SYSREAD,XTERM);
4611 LOP(OP_SYSWRITE,XTERM);
4615 TERM(sublex_start());
4636 LOP(OP_TRUNCATE,XTERM);
4648 yylval.ival = PL_curcop->cop_line;
4652 yylval.ival = PL_curcop->cop_line;
4656 LOP(OP_UNLINK,XTERM);
4662 LOP(OP_UNPACK,XTERM);
4665 LOP(OP_UTIME,XTERM);
4668 if (ckWARN(WARN_OCTAL)) {
4669 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4670 if (*d != '0' && isDIGIT(*d))
4671 Perl_warner(aTHX_ WARN_OCTAL,
4672 "umask: argument is missing initial 0");
4677 LOP(OP_UNSHIFT,XTERM);
4680 if (PL_expect != XSTATE)
4681 yyerror("\"use\" not allowed in expression");
4684 s = force_version(s);
4685 if(*s == ';' || (s = skipspace(s), *s == ';')) {
4686 PL_nextval[PL_nexttoke].opval = Nullop;
4691 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4692 s = force_version(s);
4705 yylval.ival = PL_curcop->cop_line;
4709 PL_hints |= HINT_BLOCK_SCOPE;
4716 LOP(OP_WAITPID,XTERM);
4724 static char ctl_l[2];
4726 if (ctl_l[0] == '\0')
4727 ctl_l[0] = toCTRL('L');
4728 gv_fetchpv(ctl_l,TRUE, SVt_PV);
4731 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
4736 if (PL_expect == XOPERATOR)
4742 yylval.ival = OP_XOR;
4747 TERM(sublex_start());
4753 Perl_keyword(pTHX_ register char *d, I32 len)
4758 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
4759 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
4760 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
4761 if (strEQ(d,"__DATA__")) return KEY___DATA__;
4762 if (strEQ(d,"__END__")) return KEY___END__;
4766 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
4771 if (strEQ(d,"and")) return -KEY_and;
4772 if (strEQ(d,"abs")) return -KEY_abs;
4775 if (strEQ(d,"alarm")) return -KEY_alarm;
4776 if (strEQ(d,"atan2")) return -KEY_atan2;
4779 if (strEQ(d,"accept")) return -KEY_accept;
4784 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
4787 if (strEQ(d,"bless")) return -KEY_bless;
4788 if (strEQ(d,"bind")) return -KEY_bind;
4789 if (strEQ(d,"binmode")) return -KEY_binmode;
4792 if (strEQ(d,"CORE")) return -KEY_CORE;
4797 if (strEQ(d,"cmp")) return -KEY_cmp;
4798 if (strEQ(d,"chr")) return -KEY_chr;
4799 if (strEQ(d,"cos")) return -KEY_cos;
4802 if (strEQ(d,"chop")) return KEY_chop;
4805 if (strEQ(d,"close")) return -KEY_close;
4806 if (strEQ(d,"chdir")) return -KEY_chdir;
4807 if (strEQ(d,"chomp")) return KEY_chomp;
4808 if (strEQ(d,"chmod")) return -KEY_chmod;
4809 if (strEQ(d,"chown")) return -KEY_chown;
4810 if (strEQ(d,"crypt")) return -KEY_crypt;
4813 if (strEQ(d,"chroot")) return -KEY_chroot;
4814 if (strEQ(d,"caller")) return -KEY_caller;
4817 if (strEQ(d,"connect")) return -KEY_connect;
4820 if (strEQ(d,"closedir")) return -KEY_closedir;
4821 if (strEQ(d,"continue")) return -KEY_continue;
4826 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
4831 if (strEQ(d,"do")) return KEY_do;
4834 if (strEQ(d,"die")) return -KEY_die;
4837 if (strEQ(d,"dump")) return -KEY_dump;
4840 if (strEQ(d,"delete")) return KEY_delete;
4843 if (strEQ(d,"defined")) return KEY_defined;
4844 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
4847 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
4852 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
4853 if (strEQ(d,"END")) return KEY_END;
4858 if (strEQ(d,"eq")) return -KEY_eq;
4861 if (strEQ(d,"eof")) return -KEY_eof;
4862 if (strEQ(d,"exp")) return -KEY_exp;
4865 if (strEQ(d,"else")) return KEY_else;
4866 if (strEQ(d,"exit")) return -KEY_exit;
4867 if (strEQ(d,"eval")) return KEY_eval;
4868 if (strEQ(d,"exec")) return -KEY_exec;
4869 if (strEQ(d,"each")) return KEY_each;
4872 if (strEQ(d,"elsif")) return KEY_elsif;
4875 if (strEQ(d,"exists")) return KEY_exists;
4876 if (strEQ(d,"elseif")) Perl_warn(aTHX_ "elseif should be elsif");
4879 if (strEQ(d,"endgrent")) return -KEY_endgrent;
4880 if (strEQ(d,"endpwent")) return -KEY_endpwent;
4883 if (strEQ(d,"endnetent")) return -KEY_endnetent;
4886 if (strEQ(d,"endhostent")) return -KEY_endhostent;
4887 if (strEQ(d,"endservent")) return -KEY_endservent;
4890 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
4897 if (strEQ(d,"for")) return KEY_for;
4900 if (strEQ(d,"fork")) return -KEY_fork;
4903 if (strEQ(d,"fcntl")) return -KEY_fcntl;
4904 if (strEQ(d,"flock")) return -KEY_flock;
4907 if (strEQ(d,"format")) return KEY_format;
4908 if (strEQ(d,"fileno")) return -KEY_fileno;
4911 if (strEQ(d,"foreach")) return KEY_foreach;
4914 if (strEQ(d,"formline")) return -KEY_formline;
4920 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
4921 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
4925 if (strnEQ(d,"get",3)) {
4930 if (strEQ(d,"ppid")) return -KEY_getppid;
4931 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
4934 if (strEQ(d,"pwent")) return -KEY_getpwent;
4935 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
4936 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
4939 if (strEQ(d,"peername")) return -KEY_getpeername;
4940 if (strEQ(d,"protoent")) return -KEY_getprotoent;
4941 if (strEQ(d,"priority")) return -KEY_getpriority;
4944 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
4947 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
4951 else if (*d == 'h') {
4952 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
4953 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
4954 if (strEQ(d,"hostent")) return -KEY_gethostent;
4956 else if (*d == 'n') {
4957 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
4958 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
4959 if (strEQ(d,"netent")) return -KEY_getnetent;
4961 else if (*d == 's') {
4962 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
4963 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
4964 if (strEQ(d,"servent")) return -KEY_getservent;
4965 if (strEQ(d,"sockname")) return -KEY_getsockname;
4966 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
4968 else if (*d == 'g') {
4969 if (strEQ(d,"grent")) return -KEY_getgrent;
4970 if (strEQ(d,"grnam")) return -KEY_getgrnam;
4971 if (strEQ(d,"grgid")) return -KEY_getgrgid;
4973 else if (*d == 'l') {
4974 if (strEQ(d,"login")) return -KEY_getlogin;
4976 else if (strEQ(d,"c")) return -KEY_getc;
4981 if (strEQ(d,"gt")) return -KEY_gt;
4982 if (strEQ(d,"ge")) return -KEY_ge;
4985 if (strEQ(d,"grep")) return KEY_grep;
4986 if (strEQ(d,"goto")) return KEY_goto;
4987 if (strEQ(d,"glob")) return KEY_glob;
4990 if (strEQ(d,"gmtime")) return -KEY_gmtime;
4995 if (strEQ(d,"hex")) return -KEY_hex;
4998 if (strEQ(d,"INIT")) return KEY_INIT;
5003 if (strEQ(d,"if")) return KEY_if;
5006 if (strEQ(d,"int")) return -KEY_int;
5009 if (strEQ(d,"index")) return -KEY_index;
5010 if (strEQ(d,"ioctl")) return -KEY_ioctl;
5015 if (strEQ(d,"join")) return -KEY_join;
5019 if (strEQ(d,"keys")) return KEY_keys;
5020 if (strEQ(d,"kill")) return -KEY_kill;
5025 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
5026 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
5032 if (strEQ(d,"lt")) return -KEY_lt;
5033 if (strEQ(d,"le")) return -KEY_le;
5034 if (strEQ(d,"lc")) return -KEY_lc;
5037 if (strEQ(d,"log")) return -KEY_log;
5040 if (strEQ(d,"last")) return KEY_last;
5041 if (strEQ(d,"link")) return -KEY_link;
5042 if (strEQ(d,"lock")) return -KEY_lock;
5045 if (strEQ(d,"local")) return KEY_local;
5046 if (strEQ(d,"lstat")) return -KEY_lstat;
5049 if (strEQ(d,"length")) return -KEY_length;
5050 if (strEQ(d,"listen")) return -KEY_listen;
5053 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
5056 if (strEQ(d,"localtime")) return -KEY_localtime;
5062 case 1: return KEY_m;
5064 if (strEQ(d,"my")) return KEY_my;
5067 if (strEQ(d,"map")) return KEY_map;
5070 if (strEQ(d,"mkdir")) return -KEY_mkdir;
5073 if (strEQ(d,"msgctl")) return -KEY_msgctl;
5074 if (strEQ(d,"msgget")) return -KEY_msgget;
5075 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
5076 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
5081 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
5084 if (strEQ(d,"next")) return KEY_next;
5085 if (strEQ(d,"ne")) return -KEY_ne;
5086 if (strEQ(d,"not")) return -KEY_not;
5087 if (strEQ(d,"no")) return KEY_no;
5092 if (strEQ(d,"or")) return -KEY_or;
5095 if (strEQ(d,"ord")) return -KEY_ord;
5096 if (strEQ(d,"oct")) return -KEY_oct;
5097 if (strEQ(d,"our")) { deprecate("reserved word \"our\"");
5101 if (strEQ(d,"open")) return -KEY_open;
5104 if (strEQ(d,"opendir")) return -KEY_opendir;
5111 if (strEQ(d,"pop")) return KEY_pop;
5112 if (strEQ(d,"pos")) return KEY_pos;
5115 if (strEQ(d,"push")) return KEY_push;
5116 if (strEQ(d,"pack")) return -KEY_pack;
5117 if (strEQ(d,"pipe")) return -KEY_pipe;
5120 if (strEQ(d,"print")) return KEY_print;
5123 if (strEQ(d,"printf")) return KEY_printf;
5126 if (strEQ(d,"package")) return KEY_package;
5129 if (strEQ(d,"prototype")) return KEY_prototype;
5134 if (strEQ(d,"q")) return KEY_q;
5135 if (strEQ(d,"qr")) return KEY_qr;
5136 if (strEQ(d,"qq")) return KEY_qq;
5137 if (strEQ(d,"qw")) return KEY_qw;
5138 if (strEQ(d,"qx")) return KEY_qx;
5140 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
5145 if (strEQ(d,"ref")) return -KEY_ref;
5148 if (strEQ(d,"read")) return -KEY_read;
5149 if (strEQ(d,"rand")) return -KEY_rand;
5150 if (strEQ(d,"recv")) return -KEY_recv;
5151 if (strEQ(d,"redo")) return KEY_redo;
5154 if (strEQ(d,"rmdir")) return -KEY_rmdir;
5155 if (strEQ(d,"reset")) return -KEY_reset;
5158 if (strEQ(d,"return")) return KEY_return;
5159 if (strEQ(d,"rename")) return -KEY_rename;
5160 if (strEQ(d,"rindex")) return -KEY_rindex;
5163 if (strEQ(d,"require")) return -KEY_require;
5164 if (strEQ(d,"reverse")) return -KEY_reverse;
5165 if (strEQ(d,"readdir")) return -KEY_readdir;
5168 if (strEQ(d,"readlink")) return -KEY_readlink;
5169 if (strEQ(d,"readline")) return -KEY_readline;
5170 if (strEQ(d,"readpipe")) return -KEY_readpipe;
5173 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
5179 case 0: return KEY_s;
5181 if (strEQ(d,"scalar")) return KEY_scalar;
5186 if (strEQ(d,"seek")) return -KEY_seek;
5187 if (strEQ(d,"send")) return -KEY_send;
5190 if (strEQ(d,"semop")) return -KEY_semop;
5193 if (strEQ(d,"select")) return -KEY_select;
5194 if (strEQ(d,"semctl")) return -KEY_semctl;
5195 if (strEQ(d,"semget")) return -KEY_semget;
5198 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
5199 if (strEQ(d,"seekdir")) return -KEY_seekdir;
5202 if (strEQ(d,"setpwent")) return -KEY_setpwent;
5203 if (strEQ(d,"setgrent")) return -KEY_setgrent;
5206 if (strEQ(d,"setnetent")) return -KEY_setnetent;
5209 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
5210 if (strEQ(d,"sethostent")) return -KEY_sethostent;
5211 if (strEQ(d,"setservent")) return -KEY_setservent;
5214 if (strEQ(d,"setpriority")) return -KEY_setpriority;
5215 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
5222 if (strEQ(d,"shift")) return KEY_shift;
5225 if (strEQ(d,"shmctl")) return -KEY_shmctl;
5226 if (strEQ(d,"shmget")) return -KEY_shmget;
5229 if (strEQ(d,"shmread")) return -KEY_shmread;
5232 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
5233 if (strEQ(d,"shutdown")) return -KEY_shutdown;
5238 if (strEQ(d,"sin")) return -KEY_sin;
5241 if (strEQ(d,"sleep")) return -KEY_sleep;
5244 if (strEQ(d,"sort")) return KEY_sort;
5245 if (strEQ(d,"socket")) return -KEY_socket;
5246 if (strEQ(d,"socketpair")) return -KEY_socketpair;
5249 if (strEQ(d,"split")) return KEY_split;
5250 if (strEQ(d,"sprintf")) return -KEY_sprintf;
5251 if (strEQ(d,"splice")) return KEY_splice;
5254 if (strEQ(d,"sqrt")) return -KEY_sqrt;
5257 if (strEQ(d,"srand")) return -KEY_srand;
5260 if (strEQ(d,"stat")) return -KEY_stat;
5261 if (strEQ(d,"study")) return KEY_study;
5264 if (strEQ(d,"substr")) return -KEY_substr;
5265 if (strEQ(d,"sub")) return KEY_sub;
5270 if (strEQ(d,"system")) return -KEY_system;
5273 if (strEQ(d,"symlink")) return -KEY_symlink;
5274 if (strEQ(d,"syscall")) return -KEY_syscall;
5275 if (strEQ(d,"sysopen")) return -KEY_sysopen;
5276 if (strEQ(d,"sysread")) return -KEY_sysread;
5277 if (strEQ(d,"sysseek")) return -KEY_sysseek;
5280 if (strEQ(d,"syswrite")) return -KEY_syswrite;
5289 if (strEQ(d,"tr")) return KEY_tr;
5292 if (strEQ(d,"tie")) return KEY_tie;
5295 if (strEQ(d,"tell")) return -KEY_tell;
5296 if (strEQ(d,"tied")) return KEY_tied;
5297 if (strEQ(d,"time")) return -KEY_time;
5300 if (strEQ(d,"times")) return -KEY_times;
5303 if (strEQ(d,"telldir")) return -KEY_telldir;
5306 if (strEQ(d,"truncate")) return -KEY_truncate;
5313 if (strEQ(d,"uc")) return -KEY_uc;
5316 if (strEQ(d,"use")) return KEY_use;
5319 if (strEQ(d,"undef")) return KEY_undef;
5320 if (strEQ(d,"until")) return KEY_until;
5321 if (strEQ(d,"untie")) return KEY_untie;
5322 if (strEQ(d,"utime")) return -KEY_utime;
5323 if (strEQ(d,"umask")) return -KEY_umask;
5326 if (strEQ(d,"unless")) return KEY_unless;
5327 if (strEQ(d,"unpack")) return -KEY_unpack;
5328 if (strEQ(d,"unlink")) return -KEY_unlink;
5331 if (strEQ(d,"unshift")) return KEY_unshift;
5332 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
5337 if (strEQ(d,"values")) return -KEY_values;
5338 if (strEQ(d,"vec")) return -KEY_vec;
5343 if (strEQ(d,"warn")) return -KEY_warn;
5344 if (strEQ(d,"wait")) return -KEY_wait;
5347 if (strEQ(d,"while")) return KEY_while;
5348 if (strEQ(d,"write")) return -KEY_write;
5351 if (strEQ(d,"waitpid")) return -KEY_waitpid;
5354 if (strEQ(d,"wantarray")) return -KEY_wantarray;
5359 if (len == 1) return -KEY_x;
5360 if (strEQ(d,"xor")) return -KEY_xor;
5363 if (len == 1) return KEY_y;
5372 S_checkcomma(pTHX_ register char *s, char *name, char *what)
5376 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
5377 dTHR; /* only for ckWARN */
5378 if (ckWARN(WARN_SYNTAX)) {
5380 for (w = s+2; *w && level; w++) {
5387 for (; *w && isSPACE(*w); w++) ;
5388 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
5389 Perl_warner(aTHX_ WARN_SYNTAX, "%s (...) interpreted as function",name);
5392 while (s < PL_bufend && isSPACE(*s))
5396 while (s < PL_bufend && isSPACE(*s))
5398 if (isIDFIRST_lazy(s)) {
5400 while (isALNUM_lazy(s))
5402 while (s < PL_bufend && isSPACE(*s))
5407 kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
5411 Perl_croak(aTHX_ "No comma allowed after %s", what);
5416 /* Either returns sv, or mortalizes sv and returns a new SV*.
5417 Best used as sv=new_constant(..., sv, ...).
5418 If s, pv are NULL, calls subroutine with one argument,
5419 and type is used with error messages only. */
5422 S_new_constant(pTHX_ char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)
5425 HV *table = GvHV(PL_hintgv); /* ^H */
5429 char *why, *why1, *why2;
5431 if (!(PL_hints & HINT_LOCALIZE_HH)) {
5434 why = "%^H is not localized";
5438 msg = Perl_newSVpvf(aTHX_ "constant(%s): %s%s%s",
5439 (type ? type: "undef"), why1, why2, why);
5440 yyerror(SvPVX(msg));
5445 why = "%^H is not defined";
5448 cvp = hv_fetch(table, key, strlen(key), FALSE);
5449 if (!cvp || !SvOK(*cvp)) {
5450 why = "} is not defined";
5455 sv_2mortal(sv); /* Parent created it permanently */
5458 pv = sv_2mortal(newSVpvn(s, len));
5460 typesv = sv_2mortal(newSVpv(type, 0));
5462 typesv = &PL_sv_undef;
5464 PUSHSTACKi(PERLSI_OVERLOAD);
5477 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
5481 /* Check the eval first */
5482 if (!PL_in_eval && SvTRUE(ERRSV))
5485 sv_catpv(ERRSV, "Propagated");
5486 yyerror(SvPV(ERRSV, n_a)); /* Duplicates the message inside eval */
5488 res = SvREFCNT_inc(sv);
5501 why = "}} did not return a defined value";
5502 why1 = "Call to &{$^H{";
5512 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
5514 register char *d = dest;
5515 register char *e = d + destlen - 3; /* two-character token, ending NUL */
5518 Perl_croak(aTHX_ ident_too_long);
5519 if (isALNUM(*s)) /* UTF handled below */
5521 else if (*s == '\'' && allow_package && isIDFIRST_lazy(s+1)) {
5526 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
5530 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5531 char *t = s + UTF8SKIP(s);
5532 while (*t & 0x80 && is_utf8_mark((U8*)t))
5534 if (d + (t - s) > e)
5535 Perl_croak(aTHX_ ident_too_long);
5536 Copy(s, d, t - s, char);
5549 S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
5556 if (PL_lex_brackets == 0)
5557 PL_lex_fakebrack = 0;
5561 e = d + destlen - 3; /* two-character token, ending NUL */
5563 while (isDIGIT(*s)) {
5565 Perl_croak(aTHX_ ident_too_long);
5572 Perl_croak(aTHX_ ident_too_long);
5573 if (isALNUM(*s)) /* UTF handled below */
5575 else if (*s == '\'' && isIDFIRST_lazy(s+1)) {
5580 else if (*s == ':' && s[1] == ':') {
5584 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5585 char *t = s + UTF8SKIP(s);
5586 while (*t & 0x80 && is_utf8_mark((U8*)t))
5588 if (d + (t - s) > e)
5589 Perl_croak(aTHX_ ident_too_long);
5590 Copy(s, d, t - s, char);
5601 if (PL_lex_state != LEX_NORMAL)
5602 PL_lex_state = LEX_INTERPENDMAYBE;
5605 if (*s == '$' && s[1] &&
5606 (isALNUM_lazy(s+1) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
5619 if (*d == '^' && *s && isCONTROLVAR(*s)) {
5624 if (isSPACE(s[-1])) {
5627 if (ch != ' ' && ch != '\t') {
5633 if (isIDFIRST_lazy(d)) {
5637 while (e < send && isALNUM_lazy(e) || *e == ':') {
5639 while (e < send && *e & 0x80 && is_utf8_mark((U8*)e))
5642 Copy(s, d, e - s, char);
5647 while ((isALNUM(*s) || *s == ':') && d < e)
5650 Perl_croak(aTHX_ ident_too_long);
5653 while (s < send && (*s == ' ' || *s == '\t')) s++;
5654 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
5655 dTHR; /* only for ckWARN */
5656 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
5657 char *brack = *s == '[' ? "[...]" : "{...}";
5658 Perl_warner(aTHX_ WARN_AMBIGUOUS,
5659 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
5660 funny, dest, brack, funny, dest, brack);
5662 PL_lex_fakebrack = PL_lex_brackets+1;
5664 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5668 /* Handle extended ${^Foo} variables
5669 * 1999-02-27 mjd-perl-patch@plover.com */
5670 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
5674 while (isALNUM(*s) && d < e) {
5678 Perl_croak(aTHX_ ident_too_long);
5683 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
5684 PL_lex_state = LEX_INTERPEND;
5687 if (PL_lex_state == LEX_NORMAL) {
5688 dTHR; /* only for ckWARN */
5689 if (ckWARN(WARN_AMBIGUOUS) &&
5690 (keyword(dest, d - dest) || get_cv(dest, FALSE)))
5692 Perl_warner(aTHX_ WARN_AMBIGUOUS,
5693 "Ambiguous use of %c{%s} resolved to %c%s",
5694 funny, dest, funny, dest);
5699 s = bracket; /* let the parser handle it */
5703 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
5704 PL_lex_state = LEX_INTERPEND;
5709 Perl_pmflag(pTHX_ U16 *pmfl, int ch)
5714 *pmfl |= PMf_GLOBAL;
5716 *pmfl |= PMf_CONTINUE;
5720 *pmfl |= PMf_MULTILINE;
5722 *pmfl |= PMf_SINGLELINE;
5724 *pmfl |= PMf_EXTENDED;
5728 S_scan_pat(pTHX_ char *start, I32 type)
5733 s = scan_str(start,FALSE,FALSE);
5736 SvREFCNT_dec(PL_lex_stuff);
5737 PL_lex_stuff = Nullsv;
5738 Perl_croak(aTHX_ "Search pattern not terminated");
5741 pm = (PMOP*)newPMOP(type, 0);
5742 if (PL_multi_open == '?')
5743 pm->op_pmflags |= PMf_ONCE;
5745 while (*s && strchr("iomsx", *s))
5746 pmflag(&pm->op_pmflags,*s++);
5749 while (*s && strchr("iogcmsx", *s))
5750 pmflag(&pm->op_pmflags,*s++);
5752 pm->op_pmpermflags = pm->op_pmflags;
5754 PL_lex_op = (OP*)pm;
5755 yylval.ival = OP_MATCH;
5760 S_scan_subst(pTHX_ char *start)
5767 yylval.ival = OP_NULL;
5769 s = scan_str(start,FALSE,FALSE);
5773 SvREFCNT_dec(PL_lex_stuff);
5774 PL_lex_stuff = Nullsv;
5775 Perl_croak(aTHX_ "Substitution pattern not terminated");
5778 if (s[-1] == PL_multi_open)
5781 first_start = PL_multi_start;
5782 s = scan_str(s,FALSE,FALSE);
5785 SvREFCNT_dec(PL_lex_stuff);
5786 PL_lex_stuff = Nullsv;
5788 SvREFCNT_dec(PL_lex_repl);
5789 PL_lex_repl = Nullsv;
5790 Perl_croak(aTHX_ "Substitution replacement not terminated");
5792 PL_multi_start = first_start; /* so whole substitution is taken together */
5794 pm = (PMOP*)newPMOP(OP_SUBST, 0);
5800 else if (strchr("iogcmsx", *s))
5801 pmflag(&pm->op_pmflags,*s++);
5808 PL_sublex_info.super_bufptr = s;
5809 PL_sublex_info.super_bufend = PL_bufend;
5811 pm->op_pmflags |= PMf_EVAL;
5812 repl = newSVpvn("",0);
5814 sv_catpv(repl, es ? "eval " : "do ");
5815 sv_catpvn(repl, "{ ", 2);
5816 sv_catsv(repl, PL_lex_repl);
5817 sv_catpvn(repl, " };", 2);
5819 SvREFCNT_dec(PL_lex_repl);
5823 pm->op_pmpermflags = pm->op_pmflags;
5824 PL_lex_op = (OP*)pm;
5825 yylval.ival = OP_SUBST;
5830 S_scan_trans(pTHX_ char *start)
5841 yylval.ival = OP_NULL;
5843 s = scan_str(start,FALSE,FALSE);
5846 SvREFCNT_dec(PL_lex_stuff);
5847 PL_lex_stuff = Nullsv;
5848 Perl_croak(aTHX_ "Transliteration pattern not terminated");
5850 if (s[-1] == PL_multi_open)
5853 s = scan_str(s,FALSE,FALSE);
5856 SvREFCNT_dec(PL_lex_stuff);
5857 PL_lex_stuff = Nullsv;
5859 SvREFCNT_dec(PL_lex_repl);
5860 PL_lex_repl = Nullsv;
5861 Perl_croak(aTHX_ "Transliteration replacement not terminated");
5865 o = newSVOP(OP_TRANS, 0, 0);
5866 utf8 = OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF;
5869 New(803,tbl,256,short);
5870 o = newPVOP(OP_TRANS, 0, (char*)tbl);
5874 complement = del = squash = 0;
5875 while (strchr("cdsCU", *s)) {
5877 complement = OPpTRANS_COMPLEMENT;
5879 del = OPpTRANS_DELETE;
5881 squash = OPpTRANS_SQUASH;
5886 utf8 &= ~OPpTRANS_FROM_UTF;
5888 utf8 |= OPpTRANS_FROM_UTF;
5892 utf8 &= ~OPpTRANS_TO_UTF;
5894 utf8 |= OPpTRANS_TO_UTF;
5897 Perl_croak(aTHX_ "Too many /C and /U options");
5902 o->op_private = del|squash|complement|utf8;
5905 yylval.ival = OP_TRANS;
5910 S_scan_heredoc(pTHX_ register char *s)
5914 I32 op_type = OP_SCALAR;
5921 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
5925 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
5928 for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5929 if (*peek && strchr("`'\"",*peek)) {
5932 s = delimcpy(d, e, s, PL_bufend, term, &len);
5942 if (!isALNUM_lazy(s))
5943 deprecate("bare << to mean <<\"\"");
5944 for (; isALNUM_lazy(s); s++) {
5949 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
5950 Perl_croak(aTHX_ "Delimiter for here document is too long");
5953 len = d - PL_tokenbuf;
5954 #ifndef PERL_STRICT_CR
5955 d = strchr(s, '\r');
5959 while (s < PL_bufend) {
5965 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
5974 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5979 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
5980 herewas = newSVpvn(s,PL_bufend-s);
5982 s--, herewas = newSVpvn(s,d-s);
5983 s += SvCUR(herewas);
5985 tmpstr = NEWSV(87,79);
5986 sv_upgrade(tmpstr, SVt_PVIV);
5991 else if (term == '`') {
5992 op_type = OP_BACKTICK;
5993 SvIVX(tmpstr) = '\\';
5997 PL_multi_start = PL_curcop->cop_line;
5998 PL_multi_open = PL_multi_close = '<';
5999 term = *PL_tokenbuf;
6000 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
6001 char *bufptr = PL_sublex_info.super_bufptr;
6002 char *bufend = PL_sublex_info.super_bufend;
6003 char *olds = s - SvCUR(herewas);
6004 s = strchr(bufptr, '\n');
6008 while (s < bufend &&
6009 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6011 PL_curcop->cop_line++;
6014 PL_curcop->cop_line = PL_multi_start;
6015 missingterm(PL_tokenbuf);
6017 sv_setpvn(herewas,bufptr,d-bufptr+1);
6018 sv_setpvn(tmpstr,d+1,s-d);
6020 sv_catpvn(herewas,s,bufend-s);
6021 (void)strcpy(bufptr,SvPVX(herewas));
6028 while (s < PL_bufend &&
6029 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6031 PL_curcop->cop_line++;
6033 if (s >= PL_bufend) {
6034 PL_curcop->cop_line = PL_multi_start;
6035 missingterm(PL_tokenbuf);
6037 sv_setpvn(tmpstr,d+1,s-d);
6039 PL_curcop->cop_line++; /* the preceding stmt passes a newline */
6041 sv_catpvn(herewas,s,PL_bufend-s);
6042 sv_setsv(PL_linestr,herewas);
6043 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
6044 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6047 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
6048 while (s >= PL_bufend) { /* multiple line string? */
6050 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6051 PL_curcop->cop_line = PL_multi_start;
6052 missingterm(PL_tokenbuf);
6054 PL_curcop->cop_line++;
6055 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6056 #ifndef PERL_STRICT_CR
6057 if (PL_bufend - PL_linestart >= 2) {
6058 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
6059 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
6061 PL_bufend[-2] = '\n';
6063 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6065 else if (PL_bufend[-1] == '\r')
6066 PL_bufend[-1] = '\n';
6068 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
6069 PL_bufend[-1] = '\n';
6071 if (PERLDB_LINE && PL_curstash != PL_debstash) {
6072 SV *sv = NEWSV(88,0);
6074 sv_upgrade(sv, SVt_PVMG);
6075 sv_setsv(sv,PL_linestr);
6076 av_store(GvAV(PL_curcop->cop_filegv),
6077 (I32)PL_curcop->cop_line,sv);
6079 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
6082 sv_catsv(PL_linestr,herewas);
6083 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6087 sv_catsv(tmpstr,PL_linestr);
6092 PL_multi_end = PL_curcop->cop_line;
6093 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
6094 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
6095 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
6097 SvREFCNT_dec(herewas);
6098 PL_lex_stuff = tmpstr;
6099 yylval.ival = op_type;
6104 takes: current position in input buffer
6105 returns: new position in input buffer
6106 side-effects: yylval and lex_op are set.
6111 <FH> read from filehandle
6112 <pkg::FH> read from package qualified filehandle
6113 <pkg'FH> read from package qualified filehandle
6114 <$fh> read from filehandle in $fh
6120 S_scan_inputsymbol(pTHX_ char *start)
6122 register char *s = start; /* current position in buffer */
6128 d = PL_tokenbuf; /* start of temp holding space */
6129 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
6130 end = strchr(s, '\n');
6133 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
6135 /* die if we didn't have space for the contents of the <>,
6136 or if it didn't end, or if we see a newline
6139 if (len >= sizeof PL_tokenbuf)
6140 Perl_croak(aTHX_ "Excessively long <> operator");
6142 Perl_croak(aTHX_ "Unterminated <> operator");
6147 Remember, only scalar variables are interpreted as filehandles by
6148 this code. Anything more complex (e.g., <$fh{$num}>) will be
6149 treated as a glob() call.
6150 This code makes use of the fact that except for the $ at the front,
6151 a scalar variable and a filehandle look the same.
6153 if (*d == '$' && d[1]) d++;
6155 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
6156 while (*d && (isALNUM_lazy(d) || *d == '\'' || *d == ':'))
6159 /* If we've tried to read what we allow filehandles to look like, and
6160 there's still text left, then it must be a glob() and not a getline.
6161 Use scan_str to pull out the stuff between the <> and treat it
6162 as nothing more than a string.
6165 if (d - PL_tokenbuf != len) {
6166 yylval.ival = OP_GLOB;
6168 s = scan_str(start,FALSE,FALSE);
6170 Perl_croak(aTHX_ "Glob not terminated");
6174 /* we're in a filehandle read situation */
6177 /* turn <> into <ARGV> */
6179 (void)strcpy(d,"ARGV");
6181 /* if <$fh>, create the ops to turn the variable into a
6187 /* try to find it in the pad for this block, otherwise find
6188 add symbol table ops
6190 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
6191 OP *o = newOP(OP_PADSV, 0);
6193 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, o);
6196 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
6197 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
6198 newUNOP(OP_RV2SV, 0,
6199 newGVOP(OP_GV, 0, gv)));
6201 PL_lex_op->op_flags |= OPf_SPECIAL;
6202 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
6203 yylval.ival = OP_NULL;
6206 /* If it's none of the above, it must be a literal filehandle
6207 (<Foo::BAR> or <FOO>) so build a simple readline OP */
6209 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
6210 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
6211 yylval.ival = OP_NULL;
6220 takes: start position in buffer
6221 keep_quoted preserve \ on the embedded delimiter(s)
6222 keep_delims preserve the delimiters around the string
6223 returns: position to continue reading from buffer
6224 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
6225 updates the read buffer.
6227 This subroutine pulls a string out of the input. It is called for:
6228 q single quotes q(literal text)
6229 ' single quotes 'literal text'
6230 qq double quotes qq(interpolate $here please)
6231 " double quotes "interpolate $here please"
6232 qx backticks qx(/bin/ls -l)
6233 ` backticks `/bin/ls -l`
6234 qw quote words @EXPORT_OK = qw( func() $spam )
6235 m// regexp match m/this/
6236 s/// regexp substitute s/this/that/
6237 tr/// string transliterate tr/this/that/
6238 y/// string transliterate y/this/that/
6239 ($*@) sub prototypes sub foo ($)
6240 (stuff) sub attr parameters sub foo : attr(stuff)
6241 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
6243 In most of these cases (all but <>, patterns and transliterate)
6244 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
6245 calls scan_str(). s/// makes yylex() call scan_subst() which calls
6246 scan_str(). tr/// and y/// make yylex() call scan_trans() which
6249 It skips whitespace before the string starts, and treats the first
6250 character as the delimiter. If the delimiter is one of ([{< then
6251 the corresponding "close" character )]}> is used as the closing
6252 delimiter. It allows quoting of delimiters, and if the string has
6253 balanced delimiters ([{<>}]) it allows nesting.
6255 The lexer always reads these strings into lex_stuff, except in the
6256 case of the operators which take *two* arguments (s/// and tr///)
6257 when it checks to see if lex_stuff is full (presumably with the 1st
6258 arg to s or tr) and if so puts the string into lex_repl.
6263 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
6266 SV *sv; /* scalar value: string */
6267 char *tmps; /* temp string, used for delimiter matching */
6268 register char *s = start; /* current position in the buffer */
6269 register char term; /* terminating character */
6270 register char *to; /* current position in the sv's data */
6271 I32 brackets = 1; /* bracket nesting level */
6273 /* skip space before the delimiter */
6277 /* mark where we are, in case we need to report errors */
6280 /* after skipping whitespace, the next character is the terminator */
6282 /* mark where we are */
6283 PL_multi_start = PL_curcop->cop_line;
6284 PL_multi_open = term;
6286 /* find corresponding closing delimiter */
6287 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
6289 PL_multi_close = term;
6291 /* create a new SV to hold the contents. 87 is leak category, I'm
6292 assuming. 79 is the SV's initial length. What a random number. */
6294 sv_upgrade(sv, SVt_PVIV);
6296 (void)SvPOK_only(sv); /* validate pointer */
6298 /* move past delimiter and try to read a complete string */
6300 sv_catpvn(sv, s, 1);
6303 /* extend sv if need be */
6304 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
6305 /* set 'to' to the next character in the sv's string */
6306 to = SvPVX(sv)+SvCUR(sv);
6308 /* if open delimiter is the close delimiter read unbridle */
6309 if (PL_multi_open == PL_multi_close) {
6310 for (; s < PL_bufend; s++,to++) {
6311 /* embedded newlines increment the current line number */
6312 if (*s == '\n' && !PL_rsfp)
6313 PL_curcop->cop_line++;
6314 /* handle quoted delimiters */
6315 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
6316 if (!keep_quoted && s[1] == term)
6318 /* any other quotes are simply copied straight through */
6322 /* terminate when run out of buffer (the for() condition), or
6323 have found the terminator */
6324 else if (*s == term)
6330 /* if the terminator isn't the same as the start character (e.g.,
6331 matched brackets), we have to allow more in the quoting, and
6332 be prepared for nested brackets.
6335 /* read until we run out of string, or we find the terminator */
6336 for (; s < PL_bufend; s++,to++) {
6337 /* embedded newlines increment the line count */
6338 if (*s == '\n' && !PL_rsfp)
6339 PL_curcop->cop_line++;
6340 /* backslashes can escape the open or closing characters */
6341 if (*s == '\\' && s+1 < PL_bufend) {
6343 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
6348 /* allow nested opens and closes */
6349 else if (*s == PL_multi_close && --brackets <= 0)
6351 else if (*s == PL_multi_open)
6356 /* terminate the copied string and update the sv's end-of-string */
6358 SvCUR_set(sv, to - SvPVX(sv));
6361 * this next chunk reads more into the buffer if we're not done yet
6364 if (s < PL_bufend) break; /* handle case where we are done yet :-) */
6366 #ifndef PERL_STRICT_CR
6367 if (to - SvPVX(sv) >= 2) {
6368 if ((to[-2] == '\r' && to[-1] == '\n') ||
6369 (to[-2] == '\n' && to[-1] == '\r'))
6373 SvCUR_set(sv, to - SvPVX(sv));
6375 else if (to[-1] == '\r')
6378 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
6382 /* if we're out of file, or a read fails, bail and reset the current
6383 line marker so we can report where the unterminated string began
6386 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6388 PL_curcop->cop_line = PL_multi_start;
6391 /* we read a line, so increment our line counter */
6392 PL_curcop->cop_line++;
6394 /* update debugger info */
6395 if (PERLDB_LINE && PL_curstash != PL_debstash) {
6396 SV *sv = NEWSV(88,0);
6398 sv_upgrade(sv, SVt_PVMG);
6399 sv_setsv(sv,PL_linestr);
6400 av_store(GvAV(PL_curcop->cop_filegv),
6401 (I32)PL_curcop->cop_line, sv);
6404 /* having changed the buffer, we must update PL_bufend */
6405 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6408 /* at this point, we have successfully read the delimited string */
6411 sv_catpvn(sv, s, 1);
6412 PL_multi_end = PL_curcop->cop_line;
6415 /* if we allocated too much space, give some back */
6416 if (SvCUR(sv) + 5 < SvLEN(sv)) {
6417 SvLEN_set(sv, SvCUR(sv) + 1);
6418 Renew(SvPVX(sv), SvLEN(sv), char);
6421 /* decide whether this is the first or second quoted string we've read
6434 takes: pointer to position in buffer
6435 returns: pointer to new position in buffer
6436 side-effects: builds ops for the constant in yylval.op
6438 Read a number in any of the formats that Perl accepts:
6440 0(x[0-7A-F]+)|([0-7]+)|(b[01])
6441 [\d_]+(\.[\d_]*)?[Ee](\d+)
6443 Underbars (_) are allowed in decimal numbers. If -w is on,
6444 underbars before a decimal point must be at three digit intervals.
6446 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
6449 If it reads a number without a decimal point or an exponent, it will
6450 try converting the number to an integer and see if it can do so
6451 without loss of precision.
6455 Perl_scan_num(pTHX_ char *start)
6457 register char *s = start; /* current position in buffer */
6458 register char *d; /* destination in temp buffer */
6459 register char *e; /* end of temp buffer */
6460 IV tryiv; /* used to see if it can be an IV */
6461 NV value; /* number read, as a double */
6462 SV *sv; /* place to put the converted number */
6463 bool floatit; /* boolean: int or float? */
6464 char *lastub = 0; /* position of last underbar */
6465 static char number_too_long[] = "Number too long";
6467 /* We use the first character to decide what type of number this is */
6471 Perl_croak(aTHX_ "panic: scan_num");
6473 /* if it starts with a 0, it could be an octal number, a decimal in
6474 0.13 disguise, or a hexadecimal number, or a binary number.
6479 u holds the "number so far"
6480 shift the power of 2 of the base
6481 (hex == 4, octal == 3, binary == 1)
6482 overflowed was the number more than we can hold?
6484 Shift is used when we add a digit. It also serves as an "are
6485 we in octal/hex/binary?" indicator to disallow hex characters
6492 bool overflowed = FALSE;
6493 static NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
6494 static char* bases[5] = { "", "binary", "", "octal",
6496 static char* Bases[5] = { "", "Binary", "", "Octal",
6498 static char *maxima[5] = { "",
6499 "0b11111111111111111111111111111111",
6503 char *base, *Base, *max;
6509 } else if (s[1] == 'b') {
6513 /* check for a decimal in disguise */
6514 else if (strchr(".Ee", s[1]))
6516 /* so it must be octal */
6520 base = bases[shift];
6521 Base = Bases[shift];
6522 max = maxima[shift];
6524 /* read the rest of the number */
6526 /* x is used in the overflow test,
6527 b is the digit we're adding on. */
6532 /* if we don't mention it, we're done */
6541 /* 8 and 9 are not octal */
6544 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
6548 case '2': case '3': case '4':
6549 case '5': case '6': case '7':
6551 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
6555 b = *s++ & 15; /* ASCII digit -> value of digit */
6559 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
6560 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
6561 /* make sure they said 0x */
6566 /* Prepare to put the digit we have onto the end
6567 of the number so far. We check for overflows.
6572 x = u << shift; /* make room for the digit */
6574 if ((x >> shift) != u
6575 && !(PL_hints & HINT_NEW_BINARY)) {
6579 if (ckWARN_d(WARN_UNSAFE))
6580 Perl_warner(aTHX_ ((shift == 3) ?
6581 WARN_OCTAL : WARN_UNSAFE),
6582 "Integer overflow in %s number",
6585 u = x | b; /* add the digit to the end */
6588 n *= nvshift[shift];
6589 /* If an NV has not enough bits in its
6590 * mantissa to represent an UV this summing of
6591 * small low-order numbers is a waste of time
6592 * (because the NV cannot preserve the
6593 * low-order bits anyway): we could just
6594 * remember when did we overflow and in the
6595 * end just multiply n by the right
6603 /* if we get here, we had success: make a scalar value from
6610 if (ckWARN(WARN_UNSAFE) && n > 4294967295.0)
6611 Perl_warner(aTHX_ WARN_UNSAFE,
6612 "%s number > %s non-portable",
6619 if (ckWARN(WARN_UNSAFE) && u > 0xffffffff)
6620 Perl_warner(aTHX_ WARN_UNSAFE,
6621 "%s number > %s non-portable",
6626 if (PL_hints & HINT_NEW_BINARY)
6627 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
6632 handle decimal numbers.
6633 we're also sent here when we read a 0 as the first digit
6635 case '1': case '2': case '3': case '4': case '5':
6636 case '6': case '7': case '8': case '9': case '.':
6639 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
6642 /* read next group of digits and _ and copy into d */
6643 while (isDIGIT(*s) || *s == '_') {
6644 /* skip underscores, checking for misplaced ones
6648 dTHR; /* only for ckWARN */
6649 if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
6650 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
6654 /* check for end of fixed-length buffer */
6656 Perl_croak(aTHX_ number_too_long);
6657 /* if we're ok, copy the character */
6662 /* final misplaced underbar check */
6663 if (lastub && s - lastub != 3) {
6665 if (ckWARN(WARN_SYNTAX))
6666 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
6669 /* read a decimal portion if there is one. avoid
6670 3..5 being interpreted as the number 3. followed
6673 if (*s == '.' && s[1] != '.') {
6677 /* copy, ignoring underbars, until we run out of
6678 digits. Note: no misplaced underbar checks!
6680 for (; isDIGIT(*s) || *s == '_'; s++) {
6681 /* fixed length buffer check */
6683 Perl_croak(aTHX_ number_too_long);
6689 /* read exponent part, if present */
6690 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
6694 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
6695 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
6697 /* allow positive or negative exponent */
6698 if (*s == '+' || *s == '-')
6701 /* read digits of exponent (no underbars :-) */
6702 while (isDIGIT(*s)) {
6704 Perl_croak(aTHX_ number_too_long);
6709 /* terminate the string */
6712 /* make an sv from the string */
6715 value = Atof(PL_tokenbuf);
6718 See if we can make do with an integer value without loss of
6719 precision. We use I_V to cast to an int, because some
6720 compilers have issues. Then we try casting it back and see
6721 if it was the same. We only do this if we know we
6722 specifically read an integer.
6724 Note: if floatit is true, then we don't need to do the
6728 if (!floatit && (NV)tryiv == value)
6729 sv_setiv(sv, tryiv);
6731 sv_setnv(sv, value);
6732 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
6733 (PL_hints & HINT_NEW_INTEGER) )
6734 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
6735 (floatit ? "float" : "integer"),
6740 /* make the op for the constant and return */
6742 yylval.opval = newSVOP(OP_CONST, 0, sv);
6748 S_scan_formline(pTHX_ register char *s)
6753 SV *stuff = newSVpvn("",0);
6754 bool needargs = FALSE;
6757 if (*s == '.' || *s == '}') {
6759 #ifdef PERL_STRICT_CR
6760 for (t = s+1;*t == ' ' || *t == '\t'; t++) ;
6762 for (t = s+1;*t == ' ' || *t == '\t' || *t == '\r'; t++) ;
6764 if (*t == '\n' || t == PL_bufend)
6767 if (PL_in_eval && !PL_rsfp) {
6768 eol = strchr(s,'\n');
6773 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6775 for (t = s; t < eol; t++) {
6776 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
6778 goto enough; /* ~~ must be first line in formline */
6780 if (*t == '@' || *t == '^')
6783 sv_catpvn(stuff, s, eol-s);
6787 s = filter_gets(PL_linestr, PL_rsfp, 0);
6788 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
6789 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
6792 yyerror("Format not terminated");
6802 PL_lex_state = LEX_NORMAL;
6803 PL_nextval[PL_nexttoke].ival = 0;
6807 PL_lex_state = LEX_FORMLINE;
6808 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
6810 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
6814 SvREFCNT_dec(stuff);
6815 PL_lex_formbrack = 0;
6826 PL_cshlen = strlen(PL_cshname);
6831 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
6834 I32 oldsavestack_ix = PL_savestack_ix;
6835 CV* outsidecv = PL_compcv;
6839 assert(SvTYPE(PL_compcv) == SVt_PVCV);
6841 save_I32(&PL_subline);
6842 save_item(PL_subname);
6844 SAVESPTR(PL_curpad);
6845 SAVESPTR(PL_comppad);
6846 SAVESPTR(PL_comppad_name);
6847 SAVESPTR(PL_compcv);
6848 SAVEI32(PL_comppad_name_fill);
6849 SAVEI32(PL_min_intro_pending);
6850 SAVEI32(PL_max_intro_pending);
6851 SAVEI32(PL_pad_reset_pending);
6853 PL_compcv = (CV*)NEWSV(1104,0);
6854 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
6855 CvFLAGS(PL_compcv) |= flags;
6857 PL_comppad = newAV();
6858 av_push(PL_comppad, Nullsv);
6859 PL_curpad = AvARRAY(PL_comppad);
6860 PL_comppad_name = newAV();
6861 PL_comppad_name_fill = 0;
6862 PL_min_intro_pending = 0;
6864 PL_subline = PL_curcop->cop_line;
6866 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
6867 PL_curpad[0] = (SV*)newAV();
6868 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
6869 #endif /* USE_THREADS */
6871 comppadlist = newAV();
6872 AvREAL_off(comppadlist);
6873 av_store(comppadlist, 0, (SV*)PL_comppad_name);
6874 av_store(comppadlist, 1, (SV*)PL_comppad);
6876 CvPADLIST(PL_compcv) = comppadlist;
6877 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
6879 CvOWNER(PL_compcv) = 0;
6880 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
6881 MUTEX_INIT(CvMUTEXP(PL_compcv));
6882 #endif /* USE_THREADS */
6884 return oldsavestack_ix;
6888 Perl_yywarn(pTHX_ char *s)
6892 PL_in_eval |= EVAL_WARNONLY;
6894 PL_in_eval &= ~EVAL_WARNONLY;
6899 Perl_yyerror(pTHX_ char *s)
6903 char *context = NULL;
6907 if (!yychar || (yychar == ';' && !PL_rsfp))
6909 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
6910 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
6911 while (isSPACE(*PL_oldoldbufptr))
6913 context = PL_oldoldbufptr;
6914 contlen = PL_bufptr - PL_oldoldbufptr;
6916 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
6917 PL_oldbufptr != PL_bufptr) {
6918 while (isSPACE(*PL_oldbufptr))
6920 context = PL_oldbufptr;
6921 contlen = PL_bufptr - PL_oldbufptr;
6923 else if (yychar > 255)
6924 where = "next token ???";
6925 else if ((yychar & 127) == 127) {
6926 if (PL_lex_state == LEX_NORMAL ||
6927 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
6928 where = "at end of line";
6929 else if (PL_lex_inpat)
6930 where = "within pattern";
6932 where = "within string";
6935 SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
6937 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
6938 else if (isPRINT_LC(yychar))
6939 Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
6941 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
6942 where = SvPVX(where_sv);
6944 msg = sv_2mortal(newSVpv(s, 0));
6946 Perl_sv_catpvf(aTHX_ msg, " at %_ line %" PERL_PRId64 ", ",
6947 GvSV(PL_curcop->cop_filegv), (IV)PL_curcop->cop_line);
6949 Perl_sv_catpvf(aTHX_ msg, " at %_ line %ld, ",
6950 GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line);
6953 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
6955 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
6956 if (PL_multi_start < PL_multi_end && (U32)(PL_curcop->cop_line - PL_multi_end) <= 1) {
6958 Perl_sv_catpvf(aTHX_ msg,
6959 " (Might be a runaway multi-line %c%c string starting on line %" PERL_\
6961 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
6963 Perl_sv_catpvf(aTHX_ msg,
6964 " (Might be a runaway multi-line %c%c string starting on line %ld)\n",
6965 (int)PL_multi_open,(int)PL_multi_close,(long)PL_multi_start);
6969 if (PL_in_eval & EVAL_WARNONLY)
6970 Perl_warn(aTHX_ "%_", msg);
6971 else if (PL_in_eval)
6972 sv_catsv(ERRSV, msg);
6974 PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
6975 if (++PL_error_count >= 10)
6976 Perl_croak(aTHX_ "%_ has too many errors.\n", GvSV(PL_curcop->cop_filegv));
6978 PL_in_my_stash = Nullhv;
6990 * Restore a source filter.
6994 restore_rsfp(pTHXo_ void *f)
6996 PerlIO *fp = (PerlIO*)f;
6998 if (PL_rsfp == PerlIO_stdin())
6999 PerlIO_clearerr(PL_rsfp);
7000 else if (PL_rsfp && (PL_rsfp != fp))
7001 PerlIO_close(PL_rsfp);
7007 * Restores the state of PL_expect when the lexing that begun with a
7008 * start_lex() call has ended.
7012 restore_expect(pTHXo_ void *e)
7014 /* a safe way to store a small integer in a pointer */
7015 PL_expect = (expectation)((char *)e - PL_tokenbuf);
7019 * restore_lex_expect
7020 * Restores the state of PL_lex_expect when the lexing that begun with a
7021 * start_lex() call has ended.
7025 restore_lex_expect(pTHXo_ void *e)
7027 /* a safe way to store a small integer in a pointer */
7028 PL_lex_expect = (expectation)((char *)e - PL_tokenbuf);