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;
824 bool is_vstr = FALSE;
835 for (; isDIGIT(*d) || *d == '_' || *d == '.'; d++);
836 if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
838 /* real VERSION number -- GBARR */
839 version = yylval.opval;
841 SV *ver = cSVOPx(version)->op_sv;
842 SvUPGRADE(ver, SVt_PVIV);
843 SvIOKp_on(ver); /* hint that it is a version */
848 /* NOTE: The parser sees the package name and the VERSION swapped */
849 PL_nextval[PL_nexttoke].opval = version;
857 * Tokenize a quoted string passed in as an SV. It finds the next
858 * chunk, up to end of string or a backslash. It may make a new
859 * SV containing that chunk (if HINT_NEW_STRING is on). It also
864 S_tokeq(pTHX_ SV *sv)
875 s = SvPV_force(sv, len);
879 while (s < send && *s != '\\')
884 if ( PL_hints & HINT_NEW_STRING )
885 pv = sv_2mortal(newSVpvn(SvPVX(pv), len));
888 if (s + 1 < send && (s[1] == '\\'))
889 s++; /* all that, just for this */
894 SvCUR_set(sv, d - SvPVX(sv));
896 if ( PL_hints & HINT_NEW_STRING )
897 return new_constant(NULL, 0, "q", sv, pv, "q");
902 * Now come three functions related to double-quote context,
903 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
904 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
905 * interact with PL_lex_state, and create fake ( ... ) argument lists
906 * to handle functions and concatenation.
907 * They assume that whoever calls them will be setting up a fake
908 * join call, because each subthing puts a ',' after it. This lets
911 * join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
913 * (I'm not sure whether the spurious commas at the end of lcfirst's
914 * arguments and join's arguments are created or not).
919 * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST).
921 * Pattern matching will set PL_lex_op to the pattern-matching op to
922 * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise).
924 * OP_CONST and OP_READLINE are easy--just make the new op and return.
926 * Everything else becomes a FUNC.
928 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
929 * had an OP_CONST or OP_READLINE). This just sets us up for a
930 * call to S_sublex_push().
936 register I32 op_type = yylval.ival;
938 if (op_type == OP_NULL) {
939 yylval.opval = PL_lex_op;
943 if (op_type == OP_CONST || op_type == OP_READLINE) {
944 SV *sv = tokeq(PL_lex_stuff);
946 if (SvTYPE(sv) == SVt_PVIV) {
947 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
953 nsv = newSVpvn(p, len);
957 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
958 PL_lex_stuff = Nullsv;
962 PL_sublex_info.super_state = PL_lex_state;
963 PL_sublex_info.sub_inwhat = op_type;
964 PL_sublex_info.sub_op = PL_lex_op;
965 PL_lex_state = LEX_INTERPPUSH;
969 yylval.opval = PL_lex_op;
979 * Create a new scope to save the lexing state. The scope will be
980 * ended in S_sublex_done. Returns a '(', starting the function arguments
981 * to the uc, lc, etc. found before.
982 * Sets PL_lex_state to LEX_INTERPCONCAT.
991 PL_lex_state = PL_sublex_info.super_state;
992 SAVEI32(PL_lex_dojoin);
993 SAVEI32(PL_lex_brackets);
994 SAVEI32(PL_lex_casemods);
995 SAVEI32(PL_lex_starts);
996 SAVEI32(PL_lex_state);
997 SAVEVPTR(PL_lex_inpat);
998 SAVEI32(PL_lex_inwhat);
999 SAVECOPLINE(PL_curcop);
1000 SAVEPPTR(PL_bufptr);
1001 SAVEPPTR(PL_oldbufptr);
1002 SAVEPPTR(PL_oldoldbufptr);
1003 SAVEPPTR(PL_linestart);
1004 SAVESPTR(PL_linestr);
1005 SAVEPPTR(PL_lex_brackstack);
1006 SAVEPPTR(PL_lex_casestack);
1008 PL_linestr = PL_lex_stuff;
1009 PL_lex_stuff = Nullsv;
1011 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
1012 = SvPVX(PL_linestr);
1013 PL_bufend += SvCUR(PL_linestr);
1014 SAVEFREESV(PL_linestr);
1016 PL_lex_dojoin = FALSE;
1017 PL_lex_brackets = 0;
1018 New(899, PL_lex_brackstack, 120, char);
1019 New(899, PL_lex_casestack, 12, char);
1020 SAVEFREEPV(PL_lex_brackstack);
1021 SAVEFREEPV(PL_lex_casestack);
1022 PL_lex_casemods = 0;
1023 *PL_lex_casestack = '\0';
1025 PL_lex_state = LEX_INTERPCONCAT;
1026 CopLINE_set(PL_curcop, PL_multi_start);
1028 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1029 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1030 PL_lex_inpat = PL_sublex_info.sub_op;
1032 PL_lex_inpat = Nullop;
1039 * Restores lexer state after a S_sublex_push.
1045 if (!PL_lex_starts++) {
1046 PL_expect = XOPERATOR;
1047 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpvn("",0));
1051 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
1052 PL_lex_state = LEX_INTERPCASEMOD;
1056 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1057 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1058 PL_linestr = PL_lex_repl;
1060 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1061 PL_bufend += SvCUR(PL_linestr);
1062 SAVEFREESV(PL_linestr);
1063 PL_lex_dojoin = FALSE;
1064 PL_lex_brackets = 0;
1065 PL_lex_casemods = 0;
1066 *PL_lex_casestack = '\0';
1068 if (SvEVALED(PL_lex_repl)) {
1069 PL_lex_state = LEX_INTERPNORMAL;
1071 /* we don't clear PL_lex_repl here, so that we can check later
1072 whether this is an evalled subst; that means we rely on the
1073 logic to ensure sublex_done() is called again only via the
1074 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1077 PL_lex_state = LEX_INTERPCONCAT;
1078 PL_lex_repl = Nullsv;
1084 PL_bufend = SvPVX(PL_linestr);
1085 PL_bufend += SvCUR(PL_linestr);
1086 PL_expect = XOPERATOR;
1087 PL_sublex_info.sub_inwhat = 0;
1095 Extracts a pattern, double-quoted string, or transliteration. This
1098 It looks at lex_inwhat and PL_lex_inpat to find out whether it's
1099 processing a pattern (PL_lex_inpat is true), a transliteration
1100 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
1102 Returns a pointer to the character scanned up to. Iff this is
1103 advanced from the start pointer supplied (ie if anything was
1104 successfully parsed), will leave an OP for the substring scanned
1105 in yylval. Caller must intuit reason for not parsing further
1106 by looking at the next characters herself.
1110 double-quoted style: \r and \n
1111 regexp special ones: \D \s
1113 backrefs: \1 (deprecated in substitution replacements)
1114 case and quoting: \U \Q \E
1115 stops on @ and $, but not for $ as tail anchor
1117 In transliterations:
1118 characters are VERY literal, except for - not at the start or end
1119 of the string, which indicates a range. scan_const expands the
1120 range to the full set of intermediate characters.
1122 In double-quoted strings:
1124 double-quoted style: \r and \n
1126 backrefs: \1 (deprecated)
1127 case and quoting: \U \Q \E
1130 scan_const does *not* construct ops to handle interpolated strings.
1131 It stops processing as soon as it finds an embedded $ or @ variable
1132 and leaves it to the caller to work out what's going on.
1134 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
1136 $ in pattern could be $foo or could be tail anchor. Assumption:
1137 it's a tail anchor if $ is the last thing in the string, or if it's
1138 followed by one of ")| \n\t"
1140 \1 (backreferences) are turned into $1
1142 The structure of the code is
1143 while (there's a character to process) {
1144 handle transliteration ranges
1145 skip regexp comments
1146 skip # initiated comments in //x patterns
1147 check for embedded @foo
1148 check for embedded scalars
1150 leave intact backslashes from leave (below)
1151 deprecate \1 in strings and sub replacements
1152 handle string-changing backslashes \l \U \Q \E, etc.
1153 switch (what was escaped) {
1154 handle - in a transliteration (becomes a literal -)
1155 handle \132 octal characters
1156 handle 0x15 hex characters
1157 handle \cV (control V)
1158 handle printf backslashes (\f, \r, \n, etc)
1160 } (end if backslash)
1161 } (end while character to read)
1166 S_scan_const(pTHX_ char *start)
1168 register char *send = PL_bufend; /* end of the constant */
1169 SV *sv = NEWSV(93, send - start); /* sv for the constant */
1170 register char *s = start; /* start of the constant */
1171 register char *d = SvPVX(sv); /* destination for copies */
1172 bool dorange = FALSE; /* are we in a translit range? */
1173 bool has_utf = FALSE; /* embedded \x{} */
1177 I32 utf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op)
1178 ? (PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
1180 I32 thisutf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op)
1181 ? (PL_sublex_info.sub_op->op_private & (PL_lex_repl ?
1182 OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF))
1184 const char *leaveit = /* set of acceptably-backslashed characters */
1186 ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
1189 while (s < send || dorange) {
1190 /* get transliterations out of the way (they're most literal) */
1191 if (PL_lex_inwhat == OP_TRANS) {
1192 /* expand a range A-Z to the full set of characters. AIE! */
1194 I32 i; /* current expanded character */
1195 I32 min; /* first character in range */
1196 I32 max; /* last character in range */
1198 i = d - SvPVX(sv); /* remember current offset */
1199 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
1200 d = SvPVX(sv) + i; /* refresh d after realloc */
1201 d -= 2; /* eat the first char and the - */
1203 min = (U8)*d; /* first char in range */
1204 max = (U8)d[1]; /* last char in range */
1207 if ((isLOWER(min) && isLOWER(max)) ||
1208 (isUPPER(min) && isUPPER(max))) {
1210 for (i = min; i <= max; i++)
1214 for (i = min; i <= max; i++)
1221 for (i = min; i <= max; i++)
1224 /* mark the range as done, and continue */
1229 /* range begins (ignore - as first or last char) */
1230 else if (*s == '-' && s+1 < send && s != start) {
1232 *d++ = (char)0xff; /* use illegal utf8 byte--see pmtrans */
1241 /* if we get here, we're not doing a transliteration */
1243 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
1244 except for the last char, which will be done separately. */
1245 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
1247 while (s < send && *s != ')')
1249 } else if (s[2] == '{'
1250 || s[2] == 'p' && s[3] == '{') { /* This should march regcomp.c */
1252 char *regparse = s + (s[2] == '{' ? 3 : 4);
1255 while (count && (c = *regparse)) {
1256 if (c == '\\' && regparse[1])
1264 if (*regparse != ')') {
1265 regparse--; /* Leave one char for continuation. */
1266 yyerror("Sequence (?{...}) not terminated or not {}-balanced");
1268 while (s < regparse)
1273 /* likewise skip #-initiated comments in //x patterns */
1274 else if (*s == '#' && PL_lex_inpat &&
1275 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
1276 while (s+1 < send && *s != '\n')
1280 /* check for embedded arrays (@foo, @:foo, @'foo, @{foo}, @$foo) */
1281 else if (*s == '@' && s[1]
1282 && (isALNUM_lazy_if(s+1,UTF) || strchr(":'{$", s[1])))
1285 /* check for embedded scalars. only stop if we're sure it's a
1288 else if (*s == '$') {
1289 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
1291 if (s + 1 < send && !strchr("()| \n\t", s[1]))
1292 break; /* in regexp, $ might be tail anchor */
1295 /* (now in tr/// code again) */
1297 if (*s & 0x80 && thisutf) {
1298 (void)utf8_to_uv((U8*)s, &len);
1300 /* illegal UTF8, make it valid */
1301 char *old_pvx = SvPVX(sv);
1302 /* need space for one extra char (NOTE: SvCUR() not set here) */
1303 d = SvGROW(sv, SvLEN(sv) + 1) + (d - old_pvx);
1304 d = (char*)uv_to_utf8((U8*)d, (U8)*s++);
1315 if (*s == '\\' && s+1 < send) {
1318 /* some backslashes we leave behind */
1319 if (*leaveit && *s && strchr(leaveit, *s)) {
1325 /* deprecate \1 in strings and substitution replacements */
1326 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1327 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1329 dTHR; /* only for ckWARN */
1330 if (ckWARN(WARN_SYNTAX))
1331 Perl_warner(aTHX_ WARN_SYNTAX, "\\%c better written as $%c", *s, *s);
1336 /* string-change backslash escapes */
1337 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1342 /* if we get here, it's either a quoted -, or a digit */
1345 /* quoted - in transliterations */
1347 if (PL_lex_inwhat == OP_TRANS) {
1355 if (ckWARN(WARN_MISC) && isALPHA(*s))
1356 Perl_warner(aTHX_ WARN_MISC,
1357 "Unrecognized escape \\%c passed through",
1359 /* default action is to copy the quoted character */
1364 /* \132 indicates an octal constant */
1365 case '0': case '1': case '2': case '3':
1366 case '4': case '5': case '6': case '7':
1367 uv = (UV)scan_oct(s, 3, &len);
1369 goto NUM_ESCAPE_INSERT;
1371 /* \x24 indicates a hex constant */
1375 char* e = strchr(s, '}');
1377 yyerror("Missing right brace on \\x{}");
1380 uv = (UV)scan_hex(s + 1, e - s - 1, &len);
1384 uv = (UV)scan_hex(s, 2, &len);
1389 /* Insert oct or hex escaped character.
1390 * There will always enough room in sv since such escapes will
1391 * be longer than any utf8 sequence they can end up as
1394 if (!thisutf && !has_utf && uv > 255) {
1395 /* might need to recode whatever we have accumulated so far
1396 * if it contains any hibit chars
1400 for (c = SvPVX(sv); c < d; c++) {
1405 char *old_pvx = SvPVX(sv);
1407 d = SvGROW(sv, SvCUR(sv) + hicount + 1) + (d - old_pvx);
1416 uv_to_utf8((U8*)dst, (U8)*src--);
1426 if (thisutf || uv > 255) {
1427 d = (char*)uv_to_utf8((U8*)d, uv);
1439 /* \N{latin small letter a} is a named character */
1443 char* e = strchr(s, '}');
1452 yyerror("Missing right brace on \\N{}");
1456 res = newSVpvn(s + 1, e - s - 1);
1457 res = new_constant( Nullch, 0, "charnames",
1458 res, Nullsv, "\\N{...}" );
1459 str = SvPV(res,len);
1460 if (len > e - s + 4) {
1461 char *odest = SvPVX(sv);
1463 SvGROW(sv, (SvCUR(sv) + len - (e - s + 4)));
1464 d = SvPVX(sv) + (d - odest);
1466 Copy(str, d, len, char);
1473 yyerror("Missing braces on \\N{}");
1476 /* \c is a control character */
1490 /* printf-style backslashes, formfeeds, newlines, etc */
1508 *d++ = '\047'; /* CP 1047 */
1511 *d++ = '\057'; /* CP 1047 */
1525 } /* end if (backslash) */
1528 } /* while loop to process each character */
1530 /* terminate the string and set up the sv */
1532 SvCUR_set(sv, d - SvPVX(sv));
1537 /* shrink the sv if we allocated more than we used */
1538 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1539 SvLEN_set(sv, SvCUR(sv) + 1);
1540 Renew(SvPVX(sv), SvLEN(sv), char);
1543 /* return the substring (via yylval) only if we parsed anything */
1544 if (s > PL_bufptr) {
1545 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1546 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1548 ( PL_lex_inwhat == OP_TRANS
1550 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1553 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1560 * Returns TRUE if there's more to the expression (e.g., a subscript),
1563 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
1565 * ->[ and ->{ return TRUE
1566 * { and [ outside a pattern are always subscripts, so return TRUE
1567 * if we're outside a pattern and it's not { or [, then return FALSE
1568 * if we're in a pattern and the first char is a {
1569 * {4,5} (any digits around the comma) returns FALSE
1570 * if we're in a pattern and the first char is a [
1572 * [SOMETHING] has a funky algorithm to decide whether it's a
1573 * character class or not. It has to deal with things like
1574 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
1575 * anything else returns TRUE
1578 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1581 S_intuit_more(pTHX_ register char *s)
1583 if (PL_lex_brackets)
1585 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1587 if (*s != '{' && *s != '[')
1592 /* In a pattern, so maybe we have {n,m}. */
1609 /* On the other hand, maybe we have a character class */
1612 if (*s == ']' || *s == '^')
1615 /* this is terrifying, and it works */
1616 int weight = 2; /* let's weigh the evidence */
1618 unsigned char un_char = 255, last_un_char;
1619 char *send = strchr(s,']');
1620 char tmpbuf[sizeof PL_tokenbuf * 4];
1622 if (!send) /* has to be an expression */
1625 Zero(seen,256,char);
1628 else if (isDIGIT(*s)) {
1630 if (isDIGIT(s[1]) && s[2] == ']')
1636 for (; s < send; s++) {
1637 last_un_char = un_char;
1638 un_char = (unsigned char)*s;
1643 weight -= seen[un_char] * 10;
1644 if (isALNUM_lazy_if(s+1,UTF)) {
1645 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1646 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1651 else if (*s == '$' && s[1] &&
1652 strchr("[#!%*<>()-=",s[1])) {
1653 if (/*{*/ strchr("])} =",s[2]))
1662 if (strchr("wds]",s[1]))
1664 else if (seen['\''] || seen['"'])
1666 else if (strchr("rnftbxcav",s[1]))
1668 else if (isDIGIT(s[1])) {
1670 while (s[1] && isDIGIT(s[1]))
1680 if (strchr("aA01! ",last_un_char))
1682 if (strchr("zZ79~",s[1]))
1684 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1685 weight -= 5; /* cope with negative subscript */
1688 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1689 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1694 if (keyword(tmpbuf, d - tmpbuf))
1697 if (un_char == last_un_char + 1)
1699 weight -= seen[un_char];
1704 if (weight >= 0) /* probably a character class */
1714 * Does all the checking to disambiguate
1716 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
1717 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
1719 * First argument is the stuff after the first token, e.g. "bar".
1721 * Not a method if bar is a filehandle.
1722 * Not a method if foo is a subroutine prototyped to take a filehandle.
1723 * Not a method if it's really "Foo $bar"
1724 * Method if it's "foo $bar"
1725 * Not a method if it's really "print foo $bar"
1726 * Method if it's really "foo package::" (interpreted as package->foo)
1727 * Not a method if bar is known to be a subroutne ("sub bar; foo bar")
1728 * Not a method if bar is a filehandle or package, but is quoted with
1733 S_intuit_method(pTHX_ char *start, GV *gv)
1735 char *s = start + (*start == '$');
1736 char tmpbuf[sizeof PL_tokenbuf];
1744 if ((cv = GvCVu(gv))) {
1745 char *proto = SvPVX(cv);
1755 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1756 /* start is the beginning of the possible filehandle/object,
1757 * and s is the end of it
1758 * tmpbuf is a copy of it
1761 if (*start == '$') {
1762 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1767 return *s == '(' ? FUNCMETH : METHOD;
1769 if (!keyword(tmpbuf, len)) {
1770 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1775 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1776 if (indirgv && GvCVu(indirgv))
1778 /* filehandle or package name makes it a method */
1779 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1781 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1782 return 0; /* no assumptions -- "=>" quotes bearword */
1784 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1785 newSVpvn(tmpbuf,len));
1786 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1790 return *s == '(' ? FUNCMETH : METHOD;
1798 * Return a string of Perl code to load the debugger. If PERL5DB
1799 * is set, it will return the contents of that, otherwise a
1800 * compile-time require of perl5db.pl.
1807 char *pdb = PerlEnv_getenv("PERL5DB");
1811 SETERRNO(0,SS$_NORMAL);
1812 return "BEGIN { require 'perl5db.pl' }";
1818 /* Encoded script support. filter_add() effectively inserts a
1819 * 'pre-processing' function into the current source input stream.
1820 * Note that the filter function only applies to the current source file
1821 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1823 * The datasv parameter (which may be NULL) can be used to pass
1824 * private data to this instance of the filter. The filter function
1825 * can recover the SV using the FILTER_DATA macro and use it to
1826 * store private buffers and state information.
1828 * The supplied datasv parameter is upgraded to a PVIO type
1829 * and the IoDIRP field is used to store the function pointer,
1830 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
1831 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1832 * private use must be set using malloc'd pointers.
1836 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
1841 if (!PL_rsfp_filters)
1842 PL_rsfp_filters = newAV();
1844 datasv = NEWSV(255,0);
1845 if (!SvUPGRADE(datasv, SVt_PVIO))
1846 Perl_die(aTHX_ "Can't upgrade filter_add data to SVt_PVIO");
1847 IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
1848 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
1849 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
1850 funcp, SvPV_nolen(datasv)));
1851 av_unshift(PL_rsfp_filters, 1);
1852 av_store(PL_rsfp_filters, 0, datasv) ;
1857 /* Delete most recently added instance of this filter function. */
1859 Perl_filter_del(pTHX_ filter_t funcp)
1862 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", funcp));
1863 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
1865 /* if filter is on top of stack (usual case) just pop it off */
1866 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
1867 if (IoDIRP(datasv) == (DIR*)funcp) {
1868 IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
1869 IoDIRP(datasv) = (DIR*)NULL;
1870 sv_free(av_pop(PL_rsfp_filters));
1874 /* we need to search for the correct entry and clear it */
1875 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
1879 /* Invoke the n'th filter function for the current rsfp. */
1881 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
1884 /* 0 = read one text line */
1889 if (!PL_rsfp_filters)
1891 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
1892 /* Provide a default input filter to make life easy. */
1893 /* Note that we append to the line. This is handy. */
1894 DEBUG_P(PerlIO_printf(Perl_debug_log,
1895 "filter_read %d: from rsfp\n", idx));
1899 int old_len = SvCUR(buf_sv) ;
1901 /* ensure buf_sv is large enough */
1902 SvGROW(buf_sv, old_len + maxlen) ;
1903 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1904 if (PerlIO_error(PL_rsfp))
1905 return -1; /* error */
1907 return 0 ; /* end of file */
1909 SvCUR_set(buf_sv, old_len + len) ;
1912 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
1913 if (PerlIO_error(PL_rsfp))
1914 return -1; /* error */
1916 return 0 ; /* end of file */
1919 return SvCUR(buf_sv);
1921 /* Skip this filter slot if filter has been deleted */
1922 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
1923 DEBUG_P(PerlIO_printf(Perl_debug_log,
1924 "filter_read %d: skipped (filter deleted)\n",
1926 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1928 /* Get function pointer hidden within datasv */
1929 funcp = (filter_t)IoDIRP(datasv);
1930 DEBUG_P(PerlIO_printf(Perl_debug_log,
1931 "filter_read %d: via function %p (%s)\n",
1932 idx, funcp, SvPV_nolen(datasv)));
1933 /* Call function. The function is expected to */
1934 /* call "FILTER_READ(idx+1, buf_sv)" first. */
1935 /* Return: <0:error, =0:eof, >0:not eof */
1936 return (*funcp)(aTHXo_ idx, buf_sv, maxlen);
1940 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
1942 #ifdef PERL_CR_FILTER
1943 if (!PL_rsfp_filters) {
1944 filter_add(S_cr_textfilter,NULL);
1947 if (PL_rsfp_filters) {
1950 SvCUR_set(sv, 0); /* start with empty line */
1951 if (FILTER_READ(0, sv, 0) > 0)
1952 return ( SvPVX(sv) ) ;
1957 return (sv_gets(sv, fp, append));
1962 static char* exp_name[] =
1963 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
1964 "ATTRTERM", "TERMBLOCK"
1971 Works out what to call the token just pulled out of the input
1972 stream. The yacc parser takes care of taking the ops we return and
1973 stitching them into a tree.
1979 if read an identifier
1980 if we're in a my declaration
1981 croak if they tried to say my($foo::bar)
1982 build the ops for a my() declaration
1983 if it's an access to a my() variable
1984 are we in a sort block?
1985 croak if my($a); $a <=> $b
1986 build ops for access to a my() variable
1987 if in a dq string, and they've said @foo and we can't find @foo
1989 build ops for a bareword
1990 if we already built the token before, use it.
1994 #ifdef USE_PURE_BISON
1995 Perl_yylex(pTHX_ YYSTYPE *lvalp, int *lcharp)
2008 #ifdef USE_PURE_BISON
2009 yylval_pointer = lvalp;
2010 yychar_pointer = lcharp;
2013 /* check if there's an identifier for us to look at */
2014 if (PL_pending_ident) {
2015 /* pit holds the identifier we read and pending_ident is reset */
2016 char pit = PL_pending_ident;
2017 PL_pending_ident = 0;
2019 /* if we're in a my(), we can't allow dynamics here.
2020 $foo'bar has already been turned into $foo::bar, so
2021 just check for colons.
2023 if it's a legal name, the OP is a PADANY.
2026 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
2027 if (strchr(PL_tokenbuf,':'))
2028 yyerror(Perl_form(aTHX_ "No package name allowed for "
2029 "variable %s in \"our\"",
2031 tmp = pad_allocmy(PL_tokenbuf);
2034 if (strchr(PL_tokenbuf,':'))
2035 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
2037 yylval.opval = newOP(OP_PADANY, 0);
2038 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
2044 build the ops for accesses to a my() variable.
2046 Deny my($a) or my($b) in a sort block, *if* $a or $b is
2047 then used in a comparison. This catches most, but not
2048 all cases. For instance, it catches
2049 sort { my($a); $a <=> $b }
2051 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
2052 (although why you'd do that is anyone's guess).
2055 if (!strchr(PL_tokenbuf,':')) {
2057 /* Check for single character per-thread SVs */
2058 if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
2059 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
2060 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
2062 yylval.opval = newOP(OP_THREADSV, 0);
2063 yylval.opval->op_targ = tmp;
2066 #endif /* USE_THREADS */
2067 if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
2068 SV *namesv = AvARRAY(PL_comppad_name)[tmp];
2069 /* might be an "our" variable" */
2070 if (SvFLAGS(namesv) & SVpad_OUR) {
2071 /* build ops for a bareword */
2072 SV *sym = newSVpv(HvNAME(GvSTASH(namesv)),0);
2073 sv_catpvn(sym, "::", 2);
2074 sv_catpv(sym, PL_tokenbuf+1);
2075 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
2076 yylval.opval->op_private = OPpCONST_ENTERED;
2077 gv_fetchpv(SvPVX(sym),
2079 ? (GV_ADDMULTI | GV_ADDINEVAL)
2082 ((PL_tokenbuf[0] == '$') ? SVt_PV
2083 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
2088 /* if it's a sort block and they're naming $a or $b */
2089 if (PL_last_lop_op == OP_SORT &&
2090 PL_tokenbuf[0] == '$' &&
2091 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
2094 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
2095 d < PL_bufend && *d != '\n';
2098 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
2099 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
2105 yylval.opval = newOP(OP_PADANY, 0);
2106 yylval.opval->op_targ = tmp;
2112 Whine if they've said @foo in a doublequoted string,
2113 and @foo isn't a variable we can find in the symbol
2116 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
2117 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
2118 if (!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
2119 yyerror(Perl_form(aTHX_ "In string, %s now must be written as \\%s",
2120 PL_tokenbuf, PL_tokenbuf));
2123 /* build ops for a bareword */
2124 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
2125 yylval.opval->op_private = OPpCONST_ENTERED;
2126 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
2127 ((PL_tokenbuf[0] == '$') ? SVt_PV
2128 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
2133 /* no identifier pending identification */
2135 switch (PL_lex_state) {
2137 case LEX_NORMAL: /* Some compilers will produce faster */
2138 case LEX_INTERPNORMAL: /* code if we comment these out. */
2142 /* when we've already built the next token, just pull it out of the queue */
2145 yylval = PL_nextval[PL_nexttoke];
2147 PL_lex_state = PL_lex_defer;
2148 PL_expect = PL_lex_expect;
2149 PL_lex_defer = LEX_NORMAL;
2151 return(PL_nexttype[PL_nexttoke]);
2153 /* interpolated case modifiers like \L \U, including \Q and \E.
2154 when we get here, PL_bufptr is at the \
2156 case LEX_INTERPCASEMOD:
2158 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
2159 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
2161 /* handle \E or end of string */
2162 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
2166 if (PL_lex_casemods) {
2167 oldmod = PL_lex_casestack[--PL_lex_casemods];
2168 PL_lex_casestack[PL_lex_casemods] = '\0';
2170 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
2172 PL_lex_state = LEX_INTERPCONCAT;
2176 if (PL_bufptr != PL_bufend)
2178 PL_lex_state = LEX_INTERPCONCAT;
2183 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
2184 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
2185 if (strchr("LU", *s) &&
2186 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
2188 PL_lex_casestack[--PL_lex_casemods] = '\0';
2191 if (PL_lex_casemods > 10) {
2192 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
2193 if (newlb != PL_lex_casestack) {
2195 PL_lex_casestack = newlb;
2198 PL_lex_casestack[PL_lex_casemods++] = *s;
2199 PL_lex_casestack[PL_lex_casemods] = '\0';
2200 PL_lex_state = LEX_INTERPCONCAT;
2201 PL_nextval[PL_nexttoke].ival = 0;
2204 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
2206 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
2208 PL_nextval[PL_nexttoke].ival = OP_LC;
2210 PL_nextval[PL_nexttoke].ival = OP_UC;
2212 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
2214 Perl_croak(aTHX_ "panic: yylex");
2217 if (PL_lex_starts) {
2226 case LEX_INTERPPUSH:
2227 return sublex_push();
2229 case LEX_INTERPSTART:
2230 if (PL_bufptr == PL_bufend)
2231 return sublex_done();
2233 PL_lex_dojoin = (*PL_bufptr == '@');
2234 PL_lex_state = LEX_INTERPNORMAL;
2235 if (PL_lex_dojoin) {
2236 PL_nextval[PL_nexttoke].ival = 0;
2239 PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
2240 PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
2241 force_next(PRIVATEREF);
2243 force_ident("\"", '$');
2244 #endif /* USE_THREADS */
2245 PL_nextval[PL_nexttoke].ival = 0;
2247 PL_nextval[PL_nexttoke].ival = 0;
2249 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
2252 if (PL_lex_starts++) {
2258 case LEX_INTERPENDMAYBE:
2259 if (intuit_more(PL_bufptr)) {
2260 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
2266 if (PL_lex_dojoin) {
2267 PL_lex_dojoin = FALSE;
2268 PL_lex_state = LEX_INTERPCONCAT;
2271 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
2272 && SvEVALED(PL_lex_repl))
2274 if (PL_bufptr != PL_bufend)
2275 Perl_croak(aTHX_ "Bad evalled substitution pattern");
2276 PL_lex_repl = Nullsv;
2279 case LEX_INTERPCONCAT:
2281 if (PL_lex_brackets)
2282 Perl_croak(aTHX_ "panic: INTERPCONCAT");
2284 if (PL_bufptr == PL_bufend)
2285 return sublex_done();
2287 if (SvIVX(PL_linestr) == '\'') {
2288 SV *sv = newSVsv(PL_linestr);
2291 else if ( PL_hints & HINT_NEW_RE )
2292 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
2293 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2297 s = scan_const(PL_bufptr);
2299 PL_lex_state = LEX_INTERPCASEMOD;
2301 PL_lex_state = LEX_INTERPSTART;
2304 if (s != PL_bufptr) {
2305 PL_nextval[PL_nexttoke] = yylval;
2308 if (PL_lex_starts++)
2318 PL_lex_state = LEX_NORMAL;
2319 s = scan_formline(PL_bufptr);
2320 if (!PL_lex_formbrack)
2326 PL_oldoldbufptr = PL_oldbufptr;
2329 PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at %s\n",
2330 exp_name[PL_expect], s);
2336 if (isIDFIRST_lazy_if(s,UTF))
2338 Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
2341 goto fake_eof; /* emulate EOF on ^D or ^Z */
2346 if (PL_lex_brackets)
2347 yyerror("Missing right curly or square bracket");
2350 if (s++ < PL_bufend)
2351 goto retry; /* ignore stray nulls */
2354 if (!PL_in_eval && !PL_preambled) {
2355 PL_preambled = TRUE;
2356 sv_setpv(PL_linestr,incl_perldb());
2357 if (SvCUR(PL_linestr))
2358 sv_catpv(PL_linestr,";");
2360 while(AvFILLp(PL_preambleav) >= 0) {
2361 SV *tmpsv = av_shift(PL_preambleav);
2362 sv_catsv(PL_linestr, tmpsv);
2363 sv_catpv(PL_linestr, ";");
2366 sv_free((SV*)PL_preambleav);
2367 PL_preambleav = NULL;
2369 if (PL_minus_n || PL_minus_p) {
2370 sv_catpv(PL_linestr, "LINE: while (<>) {");
2372 sv_catpv(PL_linestr,"chomp;");
2374 GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
2376 GvIMPORTED_AV_on(gv);
2378 if (strchr("/'\"", *PL_splitstr)
2379 && strchr(PL_splitstr + 1, *PL_splitstr))
2380 Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s);", PL_splitstr);
2383 s = "'~#\200\1'"; /* surely one char is unused...*/
2384 while (s[1] && strchr(PL_splitstr, *s)) s++;
2386 Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s%c",
2387 "q" + (delim == '\''), delim);
2388 for (s = PL_splitstr; *s; s++) {
2390 sv_catpvn(PL_linestr, "\\", 1);
2391 sv_catpvn(PL_linestr, s, 1);
2393 Perl_sv_catpvf(aTHX_ PL_linestr, "%c);", delim);
2397 sv_catpv(PL_linestr,"@F=split(' ');");
2400 sv_catpv(PL_linestr, "\n");
2401 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2402 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2403 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2404 SV *sv = NEWSV(85,0);
2406 sv_upgrade(sv, SVt_PVMG);
2407 sv_setsv(sv,PL_linestr);
2408 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2413 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
2416 if (PL_preprocess && !PL_in_eval)
2417 (void)PerlProc_pclose(PL_rsfp);
2418 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2419 PerlIO_clearerr(PL_rsfp);
2421 (void)PerlIO_close(PL_rsfp);
2423 PL_doextract = FALSE;
2425 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2426 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
2427 sv_catpv(PL_linestr,";}");
2428 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2429 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2430 PL_minus_n = PL_minus_p = 0;
2433 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2434 sv_setpv(PL_linestr,"");
2435 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
2438 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
2439 PL_doextract = FALSE;
2441 /* Incest with pod. */
2442 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2443 sv_setpv(PL_linestr, "");
2444 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2445 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2446 PL_doextract = FALSE;
2450 } while (PL_doextract);
2451 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2452 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2453 SV *sv = NEWSV(85,0);
2455 sv_upgrade(sv, SVt_PVMG);
2456 sv_setsv(sv,PL_linestr);
2457 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2459 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2460 if (CopLINE(PL_curcop) == 1) {
2461 while (s < PL_bufend && isSPACE(*s))
2463 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2467 if (*s == '#' && *(s+1) == '!')
2469 #ifdef ALTERNATE_SHEBANG
2471 static char as[] = ALTERNATE_SHEBANG;
2472 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2473 d = s + (sizeof(as) - 1);
2475 #endif /* ALTERNATE_SHEBANG */
2484 while (*d && !isSPACE(*d))
2488 #ifdef ARG_ZERO_IS_SCRIPT
2489 if (ipathend > ipath) {
2491 * HP-UX (at least) sets argv[0] to the script name,
2492 * which makes $^X incorrect. And Digital UNIX and Linux,
2493 * at least, set argv[0] to the basename of the Perl
2494 * interpreter. So, having found "#!", we'll set it right.
2496 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
2497 assert(SvPOK(x) || SvGMAGICAL(x));
2498 if (sv_eq(x, CopFILESV(PL_curcop))) {
2499 sv_setpvn(x, ipath, ipathend - ipath);
2502 TAINT_NOT; /* $^X is always tainted, but that's OK */
2504 #endif /* ARG_ZERO_IS_SCRIPT */
2509 d = instr(s,"perl -");
2511 d = instr(s,"perl");
2513 /* avoid getting into infinite loops when shebang
2514 * line contains "Perl" rather than "perl" */
2516 for (d = ipathend-4; d >= ipath; --d) {
2517 if ((*d == 'p' || *d == 'P')
2518 && !ibcmp(d, "perl", 4))
2528 #ifdef ALTERNATE_SHEBANG
2530 * If the ALTERNATE_SHEBANG on this system starts with a
2531 * character that can be part of a Perl expression, then if
2532 * we see it but not "perl", we're probably looking at the
2533 * start of Perl code, not a request to hand off to some
2534 * other interpreter. Similarly, if "perl" is there, but
2535 * not in the first 'word' of the line, we assume the line
2536 * contains the start of the Perl program.
2538 if (d && *s != '#') {
2540 while (*c && !strchr("; \t\r\n\f\v#", *c))
2543 d = Nullch; /* "perl" not in first word; ignore */
2545 *s = '#'; /* Don't try to parse shebang line */
2547 #endif /* ALTERNATE_SHEBANG */
2552 !instr(s,"indir") &&
2553 instr(PL_origargv[0],"perl"))
2559 while (s < PL_bufend && isSPACE(*s))
2561 if (s < PL_bufend) {
2562 Newz(899,newargv,PL_origargc+3,char*);
2564 while (s < PL_bufend && !isSPACE(*s))
2567 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2570 newargv = PL_origargv;
2572 PerlProc_execv(ipath, newargv);
2573 Perl_croak(aTHX_ "Can't exec %s", ipath);
2576 U32 oldpdb = PL_perldb;
2577 bool oldn = PL_minus_n;
2578 bool oldp = PL_minus_p;
2580 while (*d && !isSPACE(*d)) d++;
2581 while (*d == ' ' || *d == '\t') d++;
2585 if (*d == 'M' || *d == 'm') {
2587 while (*d && !isSPACE(*d)) d++;
2588 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2591 d = moreswitches(d);
2593 if (PERLDB_LINE && !oldpdb ||
2594 ( PL_minus_n || PL_minus_p ) && !(oldn || oldp) )
2595 /* if we have already added "LINE: while (<>) {",
2596 we must not do it again */
2598 sv_setpv(PL_linestr, "");
2599 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2600 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2601 PL_preambled = FALSE;
2603 (void)gv_fetchfile(PL_origfilename);
2610 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2612 PL_lex_state = LEX_FORMLINE;
2617 #ifdef PERL_STRICT_CR
2618 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2620 "(Maybe you didn't strip carriage returns after a network transfer?)\n");
2622 case ' ': case '\t': case '\f': case 013:
2627 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2629 while (s < d && *s != '\n')
2634 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2636 PL_lex_state = LEX_FORMLINE;
2646 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2651 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2654 if (strnEQ(s,"=>",2)) {
2655 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2656 OPERATOR('-'); /* unary minus */
2658 PL_last_uni = PL_oldbufptr;
2659 PL_last_lop_op = OP_FTEREAD; /* good enough */
2661 case 'r': FTST(OP_FTEREAD);
2662 case 'w': FTST(OP_FTEWRITE);
2663 case 'x': FTST(OP_FTEEXEC);
2664 case 'o': FTST(OP_FTEOWNED);
2665 case 'R': FTST(OP_FTRREAD);
2666 case 'W': FTST(OP_FTRWRITE);
2667 case 'X': FTST(OP_FTREXEC);
2668 case 'O': FTST(OP_FTROWNED);
2669 case 'e': FTST(OP_FTIS);
2670 case 'z': FTST(OP_FTZERO);
2671 case 's': FTST(OP_FTSIZE);
2672 case 'f': FTST(OP_FTFILE);
2673 case 'd': FTST(OP_FTDIR);
2674 case 'l': FTST(OP_FTLINK);
2675 case 'p': FTST(OP_FTPIPE);
2676 case 'S': FTST(OP_FTSOCK);
2677 case 'u': FTST(OP_FTSUID);
2678 case 'g': FTST(OP_FTSGID);
2679 case 'k': FTST(OP_FTSVTX);
2680 case 'b': FTST(OP_FTBLK);
2681 case 'c': FTST(OP_FTCHR);
2682 case 't': FTST(OP_FTTTY);
2683 case 'T': FTST(OP_FTTEXT);
2684 case 'B': FTST(OP_FTBINARY);
2685 case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2686 case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2687 case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
2689 Perl_croak(aTHX_ "Unrecognized file test: -%c", (int)tmp);
2696 if (PL_expect == XOPERATOR)
2701 else if (*s == '>') {
2704 if (isIDFIRST_lazy_if(s,UTF)) {
2705 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2713 if (PL_expect == XOPERATOR)
2716 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2718 OPERATOR('-'); /* unary minus */
2725 if (PL_expect == XOPERATOR)
2730 if (PL_expect == XOPERATOR)
2733 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2739 if (PL_expect != XOPERATOR) {
2740 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2741 PL_expect = XOPERATOR;
2742 force_ident(PL_tokenbuf, '*');
2755 if (PL_expect == XOPERATOR) {
2759 PL_tokenbuf[0] = '%';
2760 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2761 if (!PL_tokenbuf[1]) {
2763 yyerror("Final % should be \\% or %name");
2766 PL_pending_ident = '%';
2785 switch (PL_expect) {
2788 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
2790 PL_bufptr = s; /* update in case we back off */
2796 PL_expect = XTERMBLOCK;
2800 while (isIDFIRST_lazy_if(s,UTF)) {
2801 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2802 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
2803 if (tmp < 0) tmp = -tmp;
2818 d = scan_str(d,TRUE,TRUE);
2821 SvREFCNT_dec(PL_lex_stuff);
2822 PL_lex_stuff = Nullsv;
2824 /* MUST advance bufptr here to avoid bogus
2825 "at end of line" context messages from yyerror().
2827 PL_bufptr = s + len;
2828 yyerror("Unterminated attribute parameter in attribute list");
2831 return 0; /* EOF indicator */
2835 SV *sv = newSVpvn(s, len);
2836 sv_catsv(sv, PL_lex_stuff);
2837 attrs = append_elem(OP_LIST, attrs,
2838 newSVOP(OP_CONST, 0, sv));
2839 SvREFCNT_dec(PL_lex_stuff);
2840 PL_lex_stuff = Nullsv;
2843 attrs = append_elem(OP_LIST, attrs,
2844 newSVOP(OP_CONST, 0,
2848 if (*s == ':' && s[1] != ':')
2851 break; /* require real whitespace or :'s */
2853 tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
2854 if (*s != ';' && *s != tmp && (tmp != '=' || *s != ')')) {
2855 char q = ((*s == '\'') ? '"' : '\'');
2856 /* If here for an expression, and parsed no attrs, back off. */
2857 if (tmp == '=' && !attrs) {
2861 /* MUST advance bufptr here to avoid bogus "at end of line"
2862 context messages from yyerror().
2866 yyerror("Unterminated attribute list");
2868 yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list",
2876 PL_nextval[PL_nexttoke].opval = attrs;
2884 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
2885 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
2890 if (CopLINE(PL_curcop) < PL_copline)
2891 PL_copline = CopLINE(PL_curcop);
2902 if (PL_lex_brackets <= 0)
2903 yyerror("Unmatched right square bracket");
2906 if (PL_lex_state == LEX_INTERPNORMAL) {
2907 if (PL_lex_brackets == 0) {
2908 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
2909 PL_lex_state = LEX_INTERPEND;
2916 if (PL_lex_brackets > 100) {
2917 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
2918 if (newlb != PL_lex_brackstack) {
2920 PL_lex_brackstack = newlb;
2923 switch (PL_expect) {
2925 if (PL_lex_formbrack) {
2929 if (PL_oldoldbufptr == PL_last_lop)
2930 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2932 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2933 OPERATOR(HASHBRACK);
2935 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2938 PL_tokenbuf[0] = '\0';
2939 if (d < PL_bufend && *d == '-') {
2940 PL_tokenbuf[0] = '-';
2942 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2945 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
2946 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2948 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2951 char minus = (PL_tokenbuf[0] == '-');
2952 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2960 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
2965 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2970 if (PL_oldoldbufptr == PL_last_lop)
2971 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2973 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2976 OPERATOR(HASHBRACK);
2977 /* This hack serves to disambiguate a pair of curlies
2978 * as being a block or an anon hash. Normally, expectation
2979 * determines that, but in cases where we're not in a
2980 * position to expect anything in particular (like inside
2981 * eval"") we have to resolve the ambiguity. This code
2982 * covers the case where the first term in the curlies is a
2983 * quoted string. Most other cases need to be explicitly
2984 * disambiguated by prepending a `+' before the opening
2985 * curly in order to force resolution as an anon hash.
2987 * XXX should probably propagate the outer expectation
2988 * into eval"" to rely less on this hack, but that could
2989 * potentially break current behavior of eval"".
2993 if (*s == '\'' || *s == '"' || *s == '`') {
2994 /* common case: get past first string, handling escapes */
2995 for (t++; t < PL_bufend && *t != *s;)
2996 if (*t++ == '\\' && (*t == '\\' || *t == *s))
3000 else if (*s == 'q') {
3003 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
3007 char open, close, term;
3010 while (t < PL_bufend && isSPACE(*t))
3014 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
3018 for (t++; t < PL_bufend; t++) {
3019 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
3021 else if (*t == open)
3025 for (t++; t < PL_bufend; t++) {
3026 if (*t == '\\' && t+1 < PL_bufend)
3028 else if (*t == close && --brackets <= 0)
3030 else if (*t == open)
3036 else if (isALNUM_lazy_if(t,UTF)) {
3038 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3041 while (t < PL_bufend && isSPACE(*t))
3043 /* if comma follows first term, call it an anon hash */
3044 /* XXX it could be a comma expression with loop modifiers */
3045 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
3046 || (*t == '=' && t[1] == '>')))
3047 OPERATOR(HASHBRACK);
3048 if (PL_expect == XREF)
3051 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
3057 yylval.ival = CopLINE(PL_curcop);
3058 if (isSPACE(*s) || *s == '#')
3059 PL_copline = NOLINE; /* invalidate current command line number */
3064 if (PL_lex_brackets <= 0)
3065 yyerror("Unmatched right curly bracket");
3067 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
3068 if (PL_lex_brackets < PL_lex_formbrack)
3069 PL_lex_formbrack = 0;
3070 if (PL_lex_state == LEX_INTERPNORMAL) {
3071 if (PL_lex_brackets == 0) {
3072 if (PL_expect & XFAKEBRACK) {
3073 PL_expect &= XENUMMASK;
3074 PL_lex_state = LEX_INTERPEND;
3076 return yylex(); /* ignore fake brackets */
3078 if (*s == '-' && s[1] == '>')
3079 PL_lex_state = LEX_INTERPENDMAYBE;
3080 else if (*s != '[' && *s != '{')
3081 PL_lex_state = LEX_INTERPEND;
3084 if (PL_expect & XFAKEBRACK) {
3085 PL_expect &= XENUMMASK;
3087 return yylex(); /* ignore fake brackets */
3097 if (PL_expect == XOPERATOR) {
3098 if (ckWARN(WARN_SEMICOLON)
3099 && isIDFIRST_lazy_if(s,UTF) && PL_bufptr == PL_linestart)
3101 CopLINE_dec(PL_curcop);
3102 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3103 CopLINE_inc(PL_curcop);
3108 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3110 PL_expect = XOPERATOR;
3111 force_ident(PL_tokenbuf, '&');
3115 yylval.ival = (OPpENTERSUB_AMPER<<8);
3134 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
3135 Perl_warner(aTHX_ WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
3137 if (PL_expect == XSTATE && isALPHA(tmp) &&
3138 (s == PL_linestart+1 || s[-2] == '\n') )
3140 if (PL_in_eval && !PL_rsfp) {
3145 if (strnEQ(s,"=cut",4)) {
3159 PL_doextract = TRUE;
3162 if (PL_lex_brackets < PL_lex_formbrack) {
3164 #ifdef PERL_STRICT_CR
3165 for (t = s; *t == ' ' || *t == '\t'; t++) ;
3167 for (t = s; *t == ' ' || *t == '\t' || *t == '\r'; t++) ;
3169 if (*t == '\n' || *t == '#') {
3187 if (PL_expect != XOPERATOR) {
3188 if (s[1] != '<' && !strchr(s,'>'))
3191 s = scan_heredoc(s);
3193 s = scan_inputsymbol(s);
3194 TERM(sublex_start());
3199 SHop(OP_LEFT_SHIFT);
3213 SHop(OP_RIGHT_SHIFT);
3222 if (PL_expect == XOPERATOR) {
3223 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3226 return ','; /* grandfather non-comma-format format */
3230 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
3231 PL_tokenbuf[0] = '@';
3232 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3233 sizeof PL_tokenbuf - 1, FALSE);
3234 if (PL_expect == XOPERATOR)
3235 no_op("Array length", s);
3236 if (!PL_tokenbuf[1])
3238 PL_expect = XOPERATOR;
3239 PL_pending_ident = '#';
3243 PL_tokenbuf[0] = '$';
3244 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3245 sizeof PL_tokenbuf - 1, FALSE);
3246 if (PL_expect == XOPERATOR)
3248 if (!PL_tokenbuf[1]) {
3250 yyerror("Final $ should be \\$ or $name");
3254 /* This kludge not intended to be bulletproof. */
3255 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
3256 yylval.opval = newSVOP(OP_CONST, 0,
3257 newSViv((IV)PL_compiling.cop_arybase));
3258 yylval.opval->op_private = OPpCONST_ARYBASE;
3264 if (PL_lex_state == LEX_NORMAL)
3267 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3270 PL_tokenbuf[0] = '@';
3271 if (ckWARN(WARN_SYNTAX)) {
3273 isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$';
3276 PL_bufptr = skipspace(PL_bufptr);
3277 while (t < PL_bufend && *t != ']')
3279 Perl_warner(aTHX_ WARN_SYNTAX,
3280 "Multidimensional syntax %.*s not supported",
3281 (t - PL_bufptr) + 1, PL_bufptr);
3285 else if (*s == '{') {
3286 PL_tokenbuf[0] = '%';
3287 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
3288 (t = strchr(s, '}')) && (t = strchr(t, '=')))
3290 char tmpbuf[sizeof PL_tokenbuf];
3292 for (t++; isSPACE(*t); t++) ;
3293 if (isIDFIRST_lazy_if(t,UTF)) {
3294 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
3295 for (; isSPACE(*t); t++) ;
3296 if (*t == ';' && get_cv(tmpbuf, FALSE))
3297 Perl_warner(aTHX_ WARN_SYNTAX,
3298 "You need to quote \"%s\"", tmpbuf);
3304 PL_expect = XOPERATOR;
3305 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3306 bool islop = (PL_last_lop == PL_oldoldbufptr);
3307 if (!islop || PL_last_lop_op == OP_GREPSTART)
3308 PL_expect = XOPERATOR;
3309 else if (strchr("$@\"'`q", *s))
3310 PL_expect = XTERM; /* e.g. print $fh "foo" */
3311 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
3312 PL_expect = XTERM; /* e.g. print $fh &sub */
3313 else if (isIDFIRST_lazy_if(s,UTF)) {
3314 char tmpbuf[sizeof PL_tokenbuf];
3315 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3316 if (tmp = keyword(tmpbuf, len)) {
3317 /* binary operators exclude handle interpretations */
3329 PL_expect = XTERM; /* e.g. print $fh length() */
3334 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
3335 if (gv && GvCVu(gv))
3336 PL_expect = XTERM; /* e.g. print $fh subr() */
3339 else if (isDIGIT(*s))
3340 PL_expect = XTERM; /* e.g. print $fh 3 */
3341 else if (*s == '.' && isDIGIT(s[1]))
3342 PL_expect = XTERM; /* e.g. print $fh .3 */
3343 else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
3344 PL_expect = XTERM; /* e.g. print $fh -1 */
3345 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3346 PL_expect = XTERM; /* print $fh <<"EOF" */
3348 PL_pending_ident = '$';
3352 if (PL_expect == XOPERATOR)
3354 PL_tokenbuf[0] = '@';
3355 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3356 if (!PL_tokenbuf[1]) {
3358 yyerror("Final @ should be \\@ or @name");
3361 if (PL_lex_state == LEX_NORMAL)
3363 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3365 PL_tokenbuf[0] = '%';
3367 /* Warn about @ where they meant $. */
3368 if (ckWARN(WARN_SYNTAX)) {
3369 if (*s == '[' || *s == '{') {
3371 while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
3373 if (*t == '}' || *t == ']') {
3375 PL_bufptr = skipspace(PL_bufptr);
3376 Perl_warner(aTHX_ WARN_SYNTAX,
3377 "Scalar value %.*s better written as $%.*s",
3378 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
3383 PL_pending_ident = '@';
3386 case '/': /* may either be division or pattern */
3387 case '?': /* may either be conditional or pattern */
3388 if (PL_expect != XOPERATOR) {
3389 /* Disable warning on "study /blah/" */
3390 if (PL_oldoldbufptr == PL_last_uni
3391 && (*PL_last_uni != 's' || s - PL_last_uni < 5
3392 || memNE(PL_last_uni, "study", 5)
3393 || isALNUM_lazy_if(PL_last_uni+5,UTF)))
3395 s = scan_pat(s,OP_MATCH);
3396 TERM(sublex_start());
3404 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3405 #ifdef PERL_STRICT_CR
3408 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3410 && (s == PL_linestart || s[-1] == '\n') )
3412 PL_lex_formbrack = 0;
3416 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
3422 yylval.ival = OPf_SPECIAL;
3428 if (PL_expect != XOPERATOR)
3433 case '0': case '1': case '2': case '3': case '4':
3434 case '5': case '6': case '7': case '8': case '9':
3436 if (PL_expect == XOPERATOR)
3441 s = scan_str(s,FALSE,FALSE);
3442 if (PL_expect == XOPERATOR) {
3443 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3446 return ','; /* grandfather non-comma-format format */
3452 missingterm((char*)0);
3453 yylval.ival = OP_CONST;
3454 TERM(sublex_start());
3457 s = scan_str(s,FALSE,FALSE);
3458 if (PL_expect == XOPERATOR) {
3459 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3462 return ','; /* grandfather non-comma-format format */
3468 missingterm((char*)0);
3469 yylval.ival = OP_CONST;
3470 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
3471 if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
3472 yylval.ival = OP_STRINGIFY;
3476 TERM(sublex_start());
3479 s = scan_str(s,FALSE,FALSE);
3480 if (PL_expect == XOPERATOR)
3481 no_op("Backticks",s);
3483 missingterm((char*)0);
3484 yylval.ival = OP_BACKTICK;
3486 TERM(sublex_start());
3490 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
3491 Perl_warner(aTHX_ WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
3493 if (PL_expect == XOPERATOR)
3494 no_op("Backslash",s);
3498 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
3502 while (isDIGIT(*start))
3504 if (*start == '.' && isDIGIT(start[1])) {
3508 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
3509 else if (!isALPHA(*start) && (PL_expect == XTERM || PL_expect == XREF)) {
3513 gv = gv_fetchpv(s, FALSE, SVt_PVCV);
3523 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
3563 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3565 /* Some keywords can be followed by any delimiter, including ':' */
3566 tmp = (len == 1 && strchr("msyq", PL_tokenbuf[0]) ||
3567 len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
3568 (PL_tokenbuf[0] == 'q' &&
3569 strchr("qwxr", PL_tokenbuf[1]))));
3571 /* x::* is just a word, unless x is "CORE" */
3572 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
3576 while (d < PL_bufend && isSPACE(*d))
3577 d++; /* no comments skipped here, or s### is misparsed */
3579 /* Is this a label? */
3580 if (!tmp && PL_expect == XSTATE
3581 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
3583 yylval.pval = savepv(PL_tokenbuf);
3588 /* Check for keywords */
3589 tmp = keyword(PL_tokenbuf, len);
3591 /* Is this a word before a => operator? */
3592 if (strnEQ(d,"=>",2)) {
3594 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
3595 yylval.opval->op_private = OPpCONST_BARE;
3599 if (tmp < 0) { /* second-class keyword? */
3600 GV *ogv = Nullgv; /* override (winner) */
3601 GV *hgv = Nullgv; /* hidden (loser) */
3602 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3604 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3607 if (GvIMPORTED_CV(gv))
3609 else if (! CvMETHOD(cv))
3613 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3614 (gv = *gvp) != (GV*)&PL_sv_undef &&
3615 GvCVu(gv) && GvIMPORTED_CV(gv))
3621 tmp = 0; /* overridden by import or by GLOBAL */
3624 && -tmp==KEY_lock /* XXX generalizable kludge */
3626 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3628 tmp = 0; /* any sub overrides "weak" keyword */
3630 else { /* no override */
3634 if (ckWARN(WARN_AMBIGUOUS) && hgv
3635 && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3636 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3637 "Ambiguous call resolved as CORE::%s(), %s",
3638 GvENAME(hgv), "qualify as such or use &");
3645 default: /* not a keyword */
3648 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3650 /* Get the rest if it looks like a package qualifier */
3652 if (*s == '\'' || *s == ':' && s[1] == ':') {
3654 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3657 Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
3658 *s == '\'' ? "'" : "::");
3662 if (PL_expect == XOPERATOR) {
3663 if (PL_bufptr == PL_linestart) {
3664 CopLINE_dec(PL_curcop);
3665 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3666 CopLINE_inc(PL_curcop);
3669 no_op("Bareword",s);
3672 /* Look for a subroutine with this name in current package,
3673 unless name is "Foo::", in which case Foo is a bearword
3674 (and a package name). */
3677 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3679 if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3680 Perl_warner(aTHX_ WARN_BAREWORD,
3681 "Bareword \"%s\" refers to nonexistent package",
3684 PL_tokenbuf[len] = '\0';
3691 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3694 /* if we saw a global override before, get the right name */
3697 sv = newSVpvn("CORE::GLOBAL::",14);
3698 sv_catpv(sv,PL_tokenbuf);
3701 sv = newSVpv(PL_tokenbuf,0);
3703 /* Presume this is going to be a bareword of some sort. */
3706 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3707 yylval.opval->op_private = OPpCONST_BARE;
3709 /* And if "Foo::", then that's what it certainly is. */
3714 /* See if it's the indirect object for a list operator. */
3716 if (PL_oldoldbufptr &&
3717 PL_oldoldbufptr < PL_bufptr &&
3718 (PL_oldoldbufptr == PL_last_lop
3719 || PL_oldoldbufptr == PL_last_uni) &&
3720 /* NO SKIPSPACE BEFORE HERE! */
3721 (PL_expect == XREF ||
3722 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
3724 bool immediate_paren = *s == '(';
3726 /* (Now we can afford to cross potential line boundary.) */
3729 /* Two barewords in a row may indicate method call. */
3731 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp=intuit_method(s,gv)))
3734 /* If not a declared subroutine, it's an indirect object. */
3735 /* (But it's an indir obj regardless for sort.) */
3737 if ((PL_last_lop_op == OP_SORT ||
3738 (!immediate_paren && (!gv || !GvCVu(gv)))) &&
3739 (PL_last_lop_op != OP_MAPSTART &&
3740 PL_last_lop_op != OP_GREPSTART))
3742 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3747 /* If followed by a paren, it's certainly a subroutine. */
3749 PL_expect = XOPERATOR;
3753 if (gv && GvCVu(gv)) {
3754 for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
3755 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
3760 PL_nextval[PL_nexttoke].opval = yylval.opval;
3761 PL_expect = XOPERATOR;
3767 /* If followed by var or block, call it a method (unless sub) */
3769 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3770 PL_last_lop = PL_oldbufptr;
3771 PL_last_lop_op = OP_METHOD;
3775 /* If followed by a bareword, see if it looks like indir obj. */
3777 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp = intuit_method(s,gv)))
3780 /* Not a method, so call it a subroutine (if defined) */
3782 if (gv && GvCVu(gv)) {
3784 if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
3785 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3786 "Ambiguous use of -%s resolved as -&%s()",
3787 PL_tokenbuf, PL_tokenbuf);
3788 /* Check for a constant sub */
3790 if ((sv = cv_const_sv(cv))) {
3792 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3793 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3794 yylval.opval->op_private = 0;
3798 /* Resolve to GV now. */
3799 op_free(yylval.opval);
3800 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3801 yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
3802 PL_last_lop = PL_oldbufptr;
3803 PL_last_lop_op = OP_ENTERSUB;
3804 /* Is there a prototype? */
3807 char *proto = SvPV((SV*)cv, len);
3810 if (strEQ(proto, "$"))
3812 if (*proto == '&' && *s == '{') {
3813 sv_setpv(PL_subname,"__ANON__");
3817 PL_nextval[PL_nexttoke].opval = yylval.opval;
3823 /* Call it a bare word */
3825 if (PL_hints & HINT_STRICT_SUBS)
3826 yylval.opval->op_private |= OPpCONST_STRICT;
3829 if (ckWARN(WARN_RESERVED)) {
3830 if (lastchar != '-') {
3831 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3833 Perl_warner(aTHX_ WARN_RESERVED, PL_warn_reserved,
3840 if (lastchar && strchr("*%&", lastchar) && ckWARN_d(WARN_AMBIGUOUS)) {
3841 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3842 "Operator or semicolon missing before %c%s",
3843 lastchar, PL_tokenbuf);
3844 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3845 "Ambiguous use of %c resolved as operator %c",
3846 lastchar, lastchar);
3852 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3853 newSVpv(CopFILE(PL_curcop),0));
3857 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3858 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
3861 case KEY___PACKAGE__:
3862 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3864 ? newSVsv(PL_curstname)
3873 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3874 char *pname = "main";
3875 if (PL_tokenbuf[2] == 'D')
3876 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3877 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
3880 GvIOp(gv) = newIO();
3881 IoIFP(GvIOp(gv)) = PL_rsfp;
3882 #if defined(HAS_FCNTL) && defined(F_SETFD)
3884 int fd = PerlIO_fileno(PL_rsfp);
3885 fcntl(fd,F_SETFD,fd >= 3);
3888 /* Mark this internal pseudo-handle as clean */
3889 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3891 IoTYPE(GvIOp(gv)) = '|';
3892 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
3893 IoTYPE(GvIOp(gv)) = '-';
3895 IoTYPE(GvIOp(gv)) = '<';
3896 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
3897 /* if the script was opened in binmode, we need to revert
3898 * it to text mode for compatibility; but only iff it has CRs
3899 * XXX this is a questionable hack at best. */
3900 if (PL_bufend-PL_bufptr > 2
3901 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
3904 if (IoTYPE(GvIOp(gv)) == '<') {
3905 loc = PerlIO_tell(PL_rsfp);
3906 (void)PerlIO_seek(PL_rsfp, 0L, 0);
3908 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
3909 #if defined(__BORLANDC__)
3910 /* XXX see note in do_binmode() */
3911 ((FILE*)PL_rsfp)->flags |= _F_BIN;
3914 PerlIO_seek(PL_rsfp, loc, 0);
3929 if (PL_expect == XSTATE) {
3936 if (*s == ':' && s[1] == ':') {
3939 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3940 tmp = keyword(PL_tokenbuf, len);
3954 LOP(OP_ACCEPT,XTERM);
3960 LOP(OP_ATAN2,XTERM);
3969 LOP(OP_BLESS,XTERM);
3978 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
3995 if (!PL_cryptseen) {
3996 PL_cryptseen = TRUE;
4000 LOP(OP_CRYPT,XTERM);
4003 if (ckWARN(WARN_CHMOD)) {
4004 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4005 if (*d != '0' && isDIGIT(*d))
4006 Perl_warner(aTHX_ WARN_CHMOD,
4007 "chmod() mode argument is missing initial 0");
4009 LOP(OP_CHMOD,XTERM);
4012 LOP(OP_CHOWN,XTERM);
4015 LOP(OP_CONNECT,XTERM);
4031 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4035 PL_hints |= HINT_BLOCK_SCOPE;
4045 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
4046 LOP(OP_DBMOPEN,XTERM);
4052 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4059 yylval.ival = CopLINE(PL_curcop);
4073 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
4074 UNIBRACK(OP_ENTEREVAL);
4089 case KEY_endhostent:
4095 case KEY_endservent:
4098 case KEY_endprotoent:
4109 yylval.ival = CopLINE(PL_curcop);
4111 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
4113 if ((PL_bufend - p) >= 3 &&
4114 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
4116 else if ((PL_bufend - p) >= 4 &&
4117 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
4120 if (isIDFIRST_lazy_if(p,UTF)) {
4121 p = scan_ident(p, PL_bufend,
4122 PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4126 Perl_croak(aTHX_ "Missing $ on loop variable");
4131 LOP(OP_FORMLINE,XTERM);
4137 LOP(OP_FCNTL,XTERM);
4143 LOP(OP_FLOCK,XTERM);
4152 LOP(OP_GREPSTART, XREF);
4155 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4170 case KEY_getpriority:
4171 LOP(OP_GETPRIORITY,XTERM);
4173 case KEY_getprotobyname:
4176 case KEY_getprotobynumber:
4177 LOP(OP_GPBYNUMBER,XTERM);
4179 case KEY_getprotoent:
4191 case KEY_getpeername:
4192 UNI(OP_GETPEERNAME);
4194 case KEY_gethostbyname:
4197 case KEY_gethostbyaddr:
4198 LOP(OP_GHBYADDR,XTERM);
4200 case KEY_gethostent:
4203 case KEY_getnetbyname:
4206 case KEY_getnetbyaddr:
4207 LOP(OP_GNBYADDR,XTERM);
4212 case KEY_getservbyname:
4213 LOP(OP_GSBYNAME,XTERM);
4215 case KEY_getservbyport:
4216 LOP(OP_GSBYPORT,XTERM);
4218 case KEY_getservent:
4221 case KEY_getsockname:
4222 UNI(OP_GETSOCKNAME);
4224 case KEY_getsockopt:
4225 LOP(OP_GSOCKOPT,XTERM);
4247 yylval.ival = CopLINE(PL_curcop);
4251 LOP(OP_INDEX,XTERM);
4257 LOP(OP_IOCTL,XTERM);
4269 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4301 LOP(OP_LISTEN,XTERM);
4310 s = scan_pat(s,OP_MATCH);
4311 TERM(sublex_start());
4314 LOP(OP_MAPSTART, XREF);
4317 LOP(OP_MKDIR,XTERM);
4320 LOP(OP_MSGCTL,XTERM);
4323 LOP(OP_MSGGET,XTERM);
4326 LOP(OP_MSGRCV,XTERM);
4329 LOP(OP_MSGSND,XTERM);
4335 if (isIDFIRST_lazy_if(s,UTF)) {
4336 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
4337 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
4339 PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
4340 if (!PL_in_my_stash) {
4343 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
4351 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4358 if (PL_expect != XSTATE)
4359 yyerror("\"no\" not allowed in expression");
4360 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4361 s = force_version(s);
4366 if (*s == '(' || (s = skipspace(s), *s == '('))
4373 if (isIDFIRST_lazy_if(s,UTF)) {
4375 for (d = s; isALNUM_lazy_if(d,UTF); d++) ;
4377 if (strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE))
4378 Perl_warner(aTHX_ WARN_PRECEDENCE,
4379 "Precedence problem: open %.*s should be open(%.*s)",
4385 yylval.ival = OP_OR;
4395 LOP(OP_OPEN_DIR,XTERM);
4398 checkcomma(s,PL_tokenbuf,"filehandle");
4402 checkcomma(s,PL_tokenbuf,"filehandle");
4421 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4425 LOP(OP_PIPE_OP,XTERM);
4428 s = scan_str(s,FALSE,FALSE);
4430 missingterm((char*)0);
4431 yylval.ival = OP_CONST;
4432 TERM(sublex_start());
4438 s = scan_str(s,FALSE,FALSE);
4440 missingterm((char*)0);
4442 if (SvCUR(PL_lex_stuff)) {
4445 d = SvPV_force(PL_lex_stuff, len);
4447 for (; isSPACE(*d) && len; --len, ++d) ;
4450 if (!warned && ckWARN(WARN_QW)) {
4451 for (; !isSPACE(*d) && len; --len, ++d) {
4453 Perl_warner(aTHX_ WARN_QW,
4454 "Possible attempt to separate words with commas");
4457 else if (*d == '#') {
4458 Perl_warner(aTHX_ WARN_QW,
4459 "Possible attempt to put comments in qw() list");
4465 for (; !isSPACE(*d) && len; --len, ++d) ;
4467 words = append_elem(OP_LIST, words,
4468 newSVOP(OP_CONST, 0, newSVpvn(b, d-b)));
4472 PL_nextval[PL_nexttoke].opval = words;
4477 SvREFCNT_dec(PL_lex_stuff);
4478 PL_lex_stuff = Nullsv;
4483 s = scan_str(s,FALSE,FALSE);
4485 missingterm((char*)0);
4486 yylval.ival = OP_STRINGIFY;
4487 if (SvIVX(PL_lex_stuff) == '\'')
4488 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
4489 TERM(sublex_start());
4492 s = scan_pat(s,OP_QR);
4493 TERM(sublex_start());
4496 s = scan_str(s,FALSE,FALSE);
4498 missingterm((char*)0);
4499 yylval.ival = OP_BACKTICK;
4501 TERM(sublex_start());
4508 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4509 s = force_version(s);
4512 *PL_tokenbuf = '\0';
4513 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4514 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
4515 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
4517 yyerror("<> should be quotes");
4525 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4529 LOP(OP_RENAME,XTERM);
4538 LOP(OP_RINDEX,XTERM);
4561 LOP(OP_REVERSE,XTERM);
4572 TERM(sublex_start());
4574 TOKEN(1); /* force error */
4583 LOP(OP_SELECT,XTERM);
4589 LOP(OP_SEMCTL,XTERM);
4592 LOP(OP_SEMGET,XTERM);
4595 LOP(OP_SEMOP,XTERM);
4601 LOP(OP_SETPGRP,XTERM);
4603 case KEY_setpriority:
4604 LOP(OP_SETPRIORITY,XTERM);
4606 case KEY_sethostent:
4612 case KEY_setservent:
4615 case KEY_setprotoent:
4625 LOP(OP_SEEKDIR,XTERM);
4627 case KEY_setsockopt:
4628 LOP(OP_SSOCKOPT,XTERM);
4634 LOP(OP_SHMCTL,XTERM);
4637 LOP(OP_SHMGET,XTERM);
4640 LOP(OP_SHMREAD,XTERM);
4643 LOP(OP_SHMWRITE,XTERM);
4646 LOP(OP_SHUTDOWN,XTERM);
4655 LOP(OP_SOCKET,XTERM);
4657 case KEY_socketpair:
4658 LOP(OP_SOCKPAIR,XTERM);
4661 checkcomma(s,PL_tokenbuf,"subroutine name");
4663 if (*s == ';' || *s == ')') /* probably a close */
4664 Perl_croak(aTHX_ "sort is now a reserved word");
4666 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4670 LOP(OP_SPLIT,XTERM);
4673 LOP(OP_SPRINTF,XTERM);
4676 LOP(OP_SPLICE,XTERM);
4691 LOP(OP_SUBSTR,XTERM);
4697 char tmpbuf[sizeof PL_tokenbuf];
4699 expectation attrful;
4700 bool have_name, have_proto;
4705 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
4706 (*s == ':' && s[1] == ':'))
4709 attrful = XATTRBLOCK;
4710 /* remember buffer pos'n for later force_word */
4711 tboffset = s - PL_oldbufptr;
4712 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4713 if (strchr(tmpbuf, ':'))
4714 sv_setpv(PL_subname, tmpbuf);
4716 sv_setsv(PL_subname,PL_curstname);
4717 sv_catpvn(PL_subname,"::",2);
4718 sv_catpvn(PL_subname,tmpbuf,len);
4725 Perl_croak(aTHX_ "Missing name in \"my sub\"");
4726 PL_expect = XTERMBLOCK;
4727 attrful = XATTRTERM;
4728 sv_setpv(PL_subname,"?");
4732 if (key == KEY_format) {
4734 PL_lex_formbrack = PL_lex_brackets + 1;
4736 (void) force_word(PL_oldbufptr + tboffset, WORD,
4741 /* Look for a prototype */
4745 s = scan_str(s,FALSE,FALSE);
4748 SvREFCNT_dec(PL_lex_stuff);
4749 PL_lex_stuff = Nullsv;
4750 Perl_croak(aTHX_ "Prototype not terminated");
4753 d = SvPVX(PL_lex_stuff);
4755 for (p = d; *p; ++p) {
4760 SvCUR(PL_lex_stuff) = tmp;
4768 if (*s == ':' && s[1] != ':')
4769 PL_expect = attrful;
4772 PL_nextval[PL_nexttoke].opval =
4773 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4774 PL_lex_stuff = Nullsv;
4778 sv_setpv(PL_subname,"__ANON__");
4781 (void) force_word(PL_oldbufptr + tboffset, WORD,
4790 LOP(OP_SYSTEM,XREF);
4793 LOP(OP_SYMLINK,XTERM);
4796 LOP(OP_SYSCALL,XTERM);
4799 LOP(OP_SYSOPEN,XTERM);
4802 LOP(OP_SYSSEEK,XTERM);
4805 LOP(OP_SYSREAD,XTERM);
4808 LOP(OP_SYSWRITE,XTERM);
4812 TERM(sublex_start());
4833 LOP(OP_TRUNCATE,XTERM);
4845 yylval.ival = CopLINE(PL_curcop);
4849 yylval.ival = CopLINE(PL_curcop);
4853 LOP(OP_UNLINK,XTERM);
4859 LOP(OP_UNPACK,XTERM);
4862 LOP(OP_UTIME,XTERM);
4865 if (ckWARN(WARN_UMASK)) {
4866 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4867 if (*d != '0' && isDIGIT(*d))
4868 Perl_warner(aTHX_ WARN_UMASK,
4869 "umask: argument is missing initial 0");
4874 LOP(OP_UNSHIFT,XTERM);
4877 if (PL_expect != XSTATE)
4878 yyerror("\"use\" not allowed in expression");
4880 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4881 s = force_version(s);
4882 if (*s == ';' || (s = skipspace(s), *s == ';')) {
4883 PL_nextval[PL_nexttoke].opval = Nullop;
4888 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4889 s = force_version(s);
4901 yylval.ival = CopLINE(PL_curcop);
4905 PL_hints |= HINT_BLOCK_SCOPE;
4912 LOP(OP_WAITPID,XTERM);
4920 static char ctl_l[2];
4922 if (ctl_l[0] == '\0')
4923 ctl_l[0] = toCTRL('L');
4924 gv_fetchpv(ctl_l,TRUE, SVt_PV);
4927 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
4932 if (PL_expect == XOPERATOR)
4938 yylval.ival = OP_XOR;
4943 TERM(sublex_start());
4949 Perl_keyword(pTHX_ register char *d, I32 len)
4954 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
4955 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
4956 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
4957 if (strEQ(d,"__DATA__")) return KEY___DATA__;
4958 if (strEQ(d,"__END__")) return KEY___END__;
4962 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
4967 if (strEQ(d,"and")) return -KEY_and;
4968 if (strEQ(d,"abs")) return -KEY_abs;
4971 if (strEQ(d,"alarm")) return -KEY_alarm;
4972 if (strEQ(d,"atan2")) return -KEY_atan2;
4975 if (strEQ(d,"accept")) return -KEY_accept;
4980 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
4983 if (strEQ(d,"bless")) return -KEY_bless;
4984 if (strEQ(d,"bind")) return -KEY_bind;
4985 if (strEQ(d,"binmode")) return -KEY_binmode;
4988 if (strEQ(d,"CORE")) return -KEY_CORE;
4989 if (strEQ(d,"CHECK")) return KEY_CHECK;
4994 if (strEQ(d,"cmp")) return -KEY_cmp;
4995 if (strEQ(d,"chr")) return -KEY_chr;
4996 if (strEQ(d,"cos")) return -KEY_cos;
4999 if (strEQ(d,"chop")) return KEY_chop;
5002 if (strEQ(d,"close")) return -KEY_close;
5003 if (strEQ(d,"chdir")) return -KEY_chdir;
5004 if (strEQ(d,"chomp")) return KEY_chomp;
5005 if (strEQ(d,"chmod")) return -KEY_chmod;
5006 if (strEQ(d,"chown")) return -KEY_chown;
5007 if (strEQ(d,"crypt")) return -KEY_crypt;
5010 if (strEQ(d,"chroot")) return -KEY_chroot;
5011 if (strEQ(d,"caller")) return -KEY_caller;
5014 if (strEQ(d,"connect")) return -KEY_connect;
5017 if (strEQ(d,"closedir")) return -KEY_closedir;
5018 if (strEQ(d,"continue")) return -KEY_continue;
5023 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
5028 if (strEQ(d,"do")) return KEY_do;
5031 if (strEQ(d,"die")) return -KEY_die;
5034 if (strEQ(d,"dump")) return -KEY_dump;
5037 if (strEQ(d,"delete")) return KEY_delete;
5040 if (strEQ(d,"defined")) return KEY_defined;
5041 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
5044 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
5049 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
5050 if (strEQ(d,"END")) return KEY_END;
5055 if (strEQ(d,"eq")) return -KEY_eq;
5058 if (strEQ(d,"eof")) return -KEY_eof;
5059 if (strEQ(d,"exp")) return -KEY_exp;
5062 if (strEQ(d,"else")) return KEY_else;
5063 if (strEQ(d,"exit")) return -KEY_exit;
5064 if (strEQ(d,"eval")) return KEY_eval;
5065 if (strEQ(d,"exec")) return -KEY_exec;
5066 if (strEQ(d,"each")) return KEY_each;
5069 if (strEQ(d,"elsif")) return KEY_elsif;
5072 if (strEQ(d,"exists")) return KEY_exists;
5073 if (strEQ(d,"elseif")) Perl_warn(aTHX_ "elseif should be elsif");
5076 if (strEQ(d,"endgrent")) return -KEY_endgrent;
5077 if (strEQ(d,"endpwent")) return -KEY_endpwent;
5080 if (strEQ(d,"endnetent")) return -KEY_endnetent;
5083 if (strEQ(d,"endhostent")) return -KEY_endhostent;
5084 if (strEQ(d,"endservent")) return -KEY_endservent;
5087 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
5094 if (strEQ(d,"for")) return KEY_for;
5097 if (strEQ(d,"fork")) return -KEY_fork;
5100 if (strEQ(d,"fcntl")) return -KEY_fcntl;
5101 if (strEQ(d,"flock")) return -KEY_flock;
5104 if (strEQ(d,"format")) return KEY_format;
5105 if (strEQ(d,"fileno")) return -KEY_fileno;
5108 if (strEQ(d,"foreach")) return KEY_foreach;
5111 if (strEQ(d,"formline")) return -KEY_formline;
5117 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
5118 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
5122 if (strnEQ(d,"get",3)) {
5127 if (strEQ(d,"ppid")) return -KEY_getppid;
5128 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
5131 if (strEQ(d,"pwent")) return -KEY_getpwent;
5132 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
5133 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
5136 if (strEQ(d,"peername")) return -KEY_getpeername;
5137 if (strEQ(d,"protoent")) return -KEY_getprotoent;
5138 if (strEQ(d,"priority")) return -KEY_getpriority;
5141 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
5144 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
5148 else if (*d == 'h') {
5149 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
5150 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
5151 if (strEQ(d,"hostent")) return -KEY_gethostent;
5153 else if (*d == 'n') {
5154 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
5155 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
5156 if (strEQ(d,"netent")) return -KEY_getnetent;
5158 else if (*d == 's') {
5159 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
5160 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
5161 if (strEQ(d,"servent")) return -KEY_getservent;
5162 if (strEQ(d,"sockname")) return -KEY_getsockname;
5163 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
5165 else if (*d == 'g') {
5166 if (strEQ(d,"grent")) return -KEY_getgrent;
5167 if (strEQ(d,"grnam")) return -KEY_getgrnam;
5168 if (strEQ(d,"grgid")) return -KEY_getgrgid;
5170 else if (*d == 'l') {
5171 if (strEQ(d,"login")) return -KEY_getlogin;
5173 else if (strEQ(d,"c")) return -KEY_getc;
5178 if (strEQ(d,"gt")) return -KEY_gt;
5179 if (strEQ(d,"ge")) return -KEY_ge;
5182 if (strEQ(d,"grep")) return KEY_grep;
5183 if (strEQ(d,"goto")) return KEY_goto;
5184 if (strEQ(d,"glob")) return KEY_glob;
5187 if (strEQ(d,"gmtime")) return -KEY_gmtime;
5192 if (strEQ(d,"hex")) return -KEY_hex;
5195 if (strEQ(d,"INIT")) return KEY_INIT;
5200 if (strEQ(d,"if")) return KEY_if;
5203 if (strEQ(d,"int")) return -KEY_int;
5206 if (strEQ(d,"index")) return -KEY_index;
5207 if (strEQ(d,"ioctl")) return -KEY_ioctl;
5212 if (strEQ(d,"join")) return -KEY_join;
5216 if (strEQ(d,"keys")) return KEY_keys;
5217 if (strEQ(d,"kill")) return -KEY_kill;
5222 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
5223 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
5229 if (strEQ(d,"lt")) return -KEY_lt;
5230 if (strEQ(d,"le")) return -KEY_le;
5231 if (strEQ(d,"lc")) return -KEY_lc;
5234 if (strEQ(d,"log")) return -KEY_log;
5237 if (strEQ(d,"last")) return KEY_last;
5238 if (strEQ(d,"link")) return -KEY_link;
5239 if (strEQ(d,"lock")) return -KEY_lock;
5242 if (strEQ(d,"local")) return KEY_local;
5243 if (strEQ(d,"lstat")) return -KEY_lstat;
5246 if (strEQ(d,"length")) return -KEY_length;
5247 if (strEQ(d,"listen")) return -KEY_listen;
5250 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
5253 if (strEQ(d,"localtime")) return -KEY_localtime;
5259 case 1: return KEY_m;
5261 if (strEQ(d,"my")) return KEY_my;
5264 if (strEQ(d,"map")) return KEY_map;
5267 if (strEQ(d,"mkdir")) return -KEY_mkdir;
5270 if (strEQ(d,"msgctl")) return -KEY_msgctl;
5271 if (strEQ(d,"msgget")) return -KEY_msgget;
5272 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
5273 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
5278 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
5281 if (strEQ(d,"next")) return KEY_next;
5282 if (strEQ(d,"ne")) return -KEY_ne;
5283 if (strEQ(d,"not")) return -KEY_not;
5284 if (strEQ(d,"no")) return KEY_no;
5289 if (strEQ(d,"or")) return -KEY_or;
5292 if (strEQ(d,"ord")) return -KEY_ord;
5293 if (strEQ(d,"oct")) return -KEY_oct;
5294 if (strEQ(d,"our")) return KEY_our;
5297 if (strEQ(d,"open")) return -KEY_open;
5300 if (strEQ(d,"opendir")) return -KEY_opendir;
5307 if (strEQ(d,"pop")) return KEY_pop;
5308 if (strEQ(d,"pos")) return KEY_pos;
5311 if (strEQ(d,"push")) return KEY_push;
5312 if (strEQ(d,"pack")) return -KEY_pack;
5313 if (strEQ(d,"pipe")) return -KEY_pipe;
5316 if (strEQ(d,"print")) return KEY_print;
5319 if (strEQ(d,"printf")) return KEY_printf;
5322 if (strEQ(d,"package")) return KEY_package;
5325 if (strEQ(d,"prototype")) return KEY_prototype;
5330 if (strEQ(d,"q")) return KEY_q;
5331 if (strEQ(d,"qr")) return KEY_qr;
5332 if (strEQ(d,"qq")) return KEY_qq;
5333 if (strEQ(d,"qw")) return KEY_qw;
5334 if (strEQ(d,"qx")) return KEY_qx;
5336 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
5341 if (strEQ(d,"ref")) return -KEY_ref;
5344 if (strEQ(d,"read")) return -KEY_read;
5345 if (strEQ(d,"rand")) return -KEY_rand;
5346 if (strEQ(d,"recv")) return -KEY_recv;
5347 if (strEQ(d,"redo")) return KEY_redo;
5350 if (strEQ(d,"rmdir")) return -KEY_rmdir;
5351 if (strEQ(d,"reset")) return -KEY_reset;
5354 if (strEQ(d,"return")) return KEY_return;
5355 if (strEQ(d,"rename")) return -KEY_rename;
5356 if (strEQ(d,"rindex")) return -KEY_rindex;
5359 if (strEQ(d,"require")) return -KEY_require;
5360 if (strEQ(d,"reverse")) return -KEY_reverse;
5361 if (strEQ(d,"readdir")) return -KEY_readdir;
5364 if (strEQ(d,"readlink")) return -KEY_readlink;
5365 if (strEQ(d,"readline")) return -KEY_readline;
5366 if (strEQ(d,"readpipe")) return -KEY_readpipe;
5369 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
5375 case 0: return KEY_s;
5377 if (strEQ(d,"scalar")) return KEY_scalar;
5382 if (strEQ(d,"seek")) return -KEY_seek;
5383 if (strEQ(d,"send")) return -KEY_send;
5386 if (strEQ(d,"semop")) return -KEY_semop;
5389 if (strEQ(d,"select")) return -KEY_select;
5390 if (strEQ(d,"semctl")) return -KEY_semctl;
5391 if (strEQ(d,"semget")) return -KEY_semget;
5394 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
5395 if (strEQ(d,"seekdir")) return -KEY_seekdir;
5398 if (strEQ(d,"setpwent")) return -KEY_setpwent;
5399 if (strEQ(d,"setgrent")) return -KEY_setgrent;
5402 if (strEQ(d,"setnetent")) return -KEY_setnetent;
5405 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
5406 if (strEQ(d,"sethostent")) return -KEY_sethostent;
5407 if (strEQ(d,"setservent")) return -KEY_setservent;
5410 if (strEQ(d,"setpriority")) return -KEY_setpriority;
5411 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
5418 if (strEQ(d,"shift")) return KEY_shift;
5421 if (strEQ(d,"shmctl")) return -KEY_shmctl;
5422 if (strEQ(d,"shmget")) return -KEY_shmget;
5425 if (strEQ(d,"shmread")) return -KEY_shmread;
5428 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
5429 if (strEQ(d,"shutdown")) return -KEY_shutdown;
5434 if (strEQ(d,"sin")) return -KEY_sin;
5437 if (strEQ(d,"sleep")) return -KEY_sleep;
5440 if (strEQ(d,"sort")) return KEY_sort;
5441 if (strEQ(d,"socket")) return -KEY_socket;
5442 if (strEQ(d,"socketpair")) return -KEY_socketpair;
5445 if (strEQ(d,"split")) return KEY_split;
5446 if (strEQ(d,"sprintf")) return -KEY_sprintf;
5447 if (strEQ(d,"splice")) return KEY_splice;
5450 if (strEQ(d,"sqrt")) return -KEY_sqrt;
5453 if (strEQ(d,"srand")) return -KEY_srand;
5456 if (strEQ(d,"stat")) return -KEY_stat;
5457 if (strEQ(d,"study")) return KEY_study;
5460 if (strEQ(d,"substr")) return -KEY_substr;
5461 if (strEQ(d,"sub")) return KEY_sub;
5466 if (strEQ(d,"system")) return -KEY_system;
5469 if (strEQ(d,"symlink")) return -KEY_symlink;
5470 if (strEQ(d,"syscall")) return -KEY_syscall;
5471 if (strEQ(d,"sysopen")) return -KEY_sysopen;
5472 if (strEQ(d,"sysread")) return -KEY_sysread;
5473 if (strEQ(d,"sysseek")) return -KEY_sysseek;
5476 if (strEQ(d,"syswrite")) return -KEY_syswrite;
5485 if (strEQ(d,"tr")) return KEY_tr;
5488 if (strEQ(d,"tie")) return KEY_tie;
5491 if (strEQ(d,"tell")) return -KEY_tell;
5492 if (strEQ(d,"tied")) return KEY_tied;
5493 if (strEQ(d,"time")) return -KEY_time;
5496 if (strEQ(d,"times")) return -KEY_times;
5499 if (strEQ(d,"telldir")) return -KEY_telldir;
5502 if (strEQ(d,"truncate")) return -KEY_truncate;
5509 if (strEQ(d,"uc")) return -KEY_uc;
5512 if (strEQ(d,"use")) return KEY_use;
5515 if (strEQ(d,"undef")) return KEY_undef;
5516 if (strEQ(d,"until")) return KEY_until;
5517 if (strEQ(d,"untie")) return KEY_untie;
5518 if (strEQ(d,"utime")) return -KEY_utime;
5519 if (strEQ(d,"umask")) return -KEY_umask;
5522 if (strEQ(d,"unless")) return KEY_unless;
5523 if (strEQ(d,"unpack")) return -KEY_unpack;
5524 if (strEQ(d,"unlink")) return -KEY_unlink;
5527 if (strEQ(d,"unshift")) return KEY_unshift;
5528 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
5533 if (strEQ(d,"values")) return -KEY_values;
5534 if (strEQ(d,"vec")) return -KEY_vec;
5539 if (strEQ(d,"warn")) return -KEY_warn;
5540 if (strEQ(d,"wait")) return -KEY_wait;
5543 if (strEQ(d,"while")) return KEY_while;
5544 if (strEQ(d,"write")) return -KEY_write;
5547 if (strEQ(d,"waitpid")) return -KEY_waitpid;
5550 if (strEQ(d,"wantarray")) return -KEY_wantarray;
5555 if (len == 1) return -KEY_x;
5556 if (strEQ(d,"xor")) return -KEY_xor;
5559 if (len == 1) return KEY_y;
5568 S_checkcomma(pTHX_ register char *s, char *name, char *what)
5572 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
5573 dTHR; /* only for ckWARN */
5574 if (ckWARN(WARN_SYNTAX)) {
5576 for (w = s+2; *w && level; w++) {
5583 for (; *w && isSPACE(*w); w++) ;
5584 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
5585 Perl_warner(aTHX_ WARN_SYNTAX,
5586 "%s (...) interpreted as function",name);
5589 while (s < PL_bufend && isSPACE(*s))
5593 while (s < PL_bufend && isSPACE(*s))
5595 if (isIDFIRST_lazy_if(s,UTF)) {
5597 while (isALNUM_lazy_if(s,UTF))
5599 while (s < PL_bufend && isSPACE(*s))
5604 kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
5608 Perl_croak(aTHX_ "No comma allowed after %s", what);
5613 /* Either returns sv, or mortalizes sv and returns a new SV*.
5614 Best used as sv=new_constant(..., sv, ...).
5615 If s, pv are NULL, calls subroutine with one argument,
5616 and type is used with error messages only. */
5619 S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv,
5623 HV *table = GvHV(PL_hintgv); /* ^H */
5627 const char *why, *why1, *why2;
5629 if (!(PL_hints & HINT_LOCALIZE_HH)) {
5632 why = "%^H is not localized";
5636 msg = Perl_newSVpvf(aTHX_ "constant(%s): %s%s%s",
5637 (type ? type: "undef"), why1, why2, why);
5638 yyerror(SvPVX(msg));
5643 why = "%^H is not defined";
5646 cvp = hv_fetch(table, key, strlen(key), FALSE);
5647 if (!cvp || !SvOK(*cvp)) {
5648 why = "} is not defined";
5653 sv_2mortal(sv); /* Parent created it permanently */
5656 pv = sv_2mortal(newSVpvn(s, len));
5658 typesv = sv_2mortal(newSVpv(type, 0));
5660 typesv = &PL_sv_undef;
5662 PUSHSTACKi(PERLSI_OVERLOAD);
5675 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
5679 /* Check the eval first */
5680 if (!PL_in_eval && SvTRUE(ERRSV))
5683 sv_catpv(ERRSV, "Propagated");
5684 yyerror(SvPV(ERRSV, n_a)); /* Duplicates the message inside eval */
5686 res = SvREFCNT_inc(sv);
5690 (void)SvREFCNT_inc(res);
5699 why = "}} did not return a defined value";
5700 why1 = "Call to &{$^H{";
5710 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
5712 register char *d = dest;
5713 register char *e = d + destlen - 3; /* two-character token, ending NUL */
5716 Perl_croak(aTHX_ ident_too_long);
5717 if (isALNUM(*s)) /* UTF handled below */
5719 else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) {
5724 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
5728 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5729 char *t = s + UTF8SKIP(s);
5730 while (*t & 0x80 && is_utf8_mark((U8*)t))
5732 if (d + (t - s) > e)
5733 Perl_croak(aTHX_ ident_too_long);
5734 Copy(s, d, t - s, char);
5747 S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
5757 e = d + destlen - 3; /* two-character token, ending NUL */
5759 while (isDIGIT(*s)) {
5761 Perl_croak(aTHX_ ident_too_long);
5768 Perl_croak(aTHX_ ident_too_long);
5769 if (isALNUM(*s)) /* UTF handled below */
5771 else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
5776 else if (*s == ':' && s[1] == ':') {
5780 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5781 char *t = s + UTF8SKIP(s);
5782 while (*t & 0x80 && is_utf8_mark((U8*)t))
5784 if (d + (t - s) > e)
5785 Perl_croak(aTHX_ ident_too_long);
5786 Copy(s, d, t - s, char);
5797 if (PL_lex_state != LEX_NORMAL)
5798 PL_lex_state = LEX_INTERPENDMAYBE;
5801 if (*s == '$' && s[1] &&
5802 (isALNUM_lazy_if(s+1,UTF) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
5815 if (*d == '^' && *s && isCONTROLVAR(*s)) {
5820 if (isSPACE(s[-1])) {
5823 if (ch != ' ' && ch != '\t') {
5829 if (isIDFIRST_lazy_if(d,UTF)) {
5833 while (e < send && isALNUM_lazy_if(e,UTF) || *e == ':') {
5835 while (e < send && *e & 0x80 && is_utf8_mark((U8*)e))
5838 Copy(s, d, e - s, char);
5843 while ((isALNUM(*s) || *s == ':') && d < e)
5846 Perl_croak(aTHX_ ident_too_long);
5849 while (s < send && (*s == ' ' || *s == '\t')) s++;
5850 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
5851 dTHR; /* only for ckWARN */
5852 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
5853 const char *brack = *s == '[' ? "[...]" : "{...}";
5854 Perl_warner(aTHX_ WARN_AMBIGUOUS,
5855 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
5856 funny, dest, brack, funny, dest, brack);
5859 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
5863 /* Handle extended ${^Foo} variables
5864 * 1999-02-27 mjd-perl-patch@plover.com */
5865 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
5869 while (isALNUM(*s) && d < e) {
5873 Perl_croak(aTHX_ ident_too_long);
5878 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
5879 PL_lex_state = LEX_INTERPEND;
5882 if (PL_lex_state == LEX_NORMAL) {
5883 dTHR; /* only for ckWARN */
5884 if (ckWARN(WARN_AMBIGUOUS) &&
5885 (keyword(dest, d - dest) || get_cv(dest, FALSE)))
5887 Perl_warner(aTHX_ WARN_AMBIGUOUS,
5888 "Ambiguous use of %c{%s} resolved to %c%s",
5889 funny, dest, funny, dest);
5894 s = bracket; /* let the parser handle it */
5898 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
5899 PL_lex_state = LEX_INTERPEND;
5904 Perl_pmflag(pTHX_ U16 *pmfl, int ch)
5909 *pmfl |= PMf_GLOBAL;
5911 *pmfl |= PMf_CONTINUE;
5915 *pmfl |= PMf_MULTILINE;
5917 *pmfl |= PMf_SINGLELINE;
5919 *pmfl |= PMf_EXTENDED;
5923 S_scan_pat(pTHX_ char *start, I32 type)
5928 s = scan_str(start,FALSE,FALSE);
5931 SvREFCNT_dec(PL_lex_stuff);
5932 PL_lex_stuff = Nullsv;
5933 Perl_croak(aTHX_ "Search pattern not terminated");
5936 pm = (PMOP*)newPMOP(type, 0);
5937 if (PL_multi_open == '?')
5938 pm->op_pmflags |= PMf_ONCE;
5940 while (*s && strchr("iomsx", *s))
5941 pmflag(&pm->op_pmflags,*s++);
5944 while (*s && strchr("iogcmsx", *s))
5945 pmflag(&pm->op_pmflags,*s++);
5947 pm->op_pmpermflags = pm->op_pmflags;
5949 PL_lex_op = (OP*)pm;
5950 yylval.ival = OP_MATCH;
5955 S_scan_subst(pTHX_ char *start)
5962 yylval.ival = OP_NULL;
5964 s = scan_str(start,FALSE,FALSE);
5968 SvREFCNT_dec(PL_lex_stuff);
5969 PL_lex_stuff = Nullsv;
5970 Perl_croak(aTHX_ "Substitution pattern not terminated");
5973 if (s[-1] == PL_multi_open)
5976 first_start = PL_multi_start;
5977 s = scan_str(s,FALSE,FALSE);
5980 SvREFCNT_dec(PL_lex_stuff);
5981 PL_lex_stuff = Nullsv;
5983 SvREFCNT_dec(PL_lex_repl);
5984 PL_lex_repl = Nullsv;
5985 Perl_croak(aTHX_ "Substitution replacement not terminated");
5987 PL_multi_start = first_start; /* so whole substitution is taken together */
5989 pm = (PMOP*)newPMOP(OP_SUBST, 0);
5995 else if (strchr("iogcmsx", *s))
5996 pmflag(&pm->op_pmflags,*s++);
6003 PL_sublex_info.super_bufptr = s;
6004 PL_sublex_info.super_bufend = PL_bufend;
6006 pm->op_pmflags |= PMf_EVAL;
6007 repl = newSVpvn("",0);
6009 sv_catpv(repl, es ? "eval " : "do ");
6010 sv_catpvn(repl, "{ ", 2);
6011 sv_catsv(repl, PL_lex_repl);
6012 sv_catpvn(repl, " };", 2);
6014 SvREFCNT_dec(PL_lex_repl);
6018 pm->op_pmpermflags = pm->op_pmflags;
6019 PL_lex_op = (OP*)pm;
6020 yylval.ival = OP_SUBST;
6025 S_scan_trans(pTHX_ char *start)
6036 yylval.ival = OP_NULL;
6038 s = scan_str(start,FALSE,FALSE);
6041 SvREFCNT_dec(PL_lex_stuff);
6042 PL_lex_stuff = Nullsv;
6043 Perl_croak(aTHX_ "Transliteration pattern not terminated");
6045 if (s[-1] == PL_multi_open)
6048 s = scan_str(s,FALSE,FALSE);
6051 SvREFCNT_dec(PL_lex_stuff);
6052 PL_lex_stuff = Nullsv;
6054 SvREFCNT_dec(PL_lex_repl);
6055 PL_lex_repl = Nullsv;
6056 Perl_croak(aTHX_ "Transliteration replacement not terminated");
6060 o = newSVOP(OP_TRANS, 0, 0);
6061 utf8 = OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF;
6064 New(803,tbl,256,short);
6065 o = newPVOP(OP_TRANS, 0, (char*)tbl);
6069 complement = del = squash = 0;
6070 while (strchr("cdsCU", *s)) {
6072 complement = OPpTRANS_COMPLEMENT;
6074 del = OPpTRANS_DELETE;
6076 squash = OPpTRANS_SQUASH;
6081 utf8 &= ~OPpTRANS_FROM_UTF;
6083 utf8 |= OPpTRANS_FROM_UTF;
6087 utf8 &= ~OPpTRANS_TO_UTF;
6089 utf8 |= OPpTRANS_TO_UTF;
6092 Perl_croak(aTHX_ "Too many /C and /U options");
6097 o->op_private = del|squash|complement|utf8;
6100 yylval.ival = OP_TRANS;
6105 S_scan_heredoc(pTHX_ register char *s)
6109 I32 op_type = OP_SCALAR;
6116 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
6120 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
6123 for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
6124 if (*peek && strchr("`'\"",*peek)) {
6127 s = delimcpy(d, e, s, PL_bufend, term, &len);
6137 if (!isALNUM_lazy_if(s,UTF))
6138 deprecate("bare << to mean <<\"\"");
6139 for (; isALNUM_lazy_if(s,UTF); s++) {
6144 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
6145 Perl_croak(aTHX_ "Delimiter for here document is too long");
6148 len = d - PL_tokenbuf;
6149 #ifndef PERL_STRICT_CR
6150 d = strchr(s, '\r');
6154 while (s < PL_bufend) {
6160 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
6169 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6174 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
6175 herewas = newSVpvn(s,PL_bufend-s);
6177 s--, herewas = newSVpvn(s,d-s);
6178 s += SvCUR(herewas);
6180 tmpstr = NEWSV(87,79);
6181 sv_upgrade(tmpstr, SVt_PVIV);
6186 else if (term == '`') {
6187 op_type = OP_BACKTICK;
6188 SvIVX(tmpstr) = '\\';
6192 PL_multi_start = CopLINE(PL_curcop);
6193 PL_multi_open = PL_multi_close = '<';
6194 term = *PL_tokenbuf;
6195 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
6196 char *bufptr = PL_sublex_info.super_bufptr;
6197 char *bufend = PL_sublex_info.super_bufend;
6198 char *olds = s - SvCUR(herewas);
6199 s = strchr(bufptr, '\n');
6203 while (s < bufend &&
6204 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6206 CopLINE_inc(PL_curcop);
6209 CopLINE_set(PL_curcop, PL_multi_start);
6210 missingterm(PL_tokenbuf);
6212 sv_setpvn(herewas,bufptr,d-bufptr+1);
6213 sv_setpvn(tmpstr,d+1,s-d);
6215 sv_catpvn(herewas,s,bufend-s);
6216 (void)strcpy(bufptr,SvPVX(herewas));
6223 while (s < PL_bufend &&
6224 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6226 CopLINE_inc(PL_curcop);
6228 if (s >= PL_bufend) {
6229 CopLINE_set(PL_curcop, PL_multi_start);
6230 missingterm(PL_tokenbuf);
6232 sv_setpvn(tmpstr,d+1,s-d);
6234 CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
6236 sv_catpvn(herewas,s,PL_bufend-s);
6237 sv_setsv(PL_linestr,herewas);
6238 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
6239 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6242 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
6243 while (s >= PL_bufend) { /* multiple line string? */
6245 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6246 CopLINE_set(PL_curcop, PL_multi_start);
6247 missingterm(PL_tokenbuf);
6249 CopLINE_inc(PL_curcop);
6250 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6251 #ifndef PERL_STRICT_CR
6252 if (PL_bufend - PL_linestart >= 2) {
6253 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
6254 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
6256 PL_bufend[-2] = '\n';
6258 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6260 else if (PL_bufend[-1] == '\r')
6261 PL_bufend[-1] = '\n';
6263 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
6264 PL_bufend[-1] = '\n';
6266 if (PERLDB_LINE && PL_curstash != PL_debstash) {
6267 SV *sv = NEWSV(88,0);
6269 sv_upgrade(sv, SVt_PVMG);
6270 sv_setsv(sv,PL_linestr);
6271 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop),sv);
6273 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
6276 sv_catsv(PL_linestr,herewas);
6277 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6281 sv_catsv(tmpstr,PL_linestr);
6286 PL_multi_end = CopLINE(PL_curcop);
6287 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
6288 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
6289 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
6291 SvREFCNT_dec(herewas);
6292 PL_lex_stuff = tmpstr;
6293 yylval.ival = op_type;
6298 takes: current position in input buffer
6299 returns: new position in input buffer
6300 side-effects: yylval and lex_op are set.
6305 <FH> read from filehandle
6306 <pkg::FH> read from package qualified filehandle
6307 <pkg'FH> read from package qualified filehandle
6308 <$fh> read from filehandle in $fh
6314 S_scan_inputsymbol(pTHX_ char *start)
6316 register char *s = start; /* current position in buffer */
6322 d = PL_tokenbuf; /* start of temp holding space */
6323 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
6324 end = strchr(s, '\n');
6327 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
6329 /* die if we didn't have space for the contents of the <>,
6330 or if it didn't end, or if we see a newline
6333 if (len >= sizeof PL_tokenbuf)
6334 Perl_croak(aTHX_ "Excessively long <> operator");
6336 Perl_croak(aTHX_ "Unterminated <> operator");
6341 Remember, only scalar variables are interpreted as filehandles by
6342 this code. Anything more complex (e.g., <$fh{$num}>) will be
6343 treated as a glob() call.
6344 This code makes use of the fact that except for the $ at the front,
6345 a scalar variable and a filehandle look the same.
6347 if (*d == '$' && d[1]) d++;
6349 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
6350 while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
6353 /* If we've tried to read what we allow filehandles to look like, and
6354 there's still text left, then it must be a glob() and not a getline.
6355 Use scan_str to pull out the stuff between the <> and treat it
6356 as nothing more than a string.
6359 if (d - PL_tokenbuf != len) {
6360 yylval.ival = OP_GLOB;
6362 s = scan_str(start,FALSE,FALSE);
6364 Perl_croak(aTHX_ "Glob not terminated");
6368 /* we're in a filehandle read situation */
6371 /* turn <> into <ARGV> */
6373 (void)strcpy(d,"ARGV");
6375 /* if <$fh>, create the ops to turn the variable into a
6381 /* try to find it in the pad for this block, otherwise find
6382 add symbol table ops
6384 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
6385 OP *o = newOP(OP_PADSV, 0);
6387 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, o);
6390 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
6391 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
6392 newUNOP(OP_RV2SV, 0,
6393 newGVOP(OP_GV, 0, gv)));
6395 PL_lex_op->op_flags |= OPf_SPECIAL;
6396 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
6397 yylval.ival = OP_NULL;
6400 /* If it's none of the above, it must be a literal filehandle
6401 (<Foo::BAR> or <FOO>) so build a simple readline OP */
6403 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
6404 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
6405 yylval.ival = OP_NULL;
6414 takes: start position in buffer
6415 keep_quoted preserve \ on the embedded delimiter(s)
6416 keep_delims preserve the delimiters around the string
6417 returns: position to continue reading from buffer
6418 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
6419 updates the read buffer.
6421 This subroutine pulls a string out of the input. It is called for:
6422 q single quotes q(literal text)
6423 ' single quotes 'literal text'
6424 qq double quotes qq(interpolate $here please)
6425 " double quotes "interpolate $here please"
6426 qx backticks qx(/bin/ls -l)
6427 ` backticks `/bin/ls -l`
6428 qw quote words @EXPORT_OK = qw( func() $spam )
6429 m// regexp match m/this/
6430 s/// regexp substitute s/this/that/
6431 tr/// string transliterate tr/this/that/
6432 y/// string transliterate y/this/that/
6433 ($*@) sub prototypes sub foo ($)
6434 (stuff) sub attr parameters sub foo : attr(stuff)
6435 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
6437 In most of these cases (all but <>, patterns and transliterate)
6438 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
6439 calls scan_str(). s/// makes yylex() call scan_subst() which calls
6440 scan_str(). tr/// and y/// make yylex() call scan_trans() which
6443 It skips whitespace before the string starts, and treats the first
6444 character as the delimiter. If the delimiter is one of ([{< then
6445 the corresponding "close" character )]}> is used as the closing
6446 delimiter. It allows quoting of delimiters, and if the string has
6447 balanced delimiters ([{<>}]) it allows nesting.
6449 The lexer always reads these strings into lex_stuff, except in the
6450 case of the operators which take *two* arguments (s/// and tr///)
6451 when it checks to see if lex_stuff is full (presumably with the 1st
6452 arg to s or tr) and if so puts the string into lex_repl.
6457 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
6460 SV *sv; /* scalar value: string */
6461 char *tmps; /* temp string, used for delimiter matching */
6462 register char *s = start; /* current position in the buffer */
6463 register char term; /* terminating character */
6464 register char *to; /* current position in the sv's data */
6465 I32 brackets = 1; /* bracket nesting level */
6466 bool has_utf = FALSE; /* is there any utf8 content? */
6468 /* skip space before the delimiter */
6472 /* mark where we are, in case we need to report errors */
6475 /* after skipping whitespace, the next character is the terminator */
6477 if ((term & 0x80) && UTF)
6480 /* mark where we are */
6481 PL_multi_start = CopLINE(PL_curcop);
6482 PL_multi_open = term;
6484 /* find corresponding closing delimiter */
6485 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
6487 PL_multi_close = term;
6489 /* create a new SV to hold the contents. 87 is leak category, I'm
6490 assuming. 79 is the SV's initial length. What a random number. */
6492 sv_upgrade(sv, SVt_PVIV);
6494 (void)SvPOK_only(sv); /* validate pointer */
6496 /* move past delimiter and try to read a complete string */
6498 sv_catpvn(sv, s, 1);
6501 /* extend sv if need be */
6502 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
6503 /* set 'to' to the next character in the sv's string */
6504 to = SvPVX(sv)+SvCUR(sv);
6506 /* if open delimiter is the close delimiter read unbridle */
6507 if (PL_multi_open == PL_multi_close) {
6508 for (; s < PL_bufend; s++,to++) {
6509 /* embedded newlines increment the current line number */
6510 if (*s == '\n' && !PL_rsfp)
6511 CopLINE_inc(PL_curcop);
6512 /* handle quoted delimiters */
6513 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
6514 if (!keep_quoted && s[1] == term)
6516 /* any other quotes are simply copied straight through */
6520 /* terminate when run out of buffer (the for() condition), or
6521 have found the terminator */
6522 else if (*s == term)
6524 else if (!has_utf && (*s & 0x80) && UTF)
6530 /* if the terminator isn't the same as the start character (e.g.,
6531 matched brackets), we have to allow more in the quoting, and
6532 be prepared for nested brackets.
6535 /* read until we run out of string, or we find the terminator */
6536 for (; s < PL_bufend; s++,to++) {
6537 /* embedded newlines increment the line count */
6538 if (*s == '\n' && !PL_rsfp)
6539 CopLINE_inc(PL_curcop);
6540 /* backslashes can escape the open or closing characters */
6541 if (*s == '\\' && s+1 < PL_bufend) {
6543 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
6548 /* allow nested opens and closes */
6549 else if (*s == PL_multi_close && --brackets <= 0)
6551 else if (*s == PL_multi_open)
6553 else if (!has_utf && (*s & 0x80) && UTF)
6558 /* terminate the copied string and update the sv's end-of-string */
6560 SvCUR_set(sv, to - SvPVX(sv));
6563 * this next chunk reads more into the buffer if we're not done yet
6567 break; /* handle case where we are done yet :-) */
6569 #ifndef PERL_STRICT_CR
6570 if (to - SvPVX(sv) >= 2) {
6571 if ((to[-2] == '\r' && to[-1] == '\n') ||
6572 (to[-2] == '\n' && to[-1] == '\r'))
6576 SvCUR_set(sv, to - SvPVX(sv));
6578 else if (to[-1] == '\r')
6581 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
6585 /* if we're out of file, or a read fails, bail and reset the current
6586 line marker so we can report where the unterminated string began
6589 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6591 CopLINE_set(PL_curcop, PL_multi_start);
6594 /* we read a line, so increment our line counter */
6595 CopLINE_inc(PL_curcop);
6597 /* update debugger info */
6598 if (PERLDB_LINE && PL_curstash != PL_debstash) {
6599 SV *sv = NEWSV(88,0);
6601 sv_upgrade(sv, SVt_PVMG);
6602 sv_setsv(sv,PL_linestr);
6603 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop), sv);
6606 /* having changed the buffer, we must update PL_bufend */
6607 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6610 /* at this point, we have successfully read the delimited string */
6613 sv_catpvn(sv, s, 1);
6616 PL_multi_end = CopLINE(PL_curcop);
6619 /* if we allocated too much space, give some back */
6620 if (SvCUR(sv) + 5 < SvLEN(sv)) {
6621 SvLEN_set(sv, SvCUR(sv) + 1);
6622 Renew(SvPVX(sv), SvLEN(sv), char);
6625 /* decide whether this is the first or second quoted string we've read
6638 takes: pointer to position in buffer
6639 returns: pointer to new position in buffer
6640 side-effects: builds ops for the constant in yylval.op
6642 Read a number in any of the formats that Perl accepts:
6644 0(x[0-7A-F]+)|([0-7]+)|(b[01])
6645 [\d_]+(\.[\d_]*)?[Ee](\d+)
6647 Underbars (_) are allowed in decimal numbers. If -w is on,
6648 underbars before a decimal point must be at three digit intervals.
6650 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
6653 If it reads a number without a decimal point or an exponent, it will
6654 try converting the number to an integer and see if it can do so
6655 without loss of precision.
6659 Perl_scan_num(pTHX_ char *start)
6661 register char *s = start; /* current position in buffer */
6662 register char *d; /* destination in temp buffer */
6663 register char *e; /* end of temp buffer */
6664 IV tryiv; /* used to see if it can be an IV */
6665 NV value; /* number read, as a double */
6666 SV *sv = Nullsv; /* place to put the converted number */
6667 bool floatit; /* boolean: int or float? */
6668 char *lastub = 0; /* position of last underbar */
6669 static char number_too_long[] = "Number too long";
6671 /* We use the first character to decide what type of number this is */
6675 Perl_croak(aTHX_ "panic: scan_num");
6677 /* if it starts with a 0, it could be an octal number, a decimal in
6678 0.13 disguise, or a hexadecimal number, or a binary number. */
6682 u holds the "number so far"
6683 shift the power of 2 of the base
6684 (hex == 4, octal == 3, binary == 1)
6685 overflowed was the number more than we can hold?
6687 Shift is used when we add a digit. It also serves as an "are
6688 we in octal/hex/binary?" indicator to disallow hex characters
6695 bool overflowed = FALSE;
6696 static NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
6697 static char* bases[5] = { "", "binary", "", "octal",
6699 static char* Bases[5] = { "", "Binary", "", "Octal",
6701 static char *maxima[5] = { "",
6702 "0b11111111111111111111111111111111",
6706 char *base, *Base, *max;
6712 } else if (s[1] == 'b') {
6716 /* check for a decimal in disguise */
6717 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
6719 /* so it must be octal */
6723 base = bases[shift];
6724 Base = Bases[shift];
6725 max = maxima[shift];
6727 /* read the rest of the number */
6729 /* x is used in the overflow test,
6730 b is the digit we're adding on. */
6735 /* if we don't mention it, we're done */
6744 /* 8 and 9 are not octal */
6747 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
6751 case '2': case '3': case '4':
6752 case '5': case '6': case '7':
6754 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
6758 b = *s++ & 15; /* ASCII digit -> value of digit */
6762 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
6763 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
6764 /* make sure they said 0x */
6769 /* Prepare to put the digit we have onto the end
6770 of the number so far. We check for overflows.
6775 x = u << shift; /* make room for the digit */
6777 if ((x >> shift) != u
6778 && !(PL_hints & HINT_NEW_BINARY)) {
6782 if (ckWARN_d(WARN_OVERFLOW))
6783 Perl_warner(aTHX_ WARN_OVERFLOW,
6784 "Integer overflow in %s number",
6787 u = x | b; /* add the digit to the end */
6790 n *= nvshift[shift];
6791 /* If an NV has not enough bits in its
6792 * mantissa to represent an UV this summing of
6793 * small low-order numbers is a waste of time
6794 * (because the NV cannot preserve the
6795 * low-order bits anyway): we could just
6796 * remember when did we overflow and in the
6797 * end just multiply n by the right
6805 /* if we get here, we had success: make a scalar value from
6812 if (ckWARN(WARN_PORTABLE) && n > 4294967295.0)
6813 Perl_warner(aTHX_ WARN_PORTABLE,
6814 "%s number > %s non-portable",
6821 if (ckWARN(WARN_PORTABLE) && u > 0xffffffff)
6822 Perl_warner(aTHX_ WARN_PORTABLE,
6823 "%s number > %s non-portable",
6828 if (PL_hints & HINT_NEW_BINARY)
6829 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
6834 handle decimal numbers.
6835 we're also sent here when we read a 0 as the first digit
6837 case '1': case '2': case '3': case '4': case '5':
6838 case '6': case '7': case '8': case '9': case '.':
6841 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
6844 /* read next group of digits and _ and copy into d */
6845 while (isDIGIT(*s) || *s == '_') {
6846 /* skip underscores, checking for misplaced ones
6850 dTHR; /* only for ckWARN */
6851 if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
6852 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
6856 /* check for end of fixed-length buffer */
6858 Perl_croak(aTHX_ number_too_long);
6859 /* if we're ok, copy the character */
6864 /* final misplaced underbar check */
6865 if (lastub && s - lastub != 3) {
6867 if (ckWARN(WARN_SYNTAX))
6868 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
6871 /* read a decimal portion if there is one. avoid
6872 3..5 being interpreted as the number 3. followed
6875 if (*s == '.' && s[1] != '.') {
6879 /* copy, ignoring underbars, until we run out of
6880 digits. Note: no misplaced underbar checks!
6882 for (; isDIGIT(*s) || *s == '_'; s++) {
6883 /* fixed length buffer check */
6885 Perl_croak(aTHX_ number_too_long);
6891 /* read exponent part, if present */
6892 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
6896 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
6897 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
6899 /* allow positive or negative exponent */
6900 if (*s == '+' || *s == '-')
6903 /* read digits of exponent (no underbars :-) */
6904 while (isDIGIT(*s)) {
6906 Perl_croak(aTHX_ number_too_long);
6911 /* terminate the string */
6914 /* make an sv from the string */
6917 value = Atof(PL_tokenbuf);
6920 See if we can make do with an integer value without loss of
6921 precision. We use I_V to cast to an int, because some
6922 compilers have issues. Then we try casting it back and see
6923 if it was the same. We only do this if we know we
6924 specifically read an integer.
6926 Note: if floatit is true, then we don't need to do the
6930 if (!floatit && (NV)tryiv == value)
6931 sv_setiv(sv, tryiv);
6933 sv_setnv(sv, value);
6934 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
6935 (PL_hints & HINT_NEW_INTEGER) )
6936 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
6937 (floatit ? "float" : "integer"),
6940 /* if it starts with a v, it could be a version number */
6945 while (isDIGIT(*pos))
6947 if (!isALPHA(*pos)) {
6949 U8 tmpbuf[UTF8_MAXLEN];
6952 s++; /* get past 'v' */
6955 sv_setpvn(sv, "", 0);
6958 if (*s == '0' && isDIGIT(s[1]))
6959 yyerror("Octal number in vector unsupported");
6961 tmpend = uv_to_utf8(tmpbuf, rev);
6962 utf8 = utf8 || rev > 127;
6963 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
6964 if (*pos == '.' && isDIGIT(pos[1]))
6970 while (isDIGIT(*pos))
6978 sv_utf8_downgrade(sv, TRUE);
6985 /* make the op for the constant and return */
6988 yylval.opval = newSVOP(OP_CONST, 0, sv);
6990 yylval.opval = Nullop;
6996 S_scan_formline(pTHX_ register char *s)
7001 SV *stuff = newSVpvn("",0);
7002 bool needargs = FALSE;
7005 if (*s == '.' || *s == '}') {
7007 #ifdef PERL_STRICT_CR
7008 for (t = s+1;*t == ' ' || *t == '\t'; t++) ;
7010 for (t = s+1;*t == ' ' || *t == '\t' || *t == '\r'; t++) ;
7012 if (*t == '\n' || t == PL_bufend)
7015 if (PL_in_eval && !PL_rsfp) {
7016 eol = strchr(s,'\n');
7021 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7023 for (t = s; t < eol; t++) {
7024 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
7026 goto enough; /* ~~ must be first line in formline */
7028 if (*t == '@' || *t == '^')
7031 sv_catpvn(stuff, s, eol-s);
7032 #ifndef PERL_STRICT_CR
7033 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
7034 char *end = SvPVX(stuff) + SvCUR(stuff);
7043 s = filter_gets(PL_linestr, PL_rsfp, 0);
7044 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
7045 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
7048 yyerror("Format not terminated");
7058 PL_lex_state = LEX_NORMAL;
7059 PL_nextval[PL_nexttoke].ival = 0;
7063 PL_lex_state = LEX_FORMLINE;
7064 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
7066 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
7070 SvREFCNT_dec(stuff);
7071 PL_lex_formbrack = 0;
7082 PL_cshlen = strlen(PL_cshname);
7087 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
7090 I32 oldsavestack_ix = PL_savestack_ix;
7091 CV* outsidecv = PL_compcv;
7095 assert(SvTYPE(PL_compcv) == SVt_PVCV);
7097 SAVEI32(PL_subline);
7098 save_item(PL_subname);
7101 SAVESPTR(PL_comppad_name);
7102 SAVESPTR(PL_compcv);
7103 SAVEI32(PL_comppad_name_fill);
7104 SAVEI32(PL_min_intro_pending);
7105 SAVEI32(PL_max_intro_pending);
7106 SAVEI32(PL_pad_reset_pending);
7108 PL_compcv = (CV*)NEWSV(1104,0);
7109 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
7110 CvFLAGS(PL_compcv) |= flags;
7112 PL_comppad = newAV();
7113 av_push(PL_comppad, Nullsv);
7114 PL_curpad = AvARRAY(PL_comppad);
7115 PL_comppad_name = newAV();
7116 PL_comppad_name_fill = 0;
7117 PL_min_intro_pending = 0;
7119 PL_subline = CopLINE(PL_curcop);
7121 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
7122 PL_curpad[0] = (SV*)newAV();
7123 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
7124 #endif /* USE_THREADS */
7126 comppadlist = newAV();
7127 AvREAL_off(comppadlist);
7128 av_store(comppadlist, 0, (SV*)PL_comppad_name);
7129 av_store(comppadlist, 1, (SV*)PL_comppad);
7131 CvPADLIST(PL_compcv) = comppadlist;
7132 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
7134 CvOWNER(PL_compcv) = 0;
7135 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
7136 MUTEX_INIT(CvMUTEXP(PL_compcv));
7137 #endif /* USE_THREADS */
7139 return oldsavestack_ix;
7143 Perl_yywarn(pTHX_ char *s)
7146 PL_in_eval |= EVAL_WARNONLY;
7148 PL_in_eval &= ~EVAL_WARNONLY;
7153 Perl_yyerror(pTHX_ char *s)
7157 char *context = NULL;
7161 if (!yychar || (yychar == ';' && !PL_rsfp))
7163 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
7164 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
7165 while (isSPACE(*PL_oldoldbufptr))
7167 context = PL_oldoldbufptr;
7168 contlen = PL_bufptr - PL_oldoldbufptr;
7170 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
7171 PL_oldbufptr != PL_bufptr) {
7172 while (isSPACE(*PL_oldbufptr))
7174 context = PL_oldbufptr;
7175 contlen = PL_bufptr - PL_oldbufptr;
7177 else if (yychar > 255)
7178 where = "next token ???";
7179 #ifdef USE_PURE_BISON
7180 /* GNU Bison sets the value -2 */
7181 else if (yychar == -2) {
7183 else if ((yychar & 127) == 127) {
7185 if (PL_lex_state == LEX_NORMAL ||
7186 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
7187 where = "at end of line";
7188 else if (PL_lex_inpat)
7189 where = "within pattern";
7191 where = "within string";
7194 SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
7196 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
7197 else if (isPRINT_LC(yychar))
7198 Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
7200 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
7201 where = SvPVX(where_sv);
7203 msg = sv_2mortal(newSVpv(s, 0));
7204 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
7205 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
7207 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
7209 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
7210 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
7211 Perl_sv_catpvf(aTHX_ msg,
7212 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
7213 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
7216 if (PL_in_eval & EVAL_WARNONLY)
7217 Perl_warn(aTHX_ "%"SVf, msg);
7220 if (PL_error_count >= 10)
7221 Perl_croak(aTHX_ "%s has too many errors.\n", CopFILE(PL_curcop));
7223 PL_in_my_stash = Nullhv;
7234 * Restore a source filter.
7238 restore_rsfp(pTHXo_ void *f)
7240 PerlIO *fp = (PerlIO*)f;
7242 if (PL_rsfp == PerlIO_stdin())
7243 PerlIO_clearerr(PL_rsfp);
7244 else if (PL_rsfp && (PL_rsfp != fp))
7245 PerlIO_close(PL_rsfp);