3 * Copyright (c) 1991-2000, 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);
32 #define XFAKEBRACK 128
35 /*#define UTF (SvUTF8(PL_linestr) && !(PL_hints & HINT_BYTE))*/
36 #define UTF (PL_hints & HINT_UTF8)
38 /* In variables name $^X, these are the legal values for X.
39 * 1999-02-27 mjd-perl-patch@plover.com */
40 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
42 /* LEX_* are values for PL_lex_state, the state of the lexer.
43 * They are arranged oddly so that the guard on the switch statement
44 * can get by with a single comparison (if the compiler is smart enough).
47 /* #define LEX_NOTPARSING 11 is done in perl.h. */
50 #define LEX_INTERPNORMAL 9
51 #define LEX_INTERPCASEMOD 8
52 #define LEX_INTERPPUSH 7
53 #define LEX_INTERPSTART 6
54 #define LEX_INTERPEND 5
55 #define LEX_INTERPENDMAYBE 4
56 #define LEX_INTERPCONCAT 3
57 #define LEX_INTERPCONST 2
58 #define LEX_FORMLINE 1
59 #define LEX_KNOWNEXT 0
61 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
63 # include <unistd.h> /* Needed for execv() */
72 YYSTYPE* yylval_pointer = NULL;
73 int* yychar_pointer = NULL;
76 # define yylval (*yylval_pointer)
77 # define yychar (*yychar_pointer)
78 # define PERL_YYLEX_PARAM yylval_pointer,yychar_pointer
80 # define yylex() Perl_yylex(aTHX_ yylval_pointer, yychar_pointer)
85 /* CLINE is a macro that ensures PL_copline has a sane value */
90 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
93 * Convenience functions to return different tokens and prime the
94 * lexer for the next token. They all take an argument.
96 * TOKEN : generic token (used for '(', DOLSHARP, etc)
97 * OPERATOR : generic operator
98 * AOPERATOR : assignment operator
99 * PREBLOCK : beginning the block after an if, while, foreach, ...
100 * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
101 * PREREF : *EXPR where EXPR is not a simple identifier
102 * TERM : expression term
103 * LOOPX : loop exiting command (goto, last, dump, etc)
104 * FTST : file test operator
105 * FUN0 : zero-argument function
106 * FUN1 : not used, except for not, which isn't a UNIOP
107 * BOop : bitwise or or xor
109 * SHop : shift operator
110 * PWop : power operator
111 * PMop : pattern-matching operator
112 * Aop : addition-level operator
113 * Mop : multiplication-level operator
114 * Eop : equality-testing operator
115 * Rop : relational operator <= != gt
117 * Also see LOP and lop() below.
120 #define TOKEN(retval) return (PL_bufptr = s,(int)retval)
121 #define OPERATOR(retval) return (PL_expect = XTERM,PL_bufptr = s,(int)retval)
122 #define AOPERATOR(retval) return ao((PL_expect = XTERM,PL_bufptr = s,(int)retval))
123 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s,(int)retval)
124 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval)
125 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s,(int)retval)
126 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR,PL_bufptr = s,(int)retval)
127 #define LOOPX(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX)
128 #define FTST(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)UNIOP)
129 #define FUN0(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0)
130 #define FUN1(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1)
131 #define BOop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITOROP))
132 #define BAop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP))
133 #define SHop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP))
134 #define PWop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)POWOP))
135 #define PMop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP)
136 #define Aop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)ADDOP))
137 #define Mop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MULOP))
138 #define Eop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)EQOP)
139 #define Rop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)RELOP)
141 /* This bit of chicanery makes a unary function followed by
142 * a parenthesis into a function with one argument, highest precedence.
144 #define UNI(f) return(yylval.ival = f, \
147 PL_last_uni = PL_oldbufptr, \
148 PL_last_lop_op = f, \
149 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
151 #define UNIBRACK(f) return(yylval.ival = f, \
153 PL_last_uni = PL_oldbufptr, \
154 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
156 /* grandfather return to old style */
157 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
162 * This subroutine detects &&= and ||= and turns an ANDAND or OROR
163 * into an OP_ANDASSIGN or OP_ORASSIGN
167 S_ao(pTHX_ int toketype)
169 if (*PL_bufptr == '=') {
171 if (toketype == ANDAND)
172 yylval.ival = OP_ANDASSIGN;
173 else if (toketype == OROR)
174 yylval.ival = OP_ORASSIGN;
182 * When Perl expects an operator and finds something else, no_op
183 * prints the warning. It always prints "<something> found where
184 * operator expected. It prints "Missing semicolon on previous line?"
185 * if the surprise occurs at the start of the line. "do you need to
186 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
187 * where the compiler doesn't know if foo is a method call or a function.
188 * It prints "Missing operator before end of line" if there's nothing
189 * after the missing operator, or "... before <...>" if there is something
190 * after the missing operator.
194 S_no_op(pTHX_ char *what, char *s)
196 char *oldbp = PL_bufptr;
197 bool is_first = (PL_oldbufptr == PL_linestart);
205 yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
207 Perl_warn(aTHX_ "\t(Missing semicolon on previous line?)\n");
208 else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
210 for (t = PL_oldoldbufptr; *t && (isALNUM_lazy_if(t,UTF) || *t == ':'); t++) ;
211 if (t < PL_bufptr && isSPACE(*t))
212 Perl_warn(aTHX_ "\t(Do you need to predeclare %.*s?)\n",
213 t - PL_oldoldbufptr, PL_oldoldbufptr);
216 Perl_warn(aTHX_ "\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
222 * Complain about missing quote/regexp/heredoc terminator.
223 * If it's called with (char *)NULL then it cauterizes the line buffer.
224 * If we're in a delimited string and the delimiter is a control
225 * character, it's reformatted into a two-char sequence like ^C.
230 S_missingterm(pTHX_ char *s)
235 char *nl = strrchr(s,'\n');
241 iscntrl(PL_multi_close)
243 PL_multi_close < 32 || PL_multi_close == 127
247 tmpbuf[1] = toCTRL(PL_multi_close);
253 *tmpbuf = PL_multi_close;
257 q = strchr(s,'"') ? '\'' : '"';
258 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
266 Perl_deprecate(pTHX_ char *s)
269 if (ckWARN(WARN_DEPRECATED))
270 Perl_warner(aTHX_ WARN_DEPRECATED, "Use of %s is deprecated", s);
275 * Deprecate a comma-less variable list.
281 deprecate("comma-less variable list");
285 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
286 * utf16-to-utf8-reversed.
289 #ifdef PERL_CR_FILTER
293 register char *s = SvPVX(sv);
294 register char *e = s + SvCUR(sv);
295 /* outer loop optimized to do nothing if there are no CR-LFs */
297 if (*s++ == '\r' && *s == '\n') {
298 /* hit a CR-LF, need to copy the rest */
299 register char *d = s - 1;
302 if (*s == '\r' && s[1] == '\n')
313 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
315 I32 count = FILTER_READ(idx+1, sv, maxlen);
316 if (count > 0 && !maxlen)
323 S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
325 I32 count = FILTER_READ(idx+1, sv, maxlen);
329 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
330 tend = utf16_to_utf8((U16*)SvPVX(sv), tmps, SvCUR(sv));
331 sv_usepvn(sv, (char*)tmps, tend - tmps);
338 S_utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
340 I32 count = FILTER_READ(idx+1, sv, maxlen);
344 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
345 tend = utf16_to_utf8_reversed((U16*)SvPVX(sv), tmps, SvCUR(sv));
346 sv_usepvn(sv, (char*)tmps, tend - tmps);
354 * Initialize variables. Uses the Perl save_stack to save its state (for
355 * recursive calls to the parser).
359 Perl_lex_start(pTHX_ SV *line)
365 SAVEI32(PL_lex_dojoin);
366 SAVEI32(PL_lex_brackets);
367 SAVEI32(PL_lex_casemods);
368 SAVEI32(PL_lex_starts);
369 SAVEI32(PL_lex_state);
370 SAVEVPTR(PL_lex_inpat);
371 SAVEI32(PL_lex_inwhat);
372 if (PL_lex_state == LEX_KNOWNEXT) {
373 I32 toke = PL_nexttoke;
374 while (--toke >= 0) {
375 SAVEI32(PL_nexttype[toke]);
376 SAVEVPTR(PL_nextval[toke]);
378 SAVEI32(PL_nexttoke);
381 SAVECOPLINE(PL_curcop);
384 SAVEPPTR(PL_oldbufptr);
385 SAVEPPTR(PL_oldoldbufptr);
386 SAVEPPTR(PL_linestart);
387 SAVESPTR(PL_linestr);
388 SAVEPPTR(PL_lex_brackstack);
389 SAVEPPTR(PL_lex_casestack);
390 SAVEDESTRUCTOR_X(restore_rsfp, PL_rsfp);
391 SAVESPTR(PL_lex_stuff);
392 SAVEI32(PL_lex_defer);
393 SAVEI32(PL_sublex_info.sub_inwhat);
394 SAVESPTR(PL_lex_repl);
396 SAVEINT(PL_lex_expect);
398 PL_lex_state = LEX_NORMAL;
402 New(899, PL_lex_brackstack, 120, char);
403 New(899, PL_lex_casestack, 12, char);
404 SAVEFREEPV(PL_lex_brackstack);
405 SAVEFREEPV(PL_lex_casestack);
407 *PL_lex_casestack = '\0';
410 PL_lex_stuff = Nullsv;
411 PL_lex_repl = Nullsv;
414 PL_sublex_info.sub_inwhat = 0;
416 if (SvREADONLY(PL_linestr))
417 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
418 s = SvPV(PL_linestr, len);
419 if (len && s[len-1] != ';') {
420 if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
421 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
422 sv_catpvn(PL_linestr, "\n;", 2);
424 SvTEMP_off(PL_linestr);
425 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
426 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
428 PL_rs = newSVpvn("\n", 1);
434 * Finalizer for lexing operations. Must be called when the parser is
435 * done with the lexer.
441 PL_doextract = FALSE;
446 * This subroutine has nothing to do with tilting, whether at windmills
447 * or pinball tables. Its name is short for "increment line". It
448 * increments the current line number in CopLINE(PL_curcop) and checks
449 * to see whether the line starts with a comment of the form
450 * # line 500 "foo.pm"
451 * If so, it sets the current line number and file to the values in the comment.
455 S_incline(pTHX_ char *s)
463 CopLINE_inc(PL_curcop);
466 while (*s == ' ' || *s == '\t') s++;
467 if (strnEQ(s, "line", 4))
471 if (*s == ' ' || *s == '\t')
475 while (*s == ' ' || *s == '\t') s++;
481 while (*s == ' ' || *s == '\t')
483 if (*s == '"' && (t = strchr(s+1, '"'))) {
488 for (t = s; !isSPACE(*t); t++) ;
491 while (*e == ' ' || *e == '\t' || *e == '\r' || *e == '\f')
493 if (*e != '\n' && *e != '\0')
494 return; /* false alarm */
499 CopFILE_set(PL_curcop, s);
501 CopLINE_set(PL_curcop, atoi(n)-1);
506 * Called to gobble the appropriate amount and type of whitespace.
507 * Skips comments as well.
511 S_skipspace(pTHX_ register char *s)
514 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
515 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
521 SSize_t oldprevlen, oldoldprevlen;
522 SSize_t oldloplen, oldunilen;
523 while (s < PL_bufend && isSPACE(*s)) {
524 if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
529 if (s < PL_bufend && *s == '#') {
530 while (s < PL_bufend && *s != '\n')
534 if (PL_in_eval && !PL_rsfp) {
541 /* only continue to recharge the buffer if we're at the end
542 * of the buffer, we're not reading from a source filter, and
543 * we're in normal lexing mode
545 if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat ||
546 PL_lex_state == LEX_FORMLINE)
549 /* try to recharge the buffer */
550 if ((s = filter_gets(PL_linestr, PL_rsfp,
551 (prevlen = SvCUR(PL_linestr)))) == Nullch)
553 /* end of file. Add on the -p or -n magic */
554 if (PL_minus_n || PL_minus_p) {
555 sv_setpv(PL_linestr,PL_minus_p ?
556 ";}continue{print or die qq(-p destination: $!\\n)" :
558 sv_catpv(PL_linestr,";}");
559 PL_minus_n = PL_minus_p = 0;
562 sv_setpv(PL_linestr,";");
564 /* reset variables for next time we lex */
565 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
567 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
569 /* Close the filehandle. Could be from -P preprocessor,
570 * STDIN, or a regular file. If we were reading code from
571 * STDIN (because the commandline held no -e or filename)
572 * then we don't close it, we reset it so the code can
573 * read from STDIN too.
576 if (PL_preprocess && !PL_in_eval)
577 (void)PerlProc_pclose(PL_rsfp);
578 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
579 PerlIO_clearerr(PL_rsfp);
581 (void)PerlIO_close(PL_rsfp);
586 /* not at end of file, so we only read another line */
587 /* make corresponding updates to old pointers, for yyerror() */
588 oldprevlen = PL_oldbufptr - PL_bufend;
589 oldoldprevlen = PL_oldoldbufptr - PL_bufend;
591 oldunilen = PL_last_uni - PL_bufend;
593 oldloplen = PL_last_lop - PL_bufend;
594 PL_linestart = PL_bufptr = s + prevlen;
595 PL_bufend = s + SvCUR(PL_linestr);
597 PL_oldbufptr = s + oldprevlen;
598 PL_oldoldbufptr = s + oldoldprevlen;
600 PL_last_uni = s + oldunilen;
602 PL_last_lop = s + oldloplen;
605 /* debugger active and we're not compiling the debugger code,
606 * so store the line into the debugger's array of lines
608 if (PERLDB_LINE && PL_curstash != PL_debstash) {
609 SV *sv = NEWSV(85,0);
611 sv_upgrade(sv, SVt_PVMG);
612 sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
613 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
620 * Check the unary operators to ensure there's no ambiguity in how they're
621 * used. An ambiguous piece of code would be:
623 * This doesn't mean rand() + 5. Because rand() is a unary operator,
624 * the +5 is its argument.
634 if (PL_oldoldbufptr != PL_last_uni)
636 while (isSPACE(*PL_last_uni))
638 for (s = PL_last_uni; isALNUM_lazy_if(s,UTF) || *s == '-'; s++) ;
639 if ((t = strchr(s, '(')) && t < PL_bufptr)
641 if (ckWARN_d(WARN_AMBIGUOUS)){
644 Perl_warner(aTHX_ WARN_AMBIGUOUS,
645 "Warning: Use of \"%s\" without parens is ambiguous",
651 /* workaround to replace the UNI() macro with a function. Only the
652 * hints/uts.sh file mentions this. Other comments elsewhere in the
653 * source indicate Microport Unix might need it too.
659 #define UNI(f) return uni(f,s)
662 S_uni(pTHX_ I32 f, char *s)
667 PL_last_uni = PL_oldbufptr;
678 #endif /* CRIPPLED_CC */
681 * LOP : macro to build a list operator. Its behaviour has been replaced
682 * with a subroutine, S_lop() for which LOP is just another name.
685 #define LOP(f,x) return lop(f,x,s)
689 * Build a list operator (or something that might be one). The rules:
690 * - if we have a next token, then it's a list operator [why?]
691 * - if the next thing is an opening paren, then it's a function
692 * - else it's a list operator
696 S_lop(pTHX_ I32 f, int x, char *s)
703 PL_last_lop = PL_oldbufptr;
718 * When the lexer realizes it knows the next token (for instance,
719 * it is reordering tokens for the parser) then it can call S_force_next
720 * to know what token to return the next time the lexer is called. Caller
721 * will need to set PL_nextval[], and possibly PL_expect to ensure the lexer
722 * handles the token correctly.
726 S_force_next(pTHX_ I32 type)
728 PL_nexttype[PL_nexttoke] = type;
730 if (PL_lex_state != LEX_KNOWNEXT) {
731 PL_lex_defer = PL_lex_state;
732 PL_lex_expect = PL_expect;
733 PL_lex_state = LEX_KNOWNEXT;
739 * When the lexer knows the next thing is a word (for instance, it has
740 * just seen -> and it knows that the next char is a word char, then
741 * it calls S_force_word to stick the next word into the PL_next lookahead.
744 * char *start : buffer position (must be within PL_linestr)
745 * int token : PL_next will be this type of bare word (e.g., METHOD,WORD)
746 * int check_keyword : if true, Perl checks to make sure the word isn't
747 * a keyword (do this if the word is a label, e.g. goto FOO)
748 * int allow_pack : if true, : characters will also be allowed (require,
750 * int allow_initial_tick : used by the "sub" lexer only.
754 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
759 start = skipspace(start);
761 if (isIDFIRST_lazy_if(s,UTF) ||
762 (allow_pack && *s == ':') ||
763 (allow_initial_tick && *s == '\'') )
765 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
766 if (check_keyword && keyword(PL_tokenbuf, len))
768 if (token == METHOD) {
773 PL_expect = XOPERATOR;
776 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(PL_tokenbuf,0));
777 PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
785 * Called when the lexer wants $foo *foo &foo etc, but the program
786 * text only contains the "foo" portion. The first argument is a pointer
787 * to the "foo", and the second argument is the type symbol to prefix.
788 * Forces the next token to be a "WORD".
789 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
793 S_force_ident(pTHX_ register char *s, int kind)
796 OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
797 PL_nextval[PL_nexttoke].opval = o;
800 dTHR; /* just for in_eval */
801 o->op_private = OPpCONST_ENTERED;
802 /* XXX see note in pp_entereval() for why we forgo typo
803 warnings if the symbol must be introduced in an eval.
805 gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
806 kind == '$' ? SVt_PV :
807 kind == '@' ? SVt_PVAV :
808 kind == '%' ? SVt_PVHV :
817 * Forces the next token to be a version number.
821 S_force_version(pTHX_ char *s)
823 OP *version = Nullop;
832 for (; isDIGIT(*d) || *d == '_' || *d == '.'; d++);
833 if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
836 /* real VERSION number -- GBARR */
837 version = yylval.opval;
838 ver = cSVOPx(version)->op_sv;
839 if (SvPOK(ver) && !SvNIOK(ver)) {
840 SvUPGRADE(ver, SVt_PVIV);
841 SvIOKp_on(ver); /* hint that it is a version */
846 /* NOTE: The parser sees the package name and the VERSION swapped */
847 PL_nextval[PL_nexttoke].opval = version;
855 * Tokenize a quoted string passed in as an SV. It finds the next
856 * chunk, up to end of string or a backslash. It may make a new
857 * SV containing that chunk (if HINT_NEW_STRING is on). It also
862 S_tokeq(pTHX_ SV *sv)
873 s = SvPV_force(sv, len);
877 while (s < send && *s != '\\')
882 if ( PL_hints & HINT_NEW_STRING )
883 pv = sv_2mortal(newSVpvn(SvPVX(pv), len));
886 if (s + 1 < send && (s[1] == '\\'))
887 s++; /* all that, just for this */
892 SvCUR_set(sv, d - SvPVX(sv));
894 if ( PL_hints & HINT_NEW_STRING )
895 return new_constant(NULL, 0, "q", sv, pv, "q");
900 * Now come three functions related to double-quote context,
901 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
902 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
903 * interact with PL_lex_state, and create fake ( ... ) argument lists
904 * to handle functions and concatenation.
905 * They assume that whoever calls them will be setting up a fake
906 * join call, because each subthing puts a ',' after it. This lets
909 * join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
911 * (I'm not sure whether the spurious commas at the end of lcfirst's
912 * arguments and join's arguments are created or not).
917 * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST).
919 * Pattern matching will set PL_lex_op to the pattern-matching op to
920 * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise).
922 * OP_CONST and OP_READLINE are easy--just make the new op and return.
924 * Everything else becomes a FUNC.
926 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
927 * had an OP_CONST or OP_READLINE). This just sets us up for a
928 * call to S_sublex_push().
934 register I32 op_type = yylval.ival;
936 if (op_type == OP_NULL) {
937 yylval.opval = PL_lex_op;
941 if (op_type == OP_CONST || op_type == OP_READLINE) {
942 SV *sv = tokeq(PL_lex_stuff);
944 if (SvTYPE(sv) == SVt_PVIV) {
945 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
951 nsv = newSVpvn(p, len);
955 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
956 PL_lex_stuff = Nullsv;
960 PL_sublex_info.super_state = PL_lex_state;
961 PL_sublex_info.sub_inwhat = op_type;
962 PL_sublex_info.sub_op = PL_lex_op;
963 PL_lex_state = LEX_INTERPPUSH;
967 yylval.opval = PL_lex_op;
977 * Create a new scope to save the lexing state. The scope will be
978 * ended in S_sublex_done. Returns a '(', starting the function arguments
979 * to the uc, lc, etc. found before.
980 * Sets PL_lex_state to LEX_INTERPCONCAT.
989 PL_lex_state = PL_sublex_info.super_state;
990 SAVEI32(PL_lex_dojoin);
991 SAVEI32(PL_lex_brackets);
992 SAVEI32(PL_lex_casemods);
993 SAVEI32(PL_lex_starts);
994 SAVEI32(PL_lex_state);
995 SAVEVPTR(PL_lex_inpat);
996 SAVEI32(PL_lex_inwhat);
997 SAVECOPLINE(PL_curcop);
999 SAVEPPTR(PL_oldbufptr);
1000 SAVEPPTR(PL_oldoldbufptr);
1001 SAVEPPTR(PL_linestart);
1002 SAVESPTR(PL_linestr);
1003 SAVEPPTR(PL_lex_brackstack);
1004 SAVEPPTR(PL_lex_casestack);
1006 PL_linestr = PL_lex_stuff;
1007 PL_lex_stuff = Nullsv;
1009 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
1010 = SvPVX(PL_linestr);
1011 PL_bufend += SvCUR(PL_linestr);
1012 SAVEFREESV(PL_linestr);
1014 PL_lex_dojoin = FALSE;
1015 PL_lex_brackets = 0;
1016 New(899, PL_lex_brackstack, 120, char);
1017 New(899, PL_lex_casestack, 12, char);
1018 SAVEFREEPV(PL_lex_brackstack);
1019 SAVEFREEPV(PL_lex_casestack);
1020 PL_lex_casemods = 0;
1021 *PL_lex_casestack = '\0';
1023 PL_lex_state = LEX_INTERPCONCAT;
1024 CopLINE_set(PL_curcop, PL_multi_start);
1026 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1027 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1028 PL_lex_inpat = PL_sublex_info.sub_op;
1030 PL_lex_inpat = Nullop;
1037 * Restores lexer state after a S_sublex_push.
1043 if (!PL_lex_starts++) {
1044 PL_expect = XOPERATOR;
1045 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpvn("",0));
1049 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
1050 PL_lex_state = LEX_INTERPCASEMOD;
1054 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1055 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1056 PL_linestr = PL_lex_repl;
1058 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1059 PL_bufend += SvCUR(PL_linestr);
1060 SAVEFREESV(PL_linestr);
1061 PL_lex_dojoin = FALSE;
1062 PL_lex_brackets = 0;
1063 PL_lex_casemods = 0;
1064 *PL_lex_casestack = '\0';
1066 if (SvEVALED(PL_lex_repl)) {
1067 PL_lex_state = LEX_INTERPNORMAL;
1069 /* we don't clear PL_lex_repl here, so that we can check later
1070 whether this is an evalled subst; that means we rely on the
1071 logic to ensure sublex_done() is called again only via the
1072 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1075 PL_lex_state = LEX_INTERPCONCAT;
1076 PL_lex_repl = Nullsv;
1082 PL_bufend = SvPVX(PL_linestr);
1083 PL_bufend += SvCUR(PL_linestr);
1084 PL_expect = XOPERATOR;
1085 PL_sublex_info.sub_inwhat = 0;
1093 Extracts a pattern, double-quoted string, or transliteration. This
1096 It looks at lex_inwhat and PL_lex_inpat to find out whether it's
1097 processing a pattern (PL_lex_inpat is true), a transliteration
1098 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
1100 Returns a pointer to the character scanned up to. Iff this is
1101 advanced from the start pointer supplied (ie if anything was
1102 successfully parsed), will leave an OP for the substring scanned
1103 in yylval. Caller must intuit reason for not parsing further
1104 by looking at the next characters herself.
1108 double-quoted style: \r and \n
1109 regexp special ones: \D \s
1111 backrefs: \1 (deprecated in substitution replacements)
1112 case and quoting: \U \Q \E
1113 stops on @ and $, but not for $ as tail anchor
1115 In transliterations:
1116 characters are VERY literal, except for - not at the start or end
1117 of the string, which indicates a range. scan_const expands the
1118 range to the full set of intermediate characters.
1120 In double-quoted strings:
1122 double-quoted style: \r and \n
1124 backrefs: \1 (deprecated)
1125 case and quoting: \U \Q \E
1128 scan_const does *not* construct ops to handle interpolated strings.
1129 It stops processing as soon as it finds an embedded $ or @ variable
1130 and leaves it to the caller to work out what's going on.
1132 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
1134 $ in pattern could be $foo or could be tail anchor. Assumption:
1135 it's a tail anchor if $ is the last thing in the string, or if it's
1136 followed by one of ")| \n\t"
1138 \1 (backreferences) are turned into $1
1140 The structure of the code is
1141 while (there's a character to process) {
1142 handle transliteration ranges
1143 skip regexp comments
1144 skip # initiated comments in //x patterns
1145 check for embedded @foo
1146 check for embedded scalars
1148 leave intact backslashes from leave (below)
1149 deprecate \1 in strings and sub replacements
1150 handle string-changing backslashes \l \U \Q \E, etc.
1151 switch (what was escaped) {
1152 handle - in a transliteration (becomes a literal -)
1153 handle \132 octal characters
1154 handle 0x15 hex characters
1155 handle \cV (control V)
1156 handle printf backslashes (\f, \r, \n, etc)
1158 } (end if backslash)
1159 } (end while character to read)
1164 S_scan_const(pTHX_ char *start)
1166 register char *send = PL_bufend; /* end of the constant */
1167 SV *sv = NEWSV(93, send - start); /* sv for the constant */
1168 register char *s = start; /* start of the constant */
1169 register char *d = SvPVX(sv); /* destination for copies */
1170 bool dorange = FALSE; /* are we in a translit range? */
1171 bool has_utf = FALSE; /* embedded \x{} */
1175 I32 utf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op)
1176 ? (PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
1178 I32 thisutf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op)
1179 ? (PL_sublex_info.sub_op->op_private & (PL_lex_repl ?
1180 OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF))
1182 const char *leaveit = /* set of acceptably-backslashed characters */
1184 ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
1187 while (s < send || dorange) {
1188 /* get transliterations out of the way (they're most literal) */
1189 if (PL_lex_inwhat == OP_TRANS) {
1190 /* expand a range A-Z to the full set of characters. AIE! */
1192 I32 i; /* current expanded character */
1193 I32 min; /* first character in range */
1194 I32 max; /* last character in range */
1196 i = d - SvPVX(sv); /* remember current offset */
1197 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
1198 d = SvPVX(sv) + i; /* refresh d after realloc */
1199 d -= 2; /* eat the first char and the - */
1201 min = (U8)*d; /* first char in range */
1202 max = (U8)d[1]; /* last char in range */
1205 if ((isLOWER(min) && isLOWER(max)) ||
1206 (isUPPER(min) && isUPPER(max))) {
1208 for (i = min; i <= max; i++)
1212 for (i = min; i <= max; i++)
1219 for (i = min; i <= max; i++)
1222 /* mark the range as done, and continue */
1227 /* range begins (ignore - as first or last char) */
1228 else if (*s == '-' && s+1 < send && s != start) {
1230 *d++ = (char)0xff; /* use illegal utf8 byte--see pmtrans */
1239 /* if we get here, we're not doing a transliteration */
1241 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
1242 except for the last char, which will be done separately. */
1243 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
1245 while (s < send && *s != ')')
1247 } else if (s[2] == '{'
1248 || s[2] == 'p' && s[3] == '{') { /* This should march regcomp.c */
1250 char *regparse = s + (s[2] == '{' ? 3 : 4);
1253 while (count && (c = *regparse)) {
1254 if (c == '\\' && regparse[1])
1262 if (*regparse != ')') {
1263 regparse--; /* Leave one char for continuation. */
1264 yyerror("Sequence (?{...}) not terminated or not {}-balanced");
1266 while (s < regparse)
1271 /* likewise skip #-initiated comments in //x patterns */
1272 else if (*s == '#' && PL_lex_inpat &&
1273 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
1274 while (s+1 < send && *s != '\n')
1278 /* check for embedded arrays (@foo, @:foo, @'foo, @{foo}, @$foo) */
1279 else if (*s == '@' && s[1]
1280 && (isALNUM_lazy_if(s+1,UTF) || strchr(":'{$", s[1])))
1283 /* check for embedded scalars. only stop if we're sure it's a
1286 else if (*s == '$') {
1287 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
1289 if (s + 1 < send && !strchr("()| \n\t", s[1]))
1290 break; /* in regexp, $ might be tail anchor */
1293 /* (now in tr/// code again) */
1295 if (*s & 0x80 && thisutf) {
1296 (void)utf8_to_uv((U8*)s, &len);
1298 /* illegal UTF8, make it valid */
1299 char *old_pvx = SvPVX(sv);
1300 /* need space for one extra char (NOTE: SvCUR() not set here) */
1301 d = SvGROW(sv, SvLEN(sv) + 1) + (d - old_pvx);
1302 d = (char*)uv_to_utf8((U8*)d, (U8)*s++);
1313 if (*s == '\\' && s+1 < send) {
1316 /* some backslashes we leave behind */
1317 if (*leaveit && *s && strchr(leaveit, *s)) {
1323 /* deprecate \1 in strings and substitution replacements */
1324 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1325 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1327 dTHR; /* only for ckWARN */
1328 if (ckWARN(WARN_SYNTAX))
1329 Perl_warner(aTHX_ WARN_SYNTAX, "\\%c better written as $%c", *s, *s);
1334 /* string-change backslash escapes */
1335 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1340 /* if we get here, it's either a quoted -, or a digit */
1343 /* quoted - in transliterations */
1345 if (PL_lex_inwhat == OP_TRANS) {
1353 if (ckWARN(WARN_MISC) && isALPHA(*s))
1354 Perl_warner(aTHX_ WARN_MISC,
1355 "Unrecognized escape \\%c passed through",
1357 /* default action is to copy the quoted character */
1362 /* \132 indicates an octal constant */
1363 case '0': case '1': case '2': case '3':
1364 case '4': case '5': case '6': case '7':
1365 uv = (UV)scan_oct(s, 3, &len);
1367 goto NUM_ESCAPE_INSERT;
1369 /* \x24 indicates a hex constant */
1373 char* e = strchr(s, '}');
1375 yyerror("Missing right brace on \\x{}");
1378 uv = (UV)scan_hex(s + 1, e - s - 1, &len);
1382 uv = (UV)scan_hex(s, 2, &len);
1387 /* Insert oct or hex escaped character.
1388 * There will always enough room in sv since such escapes will
1389 * be longer than any utf8 sequence they can end up as
1392 if (!thisutf && !has_utf && uv > 255) {
1393 /* might need to recode whatever we have accumulated so far
1394 * if it contains any hibit chars
1398 for (c = SvPVX(sv); c < d; c++) {
1403 char *old_pvx = SvPVX(sv);
1405 d = SvGROW(sv, SvCUR(sv) + hicount + 1) + (d - old_pvx);
1414 uv_to_utf8((U8*)dst, (U8)*src--);
1424 if (thisutf || uv > 255) {
1425 d = (char*)uv_to_utf8((U8*)d, uv);
1437 /* \N{latin small letter a} is a named character */
1441 char* e = strchr(s, '}');
1450 yyerror("Missing right brace on \\N{}");
1454 res = newSVpvn(s + 1, e - s - 1);
1455 res = new_constant( Nullch, 0, "charnames",
1456 res, Nullsv, "\\N{...}" );
1457 str = SvPV(res,len);
1458 if (len > e - s + 4) {
1459 char *odest = SvPVX(sv);
1461 SvGROW(sv, (SvCUR(sv) + len - (e - s + 4)));
1462 d = SvPVX(sv) + (d - odest);
1464 Copy(str, d, len, char);
1471 yyerror("Missing braces on \\N{}");
1474 /* \c is a control character */
1488 /* printf-style backslashes, formfeeds, newlines, etc */
1506 *d++ = '\047'; /* CP 1047 */
1509 *d++ = '\057'; /* CP 1047 */
1523 } /* end if (backslash) */
1526 } /* while loop to process each character */
1528 /* terminate the string and set up the sv */
1530 SvCUR_set(sv, d - SvPVX(sv));
1535 /* shrink the sv if we allocated more than we used */
1536 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1537 SvLEN_set(sv, SvCUR(sv) + 1);
1538 Renew(SvPVX(sv), SvLEN(sv), char);
1541 /* return the substring (via yylval) only if we parsed anything */
1542 if (s > PL_bufptr) {
1543 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1544 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1546 ( PL_lex_inwhat == OP_TRANS
1548 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1551 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1558 * Returns TRUE if there's more to the expression (e.g., a subscript),
1561 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
1563 * ->[ and ->{ return TRUE
1564 * { and [ outside a pattern are always subscripts, so return TRUE
1565 * if we're outside a pattern and it's not { or [, then return FALSE
1566 * if we're in a pattern and the first char is a {
1567 * {4,5} (any digits around the comma) returns FALSE
1568 * if we're in a pattern and the first char is a [
1570 * [SOMETHING] has a funky algorithm to decide whether it's a
1571 * character class or not. It has to deal with things like
1572 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
1573 * anything else returns TRUE
1576 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1579 S_intuit_more(pTHX_ register char *s)
1581 if (PL_lex_brackets)
1583 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1585 if (*s != '{' && *s != '[')
1590 /* In a pattern, so maybe we have {n,m}. */
1607 /* On the other hand, maybe we have a character class */
1610 if (*s == ']' || *s == '^')
1613 /* this is terrifying, and it works */
1614 int weight = 2; /* let's weigh the evidence */
1616 unsigned char un_char = 255, last_un_char;
1617 char *send = strchr(s,']');
1618 char tmpbuf[sizeof PL_tokenbuf * 4];
1620 if (!send) /* has to be an expression */
1623 Zero(seen,256,char);
1626 else if (isDIGIT(*s)) {
1628 if (isDIGIT(s[1]) && s[2] == ']')
1634 for (; s < send; s++) {
1635 last_un_char = un_char;
1636 un_char = (unsigned char)*s;
1641 weight -= seen[un_char] * 10;
1642 if (isALNUM_lazy_if(s+1,UTF)) {
1643 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1644 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1649 else if (*s == '$' && s[1] &&
1650 strchr("[#!%*<>()-=",s[1])) {
1651 if (/*{*/ strchr("])} =",s[2]))
1660 if (strchr("wds]",s[1]))
1662 else if (seen['\''] || seen['"'])
1664 else if (strchr("rnftbxcav",s[1]))
1666 else if (isDIGIT(s[1])) {
1668 while (s[1] && isDIGIT(s[1]))
1678 if (strchr("aA01! ",last_un_char))
1680 if (strchr("zZ79~",s[1]))
1682 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1683 weight -= 5; /* cope with negative subscript */
1686 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1687 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1692 if (keyword(tmpbuf, d - tmpbuf))
1695 if (un_char == last_un_char + 1)
1697 weight -= seen[un_char];
1702 if (weight >= 0) /* probably a character class */
1712 * Does all the checking to disambiguate
1714 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
1715 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
1717 * First argument is the stuff after the first token, e.g. "bar".
1719 * Not a method if bar is a filehandle.
1720 * Not a method if foo is a subroutine prototyped to take a filehandle.
1721 * Not a method if it's really "Foo $bar"
1722 * Method if it's "foo $bar"
1723 * Not a method if it's really "print foo $bar"
1724 * Method if it's really "foo package::" (interpreted as package->foo)
1725 * Not a method if bar is known to be a subroutne ("sub bar; foo bar")
1726 * Not a method if bar is a filehandle or package, but is quoted with
1731 S_intuit_method(pTHX_ char *start, GV *gv)
1733 char *s = start + (*start == '$');
1734 char tmpbuf[sizeof PL_tokenbuf];
1742 if ((cv = GvCVu(gv))) {
1743 char *proto = SvPVX(cv);
1753 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1754 /* start is the beginning of the possible filehandle/object,
1755 * and s is the end of it
1756 * tmpbuf is a copy of it
1759 if (*start == '$') {
1760 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1765 return *s == '(' ? FUNCMETH : METHOD;
1767 if (!keyword(tmpbuf, len)) {
1768 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1773 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1774 if (indirgv && GvCVu(indirgv))
1776 /* filehandle or package name makes it a method */
1777 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1779 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1780 return 0; /* no assumptions -- "=>" quotes bearword */
1782 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1783 newSVpvn(tmpbuf,len));
1784 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1788 return *s == '(' ? FUNCMETH : METHOD;
1796 * Return a string of Perl code to load the debugger. If PERL5DB
1797 * is set, it will return the contents of that, otherwise a
1798 * compile-time require of perl5db.pl.
1805 char *pdb = PerlEnv_getenv("PERL5DB");
1809 SETERRNO(0,SS$_NORMAL);
1810 return "BEGIN { require 'perl5db.pl' }";
1816 /* Encoded script support. filter_add() effectively inserts a
1817 * 'pre-processing' function into the current source input stream.
1818 * Note that the filter function only applies to the current source file
1819 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1821 * The datasv parameter (which may be NULL) can be used to pass
1822 * private data to this instance of the filter. The filter function
1823 * can recover the SV using the FILTER_DATA macro and use it to
1824 * store private buffers and state information.
1826 * The supplied datasv parameter is upgraded to a PVIO type
1827 * and the IoDIRP field is used to store the function pointer,
1828 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
1829 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1830 * private use must be set using malloc'd pointers.
1834 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
1839 if (!PL_rsfp_filters)
1840 PL_rsfp_filters = newAV();
1842 datasv = NEWSV(255,0);
1843 if (!SvUPGRADE(datasv, SVt_PVIO))
1844 Perl_die(aTHX_ "Can't upgrade filter_add data to SVt_PVIO");
1845 IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
1846 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
1847 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
1848 funcp, SvPV_nolen(datasv)));
1849 av_unshift(PL_rsfp_filters, 1);
1850 av_store(PL_rsfp_filters, 0, datasv) ;
1855 /* Delete most recently added instance of this filter function. */
1857 Perl_filter_del(pTHX_ filter_t funcp)
1860 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", funcp));
1861 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
1863 /* if filter is on top of stack (usual case) just pop it off */
1864 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
1865 if (IoDIRP(datasv) == (DIR*)funcp) {
1866 IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
1867 IoDIRP(datasv) = (DIR*)NULL;
1868 sv_free(av_pop(PL_rsfp_filters));
1872 /* we need to search for the correct entry and clear it */
1873 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
1877 /* Invoke the n'th filter function for the current rsfp. */
1879 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
1882 /* 0 = read one text line */
1887 if (!PL_rsfp_filters)
1889 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
1890 /* Provide a default input filter to make life easy. */
1891 /* Note that we append to the line. This is handy. */
1892 DEBUG_P(PerlIO_printf(Perl_debug_log,
1893 "filter_read %d: from rsfp\n", idx));
1897 int old_len = SvCUR(buf_sv) ;
1899 /* ensure buf_sv is large enough */
1900 SvGROW(buf_sv, old_len + maxlen) ;
1901 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1902 if (PerlIO_error(PL_rsfp))
1903 return -1; /* error */
1905 return 0 ; /* end of file */
1907 SvCUR_set(buf_sv, old_len + len) ;
1910 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
1911 if (PerlIO_error(PL_rsfp))
1912 return -1; /* error */
1914 return 0 ; /* end of file */
1917 return SvCUR(buf_sv);
1919 /* Skip this filter slot if filter has been deleted */
1920 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
1921 DEBUG_P(PerlIO_printf(Perl_debug_log,
1922 "filter_read %d: skipped (filter deleted)\n",
1924 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1926 /* Get function pointer hidden within datasv */
1927 funcp = (filter_t)IoDIRP(datasv);
1928 DEBUG_P(PerlIO_printf(Perl_debug_log,
1929 "filter_read %d: via function %p (%s)\n",
1930 idx, funcp, SvPV_nolen(datasv)));
1931 /* Call function. The function is expected to */
1932 /* call "FILTER_READ(idx+1, buf_sv)" first. */
1933 /* Return: <0:error, =0:eof, >0:not eof */
1934 return (*funcp)(aTHXo_ idx, buf_sv, maxlen);
1938 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
1940 #ifdef PERL_CR_FILTER
1941 if (!PL_rsfp_filters) {
1942 filter_add(S_cr_textfilter,NULL);
1945 if (PL_rsfp_filters) {
1948 SvCUR_set(sv, 0); /* start with empty line */
1949 if (FILTER_READ(0, sv, 0) > 0)
1950 return ( SvPVX(sv) ) ;
1955 return (sv_gets(sv, fp, append));
1960 static char* exp_name[] =
1961 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
1962 "ATTRTERM", "TERMBLOCK"
1969 Works out what to call the token just pulled out of the input
1970 stream. The yacc parser takes care of taking the ops we return and
1971 stitching them into a tree.
1977 if read an identifier
1978 if we're in a my declaration
1979 croak if they tried to say my($foo::bar)
1980 build the ops for a my() declaration
1981 if it's an access to a my() variable
1982 are we in a sort block?
1983 croak if my($a); $a <=> $b
1984 build ops for access to a my() variable
1985 if in a dq string, and they've said @foo and we can't find @foo
1987 build ops for a bareword
1988 if we already built the token before, use it.
1992 #ifdef USE_PURE_BISON
1993 Perl_yylex(pTHX_ YYSTYPE *lvalp, int *lcharp)
2006 #ifdef USE_PURE_BISON
2007 yylval_pointer = lvalp;
2008 yychar_pointer = lcharp;
2011 /* check if there's an identifier for us to look at */
2012 if (PL_pending_ident) {
2013 /* pit holds the identifier we read and pending_ident is reset */
2014 char pit = PL_pending_ident;
2015 PL_pending_ident = 0;
2017 /* if we're in a my(), we can't allow dynamics here.
2018 $foo'bar has already been turned into $foo::bar, so
2019 just check for colons.
2021 if it's a legal name, the OP is a PADANY.
2024 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
2025 if (strchr(PL_tokenbuf,':'))
2026 yyerror(Perl_form(aTHX_ "No package name allowed for "
2027 "variable %s in \"our\"",
2029 tmp = pad_allocmy(PL_tokenbuf);
2032 if (strchr(PL_tokenbuf,':'))
2033 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
2035 yylval.opval = newOP(OP_PADANY, 0);
2036 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
2042 build the ops for accesses to a my() variable.
2044 Deny my($a) or my($b) in a sort block, *if* $a or $b is
2045 then used in a comparison. This catches most, but not
2046 all cases. For instance, it catches
2047 sort { my($a); $a <=> $b }
2049 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
2050 (although why you'd do that is anyone's guess).
2053 if (!strchr(PL_tokenbuf,':')) {
2055 /* Check for single character per-thread SVs */
2056 if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
2057 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
2058 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
2060 yylval.opval = newOP(OP_THREADSV, 0);
2061 yylval.opval->op_targ = tmp;
2064 #endif /* USE_THREADS */
2065 if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
2066 SV *namesv = AvARRAY(PL_comppad_name)[tmp];
2067 /* might be an "our" variable" */
2068 if (SvFLAGS(namesv) & SVpad_OUR) {
2069 /* build ops for a bareword */
2070 SV *sym = newSVpv(HvNAME(GvSTASH(namesv)),0);
2071 sv_catpvn(sym, "::", 2);
2072 sv_catpv(sym, PL_tokenbuf+1);
2073 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
2074 yylval.opval->op_private = OPpCONST_ENTERED;
2075 gv_fetchpv(SvPVX(sym),
2077 ? (GV_ADDMULTI | GV_ADDINEVAL)
2080 ((PL_tokenbuf[0] == '$') ? SVt_PV
2081 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
2086 /* if it's a sort block and they're naming $a or $b */
2087 if (PL_last_lop_op == OP_SORT &&
2088 PL_tokenbuf[0] == '$' &&
2089 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
2092 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
2093 d < PL_bufend && *d != '\n';
2096 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
2097 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
2103 yylval.opval = newOP(OP_PADANY, 0);
2104 yylval.opval->op_targ = tmp;
2110 Whine if they've said @foo in a doublequoted string,
2111 and @foo isn't a variable we can find in the symbol
2114 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
2115 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
2116 if (!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
2117 yyerror(Perl_form(aTHX_ "In string, %s now must be written as \\%s",
2118 PL_tokenbuf, PL_tokenbuf));
2121 /* build ops for a bareword */
2122 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
2123 yylval.opval->op_private = OPpCONST_ENTERED;
2124 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
2125 ((PL_tokenbuf[0] == '$') ? SVt_PV
2126 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
2131 /* no identifier pending identification */
2133 switch (PL_lex_state) {
2135 case LEX_NORMAL: /* Some compilers will produce faster */
2136 case LEX_INTERPNORMAL: /* code if we comment these out. */
2140 /* when we've already built the next token, just pull it out of the queue */
2143 yylval = PL_nextval[PL_nexttoke];
2145 PL_lex_state = PL_lex_defer;
2146 PL_expect = PL_lex_expect;
2147 PL_lex_defer = LEX_NORMAL;
2149 return(PL_nexttype[PL_nexttoke]);
2151 /* interpolated case modifiers like \L \U, including \Q and \E.
2152 when we get here, PL_bufptr is at the \
2154 case LEX_INTERPCASEMOD:
2156 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
2157 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
2159 /* handle \E or end of string */
2160 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
2164 if (PL_lex_casemods) {
2165 oldmod = PL_lex_casestack[--PL_lex_casemods];
2166 PL_lex_casestack[PL_lex_casemods] = '\0';
2168 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
2170 PL_lex_state = LEX_INTERPCONCAT;
2174 if (PL_bufptr != PL_bufend)
2176 PL_lex_state = LEX_INTERPCONCAT;
2181 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
2182 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
2183 if (strchr("LU", *s) &&
2184 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
2186 PL_lex_casestack[--PL_lex_casemods] = '\0';
2189 if (PL_lex_casemods > 10) {
2190 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
2191 if (newlb != PL_lex_casestack) {
2193 PL_lex_casestack = newlb;
2196 PL_lex_casestack[PL_lex_casemods++] = *s;
2197 PL_lex_casestack[PL_lex_casemods] = '\0';
2198 PL_lex_state = LEX_INTERPCONCAT;
2199 PL_nextval[PL_nexttoke].ival = 0;
2202 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
2204 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
2206 PL_nextval[PL_nexttoke].ival = OP_LC;
2208 PL_nextval[PL_nexttoke].ival = OP_UC;
2210 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
2212 Perl_croak(aTHX_ "panic: yylex");
2215 if (PL_lex_starts) {
2224 case LEX_INTERPPUSH:
2225 return sublex_push();
2227 case LEX_INTERPSTART:
2228 if (PL_bufptr == PL_bufend)
2229 return sublex_done();
2231 PL_lex_dojoin = (*PL_bufptr == '@');
2232 PL_lex_state = LEX_INTERPNORMAL;
2233 if (PL_lex_dojoin) {
2234 PL_nextval[PL_nexttoke].ival = 0;
2237 PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
2238 PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
2239 force_next(PRIVATEREF);
2241 force_ident("\"", '$');
2242 #endif /* USE_THREADS */
2243 PL_nextval[PL_nexttoke].ival = 0;
2245 PL_nextval[PL_nexttoke].ival = 0;
2247 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
2250 if (PL_lex_starts++) {
2256 case LEX_INTERPENDMAYBE:
2257 if (intuit_more(PL_bufptr)) {
2258 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
2264 if (PL_lex_dojoin) {
2265 PL_lex_dojoin = FALSE;
2266 PL_lex_state = LEX_INTERPCONCAT;
2269 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
2270 && SvEVALED(PL_lex_repl))
2272 if (PL_bufptr != PL_bufend)
2273 Perl_croak(aTHX_ "Bad evalled substitution pattern");
2274 PL_lex_repl = Nullsv;
2277 case LEX_INTERPCONCAT:
2279 if (PL_lex_brackets)
2280 Perl_croak(aTHX_ "panic: INTERPCONCAT");
2282 if (PL_bufptr == PL_bufend)
2283 return sublex_done();
2285 if (SvIVX(PL_linestr) == '\'') {
2286 SV *sv = newSVsv(PL_linestr);
2289 else if ( PL_hints & HINT_NEW_RE )
2290 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
2291 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2295 s = scan_const(PL_bufptr);
2297 PL_lex_state = LEX_INTERPCASEMOD;
2299 PL_lex_state = LEX_INTERPSTART;
2302 if (s != PL_bufptr) {
2303 PL_nextval[PL_nexttoke] = yylval;
2306 if (PL_lex_starts++)
2316 PL_lex_state = LEX_NORMAL;
2317 s = scan_formline(PL_bufptr);
2318 if (!PL_lex_formbrack)
2324 PL_oldoldbufptr = PL_oldbufptr;
2327 PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at %s\n",
2328 exp_name[PL_expect], s);
2334 if (isIDFIRST_lazy_if(s,UTF))
2336 Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
2339 goto fake_eof; /* emulate EOF on ^D or ^Z */
2344 if (PL_lex_brackets)
2345 yyerror("Missing right curly or square bracket");
2348 if (s++ < PL_bufend)
2349 goto retry; /* ignore stray nulls */
2352 if (!PL_in_eval && !PL_preambled) {
2353 PL_preambled = TRUE;
2354 sv_setpv(PL_linestr,incl_perldb());
2355 if (SvCUR(PL_linestr))
2356 sv_catpv(PL_linestr,";");
2358 while(AvFILLp(PL_preambleav) >= 0) {
2359 SV *tmpsv = av_shift(PL_preambleav);
2360 sv_catsv(PL_linestr, tmpsv);
2361 sv_catpv(PL_linestr, ";");
2364 sv_free((SV*)PL_preambleav);
2365 PL_preambleav = NULL;
2367 if (PL_minus_n || PL_minus_p) {
2368 sv_catpv(PL_linestr, "LINE: while (<>) {");
2370 sv_catpv(PL_linestr,"chomp;");
2372 GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
2374 GvIMPORTED_AV_on(gv);
2376 if (strchr("/'\"", *PL_splitstr)
2377 && strchr(PL_splitstr + 1, *PL_splitstr))
2378 Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s);", PL_splitstr);
2381 s = "'~#\200\1'"; /* surely one char is unused...*/
2382 while (s[1] && strchr(PL_splitstr, *s)) s++;
2384 Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s%c",
2385 "q" + (delim == '\''), delim);
2386 for (s = PL_splitstr; *s; s++) {
2388 sv_catpvn(PL_linestr, "\\", 1);
2389 sv_catpvn(PL_linestr, s, 1);
2391 Perl_sv_catpvf(aTHX_ PL_linestr, "%c);", delim);
2395 sv_catpv(PL_linestr,"@F=split(' ');");
2398 sv_catpv(PL_linestr, "\n");
2399 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2400 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2401 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2402 SV *sv = NEWSV(85,0);
2404 sv_upgrade(sv, SVt_PVMG);
2405 sv_setsv(sv,PL_linestr);
2406 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2411 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
2414 if (PL_preprocess && !PL_in_eval)
2415 (void)PerlProc_pclose(PL_rsfp);
2416 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2417 PerlIO_clearerr(PL_rsfp);
2419 (void)PerlIO_close(PL_rsfp);
2421 PL_doextract = FALSE;
2423 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2424 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
2425 sv_catpv(PL_linestr,";}");
2426 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2427 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2428 PL_minus_n = PL_minus_p = 0;
2431 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2432 sv_setpv(PL_linestr,"");
2433 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
2436 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
2437 PL_doextract = FALSE;
2439 /* Incest with pod. */
2440 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2441 sv_setpv(PL_linestr, "");
2442 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2443 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2444 PL_doextract = FALSE;
2448 } while (PL_doextract);
2449 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2450 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2451 SV *sv = NEWSV(85,0);
2453 sv_upgrade(sv, SVt_PVMG);
2454 sv_setsv(sv,PL_linestr);
2455 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2457 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2458 if (CopLINE(PL_curcop) == 1) {
2459 while (s < PL_bufend && isSPACE(*s))
2461 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2465 if (*s == '#' && *(s+1) == '!')
2467 #ifdef ALTERNATE_SHEBANG
2469 static char as[] = ALTERNATE_SHEBANG;
2470 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2471 d = s + (sizeof(as) - 1);
2473 #endif /* ALTERNATE_SHEBANG */
2482 while (*d && !isSPACE(*d))
2486 #ifdef ARG_ZERO_IS_SCRIPT
2487 if (ipathend > ipath) {
2489 * HP-UX (at least) sets argv[0] to the script name,
2490 * which makes $^X incorrect. And Digital UNIX and Linux,
2491 * at least, set argv[0] to the basename of the Perl
2492 * interpreter. So, having found "#!", we'll set it right.
2494 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
2495 assert(SvPOK(x) || SvGMAGICAL(x));
2496 if (sv_eq(x, CopFILESV(PL_curcop))) {
2497 sv_setpvn(x, ipath, ipathend - ipath);
2500 TAINT_NOT; /* $^X is always tainted, but that's OK */
2502 #endif /* ARG_ZERO_IS_SCRIPT */
2507 d = instr(s,"perl -");
2509 d = instr(s,"perl");
2511 /* avoid getting into infinite loops when shebang
2512 * line contains "Perl" rather than "perl" */
2514 for (d = ipathend-4; d >= ipath; --d) {
2515 if ((*d == 'p' || *d == 'P')
2516 && !ibcmp(d, "perl", 4))
2526 #ifdef ALTERNATE_SHEBANG
2528 * If the ALTERNATE_SHEBANG on this system starts with a
2529 * character that can be part of a Perl expression, then if
2530 * we see it but not "perl", we're probably looking at the
2531 * start of Perl code, not a request to hand off to some
2532 * other interpreter. Similarly, if "perl" is there, but
2533 * not in the first 'word' of the line, we assume the line
2534 * contains the start of the Perl program.
2536 if (d && *s != '#') {
2538 while (*c && !strchr("; \t\r\n\f\v#", *c))
2541 d = Nullch; /* "perl" not in first word; ignore */
2543 *s = '#'; /* Don't try to parse shebang line */
2545 #endif /* ALTERNATE_SHEBANG */
2550 !instr(s,"indir") &&
2551 instr(PL_origargv[0],"perl"))
2557 while (s < PL_bufend && isSPACE(*s))
2559 if (s < PL_bufend) {
2560 Newz(899,newargv,PL_origargc+3,char*);
2562 while (s < PL_bufend && !isSPACE(*s))
2565 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2568 newargv = PL_origargv;
2570 PerlProc_execv(ipath, newargv);
2571 Perl_croak(aTHX_ "Can't exec %s", ipath);
2574 U32 oldpdb = PL_perldb;
2575 bool oldn = PL_minus_n;
2576 bool oldp = PL_minus_p;
2578 while (*d && !isSPACE(*d)) d++;
2579 while (*d == ' ' || *d == '\t') d++;
2583 if (*d == 'M' || *d == 'm') {
2585 while (*d && !isSPACE(*d)) d++;
2586 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2589 d = moreswitches(d);
2591 if (PERLDB_LINE && !oldpdb ||
2592 ( PL_minus_n || PL_minus_p ) && !(oldn || oldp) )
2593 /* if we have already added "LINE: while (<>) {",
2594 we must not do it again */
2596 sv_setpv(PL_linestr, "");
2597 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2598 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2599 PL_preambled = FALSE;
2601 (void)gv_fetchfile(PL_origfilename);
2608 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2610 PL_lex_state = LEX_FORMLINE;
2615 #ifdef PERL_STRICT_CR
2616 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2618 "(Maybe you didn't strip carriage returns after a network transfer?)\n");
2620 case ' ': case '\t': case '\f': case 013:
2625 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2627 while (s < d && *s != '\n')
2632 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2634 PL_lex_state = LEX_FORMLINE;
2644 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2649 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2652 if (strnEQ(s,"=>",2)) {
2653 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2654 OPERATOR('-'); /* unary minus */
2656 PL_last_uni = PL_oldbufptr;
2657 PL_last_lop_op = OP_FTEREAD; /* good enough */
2659 case 'r': FTST(OP_FTEREAD);
2660 case 'w': FTST(OP_FTEWRITE);
2661 case 'x': FTST(OP_FTEEXEC);
2662 case 'o': FTST(OP_FTEOWNED);
2663 case 'R': FTST(OP_FTRREAD);
2664 case 'W': FTST(OP_FTRWRITE);
2665 case 'X': FTST(OP_FTREXEC);
2666 case 'O': FTST(OP_FTROWNED);
2667 case 'e': FTST(OP_FTIS);
2668 case 'z': FTST(OP_FTZERO);
2669 case 's': FTST(OP_FTSIZE);
2670 case 'f': FTST(OP_FTFILE);
2671 case 'd': FTST(OP_FTDIR);
2672 case 'l': FTST(OP_FTLINK);
2673 case 'p': FTST(OP_FTPIPE);
2674 case 'S': FTST(OP_FTSOCK);
2675 case 'u': FTST(OP_FTSUID);
2676 case 'g': FTST(OP_FTSGID);
2677 case 'k': FTST(OP_FTSVTX);
2678 case 'b': FTST(OP_FTBLK);
2679 case 'c': FTST(OP_FTCHR);
2680 case 't': FTST(OP_FTTTY);
2681 case 'T': FTST(OP_FTTEXT);
2682 case 'B': FTST(OP_FTBINARY);
2683 case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2684 case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2685 case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
2687 Perl_croak(aTHX_ "Unrecognized file test: -%c", (int)tmp);
2694 if (PL_expect == XOPERATOR)
2699 else if (*s == '>') {
2702 if (isIDFIRST_lazy_if(s,UTF)) {
2703 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2711 if (PL_expect == XOPERATOR)
2714 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2716 OPERATOR('-'); /* unary minus */
2723 if (PL_expect == XOPERATOR)
2728 if (PL_expect == XOPERATOR)
2731 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2737 if (PL_expect != XOPERATOR) {
2738 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2739 PL_expect = XOPERATOR;
2740 force_ident(PL_tokenbuf, '*');
2753 if (PL_expect == XOPERATOR) {
2757 PL_tokenbuf[0] = '%';
2758 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2759 if (!PL_tokenbuf[1]) {
2761 yyerror("Final % should be \\% or %name");
2764 PL_pending_ident = '%';
2783 switch (PL_expect) {
2786 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
2788 PL_bufptr = s; /* update in case we back off */
2794 PL_expect = XTERMBLOCK;
2798 while (isIDFIRST_lazy_if(s,UTF)) {
2799 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2800 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
2801 if (tmp < 0) tmp = -tmp;
2816 d = scan_str(d,TRUE,TRUE);
2819 SvREFCNT_dec(PL_lex_stuff);
2820 PL_lex_stuff = Nullsv;
2822 /* MUST advance bufptr here to avoid bogus
2823 "at end of line" context messages from yyerror().
2825 PL_bufptr = s + len;
2826 yyerror("Unterminated attribute parameter in attribute list");
2829 return 0; /* EOF indicator */
2833 SV *sv = newSVpvn(s, len);
2834 sv_catsv(sv, PL_lex_stuff);
2835 attrs = append_elem(OP_LIST, attrs,
2836 newSVOP(OP_CONST, 0, sv));
2837 SvREFCNT_dec(PL_lex_stuff);
2838 PL_lex_stuff = Nullsv;
2841 attrs = append_elem(OP_LIST, attrs,
2842 newSVOP(OP_CONST, 0,
2846 if (*s == ':' && s[1] != ':')
2849 break; /* require real whitespace or :'s */
2851 tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
2852 if (*s != ';' && *s != tmp && (tmp != '=' || *s != ')')) {
2853 char q = ((*s == '\'') ? '"' : '\'');
2854 /* If here for an expression, and parsed no attrs, back off. */
2855 if (tmp == '=' && !attrs) {
2859 /* MUST advance bufptr here to avoid bogus "at end of line"
2860 context messages from yyerror().
2864 yyerror("Unterminated attribute list");
2866 yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list",
2874 PL_nextval[PL_nexttoke].opval = attrs;
2882 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
2883 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
2888 if (CopLINE(PL_curcop) < PL_copline)
2889 PL_copline = CopLINE(PL_curcop);
2900 if (PL_lex_brackets <= 0)
2901 yyerror("Unmatched right square bracket");
2904 if (PL_lex_state == LEX_INTERPNORMAL) {
2905 if (PL_lex_brackets == 0) {
2906 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
2907 PL_lex_state = LEX_INTERPEND;
2914 if (PL_lex_brackets > 100) {
2915 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
2916 if (newlb != PL_lex_brackstack) {
2918 PL_lex_brackstack = newlb;
2921 switch (PL_expect) {
2923 if (PL_lex_formbrack) {
2927 if (PL_oldoldbufptr == PL_last_lop)
2928 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2930 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2931 OPERATOR(HASHBRACK);
2933 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2936 PL_tokenbuf[0] = '\0';
2937 if (d < PL_bufend && *d == '-') {
2938 PL_tokenbuf[0] = '-';
2940 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2943 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
2944 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2946 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2949 char minus = (PL_tokenbuf[0] == '-');
2950 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2958 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
2963 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2968 if (PL_oldoldbufptr == PL_last_lop)
2969 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2971 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2974 OPERATOR(HASHBRACK);
2975 /* This hack serves to disambiguate a pair of curlies
2976 * as being a block or an anon hash. Normally, expectation
2977 * determines that, but in cases where we're not in a
2978 * position to expect anything in particular (like inside
2979 * eval"") we have to resolve the ambiguity. This code
2980 * covers the case where the first term in the curlies is a
2981 * quoted string. Most other cases need to be explicitly
2982 * disambiguated by prepending a `+' before the opening
2983 * curly in order to force resolution as an anon hash.
2985 * XXX should probably propagate the outer expectation
2986 * into eval"" to rely less on this hack, but that could
2987 * potentially break current behavior of eval"".
2991 if (*s == '\'' || *s == '"' || *s == '`') {
2992 /* common case: get past first string, handling escapes */
2993 for (t++; t < PL_bufend && *t != *s;)
2994 if (*t++ == '\\' && (*t == '\\' || *t == *s))
2998 else if (*s == 'q') {
3001 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
3005 char open, close, term;
3008 while (t < PL_bufend && isSPACE(*t))
3012 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
3016 for (t++; t < PL_bufend; t++) {
3017 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
3019 else if (*t == open)
3023 for (t++; t < PL_bufend; t++) {
3024 if (*t == '\\' && t+1 < PL_bufend)
3026 else if (*t == close && --brackets <= 0)
3028 else if (*t == open)
3034 else if (isALNUM_lazy_if(t,UTF)) {
3036 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3039 while (t < PL_bufend && isSPACE(*t))
3041 /* if comma follows first term, call it an anon hash */
3042 /* XXX it could be a comma expression with loop modifiers */
3043 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
3044 || (*t == '=' && t[1] == '>')))
3045 OPERATOR(HASHBRACK);
3046 if (PL_expect == XREF)
3049 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
3055 yylval.ival = CopLINE(PL_curcop);
3056 if (isSPACE(*s) || *s == '#')
3057 PL_copline = NOLINE; /* invalidate current command line number */
3062 if (PL_lex_brackets <= 0)
3063 yyerror("Unmatched right curly bracket");
3065 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
3066 if (PL_lex_brackets < PL_lex_formbrack)
3067 PL_lex_formbrack = 0;
3068 if (PL_lex_state == LEX_INTERPNORMAL) {
3069 if (PL_lex_brackets == 0) {
3070 if (PL_expect & XFAKEBRACK) {
3071 PL_expect &= XENUMMASK;
3072 PL_lex_state = LEX_INTERPEND;
3074 return yylex(); /* ignore fake brackets */
3076 if (*s == '-' && s[1] == '>')
3077 PL_lex_state = LEX_INTERPENDMAYBE;
3078 else if (*s != '[' && *s != '{')
3079 PL_lex_state = LEX_INTERPEND;
3082 if (PL_expect & XFAKEBRACK) {
3083 PL_expect &= XENUMMASK;
3085 return yylex(); /* ignore fake brackets */
3095 if (PL_expect == XOPERATOR) {
3096 if (ckWARN(WARN_SEMICOLON)
3097 && isIDFIRST_lazy_if(s,UTF) && PL_bufptr == PL_linestart)
3099 CopLINE_dec(PL_curcop);
3100 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3101 CopLINE_inc(PL_curcop);
3106 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3108 PL_expect = XOPERATOR;
3109 force_ident(PL_tokenbuf, '&');
3113 yylval.ival = (OPpENTERSUB_AMPER<<8);
3132 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
3133 Perl_warner(aTHX_ WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
3135 if (PL_expect == XSTATE && isALPHA(tmp) &&
3136 (s == PL_linestart+1 || s[-2] == '\n') )
3138 if (PL_in_eval && !PL_rsfp) {
3143 if (strnEQ(s,"=cut",4)) {
3157 PL_doextract = TRUE;
3160 if (PL_lex_brackets < PL_lex_formbrack) {
3162 #ifdef PERL_STRICT_CR
3163 for (t = s; *t == ' ' || *t == '\t'; t++) ;
3165 for (t = s; *t == ' ' || *t == '\t' || *t == '\r'; t++) ;
3167 if (*t == '\n' || *t == '#') {
3185 if (PL_expect != XOPERATOR) {
3186 if (s[1] != '<' && !strchr(s,'>'))
3189 s = scan_heredoc(s);
3191 s = scan_inputsymbol(s);
3192 TERM(sublex_start());
3197 SHop(OP_LEFT_SHIFT);
3211 SHop(OP_RIGHT_SHIFT);
3220 if (PL_expect == XOPERATOR) {
3221 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3224 return ','; /* grandfather non-comma-format format */
3228 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
3229 PL_tokenbuf[0] = '@';
3230 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3231 sizeof PL_tokenbuf - 1, FALSE);
3232 if (PL_expect == XOPERATOR)
3233 no_op("Array length", s);
3234 if (!PL_tokenbuf[1])
3236 PL_expect = XOPERATOR;
3237 PL_pending_ident = '#';
3241 PL_tokenbuf[0] = '$';
3242 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3243 sizeof PL_tokenbuf - 1, FALSE);
3244 if (PL_expect == XOPERATOR)
3246 if (!PL_tokenbuf[1]) {
3248 yyerror("Final $ should be \\$ or $name");
3252 /* This kludge not intended to be bulletproof. */
3253 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
3254 yylval.opval = newSVOP(OP_CONST, 0,
3255 newSViv((IV)PL_compiling.cop_arybase));
3256 yylval.opval->op_private = OPpCONST_ARYBASE;
3262 if (PL_lex_state == LEX_NORMAL)
3265 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3268 PL_tokenbuf[0] = '@';
3269 if (ckWARN(WARN_SYNTAX)) {
3271 isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$';
3274 PL_bufptr = skipspace(PL_bufptr);
3275 while (t < PL_bufend && *t != ']')
3277 Perl_warner(aTHX_ WARN_SYNTAX,
3278 "Multidimensional syntax %.*s not supported",
3279 (t - PL_bufptr) + 1, PL_bufptr);
3283 else if (*s == '{') {
3284 PL_tokenbuf[0] = '%';
3285 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
3286 (t = strchr(s, '}')) && (t = strchr(t, '=')))
3288 char tmpbuf[sizeof PL_tokenbuf];
3290 for (t++; isSPACE(*t); t++) ;
3291 if (isIDFIRST_lazy_if(t,UTF)) {
3292 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
3293 for (; isSPACE(*t); t++) ;
3294 if (*t == ';' && get_cv(tmpbuf, FALSE))
3295 Perl_warner(aTHX_ WARN_SYNTAX,
3296 "You need to quote \"%s\"", tmpbuf);
3302 PL_expect = XOPERATOR;
3303 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3304 bool islop = (PL_last_lop == PL_oldoldbufptr);
3305 if (!islop || PL_last_lop_op == OP_GREPSTART)
3306 PL_expect = XOPERATOR;
3307 else if (strchr("$@\"'`q", *s))
3308 PL_expect = XTERM; /* e.g. print $fh "foo" */
3309 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
3310 PL_expect = XTERM; /* e.g. print $fh &sub */
3311 else if (isIDFIRST_lazy_if(s,UTF)) {
3312 char tmpbuf[sizeof PL_tokenbuf];
3313 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3314 if (tmp = keyword(tmpbuf, len)) {
3315 /* binary operators exclude handle interpretations */
3327 PL_expect = XTERM; /* e.g. print $fh length() */
3332 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
3333 if (gv && GvCVu(gv))
3334 PL_expect = XTERM; /* e.g. print $fh subr() */
3337 else if (isDIGIT(*s))
3338 PL_expect = XTERM; /* e.g. print $fh 3 */
3339 else if (*s == '.' && isDIGIT(s[1]))
3340 PL_expect = XTERM; /* e.g. print $fh .3 */
3341 else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
3342 PL_expect = XTERM; /* e.g. print $fh -1 */
3343 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3344 PL_expect = XTERM; /* print $fh <<"EOF" */
3346 PL_pending_ident = '$';
3350 if (PL_expect == XOPERATOR)
3352 PL_tokenbuf[0] = '@';
3353 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3354 if (!PL_tokenbuf[1]) {
3356 yyerror("Final @ should be \\@ or @name");
3359 if (PL_lex_state == LEX_NORMAL)
3361 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3363 PL_tokenbuf[0] = '%';
3365 /* Warn about @ where they meant $. */
3366 if (ckWARN(WARN_SYNTAX)) {
3367 if (*s == '[' || *s == '{') {
3369 while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
3371 if (*t == '}' || *t == ']') {
3373 PL_bufptr = skipspace(PL_bufptr);
3374 Perl_warner(aTHX_ WARN_SYNTAX,
3375 "Scalar value %.*s better written as $%.*s",
3376 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
3381 PL_pending_ident = '@';
3384 case '/': /* may either be division or pattern */
3385 case '?': /* may either be conditional or pattern */
3386 if (PL_expect != XOPERATOR) {
3387 /* Disable warning on "study /blah/" */
3388 if (PL_oldoldbufptr == PL_last_uni
3389 && (*PL_last_uni != 's' || s - PL_last_uni < 5
3390 || memNE(PL_last_uni, "study", 5)
3391 || isALNUM_lazy_if(PL_last_uni+5,UTF)))
3393 s = scan_pat(s,OP_MATCH);
3394 TERM(sublex_start());
3402 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3403 #ifdef PERL_STRICT_CR
3406 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3408 && (s == PL_linestart || s[-1] == '\n') )
3410 PL_lex_formbrack = 0;
3414 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
3420 yylval.ival = OPf_SPECIAL;
3426 if (PL_expect != XOPERATOR)
3431 case '0': case '1': case '2': case '3': case '4':
3432 case '5': case '6': case '7': case '8': case '9':
3434 if (PL_expect == XOPERATOR)
3439 s = scan_str(s,FALSE,FALSE);
3440 if (PL_expect == XOPERATOR) {
3441 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3444 return ','; /* grandfather non-comma-format format */
3450 missingterm((char*)0);
3451 yylval.ival = OP_CONST;
3452 TERM(sublex_start());
3455 s = scan_str(s,FALSE,FALSE);
3456 if (PL_expect == XOPERATOR) {
3457 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3460 return ','; /* grandfather non-comma-format format */
3466 missingterm((char*)0);
3467 yylval.ival = OP_CONST;
3468 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
3469 if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
3470 yylval.ival = OP_STRINGIFY;
3474 TERM(sublex_start());
3477 s = scan_str(s,FALSE,FALSE);
3478 if (PL_expect == XOPERATOR)
3479 no_op("Backticks",s);
3481 missingterm((char*)0);
3482 yylval.ival = OP_BACKTICK;
3484 TERM(sublex_start());
3488 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
3489 Perl_warner(aTHX_ WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
3491 if (PL_expect == XOPERATOR)
3492 no_op("Backslash",s);
3496 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
3500 while (isDIGIT(*start) || *start == '_')
3502 if (*start == '.' && isDIGIT(start[1])) {
3506 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
3507 else if (!isALPHA(*start) && (PL_expect == XTERM || PL_expect == XREF)) {
3511 gv = gv_fetchpv(s, FALSE, SVt_PVCV);
3521 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
3561 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3563 /* Some keywords can be followed by any delimiter, including ':' */
3564 tmp = (len == 1 && strchr("msyq", PL_tokenbuf[0]) ||
3565 len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
3566 (PL_tokenbuf[0] == 'q' &&
3567 strchr("qwxr", PL_tokenbuf[1]))));
3569 /* x::* is just a word, unless x is "CORE" */
3570 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
3574 while (d < PL_bufend && isSPACE(*d))
3575 d++; /* no comments skipped here, or s### is misparsed */
3577 /* Is this a label? */
3578 if (!tmp && PL_expect == XSTATE
3579 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
3581 yylval.pval = savepv(PL_tokenbuf);
3586 /* Check for keywords */
3587 tmp = keyword(PL_tokenbuf, len);
3589 /* Is this a word before a => operator? */
3590 if (strnEQ(d,"=>",2)) {
3592 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
3593 yylval.opval->op_private = OPpCONST_BARE;
3597 if (tmp < 0) { /* second-class keyword? */
3598 GV *ogv = Nullgv; /* override (winner) */
3599 GV *hgv = Nullgv; /* hidden (loser) */
3600 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3602 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3605 if (GvIMPORTED_CV(gv))
3607 else if (! CvMETHOD(cv))
3611 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3612 (gv = *gvp) != (GV*)&PL_sv_undef &&
3613 GvCVu(gv) && GvIMPORTED_CV(gv))
3619 tmp = 0; /* overridden by import or by GLOBAL */
3622 && -tmp==KEY_lock /* XXX generalizable kludge */
3624 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3626 tmp = 0; /* any sub overrides "weak" keyword */
3628 else { /* no override */
3632 if (ckWARN(WARN_AMBIGUOUS) && hgv
3633 && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3634 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3635 "Ambiguous call resolved as CORE::%s(), %s",
3636 GvENAME(hgv), "qualify as such or use &");
3643 default: /* not a keyword */
3646 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3648 /* Get the rest if it looks like a package qualifier */
3650 if (*s == '\'' || *s == ':' && s[1] == ':') {
3652 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3655 Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
3656 *s == '\'' ? "'" : "::");
3660 if (PL_expect == XOPERATOR) {
3661 if (PL_bufptr == PL_linestart) {
3662 CopLINE_dec(PL_curcop);
3663 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3664 CopLINE_inc(PL_curcop);
3667 no_op("Bareword",s);
3670 /* Look for a subroutine with this name in current package,
3671 unless name is "Foo::", in which case Foo is a bearword
3672 (and a package name). */
3675 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3677 if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3678 Perl_warner(aTHX_ WARN_BAREWORD,
3679 "Bareword \"%s\" refers to nonexistent package",
3682 PL_tokenbuf[len] = '\0';
3689 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3692 /* if we saw a global override before, get the right name */
3695 sv = newSVpvn("CORE::GLOBAL::",14);
3696 sv_catpv(sv,PL_tokenbuf);
3699 sv = newSVpv(PL_tokenbuf,0);
3701 /* Presume this is going to be a bareword of some sort. */
3704 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3705 yylval.opval->op_private = OPpCONST_BARE;
3707 /* And if "Foo::", then that's what it certainly is. */
3712 /* See if it's the indirect object for a list operator. */
3714 if (PL_oldoldbufptr &&
3715 PL_oldoldbufptr < PL_bufptr &&
3716 (PL_oldoldbufptr == PL_last_lop
3717 || PL_oldoldbufptr == PL_last_uni) &&
3718 /* NO SKIPSPACE BEFORE HERE! */
3719 (PL_expect == XREF ||
3720 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
3722 bool immediate_paren = *s == '(';
3724 /* (Now we can afford to cross potential line boundary.) */
3727 /* Two barewords in a row may indicate method call. */
3729 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp=intuit_method(s,gv)))
3732 /* If not a declared subroutine, it's an indirect object. */
3733 /* (But it's an indir obj regardless for sort.) */
3735 if ((PL_last_lop_op == OP_SORT ||
3736 (!immediate_paren && (!gv || !GvCVu(gv)))) &&
3737 (PL_last_lop_op != OP_MAPSTART &&
3738 PL_last_lop_op != OP_GREPSTART))
3740 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3745 /* If followed by a paren, it's certainly a subroutine. */
3747 PL_expect = XOPERATOR;
3751 if (gv && GvCVu(gv)) {
3752 for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
3753 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
3758 PL_nextval[PL_nexttoke].opval = yylval.opval;
3759 PL_expect = XOPERATOR;
3765 /* If followed by var or block, call it a method (unless sub) */
3767 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3768 PL_last_lop = PL_oldbufptr;
3769 PL_last_lop_op = OP_METHOD;
3773 /* If followed by a bareword, see if it looks like indir obj. */
3775 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp = intuit_method(s,gv)))
3778 /* Not a method, so call it a subroutine (if defined) */
3780 if (gv && GvCVu(gv)) {
3782 if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
3783 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3784 "Ambiguous use of -%s resolved as -&%s()",
3785 PL_tokenbuf, PL_tokenbuf);
3786 /* Check for a constant sub */
3788 if ((sv = cv_const_sv(cv))) {
3790 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3791 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3792 yylval.opval->op_private = 0;
3796 /* Resolve to GV now. */
3797 op_free(yylval.opval);
3798 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3799 yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
3800 PL_last_lop = PL_oldbufptr;
3801 PL_last_lop_op = OP_ENTERSUB;
3802 /* Is there a prototype? */
3805 char *proto = SvPV((SV*)cv, len);
3808 if (strEQ(proto, "$"))
3810 if (*proto == '&' && *s == '{') {
3811 sv_setpv(PL_subname,"__ANON__");
3815 PL_nextval[PL_nexttoke].opval = yylval.opval;
3821 /* Call it a bare word */
3823 if (PL_hints & HINT_STRICT_SUBS)
3824 yylval.opval->op_private |= OPpCONST_STRICT;
3827 if (ckWARN(WARN_RESERVED)) {
3828 if (lastchar != '-') {
3829 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3831 Perl_warner(aTHX_ WARN_RESERVED, PL_warn_reserved,
3838 if (lastchar && strchr("*%&", lastchar) && ckWARN_d(WARN_AMBIGUOUS)) {
3839 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3840 "Operator or semicolon missing before %c%s",
3841 lastchar, PL_tokenbuf);
3842 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3843 "Ambiguous use of %c resolved as operator %c",
3844 lastchar, lastchar);
3850 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3851 newSVpv(CopFILE(PL_curcop),0));
3855 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3856 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
3859 case KEY___PACKAGE__:
3860 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3862 ? newSVsv(PL_curstname)
3871 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3872 char *pname = "main";
3873 if (PL_tokenbuf[2] == 'D')
3874 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3875 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
3878 GvIOp(gv) = newIO();
3879 IoIFP(GvIOp(gv)) = PL_rsfp;
3880 #if defined(HAS_FCNTL) && defined(F_SETFD)
3882 int fd = PerlIO_fileno(PL_rsfp);
3883 fcntl(fd,F_SETFD,fd >= 3);
3886 /* Mark this internal pseudo-handle as clean */
3887 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3889 IoTYPE(GvIOp(gv)) = '|';
3890 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
3891 IoTYPE(GvIOp(gv)) = '-';
3893 IoTYPE(GvIOp(gv)) = '<';
3894 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
3895 /* if the script was opened in binmode, we need to revert
3896 * it to text mode for compatibility; but only iff it has CRs
3897 * XXX this is a questionable hack at best. */
3898 if (PL_bufend-PL_bufptr > 2
3899 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
3902 if (IoTYPE(GvIOp(gv)) == '<') {
3903 loc = PerlIO_tell(PL_rsfp);
3904 (void)PerlIO_seek(PL_rsfp, 0L, 0);
3906 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
3907 #if defined(__BORLANDC__)
3908 /* XXX see note in do_binmode() */
3909 ((FILE*)PL_rsfp)->flags |= _F_BIN;
3912 PerlIO_seek(PL_rsfp, loc, 0);
3927 if (PL_expect == XSTATE) {
3934 if (*s == ':' && s[1] == ':') {
3937 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3938 tmp = keyword(PL_tokenbuf, len);
3952 LOP(OP_ACCEPT,XTERM);
3958 LOP(OP_ATAN2,XTERM);
3967 LOP(OP_BLESS,XTERM);
3976 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
3993 if (!PL_cryptseen) {
3994 PL_cryptseen = TRUE;
3998 LOP(OP_CRYPT,XTERM);
4001 if (ckWARN(WARN_CHMOD)) {
4002 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4003 if (*d != '0' && isDIGIT(*d))
4004 Perl_warner(aTHX_ WARN_CHMOD,
4005 "chmod() mode argument is missing initial 0");
4007 LOP(OP_CHMOD,XTERM);
4010 LOP(OP_CHOWN,XTERM);
4013 LOP(OP_CONNECT,XTERM);
4029 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4033 PL_hints |= HINT_BLOCK_SCOPE;
4043 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
4044 LOP(OP_DBMOPEN,XTERM);
4050 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4057 yylval.ival = CopLINE(PL_curcop);
4071 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
4072 UNIBRACK(OP_ENTEREVAL);
4087 case KEY_endhostent:
4093 case KEY_endservent:
4096 case KEY_endprotoent:
4107 yylval.ival = CopLINE(PL_curcop);
4109 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
4111 if ((PL_bufend - p) >= 3 &&
4112 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
4114 else if ((PL_bufend - p) >= 4 &&
4115 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
4118 if (isIDFIRST_lazy_if(p,UTF)) {
4119 p = scan_ident(p, PL_bufend,
4120 PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4124 Perl_croak(aTHX_ "Missing $ on loop variable");
4129 LOP(OP_FORMLINE,XTERM);
4135 LOP(OP_FCNTL,XTERM);
4141 LOP(OP_FLOCK,XTERM);
4150 LOP(OP_GREPSTART, XREF);
4153 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4168 case KEY_getpriority:
4169 LOP(OP_GETPRIORITY,XTERM);
4171 case KEY_getprotobyname:
4174 case KEY_getprotobynumber:
4175 LOP(OP_GPBYNUMBER,XTERM);
4177 case KEY_getprotoent:
4189 case KEY_getpeername:
4190 UNI(OP_GETPEERNAME);
4192 case KEY_gethostbyname:
4195 case KEY_gethostbyaddr:
4196 LOP(OP_GHBYADDR,XTERM);
4198 case KEY_gethostent:
4201 case KEY_getnetbyname:
4204 case KEY_getnetbyaddr:
4205 LOP(OP_GNBYADDR,XTERM);
4210 case KEY_getservbyname:
4211 LOP(OP_GSBYNAME,XTERM);
4213 case KEY_getservbyport:
4214 LOP(OP_GSBYPORT,XTERM);
4216 case KEY_getservent:
4219 case KEY_getsockname:
4220 UNI(OP_GETSOCKNAME);
4222 case KEY_getsockopt:
4223 LOP(OP_GSOCKOPT,XTERM);
4245 yylval.ival = CopLINE(PL_curcop);
4249 LOP(OP_INDEX,XTERM);
4255 LOP(OP_IOCTL,XTERM);
4267 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4299 LOP(OP_LISTEN,XTERM);
4308 s = scan_pat(s,OP_MATCH);
4309 TERM(sublex_start());
4312 LOP(OP_MAPSTART, XREF);
4315 LOP(OP_MKDIR,XTERM);
4318 LOP(OP_MSGCTL,XTERM);
4321 LOP(OP_MSGGET,XTERM);
4324 LOP(OP_MSGRCV,XTERM);
4327 LOP(OP_MSGSND,XTERM);
4333 if (isIDFIRST_lazy_if(s,UTF)) {
4334 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
4335 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
4337 PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
4338 if (!PL_in_my_stash) {
4341 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
4349 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4356 if (PL_expect != XSTATE)
4357 yyerror("\"no\" not allowed in expression");
4358 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4359 s = force_version(s);
4364 if (*s == '(' || (s = skipspace(s), *s == '('))
4371 if (isIDFIRST_lazy_if(s,UTF)) {
4373 for (d = s; isALNUM_lazy_if(d,UTF); d++) ;
4375 if (strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE))
4376 Perl_warner(aTHX_ WARN_PRECEDENCE,
4377 "Precedence problem: open %.*s should be open(%.*s)",
4383 yylval.ival = OP_OR;
4393 LOP(OP_OPEN_DIR,XTERM);
4396 checkcomma(s,PL_tokenbuf,"filehandle");
4400 checkcomma(s,PL_tokenbuf,"filehandle");
4419 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4423 LOP(OP_PIPE_OP,XTERM);
4426 s = scan_str(s,FALSE,FALSE);
4428 missingterm((char*)0);
4429 yylval.ival = OP_CONST;
4430 TERM(sublex_start());
4436 s = scan_str(s,FALSE,FALSE);
4438 missingterm((char*)0);
4440 if (SvCUR(PL_lex_stuff)) {
4443 d = SvPV_force(PL_lex_stuff, len);
4445 for (; isSPACE(*d) && len; --len, ++d) ;
4448 if (!warned && ckWARN(WARN_QW)) {
4449 for (; !isSPACE(*d) && len; --len, ++d) {
4451 Perl_warner(aTHX_ WARN_QW,
4452 "Possible attempt to separate words with commas");
4455 else if (*d == '#') {
4456 Perl_warner(aTHX_ WARN_QW,
4457 "Possible attempt to put comments in qw() list");
4463 for (; !isSPACE(*d) && len; --len, ++d) ;
4465 words = append_elem(OP_LIST, words,
4466 newSVOP(OP_CONST, 0, newSVpvn(b, d-b)));
4470 PL_nextval[PL_nexttoke].opval = words;
4475 SvREFCNT_dec(PL_lex_stuff);
4476 PL_lex_stuff = Nullsv;
4481 s = scan_str(s,FALSE,FALSE);
4483 missingterm((char*)0);
4484 yylval.ival = OP_STRINGIFY;
4485 if (SvIVX(PL_lex_stuff) == '\'')
4486 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
4487 TERM(sublex_start());
4490 s = scan_pat(s,OP_QR);
4491 TERM(sublex_start());
4494 s = scan_str(s,FALSE,FALSE);
4496 missingterm((char*)0);
4497 yylval.ival = OP_BACKTICK;
4499 TERM(sublex_start());
4506 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4507 s = force_version(s);
4510 *PL_tokenbuf = '\0';
4511 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4512 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
4513 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
4515 yyerror("<> should be quotes");
4523 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4527 LOP(OP_RENAME,XTERM);
4536 LOP(OP_RINDEX,XTERM);
4559 LOP(OP_REVERSE,XTERM);
4570 TERM(sublex_start());
4572 TOKEN(1); /* force error */
4581 LOP(OP_SELECT,XTERM);
4587 LOP(OP_SEMCTL,XTERM);
4590 LOP(OP_SEMGET,XTERM);
4593 LOP(OP_SEMOP,XTERM);
4599 LOP(OP_SETPGRP,XTERM);
4601 case KEY_setpriority:
4602 LOP(OP_SETPRIORITY,XTERM);
4604 case KEY_sethostent:
4610 case KEY_setservent:
4613 case KEY_setprotoent:
4623 LOP(OP_SEEKDIR,XTERM);
4625 case KEY_setsockopt:
4626 LOP(OP_SSOCKOPT,XTERM);
4632 LOP(OP_SHMCTL,XTERM);
4635 LOP(OP_SHMGET,XTERM);
4638 LOP(OP_SHMREAD,XTERM);
4641 LOP(OP_SHMWRITE,XTERM);
4644 LOP(OP_SHUTDOWN,XTERM);
4653 LOP(OP_SOCKET,XTERM);
4655 case KEY_socketpair:
4656 LOP(OP_SOCKPAIR,XTERM);
4659 checkcomma(s,PL_tokenbuf,"subroutine name");
4661 if (*s == ';' || *s == ')') /* probably a close */
4662 Perl_croak(aTHX_ "sort is now a reserved word");
4664 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4668 LOP(OP_SPLIT,XTERM);
4671 LOP(OP_SPRINTF,XTERM);
4674 LOP(OP_SPLICE,XTERM);
4689 LOP(OP_SUBSTR,XTERM);
4695 char tmpbuf[sizeof PL_tokenbuf];
4697 expectation attrful;
4698 bool have_name, have_proto;
4703 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
4704 (*s == ':' && s[1] == ':'))
4707 attrful = XATTRBLOCK;
4708 /* remember buffer pos'n for later force_word */
4709 tboffset = s - PL_oldbufptr;
4710 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4711 if (strchr(tmpbuf, ':'))
4712 sv_setpv(PL_subname, tmpbuf);
4714 sv_setsv(PL_subname,PL_curstname);
4715 sv_catpvn(PL_subname,"::",2);
4716 sv_catpvn(PL_subname,tmpbuf,len);
4723 Perl_croak(aTHX_ "Missing name in \"my sub\"");
4724 PL_expect = XTERMBLOCK;
4725 attrful = XATTRTERM;
4726 sv_setpv(PL_subname,"?");
4730 if (key == KEY_format) {
4732 PL_lex_formbrack = PL_lex_brackets + 1;
4734 (void) force_word(PL_oldbufptr + tboffset, WORD,
4739 /* Look for a prototype */
4743 s = scan_str(s,FALSE,FALSE);
4746 SvREFCNT_dec(PL_lex_stuff);
4747 PL_lex_stuff = Nullsv;
4748 Perl_croak(aTHX_ "Prototype not terminated");
4751 d = SvPVX(PL_lex_stuff);
4753 for (p = d; *p; ++p) {
4758 SvCUR(PL_lex_stuff) = tmp;
4766 if (*s == ':' && s[1] != ':')
4767 PL_expect = attrful;
4770 PL_nextval[PL_nexttoke].opval =
4771 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4772 PL_lex_stuff = Nullsv;
4776 sv_setpv(PL_subname,"__ANON__");
4779 (void) force_word(PL_oldbufptr + tboffset, WORD,
4788 LOP(OP_SYSTEM,XREF);
4791 LOP(OP_SYMLINK,XTERM);
4794 LOP(OP_SYSCALL,XTERM);
4797 LOP(OP_SYSOPEN,XTERM);
4800 LOP(OP_SYSSEEK,XTERM);
4803 LOP(OP_SYSREAD,XTERM);
4806 LOP(OP_SYSWRITE,XTERM);
4810 TERM(sublex_start());
4831 LOP(OP_TRUNCATE,XTERM);
4843 yylval.ival = CopLINE(PL_curcop);
4847 yylval.ival = CopLINE(PL_curcop);
4851 LOP(OP_UNLINK,XTERM);
4857 LOP(OP_UNPACK,XTERM);
4860 LOP(OP_UTIME,XTERM);
4863 if (ckWARN(WARN_UMASK)) {
4864 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4865 if (*d != '0' && isDIGIT(*d))
4866 Perl_warner(aTHX_ WARN_UMASK,
4867 "umask: argument is missing initial 0");
4872 LOP(OP_UNSHIFT,XTERM);
4875 if (PL_expect != XSTATE)
4876 yyerror("\"use\" not allowed in expression");
4878 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4879 s = force_version(s);
4880 if (*s == ';' || (s = skipspace(s), *s == ';')) {
4881 PL_nextval[PL_nexttoke].opval = Nullop;
4886 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4887 s = force_version(s);
4899 yylval.ival = CopLINE(PL_curcop);
4903 PL_hints |= HINT_BLOCK_SCOPE;
4910 LOP(OP_WAITPID,XTERM);
4918 static char ctl_l[2];
4920 if (ctl_l[0] == '\0')
4921 ctl_l[0] = toCTRL('L');
4922 gv_fetchpv(ctl_l,TRUE, SVt_PV);
4925 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
4930 if (PL_expect == XOPERATOR)
4936 yylval.ival = OP_XOR;
4941 TERM(sublex_start());
4947 Perl_keyword(pTHX_ register char *d, I32 len)
4952 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
4953 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
4954 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
4955 if (strEQ(d,"__DATA__")) return KEY___DATA__;
4956 if (strEQ(d,"__END__")) return KEY___END__;
4960 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
4965 if (strEQ(d,"and")) return -KEY_and;
4966 if (strEQ(d,"abs")) return -KEY_abs;
4969 if (strEQ(d,"alarm")) return -KEY_alarm;
4970 if (strEQ(d,"atan2")) return -KEY_atan2;
4973 if (strEQ(d,"accept")) return -KEY_accept;
4978 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
4981 if (strEQ(d,"bless")) return -KEY_bless;
4982 if (strEQ(d,"bind")) return -KEY_bind;
4983 if (strEQ(d,"binmode")) return -KEY_binmode;
4986 if (strEQ(d,"CORE")) return -KEY_CORE;
4987 if (strEQ(d,"CHECK")) return KEY_CHECK;
4992 if (strEQ(d,"cmp")) return -KEY_cmp;
4993 if (strEQ(d,"chr")) return -KEY_chr;
4994 if (strEQ(d,"cos")) return -KEY_cos;
4997 if (strEQ(d,"chop")) return KEY_chop;
5000 if (strEQ(d,"close")) return -KEY_close;
5001 if (strEQ(d,"chdir")) return -KEY_chdir;
5002 if (strEQ(d,"chomp")) return KEY_chomp;
5003 if (strEQ(d,"chmod")) return -KEY_chmod;
5004 if (strEQ(d,"chown")) return -KEY_chown;
5005 if (strEQ(d,"crypt")) return -KEY_crypt;
5008 if (strEQ(d,"chroot")) return -KEY_chroot;
5009 if (strEQ(d,"caller")) return -KEY_caller;
5012 if (strEQ(d,"connect")) return -KEY_connect;
5015 if (strEQ(d,"closedir")) return -KEY_closedir;
5016 if (strEQ(d,"continue")) return -KEY_continue;
5021 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
5026 if (strEQ(d,"do")) return KEY_do;
5029 if (strEQ(d,"die")) return -KEY_die;
5032 if (strEQ(d,"dump")) return -KEY_dump;
5035 if (strEQ(d,"delete")) return KEY_delete;
5038 if (strEQ(d,"defined")) return KEY_defined;
5039 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
5042 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
5047 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
5048 if (strEQ(d,"END")) return KEY_END;
5053 if (strEQ(d,"eq")) return -KEY_eq;
5056 if (strEQ(d,"eof")) return -KEY_eof;
5057 if (strEQ(d,"exp")) return -KEY_exp;
5060 if (strEQ(d,"else")) return KEY_else;
5061 if (strEQ(d,"exit")) return -KEY_exit;
5062 if (strEQ(d,"eval")) return KEY_eval;
5063 if (strEQ(d,"exec")) return -KEY_exec;
5064 if (strEQ(d,"each")) return KEY_each;
5067 if (strEQ(d,"elsif")) return KEY_elsif;
5070 if (strEQ(d,"exists")) return KEY_exists;
5071 if (strEQ(d,"elseif")) Perl_warn(aTHX_ "elseif should be elsif");
5074 if (strEQ(d,"endgrent")) return -KEY_endgrent;
5075 if (strEQ(d,"endpwent")) return -KEY_endpwent;
5078 if (strEQ(d,"endnetent")) return -KEY_endnetent;
5081 if (strEQ(d,"endhostent")) return -KEY_endhostent;
5082 if (strEQ(d,"endservent")) return -KEY_endservent;
5085 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
5092 if (strEQ(d,"for")) return KEY_for;
5095 if (strEQ(d,"fork")) return -KEY_fork;
5098 if (strEQ(d,"fcntl")) return -KEY_fcntl;
5099 if (strEQ(d,"flock")) return -KEY_flock;
5102 if (strEQ(d,"format")) return KEY_format;
5103 if (strEQ(d,"fileno")) return -KEY_fileno;
5106 if (strEQ(d,"foreach")) return KEY_foreach;
5109 if (strEQ(d,"formline")) return -KEY_formline;
5115 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
5116 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
5120 if (strnEQ(d,"get",3)) {
5125 if (strEQ(d,"ppid")) return -KEY_getppid;
5126 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
5129 if (strEQ(d,"pwent")) return -KEY_getpwent;
5130 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
5131 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
5134 if (strEQ(d,"peername")) return -KEY_getpeername;
5135 if (strEQ(d,"protoent")) return -KEY_getprotoent;
5136 if (strEQ(d,"priority")) return -KEY_getpriority;
5139 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
5142 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
5146 else if (*d == 'h') {
5147 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
5148 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
5149 if (strEQ(d,"hostent")) return -KEY_gethostent;
5151 else if (*d == 'n') {
5152 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
5153 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
5154 if (strEQ(d,"netent")) return -KEY_getnetent;
5156 else if (*d == 's') {
5157 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
5158 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
5159 if (strEQ(d,"servent")) return -KEY_getservent;
5160 if (strEQ(d,"sockname")) return -KEY_getsockname;
5161 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
5163 else if (*d == 'g') {
5164 if (strEQ(d,"grent")) return -KEY_getgrent;
5165 if (strEQ(d,"grnam")) return -KEY_getgrnam;
5166 if (strEQ(d,"grgid")) return -KEY_getgrgid;
5168 else if (*d == 'l') {
5169 if (strEQ(d,"login")) return -KEY_getlogin;
5171 else if (strEQ(d,"c")) return -KEY_getc;
5176 if (strEQ(d,"gt")) return -KEY_gt;
5177 if (strEQ(d,"ge")) return -KEY_ge;
5180 if (strEQ(d,"grep")) return KEY_grep;
5181 if (strEQ(d,"goto")) return KEY_goto;
5182 if (strEQ(d,"glob")) return KEY_glob;
5185 if (strEQ(d,"gmtime")) return -KEY_gmtime;
5190 if (strEQ(d,"hex")) return -KEY_hex;
5193 if (strEQ(d,"INIT")) return KEY_INIT;
5198 if (strEQ(d,"if")) return KEY_if;
5201 if (strEQ(d,"int")) return -KEY_int;
5204 if (strEQ(d,"index")) return -KEY_index;
5205 if (strEQ(d,"ioctl")) return -KEY_ioctl;
5210 if (strEQ(d,"join")) return -KEY_join;
5214 if (strEQ(d,"keys")) return KEY_keys;
5215 if (strEQ(d,"kill")) return -KEY_kill;
5220 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
5221 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
5227 if (strEQ(d,"lt")) return -KEY_lt;
5228 if (strEQ(d,"le")) return -KEY_le;
5229 if (strEQ(d,"lc")) return -KEY_lc;
5232 if (strEQ(d,"log")) return -KEY_log;
5235 if (strEQ(d,"last")) return KEY_last;
5236 if (strEQ(d,"link")) return -KEY_link;
5237 if (strEQ(d,"lock")) return -KEY_lock;
5240 if (strEQ(d,"local")) return KEY_local;
5241 if (strEQ(d,"lstat")) return -KEY_lstat;
5244 if (strEQ(d,"length")) return -KEY_length;
5245 if (strEQ(d,"listen")) return -KEY_listen;
5248 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
5251 if (strEQ(d,"localtime")) return -KEY_localtime;
5257 case 1: return KEY_m;
5259 if (strEQ(d,"my")) return KEY_my;
5262 if (strEQ(d,"map")) return KEY_map;
5265 if (strEQ(d,"mkdir")) return -KEY_mkdir;
5268 if (strEQ(d,"msgctl")) return -KEY_msgctl;
5269 if (strEQ(d,"msgget")) return -KEY_msgget;
5270 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
5271 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
5276 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
5279 if (strEQ(d,"next")) return KEY_next;
5280 if (strEQ(d,"ne")) return -KEY_ne;
5281 if (strEQ(d,"not")) return -KEY_not;
5282 if (strEQ(d,"no")) return KEY_no;
5287 if (strEQ(d,"or")) return -KEY_or;
5290 if (strEQ(d,"ord")) return -KEY_ord;
5291 if (strEQ(d,"oct")) return -KEY_oct;
5292 if (strEQ(d,"our")) return KEY_our;
5295 if (strEQ(d,"open")) return -KEY_open;
5298 if (strEQ(d,"opendir")) return -KEY_opendir;
5305 if (strEQ(d,"pop")) return KEY_pop;
5306 if (strEQ(d,"pos")) return KEY_pos;
5309 if (strEQ(d,"push")) return KEY_push;
5310 if (strEQ(d,"pack")) return -KEY_pack;
5311 if (strEQ(d,"pipe")) return -KEY_pipe;
5314 if (strEQ(d,"print")) return KEY_print;
5317 if (strEQ(d,"printf")) return KEY_printf;
5320 if (strEQ(d,"package")) return KEY_package;
5323 if (strEQ(d,"prototype")) return KEY_prototype;
5328 if (strEQ(d,"q")) return KEY_q;
5329 if (strEQ(d,"qr")) return KEY_qr;
5330 if (strEQ(d,"qq")) return KEY_qq;
5331 if (strEQ(d,"qw")) return KEY_qw;
5332 if (strEQ(d,"qx")) return KEY_qx;
5334 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
5339 if (strEQ(d,"ref")) return -KEY_ref;
5342 if (strEQ(d,"read")) return -KEY_read;
5343 if (strEQ(d,"rand")) return -KEY_rand;
5344 if (strEQ(d,"recv")) return -KEY_recv;
5345 if (strEQ(d,"redo")) return KEY_redo;
5348 if (strEQ(d,"rmdir")) return -KEY_rmdir;
5349 if (strEQ(d,"reset")) return -KEY_reset;
5352 if (strEQ(d,"return")) return KEY_return;
5353 if (strEQ(d,"rename")) return -KEY_rename;
5354 if (strEQ(d,"rindex")) return -KEY_rindex;
5357 if (strEQ(d,"require")) return -KEY_require;
5358 if (strEQ(d,"reverse")) return -KEY_reverse;
5359 if (strEQ(d,"readdir")) return -KEY_readdir;
5362 if (strEQ(d,"readlink")) return -KEY_readlink;
5363 if (strEQ(d,"readline")) return -KEY_readline;
5364 if (strEQ(d,"readpipe")) return -KEY_readpipe;
5367 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
5373 case 0: return KEY_s;
5375 if (strEQ(d,"scalar")) return KEY_scalar;
5380 if (strEQ(d,"seek")) return -KEY_seek;
5381 if (strEQ(d,"send")) return -KEY_send;
5384 if (strEQ(d,"semop")) return -KEY_semop;
5387 if (strEQ(d,"select")) return -KEY_select;
5388 if (strEQ(d,"semctl")) return -KEY_semctl;
5389 if (strEQ(d,"semget")) return -KEY_semget;
5392 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
5393 if (strEQ(d,"seekdir")) return -KEY_seekdir;
5396 if (strEQ(d,"setpwent")) return -KEY_setpwent;
5397 if (strEQ(d,"setgrent")) return -KEY_setgrent;
5400 if (strEQ(d,"setnetent")) return -KEY_setnetent;
5403 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
5404 if (strEQ(d,"sethostent")) return -KEY_sethostent;
5405 if (strEQ(d,"setservent")) return -KEY_setservent;
5408 if (strEQ(d,"setpriority")) return -KEY_setpriority;
5409 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
5416 if (strEQ(d,"shift")) return KEY_shift;
5419 if (strEQ(d,"shmctl")) return -KEY_shmctl;
5420 if (strEQ(d,"shmget")) return -KEY_shmget;
5423 if (strEQ(d,"shmread")) return -KEY_shmread;
5426 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
5427 if (strEQ(d,"shutdown")) return -KEY_shutdown;
5432 if (strEQ(d,"sin")) return -KEY_sin;
5435 if (strEQ(d,"sleep")) return -KEY_sleep;
5438 if (strEQ(d,"sort")) return KEY_sort;
5439 if (strEQ(d,"socket")) return -KEY_socket;
5440 if (strEQ(d,"socketpair")) return -KEY_socketpair;
5443 if (strEQ(d,"split")) return KEY_split;
5444 if (strEQ(d,"sprintf")) return -KEY_sprintf;
5445 if (strEQ(d,"splice")) return KEY_splice;
5448 if (strEQ(d,"sqrt")) return -KEY_sqrt;
5451 if (strEQ(d,"srand")) return -KEY_srand;
5454 if (strEQ(d,"stat")) return -KEY_stat;
5455 if (strEQ(d,"study")) return KEY_study;
5458 if (strEQ(d,"substr")) return -KEY_substr;
5459 if (strEQ(d,"sub")) return KEY_sub;
5464 if (strEQ(d,"system")) return -KEY_system;
5467 if (strEQ(d,"symlink")) return -KEY_symlink;
5468 if (strEQ(d,"syscall")) return -KEY_syscall;
5469 if (strEQ(d,"sysopen")) return -KEY_sysopen;
5470 if (strEQ(d,"sysread")) return -KEY_sysread;
5471 if (strEQ(d,"sysseek")) return -KEY_sysseek;
5474 if (strEQ(d,"syswrite")) return -KEY_syswrite;
5483 if (strEQ(d,"tr")) return KEY_tr;
5486 if (strEQ(d,"tie")) return KEY_tie;
5489 if (strEQ(d,"tell")) return -KEY_tell;
5490 if (strEQ(d,"tied")) return KEY_tied;
5491 if (strEQ(d,"time")) return -KEY_time;
5494 if (strEQ(d,"times")) return -KEY_times;
5497 if (strEQ(d,"telldir")) return -KEY_telldir;
5500 if (strEQ(d,"truncate")) return -KEY_truncate;
5507 if (strEQ(d,"uc")) return -KEY_uc;
5510 if (strEQ(d,"use")) return KEY_use;
5513 if (strEQ(d,"undef")) return KEY_undef;
5514 if (strEQ(d,"until")) return KEY_until;
5515 if (strEQ(d,"untie")) return KEY_untie;
5516 if (strEQ(d,"utime")) return -KEY_utime;
5517 if (strEQ(d,"umask")) return -KEY_umask;
5520 if (strEQ(d,"unless")) return KEY_unless;
5521 if (strEQ(d,"unpack")) return -KEY_unpack;
5522 if (strEQ(d,"unlink")) return -KEY_unlink;
5525 if (strEQ(d,"unshift")) return KEY_unshift;
5526 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
5531 if (strEQ(d,"values")) return -KEY_values;
5532 if (strEQ(d,"vec")) return -KEY_vec;
5537 if (strEQ(d,"warn")) return -KEY_warn;
5538 if (strEQ(d,"wait")) return -KEY_wait;
5541 if (strEQ(d,"while")) return KEY_while;
5542 if (strEQ(d,"write")) return -KEY_write;
5545 if (strEQ(d,"waitpid")) return -KEY_waitpid;
5548 if (strEQ(d,"wantarray")) return -KEY_wantarray;
5553 if (len == 1) return -KEY_x;
5554 if (strEQ(d,"xor")) return -KEY_xor;
5557 if (len == 1) return KEY_y;
5566 S_checkcomma(pTHX_ register char *s, char *name, char *what)
5570 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
5571 dTHR; /* only for ckWARN */
5572 if (ckWARN(WARN_SYNTAX)) {
5574 for (w = s+2; *w && level; w++) {
5581 for (; *w && isSPACE(*w); w++) ;
5582 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
5583 Perl_warner(aTHX_ WARN_SYNTAX,
5584 "%s (...) interpreted as function",name);
5587 while (s < PL_bufend && isSPACE(*s))
5591 while (s < PL_bufend && isSPACE(*s))
5593 if (isIDFIRST_lazy_if(s,UTF)) {
5595 while (isALNUM_lazy_if(s,UTF))
5597 while (s < PL_bufend && isSPACE(*s))
5602 kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
5606 Perl_croak(aTHX_ "No comma allowed after %s", what);
5611 /* Either returns sv, or mortalizes sv and returns a new SV*.
5612 Best used as sv=new_constant(..., sv, ...).
5613 If s, pv are NULL, calls subroutine with one argument,
5614 and type is used with error messages only. */
5617 S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv,
5621 HV *table = GvHV(PL_hintgv); /* ^H */
5625 const char *why, *why1, *why2;
5627 if (!(PL_hints & HINT_LOCALIZE_HH)) {
5630 why = "%^H is not localized";
5634 msg = Perl_newSVpvf(aTHX_ "constant(%s): %s%s%s",
5635 (type ? type: "undef"), why1, why2, why);
5636 yyerror(SvPVX(msg));
5641 why = "%^H is not defined";
5644 cvp = hv_fetch(table, key, strlen(key), FALSE);
5645 if (!cvp || !SvOK(*cvp)) {
5646 why = "} is not defined";
5651 sv_2mortal(sv); /* Parent created it permanently */
5654 pv = sv_2mortal(newSVpvn(s, len));
5656 typesv = sv_2mortal(newSVpv(type, 0));
5658 typesv = &PL_sv_undef;
5660 PUSHSTACKi(PERLSI_OVERLOAD);
5673 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
5677 /* Check the eval first */
5678 if (!PL_in_eval && SvTRUE(ERRSV))
5681 sv_catpv(ERRSV, "Propagated");
5682 yyerror(SvPV(ERRSV, n_a)); /* Duplicates the message inside eval */
5684 res = SvREFCNT_inc(sv);
5688 (void)SvREFCNT_inc(res);
5697 why = "}} did not return a defined value";
5698 why1 = "Call to &{$^H{";
5708 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
5710 register char *d = dest;
5711 register char *e = d + destlen - 3; /* two-character token, ending NUL */
5714 Perl_croak(aTHX_ ident_too_long);
5715 if (isALNUM(*s)) /* UTF handled below */
5717 else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) {
5722 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
5726 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5727 char *t = s + UTF8SKIP(s);
5728 while (*t & 0x80 && is_utf8_mark((U8*)t))
5730 if (d + (t - s) > e)
5731 Perl_croak(aTHX_ ident_too_long);
5732 Copy(s, d, t - s, char);
5745 S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
5755 e = d + destlen - 3; /* two-character token, ending NUL */
5757 while (isDIGIT(*s)) {
5759 Perl_croak(aTHX_ ident_too_long);
5766 Perl_croak(aTHX_ ident_too_long);
5767 if (isALNUM(*s)) /* UTF handled below */
5769 else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
5774 else if (*s == ':' && s[1] == ':') {
5778 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5779 char *t = s + UTF8SKIP(s);
5780 while (*t & 0x80 && is_utf8_mark((U8*)t))
5782 if (d + (t - s) > e)
5783 Perl_croak(aTHX_ ident_too_long);
5784 Copy(s, d, t - s, char);
5795 if (PL_lex_state != LEX_NORMAL)
5796 PL_lex_state = LEX_INTERPENDMAYBE;
5799 if (*s == '$' && s[1] &&
5800 (isALNUM_lazy_if(s+1,UTF) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
5813 if (*d == '^' && *s && isCONTROLVAR(*s)) {
5818 if (isSPACE(s[-1])) {
5821 if (ch != ' ' && ch != '\t') {
5827 if (isIDFIRST_lazy_if(d,UTF)) {
5831 while (e < send && isALNUM_lazy_if(e,UTF) || *e == ':') {
5833 while (e < send && *e & 0x80 && is_utf8_mark((U8*)e))
5836 Copy(s, d, e - s, char);
5841 while ((isALNUM(*s) || *s == ':') && d < e)
5844 Perl_croak(aTHX_ ident_too_long);
5847 while (s < send && (*s == ' ' || *s == '\t')) s++;
5848 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
5849 dTHR; /* only for ckWARN */
5850 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
5851 const char *brack = *s == '[' ? "[...]" : "{...}";
5852 Perl_warner(aTHX_ WARN_AMBIGUOUS,
5853 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
5854 funny, dest, brack, funny, dest, brack);
5857 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
5861 /* Handle extended ${^Foo} variables
5862 * 1999-02-27 mjd-perl-patch@plover.com */
5863 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
5867 while (isALNUM(*s) && d < e) {
5871 Perl_croak(aTHX_ ident_too_long);
5876 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
5877 PL_lex_state = LEX_INTERPEND;
5880 if (PL_lex_state == LEX_NORMAL) {
5881 dTHR; /* only for ckWARN */
5882 if (ckWARN(WARN_AMBIGUOUS) &&
5883 (keyword(dest, d - dest) || get_cv(dest, FALSE)))
5885 Perl_warner(aTHX_ WARN_AMBIGUOUS,
5886 "Ambiguous use of %c{%s} resolved to %c%s",
5887 funny, dest, funny, dest);
5892 s = bracket; /* let the parser handle it */
5896 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
5897 PL_lex_state = LEX_INTERPEND;
5902 Perl_pmflag(pTHX_ U16 *pmfl, int ch)
5907 *pmfl |= PMf_GLOBAL;
5909 *pmfl |= PMf_CONTINUE;
5913 *pmfl |= PMf_MULTILINE;
5915 *pmfl |= PMf_SINGLELINE;
5917 *pmfl |= PMf_EXTENDED;
5921 S_scan_pat(pTHX_ char *start, I32 type)
5926 s = scan_str(start,FALSE,FALSE);
5929 SvREFCNT_dec(PL_lex_stuff);
5930 PL_lex_stuff = Nullsv;
5931 Perl_croak(aTHX_ "Search pattern not terminated");
5934 pm = (PMOP*)newPMOP(type, 0);
5935 if (PL_multi_open == '?')
5936 pm->op_pmflags |= PMf_ONCE;
5938 while (*s && strchr("iomsx", *s))
5939 pmflag(&pm->op_pmflags,*s++);
5942 while (*s && strchr("iogcmsx", *s))
5943 pmflag(&pm->op_pmflags,*s++);
5945 pm->op_pmpermflags = pm->op_pmflags;
5947 PL_lex_op = (OP*)pm;
5948 yylval.ival = OP_MATCH;
5953 S_scan_subst(pTHX_ char *start)
5960 yylval.ival = OP_NULL;
5962 s = scan_str(start,FALSE,FALSE);
5966 SvREFCNT_dec(PL_lex_stuff);
5967 PL_lex_stuff = Nullsv;
5968 Perl_croak(aTHX_ "Substitution pattern not terminated");
5971 if (s[-1] == PL_multi_open)
5974 first_start = PL_multi_start;
5975 s = scan_str(s,FALSE,FALSE);
5978 SvREFCNT_dec(PL_lex_stuff);
5979 PL_lex_stuff = Nullsv;
5981 SvREFCNT_dec(PL_lex_repl);
5982 PL_lex_repl = Nullsv;
5983 Perl_croak(aTHX_ "Substitution replacement not terminated");
5985 PL_multi_start = first_start; /* so whole substitution is taken together */
5987 pm = (PMOP*)newPMOP(OP_SUBST, 0);
5993 else if (strchr("iogcmsx", *s))
5994 pmflag(&pm->op_pmflags,*s++);
6001 PL_sublex_info.super_bufptr = s;
6002 PL_sublex_info.super_bufend = PL_bufend;
6004 pm->op_pmflags |= PMf_EVAL;
6005 repl = newSVpvn("",0);
6007 sv_catpv(repl, es ? "eval " : "do ");
6008 sv_catpvn(repl, "{ ", 2);
6009 sv_catsv(repl, PL_lex_repl);
6010 sv_catpvn(repl, " };", 2);
6012 SvREFCNT_dec(PL_lex_repl);
6016 pm->op_pmpermflags = pm->op_pmflags;
6017 PL_lex_op = (OP*)pm;
6018 yylval.ival = OP_SUBST;
6023 S_scan_trans(pTHX_ char *start)
6034 yylval.ival = OP_NULL;
6036 s = scan_str(start,FALSE,FALSE);
6039 SvREFCNT_dec(PL_lex_stuff);
6040 PL_lex_stuff = Nullsv;
6041 Perl_croak(aTHX_ "Transliteration pattern not terminated");
6043 if (s[-1] == PL_multi_open)
6046 s = scan_str(s,FALSE,FALSE);
6049 SvREFCNT_dec(PL_lex_stuff);
6050 PL_lex_stuff = Nullsv;
6052 SvREFCNT_dec(PL_lex_repl);
6053 PL_lex_repl = Nullsv;
6054 Perl_croak(aTHX_ "Transliteration replacement not terminated");
6058 o = newSVOP(OP_TRANS, 0, 0);
6059 utf8 = OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF;
6062 New(803,tbl,256,short);
6063 o = newPVOP(OP_TRANS, 0, (char*)tbl);
6067 complement = del = squash = 0;
6068 while (strchr("cdsCU", *s)) {
6070 complement = OPpTRANS_COMPLEMENT;
6072 del = OPpTRANS_DELETE;
6074 squash = OPpTRANS_SQUASH;
6079 utf8 &= ~OPpTRANS_FROM_UTF;
6081 utf8 |= OPpTRANS_FROM_UTF;
6085 utf8 &= ~OPpTRANS_TO_UTF;
6087 utf8 |= OPpTRANS_TO_UTF;
6090 Perl_croak(aTHX_ "Too many /C and /U options");
6095 o->op_private = del|squash|complement|utf8;
6098 yylval.ival = OP_TRANS;
6103 S_scan_heredoc(pTHX_ register char *s)
6107 I32 op_type = OP_SCALAR;
6114 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
6118 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
6121 for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
6122 if (*peek && strchr("`'\"",*peek)) {
6125 s = delimcpy(d, e, s, PL_bufend, term, &len);
6135 if (!isALNUM_lazy_if(s,UTF))
6136 deprecate("bare << to mean <<\"\"");
6137 for (; isALNUM_lazy_if(s,UTF); s++) {
6142 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
6143 Perl_croak(aTHX_ "Delimiter for here document is too long");
6146 len = d - PL_tokenbuf;
6147 #ifndef PERL_STRICT_CR
6148 d = strchr(s, '\r');
6152 while (s < PL_bufend) {
6158 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
6167 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6172 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
6173 herewas = newSVpvn(s,PL_bufend-s);
6175 s--, herewas = newSVpvn(s,d-s);
6176 s += SvCUR(herewas);
6178 tmpstr = NEWSV(87,79);
6179 sv_upgrade(tmpstr, SVt_PVIV);
6184 else if (term == '`') {
6185 op_type = OP_BACKTICK;
6186 SvIVX(tmpstr) = '\\';
6190 PL_multi_start = CopLINE(PL_curcop);
6191 PL_multi_open = PL_multi_close = '<';
6192 term = *PL_tokenbuf;
6193 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
6194 char *bufptr = PL_sublex_info.super_bufptr;
6195 char *bufend = PL_sublex_info.super_bufend;
6196 char *olds = s - SvCUR(herewas);
6197 s = strchr(bufptr, '\n');
6201 while (s < bufend &&
6202 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6204 CopLINE_inc(PL_curcop);
6207 CopLINE_set(PL_curcop, PL_multi_start);
6208 missingterm(PL_tokenbuf);
6210 sv_setpvn(herewas,bufptr,d-bufptr+1);
6211 sv_setpvn(tmpstr,d+1,s-d);
6213 sv_catpvn(herewas,s,bufend-s);
6214 (void)strcpy(bufptr,SvPVX(herewas));
6221 while (s < PL_bufend &&
6222 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6224 CopLINE_inc(PL_curcop);
6226 if (s >= PL_bufend) {
6227 CopLINE_set(PL_curcop, PL_multi_start);
6228 missingterm(PL_tokenbuf);
6230 sv_setpvn(tmpstr,d+1,s-d);
6232 CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
6234 sv_catpvn(herewas,s,PL_bufend-s);
6235 sv_setsv(PL_linestr,herewas);
6236 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
6237 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6240 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
6241 while (s >= PL_bufend) { /* multiple line string? */
6243 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6244 CopLINE_set(PL_curcop, PL_multi_start);
6245 missingterm(PL_tokenbuf);
6247 CopLINE_inc(PL_curcop);
6248 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6249 #ifndef PERL_STRICT_CR
6250 if (PL_bufend - PL_linestart >= 2) {
6251 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
6252 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
6254 PL_bufend[-2] = '\n';
6256 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6258 else if (PL_bufend[-1] == '\r')
6259 PL_bufend[-1] = '\n';
6261 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
6262 PL_bufend[-1] = '\n';
6264 if (PERLDB_LINE && PL_curstash != PL_debstash) {
6265 SV *sv = NEWSV(88,0);
6267 sv_upgrade(sv, SVt_PVMG);
6268 sv_setsv(sv,PL_linestr);
6269 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop),sv);
6271 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
6274 sv_catsv(PL_linestr,herewas);
6275 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6279 sv_catsv(tmpstr,PL_linestr);
6284 PL_multi_end = CopLINE(PL_curcop);
6285 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
6286 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
6287 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
6289 SvREFCNT_dec(herewas);
6290 PL_lex_stuff = tmpstr;
6291 yylval.ival = op_type;
6296 takes: current position in input buffer
6297 returns: new position in input buffer
6298 side-effects: yylval and lex_op are set.
6303 <FH> read from filehandle
6304 <pkg::FH> read from package qualified filehandle
6305 <pkg'FH> read from package qualified filehandle
6306 <$fh> read from filehandle in $fh
6312 S_scan_inputsymbol(pTHX_ char *start)
6314 register char *s = start; /* current position in buffer */
6320 d = PL_tokenbuf; /* start of temp holding space */
6321 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
6322 end = strchr(s, '\n');
6325 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
6327 /* die if we didn't have space for the contents of the <>,
6328 or if it didn't end, or if we see a newline
6331 if (len >= sizeof PL_tokenbuf)
6332 Perl_croak(aTHX_ "Excessively long <> operator");
6334 Perl_croak(aTHX_ "Unterminated <> operator");
6339 Remember, only scalar variables are interpreted as filehandles by
6340 this code. Anything more complex (e.g., <$fh{$num}>) will be
6341 treated as a glob() call.
6342 This code makes use of the fact that except for the $ at the front,
6343 a scalar variable and a filehandle look the same.
6345 if (*d == '$' && d[1]) d++;
6347 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
6348 while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
6351 /* If we've tried to read what we allow filehandles to look like, and
6352 there's still text left, then it must be a glob() and not a getline.
6353 Use scan_str to pull out the stuff between the <> and treat it
6354 as nothing more than a string.
6357 if (d - PL_tokenbuf != len) {
6358 yylval.ival = OP_GLOB;
6360 s = scan_str(start,FALSE,FALSE);
6362 Perl_croak(aTHX_ "Glob not terminated");
6366 /* we're in a filehandle read situation */
6369 /* turn <> into <ARGV> */
6371 (void)strcpy(d,"ARGV");
6373 /* if <$fh>, create the ops to turn the variable into a
6379 /* try to find it in the pad for this block, otherwise find
6380 add symbol table ops
6382 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
6383 OP *o = newOP(OP_PADSV, 0);
6385 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, o);
6388 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
6389 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
6390 newUNOP(OP_RV2SV, 0,
6391 newGVOP(OP_GV, 0, gv)));
6393 PL_lex_op->op_flags |= OPf_SPECIAL;
6394 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
6395 yylval.ival = OP_NULL;
6398 /* If it's none of the above, it must be a literal filehandle
6399 (<Foo::BAR> or <FOO>) so build a simple readline OP */
6401 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
6402 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
6403 yylval.ival = OP_NULL;
6412 takes: start position in buffer
6413 keep_quoted preserve \ on the embedded delimiter(s)
6414 keep_delims preserve the delimiters around the string
6415 returns: position to continue reading from buffer
6416 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
6417 updates the read buffer.
6419 This subroutine pulls a string out of the input. It is called for:
6420 q single quotes q(literal text)
6421 ' single quotes 'literal text'
6422 qq double quotes qq(interpolate $here please)
6423 " double quotes "interpolate $here please"
6424 qx backticks qx(/bin/ls -l)
6425 ` backticks `/bin/ls -l`
6426 qw quote words @EXPORT_OK = qw( func() $spam )
6427 m// regexp match m/this/
6428 s/// regexp substitute s/this/that/
6429 tr/// string transliterate tr/this/that/
6430 y/// string transliterate y/this/that/
6431 ($*@) sub prototypes sub foo ($)
6432 (stuff) sub attr parameters sub foo : attr(stuff)
6433 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
6435 In most of these cases (all but <>, patterns and transliterate)
6436 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
6437 calls scan_str(). s/// makes yylex() call scan_subst() which calls
6438 scan_str(). tr/// and y/// make yylex() call scan_trans() which
6441 It skips whitespace before the string starts, and treats the first
6442 character as the delimiter. If the delimiter is one of ([{< then
6443 the corresponding "close" character )]}> is used as the closing
6444 delimiter. It allows quoting of delimiters, and if the string has
6445 balanced delimiters ([{<>}]) it allows nesting.
6447 The lexer always reads these strings into lex_stuff, except in the
6448 case of the operators which take *two* arguments (s/// and tr///)
6449 when it checks to see if lex_stuff is full (presumably with the 1st
6450 arg to s or tr) and if so puts the string into lex_repl.
6455 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
6458 SV *sv; /* scalar value: string */
6459 char *tmps; /* temp string, used for delimiter matching */
6460 register char *s = start; /* current position in the buffer */
6461 register char term; /* terminating character */
6462 register char *to; /* current position in the sv's data */
6463 I32 brackets = 1; /* bracket nesting level */
6464 bool has_utf = FALSE; /* is there any utf8 content? */
6466 /* skip space before the delimiter */
6470 /* mark where we are, in case we need to report errors */
6473 /* after skipping whitespace, the next character is the terminator */
6475 if ((term & 0x80) && UTF)
6478 /* mark where we are */
6479 PL_multi_start = CopLINE(PL_curcop);
6480 PL_multi_open = term;
6482 /* find corresponding closing delimiter */
6483 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
6485 PL_multi_close = term;
6487 /* create a new SV to hold the contents. 87 is leak category, I'm
6488 assuming. 79 is the SV's initial length. What a random number. */
6490 sv_upgrade(sv, SVt_PVIV);
6492 (void)SvPOK_only(sv); /* validate pointer */
6494 /* move past delimiter and try to read a complete string */
6496 sv_catpvn(sv, s, 1);
6499 /* extend sv if need be */
6500 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
6501 /* set 'to' to the next character in the sv's string */
6502 to = SvPVX(sv)+SvCUR(sv);
6504 /* if open delimiter is the close delimiter read unbridle */
6505 if (PL_multi_open == PL_multi_close) {
6506 for (; s < PL_bufend; s++,to++) {
6507 /* embedded newlines increment the current line number */
6508 if (*s == '\n' && !PL_rsfp)
6509 CopLINE_inc(PL_curcop);
6510 /* handle quoted delimiters */
6511 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
6512 if (!keep_quoted && s[1] == term)
6514 /* any other quotes are simply copied straight through */
6518 /* terminate when run out of buffer (the for() condition), or
6519 have found the terminator */
6520 else if (*s == term)
6522 else if (!has_utf && (*s & 0x80) && UTF)
6528 /* if the terminator isn't the same as the start character (e.g.,
6529 matched brackets), we have to allow more in the quoting, and
6530 be prepared for nested brackets.
6533 /* read until we run out of string, or we find the terminator */
6534 for (; s < PL_bufend; s++,to++) {
6535 /* embedded newlines increment the line count */
6536 if (*s == '\n' && !PL_rsfp)
6537 CopLINE_inc(PL_curcop);
6538 /* backslashes can escape the open or closing characters */
6539 if (*s == '\\' && s+1 < PL_bufend) {
6541 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
6546 /* allow nested opens and closes */
6547 else if (*s == PL_multi_close && --brackets <= 0)
6549 else if (*s == PL_multi_open)
6551 else if (!has_utf && (*s & 0x80) && UTF)
6556 /* terminate the copied string and update the sv's end-of-string */
6558 SvCUR_set(sv, to - SvPVX(sv));
6561 * this next chunk reads more into the buffer if we're not done yet
6565 break; /* handle case where we are done yet :-) */
6567 #ifndef PERL_STRICT_CR
6568 if (to - SvPVX(sv) >= 2) {
6569 if ((to[-2] == '\r' && to[-1] == '\n') ||
6570 (to[-2] == '\n' && to[-1] == '\r'))
6574 SvCUR_set(sv, to - SvPVX(sv));
6576 else if (to[-1] == '\r')
6579 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
6583 /* if we're out of file, or a read fails, bail and reset the current
6584 line marker so we can report where the unterminated string began
6587 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6589 CopLINE_set(PL_curcop, PL_multi_start);
6592 /* we read a line, so increment our line counter */
6593 CopLINE_inc(PL_curcop);
6595 /* update debugger info */
6596 if (PERLDB_LINE && PL_curstash != PL_debstash) {
6597 SV *sv = NEWSV(88,0);
6599 sv_upgrade(sv, SVt_PVMG);
6600 sv_setsv(sv,PL_linestr);
6601 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop), sv);
6604 /* having changed the buffer, we must update PL_bufend */
6605 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6608 /* at this point, we have successfully read the delimited string */
6611 sv_catpvn(sv, s, 1);
6614 PL_multi_end = CopLINE(PL_curcop);
6617 /* if we allocated too much space, give some back */
6618 if (SvCUR(sv) + 5 < SvLEN(sv)) {
6619 SvLEN_set(sv, SvCUR(sv) + 1);
6620 Renew(SvPVX(sv), SvLEN(sv), char);
6623 /* decide whether this is the first or second quoted string we've read
6636 takes: pointer to position in buffer
6637 returns: pointer to new position in buffer
6638 side-effects: builds ops for the constant in yylval.op
6640 Read a number in any of the formats that Perl accepts:
6642 0(x[0-7A-F]+)|([0-7]+)|(b[01])
6643 [\d_]+(\.[\d_]*)?[Ee](\d+)
6645 Underbars (_) are allowed in decimal numbers. If -w is on,
6646 underbars before a decimal point must be at three digit intervals.
6648 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
6651 If it reads a number without a decimal point or an exponent, it will
6652 try converting the number to an integer and see if it can do so
6653 without loss of precision.
6657 Perl_scan_num(pTHX_ char *start)
6659 register char *s = start; /* current position in buffer */
6660 register char *d; /* destination in temp buffer */
6661 register char *e; /* end of temp buffer */
6662 IV tryiv; /* used to see if it can be an IV */
6663 NV value; /* number read, as a double */
6664 SV *sv = Nullsv; /* place to put the converted number */
6665 bool floatit; /* boolean: int or float? */
6666 char *lastub = 0; /* position of last underbar */
6667 static char number_too_long[] = "Number too long";
6669 /* We use the first character to decide what type of number this is */
6673 Perl_croak(aTHX_ "panic: scan_num");
6675 /* if it starts with a 0, it could be an octal number, a decimal in
6676 0.13 disguise, or a hexadecimal number, or a binary number. */
6680 u holds the "number so far"
6681 shift the power of 2 of the base
6682 (hex == 4, octal == 3, binary == 1)
6683 overflowed was the number more than we can hold?
6685 Shift is used when we add a digit. It also serves as an "are
6686 we in octal/hex/binary?" indicator to disallow hex characters
6693 bool overflowed = FALSE;
6694 static NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
6695 static char* bases[5] = { "", "binary", "", "octal",
6697 static char* Bases[5] = { "", "Binary", "", "Octal",
6699 static char *maxima[5] = { "",
6700 "0b11111111111111111111111111111111",
6704 char *base, *Base, *max;
6710 } else if (s[1] == 'b') {
6714 /* check for a decimal in disguise */
6715 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
6717 /* so it must be octal */
6721 base = bases[shift];
6722 Base = Bases[shift];
6723 max = maxima[shift];
6725 /* read the rest of the number */
6727 /* x is used in the overflow test,
6728 b is the digit we're adding on. */
6733 /* if we don't mention it, we're done */
6742 /* 8 and 9 are not octal */
6745 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
6749 case '2': case '3': case '4':
6750 case '5': case '6': case '7':
6752 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
6756 b = *s++ & 15; /* ASCII digit -> value of digit */
6760 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
6761 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
6762 /* make sure they said 0x */
6767 /* Prepare to put the digit we have onto the end
6768 of the number so far. We check for overflows.
6773 x = u << shift; /* make room for the digit */
6775 if ((x >> shift) != u
6776 && !(PL_hints & HINT_NEW_BINARY)) {
6780 if (ckWARN_d(WARN_OVERFLOW))
6781 Perl_warner(aTHX_ WARN_OVERFLOW,
6782 "Integer overflow in %s number",
6785 u = x | b; /* add the digit to the end */
6788 n *= nvshift[shift];
6789 /* If an NV has not enough bits in its
6790 * mantissa to represent an UV this summing of
6791 * small low-order numbers is a waste of time
6792 * (because the NV cannot preserve the
6793 * low-order bits anyway): we could just
6794 * remember when did we overflow and in the
6795 * end just multiply n by the right
6803 /* if we get here, we had success: make a scalar value from
6810 if (ckWARN(WARN_PORTABLE) && n > 4294967295.0)
6811 Perl_warner(aTHX_ WARN_PORTABLE,
6812 "%s number > %s non-portable",
6819 if (ckWARN(WARN_PORTABLE) && u > 0xffffffff)
6820 Perl_warner(aTHX_ WARN_PORTABLE,
6821 "%s number > %s non-portable",
6826 if (PL_hints & HINT_NEW_BINARY)
6827 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
6832 handle decimal numbers.
6833 we're also sent here when we read a 0 as the first digit
6835 case '1': case '2': case '3': case '4': case '5':
6836 case '6': case '7': case '8': case '9': case '.':
6839 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
6842 /* read next group of digits and _ and copy into d */
6843 while (isDIGIT(*s) || *s == '_') {
6844 /* skip underscores, checking for misplaced ones
6848 dTHR; /* only for ckWARN */
6849 if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
6850 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
6854 /* check for end of fixed-length buffer */
6856 Perl_croak(aTHX_ number_too_long);
6857 /* if we're ok, copy the character */
6862 /* final misplaced underbar check */
6863 if (lastub && s - lastub != 3) {
6865 if (ckWARN(WARN_SYNTAX))
6866 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
6869 /* read a decimal portion if there is one. avoid
6870 3..5 being interpreted as the number 3. followed
6873 if (*s == '.' && s[1] != '.') {
6877 /* copy, ignoring underbars, until we run out of
6878 digits. Note: no misplaced underbar checks!
6880 for (; isDIGIT(*s) || *s == '_'; s++) {
6881 /* fixed length buffer check */
6883 Perl_croak(aTHX_ number_too_long);
6887 if (*s == '.' && isDIGIT(s[1])) {
6888 /* oops, it's really a v-string, but without the "v" */
6894 /* read exponent part, if present */
6895 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
6899 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
6900 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
6902 /* allow positive or negative exponent */
6903 if (*s == '+' || *s == '-')
6906 /* read digits of exponent (no underbars :-) */
6907 while (isDIGIT(*s)) {
6909 Perl_croak(aTHX_ number_too_long);
6914 /* terminate the string */
6917 /* make an sv from the string */
6920 value = Atof(PL_tokenbuf);
6923 See if we can make do with an integer value without loss of
6924 precision. We use I_V to cast to an int, because some
6925 compilers have issues. Then we try casting it back and see
6926 if it was the same. We only do this if we know we
6927 specifically read an integer.
6929 Note: if floatit is true, then we don't need to do the
6933 if (!floatit && (NV)tryiv == value)
6934 sv_setiv(sv, tryiv);
6936 sv_setnv(sv, value);
6937 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
6938 (PL_hints & HINT_NEW_INTEGER) )
6939 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
6940 (floatit ? "float" : "integer"),
6943 /* if it starts with a v, it could be a version number */
6949 while (isDIGIT(*pos) || *pos == '_')
6951 if (!isALPHA(*pos)) {
6953 U8 tmpbuf[UTF8_MAXLEN];
6956 s++; /* get past 'v' */
6959 sv_setpvn(sv, "", 0);
6962 if (*s == '0' && isDIGIT(s[1]))
6963 yyerror("Octal number in vector unsupported");
6966 /* this is atoi() that tolerates underscores */
6969 while (--end >= s) {
6974 rev += (*end - '0') * mult;
6976 if (orev > rev && ckWARN_d(WARN_OVERFLOW))
6977 Perl_warner(aTHX_ WARN_OVERFLOW,
6978 "Integer overflow in decimal number");
6981 tmpend = uv_to_utf8(tmpbuf, rev);
6982 utf8 = utf8 || rev > 127;
6983 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
6984 if (*pos == '.' && isDIGIT(pos[1]))
6990 while (isDIGIT(*pos) || *pos == '_')
6998 sv_utf8_downgrade(sv, TRUE);
7005 /* make the op for the constant and return */
7008 yylval.opval = newSVOP(OP_CONST, 0, sv);
7010 yylval.opval = Nullop;
7016 S_scan_formline(pTHX_ register char *s)
7021 SV *stuff = newSVpvn("",0);
7022 bool needargs = FALSE;
7025 if (*s == '.' || *s == '}') {
7027 #ifdef PERL_STRICT_CR
7028 for (t = s+1;*t == ' ' || *t == '\t'; t++) ;
7030 for (t = s+1;*t == ' ' || *t == '\t' || *t == '\r'; t++) ;
7032 if (*t == '\n' || t == PL_bufend)
7035 if (PL_in_eval && !PL_rsfp) {
7036 eol = strchr(s,'\n');
7041 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7043 for (t = s; t < eol; t++) {
7044 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
7046 goto enough; /* ~~ must be first line in formline */
7048 if (*t == '@' || *t == '^')
7051 sv_catpvn(stuff, s, eol-s);
7052 #ifndef PERL_STRICT_CR
7053 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
7054 char *end = SvPVX(stuff) + SvCUR(stuff);
7063 s = filter_gets(PL_linestr, PL_rsfp, 0);
7064 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
7065 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
7068 yyerror("Format not terminated");
7078 PL_lex_state = LEX_NORMAL;
7079 PL_nextval[PL_nexttoke].ival = 0;
7083 PL_lex_state = LEX_FORMLINE;
7084 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
7086 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
7090 SvREFCNT_dec(stuff);
7091 PL_lex_formbrack = 0;
7102 PL_cshlen = strlen(PL_cshname);
7107 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
7110 I32 oldsavestack_ix = PL_savestack_ix;
7111 CV* outsidecv = PL_compcv;
7115 assert(SvTYPE(PL_compcv) == SVt_PVCV);
7117 SAVEI32(PL_subline);
7118 save_item(PL_subname);
7121 SAVESPTR(PL_comppad_name);
7122 SAVESPTR(PL_compcv);
7123 SAVEI32(PL_comppad_name_fill);
7124 SAVEI32(PL_min_intro_pending);
7125 SAVEI32(PL_max_intro_pending);
7126 SAVEI32(PL_pad_reset_pending);
7128 PL_compcv = (CV*)NEWSV(1104,0);
7129 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
7130 CvFLAGS(PL_compcv) |= flags;
7132 PL_comppad = newAV();
7133 av_push(PL_comppad, Nullsv);
7134 PL_curpad = AvARRAY(PL_comppad);
7135 PL_comppad_name = newAV();
7136 PL_comppad_name_fill = 0;
7137 PL_min_intro_pending = 0;
7139 PL_subline = CopLINE(PL_curcop);
7141 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
7142 PL_curpad[0] = (SV*)newAV();
7143 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
7144 #endif /* USE_THREADS */
7146 comppadlist = newAV();
7147 AvREAL_off(comppadlist);
7148 av_store(comppadlist, 0, (SV*)PL_comppad_name);
7149 av_store(comppadlist, 1, (SV*)PL_comppad);
7151 CvPADLIST(PL_compcv) = comppadlist;
7152 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
7154 CvOWNER(PL_compcv) = 0;
7155 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
7156 MUTEX_INIT(CvMUTEXP(PL_compcv));
7157 #endif /* USE_THREADS */
7159 return oldsavestack_ix;
7163 Perl_yywarn(pTHX_ char *s)
7166 PL_in_eval |= EVAL_WARNONLY;
7168 PL_in_eval &= ~EVAL_WARNONLY;
7173 Perl_yyerror(pTHX_ char *s)
7177 char *context = NULL;
7181 if (!yychar || (yychar == ';' && !PL_rsfp))
7183 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
7184 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
7185 while (isSPACE(*PL_oldoldbufptr))
7187 context = PL_oldoldbufptr;
7188 contlen = PL_bufptr - PL_oldoldbufptr;
7190 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
7191 PL_oldbufptr != PL_bufptr) {
7192 while (isSPACE(*PL_oldbufptr))
7194 context = PL_oldbufptr;
7195 contlen = PL_bufptr - PL_oldbufptr;
7197 else if (yychar > 255)
7198 where = "next token ???";
7199 #ifdef USE_PURE_BISON
7200 /* GNU Bison sets the value -2 */
7201 else if (yychar == -2) {
7203 else if ((yychar & 127) == 127) {
7205 if (PL_lex_state == LEX_NORMAL ||
7206 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
7207 where = "at end of line";
7208 else if (PL_lex_inpat)
7209 where = "within pattern";
7211 where = "within string";
7214 SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
7216 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
7217 else if (isPRINT_LC(yychar))
7218 Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
7220 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
7221 where = SvPVX(where_sv);
7223 msg = sv_2mortal(newSVpv(s, 0));
7224 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
7225 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
7227 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
7229 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
7230 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
7231 Perl_sv_catpvf(aTHX_ msg,
7232 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
7233 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
7236 if (PL_in_eval & EVAL_WARNONLY)
7237 Perl_warn(aTHX_ "%"SVf, msg);
7240 if (PL_error_count >= 10)
7241 Perl_croak(aTHX_ "%s has too many errors.\n", CopFILE(PL_curcop));
7243 PL_in_my_stash = Nullhv;
7254 * Restore a source filter.
7258 restore_rsfp(pTHXo_ void *f)
7260 PerlIO *fp = (PerlIO*)f;
7262 if (PL_rsfp == PerlIO_stdin())
7263 PerlIO_clearerr(PL_rsfp);
7264 else if (PL_rsfp && (PL_rsfp != fp))
7265 PerlIO_close(PL_rsfp);