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 : buffer position (must be within PL_linestr)
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];
4508 expectation attrful;
4509 bool have_name, have_proto;
4514 if (isIDFIRST_lazy(s) || *s == '\'' ||
4515 (*s == ':' && s[1] == ':'))
4518 attrful = XATTRBLOCK;
4519 /* remember buffer pos'n for later force_word */
4520 tboffset = s - PL_oldbufptr;
4521 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4522 if (strchr(tmpbuf, ':'))
4523 sv_setpv(PL_subname, tmpbuf);
4525 sv_setsv(PL_subname,PL_curstname);
4526 sv_catpvn(PL_subname,"::",2);
4527 sv_catpvn(PL_subname,tmpbuf,len);
4534 Perl_croak(aTHX_ "Missing name in \"my sub\"");
4535 PL_expect = XTERMBLOCK;
4536 attrful = XATTRTERM;
4537 sv_setpv(PL_subname,"?");
4541 if (key == KEY_format) {
4543 PL_lex_formbrack = PL_lex_brackets + 1;
4545 (void) force_word(PL_oldbufptr + tboffset, WORD,
4550 /* Look for a prototype */
4554 s = scan_str(s,FALSE,FALSE);
4557 SvREFCNT_dec(PL_lex_stuff);
4558 PL_lex_stuff = Nullsv;
4559 Perl_croak(aTHX_ "Prototype not terminated");
4562 d = SvPVX(PL_lex_stuff);
4564 for (p = d; *p; ++p) {
4569 SvCUR(PL_lex_stuff) = tmp;
4577 if (*s == ':' && s[1] != ':')
4578 PL_expect = attrful;
4581 PL_nextval[PL_nexttoke].opval =
4582 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4583 PL_lex_stuff = Nullsv;
4587 sv_setpv(PL_subname,"__ANON__");
4590 (void) force_word(PL_oldbufptr + tboffset, WORD,
4599 LOP(OP_SYSTEM,XREF);
4602 LOP(OP_SYMLINK,XTERM);
4605 LOP(OP_SYSCALL,XTERM);
4608 LOP(OP_SYSOPEN,XTERM);
4611 LOP(OP_SYSSEEK,XTERM);
4614 LOP(OP_SYSREAD,XTERM);
4617 LOP(OP_SYSWRITE,XTERM);
4621 TERM(sublex_start());
4642 LOP(OP_TRUNCATE,XTERM);
4654 yylval.ival = PL_curcop->cop_line;
4658 yylval.ival = PL_curcop->cop_line;
4662 LOP(OP_UNLINK,XTERM);
4668 LOP(OP_UNPACK,XTERM);
4671 LOP(OP_UTIME,XTERM);
4674 if (ckWARN(WARN_OCTAL)) {
4675 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4676 if (*d != '0' && isDIGIT(*d))
4677 Perl_warner(aTHX_ WARN_OCTAL,
4678 "umask: argument is missing initial 0");
4683 LOP(OP_UNSHIFT,XTERM);
4686 if (PL_expect != XSTATE)
4687 yyerror("\"use\" not allowed in expression");
4690 s = force_version(s);
4691 if(*s == ';' || (s = skipspace(s), *s == ';')) {
4692 PL_nextval[PL_nexttoke].opval = Nullop;
4697 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4698 s = force_version(s);
4711 yylval.ival = PL_curcop->cop_line;
4715 PL_hints |= HINT_BLOCK_SCOPE;
4722 LOP(OP_WAITPID,XTERM);
4730 static char ctl_l[2];
4732 if (ctl_l[0] == '\0')
4733 ctl_l[0] = toCTRL('L');
4734 gv_fetchpv(ctl_l,TRUE, SVt_PV);
4737 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
4742 if (PL_expect == XOPERATOR)
4748 yylval.ival = OP_XOR;
4753 TERM(sublex_start());
4759 Perl_keyword(pTHX_ register char *d, I32 len)
4764 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
4765 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
4766 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
4767 if (strEQ(d,"__DATA__")) return KEY___DATA__;
4768 if (strEQ(d,"__END__")) return KEY___END__;
4772 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
4777 if (strEQ(d,"and")) return -KEY_and;
4778 if (strEQ(d,"abs")) return -KEY_abs;
4781 if (strEQ(d,"alarm")) return -KEY_alarm;
4782 if (strEQ(d,"atan2")) return -KEY_atan2;
4785 if (strEQ(d,"accept")) return -KEY_accept;
4790 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
4793 if (strEQ(d,"bless")) return -KEY_bless;
4794 if (strEQ(d,"bind")) return -KEY_bind;
4795 if (strEQ(d,"binmode")) return -KEY_binmode;
4798 if (strEQ(d,"CORE")) return -KEY_CORE;
4803 if (strEQ(d,"cmp")) return -KEY_cmp;
4804 if (strEQ(d,"chr")) return -KEY_chr;
4805 if (strEQ(d,"cos")) return -KEY_cos;
4808 if (strEQ(d,"chop")) return KEY_chop;
4811 if (strEQ(d,"close")) return -KEY_close;
4812 if (strEQ(d,"chdir")) return -KEY_chdir;
4813 if (strEQ(d,"chomp")) return KEY_chomp;
4814 if (strEQ(d,"chmod")) return -KEY_chmod;
4815 if (strEQ(d,"chown")) return -KEY_chown;
4816 if (strEQ(d,"crypt")) return -KEY_crypt;
4819 if (strEQ(d,"chroot")) return -KEY_chroot;
4820 if (strEQ(d,"caller")) return -KEY_caller;
4823 if (strEQ(d,"connect")) return -KEY_connect;
4826 if (strEQ(d,"closedir")) return -KEY_closedir;
4827 if (strEQ(d,"continue")) return -KEY_continue;
4832 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
4837 if (strEQ(d,"do")) return KEY_do;
4840 if (strEQ(d,"die")) return -KEY_die;
4843 if (strEQ(d,"dump")) return -KEY_dump;
4846 if (strEQ(d,"delete")) return KEY_delete;
4849 if (strEQ(d,"defined")) return KEY_defined;
4850 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
4853 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
4858 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
4859 if (strEQ(d,"END")) return KEY_END;
4864 if (strEQ(d,"eq")) return -KEY_eq;
4867 if (strEQ(d,"eof")) return -KEY_eof;
4868 if (strEQ(d,"exp")) return -KEY_exp;
4871 if (strEQ(d,"else")) return KEY_else;
4872 if (strEQ(d,"exit")) return -KEY_exit;
4873 if (strEQ(d,"eval")) return KEY_eval;
4874 if (strEQ(d,"exec")) return -KEY_exec;
4875 if (strEQ(d,"each")) return KEY_each;
4878 if (strEQ(d,"elsif")) return KEY_elsif;
4881 if (strEQ(d,"exists")) return KEY_exists;
4882 if (strEQ(d,"elseif")) Perl_warn(aTHX_ "elseif should be elsif");
4885 if (strEQ(d,"endgrent")) return -KEY_endgrent;
4886 if (strEQ(d,"endpwent")) return -KEY_endpwent;
4889 if (strEQ(d,"endnetent")) return -KEY_endnetent;
4892 if (strEQ(d,"endhostent")) return -KEY_endhostent;
4893 if (strEQ(d,"endservent")) return -KEY_endservent;
4896 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
4903 if (strEQ(d,"for")) return KEY_for;
4906 if (strEQ(d,"fork")) return -KEY_fork;
4909 if (strEQ(d,"fcntl")) return -KEY_fcntl;
4910 if (strEQ(d,"flock")) return -KEY_flock;
4913 if (strEQ(d,"format")) return KEY_format;
4914 if (strEQ(d,"fileno")) return -KEY_fileno;
4917 if (strEQ(d,"foreach")) return KEY_foreach;
4920 if (strEQ(d,"formline")) return -KEY_formline;
4926 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
4927 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
4931 if (strnEQ(d,"get",3)) {
4936 if (strEQ(d,"ppid")) return -KEY_getppid;
4937 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
4940 if (strEQ(d,"pwent")) return -KEY_getpwent;
4941 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
4942 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
4945 if (strEQ(d,"peername")) return -KEY_getpeername;
4946 if (strEQ(d,"protoent")) return -KEY_getprotoent;
4947 if (strEQ(d,"priority")) return -KEY_getpriority;
4950 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
4953 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
4957 else if (*d == 'h') {
4958 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
4959 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
4960 if (strEQ(d,"hostent")) return -KEY_gethostent;
4962 else if (*d == 'n') {
4963 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
4964 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
4965 if (strEQ(d,"netent")) return -KEY_getnetent;
4967 else if (*d == 's') {
4968 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
4969 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
4970 if (strEQ(d,"servent")) return -KEY_getservent;
4971 if (strEQ(d,"sockname")) return -KEY_getsockname;
4972 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
4974 else if (*d == 'g') {
4975 if (strEQ(d,"grent")) return -KEY_getgrent;
4976 if (strEQ(d,"grnam")) return -KEY_getgrnam;
4977 if (strEQ(d,"grgid")) return -KEY_getgrgid;
4979 else if (*d == 'l') {
4980 if (strEQ(d,"login")) return -KEY_getlogin;
4982 else if (strEQ(d,"c")) return -KEY_getc;
4987 if (strEQ(d,"gt")) return -KEY_gt;
4988 if (strEQ(d,"ge")) return -KEY_ge;
4991 if (strEQ(d,"grep")) return KEY_grep;
4992 if (strEQ(d,"goto")) return KEY_goto;
4993 if (strEQ(d,"glob")) return KEY_glob;
4996 if (strEQ(d,"gmtime")) return -KEY_gmtime;
5001 if (strEQ(d,"hex")) return -KEY_hex;
5004 if (strEQ(d,"INIT")) return KEY_INIT;
5009 if (strEQ(d,"if")) return KEY_if;
5012 if (strEQ(d,"int")) return -KEY_int;
5015 if (strEQ(d,"index")) return -KEY_index;
5016 if (strEQ(d,"ioctl")) return -KEY_ioctl;
5021 if (strEQ(d,"join")) return -KEY_join;
5025 if (strEQ(d,"keys")) return KEY_keys;
5026 if (strEQ(d,"kill")) return -KEY_kill;
5031 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
5032 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
5038 if (strEQ(d,"lt")) return -KEY_lt;
5039 if (strEQ(d,"le")) return -KEY_le;
5040 if (strEQ(d,"lc")) return -KEY_lc;
5043 if (strEQ(d,"log")) return -KEY_log;
5046 if (strEQ(d,"last")) return KEY_last;
5047 if (strEQ(d,"link")) return -KEY_link;
5048 if (strEQ(d,"lock")) return -KEY_lock;
5051 if (strEQ(d,"local")) return KEY_local;
5052 if (strEQ(d,"lstat")) return -KEY_lstat;
5055 if (strEQ(d,"length")) return -KEY_length;
5056 if (strEQ(d,"listen")) return -KEY_listen;
5059 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
5062 if (strEQ(d,"localtime")) return -KEY_localtime;
5068 case 1: return KEY_m;
5070 if (strEQ(d,"my")) return KEY_my;
5073 if (strEQ(d,"map")) return KEY_map;
5076 if (strEQ(d,"mkdir")) return -KEY_mkdir;
5079 if (strEQ(d,"msgctl")) return -KEY_msgctl;
5080 if (strEQ(d,"msgget")) return -KEY_msgget;
5081 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
5082 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
5087 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
5090 if (strEQ(d,"next")) return KEY_next;
5091 if (strEQ(d,"ne")) return -KEY_ne;
5092 if (strEQ(d,"not")) return -KEY_not;
5093 if (strEQ(d,"no")) return KEY_no;
5098 if (strEQ(d,"or")) return -KEY_or;
5101 if (strEQ(d,"ord")) return -KEY_ord;
5102 if (strEQ(d,"oct")) return -KEY_oct;
5103 if (strEQ(d,"our")) { deprecate("reserved word \"our\"");
5107 if (strEQ(d,"open")) return -KEY_open;
5110 if (strEQ(d,"opendir")) return -KEY_opendir;
5117 if (strEQ(d,"pop")) return KEY_pop;
5118 if (strEQ(d,"pos")) return KEY_pos;
5121 if (strEQ(d,"push")) return KEY_push;
5122 if (strEQ(d,"pack")) return -KEY_pack;
5123 if (strEQ(d,"pipe")) return -KEY_pipe;
5126 if (strEQ(d,"print")) return KEY_print;
5129 if (strEQ(d,"printf")) return KEY_printf;
5132 if (strEQ(d,"package")) return KEY_package;
5135 if (strEQ(d,"prototype")) return KEY_prototype;
5140 if (strEQ(d,"q")) return KEY_q;
5141 if (strEQ(d,"qr")) return KEY_qr;
5142 if (strEQ(d,"qq")) return KEY_qq;
5143 if (strEQ(d,"qw")) return KEY_qw;
5144 if (strEQ(d,"qx")) return KEY_qx;
5146 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
5151 if (strEQ(d,"ref")) return -KEY_ref;
5154 if (strEQ(d,"read")) return -KEY_read;
5155 if (strEQ(d,"rand")) return -KEY_rand;
5156 if (strEQ(d,"recv")) return -KEY_recv;
5157 if (strEQ(d,"redo")) return KEY_redo;
5160 if (strEQ(d,"rmdir")) return -KEY_rmdir;
5161 if (strEQ(d,"reset")) return -KEY_reset;
5164 if (strEQ(d,"return")) return KEY_return;
5165 if (strEQ(d,"rename")) return -KEY_rename;
5166 if (strEQ(d,"rindex")) return -KEY_rindex;
5169 if (strEQ(d,"require")) return -KEY_require;
5170 if (strEQ(d,"reverse")) return -KEY_reverse;
5171 if (strEQ(d,"readdir")) return -KEY_readdir;
5174 if (strEQ(d,"readlink")) return -KEY_readlink;
5175 if (strEQ(d,"readline")) return -KEY_readline;
5176 if (strEQ(d,"readpipe")) return -KEY_readpipe;
5179 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
5185 case 0: return KEY_s;
5187 if (strEQ(d,"scalar")) return KEY_scalar;
5192 if (strEQ(d,"seek")) return -KEY_seek;
5193 if (strEQ(d,"send")) return -KEY_send;
5196 if (strEQ(d,"semop")) return -KEY_semop;
5199 if (strEQ(d,"select")) return -KEY_select;
5200 if (strEQ(d,"semctl")) return -KEY_semctl;
5201 if (strEQ(d,"semget")) return -KEY_semget;
5204 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
5205 if (strEQ(d,"seekdir")) return -KEY_seekdir;
5208 if (strEQ(d,"setpwent")) return -KEY_setpwent;
5209 if (strEQ(d,"setgrent")) return -KEY_setgrent;
5212 if (strEQ(d,"setnetent")) return -KEY_setnetent;
5215 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
5216 if (strEQ(d,"sethostent")) return -KEY_sethostent;
5217 if (strEQ(d,"setservent")) return -KEY_setservent;
5220 if (strEQ(d,"setpriority")) return -KEY_setpriority;
5221 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
5228 if (strEQ(d,"shift")) return KEY_shift;
5231 if (strEQ(d,"shmctl")) return -KEY_shmctl;
5232 if (strEQ(d,"shmget")) return -KEY_shmget;
5235 if (strEQ(d,"shmread")) return -KEY_shmread;
5238 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
5239 if (strEQ(d,"shutdown")) return -KEY_shutdown;
5244 if (strEQ(d,"sin")) return -KEY_sin;
5247 if (strEQ(d,"sleep")) return -KEY_sleep;
5250 if (strEQ(d,"sort")) return KEY_sort;
5251 if (strEQ(d,"socket")) return -KEY_socket;
5252 if (strEQ(d,"socketpair")) return -KEY_socketpair;
5255 if (strEQ(d,"split")) return KEY_split;
5256 if (strEQ(d,"sprintf")) return -KEY_sprintf;
5257 if (strEQ(d,"splice")) return KEY_splice;
5260 if (strEQ(d,"sqrt")) return -KEY_sqrt;
5263 if (strEQ(d,"srand")) return -KEY_srand;
5266 if (strEQ(d,"stat")) return -KEY_stat;
5267 if (strEQ(d,"study")) return KEY_study;
5270 if (strEQ(d,"substr")) return -KEY_substr;
5271 if (strEQ(d,"sub")) return KEY_sub;
5276 if (strEQ(d,"system")) return -KEY_system;
5279 if (strEQ(d,"symlink")) return -KEY_symlink;
5280 if (strEQ(d,"syscall")) return -KEY_syscall;
5281 if (strEQ(d,"sysopen")) return -KEY_sysopen;
5282 if (strEQ(d,"sysread")) return -KEY_sysread;
5283 if (strEQ(d,"sysseek")) return -KEY_sysseek;
5286 if (strEQ(d,"syswrite")) return -KEY_syswrite;
5295 if (strEQ(d,"tr")) return KEY_tr;
5298 if (strEQ(d,"tie")) return KEY_tie;
5301 if (strEQ(d,"tell")) return -KEY_tell;
5302 if (strEQ(d,"tied")) return KEY_tied;
5303 if (strEQ(d,"time")) return -KEY_time;
5306 if (strEQ(d,"times")) return -KEY_times;
5309 if (strEQ(d,"telldir")) return -KEY_telldir;
5312 if (strEQ(d,"truncate")) return -KEY_truncate;
5319 if (strEQ(d,"uc")) return -KEY_uc;
5322 if (strEQ(d,"use")) return KEY_use;
5325 if (strEQ(d,"undef")) return KEY_undef;
5326 if (strEQ(d,"until")) return KEY_until;
5327 if (strEQ(d,"untie")) return KEY_untie;
5328 if (strEQ(d,"utime")) return -KEY_utime;
5329 if (strEQ(d,"umask")) return -KEY_umask;
5332 if (strEQ(d,"unless")) return KEY_unless;
5333 if (strEQ(d,"unpack")) return -KEY_unpack;
5334 if (strEQ(d,"unlink")) return -KEY_unlink;
5337 if (strEQ(d,"unshift")) return KEY_unshift;
5338 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
5343 if (strEQ(d,"values")) return -KEY_values;
5344 if (strEQ(d,"vec")) return -KEY_vec;
5349 if (strEQ(d,"warn")) return -KEY_warn;
5350 if (strEQ(d,"wait")) return -KEY_wait;
5353 if (strEQ(d,"while")) return KEY_while;
5354 if (strEQ(d,"write")) return -KEY_write;
5357 if (strEQ(d,"waitpid")) return -KEY_waitpid;
5360 if (strEQ(d,"wantarray")) return -KEY_wantarray;
5365 if (len == 1) return -KEY_x;
5366 if (strEQ(d,"xor")) return -KEY_xor;
5369 if (len == 1) return KEY_y;
5378 S_checkcomma(pTHX_ register char *s, char *name, char *what)
5382 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
5383 dTHR; /* only for ckWARN */
5384 if (ckWARN(WARN_SYNTAX)) {
5386 for (w = s+2; *w && level; w++) {
5393 for (; *w && isSPACE(*w); w++) ;
5394 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
5395 Perl_warner(aTHX_ WARN_SYNTAX, "%s (...) interpreted as function",name);
5398 while (s < PL_bufend && isSPACE(*s))
5402 while (s < PL_bufend && isSPACE(*s))
5404 if (isIDFIRST_lazy(s)) {
5406 while (isALNUM_lazy(s))
5408 while (s < PL_bufend && isSPACE(*s))
5413 kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
5417 Perl_croak(aTHX_ "No comma allowed after %s", what);
5422 /* Either returns sv, or mortalizes sv and returns a new SV*.
5423 Best used as sv=new_constant(..., sv, ...).
5424 If s, pv are NULL, calls subroutine with one argument,
5425 and type is used with error messages only. */
5428 S_new_constant(pTHX_ char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)
5431 HV *table = GvHV(PL_hintgv); /* ^H */
5435 char *why, *why1, *why2;
5437 if (!(PL_hints & HINT_LOCALIZE_HH)) {
5440 why = "%^H is not localized";
5444 msg = Perl_newSVpvf(aTHX_ "constant(%s): %s%s%s",
5445 (type ? type: "undef"), why1, why2, why);
5446 yyerror(SvPVX(msg));
5451 why = "%^H is not defined";
5454 cvp = hv_fetch(table, key, strlen(key), FALSE);
5455 if (!cvp || !SvOK(*cvp)) {
5456 why = "} is not defined";
5461 sv_2mortal(sv); /* Parent created it permanently */
5464 pv = sv_2mortal(newSVpvn(s, len));
5466 typesv = sv_2mortal(newSVpv(type, 0));
5468 typesv = &PL_sv_undef;
5470 PUSHSTACKi(PERLSI_OVERLOAD);
5483 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
5487 /* Check the eval first */
5488 if (!PL_in_eval && SvTRUE(ERRSV))
5491 sv_catpv(ERRSV, "Propagated");
5492 yyerror(SvPV(ERRSV, n_a)); /* Duplicates the message inside eval */
5494 res = SvREFCNT_inc(sv);
5507 why = "}} did not return a defined value";
5508 why1 = "Call to &{$^H{";
5518 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
5520 register char *d = dest;
5521 register char *e = d + destlen - 3; /* two-character token, ending NUL */
5524 Perl_croak(aTHX_ ident_too_long);
5525 if (isALNUM(*s)) /* UTF handled below */
5527 else if (*s == '\'' && allow_package && isIDFIRST_lazy(s+1)) {
5532 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
5536 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5537 char *t = s + UTF8SKIP(s);
5538 while (*t & 0x80 && is_utf8_mark((U8*)t))
5540 if (d + (t - s) > e)
5541 Perl_croak(aTHX_ ident_too_long);
5542 Copy(s, d, t - s, char);
5555 S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
5562 if (PL_lex_brackets == 0)
5563 PL_lex_fakebrack = 0;
5567 e = d + destlen - 3; /* two-character token, ending NUL */
5569 while (isDIGIT(*s)) {
5571 Perl_croak(aTHX_ ident_too_long);
5578 Perl_croak(aTHX_ ident_too_long);
5579 if (isALNUM(*s)) /* UTF handled below */
5581 else if (*s == '\'' && isIDFIRST_lazy(s+1)) {
5586 else if (*s == ':' && s[1] == ':') {
5590 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5591 char *t = s + UTF8SKIP(s);
5592 while (*t & 0x80 && is_utf8_mark((U8*)t))
5594 if (d + (t - s) > e)
5595 Perl_croak(aTHX_ ident_too_long);
5596 Copy(s, d, t - s, char);
5607 if (PL_lex_state != LEX_NORMAL)
5608 PL_lex_state = LEX_INTERPENDMAYBE;
5611 if (*s == '$' && s[1] &&
5612 (isALNUM_lazy(s+1) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
5625 if (*d == '^' && *s && isCONTROLVAR(*s)) {
5630 if (isSPACE(s[-1])) {
5633 if (ch != ' ' && ch != '\t') {
5639 if (isIDFIRST_lazy(d)) {
5643 while (e < send && isALNUM_lazy(e) || *e == ':') {
5645 while (e < send && *e & 0x80 && is_utf8_mark((U8*)e))
5648 Copy(s, d, e - s, char);
5653 while ((isALNUM(*s) || *s == ':') && d < e)
5656 Perl_croak(aTHX_ ident_too_long);
5659 while (s < send && (*s == ' ' || *s == '\t')) s++;
5660 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
5661 dTHR; /* only for ckWARN */
5662 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
5663 char *brack = *s == '[' ? "[...]" : "{...}";
5664 Perl_warner(aTHX_ WARN_AMBIGUOUS,
5665 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
5666 funny, dest, brack, funny, dest, brack);
5668 PL_lex_fakebrack = PL_lex_brackets+1;
5670 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5674 /* Handle extended ${^Foo} variables
5675 * 1999-02-27 mjd-perl-patch@plover.com */
5676 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
5680 while (isALNUM(*s) && d < e) {
5684 Perl_croak(aTHX_ ident_too_long);
5689 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
5690 PL_lex_state = LEX_INTERPEND;
5693 if (PL_lex_state == LEX_NORMAL) {
5694 dTHR; /* only for ckWARN */
5695 if (ckWARN(WARN_AMBIGUOUS) &&
5696 (keyword(dest, d - dest) || get_cv(dest, FALSE)))
5698 Perl_warner(aTHX_ WARN_AMBIGUOUS,
5699 "Ambiguous use of %c{%s} resolved to %c%s",
5700 funny, dest, funny, dest);
5705 s = bracket; /* let the parser handle it */
5709 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
5710 PL_lex_state = LEX_INTERPEND;
5715 Perl_pmflag(pTHX_ U16 *pmfl, int ch)
5720 *pmfl |= PMf_GLOBAL;
5722 *pmfl |= PMf_CONTINUE;
5726 *pmfl |= PMf_MULTILINE;
5728 *pmfl |= PMf_SINGLELINE;
5730 *pmfl |= PMf_EXTENDED;
5734 S_scan_pat(pTHX_ char *start, I32 type)
5739 s = scan_str(start,FALSE,FALSE);
5742 SvREFCNT_dec(PL_lex_stuff);
5743 PL_lex_stuff = Nullsv;
5744 Perl_croak(aTHX_ "Search pattern not terminated");
5747 pm = (PMOP*)newPMOP(type, 0);
5748 if (PL_multi_open == '?')
5749 pm->op_pmflags |= PMf_ONCE;
5751 while (*s && strchr("iomsx", *s))
5752 pmflag(&pm->op_pmflags,*s++);
5755 while (*s && strchr("iogcmsx", *s))
5756 pmflag(&pm->op_pmflags,*s++);
5758 pm->op_pmpermflags = pm->op_pmflags;
5760 PL_lex_op = (OP*)pm;
5761 yylval.ival = OP_MATCH;
5766 S_scan_subst(pTHX_ char *start)
5773 yylval.ival = OP_NULL;
5775 s = scan_str(start,FALSE,FALSE);
5779 SvREFCNT_dec(PL_lex_stuff);
5780 PL_lex_stuff = Nullsv;
5781 Perl_croak(aTHX_ "Substitution pattern not terminated");
5784 if (s[-1] == PL_multi_open)
5787 first_start = PL_multi_start;
5788 s = scan_str(s,FALSE,FALSE);
5791 SvREFCNT_dec(PL_lex_stuff);
5792 PL_lex_stuff = Nullsv;
5794 SvREFCNT_dec(PL_lex_repl);
5795 PL_lex_repl = Nullsv;
5796 Perl_croak(aTHX_ "Substitution replacement not terminated");
5798 PL_multi_start = first_start; /* so whole substitution is taken together */
5800 pm = (PMOP*)newPMOP(OP_SUBST, 0);
5806 else if (strchr("iogcmsx", *s))
5807 pmflag(&pm->op_pmflags,*s++);
5814 PL_sublex_info.super_bufptr = s;
5815 PL_sublex_info.super_bufend = PL_bufend;
5817 pm->op_pmflags |= PMf_EVAL;
5818 repl = newSVpvn("",0);
5820 sv_catpv(repl, es ? "eval " : "do ");
5821 sv_catpvn(repl, "{ ", 2);
5822 sv_catsv(repl, PL_lex_repl);
5823 sv_catpvn(repl, " };", 2);
5825 SvREFCNT_dec(PL_lex_repl);
5829 pm->op_pmpermflags = pm->op_pmflags;
5830 PL_lex_op = (OP*)pm;
5831 yylval.ival = OP_SUBST;
5836 S_scan_trans(pTHX_ char *start)
5847 yylval.ival = OP_NULL;
5849 s = scan_str(start,FALSE,FALSE);
5852 SvREFCNT_dec(PL_lex_stuff);
5853 PL_lex_stuff = Nullsv;
5854 Perl_croak(aTHX_ "Transliteration pattern not terminated");
5856 if (s[-1] == PL_multi_open)
5859 s = scan_str(s,FALSE,FALSE);
5862 SvREFCNT_dec(PL_lex_stuff);
5863 PL_lex_stuff = Nullsv;
5865 SvREFCNT_dec(PL_lex_repl);
5866 PL_lex_repl = Nullsv;
5867 Perl_croak(aTHX_ "Transliteration replacement not terminated");
5871 o = newSVOP(OP_TRANS, 0, 0);
5872 utf8 = OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF;
5875 New(803,tbl,256,short);
5876 o = newPVOP(OP_TRANS, 0, (char*)tbl);
5880 complement = del = squash = 0;
5881 while (strchr("cdsCU", *s)) {
5883 complement = OPpTRANS_COMPLEMENT;
5885 del = OPpTRANS_DELETE;
5887 squash = OPpTRANS_SQUASH;
5892 utf8 &= ~OPpTRANS_FROM_UTF;
5894 utf8 |= OPpTRANS_FROM_UTF;
5898 utf8 &= ~OPpTRANS_TO_UTF;
5900 utf8 |= OPpTRANS_TO_UTF;
5903 Perl_croak(aTHX_ "Too many /C and /U options");
5908 o->op_private = del|squash|complement|utf8;
5911 yylval.ival = OP_TRANS;
5916 S_scan_heredoc(pTHX_ register char *s)
5920 I32 op_type = OP_SCALAR;
5927 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
5931 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
5934 for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5935 if (*peek && strchr("`'\"",*peek)) {
5938 s = delimcpy(d, e, s, PL_bufend, term, &len);
5948 if (!isALNUM_lazy(s))
5949 deprecate("bare << to mean <<\"\"");
5950 for (; isALNUM_lazy(s); s++) {
5955 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
5956 Perl_croak(aTHX_ "Delimiter for here document is too long");
5959 len = d - PL_tokenbuf;
5960 #ifndef PERL_STRICT_CR
5961 d = strchr(s, '\r');
5965 while (s < PL_bufend) {
5971 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
5980 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5985 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
5986 herewas = newSVpvn(s,PL_bufend-s);
5988 s--, herewas = newSVpvn(s,d-s);
5989 s += SvCUR(herewas);
5991 tmpstr = NEWSV(87,79);
5992 sv_upgrade(tmpstr, SVt_PVIV);
5997 else if (term == '`') {
5998 op_type = OP_BACKTICK;
5999 SvIVX(tmpstr) = '\\';
6003 PL_multi_start = PL_curcop->cop_line;
6004 PL_multi_open = PL_multi_close = '<';
6005 term = *PL_tokenbuf;
6006 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
6007 char *bufptr = PL_sublex_info.super_bufptr;
6008 char *bufend = PL_sublex_info.super_bufend;
6009 char *olds = s - SvCUR(herewas);
6010 s = strchr(bufptr, '\n');
6014 while (s < bufend &&
6015 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6017 PL_curcop->cop_line++;
6020 PL_curcop->cop_line = PL_multi_start;
6021 missingterm(PL_tokenbuf);
6023 sv_setpvn(herewas,bufptr,d-bufptr+1);
6024 sv_setpvn(tmpstr,d+1,s-d);
6026 sv_catpvn(herewas,s,bufend-s);
6027 (void)strcpy(bufptr,SvPVX(herewas));
6034 while (s < PL_bufend &&
6035 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6037 PL_curcop->cop_line++;
6039 if (s >= PL_bufend) {
6040 PL_curcop->cop_line = PL_multi_start;
6041 missingterm(PL_tokenbuf);
6043 sv_setpvn(tmpstr,d+1,s-d);
6045 PL_curcop->cop_line++; /* the preceding stmt passes a newline */
6047 sv_catpvn(herewas,s,PL_bufend-s);
6048 sv_setsv(PL_linestr,herewas);
6049 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
6050 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6053 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
6054 while (s >= PL_bufend) { /* multiple line string? */
6056 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6057 PL_curcop->cop_line = PL_multi_start;
6058 missingterm(PL_tokenbuf);
6060 PL_curcop->cop_line++;
6061 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6062 #ifndef PERL_STRICT_CR
6063 if (PL_bufend - PL_linestart >= 2) {
6064 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
6065 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
6067 PL_bufend[-2] = '\n';
6069 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6071 else if (PL_bufend[-1] == '\r')
6072 PL_bufend[-1] = '\n';
6074 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
6075 PL_bufend[-1] = '\n';
6077 if (PERLDB_LINE && PL_curstash != PL_debstash) {
6078 SV *sv = NEWSV(88,0);
6080 sv_upgrade(sv, SVt_PVMG);
6081 sv_setsv(sv,PL_linestr);
6082 av_store(GvAV(PL_curcop->cop_filegv),
6083 (I32)PL_curcop->cop_line,sv);
6085 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
6088 sv_catsv(PL_linestr,herewas);
6089 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6093 sv_catsv(tmpstr,PL_linestr);
6098 PL_multi_end = PL_curcop->cop_line;
6099 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
6100 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
6101 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
6103 SvREFCNT_dec(herewas);
6104 PL_lex_stuff = tmpstr;
6105 yylval.ival = op_type;
6110 takes: current position in input buffer
6111 returns: new position in input buffer
6112 side-effects: yylval and lex_op are set.
6117 <FH> read from filehandle
6118 <pkg::FH> read from package qualified filehandle
6119 <pkg'FH> read from package qualified filehandle
6120 <$fh> read from filehandle in $fh
6126 S_scan_inputsymbol(pTHX_ char *start)
6128 register char *s = start; /* current position in buffer */
6134 d = PL_tokenbuf; /* start of temp holding space */
6135 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
6136 end = strchr(s, '\n');
6139 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
6141 /* die if we didn't have space for the contents of the <>,
6142 or if it didn't end, or if we see a newline
6145 if (len >= sizeof PL_tokenbuf)
6146 Perl_croak(aTHX_ "Excessively long <> operator");
6148 Perl_croak(aTHX_ "Unterminated <> operator");
6153 Remember, only scalar variables are interpreted as filehandles by
6154 this code. Anything more complex (e.g., <$fh{$num}>) will be
6155 treated as a glob() call.
6156 This code makes use of the fact that except for the $ at the front,
6157 a scalar variable and a filehandle look the same.
6159 if (*d == '$' && d[1]) d++;
6161 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
6162 while (*d && (isALNUM_lazy(d) || *d == '\'' || *d == ':'))
6165 /* If we've tried to read what we allow filehandles to look like, and
6166 there's still text left, then it must be a glob() and not a getline.
6167 Use scan_str to pull out the stuff between the <> and treat it
6168 as nothing more than a string.
6171 if (d - PL_tokenbuf != len) {
6172 yylval.ival = OP_GLOB;
6174 s = scan_str(start,FALSE,FALSE);
6176 Perl_croak(aTHX_ "Glob not terminated");
6180 /* we're in a filehandle read situation */
6183 /* turn <> into <ARGV> */
6185 (void)strcpy(d,"ARGV");
6187 /* if <$fh>, create the ops to turn the variable into a
6193 /* try to find it in the pad for this block, otherwise find
6194 add symbol table ops
6196 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
6197 OP *o = newOP(OP_PADSV, 0);
6199 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, o);
6202 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
6203 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
6204 newUNOP(OP_RV2SV, 0,
6205 newGVOP(OP_GV, 0, gv)));
6207 PL_lex_op->op_flags |= OPf_SPECIAL;
6208 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
6209 yylval.ival = OP_NULL;
6212 /* If it's none of the above, it must be a literal filehandle
6213 (<Foo::BAR> or <FOO>) so build a simple readline OP */
6215 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
6216 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
6217 yylval.ival = OP_NULL;
6226 takes: start position in buffer
6227 keep_quoted preserve \ on the embedded delimiter(s)
6228 keep_delims preserve the delimiters around the string
6229 returns: position to continue reading from buffer
6230 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
6231 updates the read buffer.
6233 This subroutine pulls a string out of the input. It is called for:
6234 q single quotes q(literal text)
6235 ' single quotes 'literal text'
6236 qq double quotes qq(interpolate $here please)
6237 " double quotes "interpolate $here please"
6238 qx backticks qx(/bin/ls -l)
6239 ` backticks `/bin/ls -l`
6240 qw quote words @EXPORT_OK = qw( func() $spam )
6241 m// regexp match m/this/
6242 s/// regexp substitute s/this/that/
6243 tr/// string transliterate tr/this/that/
6244 y/// string transliterate y/this/that/
6245 ($*@) sub prototypes sub foo ($)
6246 (stuff) sub attr parameters sub foo : attr(stuff)
6247 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
6249 In most of these cases (all but <>, patterns and transliterate)
6250 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
6251 calls scan_str(). s/// makes yylex() call scan_subst() which calls
6252 scan_str(). tr/// and y/// make yylex() call scan_trans() which
6255 It skips whitespace before the string starts, and treats the first
6256 character as the delimiter. If the delimiter is one of ([{< then
6257 the corresponding "close" character )]}> is used as the closing
6258 delimiter. It allows quoting of delimiters, and if the string has
6259 balanced delimiters ([{<>}]) it allows nesting.
6261 The lexer always reads these strings into lex_stuff, except in the
6262 case of the operators which take *two* arguments (s/// and tr///)
6263 when it checks to see if lex_stuff is full (presumably with the 1st
6264 arg to s or tr) and if so puts the string into lex_repl.
6269 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
6272 SV *sv; /* scalar value: string */
6273 char *tmps; /* temp string, used for delimiter matching */
6274 register char *s = start; /* current position in the buffer */
6275 register char term; /* terminating character */
6276 register char *to; /* current position in the sv's data */
6277 I32 brackets = 1; /* bracket nesting level */
6279 /* skip space before the delimiter */
6283 /* mark where we are, in case we need to report errors */
6286 /* after skipping whitespace, the next character is the terminator */
6288 /* mark where we are */
6289 PL_multi_start = PL_curcop->cop_line;
6290 PL_multi_open = term;
6292 /* find corresponding closing delimiter */
6293 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
6295 PL_multi_close = term;
6297 /* create a new SV to hold the contents. 87 is leak category, I'm
6298 assuming. 79 is the SV's initial length. What a random number. */
6300 sv_upgrade(sv, SVt_PVIV);
6302 (void)SvPOK_only(sv); /* validate pointer */
6304 /* move past delimiter and try to read a complete string */
6306 sv_catpvn(sv, s, 1);
6309 /* extend sv if need be */
6310 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
6311 /* set 'to' to the next character in the sv's string */
6312 to = SvPVX(sv)+SvCUR(sv);
6314 /* if open delimiter is the close delimiter read unbridle */
6315 if (PL_multi_open == PL_multi_close) {
6316 for (; s < PL_bufend; s++,to++) {
6317 /* embedded newlines increment the current line number */
6318 if (*s == '\n' && !PL_rsfp)
6319 PL_curcop->cop_line++;
6320 /* handle quoted delimiters */
6321 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
6322 if (!keep_quoted && s[1] == term)
6324 /* any other quotes are simply copied straight through */
6328 /* terminate when run out of buffer (the for() condition), or
6329 have found the terminator */
6330 else if (*s == term)
6336 /* if the terminator isn't the same as the start character (e.g.,
6337 matched brackets), we have to allow more in the quoting, and
6338 be prepared for nested brackets.
6341 /* read until we run out of string, or we find the terminator */
6342 for (; s < PL_bufend; s++,to++) {
6343 /* embedded newlines increment the line count */
6344 if (*s == '\n' && !PL_rsfp)
6345 PL_curcop->cop_line++;
6346 /* backslashes can escape the open or closing characters */
6347 if (*s == '\\' && s+1 < PL_bufend) {
6349 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
6354 /* allow nested opens and closes */
6355 else if (*s == PL_multi_close && --brackets <= 0)
6357 else if (*s == PL_multi_open)
6362 /* terminate the copied string and update the sv's end-of-string */
6364 SvCUR_set(sv, to - SvPVX(sv));
6367 * this next chunk reads more into the buffer if we're not done yet
6370 if (s < PL_bufend) break; /* handle case where we are done yet :-) */
6372 #ifndef PERL_STRICT_CR
6373 if (to - SvPVX(sv) >= 2) {
6374 if ((to[-2] == '\r' && to[-1] == '\n') ||
6375 (to[-2] == '\n' && to[-1] == '\r'))
6379 SvCUR_set(sv, to - SvPVX(sv));
6381 else if (to[-1] == '\r')
6384 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
6388 /* if we're out of file, or a read fails, bail and reset the current
6389 line marker so we can report where the unterminated string began
6392 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6394 PL_curcop->cop_line = PL_multi_start;
6397 /* we read a line, so increment our line counter */
6398 PL_curcop->cop_line++;
6400 /* update debugger info */
6401 if (PERLDB_LINE && PL_curstash != PL_debstash) {
6402 SV *sv = NEWSV(88,0);
6404 sv_upgrade(sv, SVt_PVMG);
6405 sv_setsv(sv,PL_linestr);
6406 av_store(GvAV(PL_curcop->cop_filegv),
6407 (I32)PL_curcop->cop_line, sv);
6410 /* having changed the buffer, we must update PL_bufend */
6411 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6414 /* at this point, we have successfully read the delimited string */
6417 sv_catpvn(sv, s, 1);
6418 PL_multi_end = PL_curcop->cop_line;
6421 /* if we allocated too much space, give some back */
6422 if (SvCUR(sv) + 5 < SvLEN(sv)) {
6423 SvLEN_set(sv, SvCUR(sv) + 1);
6424 Renew(SvPVX(sv), SvLEN(sv), char);
6427 /* decide whether this is the first or second quoted string we've read
6440 takes: pointer to position in buffer
6441 returns: pointer to new position in buffer
6442 side-effects: builds ops for the constant in yylval.op
6444 Read a number in any of the formats that Perl accepts:
6446 0(x[0-7A-F]+)|([0-7]+)|(b[01])
6447 [\d_]+(\.[\d_]*)?[Ee](\d+)
6449 Underbars (_) are allowed in decimal numbers. If -w is on,
6450 underbars before a decimal point must be at three digit intervals.
6452 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
6455 If it reads a number without a decimal point or an exponent, it will
6456 try converting the number to an integer and see if it can do so
6457 without loss of precision.
6461 Perl_scan_num(pTHX_ char *start)
6463 register char *s = start; /* current position in buffer */
6464 register char *d; /* destination in temp buffer */
6465 register char *e; /* end of temp buffer */
6466 IV tryiv; /* used to see if it can be an IV */
6467 NV value; /* number read, as a double */
6468 SV *sv; /* place to put the converted number */
6469 bool floatit; /* boolean: int or float? */
6470 char *lastub = 0; /* position of last underbar */
6471 static char number_too_long[] = "Number too long";
6473 /* We use the first character to decide what type of number this is */
6477 Perl_croak(aTHX_ "panic: scan_num");
6479 /* if it starts with a 0, it could be an octal number, a decimal in
6480 0.13 disguise, or a hexadecimal number, or a binary number.
6485 u holds the "number so far"
6486 shift the power of 2 of the base
6487 (hex == 4, octal == 3, binary == 1)
6488 overflowed was the number more than we can hold?
6490 Shift is used when we add a digit. It also serves as an "are
6491 we in octal/hex/binary?" indicator to disallow hex characters
6498 bool overflowed = FALSE;
6499 static NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
6500 static char* bases[5] = { "", "binary", "", "octal",
6502 static char* Bases[5] = { "", "Binary", "", "Octal",
6504 static char *maxima[5] = { "",
6505 "0b11111111111111111111111111111111",
6509 char *base, *Base, *max;
6515 } else if (s[1] == 'b') {
6519 /* check for a decimal in disguise */
6520 else if (strchr(".Ee", s[1]))
6522 /* so it must be octal */
6526 base = bases[shift];
6527 Base = Bases[shift];
6528 max = maxima[shift];
6530 /* read the rest of the number */
6532 /* x is used in the overflow test,
6533 b is the digit we're adding on. */
6538 /* if we don't mention it, we're done */
6547 /* 8 and 9 are not octal */
6550 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
6554 case '2': case '3': case '4':
6555 case '5': case '6': case '7':
6557 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
6561 b = *s++ & 15; /* ASCII digit -> value of digit */
6565 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
6566 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
6567 /* make sure they said 0x */
6572 /* Prepare to put the digit we have onto the end
6573 of the number so far. We check for overflows.
6578 x = u << shift; /* make room for the digit */
6580 if ((x >> shift) != u
6581 && !(PL_hints & HINT_NEW_BINARY)) {
6585 if (ckWARN_d(WARN_UNSAFE))
6586 Perl_warner(aTHX_ ((shift == 3) ?
6587 WARN_OCTAL : WARN_UNSAFE),
6588 "Integer overflow in %s number",
6591 u = x | b; /* add the digit to the end */
6594 n *= nvshift[shift];
6595 /* If an NV has not enough bits in its
6596 * mantissa to represent an UV this summing of
6597 * small low-order numbers is a waste of time
6598 * (because the NV cannot preserve the
6599 * low-order bits anyway): we could just
6600 * remember when did we overflow and in the
6601 * end just multiply n by the right
6609 /* if we get here, we had success: make a scalar value from
6616 if (ckWARN(WARN_UNSAFE) && n > 4294967295.0)
6617 Perl_warner(aTHX_ WARN_UNSAFE,
6618 "%s number > %s non-portable",
6625 if (ckWARN(WARN_UNSAFE) && u > 0xffffffff)
6626 Perl_warner(aTHX_ WARN_UNSAFE,
6627 "%s number > %s non-portable",
6632 if (PL_hints & HINT_NEW_BINARY)
6633 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
6638 handle decimal numbers.
6639 we're also sent here when we read a 0 as the first digit
6641 case '1': case '2': case '3': case '4': case '5':
6642 case '6': case '7': case '8': case '9': case '.':
6645 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
6648 /* read next group of digits and _ and copy into d */
6649 while (isDIGIT(*s) || *s == '_') {
6650 /* skip underscores, checking for misplaced ones
6654 dTHR; /* only for ckWARN */
6655 if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
6656 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
6660 /* check for end of fixed-length buffer */
6662 Perl_croak(aTHX_ number_too_long);
6663 /* if we're ok, copy the character */
6668 /* final misplaced underbar check */
6669 if (lastub && s - lastub != 3) {
6671 if (ckWARN(WARN_SYNTAX))
6672 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
6675 /* read a decimal portion if there is one. avoid
6676 3..5 being interpreted as the number 3. followed
6679 if (*s == '.' && s[1] != '.') {
6683 /* copy, ignoring underbars, until we run out of
6684 digits. Note: no misplaced underbar checks!
6686 for (; isDIGIT(*s) || *s == '_'; s++) {
6687 /* fixed length buffer check */
6689 Perl_croak(aTHX_ number_too_long);
6695 /* read exponent part, if present */
6696 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
6700 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
6701 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
6703 /* allow positive or negative exponent */
6704 if (*s == '+' || *s == '-')
6707 /* read digits of exponent (no underbars :-) */
6708 while (isDIGIT(*s)) {
6710 Perl_croak(aTHX_ number_too_long);
6715 /* terminate the string */
6718 /* make an sv from the string */
6721 value = Atof(PL_tokenbuf);
6724 See if we can make do with an integer value without loss of
6725 precision. We use I_V to cast to an int, because some
6726 compilers have issues. Then we try casting it back and see
6727 if it was the same. We only do this if we know we
6728 specifically read an integer.
6730 Note: if floatit is true, then we don't need to do the
6734 if (!floatit && (NV)tryiv == value)
6735 sv_setiv(sv, tryiv);
6737 sv_setnv(sv, value);
6738 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
6739 (PL_hints & HINT_NEW_INTEGER) )
6740 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
6741 (floatit ? "float" : "integer"),
6746 /* make the op for the constant and return */
6748 yylval.opval = newSVOP(OP_CONST, 0, sv);
6754 S_scan_formline(pTHX_ register char *s)
6759 SV *stuff = newSVpvn("",0);
6760 bool needargs = FALSE;
6763 if (*s == '.' || *s == '}') {
6765 #ifdef PERL_STRICT_CR
6766 for (t = s+1;*t == ' ' || *t == '\t'; t++) ;
6768 for (t = s+1;*t == ' ' || *t == '\t' || *t == '\r'; t++) ;
6770 if (*t == '\n' || t == PL_bufend)
6773 if (PL_in_eval && !PL_rsfp) {
6774 eol = strchr(s,'\n');
6779 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6781 for (t = s; t < eol; t++) {
6782 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
6784 goto enough; /* ~~ must be first line in formline */
6786 if (*t == '@' || *t == '^')
6789 sv_catpvn(stuff, s, eol-s);
6793 s = filter_gets(PL_linestr, PL_rsfp, 0);
6794 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
6795 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
6798 yyerror("Format not terminated");
6808 PL_lex_state = LEX_NORMAL;
6809 PL_nextval[PL_nexttoke].ival = 0;
6813 PL_lex_state = LEX_FORMLINE;
6814 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
6816 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
6820 SvREFCNT_dec(stuff);
6821 PL_lex_formbrack = 0;
6832 PL_cshlen = strlen(PL_cshname);
6837 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
6840 I32 oldsavestack_ix = PL_savestack_ix;
6841 CV* outsidecv = PL_compcv;
6845 assert(SvTYPE(PL_compcv) == SVt_PVCV);
6847 save_I32(&PL_subline);
6848 save_item(PL_subname);
6850 SAVESPTR(PL_curpad);
6851 SAVESPTR(PL_comppad);
6852 SAVESPTR(PL_comppad_name);
6853 SAVESPTR(PL_compcv);
6854 SAVEI32(PL_comppad_name_fill);
6855 SAVEI32(PL_min_intro_pending);
6856 SAVEI32(PL_max_intro_pending);
6857 SAVEI32(PL_pad_reset_pending);
6859 PL_compcv = (CV*)NEWSV(1104,0);
6860 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
6861 CvFLAGS(PL_compcv) |= flags;
6863 PL_comppad = newAV();
6864 av_push(PL_comppad, Nullsv);
6865 PL_curpad = AvARRAY(PL_comppad);
6866 PL_comppad_name = newAV();
6867 PL_comppad_name_fill = 0;
6868 PL_min_intro_pending = 0;
6870 PL_subline = PL_curcop->cop_line;
6872 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
6873 PL_curpad[0] = (SV*)newAV();
6874 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
6875 #endif /* USE_THREADS */
6877 comppadlist = newAV();
6878 AvREAL_off(comppadlist);
6879 av_store(comppadlist, 0, (SV*)PL_comppad_name);
6880 av_store(comppadlist, 1, (SV*)PL_comppad);
6882 CvPADLIST(PL_compcv) = comppadlist;
6883 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
6885 CvOWNER(PL_compcv) = 0;
6886 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
6887 MUTEX_INIT(CvMUTEXP(PL_compcv));
6888 #endif /* USE_THREADS */
6890 return oldsavestack_ix;
6894 Perl_yywarn(pTHX_ char *s)
6898 PL_in_eval |= EVAL_WARNONLY;
6900 PL_in_eval &= ~EVAL_WARNONLY;
6905 Perl_yyerror(pTHX_ char *s)
6909 char *context = NULL;
6913 if (!yychar || (yychar == ';' && !PL_rsfp))
6915 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
6916 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
6917 while (isSPACE(*PL_oldoldbufptr))
6919 context = PL_oldoldbufptr;
6920 contlen = PL_bufptr - PL_oldoldbufptr;
6922 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
6923 PL_oldbufptr != PL_bufptr) {
6924 while (isSPACE(*PL_oldbufptr))
6926 context = PL_oldbufptr;
6927 contlen = PL_bufptr - PL_oldbufptr;
6929 else if (yychar > 255)
6930 where = "next token ???";
6931 else if ((yychar & 127) == 127) {
6932 if (PL_lex_state == LEX_NORMAL ||
6933 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
6934 where = "at end of line";
6935 else if (PL_lex_inpat)
6936 where = "within pattern";
6938 where = "within string";
6941 SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
6943 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
6944 else if (isPRINT_LC(yychar))
6945 Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
6947 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
6948 where = SvPVX(where_sv);
6950 msg = sv_2mortal(newSVpv(s, 0));
6952 Perl_sv_catpvf(aTHX_ msg, " at %_ line %" PERL_PRId64 ", ",
6953 GvSV(PL_curcop->cop_filegv), (IV)PL_curcop->cop_line);
6955 Perl_sv_catpvf(aTHX_ msg, " at %_ line %ld, ",
6956 GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line);
6959 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
6961 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
6962 if (PL_multi_start < PL_multi_end && (U32)(PL_curcop->cop_line - PL_multi_end) <= 1) {
6964 Perl_sv_catpvf(aTHX_ msg,
6965 " (Might be a runaway multi-line %c%c string starting on line %" PERL_\
6967 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
6969 Perl_sv_catpvf(aTHX_ msg,
6970 " (Might be a runaway multi-line %c%c string starting on line %ld)\n",
6971 (int)PL_multi_open,(int)PL_multi_close,(long)PL_multi_start);
6975 if (PL_in_eval & EVAL_WARNONLY)
6976 Perl_warn(aTHX_ "%_", msg);
6977 else if (PL_in_eval)
6978 sv_catsv(ERRSV, msg);
6980 PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
6981 if (++PL_error_count >= 10)
6982 Perl_croak(aTHX_ "%_ has too many errors.\n", GvSV(PL_curcop->cop_filegv));
6984 PL_in_my_stash = Nullhv;
6996 * Restore a source filter.
7000 restore_rsfp(pTHXo_ void *f)
7002 PerlIO *fp = (PerlIO*)f;
7004 if (PL_rsfp == PerlIO_stdin())
7005 PerlIO_clearerr(PL_rsfp);
7006 else if (PL_rsfp && (PL_rsfp != fp))
7007 PerlIO_close(PL_rsfp);
7013 * Restores the state of PL_expect when the lexing that begun with a
7014 * start_lex() call has ended.
7018 restore_expect(pTHXo_ void *e)
7020 /* a safe way to store a small integer in a pointer */
7021 PL_expect = (expectation)((char *)e - PL_tokenbuf);
7025 * restore_lex_expect
7026 * Restores the state of PL_lex_expect when the lexing that begun with a
7027 * start_lex() call has ended.
7031 restore_lex_expect(pTHXo_ void *e)
7033 /* a safe way to store a small integer in a pointer */
7034 PL_lex_expect = (expectation)((char *)e - PL_tokenbuf);