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;
827 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
831 for (; isDIGIT(*d) || *d == '_' || *d == '.'; d++);
832 if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
834 /* real VERSION number -- GBARR */
835 version = yylval.opval;
839 /* NOTE: The parser sees the package name and the VERSION swapped */
840 PL_nextval[PL_nexttoke].opval = version;
848 * Tokenize a quoted string passed in as an SV. It finds the next
849 * chunk, up to end of string or a backslash. It may make a new
850 * SV containing that chunk (if HINT_NEW_STRING is on). It also
855 S_tokeq(pTHX_ SV *sv)
866 s = SvPV_force(sv, len);
870 while (s < send && *s != '\\')
875 if ( PL_hints & HINT_NEW_STRING )
876 pv = sv_2mortal(newSVpvn(SvPVX(pv), len));
879 if (s + 1 < send && (s[1] == '\\'))
880 s++; /* all that, just for this */
885 SvCUR_set(sv, d - SvPVX(sv));
887 if ( PL_hints & HINT_NEW_STRING )
888 return new_constant(NULL, 0, "q", sv, pv, "q");
893 * Now come three functions related to double-quote context,
894 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
895 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
896 * interact with PL_lex_state, and create fake ( ... ) argument lists
897 * to handle functions and concatenation.
898 * They assume that whoever calls them will be setting up a fake
899 * join call, because each subthing puts a ',' after it. This lets
902 * join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
904 * (I'm not sure whether the spurious commas at the end of lcfirst's
905 * arguments and join's arguments are created or not).
910 * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST).
912 * Pattern matching will set PL_lex_op to the pattern-matching op to
913 * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise).
915 * OP_CONST and OP_READLINE are easy--just make the new op and return.
917 * Everything else becomes a FUNC.
919 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
920 * had an OP_CONST or OP_READLINE). This just sets us up for a
921 * call to S_sublex_push().
927 register I32 op_type = yylval.ival;
929 if (op_type == OP_NULL) {
930 yylval.opval = PL_lex_op;
934 if (op_type == OP_CONST || op_type == OP_READLINE) {
935 SV *sv = tokeq(PL_lex_stuff);
937 if (SvTYPE(sv) == SVt_PVIV) {
938 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
944 nsv = newSVpvn(p, len);
948 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
949 PL_lex_stuff = Nullsv;
953 PL_sublex_info.super_state = PL_lex_state;
954 PL_sublex_info.sub_inwhat = op_type;
955 PL_sublex_info.sub_op = PL_lex_op;
956 PL_lex_state = LEX_INTERPPUSH;
960 yylval.opval = PL_lex_op;
970 * Create a new scope to save the lexing state. The scope will be
971 * ended in S_sublex_done. Returns a '(', starting the function arguments
972 * to the uc, lc, etc. found before.
973 * Sets PL_lex_state to LEX_INTERPCONCAT.
982 PL_lex_state = PL_sublex_info.super_state;
983 SAVEI32(PL_lex_dojoin);
984 SAVEI32(PL_lex_brackets);
985 SAVEI32(PL_lex_casemods);
986 SAVEI32(PL_lex_starts);
987 SAVEI32(PL_lex_state);
988 SAVEVPTR(PL_lex_inpat);
989 SAVEI32(PL_lex_inwhat);
990 SAVECOPLINE(PL_curcop);
992 SAVEPPTR(PL_oldbufptr);
993 SAVEPPTR(PL_oldoldbufptr);
994 SAVEPPTR(PL_linestart);
995 SAVESPTR(PL_linestr);
996 SAVEPPTR(PL_lex_brackstack);
997 SAVEPPTR(PL_lex_casestack);
999 PL_linestr = PL_lex_stuff;
1000 PL_lex_stuff = Nullsv;
1002 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
1003 = SvPVX(PL_linestr);
1004 PL_bufend += SvCUR(PL_linestr);
1005 SAVEFREESV(PL_linestr);
1007 PL_lex_dojoin = FALSE;
1008 PL_lex_brackets = 0;
1009 New(899, PL_lex_brackstack, 120, char);
1010 New(899, PL_lex_casestack, 12, char);
1011 SAVEFREEPV(PL_lex_brackstack);
1012 SAVEFREEPV(PL_lex_casestack);
1013 PL_lex_casemods = 0;
1014 *PL_lex_casestack = '\0';
1016 PL_lex_state = LEX_INTERPCONCAT;
1017 CopLINE_set(PL_curcop, PL_multi_start);
1019 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1020 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1021 PL_lex_inpat = PL_sublex_info.sub_op;
1023 PL_lex_inpat = Nullop;
1030 * Restores lexer state after a S_sublex_push.
1036 if (!PL_lex_starts++) {
1037 PL_expect = XOPERATOR;
1038 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpvn("",0));
1042 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
1043 PL_lex_state = LEX_INTERPCASEMOD;
1047 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1048 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1049 PL_linestr = PL_lex_repl;
1051 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1052 PL_bufend += SvCUR(PL_linestr);
1053 SAVEFREESV(PL_linestr);
1054 PL_lex_dojoin = FALSE;
1055 PL_lex_brackets = 0;
1056 PL_lex_casemods = 0;
1057 *PL_lex_casestack = '\0';
1059 if (SvEVALED(PL_lex_repl)) {
1060 PL_lex_state = LEX_INTERPNORMAL;
1062 /* we don't clear PL_lex_repl here, so that we can check later
1063 whether this is an evalled subst; that means we rely on the
1064 logic to ensure sublex_done() is called again only via the
1065 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1068 PL_lex_state = LEX_INTERPCONCAT;
1069 PL_lex_repl = Nullsv;
1075 PL_bufend = SvPVX(PL_linestr);
1076 PL_bufend += SvCUR(PL_linestr);
1077 PL_expect = XOPERATOR;
1078 PL_sublex_info.sub_inwhat = 0;
1086 Extracts a pattern, double-quoted string, or transliteration. This
1089 It looks at lex_inwhat and PL_lex_inpat to find out whether it's
1090 processing a pattern (PL_lex_inpat is true), a transliteration
1091 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
1093 Returns a pointer to the character scanned up to. Iff this is
1094 advanced from the start pointer supplied (ie if anything was
1095 successfully parsed), will leave an OP for the substring scanned
1096 in yylval. Caller must intuit reason for not parsing further
1097 by looking at the next characters herself.
1101 double-quoted style: \r and \n
1102 regexp special ones: \D \s
1104 backrefs: \1 (deprecated in substitution replacements)
1105 case and quoting: \U \Q \E
1106 stops on @ and $, but not for $ as tail anchor
1108 In transliterations:
1109 characters are VERY literal, except for - not at the start or end
1110 of the string, which indicates a range. scan_const expands the
1111 range to the full set of intermediate characters.
1113 In double-quoted strings:
1115 double-quoted style: \r and \n
1117 backrefs: \1 (deprecated)
1118 case and quoting: \U \Q \E
1121 scan_const does *not* construct ops to handle interpolated strings.
1122 It stops processing as soon as it finds an embedded $ or @ variable
1123 and leaves it to the caller to work out what's going on.
1125 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
1127 $ in pattern could be $foo or could be tail anchor. Assumption:
1128 it's a tail anchor if $ is the last thing in the string, or if it's
1129 followed by one of ")| \n\t"
1131 \1 (backreferences) are turned into $1
1133 The structure of the code is
1134 while (there's a character to process) {
1135 handle transliteration ranges
1136 skip regexp comments
1137 skip # initiated comments in //x patterns
1138 check for embedded @foo
1139 check for embedded scalars
1141 leave intact backslashes from leave (below)
1142 deprecate \1 in strings and sub replacements
1143 handle string-changing backslashes \l \U \Q \E, etc.
1144 switch (what was escaped) {
1145 handle - in a transliteration (becomes a literal -)
1146 handle \132 octal characters
1147 handle 0x15 hex characters
1148 handle \cV (control V)
1149 handle printf backslashes (\f, \r, \n, etc)
1151 } (end if backslash)
1152 } (end while character to read)
1157 S_scan_const(pTHX_ char *start)
1159 register char *send = PL_bufend; /* end of the constant */
1160 SV *sv = NEWSV(93, send - start); /* sv for the constant */
1161 register char *s = start; /* start of the constant */
1162 register char *d = SvPVX(sv); /* destination for copies */
1163 bool dorange = FALSE; /* are we in a translit range? */
1164 bool has_utf = FALSE; /* embedded \x{} */
1166 I32 utf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op)
1167 ? (PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
1169 I32 thisutf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op)
1170 ? (PL_sublex_info.sub_op->op_private & (PL_lex_repl ?
1171 OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF))
1173 const char *leaveit = /* set of acceptably-backslashed characters */
1175 ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
1178 while (s < send || dorange) {
1179 /* get transliterations out of the way (they're most literal) */
1180 if (PL_lex_inwhat == OP_TRANS) {
1181 /* expand a range A-Z to the full set of characters. AIE! */
1183 I32 i; /* current expanded character */
1184 I32 min; /* first character in range */
1185 I32 max; /* last character in range */
1187 i = d - SvPVX(sv); /* remember current offset */
1188 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
1189 d = SvPVX(sv) + i; /* refresh d after realloc */
1190 d -= 2; /* eat the first char and the - */
1192 min = (U8)*d; /* first char in range */
1193 max = (U8)d[1]; /* last char in range */
1196 if ((isLOWER(min) && isLOWER(max)) ||
1197 (isUPPER(min) && isUPPER(max))) {
1199 for (i = min; i <= max; i++)
1203 for (i = min; i <= max; i++)
1210 for (i = min; i <= max; i++)
1213 /* mark the range as done, and continue */
1218 /* range begins (ignore - as first or last char) */
1219 else if (*s == '-' && s+1 < send && s != start) {
1221 *d++ = (char)0xff; /* use illegal utf8 byte--see pmtrans */
1230 /* if we get here, we're not doing a transliteration */
1232 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
1233 except for the last char, which will be done separately. */
1234 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
1236 while (s < send && *s != ')')
1238 } else if (s[2] == '{'
1239 || s[2] == 'p' && s[3] == '{') { /* This should march regcomp.c */
1241 char *regparse = s + (s[2] == '{' ? 3 : 4);
1244 while (count && (c = *regparse)) {
1245 if (c == '\\' && regparse[1])
1253 if (*regparse != ')') {
1254 regparse--; /* Leave one char for continuation. */
1255 yyerror("Sequence (?{...}) not terminated or not {}-balanced");
1257 while (s < regparse)
1262 /* likewise skip #-initiated comments in //x patterns */
1263 else if (*s == '#' && PL_lex_inpat &&
1264 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
1265 while (s+1 < send && *s != '\n')
1269 /* check for embedded arrays (@foo, @:foo, @'foo, @{foo}, @$foo) */
1270 else if (*s == '@' && s[1]
1271 && (isALNUM_lazy_if(s+1,UTF) || strchr(":'{$", s[1])))
1274 /* check for embedded scalars. only stop if we're sure it's a
1277 else if (*s == '$') {
1278 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
1280 if (s + 1 < send && !strchr("()| \n\t", s[1]))
1281 break; /* in regexp, $ might be tail anchor */
1284 /* (now in tr/// code again) */
1286 if (*s & 0x80 && thisutf) {
1287 dTHR; /* only for ckWARN */
1288 if (ckWARN(WARN_UTF8)) {
1289 (void)utf8_to_uv((U8*)s, &len); /* could cvt latin-1 to utf8 here... */
1298 has_utf = TRUE; /* assume valid utf8 */
1302 if (*s == '\\' && s+1 < send) {
1305 /* some backslashes we leave behind */
1306 if (*leaveit && *s && strchr(leaveit, *s)) {
1312 /* deprecate \1 in strings and substitution replacements */
1313 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1314 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1316 dTHR; /* only for ckWARN */
1317 if (ckWARN(WARN_SYNTAX))
1318 Perl_warner(aTHX_ WARN_SYNTAX, "\\%c better written as $%c", *s, *s);
1323 /* string-change backslash escapes */
1324 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1329 /* if we get here, it's either a quoted -, or a digit */
1332 /* quoted - in transliterations */
1334 if (PL_lex_inwhat == OP_TRANS) {
1342 if (ckWARN(WARN_MISC) && isALPHA(*s))
1343 Perl_warner(aTHX_ WARN_MISC,
1344 "Unrecognized escape \\%c passed through",
1346 /* default action is to copy the quoted character */
1351 /* \132 indicates an octal constant */
1352 case '0': case '1': case '2': case '3':
1353 case '4': case '5': case '6': case '7':
1354 *d++ = (char)scan_oct(s, 3, &len);
1358 /* \x24 indicates a hex constant */
1362 char* e = strchr(s, '}');
1366 yyerror("Missing right brace on \\x{}");
1369 /* note: utf always shorter than hex */
1370 uv = (UV)scan_hex(s + 1, e - s - 1, &len);
1372 d = (char*)uv_to_utf8((U8*)d, uv);
1380 /* XXX collapse this branch into the one above */
1381 UV uv = (UV)scan_hex(s, 2, &len);
1382 if (utf && PL_lex_inwhat == OP_TRANS &&
1383 utf != (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
1385 d = (char*)uv_to_utf8((U8*)d, uv); /* doing a CU or UC */
1389 if (uv >= 127 && UTF) {
1391 if (ckWARN(WARN_UTF8))
1392 Perl_warner(aTHX_ WARN_UTF8,
1393 "\\x%.*s will produce malformed UTF-8 character; use \\x{%.*s} for that",
1394 (int)len,s,(int)len,s);
1402 /* \N{latin small letter a} is a named character */
1406 char* e = strchr(s, '}');
1415 yyerror("Missing right brace on \\N{}");
1419 res = newSVpvn(s + 1, e - s - 1);
1420 res = new_constant( Nullch, 0, "charnames",
1421 res, Nullsv, "\\N{...}" );
1422 str = SvPV(res,len);
1423 if (len > e - s + 4) {
1424 char *odest = SvPVX(sv);
1426 SvGROW(sv, (SvCUR(sv) + len - (e - s + 4)));
1427 d = SvPVX(sv) + (d - odest);
1429 Copy(str, d, len, char);
1436 yyerror("Missing braces on \\N{}");
1439 /* \c is a control character */
1453 /* printf-style backslashes, formfeeds, newlines, etc */
1471 *d++ = '\047'; /* CP 1047 */
1474 *d++ = '\057'; /* CP 1047 */
1488 } /* end if (backslash) */
1491 } /* while loop to process each character */
1493 /* terminate the string and set up the sv */
1495 SvCUR_set(sv, d - SvPVX(sv));
1500 /* shrink the sv if we allocated more than we used */
1501 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1502 SvLEN_set(sv, SvCUR(sv) + 1);
1503 Renew(SvPVX(sv), SvLEN(sv), char);
1506 /* return the substring (via yylval) only if we parsed anything */
1507 if (s > PL_bufptr) {
1508 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1509 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1511 ( PL_lex_inwhat == OP_TRANS
1513 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1516 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1523 * Returns TRUE if there's more to the expression (e.g., a subscript),
1526 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
1528 * ->[ and ->{ return TRUE
1529 * { and [ outside a pattern are always subscripts, so return TRUE
1530 * if we're outside a pattern and it's not { or [, then return FALSE
1531 * if we're in a pattern and the first char is a {
1532 * {4,5} (any digits around the comma) returns FALSE
1533 * if we're in a pattern and the first char is a [
1535 * [SOMETHING] has a funky algorithm to decide whether it's a
1536 * character class or not. It has to deal with things like
1537 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
1538 * anything else returns TRUE
1541 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1544 S_intuit_more(pTHX_ register char *s)
1546 if (PL_lex_brackets)
1548 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1550 if (*s != '{' && *s != '[')
1555 /* In a pattern, so maybe we have {n,m}. */
1572 /* On the other hand, maybe we have a character class */
1575 if (*s == ']' || *s == '^')
1578 /* this is terrifying, and it works */
1579 int weight = 2; /* let's weigh the evidence */
1581 unsigned char un_char = 255, last_un_char;
1582 char *send = strchr(s,']');
1583 char tmpbuf[sizeof PL_tokenbuf * 4];
1585 if (!send) /* has to be an expression */
1588 Zero(seen,256,char);
1591 else if (isDIGIT(*s)) {
1593 if (isDIGIT(s[1]) && s[2] == ']')
1599 for (; s < send; s++) {
1600 last_un_char = un_char;
1601 un_char = (unsigned char)*s;
1606 weight -= seen[un_char] * 10;
1607 if (isALNUM_lazy_if(s+1,UTF)) {
1608 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1609 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1614 else if (*s == '$' && s[1] &&
1615 strchr("[#!%*<>()-=",s[1])) {
1616 if (/*{*/ strchr("])} =",s[2]))
1625 if (strchr("wds]",s[1]))
1627 else if (seen['\''] || seen['"'])
1629 else if (strchr("rnftbxcav",s[1]))
1631 else if (isDIGIT(s[1])) {
1633 while (s[1] && isDIGIT(s[1]))
1643 if (strchr("aA01! ",last_un_char))
1645 if (strchr("zZ79~",s[1]))
1647 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1648 weight -= 5; /* cope with negative subscript */
1651 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1652 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1657 if (keyword(tmpbuf, d - tmpbuf))
1660 if (un_char == last_un_char + 1)
1662 weight -= seen[un_char];
1667 if (weight >= 0) /* probably a character class */
1677 * Does all the checking to disambiguate
1679 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
1680 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
1682 * First argument is the stuff after the first token, e.g. "bar".
1684 * Not a method if bar is a filehandle.
1685 * Not a method if foo is a subroutine prototyped to take a filehandle.
1686 * Not a method if it's really "Foo $bar"
1687 * Method if it's "foo $bar"
1688 * Not a method if it's really "print foo $bar"
1689 * Method if it's really "foo package::" (interpreted as package->foo)
1690 * Not a method if bar is known to be a subroutne ("sub bar; foo bar")
1691 * Not a method if bar is a filehandle or package, but is quoted with
1696 S_intuit_method(pTHX_ char *start, GV *gv)
1698 char *s = start + (*start == '$');
1699 char tmpbuf[sizeof PL_tokenbuf];
1707 if ((cv = GvCVu(gv))) {
1708 char *proto = SvPVX(cv);
1718 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1719 /* start is the beginning of the possible filehandle/object,
1720 * and s is the end of it
1721 * tmpbuf is a copy of it
1724 if (*start == '$') {
1725 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1730 return *s == '(' ? FUNCMETH : METHOD;
1732 if (!keyword(tmpbuf, len)) {
1733 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1738 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1739 if (indirgv && GvCVu(indirgv))
1741 /* filehandle or package name makes it a method */
1742 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1744 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1745 return 0; /* no assumptions -- "=>" quotes bearword */
1747 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1748 newSVpvn(tmpbuf,len));
1749 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1753 return *s == '(' ? FUNCMETH : METHOD;
1761 * Return a string of Perl code to load the debugger. If PERL5DB
1762 * is set, it will return the contents of that, otherwise a
1763 * compile-time require of perl5db.pl.
1770 char *pdb = PerlEnv_getenv("PERL5DB");
1774 SETERRNO(0,SS$_NORMAL);
1775 return "BEGIN { require 'perl5db.pl' }";
1781 /* Encoded script support. filter_add() effectively inserts a
1782 * 'pre-processing' function into the current source input stream.
1783 * Note that the filter function only applies to the current source file
1784 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1786 * The datasv parameter (which may be NULL) can be used to pass
1787 * private data to this instance of the filter. The filter function
1788 * can recover the SV using the FILTER_DATA macro and use it to
1789 * store private buffers and state information.
1791 * The supplied datasv parameter is upgraded to a PVIO type
1792 * and the IoDIRP field is used to store the function pointer,
1793 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
1794 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1795 * private use must be set using malloc'd pointers.
1799 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
1804 if (!PL_rsfp_filters)
1805 PL_rsfp_filters = newAV();
1807 datasv = NEWSV(255,0);
1808 if (!SvUPGRADE(datasv, SVt_PVIO))
1809 Perl_die(aTHX_ "Can't upgrade filter_add data to SVt_PVIO");
1810 IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
1811 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
1812 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
1813 funcp, SvPV_nolen(datasv)));
1814 av_unshift(PL_rsfp_filters, 1);
1815 av_store(PL_rsfp_filters, 0, datasv) ;
1820 /* Delete most recently added instance of this filter function. */
1822 Perl_filter_del(pTHX_ filter_t funcp)
1825 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", funcp));
1826 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
1828 /* if filter is on top of stack (usual case) just pop it off */
1829 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
1830 if (IoDIRP(datasv) == (DIR*)funcp) {
1831 IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
1832 IoDIRP(datasv) = (DIR*)NULL;
1833 sv_free(av_pop(PL_rsfp_filters));
1837 /* we need to search for the correct entry and clear it */
1838 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
1842 /* Invoke the n'th filter function for the current rsfp. */
1844 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
1847 /* 0 = read one text line */
1852 if (!PL_rsfp_filters)
1854 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
1855 /* Provide a default input filter to make life easy. */
1856 /* Note that we append to the line. This is handy. */
1857 DEBUG_P(PerlIO_printf(Perl_debug_log,
1858 "filter_read %d: from rsfp\n", idx));
1862 int old_len = SvCUR(buf_sv) ;
1864 /* ensure buf_sv is large enough */
1865 SvGROW(buf_sv, old_len + maxlen) ;
1866 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1867 if (PerlIO_error(PL_rsfp))
1868 return -1; /* error */
1870 return 0 ; /* end of file */
1872 SvCUR_set(buf_sv, old_len + len) ;
1875 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
1876 if (PerlIO_error(PL_rsfp))
1877 return -1; /* error */
1879 return 0 ; /* end of file */
1882 return SvCUR(buf_sv);
1884 /* Skip this filter slot if filter has been deleted */
1885 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
1886 DEBUG_P(PerlIO_printf(Perl_debug_log,
1887 "filter_read %d: skipped (filter deleted)\n",
1889 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1891 /* Get function pointer hidden within datasv */
1892 funcp = (filter_t)IoDIRP(datasv);
1893 DEBUG_P(PerlIO_printf(Perl_debug_log,
1894 "filter_read %d: via function %p (%s)\n",
1895 idx, funcp, SvPV_nolen(datasv)));
1896 /* Call function. The function is expected to */
1897 /* call "FILTER_READ(idx+1, buf_sv)" first. */
1898 /* Return: <0:error, =0:eof, >0:not eof */
1899 return (*funcp)(aTHXo_ idx, buf_sv, maxlen);
1903 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
1905 #ifdef PERL_CR_FILTER
1906 if (!PL_rsfp_filters) {
1907 filter_add(S_cr_textfilter,NULL);
1910 if (PL_rsfp_filters) {
1913 SvCUR_set(sv, 0); /* start with empty line */
1914 if (FILTER_READ(0, sv, 0) > 0)
1915 return ( SvPVX(sv) ) ;
1920 return (sv_gets(sv, fp, append));
1925 static char* exp_name[] =
1926 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
1927 "ATTRTERM", "TERMBLOCK"
1934 Works out what to call the token just pulled out of the input
1935 stream. The yacc parser takes care of taking the ops we return and
1936 stitching them into a tree.
1942 if read an identifier
1943 if we're in a my declaration
1944 croak if they tried to say my($foo::bar)
1945 build the ops for a my() declaration
1946 if it's an access to a my() variable
1947 are we in a sort block?
1948 croak if my($a); $a <=> $b
1949 build ops for access to a my() variable
1950 if in a dq string, and they've said @foo and we can't find @foo
1952 build ops for a bareword
1953 if we already built the token before, use it.
1957 #ifdef USE_PURE_BISON
1958 Perl_yylex(pTHX_ YYSTYPE *lvalp, int *lcharp)
1971 #ifdef USE_PURE_BISON
1972 yylval_pointer = lvalp;
1973 yychar_pointer = lcharp;
1976 /* check if there's an identifier for us to look at */
1977 if (PL_pending_ident) {
1978 /* pit holds the identifier we read and pending_ident is reset */
1979 char pit = PL_pending_ident;
1980 PL_pending_ident = 0;
1982 /* if we're in a my(), we can't allow dynamics here.
1983 $foo'bar has already been turned into $foo::bar, so
1984 just check for colons.
1986 if it's a legal name, the OP is a PADANY.
1989 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
1990 if (strchr(PL_tokenbuf,':'))
1991 yyerror(Perl_form(aTHX_ "No package name allowed for "
1992 "variable %s in \"our\"",
1994 tmp = pad_allocmy(PL_tokenbuf);
1997 if (strchr(PL_tokenbuf,':'))
1998 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
2000 yylval.opval = newOP(OP_PADANY, 0);
2001 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
2007 build the ops for accesses to a my() variable.
2009 Deny my($a) or my($b) in a sort block, *if* $a or $b is
2010 then used in a comparison. This catches most, but not
2011 all cases. For instance, it catches
2012 sort { my($a); $a <=> $b }
2014 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
2015 (although why you'd do that is anyone's guess).
2018 if (!strchr(PL_tokenbuf,':')) {
2020 /* Check for single character per-thread SVs */
2021 if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
2022 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
2023 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
2025 yylval.opval = newOP(OP_THREADSV, 0);
2026 yylval.opval->op_targ = tmp;
2029 #endif /* USE_THREADS */
2030 if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
2031 SV *namesv = AvARRAY(PL_comppad_name)[tmp];
2032 /* might be an "our" variable" */
2033 if (SvFLAGS(namesv) & SVpad_OUR) {
2034 /* build ops for a bareword */
2035 SV *sym = newSVpv(HvNAME(GvSTASH(namesv)),0);
2036 sv_catpvn(sym, "::", 2);
2037 sv_catpv(sym, PL_tokenbuf+1);
2038 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
2039 yylval.opval->op_private = OPpCONST_ENTERED;
2040 gv_fetchpv(SvPVX(sym),
2042 ? (GV_ADDMULTI | GV_ADDINEVAL)
2045 ((PL_tokenbuf[0] == '$') ? SVt_PV
2046 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
2051 /* if it's a sort block and they're naming $a or $b */
2052 if (PL_last_lop_op == OP_SORT &&
2053 PL_tokenbuf[0] == '$' &&
2054 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
2057 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
2058 d < PL_bufend && *d != '\n';
2061 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
2062 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
2068 yylval.opval = newOP(OP_PADANY, 0);
2069 yylval.opval->op_targ = tmp;
2075 Whine if they've said @foo in a doublequoted string,
2076 and @foo isn't a variable we can find in the symbol
2079 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
2080 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
2081 if (!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
2082 yyerror(Perl_form(aTHX_ "In string, %s now must be written as \\%s",
2083 PL_tokenbuf, PL_tokenbuf));
2086 /* build ops for a bareword */
2087 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
2088 yylval.opval->op_private = OPpCONST_ENTERED;
2089 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
2090 ((PL_tokenbuf[0] == '$') ? SVt_PV
2091 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
2096 /* no identifier pending identification */
2098 switch (PL_lex_state) {
2100 case LEX_NORMAL: /* Some compilers will produce faster */
2101 case LEX_INTERPNORMAL: /* code if we comment these out. */
2105 /* when we've already built the next token, just pull it out of the queue */
2108 yylval = PL_nextval[PL_nexttoke];
2110 PL_lex_state = PL_lex_defer;
2111 PL_expect = PL_lex_expect;
2112 PL_lex_defer = LEX_NORMAL;
2114 return(PL_nexttype[PL_nexttoke]);
2116 /* interpolated case modifiers like \L \U, including \Q and \E.
2117 when we get here, PL_bufptr is at the \
2119 case LEX_INTERPCASEMOD:
2121 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
2122 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
2124 /* handle \E or end of string */
2125 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
2129 if (PL_lex_casemods) {
2130 oldmod = PL_lex_casestack[--PL_lex_casemods];
2131 PL_lex_casestack[PL_lex_casemods] = '\0';
2133 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
2135 PL_lex_state = LEX_INTERPCONCAT;
2139 if (PL_bufptr != PL_bufend)
2141 PL_lex_state = LEX_INTERPCONCAT;
2146 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
2147 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
2148 if (strchr("LU", *s) &&
2149 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
2151 PL_lex_casestack[--PL_lex_casemods] = '\0';
2154 if (PL_lex_casemods > 10) {
2155 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
2156 if (newlb != PL_lex_casestack) {
2158 PL_lex_casestack = newlb;
2161 PL_lex_casestack[PL_lex_casemods++] = *s;
2162 PL_lex_casestack[PL_lex_casemods] = '\0';
2163 PL_lex_state = LEX_INTERPCONCAT;
2164 PL_nextval[PL_nexttoke].ival = 0;
2167 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
2169 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
2171 PL_nextval[PL_nexttoke].ival = OP_LC;
2173 PL_nextval[PL_nexttoke].ival = OP_UC;
2175 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
2177 Perl_croak(aTHX_ "panic: yylex");
2180 if (PL_lex_starts) {
2189 case LEX_INTERPPUSH:
2190 return sublex_push();
2192 case LEX_INTERPSTART:
2193 if (PL_bufptr == PL_bufend)
2194 return sublex_done();
2196 PL_lex_dojoin = (*PL_bufptr == '@');
2197 PL_lex_state = LEX_INTERPNORMAL;
2198 if (PL_lex_dojoin) {
2199 PL_nextval[PL_nexttoke].ival = 0;
2202 PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
2203 PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
2204 force_next(PRIVATEREF);
2206 force_ident("\"", '$');
2207 #endif /* USE_THREADS */
2208 PL_nextval[PL_nexttoke].ival = 0;
2210 PL_nextval[PL_nexttoke].ival = 0;
2212 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
2215 if (PL_lex_starts++) {
2221 case LEX_INTERPENDMAYBE:
2222 if (intuit_more(PL_bufptr)) {
2223 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
2229 if (PL_lex_dojoin) {
2230 PL_lex_dojoin = FALSE;
2231 PL_lex_state = LEX_INTERPCONCAT;
2234 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
2235 && SvEVALED(PL_lex_repl))
2237 if (PL_bufptr != PL_bufend)
2238 Perl_croak(aTHX_ "Bad evalled substitution pattern");
2239 PL_lex_repl = Nullsv;
2242 case LEX_INTERPCONCAT:
2244 if (PL_lex_brackets)
2245 Perl_croak(aTHX_ "panic: INTERPCONCAT");
2247 if (PL_bufptr == PL_bufend)
2248 return sublex_done();
2250 if (SvIVX(PL_linestr) == '\'') {
2251 SV *sv = newSVsv(PL_linestr);
2254 else if ( PL_hints & HINT_NEW_RE )
2255 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
2256 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2260 s = scan_const(PL_bufptr);
2262 PL_lex_state = LEX_INTERPCASEMOD;
2264 PL_lex_state = LEX_INTERPSTART;
2267 if (s != PL_bufptr) {
2268 PL_nextval[PL_nexttoke] = yylval;
2271 if (PL_lex_starts++)
2281 PL_lex_state = LEX_NORMAL;
2282 s = scan_formline(PL_bufptr);
2283 if (!PL_lex_formbrack)
2289 PL_oldoldbufptr = PL_oldbufptr;
2292 PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at %s\n",
2293 exp_name[PL_expect], s);
2299 if (isIDFIRST_lazy_if(s,UTF))
2301 Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
2304 goto fake_eof; /* emulate EOF on ^D or ^Z */
2309 if (PL_lex_brackets)
2310 yyerror("Missing right curly or square bracket");
2313 if (s++ < PL_bufend)
2314 goto retry; /* ignore stray nulls */
2317 if (!PL_in_eval && !PL_preambled) {
2318 PL_preambled = TRUE;
2319 sv_setpv(PL_linestr,incl_perldb());
2320 if (SvCUR(PL_linestr))
2321 sv_catpv(PL_linestr,";");
2323 while(AvFILLp(PL_preambleav) >= 0) {
2324 SV *tmpsv = av_shift(PL_preambleav);
2325 sv_catsv(PL_linestr, tmpsv);
2326 sv_catpv(PL_linestr, ";");
2329 sv_free((SV*)PL_preambleav);
2330 PL_preambleav = NULL;
2332 if (PL_minus_n || PL_minus_p) {
2333 sv_catpv(PL_linestr, "LINE: while (<>) {");
2335 sv_catpv(PL_linestr,"chomp;");
2337 GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
2339 GvIMPORTED_AV_on(gv);
2341 if (strchr("/'\"", *PL_splitstr)
2342 && strchr(PL_splitstr + 1, *PL_splitstr))
2343 Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s);", PL_splitstr);
2346 s = "'~#\200\1'"; /* surely one char is unused...*/
2347 while (s[1] && strchr(PL_splitstr, *s)) s++;
2349 Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s%c",
2350 "q" + (delim == '\''), delim);
2351 for (s = PL_splitstr; *s; s++) {
2353 sv_catpvn(PL_linestr, "\\", 1);
2354 sv_catpvn(PL_linestr, s, 1);
2356 Perl_sv_catpvf(aTHX_ PL_linestr, "%c);", delim);
2360 sv_catpv(PL_linestr,"@F=split(' ');");
2363 sv_catpv(PL_linestr, "\n");
2364 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2365 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2366 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2367 SV *sv = NEWSV(85,0);
2369 sv_upgrade(sv, SVt_PVMG);
2370 sv_setsv(sv,PL_linestr);
2371 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2376 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
2379 if (PL_preprocess && !PL_in_eval)
2380 (void)PerlProc_pclose(PL_rsfp);
2381 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2382 PerlIO_clearerr(PL_rsfp);
2384 (void)PerlIO_close(PL_rsfp);
2386 PL_doextract = FALSE;
2388 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2389 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
2390 sv_catpv(PL_linestr,";}");
2391 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2392 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2393 PL_minus_n = PL_minus_p = 0;
2396 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2397 sv_setpv(PL_linestr,"");
2398 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
2401 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
2402 PL_doextract = FALSE;
2404 /* Incest with pod. */
2405 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2406 sv_setpv(PL_linestr, "");
2407 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2408 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2409 PL_doextract = FALSE;
2413 } while (PL_doextract);
2414 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2415 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2416 SV *sv = NEWSV(85,0);
2418 sv_upgrade(sv, SVt_PVMG);
2419 sv_setsv(sv,PL_linestr);
2420 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2422 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2423 if (CopLINE(PL_curcop) == 1) {
2424 while (s < PL_bufend && isSPACE(*s))
2426 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2430 if (*s == '#' && *(s+1) == '!')
2432 #ifdef ALTERNATE_SHEBANG
2434 static char as[] = ALTERNATE_SHEBANG;
2435 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2436 d = s + (sizeof(as) - 1);
2438 #endif /* ALTERNATE_SHEBANG */
2447 while (*d && !isSPACE(*d))
2451 #ifdef ARG_ZERO_IS_SCRIPT
2452 if (ipathend > ipath) {
2454 * HP-UX (at least) sets argv[0] to the script name,
2455 * which makes $^X incorrect. And Digital UNIX and Linux,
2456 * at least, set argv[0] to the basename of the Perl
2457 * interpreter. So, having found "#!", we'll set it right.
2459 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
2460 assert(SvPOK(x) || SvGMAGICAL(x));
2461 if (sv_eq(x, CopFILESV(PL_curcop))) {
2462 sv_setpvn(x, ipath, ipathend - ipath);
2465 TAINT_NOT; /* $^X is always tainted, but that's OK */
2467 #endif /* ARG_ZERO_IS_SCRIPT */
2472 d = instr(s,"perl -");
2474 d = instr(s,"perl");
2476 /* avoid getting into infinite loops when shebang
2477 * line contains "Perl" rather than "perl" */
2479 for (d = ipathend-4; d >= ipath; --d) {
2480 if ((*d == 'p' || *d == 'P')
2481 && !ibcmp(d, "perl", 4))
2491 #ifdef ALTERNATE_SHEBANG
2493 * If the ALTERNATE_SHEBANG on this system starts with a
2494 * character that can be part of a Perl expression, then if
2495 * we see it but not "perl", we're probably looking at the
2496 * start of Perl code, not a request to hand off to some
2497 * other interpreter. Similarly, if "perl" is there, but
2498 * not in the first 'word' of the line, we assume the line
2499 * contains the start of the Perl program.
2501 if (d && *s != '#') {
2503 while (*c && !strchr("; \t\r\n\f\v#", *c))
2506 d = Nullch; /* "perl" not in first word; ignore */
2508 *s = '#'; /* Don't try to parse shebang line */
2510 #endif /* ALTERNATE_SHEBANG */
2515 !instr(s,"indir") &&
2516 instr(PL_origargv[0],"perl"))
2522 while (s < PL_bufend && isSPACE(*s))
2524 if (s < PL_bufend) {
2525 Newz(899,newargv,PL_origargc+3,char*);
2527 while (s < PL_bufend && !isSPACE(*s))
2530 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2533 newargv = PL_origargv;
2535 PerlProc_execv(ipath, newargv);
2536 Perl_croak(aTHX_ "Can't exec %s", ipath);
2539 U32 oldpdb = PL_perldb;
2540 bool oldn = PL_minus_n;
2541 bool oldp = PL_minus_p;
2543 while (*d && !isSPACE(*d)) d++;
2544 while (*d == ' ' || *d == '\t') d++;
2548 if (*d == 'M' || *d == 'm') {
2550 while (*d && !isSPACE(*d)) d++;
2551 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2554 d = moreswitches(d);
2556 if (PERLDB_LINE && !oldpdb ||
2557 ( PL_minus_n || PL_minus_p ) && !(oldn || oldp) )
2558 /* if we have already added "LINE: while (<>) {",
2559 we must not do it again */
2561 sv_setpv(PL_linestr, "");
2562 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2563 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2564 PL_preambled = FALSE;
2566 (void)gv_fetchfile(PL_origfilename);
2573 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2575 PL_lex_state = LEX_FORMLINE;
2580 #ifdef PERL_STRICT_CR
2581 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2583 "(Maybe you didn't strip carriage returns after a network transfer?)\n");
2585 case ' ': case '\t': case '\f': case 013:
2590 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2592 while (s < d && *s != '\n')
2597 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2599 PL_lex_state = LEX_FORMLINE;
2609 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2614 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2617 if (strnEQ(s,"=>",2)) {
2618 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2619 OPERATOR('-'); /* unary minus */
2621 PL_last_uni = PL_oldbufptr;
2622 PL_last_lop_op = OP_FTEREAD; /* good enough */
2624 case 'r': FTST(OP_FTEREAD);
2625 case 'w': FTST(OP_FTEWRITE);
2626 case 'x': FTST(OP_FTEEXEC);
2627 case 'o': FTST(OP_FTEOWNED);
2628 case 'R': FTST(OP_FTRREAD);
2629 case 'W': FTST(OP_FTRWRITE);
2630 case 'X': FTST(OP_FTREXEC);
2631 case 'O': FTST(OP_FTROWNED);
2632 case 'e': FTST(OP_FTIS);
2633 case 'z': FTST(OP_FTZERO);
2634 case 's': FTST(OP_FTSIZE);
2635 case 'f': FTST(OP_FTFILE);
2636 case 'd': FTST(OP_FTDIR);
2637 case 'l': FTST(OP_FTLINK);
2638 case 'p': FTST(OP_FTPIPE);
2639 case 'S': FTST(OP_FTSOCK);
2640 case 'u': FTST(OP_FTSUID);
2641 case 'g': FTST(OP_FTSGID);
2642 case 'k': FTST(OP_FTSVTX);
2643 case 'b': FTST(OP_FTBLK);
2644 case 'c': FTST(OP_FTCHR);
2645 case 't': FTST(OP_FTTTY);
2646 case 'T': FTST(OP_FTTEXT);
2647 case 'B': FTST(OP_FTBINARY);
2648 case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2649 case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2650 case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
2652 Perl_croak(aTHX_ "Unrecognized file test: -%c", (int)tmp);
2659 if (PL_expect == XOPERATOR)
2664 else if (*s == '>') {
2667 if (isIDFIRST_lazy_if(s,UTF)) {
2668 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2676 if (PL_expect == XOPERATOR)
2679 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2681 OPERATOR('-'); /* unary minus */
2688 if (PL_expect == XOPERATOR)
2693 if (PL_expect == XOPERATOR)
2696 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2702 if (PL_expect != XOPERATOR) {
2703 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2704 PL_expect = XOPERATOR;
2705 force_ident(PL_tokenbuf, '*');
2718 if (PL_expect == XOPERATOR) {
2722 PL_tokenbuf[0] = '%';
2723 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2724 if (!PL_tokenbuf[1]) {
2726 yyerror("Final % should be \\% or %name");
2729 PL_pending_ident = '%';
2748 switch (PL_expect) {
2751 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
2753 PL_bufptr = s; /* update in case we back off */
2759 PL_expect = XTERMBLOCK;
2763 while (isIDFIRST_lazy_if(s,UTF)) {
2764 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2765 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
2766 if (tmp < 0) tmp = -tmp;
2781 d = scan_str(d,TRUE,TRUE);
2784 SvREFCNT_dec(PL_lex_stuff);
2785 PL_lex_stuff = Nullsv;
2787 /* MUST advance bufptr here to avoid bogus
2788 "at end of line" context messages from yyerror().
2790 PL_bufptr = s + len;
2791 yyerror("Unterminated attribute parameter in attribute list");
2794 return 0; /* EOF indicator */
2798 SV *sv = newSVpvn(s, len);
2799 sv_catsv(sv, PL_lex_stuff);
2800 attrs = append_elem(OP_LIST, attrs,
2801 newSVOP(OP_CONST, 0, sv));
2802 SvREFCNT_dec(PL_lex_stuff);
2803 PL_lex_stuff = Nullsv;
2806 attrs = append_elem(OP_LIST, attrs,
2807 newSVOP(OP_CONST, 0,
2811 if (*s == ':' && s[1] != ':')
2814 break; /* require real whitespace or :'s */
2816 tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
2817 if (*s != ';' && *s != tmp && (tmp != '=' || *s != ')')) {
2818 char q = ((*s == '\'') ? '"' : '\'');
2819 /* If here for an expression, and parsed no attrs, back off. */
2820 if (tmp == '=' && !attrs) {
2824 /* MUST advance bufptr here to avoid bogus "at end of line"
2825 context messages from yyerror().
2829 yyerror("Unterminated attribute list");
2831 yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list",
2839 PL_nextval[PL_nexttoke].opval = attrs;
2847 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
2848 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
2853 if (CopLINE(PL_curcop) < PL_copline)
2854 PL_copline = CopLINE(PL_curcop);
2865 if (PL_lex_brackets <= 0)
2866 yyerror("Unmatched right square bracket");
2869 if (PL_lex_state == LEX_INTERPNORMAL) {
2870 if (PL_lex_brackets == 0) {
2871 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
2872 PL_lex_state = LEX_INTERPEND;
2879 if (PL_lex_brackets > 100) {
2880 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
2881 if (newlb != PL_lex_brackstack) {
2883 PL_lex_brackstack = newlb;
2886 switch (PL_expect) {
2888 if (PL_lex_formbrack) {
2892 if (PL_oldoldbufptr == PL_last_lop)
2893 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2895 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2896 OPERATOR(HASHBRACK);
2898 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2901 PL_tokenbuf[0] = '\0';
2902 if (d < PL_bufend && *d == '-') {
2903 PL_tokenbuf[0] = '-';
2905 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2908 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
2909 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2911 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2914 char minus = (PL_tokenbuf[0] == '-');
2915 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2923 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
2928 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2933 if (PL_oldoldbufptr == PL_last_lop)
2934 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2936 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2939 OPERATOR(HASHBRACK);
2940 /* This hack serves to disambiguate a pair of curlies
2941 * as being a block or an anon hash. Normally, expectation
2942 * determines that, but in cases where we're not in a
2943 * position to expect anything in particular (like inside
2944 * eval"") we have to resolve the ambiguity. This code
2945 * covers the case where the first term in the curlies is a
2946 * quoted string. Most other cases need to be explicitly
2947 * disambiguated by prepending a `+' before the opening
2948 * curly in order to force resolution as an anon hash.
2950 * XXX should probably propagate the outer expectation
2951 * into eval"" to rely less on this hack, but that could
2952 * potentially break current behavior of eval"".
2956 if (*s == '\'' || *s == '"' || *s == '`') {
2957 /* common case: get past first string, handling escapes */
2958 for (t++; t < PL_bufend && *t != *s;)
2959 if (*t++ == '\\' && (*t == '\\' || *t == *s))
2963 else if (*s == 'q') {
2966 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
2970 char open, close, term;
2973 while (t < PL_bufend && isSPACE(*t))
2977 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
2981 for (t++; t < PL_bufend; t++) {
2982 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
2984 else if (*t == open)
2988 for (t++; t < PL_bufend; t++) {
2989 if (*t == '\\' && t+1 < PL_bufend)
2991 else if (*t == close && --brackets <= 0)
2993 else if (*t == open)
2999 else if (isALNUM_lazy_if(t,UTF)) {
3001 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3004 while (t < PL_bufend && isSPACE(*t))
3006 /* if comma follows first term, call it an anon hash */
3007 /* XXX it could be a comma expression with loop modifiers */
3008 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
3009 || (*t == '=' && t[1] == '>')))
3010 OPERATOR(HASHBRACK);
3011 if (PL_expect == XREF)
3014 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
3020 yylval.ival = CopLINE(PL_curcop);
3021 if (isSPACE(*s) || *s == '#')
3022 PL_copline = NOLINE; /* invalidate current command line number */
3027 if (PL_lex_brackets <= 0)
3028 yyerror("Unmatched right curly bracket");
3030 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
3031 if (PL_lex_brackets < PL_lex_formbrack)
3032 PL_lex_formbrack = 0;
3033 if (PL_lex_state == LEX_INTERPNORMAL) {
3034 if (PL_lex_brackets == 0) {
3035 if (PL_expect & XFAKEBRACK) {
3036 PL_expect &= XENUMMASK;
3037 PL_lex_state = LEX_INTERPEND;
3039 return yylex(); /* ignore fake brackets */
3041 if (*s == '-' && s[1] == '>')
3042 PL_lex_state = LEX_INTERPENDMAYBE;
3043 else if (*s != '[' && *s != '{')
3044 PL_lex_state = LEX_INTERPEND;
3047 if (PL_expect & XFAKEBRACK) {
3048 PL_expect &= XENUMMASK;
3050 return yylex(); /* ignore fake brackets */
3060 if (PL_expect == XOPERATOR) {
3061 if (ckWARN(WARN_SEMICOLON)
3062 && isIDFIRST_lazy_if(s,UTF) && PL_bufptr == PL_linestart)
3064 CopLINE_dec(PL_curcop);
3065 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3066 CopLINE_inc(PL_curcop);
3071 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3073 PL_expect = XOPERATOR;
3074 force_ident(PL_tokenbuf, '&');
3078 yylval.ival = (OPpENTERSUB_AMPER<<8);
3097 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
3098 Perl_warner(aTHX_ WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
3100 if (PL_expect == XSTATE && isALPHA(tmp) &&
3101 (s == PL_linestart+1 || s[-2] == '\n') )
3103 if (PL_in_eval && !PL_rsfp) {
3108 if (strnEQ(s,"=cut",4)) {
3122 PL_doextract = TRUE;
3125 if (PL_lex_brackets < PL_lex_formbrack) {
3127 #ifdef PERL_STRICT_CR
3128 for (t = s; *t == ' ' || *t == '\t'; t++) ;
3130 for (t = s; *t == ' ' || *t == '\t' || *t == '\r'; t++) ;
3132 if (*t == '\n' || *t == '#') {
3150 if (PL_expect != XOPERATOR) {
3151 if (s[1] != '<' && !strchr(s,'>'))
3154 s = scan_heredoc(s);
3156 s = scan_inputsymbol(s);
3157 TERM(sublex_start());
3162 SHop(OP_LEFT_SHIFT);
3176 SHop(OP_RIGHT_SHIFT);
3185 if (PL_expect == XOPERATOR) {
3186 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3189 return ','; /* grandfather non-comma-format format */
3193 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
3194 PL_tokenbuf[0] = '@';
3195 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3196 sizeof PL_tokenbuf - 1, FALSE);
3197 if (PL_expect == XOPERATOR)
3198 no_op("Array length", s);
3199 if (!PL_tokenbuf[1])
3201 PL_expect = XOPERATOR;
3202 PL_pending_ident = '#';
3206 PL_tokenbuf[0] = '$';
3207 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3208 sizeof PL_tokenbuf - 1, FALSE);
3209 if (PL_expect == XOPERATOR)
3211 if (!PL_tokenbuf[1]) {
3213 yyerror("Final $ should be \\$ or $name");
3217 /* This kludge not intended to be bulletproof. */
3218 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
3219 yylval.opval = newSVOP(OP_CONST, 0,
3220 newSViv((IV)PL_compiling.cop_arybase));
3221 yylval.opval->op_private = OPpCONST_ARYBASE;
3227 if (PL_lex_state == LEX_NORMAL)
3230 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3233 PL_tokenbuf[0] = '@';
3234 if (ckWARN(WARN_SYNTAX)) {
3236 isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$';
3239 PL_bufptr = skipspace(PL_bufptr);
3240 while (t < PL_bufend && *t != ']')
3242 Perl_warner(aTHX_ WARN_SYNTAX,
3243 "Multidimensional syntax %.*s not supported",
3244 (t - PL_bufptr) + 1, PL_bufptr);
3248 else if (*s == '{') {
3249 PL_tokenbuf[0] = '%';
3250 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
3251 (t = strchr(s, '}')) && (t = strchr(t, '=')))
3253 char tmpbuf[sizeof PL_tokenbuf];
3255 for (t++; isSPACE(*t); t++) ;
3256 if (isIDFIRST_lazy_if(t,UTF)) {
3257 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
3258 for (; isSPACE(*t); t++) ;
3259 if (*t == ';' && get_cv(tmpbuf, FALSE))
3260 Perl_warner(aTHX_ WARN_SYNTAX,
3261 "You need to quote \"%s\"", tmpbuf);
3267 PL_expect = XOPERATOR;
3268 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3269 bool islop = (PL_last_lop == PL_oldoldbufptr);
3270 if (!islop || PL_last_lop_op == OP_GREPSTART)
3271 PL_expect = XOPERATOR;
3272 else if (strchr("$@\"'`q", *s))
3273 PL_expect = XTERM; /* e.g. print $fh "foo" */
3274 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
3275 PL_expect = XTERM; /* e.g. print $fh &sub */
3276 else if (isIDFIRST_lazy_if(s,UTF)) {
3277 char tmpbuf[sizeof PL_tokenbuf];
3278 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3279 if (tmp = keyword(tmpbuf, len)) {
3280 /* binary operators exclude handle interpretations */
3292 PL_expect = XTERM; /* e.g. print $fh length() */
3297 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
3298 if (gv && GvCVu(gv))
3299 PL_expect = XTERM; /* e.g. print $fh subr() */
3302 else if (isDIGIT(*s))
3303 PL_expect = XTERM; /* e.g. print $fh 3 */
3304 else if (*s == '.' && isDIGIT(s[1]))
3305 PL_expect = XTERM; /* e.g. print $fh .3 */
3306 else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
3307 PL_expect = XTERM; /* e.g. print $fh -1 */
3308 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3309 PL_expect = XTERM; /* print $fh <<"EOF" */
3311 PL_pending_ident = '$';
3315 if (PL_expect == XOPERATOR)
3317 PL_tokenbuf[0] = '@';
3318 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3319 if (!PL_tokenbuf[1]) {
3321 yyerror("Final @ should be \\@ or @name");
3324 if (PL_lex_state == LEX_NORMAL)
3326 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3328 PL_tokenbuf[0] = '%';
3330 /* Warn about @ where they meant $. */
3331 if (ckWARN(WARN_SYNTAX)) {
3332 if (*s == '[' || *s == '{') {
3334 while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
3336 if (*t == '}' || *t == ']') {
3338 PL_bufptr = skipspace(PL_bufptr);
3339 Perl_warner(aTHX_ WARN_SYNTAX,
3340 "Scalar value %.*s better written as $%.*s",
3341 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
3346 PL_pending_ident = '@';
3349 case '/': /* may either be division or pattern */
3350 case '?': /* may either be conditional or pattern */
3351 if (PL_expect != XOPERATOR) {
3352 /* Disable warning on "study /blah/" */
3353 if (PL_oldoldbufptr == PL_last_uni
3354 && (*PL_last_uni != 's' || s - PL_last_uni < 5
3355 || memNE(PL_last_uni, "study", 5)
3356 || isALNUM_lazy_if(PL_last_uni+5,UTF)))
3358 s = scan_pat(s,OP_MATCH);
3359 TERM(sublex_start());
3367 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3368 #ifdef PERL_STRICT_CR
3371 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3373 && (s == PL_linestart || s[-1] == '\n') )
3375 PL_lex_formbrack = 0;
3379 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
3385 yylval.ival = OPf_SPECIAL;
3391 if (PL_expect != XOPERATOR)
3396 case '0': case '1': case '2': case '3': case '4':
3397 case '5': case '6': case '7': case '8': case '9':
3399 if (PL_expect == XOPERATOR)
3404 s = scan_str(s,FALSE,FALSE);
3405 if (PL_expect == XOPERATOR) {
3406 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3409 return ','; /* grandfather non-comma-format format */
3415 missingterm((char*)0);
3416 yylval.ival = OP_CONST;
3417 TERM(sublex_start());
3420 s = scan_str(s,FALSE,FALSE);
3421 if (PL_expect == XOPERATOR) {
3422 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3425 return ','; /* grandfather non-comma-format format */
3431 missingterm((char*)0);
3432 yylval.ival = OP_CONST;
3433 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
3434 if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
3435 yylval.ival = OP_STRINGIFY;
3439 TERM(sublex_start());
3442 s = scan_str(s,FALSE,FALSE);
3443 if (PL_expect == XOPERATOR)
3444 no_op("Backticks",s);
3446 missingterm((char*)0);
3447 yylval.ival = OP_BACKTICK;
3449 TERM(sublex_start());
3453 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
3454 Perl_warner(aTHX_ WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
3456 if (PL_expect == XOPERATOR)
3457 no_op("Backslash",s);
3461 if (isDIGIT(s[1]) && PL_expect == XTERM) {
3465 while (isDIGIT(*start))
3467 if (*start == '.' && isDIGIT(start[1])) {
3474 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
3514 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3516 /* Some keywords can be followed by any delimiter, including ':' */
3517 tmp = (len == 1 && strchr("msyq", PL_tokenbuf[0]) ||
3518 len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
3519 (PL_tokenbuf[0] == 'q' &&
3520 strchr("qwxr", PL_tokenbuf[1]))));
3522 /* x::* is just a word, unless x is "CORE" */
3523 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
3527 while (d < PL_bufend && isSPACE(*d))
3528 d++; /* no comments skipped here, or s### is misparsed */
3530 /* Is this a label? */
3531 if (!tmp && PL_expect == XSTATE
3532 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
3534 yylval.pval = savepv(PL_tokenbuf);
3539 /* Check for keywords */
3540 tmp = keyword(PL_tokenbuf, len);
3542 /* Is this a word before a => operator? */
3543 if (strnEQ(d,"=>",2)) {
3545 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
3546 yylval.opval->op_private = OPpCONST_BARE;
3550 if (tmp < 0) { /* second-class keyword? */
3551 GV *ogv = Nullgv; /* override (winner) */
3552 GV *hgv = Nullgv; /* hidden (loser) */
3553 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3555 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3558 if (GvIMPORTED_CV(gv))
3560 else if (! CvMETHOD(cv))
3564 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3565 (gv = *gvp) != (GV*)&PL_sv_undef &&
3566 GvCVu(gv) && GvIMPORTED_CV(gv))
3572 tmp = 0; /* overridden by import or by GLOBAL */
3575 && -tmp==KEY_lock /* XXX generalizable kludge */
3577 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3579 tmp = 0; /* any sub overrides "weak" keyword */
3581 else { /* no override */
3585 if (ckWARN(WARN_AMBIGUOUS) && hgv
3586 && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3587 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3588 "Ambiguous call resolved as CORE::%s(), %s",
3589 GvENAME(hgv), "qualify as such or use &");
3596 default: /* not a keyword */
3599 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3601 /* Get the rest if it looks like a package qualifier */
3603 if (*s == '\'' || *s == ':' && s[1] == ':') {
3605 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3608 Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
3609 *s == '\'' ? "'" : "::");
3613 if (PL_expect == XOPERATOR) {
3614 if (PL_bufptr == PL_linestart) {
3615 CopLINE_dec(PL_curcop);
3616 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3617 CopLINE_inc(PL_curcop);
3620 no_op("Bareword",s);
3623 /* Look for a subroutine with this name in current package,
3624 unless name is "Foo::", in which case Foo is a bearword
3625 (and a package name). */
3628 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3630 if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3631 Perl_warner(aTHX_ WARN_BAREWORD,
3632 "Bareword \"%s\" refers to nonexistent package",
3635 PL_tokenbuf[len] = '\0';
3642 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3645 /* if we saw a global override before, get the right name */
3648 sv = newSVpvn("CORE::GLOBAL::",14);
3649 sv_catpv(sv,PL_tokenbuf);
3652 sv = newSVpv(PL_tokenbuf,0);
3654 /* Presume this is going to be a bareword of some sort. */
3657 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3658 yylval.opval->op_private = OPpCONST_BARE;
3660 /* And if "Foo::", then that's what it certainly is. */
3665 /* See if it's the indirect object for a list operator. */
3667 if (PL_oldoldbufptr &&
3668 PL_oldoldbufptr < PL_bufptr &&
3669 (PL_oldoldbufptr == PL_last_lop
3670 || PL_oldoldbufptr == PL_last_uni) &&
3671 /* NO SKIPSPACE BEFORE HERE! */
3672 (PL_expect == XREF ||
3673 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
3675 bool immediate_paren = *s == '(';
3677 /* (Now we can afford to cross potential line boundary.) */
3680 /* Two barewords in a row may indicate method call. */
3682 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp=intuit_method(s,gv)))
3685 /* If not a declared subroutine, it's an indirect object. */
3686 /* (But it's an indir obj regardless for sort.) */
3688 if ((PL_last_lop_op == OP_SORT ||
3689 (!immediate_paren && (!gv || !GvCVu(gv)))) &&
3690 (PL_last_lop_op != OP_MAPSTART &&
3691 PL_last_lop_op != OP_GREPSTART))
3693 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3698 /* If followed by a paren, it's certainly a subroutine. */
3700 PL_expect = XOPERATOR;
3704 if (gv && GvCVu(gv)) {
3705 for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
3706 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
3711 PL_nextval[PL_nexttoke].opval = yylval.opval;
3712 PL_expect = XOPERATOR;
3718 /* If followed by var or block, call it a method (unless sub) */
3720 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3721 PL_last_lop = PL_oldbufptr;
3722 PL_last_lop_op = OP_METHOD;
3726 /* If followed by a bareword, see if it looks like indir obj. */
3728 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp = intuit_method(s,gv)))
3731 /* Not a method, so call it a subroutine (if defined) */
3733 if (gv && GvCVu(gv)) {
3735 if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
3736 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3737 "Ambiguous use of -%s resolved as -&%s()",
3738 PL_tokenbuf, PL_tokenbuf);
3739 /* Check for a constant sub */
3741 if ((sv = cv_const_sv(cv))) {
3743 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3744 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3745 yylval.opval->op_private = 0;
3749 /* Resolve to GV now. */
3750 op_free(yylval.opval);
3751 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3752 yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
3753 PL_last_lop = PL_oldbufptr;
3754 PL_last_lop_op = OP_ENTERSUB;
3755 /* Is there a prototype? */
3758 char *proto = SvPV((SV*)cv, len);
3761 if (strEQ(proto, "$"))
3763 if (*proto == '&' && *s == '{') {
3764 sv_setpv(PL_subname,"__ANON__");
3768 PL_nextval[PL_nexttoke].opval = yylval.opval;
3774 /* Call it a bare word */
3776 if (PL_hints & HINT_STRICT_SUBS)
3777 yylval.opval->op_private |= OPpCONST_STRICT;
3780 if (ckWARN(WARN_RESERVED)) {
3781 if (lastchar != '-') {
3782 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3784 Perl_warner(aTHX_ WARN_RESERVED, PL_warn_reserved,
3791 if (lastchar && strchr("*%&", lastchar) && ckWARN_d(WARN_AMBIGUOUS)) {
3792 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3793 "Operator or semicolon missing before %c%s",
3794 lastchar, PL_tokenbuf);
3795 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3796 "Ambiguous use of %c resolved as operator %c",
3797 lastchar, lastchar);
3803 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3804 newSVpv(CopFILE(PL_curcop),0));
3808 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3809 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
3812 case KEY___PACKAGE__:
3813 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3815 ? newSVsv(PL_curstname)
3824 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3825 char *pname = "main";
3826 if (PL_tokenbuf[2] == 'D')
3827 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3828 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
3831 GvIOp(gv) = newIO();
3832 IoIFP(GvIOp(gv)) = PL_rsfp;
3833 #if defined(HAS_FCNTL) && defined(F_SETFD)
3835 int fd = PerlIO_fileno(PL_rsfp);
3836 fcntl(fd,F_SETFD,fd >= 3);
3839 /* Mark this internal pseudo-handle as clean */
3840 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3842 IoTYPE(GvIOp(gv)) = '|';
3843 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
3844 IoTYPE(GvIOp(gv)) = '-';
3846 IoTYPE(GvIOp(gv)) = '<';
3847 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
3848 /* if the script was opened in binmode, we need to revert
3849 * it to text mode for compatibility; but only iff it has CRs
3850 * XXX this is a questionable hack at best. */
3851 if (PL_bufend-PL_bufptr > 2
3852 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
3855 if (IoTYPE(GvIOp(gv)) == '<') {
3856 loc = PerlIO_tell(PL_rsfp);
3857 (void)PerlIO_seek(PL_rsfp, 0L, 0);
3859 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
3860 #if defined(__BORLANDC__)
3861 /* XXX see note in do_binmode() */
3862 ((FILE*)PL_rsfp)->flags |= _F_BIN;
3865 PerlIO_seek(PL_rsfp, loc, 0);
3880 if (PL_expect == XSTATE) {
3887 if (*s == ':' && s[1] == ':') {
3890 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3891 tmp = keyword(PL_tokenbuf, len);
3905 LOP(OP_ACCEPT,XTERM);
3911 LOP(OP_ATAN2,XTERM);
3920 LOP(OP_BLESS,XTERM);
3929 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
3946 if (!PL_cryptseen) {
3947 PL_cryptseen = TRUE;
3951 LOP(OP_CRYPT,XTERM);
3954 if (ckWARN(WARN_CHMOD)) {
3955 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
3956 if (*d != '0' && isDIGIT(*d))
3957 Perl_warner(aTHX_ WARN_CHMOD,
3958 "chmod() mode argument is missing initial 0");
3960 LOP(OP_CHMOD,XTERM);
3963 LOP(OP_CHOWN,XTERM);
3966 LOP(OP_CONNECT,XTERM);
3982 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3986 PL_hints |= HINT_BLOCK_SCOPE;
3996 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3997 LOP(OP_DBMOPEN,XTERM);
4003 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4010 yylval.ival = CopLINE(PL_curcop);
4024 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
4025 UNIBRACK(OP_ENTEREVAL);
4040 case KEY_endhostent:
4046 case KEY_endservent:
4049 case KEY_endprotoent:
4060 yylval.ival = CopLINE(PL_curcop);
4062 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
4064 if ((PL_bufend - p) >= 3 &&
4065 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
4067 else if ((PL_bufend - p) >= 4 &&
4068 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
4071 if (isIDFIRST_lazy_if(p,UTF)) {
4072 p = scan_ident(p, PL_bufend,
4073 PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4077 Perl_croak(aTHX_ "Missing $ on loop variable");
4082 LOP(OP_FORMLINE,XTERM);
4088 LOP(OP_FCNTL,XTERM);
4094 LOP(OP_FLOCK,XTERM);
4103 LOP(OP_GREPSTART, XREF);
4106 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4121 case KEY_getpriority:
4122 LOP(OP_GETPRIORITY,XTERM);
4124 case KEY_getprotobyname:
4127 case KEY_getprotobynumber:
4128 LOP(OP_GPBYNUMBER,XTERM);
4130 case KEY_getprotoent:
4142 case KEY_getpeername:
4143 UNI(OP_GETPEERNAME);
4145 case KEY_gethostbyname:
4148 case KEY_gethostbyaddr:
4149 LOP(OP_GHBYADDR,XTERM);
4151 case KEY_gethostent:
4154 case KEY_getnetbyname:
4157 case KEY_getnetbyaddr:
4158 LOP(OP_GNBYADDR,XTERM);
4163 case KEY_getservbyname:
4164 LOP(OP_GSBYNAME,XTERM);
4166 case KEY_getservbyport:
4167 LOP(OP_GSBYPORT,XTERM);
4169 case KEY_getservent:
4172 case KEY_getsockname:
4173 UNI(OP_GETSOCKNAME);
4175 case KEY_getsockopt:
4176 LOP(OP_GSOCKOPT,XTERM);
4198 yylval.ival = CopLINE(PL_curcop);
4202 LOP(OP_INDEX,XTERM);
4208 LOP(OP_IOCTL,XTERM);
4220 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4252 LOP(OP_LISTEN,XTERM);
4261 s = scan_pat(s,OP_MATCH);
4262 TERM(sublex_start());
4265 LOP(OP_MAPSTART, XREF);
4268 LOP(OP_MKDIR,XTERM);
4271 LOP(OP_MSGCTL,XTERM);
4274 LOP(OP_MSGGET,XTERM);
4277 LOP(OP_MSGRCV,XTERM);
4280 LOP(OP_MSGSND,XTERM);
4286 if (isIDFIRST_lazy_if(s,UTF)) {
4287 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
4288 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
4290 PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
4291 if (!PL_in_my_stash) {
4294 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
4302 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4309 if (PL_expect != XSTATE)
4310 yyerror("\"no\" not allowed in expression");
4311 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4312 s = force_version(s);
4317 if (*s == '(' || (s = skipspace(s), *s == '('))
4324 if (isIDFIRST_lazy_if(s,UTF)) {
4326 for (d = s; isALNUM_lazy_if(d,UTF); d++) ;
4328 if (strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE))
4329 Perl_warner(aTHX_ WARN_PRECEDENCE,
4330 "Precedence problem: open %.*s should be open(%.*s)",
4336 yylval.ival = OP_OR;
4346 LOP(OP_OPEN_DIR,XTERM);
4349 checkcomma(s,PL_tokenbuf,"filehandle");
4353 checkcomma(s,PL_tokenbuf,"filehandle");
4372 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4376 LOP(OP_PIPE_OP,XTERM);
4379 s = scan_str(s,FALSE,FALSE);
4381 missingterm((char*)0);
4382 yylval.ival = OP_CONST;
4383 TERM(sublex_start());
4389 s = scan_str(s,FALSE,FALSE);
4391 missingterm((char*)0);
4393 if (SvCUR(PL_lex_stuff)) {
4396 d = SvPV_force(PL_lex_stuff, len);
4398 for (; isSPACE(*d) && len; --len, ++d) ;
4401 if (!warned && ckWARN(WARN_QW)) {
4402 for (; !isSPACE(*d) && len; --len, ++d) {
4404 Perl_warner(aTHX_ WARN_QW,
4405 "Possible attempt to separate words with commas");
4408 else if (*d == '#') {
4409 Perl_warner(aTHX_ WARN_QW,
4410 "Possible attempt to put comments in qw() list");
4416 for (; !isSPACE(*d) && len; --len, ++d) ;
4418 words = append_elem(OP_LIST, words,
4419 newSVOP(OP_CONST, 0, newSVpvn(b, d-b)));
4423 PL_nextval[PL_nexttoke].opval = words;
4428 SvREFCNT_dec(PL_lex_stuff);
4429 PL_lex_stuff = Nullsv;
4434 s = scan_str(s,FALSE,FALSE);
4436 missingterm((char*)0);
4437 yylval.ival = OP_STRINGIFY;
4438 if (SvIVX(PL_lex_stuff) == '\'')
4439 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
4440 TERM(sublex_start());
4443 s = scan_pat(s,OP_QR);
4444 TERM(sublex_start());
4447 s = scan_str(s,FALSE,FALSE);
4449 missingterm((char*)0);
4450 yylval.ival = OP_BACKTICK;
4452 TERM(sublex_start());
4459 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4460 s = force_version(s);
4463 *PL_tokenbuf = '\0';
4464 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4465 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
4466 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
4468 yyerror("<> should be quotes");
4476 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4480 LOP(OP_RENAME,XTERM);
4489 LOP(OP_RINDEX,XTERM);
4512 LOP(OP_REVERSE,XTERM);
4523 TERM(sublex_start());
4525 TOKEN(1); /* force error */
4534 LOP(OP_SELECT,XTERM);
4540 LOP(OP_SEMCTL,XTERM);
4543 LOP(OP_SEMGET,XTERM);
4546 LOP(OP_SEMOP,XTERM);
4552 LOP(OP_SETPGRP,XTERM);
4554 case KEY_setpriority:
4555 LOP(OP_SETPRIORITY,XTERM);
4557 case KEY_sethostent:
4563 case KEY_setservent:
4566 case KEY_setprotoent:
4576 LOP(OP_SEEKDIR,XTERM);
4578 case KEY_setsockopt:
4579 LOP(OP_SSOCKOPT,XTERM);
4585 LOP(OP_SHMCTL,XTERM);
4588 LOP(OP_SHMGET,XTERM);
4591 LOP(OP_SHMREAD,XTERM);
4594 LOP(OP_SHMWRITE,XTERM);
4597 LOP(OP_SHUTDOWN,XTERM);
4606 LOP(OP_SOCKET,XTERM);
4608 case KEY_socketpair:
4609 LOP(OP_SOCKPAIR,XTERM);
4612 checkcomma(s,PL_tokenbuf,"subroutine name");
4614 if (*s == ';' || *s == ')') /* probably a close */
4615 Perl_croak(aTHX_ "sort is now a reserved word");
4617 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4621 LOP(OP_SPLIT,XTERM);
4624 LOP(OP_SPRINTF,XTERM);
4627 LOP(OP_SPLICE,XTERM);
4642 LOP(OP_SUBSTR,XTERM);
4648 char tmpbuf[sizeof PL_tokenbuf];
4650 expectation attrful;
4651 bool have_name, have_proto;
4656 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
4657 (*s == ':' && s[1] == ':'))
4660 attrful = XATTRBLOCK;
4661 /* remember buffer pos'n for later force_word */
4662 tboffset = s - PL_oldbufptr;
4663 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4664 if (strchr(tmpbuf, ':'))
4665 sv_setpv(PL_subname, tmpbuf);
4667 sv_setsv(PL_subname,PL_curstname);
4668 sv_catpvn(PL_subname,"::",2);
4669 sv_catpvn(PL_subname,tmpbuf,len);
4676 Perl_croak(aTHX_ "Missing name in \"my sub\"");
4677 PL_expect = XTERMBLOCK;
4678 attrful = XATTRTERM;
4679 sv_setpv(PL_subname,"?");
4683 if (key == KEY_format) {
4685 PL_lex_formbrack = PL_lex_brackets + 1;
4687 (void) force_word(PL_oldbufptr + tboffset, WORD,
4692 /* Look for a prototype */
4696 s = scan_str(s,FALSE,FALSE);
4699 SvREFCNT_dec(PL_lex_stuff);
4700 PL_lex_stuff = Nullsv;
4701 Perl_croak(aTHX_ "Prototype not terminated");
4704 d = SvPVX(PL_lex_stuff);
4706 for (p = d; *p; ++p) {
4711 SvCUR(PL_lex_stuff) = tmp;
4719 if (*s == ':' && s[1] != ':')
4720 PL_expect = attrful;
4723 PL_nextval[PL_nexttoke].opval =
4724 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4725 PL_lex_stuff = Nullsv;
4729 sv_setpv(PL_subname,"__ANON__");
4732 (void) force_word(PL_oldbufptr + tboffset, WORD,
4741 LOP(OP_SYSTEM,XREF);
4744 LOP(OP_SYMLINK,XTERM);
4747 LOP(OP_SYSCALL,XTERM);
4750 LOP(OP_SYSOPEN,XTERM);
4753 LOP(OP_SYSSEEK,XTERM);
4756 LOP(OP_SYSREAD,XTERM);
4759 LOP(OP_SYSWRITE,XTERM);
4763 TERM(sublex_start());
4784 LOP(OP_TRUNCATE,XTERM);
4796 yylval.ival = CopLINE(PL_curcop);
4800 yylval.ival = CopLINE(PL_curcop);
4804 LOP(OP_UNLINK,XTERM);
4810 LOP(OP_UNPACK,XTERM);
4813 LOP(OP_UTIME,XTERM);
4816 if (ckWARN(WARN_UMASK)) {
4817 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4818 if (*d != '0' && isDIGIT(*d))
4819 Perl_warner(aTHX_ WARN_UMASK,
4820 "umask: argument is missing initial 0");
4825 LOP(OP_UNSHIFT,XTERM);
4828 if (PL_expect != XSTATE)
4829 yyerror("\"use\" not allowed in expression");
4831 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4832 s = force_version(s);
4833 if (*s == ';' || (s = skipspace(s), *s == ';')) {
4834 PL_nextval[PL_nexttoke].opval = Nullop;
4839 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4840 s = force_version(s);
4852 yylval.ival = CopLINE(PL_curcop);
4856 PL_hints |= HINT_BLOCK_SCOPE;
4863 LOP(OP_WAITPID,XTERM);
4871 static char ctl_l[2];
4873 if (ctl_l[0] == '\0')
4874 ctl_l[0] = toCTRL('L');
4875 gv_fetchpv(ctl_l,TRUE, SVt_PV);
4878 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
4883 if (PL_expect == XOPERATOR)
4889 yylval.ival = OP_XOR;
4894 TERM(sublex_start());
4900 Perl_keyword(pTHX_ register char *d, I32 len)
4905 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
4906 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
4907 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
4908 if (strEQ(d,"__DATA__")) return KEY___DATA__;
4909 if (strEQ(d,"__END__")) return KEY___END__;
4913 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
4918 if (strEQ(d,"and")) return -KEY_and;
4919 if (strEQ(d,"abs")) return -KEY_abs;
4922 if (strEQ(d,"alarm")) return -KEY_alarm;
4923 if (strEQ(d,"atan2")) return -KEY_atan2;
4926 if (strEQ(d,"accept")) return -KEY_accept;
4931 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
4934 if (strEQ(d,"bless")) return -KEY_bless;
4935 if (strEQ(d,"bind")) return -KEY_bind;
4936 if (strEQ(d,"binmode")) return -KEY_binmode;
4939 if (strEQ(d,"CORE")) return -KEY_CORE;
4940 if (strEQ(d,"CHECK")) return KEY_CHECK;
4945 if (strEQ(d,"cmp")) return -KEY_cmp;
4946 if (strEQ(d,"chr")) return -KEY_chr;
4947 if (strEQ(d,"cos")) return -KEY_cos;
4950 if (strEQ(d,"chop")) return KEY_chop;
4953 if (strEQ(d,"close")) return -KEY_close;
4954 if (strEQ(d,"chdir")) return -KEY_chdir;
4955 if (strEQ(d,"chomp")) return KEY_chomp;
4956 if (strEQ(d,"chmod")) return -KEY_chmod;
4957 if (strEQ(d,"chown")) return -KEY_chown;
4958 if (strEQ(d,"crypt")) return -KEY_crypt;
4961 if (strEQ(d,"chroot")) return -KEY_chroot;
4962 if (strEQ(d,"caller")) return -KEY_caller;
4965 if (strEQ(d,"connect")) return -KEY_connect;
4968 if (strEQ(d,"closedir")) return -KEY_closedir;
4969 if (strEQ(d,"continue")) return -KEY_continue;
4974 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
4979 if (strEQ(d,"do")) return KEY_do;
4982 if (strEQ(d,"die")) return -KEY_die;
4985 if (strEQ(d,"dump")) return -KEY_dump;
4988 if (strEQ(d,"delete")) return KEY_delete;
4991 if (strEQ(d,"defined")) return KEY_defined;
4992 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
4995 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
5000 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
5001 if (strEQ(d,"END")) return KEY_END;
5006 if (strEQ(d,"eq")) return -KEY_eq;
5009 if (strEQ(d,"eof")) return -KEY_eof;
5010 if (strEQ(d,"exp")) return -KEY_exp;
5013 if (strEQ(d,"else")) return KEY_else;
5014 if (strEQ(d,"exit")) return -KEY_exit;
5015 if (strEQ(d,"eval")) return KEY_eval;
5016 if (strEQ(d,"exec")) return -KEY_exec;
5017 if (strEQ(d,"each")) return KEY_each;
5020 if (strEQ(d,"elsif")) return KEY_elsif;
5023 if (strEQ(d,"exists")) return KEY_exists;
5024 if (strEQ(d,"elseif")) Perl_warn(aTHX_ "elseif should be elsif");
5027 if (strEQ(d,"endgrent")) return -KEY_endgrent;
5028 if (strEQ(d,"endpwent")) return -KEY_endpwent;
5031 if (strEQ(d,"endnetent")) return -KEY_endnetent;
5034 if (strEQ(d,"endhostent")) return -KEY_endhostent;
5035 if (strEQ(d,"endservent")) return -KEY_endservent;
5038 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
5045 if (strEQ(d,"for")) return KEY_for;
5048 if (strEQ(d,"fork")) return -KEY_fork;
5051 if (strEQ(d,"fcntl")) return -KEY_fcntl;
5052 if (strEQ(d,"flock")) return -KEY_flock;
5055 if (strEQ(d,"format")) return KEY_format;
5056 if (strEQ(d,"fileno")) return -KEY_fileno;
5059 if (strEQ(d,"foreach")) return KEY_foreach;
5062 if (strEQ(d,"formline")) return -KEY_formline;
5068 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
5069 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
5073 if (strnEQ(d,"get",3)) {
5078 if (strEQ(d,"ppid")) return -KEY_getppid;
5079 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
5082 if (strEQ(d,"pwent")) return -KEY_getpwent;
5083 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
5084 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
5087 if (strEQ(d,"peername")) return -KEY_getpeername;
5088 if (strEQ(d,"protoent")) return -KEY_getprotoent;
5089 if (strEQ(d,"priority")) return -KEY_getpriority;
5092 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
5095 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
5099 else if (*d == 'h') {
5100 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
5101 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
5102 if (strEQ(d,"hostent")) return -KEY_gethostent;
5104 else if (*d == 'n') {
5105 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
5106 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
5107 if (strEQ(d,"netent")) return -KEY_getnetent;
5109 else if (*d == 's') {
5110 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
5111 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
5112 if (strEQ(d,"servent")) return -KEY_getservent;
5113 if (strEQ(d,"sockname")) return -KEY_getsockname;
5114 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
5116 else if (*d == 'g') {
5117 if (strEQ(d,"grent")) return -KEY_getgrent;
5118 if (strEQ(d,"grnam")) return -KEY_getgrnam;
5119 if (strEQ(d,"grgid")) return -KEY_getgrgid;
5121 else if (*d == 'l') {
5122 if (strEQ(d,"login")) return -KEY_getlogin;
5124 else if (strEQ(d,"c")) return -KEY_getc;
5129 if (strEQ(d,"gt")) return -KEY_gt;
5130 if (strEQ(d,"ge")) return -KEY_ge;
5133 if (strEQ(d,"grep")) return KEY_grep;
5134 if (strEQ(d,"goto")) return KEY_goto;
5135 if (strEQ(d,"glob")) return KEY_glob;
5138 if (strEQ(d,"gmtime")) return -KEY_gmtime;
5143 if (strEQ(d,"hex")) return -KEY_hex;
5146 if (strEQ(d,"INIT")) return KEY_INIT;
5151 if (strEQ(d,"if")) return KEY_if;
5154 if (strEQ(d,"int")) return -KEY_int;
5157 if (strEQ(d,"index")) return -KEY_index;
5158 if (strEQ(d,"ioctl")) return -KEY_ioctl;
5163 if (strEQ(d,"join")) return -KEY_join;
5167 if (strEQ(d,"keys")) return KEY_keys;
5168 if (strEQ(d,"kill")) return -KEY_kill;
5173 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
5174 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
5180 if (strEQ(d,"lt")) return -KEY_lt;
5181 if (strEQ(d,"le")) return -KEY_le;
5182 if (strEQ(d,"lc")) return -KEY_lc;
5185 if (strEQ(d,"log")) return -KEY_log;
5188 if (strEQ(d,"last")) return KEY_last;
5189 if (strEQ(d,"link")) return -KEY_link;
5190 if (strEQ(d,"lock")) return -KEY_lock;
5193 if (strEQ(d,"local")) return KEY_local;
5194 if (strEQ(d,"lstat")) return -KEY_lstat;
5197 if (strEQ(d,"length")) return -KEY_length;
5198 if (strEQ(d,"listen")) return -KEY_listen;
5201 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
5204 if (strEQ(d,"localtime")) return -KEY_localtime;
5210 case 1: return KEY_m;
5212 if (strEQ(d,"my")) return KEY_my;
5215 if (strEQ(d,"map")) return KEY_map;
5218 if (strEQ(d,"mkdir")) return -KEY_mkdir;
5221 if (strEQ(d,"msgctl")) return -KEY_msgctl;
5222 if (strEQ(d,"msgget")) return -KEY_msgget;
5223 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
5224 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
5229 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
5232 if (strEQ(d,"next")) return KEY_next;
5233 if (strEQ(d,"ne")) return -KEY_ne;
5234 if (strEQ(d,"not")) return -KEY_not;
5235 if (strEQ(d,"no")) return KEY_no;
5240 if (strEQ(d,"or")) return -KEY_or;
5243 if (strEQ(d,"ord")) return -KEY_ord;
5244 if (strEQ(d,"oct")) return -KEY_oct;
5245 if (strEQ(d,"our")) return KEY_our;
5248 if (strEQ(d,"open")) return -KEY_open;
5251 if (strEQ(d,"opendir")) return -KEY_opendir;
5258 if (strEQ(d,"pop")) return KEY_pop;
5259 if (strEQ(d,"pos")) return KEY_pos;
5262 if (strEQ(d,"push")) return KEY_push;
5263 if (strEQ(d,"pack")) return -KEY_pack;
5264 if (strEQ(d,"pipe")) return -KEY_pipe;
5267 if (strEQ(d,"print")) return KEY_print;
5270 if (strEQ(d,"printf")) return KEY_printf;
5273 if (strEQ(d,"package")) return KEY_package;
5276 if (strEQ(d,"prototype")) return KEY_prototype;
5281 if (strEQ(d,"q")) return KEY_q;
5282 if (strEQ(d,"qr")) return KEY_qr;
5283 if (strEQ(d,"qq")) return KEY_qq;
5284 if (strEQ(d,"qw")) return KEY_qw;
5285 if (strEQ(d,"qx")) return KEY_qx;
5287 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
5292 if (strEQ(d,"ref")) return -KEY_ref;
5295 if (strEQ(d,"read")) return -KEY_read;
5296 if (strEQ(d,"rand")) return -KEY_rand;
5297 if (strEQ(d,"recv")) return -KEY_recv;
5298 if (strEQ(d,"redo")) return KEY_redo;
5301 if (strEQ(d,"rmdir")) return -KEY_rmdir;
5302 if (strEQ(d,"reset")) return -KEY_reset;
5305 if (strEQ(d,"return")) return KEY_return;
5306 if (strEQ(d,"rename")) return -KEY_rename;
5307 if (strEQ(d,"rindex")) return -KEY_rindex;
5310 if (strEQ(d,"require")) return -KEY_require;
5311 if (strEQ(d,"reverse")) return -KEY_reverse;
5312 if (strEQ(d,"readdir")) return -KEY_readdir;
5315 if (strEQ(d,"readlink")) return -KEY_readlink;
5316 if (strEQ(d,"readline")) return -KEY_readline;
5317 if (strEQ(d,"readpipe")) return -KEY_readpipe;
5320 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
5326 case 0: return KEY_s;
5328 if (strEQ(d,"scalar")) return KEY_scalar;
5333 if (strEQ(d,"seek")) return -KEY_seek;
5334 if (strEQ(d,"send")) return -KEY_send;
5337 if (strEQ(d,"semop")) return -KEY_semop;
5340 if (strEQ(d,"select")) return -KEY_select;
5341 if (strEQ(d,"semctl")) return -KEY_semctl;
5342 if (strEQ(d,"semget")) return -KEY_semget;
5345 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
5346 if (strEQ(d,"seekdir")) return -KEY_seekdir;
5349 if (strEQ(d,"setpwent")) return -KEY_setpwent;
5350 if (strEQ(d,"setgrent")) return -KEY_setgrent;
5353 if (strEQ(d,"setnetent")) return -KEY_setnetent;
5356 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
5357 if (strEQ(d,"sethostent")) return -KEY_sethostent;
5358 if (strEQ(d,"setservent")) return -KEY_setservent;
5361 if (strEQ(d,"setpriority")) return -KEY_setpriority;
5362 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
5369 if (strEQ(d,"shift")) return KEY_shift;
5372 if (strEQ(d,"shmctl")) return -KEY_shmctl;
5373 if (strEQ(d,"shmget")) return -KEY_shmget;
5376 if (strEQ(d,"shmread")) return -KEY_shmread;
5379 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
5380 if (strEQ(d,"shutdown")) return -KEY_shutdown;
5385 if (strEQ(d,"sin")) return -KEY_sin;
5388 if (strEQ(d,"sleep")) return -KEY_sleep;
5391 if (strEQ(d,"sort")) return KEY_sort;
5392 if (strEQ(d,"socket")) return -KEY_socket;
5393 if (strEQ(d,"socketpair")) return -KEY_socketpair;
5396 if (strEQ(d,"split")) return KEY_split;
5397 if (strEQ(d,"sprintf")) return -KEY_sprintf;
5398 if (strEQ(d,"splice")) return KEY_splice;
5401 if (strEQ(d,"sqrt")) return -KEY_sqrt;
5404 if (strEQ(d,"srand")) return -KEY_srand;
5407 if (strEQ(d,"stat")) return -KEY_stat;
5408 if (strEQ(d,"study")) return KEY_study;
5411 if (strEQ(d,"substr")) return -KEY_substr;
5412 if (strEQ(d,"sub")) return KEY_sub;
5417 if (strEQ(d,"system")) return -KEY_system;
5420 if (strEQ(d,"symlink")) return -KEY_symlink;
5421 if (strEQ(d,"syscall")) return -KEY_syscall;
5422 if (strEQ(d,"sysopen")) return -KEY_sysopen;
5423 if (strEQ(d,"sysread")) return -KEY_sysread;
5424 if (strEQ(d,"sysseek")) return -KEY_sysseek;
5427 if (strEQ(d,"syswrite")) return -KEY_syswrite;
5436 if (strEQ(d,"tr")) return KEY_tr;
5439 if (strEQ(d,"tie")) return KEY_tie;
5442 if (strEQ(d,"tell")) return -KEY_tell;
5443 if (strEQ(d,"tied")) return KEY_tied;
5444 if (strEQ(d,"time")) return -KEY_time;
5447 if (strEQ(d,"times")) return -KEY_times;
5450 if (strEQ(d,"telldir")) return -KEY_telldir;
5453 if (strEQ(d,"truncate")) return -KEY_truncate;
5460 if (strEQ(d,"uc")) return -KEY_uc;
5463 if (strEQ(d,"use")) return KEY_use;
5466 if (strEQ(d,"undef")) return KEY_undef;
5467 if (strEQ(d,"until")) return KEY_until;
5468 if (strEQ(d,"untie")) return KEY_untie;
5469 if (strEQ(d,"utime")) return -KEY_utime;
5470 if (strEQ(d,"umask")) return -KEY_umask;
5473 if (strEQ(d,"unless")) return KEY_unless;
5474 if (strEQ(d,"unpack")) return -KEY_unpack;
5475 if (strEQ(d,"unlink")) return -KEY_unlink;
5478 if (strEQ(d,"unshift")) return KEY_unshift;
5479 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
5484 if (strEQ(d,"values")) return -KEY_values;
5485 if (strEQ(d,"vec")) return -KEY_vec;
5490 if (strEQ(d,"warn")) return -KEY_warn;
5491 if (strEQ(d,"wait")) return -KEY_wait;
5494 if (strEQ(d,"while")) return KEY_while;
5495 if (strEQ(d,"write")) return -KEY_write;
5498 if (strEQ(d,"waitpid")) return -KEY_waitpid;
5501 if (strEQ(d,"wantarray")) return -KEY_wantarray;
5506 if (len == 1) return -KEY_x;
5507 if (strEQ(d,"xor")) return -KEY_xor;
5510 if (len == 1) return KEY_y;
5519 S_checkcomma(pTHX_ register char *s, char *name, char *what)
5523 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
5524 dTHR; /* only for ckWARN */
5525 if (ckWARN(WARN_SYNTAX)) {
5527 for (w = s+2; *w && level; w++) {
5534 for (; *w && isSPACE(*w); w++) ;
5535 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
5536 Perl_warner(aTHX_ WARN_SYNTAX,
5537 "%s (...) interpreted as function",name);
5540 while (s < PL_bufend && isSPACE(*s))
5544 while (s < PL_bufend && isSPACE(*s))
5546 if (isIDFIRST_lazy_if(s,UTF)) {
5548 while (isALNUM_lazy_if(s,UTF))
5550 while (s < PL_bufend && isSPACE(*s))
5555 kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
5559 Perl_croak(aTHX_ "No comma allowed after %s", what);
5564 /* Either returns sv, or mortalizes sv and returns a new SV*.
5565 Best used as sv=new_constant(..., sv, ...).
5566 If s, pv are NULL, calls subroutine with one argument,
5567 and type is used with error messages only. */
5570 S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv,
5574 HV *table = GvHV(PL_hintgv); /* ^H */
5578 const char *why, *why1, *why2;
5580 if (!(PL_hints & HINT_LOCALIZE_HH)) {
5583 why = "%^H is not localized";
5587 msg = Perl_newSVpvf(aTHX_ "constant(%s): %s%s%s",
5588 (type ? type: "undef"), why1, why2, why);
5589 yyerror(SvPVX(msg));
5594 why = "%^H is not defined";
5597 cvp = hv_fetch(table, key, strlen(key), FALSE);
5598 if (!cvp || !SvOK(*cvp)) {
5599 why = "} is not defined";
5604 sv_2mortal(sv); /* Parent created it permanently */
5607 pv = sv_2mortal(newSVpvn(s, len));
5609 typesv = sv_2mortal(newSVpv(type, 0));
5611 typesv = &PL_sv_undef;
5613 PUSHSTACKi(PERLSI_OVERLOAD);
5626 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
5630 /* Check the eval first */
5631 if (!PL_in_eval && SvTRUE(ERRSV))
5634 sv_catpv(ERRSV, "Propagated");
5635 yyerror(SvPV(ERRSV, n_a)); /* Duplicates the message inside eval */
5637 res = SvREFCNT_inc(sv);
5641 (void)SvREFCNT_inc(res);
5650 why = "}} did not return a defined value";
5651 why1 = "Call to &{$^H{";
5661 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
5663 register char *d = dest;
5664 register char *e = d + destlen - 3; /* two-character token, ending NUL */
5667 Perl_croak(aTHX_ ident_too_long);
5668 if (isALNUM(*s)) /* UTF handled below */
5670 else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) {
5675 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
5679 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5680 char *t = s + UTF8SKIP(s);
5681 while (*t & 0x80 && is_utf8_mark((U8*)t))
5683 if (d + (t - s) > e)
5684 Perl_croak(aTHX_ ident_too_long);
5685 Copy(s, d, t - s, char);
5698 S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
5708 e = d + destlen - 3; /* two-character token, ending NUL */
5710 while (isDIGIT(*s)) {
5712 Perl_croak(aTHX_ ident_too_long);
5719 Perl_croak(aTHX_ ident_too_long);
5720 if (isALNUM(*s)) /* UTF handled below */
5722 else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
5727 else if (*s == ':' && s[1] == ':') {
5731 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5732 char *t = s + UTF8SKIP(s);
5733 while (*t & 0x80 && is_utf8_mark((U8*)t))
5735 if (d + (t - s) > e)
5736 Perl_croak(aTHX_ ident_too_long);
5737 Copy(s, d, t - s, char);
5748 if (PL_lex_state != LEX_NORMAL)
5749 PL_lex_state = LEX_INTERPENDMAYBE;
5752 if (*s == '$' && s[1] &&
5753 (isALNUM_lazy_if(s+1,UTF) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
5766 if (*d == '^' && *s && isCONTROLVAR(*s)) {
5771 if (isSPACE(s[-1])) {
5774 if (ch != ' ' && ch != '\t') {
5780 if (isIDFIRST_lazy_if(d,UTF)) {
5784 while (e < send && isALNUM_lazy_if(e,UTF) || *e == ':') {
5786 while (e < send && *e & 0x80 && is_utf8_mark((U8*)e))
5789 Copy(s, d, e - s, char);
5794 while ((isALNUM(*s) || *s == ':') && d < e)
5797 Perl_croak(aTHX_ ident_too_long);
5800 while (s < send && (*s == ' ' || *s == '\t')) s++;
5801 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
5802 dTHR; /* only for ckWARN */
5803 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
5804 const char *brack = *s == '[' ? "[...]" : "{...}";
5805 Perl_warner(aTHX_ WARN_AMBIGUOUS,
5806 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
5807 funny, dest, brack, funny, dest, brack);
5810 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
5814 /* Handle extended ${^Foo} variables
5815 * 1999-02-27 mjd-perl-patch@plover.com */
5816 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
5820 while (isALNUM(*s) && d < e) {
5824 Perl_croak(aTHX_ ident_too_long);
5829 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
5830 PL_lex_state = LEX_INTERPEND;
5833 if (PL_lex_state == LEX_NORMAL) {
5834 dTHR; /* only for ckWARN */
5835 if (ckWARN(WARN_AMBIGUOUS) &&
5836 (keyword(dest, d - dest) || get_cv(dest, FALSE)))
5838 Perl_warner(aTHX_ WARN_AMBIGUOUS,
5839 "Ambiguous use of %c{%s} resolved to %c%s",
5840 funny, dest, funny, dest);
5845 s = bracket; /* let the parser handle it */
5849 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
5850 PL_lex_state = LEX_INTERPEND;
5855 Perl_pmflag(pTHX_ U16 *pmfl, int ch)
5860 *pmfl |= PMf_GLOBAL;
5862 *pmfl |= PMf_CONTINUE;
5866 *pmfl |= PMf_MULTILINE;
5868 *pmfl |= PMf_SINGLELINE;
5870 *pmfl |= PMf_EXTENDED;
5874 S_scan_pat(pTHX_ char *start, I32 type)
5879 s = scan_str(start,FALSE,FALSE);
5882 SvREFCNT_dec(PL_lex_stuff);
5883 PL_lex_stuff = Nullsv;
5884 Perl_croak(aTHX_ "Search pattern not terminated");
5887 pm = (PMOP*)newPMOP(type, 0);
5888 if (PL_multi_open == '?')
5889 pm->op_pmflags |= PMf_ONCE;
5891 while (*s && strchr("iomsx", *s))
5892 pmflag(&pm->op_pmflags,*s++);
5895 while (*s && strchr("iogcmsx", *s))
5896 pmflag(&pm->op_pmflags,*s++);
5898 pm->op_pmpermflags = pm->op_pmflags;
5900 PL_lex_op = (OP*)pm;
5901 yylval.ival = OP_MATCH;
5906 S_scan_subst(pTHX_ char *start)
5913 yylval.ival = OP_NULL;
5915 s = scan_str(start,FALSE,FALSE);
5919 SvREFCNT_dec(PL_lex_stuff);
5920 PL_lex_stuff = Nullsv;
5921 Perl_croak(aTHX_ "Substitution pattern not terminated");
5924 if (s[-1] == PL_multi_open)
5927 first_start = PL_multi_start;
5928 s = scan_str(s,FALSE,FALSE);
5931 SvREFCNT_dec(PL_lex_stuff);
5932 PL_lex_stuff = Nullsv;
5934 SvREFCNT_dec(PL_lex_repl);
5935 PL_lex_repl = Nullsv;
5936 Perl_croak(aTHX_ "Substitution replacement not terminated");
5938 PL_multi_start = first_start; /* so whole substitution is taken together */
5940 pm = (PMOP*)newPMOP(OP_SUBST, 0);
5946 else if (strchr("iogcmsx", *s))
5947 pmflag(&pm->op_pmflags,*s++);
5954 PL_sublex_info.super_bufptr = s;
5955 PL_sublex_info.super_bufend = PL_bufend;
5957 pm->op_pmflags |= PMf_EVAL;
5958 repl = newSVpvn("",0);
5960 sv_catpv(repl, es ? "eval " : "do ");
5961 sv_catpvn(repl, "{ ", 2);
5962 sv_catsv(repl, PL_lex_repl);
5963 sv_catpvn(repl, " };", 2);
5965 SvREFCNT_dec(PL_lex_repl);
5969 pm->op_pmpermflags = pm->op_pmflags;
5970 PL_lex_op = (OP*)pm;
5971 yylval.ival = OP_SUBST;
5976 S_scan_trans(pTHX_ char *start)
5987 yylval.ival = OP_NULL;
5989 s = scan_str(start,FALSE,FALSE);
5992 SvREFCNT_dec(PL_lex_stuff);
5993 PL_lex_stuff = Nullsv;
5994 Perl_croak(aTHX_ "Transliteration pattern not terminated");
5996 if (s[-1] == PL_multi_open)
5999 s = scan_str(s,FALSE,FALSE);
6002 SvREFCNT_dec(PL_lex_stuff);
6003 PL_lex_stuff = Nullsv;
6005 SvREFCNT_dec(PL_lex_repl);
6006 PL_lex_repl = Nullsv;
6007 Perl_croak(aTHX_ "Transliteration replacement not terminated");
6011 o = newSVOP(OP_TRANS, 0, 0);
6012 utf8 = OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF;
6015 New(803,tbl,256,short);
6016 o = newPVOP(OP_TRANS, 0, (char*)tbl);
6020 complement = del = squash = 0;
6021 while (strchr("cdsCU", *s)) {
6023 complement = OPpTRANS_COMPLEMENT;
6025 del = OPpTRANS_DELETE;
6027 squash = OPpTRANS_SQUASH;
6032 utf8 &= ~OPpTRANS_FROM_UTF;
6034 utf8 |= OPpTRANS_FROM_UTF;
6038 utf8 &= ~OPpTRANS_TO_UTF;
6040 utf8 |= OPpTRANS_TO_UTF;
6043 Perl_croak(aTHX_ "Too many /C and /U options");
6048 o->op_private = del|squash|complement|utf8;
6051 yylval.ival = OP_TRANS;
6056 S_scan_heredoc(pTHX_ register char *s)
6060 I32 op_type = OP_SCALAR;
6067 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
6071 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
6074 for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
6075 if (*peek && strchr("`'\"",*peek)) {
6078 s = delimcpy(d, e, s, PL_bufend, term, &len);
6088 if (!isALNUM_lazy_if(s,UTF))
6089 deprecate("bare << to mean <<\"\"");
6090 for (; isALNUM_lazy_if(s,UTF); s++) {
6095 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
6096 Perl_croak(aTHX_ "Delimiter for here document is too long");
6099 len = d - PL_tokenbuf;
6100 #ifndef PERL_STRICT_CR
6101 d = strchr(s, '\r');
6105 while (s < PL_bufend) {
6111 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
6120 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6125 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
6126 herewas = newSVpvn(s,PL_bufend-s);
6128 s--, herewas = newSVpvn(s,d-s);
6129 s += SvCUR(herewas);
6131 tmpstr = NEWSV(87,79);
6132 sv_upgrade(tmpstr, SVt_PVIV);
6137 else if (term == '`') {
6138 op_type = OP_BACKTICK;
6139 SvIVX(tmpstr) = '\\';
6143 PL_multi_start = CopLINE(PL_curcop);
6144 PL_multi_open = PL_multi_close = '<';
6145 term = *PL_tokenbuf;
6146 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
6147 char *bufptr = PL_sublex_info.super_bufptr;
6148 char *bufend = PL_sublex_info.super_bufend;
6149 char *olds = s - SvCUR(herewas);
6150 s = strchr(bufptr, '\n');
6154 while (s < bufend &&
6155 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6157 CopLINE_inc(PL_curcop);
6160 CopLINE_set(PL_curcop, PL_multi_start);
6161 missingterm(PL_tokenbuf);
6163 sv_setpvn(herewas,bufptr,d-bufptr+1);
6164 sv_setpvn(tmpstr,d+1,s-d);
6166 sv_catpvn(herewas,s,bufend-s);
6167 (void)strcpy(bufptr,SvPVX(herewas));
6174 while (s < PL_bufend &&
6175 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6177 CopLINE_inc(PL_curcop);
6179 if (s >= PL_bufend) {
6180 CopLINE_set(PL_curcop, PL_multi_start);
6181 missingterm(PL_tokenbuf);
6183 sv_setpvn(tmpstr,d+1,s-d);
6185 CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
6187 sv_catpvn(herewas,s,PL_bufend-s);
6188 sv_setsv(PL_linestr,herewas);
6189 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
6190 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6193 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
6194 while (s >= PL_bufend) { /* multiple line string? */
6196 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6197 CopLINE_set(PL_curcop, PL_multi_start);
6198 missingterm(PL_tokenbuf);
6200 CopLINE_inc(PL_curcop);
6201 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6202 #ifndef PERL_STRICT_CR
6203 if (PL_bufend - PL_linestart >= 2) {
6204 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
6205 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
6207 PL_bufend[-2] = '\n';
6209 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6211 else if (PL_bufend[-1] == '\r')
6212 PL_bufend[-1] = '\n';
6214 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
6215 PL_bufend[-1] = '\n';
6217 if (PERLDB_LINE && PL_curstash != PL_debstash) {
6218 SV *sv = NEWSV(88,0);
6220 sv_upgrade(sv, SVt_PVMG);
6221 sv_setsv(sv,PL_linestr);
6222 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop),sv);
6224 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
6227 sv_catsv(PL_linestr,herewas);
6228 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6232 sv_catsv(tmpstr,PL_linestr);
6237 PL_multi_end = CopLINE(PL_curcop);
6238 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
6239 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
6240 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
6242 SvREFCNT_dec(herewas);
6243 PL_lex_stuff = tmpstr;
6244 yylval.ival = op_type;
6249 takes: current position in input buffer
6250 returns: new position in input buffer
6251 side-effects: yylval and lex_op are set.
6256 <FH> read from filehandle
6257 <pkg::FH> read from package qualified filehandle
6258 <pkg'FH> read from package qualified filehandle
6259 <$fh> read from filehandle in $fh
6265 S_scan_inputsymbol(pTHX_ char *start)
6267 register char *s = start; /* current position in buffer */
6273 d = PL_tokenbuf; /* start of temp holding space */
6274 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
6275 end = strchr(s, '\n');
6278 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
6280 /* die if we didn't have space for the contents of the <>,
6281 or if it didn't end, or if we see a newline
6284 if (len >= sizeof PL_tokenbuf)
6285 Perl_croak(aTHX_ "Excessively long <> operator");
6287 Perl_croak(aTHX_ "Unterminated <> operator");
6292 Remember, only scalar variables are interpreted as filehandles by
6293 this code. Anything more complex (e.g., <$fh{$num}>) will be
6294 treated as a glob() call.
6295 This code makes use of the fact that except for the $ at the front,
6296 a scalar variable and a filehandle look the same.
6298 if (*d == '$' && d[1]) d++;
6300 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
6301 while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
6304 /* If we've tried to read what we allow filehandles to look like, and
6305 there's still text left, then it must be a glob() and not a getline.
6306 Use scan_str to pull out the stuff between the <> and treat it
6307 as nothing more than a string.
6310 if (d - PL_tokenbuf != len) {
6311 yylval.ival = OP_GLOB;
6313 s = scan_str(start,FALSE,FALSE);
6315 Perl_croak(aTHX_ "Glob not terminated");
6319 /* we're in a filehandle read situation */
6322 /* turn <> into <ARGV> */
6324 (void)strcpy(d,"ARGV");
6326 /* if <$fh>, create the ops to turn the variable into a
6332 /* try to find it in the pad for this block, otherwise find
6333 add symbol table ops
6335 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
6336 OP *o = newOP(OP_PADSV, 0);
6338 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, o);
6341 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
6342 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
6343 newUNOP(OP_RV2SV, 0,
6344 newGVOP(OP_GV, 0, gv)));
6346 PL_lex_op->op_flags |= OPf_SPECIAL;
6347 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
6348 yylval.ival = OP_NULL;
6351 /* If it's none of the above, it must be a literal filehandle
6352 (<Foo::BAR> or <FOO>) so build a simple readline OP */
6354 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
6355 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
6356 yylval.ival = OP_NULL;
6365 takes: start position in buffer
6366 keep_quoted preserve \ on the embedded delimiter(s)
6367 keep_delims preserve the delimiters around the string
6368 returns: position to continue reading from buffer
6369 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
6370 updates the read buffer.
6372 This subroutine pulls a string out of the input. It is called for:
6373 q single quotes q(literal text)
6374 ' single quotes 'literal text'
6375 qq double quotes qq(interpolate $here please)
6376 " double quotes "interpolate $here please"
6377 qx backticks qx(/bin/ls -l)
6378 ` backticks `/bin/ls -l`
6379 qw quote words @EXPORT_OK = qw( func() $spam )
6380 m// regexp match m/this/
6381 s/// regexp substitute s/this/that/
6382 tr/// string transliterate tr/this/that/
6383 y/// string transliterate y/this/that/
6384 ($*@) sub prototypes sub foo ($)
6385 (stuff) sub attr parameters sub foo : attr(stuff)
6386 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
6388 In most of these cases (all but <>, patterns and transliterate)
6389 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
6390 calls scan_str(). s/// makes yylex() call scan_subst() which calls
6391 scan_str(). tr/// and y/// make yylex() call scan_trans() which
6394 It skips whitespace before the string starts, and treats the first
6395 character as the delimiter. If the delimiter is one of ([{< then
6396 the corresponding "close" character )]}> is used as the closing
6397 delimiter. It allows quoting of delimiters, and if the string has
6398 balanced delimiters ([{<>}]) it allows nesting.
6400 The lexer always reads these strings into lex_stuff, except in the
6401 case of the operators which take *two* arguments (s/// and tr///)
6402 when it checks to see if lex_stuff is full (presumably with the 1st
6403 arg to s or tr) and if so puts the string into lex_repl.
6408 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
6411 SV *sv; /* scalar value: string */
6412 char *tmps; /* temp string, used for delimiter matching */
6413 register char *s = start; /* current position in the buffer */
6414 register char term; /* terminating character */
6415 register char *to; /* current position in the sv's data */
6416 I32 brackets = 1; /* bracket nesting level */
6417 bool has_utf = FALSE; /* is there any utf8 content? */
6419 /* skip space before the delimiter */
6423 /* mark where we are, in case we need to report errors */
6426 /* after skipping whitespace, the next character is the terminator */
6428 if ((term & 0x80) && UTF)
6431 /* mark where we are */
6432 PL_multi_start = CopLINE(PL_curcop);
6433 PL_multi_open = term;
6435 /* find corresponding closing delimiter */
6436 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
6438 PL_multi_close = term;
6440 /* create a new SV to hold the contents. 87 is leak category, I'm
6441 assuming. 79 is the SV's initial length. What a random number. */
6443 sv_upgrade(sv, SVt_PVIV);
6445 (void)SvPOK_only(sv); /* validate pointer */
6447 /* move past delimiter and try to read a complete string */
6449 sv_catpvn(sv, s, 1);
6452 /* extend sv if need be */
6453 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
6454 /* set 'to' to the next character in the sv's string */
6455 to = SvPVX(sv)+SvCUR(sv);
6457 /* if open delimiter is the close delimiter read unbridle */
6458 if (PL_multi_open == PL_multi_close) {
6459 for (; s < PL_bufend; s++,to++) {
6460 /* embedded newlines increment the current line number */
6461 if (*s == '\n' && !PL_rsfp)
6462 CopLINE_inc(PL_curcop);
6463 /* handle quoted delimiters */
6464 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
6465 if (!keep_quoted && s[1] == term)
6467 /* any other quotes are simply copied straight through */
6471 /* terminate when run out of buffer (the for() condition), or
6472 have found the terminator */
6473 else if (*s == term)
6475 else if (!has_utf && (*s & 0x80) && UTF)
6481 /* if the terminator isn't the same as the start character (e.g.,
6482 matched brackets), we have to allow more in the quoting, and
6483 be prepared for nested brackets.
6486 /* read until we run out of string, or we find the terminator */
6487 for (; s < PL_bufend; s++,to++) {
6488 /* embedded newlines increment the line count */
6489 if (*s == '\n' && !PL_rsfp)
6490 CopLINE_inc(PL_curcop);
6491 /* backslashes can escape the open or closing characters */
6492 if (*s == '\\' && s+1 < PL_bufend) {
6494 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
6499 /* allow nested opens and closes */
6500 else if (*s == PL_multi_close && --brackets <= 0)
6502 else if (*s == PL_multi_open)
6504 else if (!has_utf && (*s & 0x80) && UTF)
6509 /* terminate the copied string and update the sv's end-of-string */
6511 SvCUR_set(sv, to - SvPVX(sv));
6514 * this next chunk reads more into the buffer if we're not done yet
6518 break; /* handle case where we are done yet :-) */
6520 #ifndef PERL_STRICT_CR
6521 if (to - SvPVX(sv) >= 2) {
6522 if ((to[-2] == '\r' && to[-1] == '\n') ||
6523 (to[-2] == '\n' && to[-1] == '\r'))
6527 SvCUR_set(sv, to - SvPVX(sv));
6529 else if (to[-1] == '\r')
6532 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
6536 /* if we're out of file, or a read fails, bail and reset the current
6537 line marker so we can report where the unterminated string began
6540 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6542 CopLINE_set(PL_curcop, PL_multi_start);
6545 /* we read a line, so increment our line counter */
6546 CopLINE_inc(PL_curcop);
6548 /* update debugger info */
6549 if (PERLDB_LINE && PL_curstash != PL_debstash) {
6550 SV *sv = NEWSV(88,0);
6552 sv_upgrade(sv, SVt_PVMG);
6553 sv_setsv(sv,PL_linestr);
6554 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop), sv);
6557 /* having changed the buffer, we must update PL_bufend */
6558 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6561 /* at this point, we have successfully read the delimited string */
6564 sv_catpvn(sv, s, 1);
6567 PL_multi_end = CopLINE(PL_curcop);
6570 /* if we allocated too much space, give some back */
6571 if (SvCUR(sv) + 5 < SvLEN(sv)) {
6572 SvLEN_set(sv, SvCUR(sv) + 1);
6573 Renew(SvPVX(sv), SvLEN(sv), char);
6576 /* decide whether this is the first or second quoted string we've read
6589 takes: pointer to position in buffer
6590 returns: pointer to new position in buffer
6591 side-effects: builds ops for the constant in yylval.op
6593 Read a number in any of the formats that Perl accepts:
6595 0(x[0-7A-F]+)|([0-7]+)|(b[01])
6596 [\d_]+(\.[\d_]*)?[Ee](\d+)
6598 Underbars (_) are allowed in decimal numbers. If -w is on,
6599 underbars before a decimal point must be at three digit intervals.
6601 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
6604 If it reads a number without a decimal point or an exponent, it will
6605 try converting the number to an integer and see if it can do so
6606 without loss of precision.
6610 Perl_scan_num(pTHX_ char *start)
6612 register char *s = start; /* current position in buffer */
6613 register char *d; /* destination in temp buffer */
6614 register char *e; /* end of temp buffer */
6615 IV tryiv; /* used to see if it can be an IV */
6616 NV value; /* number read, as a double */
6617 SV *sv = Nullsv; /* place to put the converted number */
6618 bool floatit; /* boolean: int or float? */
6619 char *lastub = 0; /* position of last underbar */
6620 static char number_too_long[] = "Number too long";
6622 /* We use the first character to decide what type of number this is */
6626 Perl_croak(aTHX_ "panic: scan_num");
6628 /* if it starts with a 0, it could be an octal number, a decimal in
6629 0.13 disguise, or a hexadecimal number, or a binary number. */
6633 u holds the "number so far"
6634 shift the power of 2 of the base
6635 (hex == 4, octal == 3, binary == 1)
6636 overflowed was the number more than we can hold?
6638 Shift is used when we add a digit. It also serves as an "are
6639 we in octal/hex/binary?" indicator to disallow hex characters
6646 bool overflowed = FALSE;
6647 static NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
6648 static char* bases[5] = { "", "binary", "", "octal",
6650 static char* Bases[5] = { "", "Binary", "", "Octal",
6652 static char *maxima[5] = { "",
6653 "0b11111111111111111111111111111111",
6657 char *base, *Base, *max;
6663 } else if (s[1] == 'b') {
6667 /* check for a decimal in disguise */
6668 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
6670 /* so it must be octal */
6674 base = bases[shift];
6675 Base = Bases[shift];
6676 max = maxima[shift];
6678 /* read the rest of the number */
6680 /* x is used in the overflow test,
6681 b is the digit we're adding on. */
6686 /* if we don't mention it, we're done */
6695 /* 8 and 9 are not octal */
6698 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
6702 case '2': case '3': case '4':
6703 case '5': case '6': case '7':
6705 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
6709 b = *s++ & 15; /* ASCII digit -> value of digit */
6713 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
6714 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
6715 /* make sure they said 0x */
6720 /* Prepare to put the digit we have onto the end
6721 of the number so far. We check for overflows.
6726 x = u << shift; /* make room for the digit */
6728 if ((x >> shift) != u
6729 && !(PL_hints & HINT_NEW_BINARY)) {
6733 if (ckWARN_d(WARN_OVERFLOW))
6734 Perl_warner(aTHX_ WARN_OVERFLOW,
6735 "Integer overflow in %s number",
6738 u = x | b; /* add the digit to the end */
6741 n *= nvshift[shift];
6742 /* If an NV has not enough bits in its
6743 * mantissa to represent an UV this summing of
6744 * small low-order numbers is a waste of time
6745 * (because the NV cannot preserve the
6746 * low-order bits anyway): we could just
6747 * remember when did we overflow and in the
6748 * end just multiply n by the right
6756 /* if we get here, we had success: make a scalar value from
6763 if (ckWARN(WARN_PORTABLE) && n > 4294967295.0)
6764 Perl_warner(aTHX_ WARN_PORTABLE,
6765 "%s number > %s non-portable",
6772 if (ckWARN(WARN_PORTABLE) && u > 0xffffffff)
6773 Perl_warner(aTHX_ WARN_PORTABLE,
6774 "%s number > %s non-portable",
6779 if (PL_hints & HINT_NEW_BINARY)
6780 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
6785 handle decimal numbers.
6786 we're also sent here when we read a 0 as the first digit
6788 case '1': case '2': case '3': case '4': case '5':
6789 case '6': case '7': case '8': case '9': case '.':
6792 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
6795 /* read next group of digits and _ and copy into d */
6796 while (isDIGIT(*s) || *s == '_') {
6797 /* skip underscores, checking for misplaced ones
6801 dTHR; /* only for ckWARN */
6802 if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
6803 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
6807 /* check for end of fixed-length buffer */
6809 Perl_croak(aTHX_ number_too_long);
6810 /* if we're ok, copy the character */
6815 /* final misplaced underbar check */
6816 if (lastub && s - lastub != 3) {
6818 if (ckWARN(WARN_SYNTAX))
6819 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
6822 /* read a decimal portion if there is one. avoid
6823 3..5 being interpreted as the number 3. followed
6826 if (*s == '.' && s[1] != '.') {
6830 /* copy, ignoring underbars, until we run out of
6831 digits. Note: no misplaced underbar checks!
6833 for (; isDIGIT(*s) || *s == '_'; s++) {
6834 /* fixed length buffer check */
6836 Perl_croak(aTHX_ number_too_long);
6842 /* read exponent part, if present */
6843 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
6847 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
6848 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
6850 /* allow positive or negative exponent */
6851 if (*s == '+' || *s == '-')
6854 /* read digits of exponent (no underbars :-) */
6855 while (isDIGIT(*s)) {
6857 Perl_croak(aTHX_ number_too_long);
6862 /* terminate the string */
6865 /* make an sv from the string */
6868 value = Atof(PL_tokenbuf);
6871 See if we can make do with an integer value without loss of
6872 precision. We use I_V to cast to an int, because some
6873 compilers have issues. Then we try casting it back and see
6874 if it was the same. We only do this if we know we
6875 specifically read an integer.
6877 Note: if floatit is true, then we don't need to do the
6881 if (!floatit && (NV)tryiv == value)
6882 sv_setiv(sv, tryiv);
6884 sv_setnv(sv, value);
6885 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
6886 (PL_hints & HINT_NEW_INTEGER) )
6887 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
6888 (floatit ? "float" : "integer"),
6891 /* if it starts with a v, it could be a version number */
6896 while (isDIGIT(*pos))
6898 if (*pos == '.' && isDIGIT(pos[1])) {
6900 U8 tmpbuf[UTF8_MAXLEN];
6904 s++; /* get past 'v' */
6907 SvUPGRADE(sv, SVt_PVNV);
6908 sv_setpvn(sv, "", 0);
6911 if (*s == '0' && isDIGIT(s[1]))
6912 yyerror("Octal number in vector unsupported");
6915 while (isDIGIT(*pos))
6919 tmpend = uv_to_utf8(tmpbuf, rev);
6923 tmpbuf[0] = (U8)rev;
6924 tmpend = &tmpbuf[1];
6926 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
6928 SvNVX(sv) += (NV)rev/nshift;
6930 } while (*pos == '.' && isDIGIT(pos[1]));
6932 if (*s == '0' && isDIGIT(s[1]))
6933 yyerror("Octal number in vector unsupported");
6936 tmpend = uv_to_utf8(tmpbuf, rev);
6937 utf8 = utf8 || rev > 127;
6938 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
6940 SvNVX(sv) += (NV)rev/nshift;
6947 sv_utf8_downgrade(sv, TRUE);
6954 /* make the op for the constant and return */
6957 yylval.opval = newSVOP(OP_CONST, 0, sv);
6959 yylval.opval = Nullop;
6965 S_scan_formline(pTHX_ register char *s)
6970 SV *stuff = newSVpvn("",0);
6971 bool needargs = FALSE;
6974 if (*s == '.' || *s == '}') {
6976 #ifdef PERL_STRICT_CR
6977 for (t = s+1;*t == ' ' || *t == '\t'; t++) ;
6979 for (t = s+1;*t == ' ' || *t == '\t' || *t == '\r'; t++) ;
6981 if (*t == '\n' || t == PL_bufend)
6984 if (PL_in_eval && !PL_rsfp) {
6985 eol = strchr(s,'\n');
6990 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6992 for (t = s; t < eol; t++) {
6993 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
6995 goto enough; /* ~~ must be first line in formline */
6997 if (*t == '@' || *t == '^')
7000 sv_catpvn(stuff, s, eol-s);
7001 #ifndef PERL_STRICT_CR
7002 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
7003 char *end = SvPVX(stuff) + SvCUR(stuff);
7012 s = filter_gets(PL_linestr, PL_rsfp, 0);
7013 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
7014 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
7017 yyerror("Format not terminated");
7027 PL_lex_state = LEX_NORMAL;
7028 PL_nextval[PL_nexttoke].ival = 0;
7032 PL_lex_state = LEX_FORMLINE;
7033 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
7035 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
7039 SvREFCNT_dec(stuff);
7040 PL_lex_formbrack = 0;
7051 PL_cshlen = strlen(PL_cshname);
7056 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
7059 I32 oldsavestack_ix = PL_savestack_ix;
7060 CV* outsidecv = PL_compcv;
7064 assert(SvTYPE(PL_compcv) == SVt_PVCV);
7066 SAVEI32(PL_subline);
7067 save_item(PL_subname);
7070 SAVESPTR(PL_comppad_name);
7071 SAVESPTR(PL_compcv);
7072 SAVEI32(PL_comppad_name_fill);
7073 SAVEI32(PL_min_intro_pending);
7074 SAVEI32(PL_max_intro_pending);
7075 SAVEI32(PL_pad_reset_pending);
7077 PL_compcv = (CV*)NEWSV(1104,0);
7078 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
7079 CvFLAGS(PL_compcv) |= flags;
7081 PL_comppad = newAV();
7082 av_push(PL_comppad, Nullsv);
7083 PL_curpad = AvARRAY(PL_comppad);
7084 PL_comppad_name = newAV();
7085 PL_comppad_name_fill = 0;
7086 PL_min_intro_pending = 0;
7088 PL_subline = CopLINE(PL_curcop);
7090 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
7091 PL_curpad[0] = (SV*)newAV();
7092 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
7093 #endif /* USE_THREADS */
7095 comppadlist = newAV();
7096 AvREAL_off(comppadlist);
7097 av_store(comppadlist, 0, (SV*)PL_comppad_name);
7098 av_store(comppadlist, 1, (SV*)PL_comppad);
7100 CvPADLIST(PL_compcv) = comppadlist;
7101 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
7103 CvOWNER(PL_compcv) = 0;
7104 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
7105 MUTEX_INIT(CvMUTEXP(PL_compcv));
7106 #endif /* USE_THREADS */
7108 return oldsavestack_ix;
7112 Perl_yywarn(pTHX_ char *s)
7115 PL_in_eval |= EVAL_WARNONLY;
7117 PL_in_eval &= ~EVAL_WARNONLY;
7122 Perl_yyerror(pTHX_ char *s)
7126 char *context = NULL;
7130 if (!yychar || (yychar == ';' && !PL_rsfp))
7132 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
7133 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
7134 while (isSPACE(*PL_oldoldbufptr))
7136 context = PL_oldoldbufptr;
7137 contlen = PL_bufptr - PL_oldoldbufptr;
7139 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
7140 PL_oldbufptr != PL_bufptr) {
7141 while (isSPACE(*PL_oldbufptr))
7143 context = PL_oldbufptr;
7144 contlen = PL_bufptr - PL_oldbufptr;
7146 else if (yychar > 255)
7147 where = "next token ???";
7148 #ifdef USE_PURE_BISON
7149 /* GNU Bison sets the value -2 */
7150 else if (yychar == -2) {
7152 else if ((yychar & 127) == 127) {
7154 if (PL_lex_state == LEX_NORMAL ||
7155 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
7156 where = "at end of line";
7157 else if (PL_lex_inpat)
7158 where = "within pattern";
7160 where = "within string";
7163 SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
7165 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
7166 else if (isPRINT_LC(yychar))
7167 Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
7169 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
7170 where = SvPVX(where_sv);
7172 msg = sv_2mortal(newSVpv(s, 0));
7173 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
7174 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
7176 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
7178 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
7179 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
7180 Perl_sv_catpvf(aTHX_ msg,
7181 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
7182 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
7185 if (PL_in_eval & EVAL_WARNONLY)
7186 Perl_warn(aTHX_ "%"SVf, msg);
7189 if (PL_error_count >= 10)
7190 Perl_croak(aTHX_ "%s has too many errors.\n", CopFILE(PL_curcop));
7192 PL_in_my_stash = Nullhv;
7203 * Restore a source filter.
7207 restore_rsfp(pTHXo_ void *f)
7209 PerlIO *fp = (PerlIO*)f;
7211 if (PL_rsfp == PerlIO_stdin())
7212 PerlIO_clearerr(PL_rsfp);
7213 else if (PL_rsfp && (PL_rsfp != fp))
7214 PerlIO_close(PL_rsfp);