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)
324 S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
326 I32 count = FILTER_READ(idx+1, sv, maxlen);
330 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
331 tend = utf16_to_utf8((U16*)SvPVX(sv), tmps, SvCUR(sv));
332 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 :
816 Perl_str_to_version(pTHX_ SV *sv)
821 char *start = SvPVx(sv,len);
822 bool utf = SvUTF8(sv);
823 char *end = start + len;
824 while (start < end) {
828 n = utf8_to_uv((U8*)start, &skip);
833 retval += ((NV)n)/nshift;
842 * Forces the next token to be a version number.
846 S_force_version(pTHX_ char *s)
848 OP *version = Nullop;
857 for (; isDIGIT(*d) || *d == '_' || *d == '.'; d++);
858 if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
861 version = yylval.opval;
862 ver = cSVOPx(version)->op_sv;
863 if (SvPOK(ver) && !SvNIOK(ver)) {
864 (void)SvUPGRADE(ver, SVt_PVNV);
865 SvNVX(ver) = str_to_version(ver);
866 SvNOK_on(ver); /* hint that it is a version */
871 /* NOTE: The parser sees the package name and the VERSION swapped */
872 PL_nextval[PL_nexttoke].opval = version;
880 * Tokenize a quoted string passed in as an SV. It finds the next
881 * chunk, up to end of string or a backslash. It may make a new
882 * SV containing that chunk (if HINT_NEW_STRING is on). It also
887 S_tokeq(pTHX_ SV *sv)
898 s = SvPV_force(sv, len);
899 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
902 while (s < send && *s != '\\')
907 if ( PL_hints & HINT_NEW_STRING )
908 pv = sv_2mortal(newSVpvn(SvPVX(pv), len));
911 if (s + 1 < send && (s[1] == '\\'))
912 s++; /* all that, just for this */
917 SvCUR_set(sv, d - SvPVX(sv));
919 if ( PL_hints & HINT_NEW_STRING )
920 return new_constant(NULL, 0, "q", sv, pv, "q");
925 * Now come three functions related to double-quote context,
926 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
927 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
928 * interact with PL_lex_state, and create fake ( ... ) argument lists
929 * to handle functions and concatenation.
930 * They assume that whoever calls them will be setting up a fake
931 * join call, because each subthing puts a ',' after it. This lets
934 * join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
936 * (I'm not sure whether the spurious commas at the end of lcfirst's
937 * arguments and join's arguments are created or not).
942 * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST).
944 * Pattern matching will set PL_lex_op to the pattern-matching op to
945 * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise).
947 * OP_CONST and OP_READLINE are easy--just make the new op and return.
949 * Everything else becomes a FUNC.
951 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
952 * had an OP_CONST or OP_READLINE). This just sets us up for a
953 * call to S_sublex_push().
959 register I32 op_type = yylval.ival;
961 if (op_type == OP_NULL) {
962 yylval.opval = PL_lex_op;
966 if (op_type == OP_CONST || op_type == OP_READLINE) {
967 SV *sv = tokeq(PL_lex_stuff);
969 if (SvTYPE(sv) == SVt_PVIV) {
970 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
976 nsv = newSVpvn(p, len);
980 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
981 PL_lex_stuff = Nullsv;
985 PL_sublex_info.super_state = PL_lex_state;
986 PL_sublex_info.sub_inwhat = op_type;
987 PL_sublex_info.sub_op = PL_lex_op;
988 PL_lex_state = LEX_INTERPPUSH;
992 yylval.opval = PL_lex_op;
1002 * Create a new scope to save the lexing state. The scope will be
1003 * ended in S_sublex_done. Returns a '(', starting the function arguments
1004 * to the uc, lc, etc. found before.
1005 * Sets PL_lex_state to LEX_INTERPCONCAT.
1014 PL_lex_state = PL_sublex_info.super_state;
1015 SAVEI32(PL_lex_dojoin);
1016 SAVEI32(PL_lex_brackets);
1017 SAVEI32(PL_lex_casemods);
1018 SAVEI32(PL_lex_starts);
1019 SAVEI32(PL_lex_state);
1020 SAVEVPTR(PL_lex_inpat);
1021 SAVEI32(PL_lex_inwhat);
1022 SAVECOPLINE(PL_curcop);
1023 SAVEPPTR(PL_bufptr);
1024 SAVEPPTR(PL_oldbufptr);
1025 SAVEPPTR(PL_oldoldbufptr);
1026 SAVEPPTR(PL_linestart);
1027 SAVESPTR(PL_linestr);
1028 SAVEPPTR(PL_lex_brackstack);
1029 SAVEPPTR(PL_lex_casestack);
1031 PL_linestr = PL_lex_stuff;
1032 PL_lex_stuff = Nullsv;
1034 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
1035 = SvPVX(PL_linestr);
1036 PL_bufend += SvCUR(PL_linestr);
1037 SAVEFREESV(PL_linestr);
1039 PL_lex_dojoin = FALSE;
1040 PL_lex_brackets = 0;
1041 New(899, PL_lex_brackstack, 120, char);
1042 New(899, PL_lex_casestack, 12, char);
1043 SAVEFREEPV(PL_lex_brackstack);
1044 SAVEFREEPV(PL_lex_casestack);
1045 PL_lex_casemods = 0;
1046 *PL_lex_casestack = '\0';
1048 PL_lex_state = LEX_INTERPCONCAT;
1049 CopLINE_set(PL_curcop, PL_multi_start);
1051 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1052 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1053 PL_lex_inpat = PL_sublex_info.sub_op;
1055 PL_lex_inpat = Nullop;
1062 * Restores lexer state after a S_sublex_push.
1068 if (!PL_lex_starts++) {
1069 PL_expect = XOPERATOR;
1070 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpvn("",0));
1074 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
1075 PL_lex_state = LEX_INTERPCASEMOD;
1079 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1080 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1081 PL_linestr = PL_lex_repl;
1083 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1084 PL_bufend += SvCUR(PL_linestr);
1085 SAVEFREESV(PL_linestr);
1086 PL_lex_dojoin = FALSE;
1087 PL_lex_brackets = 0;
1088 PL_lex_casemods = 0;
1089 *PL_lex_casestack = '\0';
1091 if (SvEVALED(PL_lex_repl)) {
1092 PL_lex_state = LEX_INTERPNORMAL;
1094 /* we don't clear PL_lex_repl here, so that we can check later
1095 whether this is an evalled subst; that means we rely on the
1096 logic to ensure sublex_done() is called again only via the
1097 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1100 PL_lex_state = LEX_INTERPCONCAT;
1101 PL_lex_repl = Nullsv;
1107 PL_bufend = SvPVX(PL_linestr);
1108 PL_bufend += SvCUR(PL_linestr);
1109 PL_expect = XOPERATOR;
1110 PL_sublex_info.sub_inwhat = 0;
1118 Extracts a pattern, double-quoted string, or transliteration. This
1121 It looks at lex_inwhat and PL_lex_inpat to find out whether it's
1122 processing a pattern (PL_lex_inpat is true), a transliteration
1123 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
1125 Returns a pointer to the character scanned up to. Iff this is
1126 advanced from the start pointer supplied (ie if anything was
1127 successfully parsed), will leave an OP for the substring scanned
1128 in yylval. Caller must intuit reason for not parsing further
1129 by looking at the next characters herself.
1133 double-quoted style: \r and \n
1134 regexp special ones: \D \s
1136 backrefs: \1 (deprecated in substitution replacements)
1137 case and quoting: \U \Q \E
1138 stops on @ and $, but not for $ as tail anchor
1140 In transliterations:
1141 characters are VERY literal, except for - not at the start or end
1142 of the string, which indicates a range. scan_const expands the
1143 range to the full set of intermediate characters.
1145 In double-quoted strings:
1147 double-quoted style: \r and \n
1149 backrefs: \1 (deprecated)
1150 case and quoting: \U \Q \E
1153 scan_const does *not* construct ops to handle interpolated strings.
1154 It stops processing as soon as it finds an embedded $ or @ variable
1155 and leaves it to the caller to work out what's going on.
1157 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
1159 $ in pattern could be $foo or could be tail anchor. Assumption:
1160 it's a tail anchor if $ is the last thing in the string, or if it's
1161 followed by one of ")| \n\t"
1163 \1 (backreferences) are turned into $1
1165 The structure of the code is
1166 while (there's a character to process) {
1167 handle transliteration ranges
1168 skip regexp comments
1169 skip # initiated comments in //x patterns
1170 check for embedded @foo
1171 check for embedded scalars
1173 leave intact backslashes from leave (below)
1174 deprecate \1 in strings and sub replacements
1175 handle string-changing backslashes \l \U \Q \E, etc.
1176 switch (what was escaped) {
1177 handle - in a transliteration (becomes a literal -)
1178 handle \132 octal characters
1179 handle 0x15 hex characters
1180 handle \cV (control V)
1181 handle printf backslashes (\f, \r, \n, etc)
1183 } (end if backslash)
1184 } (end while character to read)
1189 S_scan_const(pTHX_ char *start)
1191 register char *send = PL_bufend; /* end of the constant */
1192 SV *sv = NEWSV(93, send - start); /* sv for the constant */
1193 register char *s = start; /* start of the constant */
1194 register char *d = SvPVX(sv); /* destination for copies */
1195 bool dorange = FALSE; /* are we in a translit range? */
1196 bool has_utf = FALSE; /* embedded \x{} */
1200 I32 utf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op)
1201 ? (PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
1203 I32 thisutf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op)
1204 ? (PL_sublex_info.sub_op->op_private & (PL_lex_repl ?
1205 OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF))
1207 const char *leaveit = /* set of acceptably-backslashed characters */
1209 ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
1212 while (s < send || dorange) {
1213 /* get transliterations out of the way (they're most literal) */
1214 if (PL_lex_inwhat == OP_TRANS) {
1215 /* expand a range A-Z to the full set of characters. AIE! */
1217 I32 i; /* current expanded character */
1218 I32 min; /* first character in range */
1219 I32 max; /* last character in range */
1221 i = d - SvPVX(sv); /* remember current offset */
1222 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
1223 d = SvPVX(sv) + i; /* refresh d after realloc */
1224 d -= 2; /* eat the first char and the - */
1226 min = (U8)*d; /* first char in range */
1227 max = (U8)d[1]; /* last char in range */
1230 if ((isLOWER(min) && isLOWER(max)) ||
1231 (isUPPER(min) && isUPPER(max))) {
1233 for (i = min; i <= max; i++)
1237 for (i = min; i <= max; i++)
1244 for (i = min; i <= max; i++)
1247 /* mark the range as done, and continue */
1252 /* range begins (ignore - as first or last char) */
1253 else if (*s == '-' && s+1 < send && s != start) {
1255 *d++ = (char)0xff; /* use illegal utf8 byte--see pmtrans */
1264 /* if we get here, we're not doing a transliteration */
1266 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
1267 except for the last char, which will be done separately. */
1268 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
1270 while (s < send && *s != ')')
1273 else if (s[2] == '{' /* This should match regcomp.c */
1274 || ((s[2] == 'p' || s[2] == '?') && s[3] == '{'))
1277 char *regparse = s + (s[2] == '{' ? 3 : 4);
1280 while (count && (c = *regparse)) {
1281 if (c == '\\' && regparse[1])
1289 if (*regparse != ')') {
1290 regparse--; /* Leave one char for continuation. */
1291 yyerror("Sequence (?{...}) not terminated or not {}-balanced");
1293 while (s < regparse)
1298 /* likewise skip #-initiated comments in //x patterns */
1299 else if (*s == '#' && PL_lex_inpat &&
1300 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
1301 while (s+1 < send && *s != '\n')
1305 /* check for embedded arrays (@foo, @:foo, @'foo, @{foo}, @$foo) */
1306 else if (*s == '@' && s[1]
1307 && (isALNUM_lazy_if(s+1,UTF) || strchr(":'{$", s[1])))
1310 /* check for embedded scalars. only stop if we're sure it's a
1313 else if (*s == '$') {
1314 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
1316 if (s + 1 < send && !strchr("()| \n\t", s[1]))
1317 break; /* in regexp, $ might be tail anchor */
1320 /* (now in tr/// code again) */
1322 if (*s & 0x80 && thisutf) {
1323 (void)utf8_to_uv((U8*)s, &len);
1325 /* illegal UTF8, make it valid */
1326 char *old_pvx = SvPVX(sv);
1327 /* need space for one extra char (NOTE: SvCUR() not set here) */
1328 d = SvGROW(sv, SvLEN(sv) + 1) + (d - old_pvx);
1329 d = (char*)uv_to_utf8((U8*)d, (U8)*s++);
1340 if (*s == '\\' && s+1 < send) {
1343 /* some backslashes we leave behind */
1344 if (*leaveit && *s && strchr(leaveit, *s)) {
1350 /* deprecate \1 in strings and substitution replacements */
1351 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1352 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1354 dTHR; /* only for ckWARN */
1355 if (ckWARN(WARN_SYNTAX))
1356 Perl_warner(aTHX_ WARN_SYNTAX, "\\%c better written as $%c", *s, *s);
1361 /* string-change backslash escapes */
1362 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1367 /* if we get here, it's either a quoted -, or a digit */
1370 /* quoted - in transliterations */
1372 if (PL_lex_inwhat == OP_TRANS) {
1380 if (ckWARN(WARN_MISC) && isALNUM(*s))
1381 Perl_warner(aTHX_ WARN_MISC,
1382 "Unrecognized escape \\%c passed through",
1384 /* default action is to copy the quoted character */
1389 /* \132 indicates an octal constant */
1390 case '0': case '1': case '2': case '3':
1391 case '4': case '5': case '6': case '7':
1392 len = 0; /* disallow underscores */
1393 uv = (UV)scan_oct(s, 3, &len);
1395 goto NUM_ESCAPE_INSERT;
1397 /* \x24 indicates a hex constant */
1401 char* e = strchr(s, '}');
1403 yyerror("Missing right brace on \\x{}");
1406 len = 1; /* allow underscores */
1407 uv = (UV)scan_hex(s + 1, e - s - 1, &len);
1411 len = 0; /* disallow underscores */
1412 uv = (UV)scan_hex(s, 2, &len);
1417 /* Insert oct or hex escaped character.
1418 * There will always enough room in sv since such escapes will
1419 * be longer than any utf8 sequence they can end up as
1422 if (!thisutf && !has_utf && uv > 255) {
1423 /* might need to recode whatever we have accumulated so far
1424 * if it contains any hibit chars
1428 for (c = SvPVX(sv); c < d; c++) {
1433 char *old_pvx = SvPVX(sv);
1435 d = SvGROW(sv, SvCUR(sv) + hicount + 1) + (d - old_pvx);
1444 uv_to_utf8((U8*)dst, (U8)*src--);
1454 if (thisutf || uv > 255) {
1455 d = (char*)uv_to_utf8((U8*)d, uv);
1467 /* \N{latin small letter a} is a named character */
1471 char* e = strchr(s, '}');
1477 yyerror("Missing right brace on \\N{}");
1481 res = newSVpvn(s + 1, e - s - 1);
1482 res = new_constant( Nullch, 0, "charnames",
1483 res, Nullsv, "\\N{...}" );
1484 str = SvPV(res,len);
1485 if (!has_utf && SvUTF8(res)) {
1486 char *ostart = SvPVX(sv);
1487 SvCUR_set(sv, d - ostart);
1489 sv_utf8_upgrade(sv);
1490 d = SvPVX(sv) + SvCUR(sv);
1493 if (len > e - s + 4) {
1494 char *odest = SvPVX(sv);
1496 SvGROW(sv, (SvCUR(sv) + len - (e - s + 4)));
1497 d = SvPVX(sv) + (d - odest);
1499 Copy(str, d, len, char);
1506 yyerror("Missing braces on \\N{}");
1509 /* \c is a control character */
1524 /* printf-style backslashes, formfeeds, newlines, etc */
1542 *d++ = '\047'; /* CP 1047 */
1545 *d++ = '\057'; /* CP 1047 */
1559 } /* end if (backslash) */
1562 } /* while loop to process each character */
1564 /* terminate the string and set up the sv */
1566 SvCUR_set(sv, d - SvPVX(sv));
1571 /* shrink the sv if we allocated more than we used */
1572 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1573 SvLEN_set(sv, SvCUR(sv) + 1);
1574 Renew(SvPVX(sv), SvLEN(sv), char);
1577 /* return the substring (via yylval) only if we parsed anything */
1578 if (s > PL_bufptr) {
1579 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1580 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1582 ( PL_lex_inwhat == OP_TRANS
1584 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1587 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1594 * Returns TRUE if there's more to the expression (e.g., a subscript),
1597 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
1599 * ->[ and ->{ return TRUE
1600 * { and [ outside a pattern are always subscripts, so return TRUE
1601 * if we're outside a pattern and it's not { or [, then return FALSE
1602 * if we're in a pattern and the first char is a {
1603 * {4,5} (any digits around the comma) returns FALSE
1604 * if we're in a pattern and the first char is a [
1606 * [SOMETHING] has a funky algorithm to decide whether it's a
1607 * character class or not. It has to deal with things like
1608 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
1609 * anything else returns TRUE
1612 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1615 S_intuit_more(pTHX_ register char *s)
1617 if (PL_lex_brackets)
1619 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1621 if (*s != '{' && *s != '[')
1626 /* In a pattern, so maybe we have {n,m}. */
1643 /* On the other hand, maybe we have a character class */
1646 if (*s == ']' || *s == '^')
1649 /* this is terrifying, and it works */
1650 int weight = 2; /* let's weigh the evidence */
1652 unsigned char un_char = 255, last_un_char;
1653 char *send = strchr(s,']');
1654 char tmpbuf[sizeof PL_tokenbuf * 4];
1656 if (!send) /* has to be an expression */
1659 Zero(seen,256,char);
1662 else if (isDIGIT(*s)) {
1664 if (isDIGIT(s[1]) && s[2] == ']')
1670 for (; s < send; s++) {
1671 last_un_char = un_char;
1672 un_char = (unsigned char)*s;
1677 weight -= seen[un_char] * 10;
1678 if (isALNUM_lazy_if(s+1,UTF)) {
1679 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1680 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1685 else if (*s == '$' && s[1] &&
1686 strchr("[#!%*<>()-=",s[1])) {
1687 if (/*{*/ strchr("])} =",s[2]))
1696 if (strchr("wds]",s[1]))
1698 else if (seen['\''] || seen['"'])
1700 else if (strchr("rnftbxcav",s[1]))
1702 else if (isDIGIT(s[1])) {
1704 while (s[1] && isDIGIT(s[1]))
1714 if (strchr("aA01! ",last_un_char))
1716 if (strchr("zZ79~",s[1]))
1718 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1719 weight -= 5; /* cope with negative subscript */
1722 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1723 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1728 if (keyword(tmpbuf, d - tmpbuf))
1731 if (un_char == last_un_char + 1)
1733 weight -= seen[un_char];
1738 if (weight >= 0) /* probably a character class */
1748 * Does all the checking to disambiguate
1750 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
1751 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
1753 * First argument is the stuff after the first token, e.g. "bar".
1755 * Not a method if bar is a filehandle.
1756 * Not a method if foo is a subroutine prototyped to take a filehandle.
1757 * Not a method if it's really "Foo $bar"
1758 * Method if it's "foo $bar"
1759 * Not a method if it's really "print foo $bar"
1760 * Method if it's really "foo package::" (interpreted as package->foo)
1761 * Not a method if bar is known to be a subroutne ("sub bar; foo bar")
1762 * Not a method if bar is a filehandle or package, but is quoted with
1767 S_intuit_method(pTHX_ char *start, GV *gv)
1769 char *s = start + (*start == '$');
1770 char tmpbuf[sizeof PL_tokenbuf];
1778 if ((cv = GvCVu(gv))) {
1779 char *proto = SvPVX(cv);
1789 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1790 /* start is the beginning of the possible filehandle/object,
1791 * and s is the end of it
1792 * tmpbuf is a copy of it
1795 if (*start == '$') {
1796 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1801 return *s == '(' ? FUNCMETH : METHOD;
1803 if (!keyword(tmpbuf, len)) {
1804 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1809 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1810 if (indirgv && GvCVu(indirgv))
1812 /* filehandle or package name makes it a method */
1813 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1815 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1816 return 0; /* no assumptions -- "=>" quotes bearword */
1818 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1819 newSVpvn(tmpbuf,len));
1820 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1824 return *s == '(' ? FUNCMETH : METHOD;
1832 * Return a string of Perl code to load the debugger. If PERL5DB
1833 * is set, it will return the contents of that, otherwise a
1834 * compile-time require of perl5db.pl.
1841 char *pdb = PerlEnv_getenv("PERL5DB");
1845 SETERRNO(0,SS$_NORMAL);
1846 return "BEGIN { require 'perl5db.pl' }";
1852 /* Encoded script support. filter_add() effectively inserts a
1853 * 'pre-processing' function into the current source input stream.
1854 * Note that the filter function only applies to the current source file
1855 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1857 * The datasv parameter (which may be NULL) can be used to pass
1858 * private data to this instance of the filter. The filter function
1859 * can recover the SV using the FILTER_DATA macro and use it to
1860 * store private buffers and state information.
1862 * The supplied datasv parameter is upgraded to a PVIO type
1863 * and the IoDIRP field is used to store the function pointer,
1864 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
1865 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1866 * private use must be set using malloc'd pointers.
1870 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
1875 if (!PL_rsfp_filters)
1876 PL_rsfp_filters = newAV();
1878 datasv = NEWSV(255,0);
1879 if (!SvUPGRADE(datasv, SVt_PVIO))
1880 Perl_die(aTHX_ "Can't upgrade filter_add data to SVt_PVIO");
1881 IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
1882 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
1883 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
1884 funcp, SvPV_nolen(datasv)));
1885 av_unshift(PL_rsfp_filters, 1);
1886 av_store(PL_rsfp_filters, 0, datasv) ;
1891 /* Delete most recently added instance of this filter function. */
1893 Perl_filter_del(pTHX_ filter_t funcp)
1896 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", funcp));
1897 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
1899 /* if filter is on top of stack (usual case) just pop it off */
1900 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
1901 if (IoDIRP(datasv) == (DIR*)funcp) {
1902 IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
1903 IoDIRP(datasv) = (DIR*)NULL;
1904 sv_free(av_pop(PL_rsfp_filters));
1908 /* we need to search for the correct entry and clear it */
1909 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
1913 /* Invoke the n'th filter function for the current rsfp. */
1915 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
1918 /* 0 = read one text line */
1923 if (!PL_rsfp_filters)
1925 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
1926 /* Provide a default input filter to make life easy. */
1927 /* Note that we append to the line. This is handy. */
1928 DEBUG_P(PerlIO_printf(Perl_debug_log,
1929 "filter_read %d: from rsfp\n", idx));
1933 int old_len = SvCUR(buf_sv) ;
1935 /* ensure buf_sv is large enough */
1936 SvGROW(buf_sv, old_len + maxlen) ;
1937 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1938 if (PerlIO_error(PL_rsfp))
1939 return -1; /* error */
1941 return 0 ; /* end of file */
1943 SvCUR_set(buf_sv, old_len + len) ;
1946 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
1947 if (PerlIO_error(PL_rsfp))
1948 return -1; /* error */
1950 return 0 ; /* end of file */
1953 return SvCUR(buf_sv);
1955 /* Skip this filter slot if filter has been deleted */
1956 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
1957 DEBUG_P(PerlIO_printf(Perl_debug_log,
1958 "filter_read %d: skipped (filter deleted)\n",
1960 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1962 /* Get function pointer hidden within datasv */
1963 funcp = (filter_t)IoDIRP(datasv);
1964 DEBUG_P(PerlIO_printf(Perl_debug_log,
1965 "filter_read %d: via function %p (%s)\n",
1966 idx, funcp, SvPV_nolen(datasv)));
1967 /* Call function. The function is expected to */
1968 /* call "FILTER_READ(idx+1, buf_sv)" first. */
1969 /* Return: <0:error, =0:eof, >0:not eof */
1970 return (*funcp)(aTHXo_ idx, buf_sv, maxlen);
1974 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
1976 #ifdef PERL_CR_FILTER
1977 if (!PL_rsfp_filters) {
1978 filter_add(S_cr_textfilter,NULL);
1981 if (PL_rsfp_filters) {
1984 SvCUR_set(sv, 0); /* start with empty line */
1985 if (FILTER_READ(0, sv, 0) > 0)
1986 return ( SvPVX(sv) ) ;
1991 return (sv_gets(sv, fp, append));
1996 static char* exp_name[] =
1997 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
1998 "ATTRTERM", "TERMBLOCK"
2005 Works out what to call the token just pulled out of the input
2006 stream. The yacc parser takes care of taking the ops we return and
2007 stitching them into a tree.
2013 if read an identifier
2014 if we're in a my declaration
2015 croak if they tried to say my($foo::bar)
2016 build the ops for a my() declaration
2017 if it's an access to a my() variable
2018 are we in a sort block?
2019 croak if my($a); $a <=> $b
2020 build ops for access to a my() variable
2021 if in a dq string, and they've said @foo and we can't find @foo
2023 build ops for a bareword
2024 if we already built the token before, use it.
2028 #ifdef USE_PURE_BISON
2029 Perl_yylex(pTHX_ YYSTYPE *lvalp, int *lcharp)
2042 #ifdef USE_PURE_BISON
2043 yylval_pointer = lvalp;
2044 yychar_pointer = lcharp;
2047 /* check if there's an identifier for us to look at */
2048 if (PL_pending_ident) {
2049 /* pit holds the identifier we read and pending_ident is reset */
2050 char pit = PL_pending_ident;
2051 PL_pending_ident = 0;
2053 /* if we're in a my(), we can't allow dynamics here.
2054 $foo'bar has already been turned into $foo::bar, so
2055 just check for colons.
2057 if it's a legal name, the OP is a PADANY.
2060 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
2061 if (strchr(PL_tokenbuf,':'))
2062 yyerror(Perl_form(aTHX_ "No package name allowed for "
2063 "variable %s in \"our\"",
2065 tmp = pad_allocmy(PL_tokenbuf);
2068 if (strchr(PL_tokenbuf,':'))
2069 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
2071 yylval.opval = newOP(OP_PADANY, 0);
2072 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
2078 build the ops for accesses to a my() variable.
2080 Deny my($a) or my($b) in a sort block, *if* $a or $b is
2081 then used in a comparison. This catches most, but not
2082 all cases. For instance, it catches
2083 sort { my($a); $a <=> $b }
2085 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
2086 (although why you'd do that is anyone's guess).
2089 if (!strchr(PL_tokenbuf,':')) {
2091 /* Check for single character per-thread SVs */
2092 if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
2093 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
2094 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
2096 yylval.opval = newOP(OP_THREADSV, 0);
2097 yylval.opval->op_targ = tmp;
2100 #endif /* USE_THREADS */
2101 if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
2102 SV *namesv = AvARRAY(PL_comppad_name)[tmp];
2103 /* might be an "our" variable" */
2104 if (SvFLAGS(namesv) & SVpad_OUR) {
2105 /* build ops for a bareword */
2106 SV *sym = newSVpv(HvNAME(GvSTASH(namesv)),0);
2107 sv_catpvn(sym, "::", 2);
2108 sv_catpv(sym, PL_tokenbuf+1);
2109 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
2110 yylval.opval->op_private = OPpCONST_ENTERED;
2111 gv_fetchpv(SvPVX(sym),
2113 ? (GV_ADDMULTI | GV_ADDINEVAL)
2116 ((PL_tokenbuf[0] == '$') ? SVt_PV
2117 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
2122 /* if it's a sort block and they're naming $a or $b */
2123 if (PL_last_lop_op == OP_SORT &&
2124 PL_tokenbuf[0] == '$' &&
2125 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
2128 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
2129 d < PL_bufend && *d != '\n';
2132 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
2133 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
2139 yylval.opval = newOP(OP_PADANY, 0);
2140 yylval.opval->op_targ = tmp;
2146 Whine if they've said @foo in a doublequoted string,
2147 and @foo isn't a variable we can find in the symbol
2150 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
2151 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
2152 if (!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
2153 yyerror(Perl_form(aTHX_ "In string, %s now must be written as \\%s",
2154 PL_tokenbuf, PL_tokenbuf));
2157 /* build ops for a bareword */
2158 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
2159 yylval.opval->op_private = OPpCONST_ENTERED;
2160 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
2161 ((PL_tokenbuf[0] == '$') ? SVt_PV
2162 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
2167 /* no identifier pending identification */
2169 switch (PL_lex_state) {
2171 case LEX_NORMAL: /* Some compilers will produce faster */
2172 case LEX_INTERPNORMAL: /* code if we comment these out. */
2176 /* when we've already built the next token, just pull it out of the queue */
2179 yylval = PL_nextval[PL_nexttoke];
2181 PL_lex_state = PL_lex_defer;
2182 PL_expect = PL_lex_expect;
2183 PL_lex_defer = LEX_NORMAL;
2185 return(PL_nexttype[PL_nexttoke]);
2187 /* interpolated case modifiers like \L \U, including \Q and \E.
2188 when we get here, PL_bufptr is at the \
2190 case LEX_INTERPCASEMOD:
2192 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
2193 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
2195 /* handle \E or end of string */
2196 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
2200 if (PL_lex_casemods) {
2201 oldmod = PL_lex_casestack[--PL_lex_casemods];
2202 PL_lex_casestack[PL_lex_casemods] = '\0';
2204 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
2206 PL_lex_state = LEX_INTERPCONCAT;
2210 if (PL_bufptr != PL_bufend)
2212 PL_lex_state = LEX_INTERPCONCAT;
2217 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
2218 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
2219 if (strchr("LU", *s) &&
2220 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
2222 PL_lex_casestack[--PL_lex_casemods] = '\0';
2225 if (PL_lex_casemods > 10) {
2226 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
2227 if (newlb != PL_lex_casestack) {
2229 PL_lex_casestack = newlb;
2232 PL_lex_casestack[PL_lex_casemods++] = *s;
2233 PL_lex_casestack[PL_lex_casemods] = '\0';
2234 PL_lex_state = LEX_INTERPCONCAT;
2235 PL_nextval[PL_nexttoke].ival = 0;
2238 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
2240 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
2242 PL_nextval[PL_nexttoke].ival = OP_LC;
2244 PL_nextval[PL_nexttoke].ival = OP_UC;
2246 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
2248 Perl_croak(aTHX_ "panic: yylex");
2251 if (PL_lex_starts) {
2260 case LEX_INTERPPUSH:
2261 return sublex_push();
2263 case LEX_INTERPSTART:
2264 if (PL_bufptr == PL_bufend)
2265 return sublex_done();
2267 PL_lex_dojoin = (*PL_bufptr == '@');
2268 PL_lex_state = LEX_INTERPNORMAL;
2269 if (PL_lex_dojoin) {
2270 PL_nextval[PL_nexttoke].ival = 0;
2273 PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
2274 PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
2275 force_next(PRIVATEREF);
2277 force_ident("\"", '$');
2278 #endif /* USE_THREADS */
2279 PL_nextval[PL_nexttoke].ival = 0;
2281 PL_nextval[PL_nexttoke].ival = 0;
2283 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
2286 if (PL_lex_starts++) {
2292 case LEX_INTERPENDMAYBE:
2293 if (intuit_more(PL_bufptr)) {
2294 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
2300 if (PL_lex_dojoin) {
2301 PL_lex_dojoin = FALSE;
2302 PL_lex_state = LEX_INTERPCONCAT;
2305 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
2306 && SvEVALED(PL_lex_repl))
2308 if (PL_bufptr != PL_bufend)
2309 Perl_croak(aTHX_ "Bad evalled substitution pattern");
2310 PL_lex_repl = Nullsv;
2313 case LEX_INTERPCONCAT:
2315 if (PL_lex_brackets)
2316 Perl_croak(aTHX_ "panic: INTERPCONCAT");
2318 if (PL_bufptr == PL_bufend)
2319 return sublex_done();
2321 if (SvIVX(PL_linestr) == '\'') {
2322 SV *sv = newSVsv(PL_linestr);
2325 else if ( PL_hints & HINT_NEW_RE )
2326 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
2327 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2331 s = scan_const(PL_bufptr);
2333 PL_lex_state = LEX_INTERPCASEMOD;
2335 PL_lex_state = LEX_INTERPSTART;
2338 if (s != PL_bufptr) {
2339 PL_nextval[PL_nexttoke] = yylval;
2342 if (PL_lex_starts++)
2352 PL_lex_state = LEX_NORMAL;
2353 s = scan_formline(PL_bufptr);
2354 if (!PL_lex_formbrack)
2360 PL_oldoldbufptr = PL_oldbufptr;
2363 PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at %s\n",
2364 exp_name[PL_expect], s);
2370 if (isIDFIRST_lazy_if(s,UTF))
2372 Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
2375 goto fake_eof; /* emulate EOF on ^D or ^Z */
2380 if (PL_lex_brackets)
2381 yyerror("Missing right curly or square bracket");
2384 if (s++ < PL_bufend)
2385 goto retry; /* ignore stray nulls */
2388 if (!PL_in_eval && !PL_preambled) {
2389 PL_preambled = TRUE;
2390 sv_setpv(PL_linestr,incl_perldb());
2391 if (SvCUR(PL_linestr))
2392 sv_catpv(PL_linestr,";");
2394 while(AvFILLp(PL_preambleav) >= 0) {
2395 SV *tmpsv = av_shift(PL_preambleav);
2396 sv_catsv(PL_linestr, tmpsv);
2397 sv_catpv(PL_linestr, ";");
2400 sv_free((SV*)PL_preambleav);
2401 PL_preambleav = NULL;
2403 if (PL_minus_n || PL_minus_p) {
2404 sv_catpv(PL_linestr, "LINE: while (<>) {");
2406 sv_catpv(PL_linestr,"chomp;");
2408 GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
2410 GvIMPORTED_AV_on(gv);
2412 if (strchr("/'\"", *PL_splitstr)
2413 && strchr(PL_splitstr + 1, *PL_splitstr))
2414 Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s);", PL_splitstr);
2417 s = "'~#\200\1'"; /* surely one char is unused...*/
2418 while (s[1] && strchr(PL_splitstr, *s)) s++;
2420 Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s%c",
2421 "q" + (delim == '\''), delim);
2422 for (s = PL_splitstr; *s; s++) {
2424 sv_catpvn(PL_linestr, "\\", 1);
2425 sv_catpvn(PL_linestr, s, 1);
2427 Perl_sv_catpvf(aTHX_ PL_linestr, "%c);", delim);
2431 sv_catpv(PL_linestr,"@F=split(' ');");
2434 sv_catpv(PL_linestr, "\n");
2435 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2436 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2437 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2438 SV *sv = NEWSV(85,0);
2440 sv_upgrade(sv, SVt_PVMG);
2441 sv_setsv(sv,PL_linestr);
2442 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2447 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
2450 if (PL_preprocess && !PL_in_eval)
2451 (void)PerlProc_pclose(PL_rsfp);
2452 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2453 PerlIO_clearerr(PL_rsfp);
2455 (void)PerlIO_close(PL_rsfp);
2457 PL_doextract = FALSE;
2459 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2460 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
2461 sv_catpv(PL_linestr,";}");
2462 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2463 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2464 PL_minus_n = PL_minus_p = 0;
2467 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2468 sv_setpv(PL_linestr,"");
2469 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
2472 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
2473 PL_doextract = FALSE;
2475 /* Incest with pod. */
2476 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2477 sv_setpv(PL_linestr, "");
2478 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2479 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2480 PL_doextract = FALSE;
2484 } while (PL_doextract);
2485 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2486 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2487 SV *sv = NEWSV(85,0);
2489 sv_upgrade(sv, SVt_PVMG);
2490 sv_setsv(sv,PL_linestr);
2491 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2493 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2494 if (CopLINE(PL_curcop) == 1) {
2495 while (s < PL_bufend && isSPACE(*s))
2497 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2501 if (*s == '#' && *(s+1) == '!')
2503 #ifdef ALTERNATE_SHEBANG
2505 static char as[] = ALTERNATE_SHEBANG;
2506 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2507 d = s + (sizeof(as) - 1);
2509 #endif /* ALTERNATE_SHEBANG */
2518 while (*d && !isSPACE(*d))
2522 #ifdef ARG_ZERO_IS_SCRIPT
2523 if (ipathend > ipath) {
2525 * HP-UX (at least) sets argv[0] to the script name,
2526 * which makes $^X incorrect. And Digital UNIX and Linux,
2527 * at least, set argv[0] to the basename of the Perl
2528 * interpreter. So, having found "#!", we'll set it right.
2530 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
2531 assert(SvPOK(x) || SvGMAGICAL(x));
2532 if (sv_eq(x, CopFILESV(PL_curcop))) {
2533 sv_setpvn(x, ipath, ipathend - ipath);
2536 TAINT_NOT; /* $^X is always tainted, but that's OK */
2538 #endif /* ARG_ZERO_IS_SCRIPT */
2543 d = instr(s,"perl -");
2545 d = instr(s,"perl");
2547 /* avoid getting into infinite loops when shebang
2548 * line contains "Perl" rather than "perl" */
2550 for (d = ipathend-4; d >= ipath; --d) {
2551 if ((*d == 'p' || *d == 'P')
2552 && !ibcmp(d, "perl", 4))
2562 #ifdef ALTERNATE_SHEBANG
2564 * If the ALTERNATE_SHEBANG on this system starts with a
2565 * character that can be part of a Perl expression, then if
2566 * we see it but not "perl", we're probably looking at the
2567 * start of Perl code, not a request to hand off to some
2568 * other interpreter. Similarly, if "perl" is there, but
2569 * not in the first 'word' of the line, we assume the line
2570 * contains the start of the Perl program.
2572 if (d && *s != '#') {
2574 while (*c && !strchr("; \t\r\n\f\v#", *c))
2577 d = Nullch; /* "perl" not in first word; ignore */
2579 *s = '#'; /* Don't try to parse shebang line */
2581 #endif /* ALTERNATE_SHEBANG */
2586 !instr(s,"indir") &&
2587 instr(PL_origargv[0],"perl"))
2593 while (s < PL_bufend && isSPACE(*s))
2595 if (s < PL_bufend) {
2596 Newz(899,newargv,PL_origargc+3,char*);
2598 while (s < PL_bufend && !isSPACE(*s))
2601 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2604 newargv = PL_origargv;
2606 PerlProc_execv(ipath, newargv);
2607 Perl_croak(aTHX_ "Can't exec %s", ipath);
2610 U32 oldpdb = PL_perldb;
2611 bool oldn = PL_minus_n;
2612 bool oldp = PL_minus_p;
2614 while (*d && !isSPACE(*d)) d++;
2615 while (*d == ' ' || *d == '\t') d++;
2619 if (*d == 'M' || *d == 'm') {
2621 while (*d && !isSPACE(*d)) d++;
2622 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2625 d = moreswitches(d);
2627 if ((PERLDB_LINE && !oldpdb) ||
2628 ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
2629 /* if we have already added "LINE: while (<>) {",
2630 we must not do it again */
2632 sv_setpv(PL_linestr, "");
2633 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2634 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2635 PL_preambled = FALSE;
2637 (void)gv_fetchfile(PL_origfilename);
2644 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2646 PL_lex_state = LEX_FORMLINE;
2651 #ifdef PERL_STRICT_CR
2652 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2654 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
2656 case ' ': case '\t': case '\f': case 013:
2661 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2662 if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
2663 /* handle eval qq[#line 1 "foo"\n ...] */
2664 CopLINE_dec(PL_curcop);
2668 while (s < d && *s != '\n')
2673 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2675 PL_lex_state = LEX_FORMLINE;
2685 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2690 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2693 if (strnEQ(s,"=>",2)) {
2694 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2695 OPERATOR('-'); /* unary minus */
2697 PL_last_uni = PL_oldbufptr;
2698 PL_last_lop_op = OP_FTEREAD; /* good enough */
2700 case 'r': FTST(OP_FTEREAD);
2701 case 'w': FTST(OP_FTEWRITE);
2702 case 'x': FTST(OP_FTEEXEC);
2703 case 'o': FTST(OP_FTEOWNED);
2704 case 'R': FTST(OP_FTRREAD);
2705 case 'W': FTST(OP_FTRWRITE);
2706 case 'X': FTST(OP_FTREXEC);
2707 case 'O': FTST(OP_FTROWNED);
2708 case 'e': FTST(OP_FTIS);
2709 case 'z': FTST(OP_FTZERO);
2710 case 's': FTST(OP_FTSIZE);
2711 case 'f': FTST(OP_FTFILE);
2712 case 'd': FTST(OP_FTDIR);
2713 case 'l': FTST(OP_FTLINK);
2714 case 'p': FTST(OP_FTPIPE);
2715 case 'S': FTST(OP_FTSOCK);
2716 case 'u': FTST(OP_FTSUID);
2717 case 'g': FTST(OP_FTSGID);
2718 case 'k': FTST(OP_FTSVTX);
2719 case 'b': FTST(OP_FTBLK);
2720 case 'c': FTST(OP_FTCHR);
2721 case 't': FTST(OP_FTTTY);
2722 case 'T': FTST(OP_FTTEXT);
2723 case 'B': FTST(OP_FTBINARY);
2724 case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2725 case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2726 case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
2728 Perl_croak(aTHX_ "Unrecognized file test: -%c", (int)tmp);
2735 if (PL_expect == XOPERATOR)
2740 else if (*s == '>') {
2743 if (isIDFIRST_lazy_if(s,UTF)) {
2744 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2752 if (PL_expect == XOPERATOR)
2755 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2757 OPERATOR('-'); /* unary minus */
2764 if (PL_expect == XOPERATOR)
2769 if (PL_expect == XOPERATOR)
2772 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2778 if (PL_expect != XOPERATOR) {
2779 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2780 PL_expect = XOPERATOR;
2781 force_ident(PL_tokenbuf, '*');
2794 if (PL_expect == XOPERATOR) {
2798 PL_tokenbuf[0] = '%';
2799 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2800 if (!PL_tokenbuf[1]) {
2802 yyerror("Final % should be \\% or %name");
2805 PL_pending_ident = '%';
2824 switch (PL_expect) {
2827 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
2829 PL_bufptr = s; /* update in case we back off */
2835 PL_expect = XTERMBLOCK;
2839 while (isIDFIRST_lazy_if(s,UTF)) {
2840 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2841 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
2842 if (tmp < 0) tmp = -tmp;
2857 d = scan_str(d,TRUE,TRUE);
2860 SvREFCNT_dec(PL_lex_stuff);
2861 PL_lex_stuff = Nullsv;
2863 /* MUST advance bufptr here to avoid bogus
2864 "at end of line" context messages from yyerror().
2866 PL_bufptr = s + len;
2867 yyerror("Unterminated attribute parameter in attribute list");
2870 return 0; /* EOF indicator */
2874 SV *sv = newSVpvn(s, len);
2875 sv_catsv(sv, PL_lex_stuff);
2876 attrs = append_elem(OP_LIST, attrs,
2877 newSVOP(OP_CONST, 0, sv));
2878 SvREFCNT_dec(PL_lex_stuff);
2879 PL_lex_stuff = Nullsv;
2882 attrs = append_elem(OP_LIST, attrs,
2883 newSVOP(OP_CONST, 0,
2887 if (*s == ':' && s[1] != ':')
2890 break; /* require real whitespace or :'s */
2892 tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
2893 if (*s != ';' && *s != tmp && (tmp != '=' || *s != ')')) {
2894 char q = ((*s == '\'') ? '"' : '\'');
2895 /* If here for an expression, and parsed no attrs, back off. */
2896 if (tmp == '=' && !attrs) {
2900 /* MUST advance bufptr here to avoid bogus "at end of line"
2901 context messages from yyerror().
2905 yyerror("Unterminated attribute list");
2907 yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list",
2915 PL_nextval[PL_nexttoke].opval = attrs;
2923 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
2924 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
2929 if (CopLINE(PL_curcop) < PL_copline)
2930 PL_copline = CopLINE(PL_curcop);
2941 if (PL_lex_brackets <= 0)
2942 yyerror("Unmatched right square bracket");
2945 if (PL_lex_state == LEX_INTERPNORMAL) {
2946 if (PL_lex_brackets == 0) {
2947 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
2948 PL_lex_state = LEX_INTERPEND;
2955 if (PL_lex_brackets > 100) {
2956 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
2957 if (newlb != PL_lex_brackstack) {
2959 PL_lex_brackstack = newlb;
2962 switch (PL_expect) {
2964 if (PL_lex_formbrack) {
2968 if (PL_oldoldbufptr == PL_last_lop)
2969 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2971 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2972 OPERATOR(HASHBRACK);
2974 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2977 PL_tokenbuf[0] = '\0';
2978 if (d < PL_bufend && *d == '-') {
2979 PL_tokenbuf[0] = '-';
2981 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2984 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
2985 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2987 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2990 char minus = (PL_tokenbuf[0] == '-');
2991 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2999 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
3004 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3009 if (PL_oldoldbufptr == PL_last_lop)
3010 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3012 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3015 OPERATOR(HASHBRACK);
3016 /* This hack serves to disambiguate a pair of curlies
3017 * as being a block or an anon hash. Normally, expectation
3018 * determines that, but in cases where we're not in a
3019 * position to expect anything in particular (like inside
3020 * eval"") we have to resolve the ambiguity. This code
3021 * covers the case where the first term in the curlies is a
3022 * quoted string. Most other cases need to be explicitly
3023 * disambiguated by prepending a `+' before the opening
3024 * curly in order to force resolution as an anon hash.
3026 * XXX should probably propagate the outer expectation
3027 * into eval"" to rely less on this hack, but that could
3028 * potentially break current behavior of eval"".
3032 if (*s == '\'' || *s == '"' || *s == '`') {
3033 /* common case: get past first string, handling escapes */
3034 for (t++; t < PL_bufend && *t != *s;)
3035 if (*t++ == '\\' && (*t == '\\' || *t == *s))
3039 else if (*s == 'q') {
3042 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
3046 char open, close, term;
3049 while (t < PL_bufend && isSPACE(*t))
3053 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
3057 for (t++; t < PL_bufend; t++) {
3058 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
3060 else if (*t == open)
3064 for (t++; t < PL_bufend; t++) {
3065 if (*t == '\\' && t+1 < PL_bufend)
3067 else if (*t == close && --brackets <= 0)
3069 else if (*t == open)
3075 else if (isALNUM_lazy_if(t,UTF)) {
3077 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3080 while (t < PL_bufend && isSPACE(*t))
3082 /* if comma follows first term, call it an anon hash */
3083 /* XXX it could be a comma expression with loop modifiers */
3084 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
3085 || (*t == '=' && t[1] == '>')))
3086 OPERATOR(HASHBRACK);
3087 if (PL_expect == XREF)
3090 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
3096 yylval.ival = CopLINE(PL_curcop);
3097 if (isSPACE(*s) || *s == '#')
3098 PL_copline = NOLINE; /* invalidate current command line number */
3103 if (PL_lex_brackets <= 0)
3104 yyerror("Unmatched right curly bracket");
3106 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
3107 if (PL_lex_brackets < PL_lex_formbrack)
3108 PL_lex_formbrack = 0;
3109 if (PL_lex_state == LEX_INTERPNORMAL) {
3110 if (PL_lex_brackets == 0) {
3111 if (PL_expect & XFAKEBRACK) {
3112 PL_expect &= XENUMMASK;
3113 PL_lex_state = LEX_INTERPEND;
3115 return yylex(); /* ignore fake brackets */
3117 if (*s == '-' && s[1] == '>')
3118 PL_lex_state = LEX_INTERPENDMAYBE;
3119 else if (*s != '[' && *s != '{')
3120 PL_lex_state = LEX_INTERPEND;
3123 if (PL_expect & XFAKEBRACK) {
3124 PL_expect &= XENUMMASK;
3126 return yylex(); /* ignore fake brackets */
3136 if (PL_expect == XOPERATOR) {
3137 if (ckWARN(WARN_SEMICOLON)
3138 && isIDFIRST_lazy_if(s,UTF) && PL_bufptr == PL_linestart)
3140 CopLINE_dec(PL_curcop);
3141 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3142 CopLINE_inc(PL_curcop);
3147 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3149 PL_expect = XOPERATOR;
3150 force_ident(PL_tokenbuf, '&');
3154 yylval.ival = (OPpENTERSUB_AMPER<<8);
3173 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
3174 Perl_warner(aTHX_ WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
3176 if (PL_expect == XSTATE && isALPHA(tmp) &&
3177 (s == PL_linestart+1 || s[-2] == '\n') )
3179 if (PL_in_eval && !PL_rsfp) {
3184 if (strnEQ(s,"=cut",4)) {
3198 PL_doextract = TRUE;
3201 if (PL_lex_brackets < PL_lex_formbrack) {
3203 #ifdef PERL_STRICT_CR
3204 for (t = s; *t == ' ' || *t == '\t'; t++) ;
3206 for (t = s; *t == ' ' || *t == '\t' || *t == '\r'; t++) ;
3208 if (*t == '\n' || *t == '#') {
3226 if (PL_expect != XOPERATOR) {
3227 if (s[1] != '<' && !strchr(s,'>'))
3230 s = scan_heredoc(s);
3232 s = scan_inputsymbol(s);
3233 TERM(sublex_start());
3238 SHop(OP_LEFT_SHIFT);
3252 SHop(OP_RIGHT_SHIFT);
3261 if (PL_expect == XOPERATOR) {
3262 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3265 return ','; /* grandfather non-comma-format format */
3269 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
3270 PL_tokenbuf[0] = '@';
3271 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3272 sizeof PL_tokenbuf - 1, FALSE);
3273 if (PL_expect == XOPERATOR)
3274 no_op("Array length", s);
3275 if (!PL_tokenbuf[1])
3277 PL_expect = XOPERATOR;
3278 PL_pending_ident = '#';
3282 PL_tokenbuf[0] = '$';
3283 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3284 sizeof PL_tokenbuf - 1, FALSE);
3285 if (PL_expect == XOPERATOR)
3287 if (!PL_tokenbuf[1]) {
3289 yyerror("Final $ should be \\$ or $name");
3293 /* This kludge not intended to be bulletproof. */
3294 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
3295 yylval.opval = newSVOP(OP_CONST, 0,
3296 newSViv(PL_compiling.cop_arybase));
3297 yylval.opval->op_private = OPpCONST_ARYBASE;
3303 if (PL_lex_state == LEX_NORMAL)
3306 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3309 PL_tokenbuf[0] = '@';
3310 if (ckWARN(WARN_SYNTAX)) {
3312 isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$';
3315 PL_bufptr = skipspace(PL_bufptr);
3316 while (t < PL_bufend && *t != ']')
3318 Perl_warner(aTHX_ WARN_SYNTAX,
3319 "Multidimensional syntax %.*s not supported",
3320 (t - PL_bufptr) + 1, PL_bufptr);
3324 else if (*s == '{') {
3325 PL_tokenbuf[0] = '%';
3326 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
3327 (t = strchr(s, '}')) && (t = strchr(t, '=')))
3329 char tmpbuf[sizeof PL_tokenbuf];
3331 for (t++; isSPACE(*t); t++) ;
3332 if (isIDFIRST_lazy_if(t,UTF)) {
3333 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
3334 for (; isSPACE(*t); t++) ;
3335 if (*t == ';' && get_cv(tmpbuf, FALSE))
3336 Perl_warner(aTHX_ WARN_SYNTAX,
3337 "You need to quote \"%s\"", tmpbuf);
3343 PL_expect = XOPERATOR;
3344 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3345 bool islop = (PL_last_lop == PL_oldoldbufptr);
3346 if (!islop || PL_last_lop_op == OP_GREPSTART)
3347 PL_expect = XOPERATOR;
3348 else if (strchr("$@\"'`q", *s))
3349 PL_expect = XTERM; /* e.g. print $fh "foo" */
3350 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
3351 PL_expect = XTERM; /* e.g. print $fh &sub */
3352 else if (isIDFIRST_lazy_if(s,UTF)) {
3353 char tmpbuf[sizeof PL_tokenbuf];
3354 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3355 if ((tmp = keyword(tmpbuf, len))) {
3356 /* binary operators exclude handle interpretations */
3368 PL_expect = XTERM; /* e.g. print $fh length() */
3373 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
3374 if (gv && GvCVu(gv))
3375 PL_expect = XTERM; /* e.g. print $fh subr() */
3378 else if (isDIGIT(*s))
3379 PL_expect = XTERM; /* e.g. print $fh 3 */
3380 else if (*s == '.' && isDIGIT(s[1]))
3381 PL_expect = XTERM; /* e.g. print $fh .3 */
3382 else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
3383 PL_expect = XTERM; /* e.g. print $fh -1 */
3384 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3385 PL_expect = XTERM; /* print $fh <<"EOF" */
3387 PL_pending_ident = '$';
3391 if (PL_expect == XOPERATOR)
3393 PL_tokenbuf[0] = '@';
3394 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3395 if (!PL_tokenbuf[1]) {
3397 yyerror("Final @ should be \\@ or @name");
3400 if (PL_lex_state == LEX_NORMAL)
3402 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3404 PL_tokenbuf[0] = '%';
3406 /* Warn about @ where they meant $. */
3407 if (ckWARN(WARN_SYNTAX)) {
3408 if (*s == '[' || *s == '{') {
3410 while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
3412 if (*t == '}' || *t == ']') {
3414 PL_bufptr = skipspace(PL_bufptr);
3415 Perl_warner(aTHX_ WARN_SYNTAX,
3416 "Scalar value %.*s better written as $%.*s",
3417 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
3422 PL_pending_ident = '@';
3425 case '/': /* may either be division or pattern */
3426 case '?': /* may either be conditional or pattern */
3427 if (PL_expect != XOPERATOR) {
3428 /* Disable warning on "study /blah/" */
3429 if (PL_oldoldbufptr == PL_last_uni
3430 && (*PL_last_uni != 's' || s - PL_last_uni < 5
3431 || memNE(PL_last_uni, "study", 5)
3432 || isALNUM_lazy_if(PL_last_uni+5,UTF)))
3434 s = scan_pat(s,OP_MATCH);
3435 TERM(sublex_start());
3443 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3444 #ifdef PERL_STRICT_CR
3447 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3449 && (s == PL_linestart || s[-1] == '\n') )
3451 PL_lex_formbrack = 0;
3455 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
3461 yylval.ival = OPf_SPECIAL;
3467 if (PL_expect != XOPERATOR)
3472 case '0': case '1': case '2': case '3': case '4':
3473 case '5': case '6': case '7': case '8': case '9':
3475 if (PL_expect == XOPERATOR)
3480 s = scan_str(s,FALSE,FALSE);
3481 if (PL_expect == XOPERATOR) {
3482 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3485 return ','; /* grandfather non-comma-format format */
3491 missingterm((char*)0);
3492 yylval.ival = OP_CONST;
3493 TERM(sublex_start());
3496 s = scan_str(s,FALSE,FALSE);
3497 if (PL_expect == XOPERATOR) {
3498 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3501 return ','; /* grandfather non-comma-format format */
3507 missingterm((char*)0);
3508 yylval.ival = OP_CONST;
3509 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
3510 if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
3511 yylval.ival = OP_STRINGIFY;
3515 TERM(sublex_start());
3518 s = scan_str(s,FALSE,FALSE);
3519 if (PL_expect == XOPERATOR)
3520 no_op("Backticks",s);
3522 missingterm((char*)0);
3523 yylval.ival = OP_BACKTICK;
3525 TERM(sublex_start());
3529 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
3530 Perl_warner(aTHX_ WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
3532 if (PL_expect == XOPERATOR)
3533 no_op("Backslash",s);
3537 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
3541 while (isDIGIT(*start) || *start == '_')
3543 if (*start == '.' && isDIGIT(start[1])) {
3547 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
3548 else if (!isALPHA(*start) && (PL_expect == XTERM || PL_expect == XREF)) {
3552 gv = gv_fetchpv(s, FALSE, SVt_PVCV);
3562 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
3601 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3603 /* Some keywords can be followed by any delimiter, including ':' */
3604 tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
3605 (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
3606 (PL_tokenbuf[0] == 'q' &&
3607 strchr("qwxr", PL_tokenbuf[1])))));
3609 /* x::* is just a word, unless x is "CORE" */
3610 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
3614 while (d < PL_bufend && isSPACE(*d))
3615 d++; /* no comments skipped here, or s### is misparsed */
3617 /* Is this a label? */
3618 if (!tmp && PL_expect == XSTATE
3619 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
3621 yylval.pval = savepv(PL_tokenbuf);
3626 /* Check for keywords */
3627 tmp = keyword(PL_tokenbuf, len);
3629 /* Is this a word before a => operator? */
3630 if (*d == '=' && d[1] == '>') {
3632 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
3633 yylval.opval->op_private = OPpCONST_BARE;
3637 if (tmp < 0) { /* second-class keyword? */
3638 GV *ogv = Nullgv; /* override (winner) */
3639 GV *hgv = Nullgv; /* hidden (loser) */
3640 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3642 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3645 if (GvIMPORTED_CV(gv))
3647 else if (! CvMETHOD(cv))
3651 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3652 (gv = *gvp) != (GV*)&PL_sv_undef &&
3653 GvCVu(gv) && GvIMPORTED_CV(gv))
3659 tmp = 0; /* overridden by import or by GLOBAL */
3662 && -tmp==KEY_lock /* XXX generalizable kludge */
3664 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3666 tmp = 0; /* any sub overrides "weak" keyword */
3668 else { /* no override */
3672 if (ckWARN(WARN_AMBIGUOUS) && hgv
3673 && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3674 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3675 "Ambiguous call resolved as CORE::%s(), %s",
3676 GvENAME(hgv), "qualify as such or use &");
3683 default: /* not a keyword */
3686 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3688 /* Get the rest if it looks like a package qualifier */
3690 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
3692 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3695 Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
3696 *s == '\'' ? "'" : "::");
3700 if (PL_expect == XOPERATOR) {
3701 if (PL_bufptr == PL_linestart) {
3702 CopLINE_dec(PL_curcop);
3703 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3704 CopLINE_inc(PL_curcop);
3707 no_op("Bareword",s);
3710 /* Look for a subroutine with this name in current package,
3711 unless name is "Foo::", in which case Foo is a bearword
3712 (and a package name). */
3715 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3717 if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3718 Perl_warner(aTHX_ WARN_BAREWORD,
3719 "Bareword \"%s\" refers to nonexistent package",
3722 PL_tokenbuf[len] = '\0';
3729 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3732 /* if we saw a global override before, get the right name */
3735 sv = newSVpvn("CORE::GLOBAL::",14);
3736 sv_catpv(sv,PL_tokenbuf);
3739 sv = newSVpv(PL_tokenbuf,0);
3741 /* Presume this is going to be a bareword of some sort. */
3744 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3745 yylval.opval->op_private = OPpCONST_BARE;
3747 /* And if "Foo::", then that's what it certainly is. */
3752 /* See if it's the indirect object for a list operator. */
3754 if (PL_oldoldbufptr &&
3755 PL_oldoldbufptr < PL_bufptr &&
3756 (PL_oldoldbufptr == PL_last_lop
3757 || PL_oldoldbufptr == PL_last_uni) &&
3758 /* NO SKIPSPACE BEFORE HERE! */
3759 (PL_expect == XREF ||
3760 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
3762 bool immediate_paren = *s == '(';
3764 /* (Now we can afford to cross potential line boundary.) */
3767 /* Two barewords in a row may indicate method call. */
3769 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp=intuit_method(s,gv)))
3772 /* If not a declared subroutine, it's an indirect object. */
3773 /* (But it's an indir obj regardless for sort.) */
3775 if ((PL_last_lop_op == OP_SORT ||
3776 (!immediate_paren && (!gv || !GvCVu(gv)))) &&
3777 (PL_last_lop_op != OP_MAPSTART &&
3778 PL_last_lop_op != OP_GREPSTART))
3780 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3786 PL_expect = XOPERATOR;
3789 /* Is this a word before a => operator? */
3790 if (*s == '=' && s[1] == '>') {
3792 sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
3796 /* If followed by a paren, it's certainly a subroutine. */
3799 if (gv && GvCVu(gv)) {
3800 for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
3801 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
3806 PL_nextval[PL_nexttoke].opval = yylval.opval;
3807 PL_expect = XOPERATOR;
3813 /* If followed by var or block, call it a method (unless sub) */
3815 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3816 PL_last_lop = PL_oldbufptr;
3817 PL_last_lop_op = OP_METHOD;
3821 /* If followed by a bareword, see if it looks like indir obj. */
3823 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp = intuit_method(s,gv)))
3826 /* Not a method, so call it a subroutine (if defined) */
3828 if (gv && GvCVu(gv)) {
3830 if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
3831 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3832 "Ambiguous use of -%s resolved as -&%s()",
3833 PL_tokenbuf, PL_tokenbuf);
3834 /* Check for a constant sub */
3836 if ((sv = cv_const_sv(cv))) {
3838 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3839 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3840 yylval.opval->op_private = 0;
3844 /* Resolve to GV now. */
3845 op_free(yylval.opval);
3846 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3847 yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
3848 PL_last_lop = PL_oldbufptr;
3849 PL_last_lop_op = OP_ENTERSUB;
3850 /* Is there a prototype? */
3853 char *proto = SvPV((SV*)cv, len);
3856 if (strEQ(proto, "$"))
3858 if (*proto == '&' && *s == '{') {
3859 sv_setpv(PL_subname,"__ANON__");
3863 PL_nextval[PL_nexttoke].opval = yylval.opval;
3869 /* Call it a bare word */
3871 if (PL_hints & HINT_STRICT_SUBS)
3872 yylval.opval->op_private |= OPpCONST_STRICT;
3875 if (ckWARN(WARN_RESERVED)) {
3876 if (lastchar != '-') {
3877 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3879 Perl_warner(aTHX_ WARN_RESERVED, PL_warn_reserved,
3886 if (lastchar && strchr("*%&", lastchar) && ckWARN_d(WARN_AMBIGUOUS)) {
3887 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3888 "Operator or semicolon missing before %c%s",
3889 lastchar, PL_tokenbuf);
3890 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3891 "Ambiguous use of %c resolved as operator %c",
3892 lastchar, lastchar);
3898 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3899 newSVpv(CopFILE(PL_curcop),0));
3903 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3904 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
3907 case KEY___PACKAGE__:
3908 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3910 ? newSVsv(PL_curstname)
3919 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3920 char *pname = "main";
3921 if (PL_tokenbuf[2] == 'D')
3922 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3923 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
3926 GvIOp(gv) = newIO();
3927 IoIFP(GvIOp(gv)) = PL_rsfp;
3928 #if defined(HAS_FCNTL) && defined(F_SETFD)
3930 int fd = PerlIO_fileno(PL_rsfp);
3931 fcntl(fd,F_SETFD,fd >= 3);
3934 /* Mark this internal pseudo-handle as clean */
3935 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3937 IoTYPE(GvIOp(gv)) = '|';
3938 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
3939 IoTYPE(GvIOp(gv)) = '-';
3941 IoTYPE(GvIOp(gv)) = '<';
3942 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
3943 /* if the script was opened in binmode, we need to revert
3944 * it to text mode for compatibility; but only iff it has CRs
3945 * XXX this is a questionable hack at best. */
3946 if (PL_bufend-PL_bufptr > 2
3947 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
3950 if (IoTYPE(GvIOp(gv)) == '<') {
3951 loc = PerlIO_tell(PL_rsfp);
3952 (void)PerlIO_seek(PL_rsfp, 0L, 0);
3954 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
3955 #if defined(__BORLANDC__)
3956 /* XXX see note in do_binmode() */
3957 ((FILE*)PL_rsfp)->flags |= _F_BIN;
3960 PerlIO_seek(PL_rsfp, loc, 0);
3975 if (PL_expect == XSTATE) {
3982 if (*s == ':' && s[1] == ':') {
3985 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3986 if (!(tmp = keyword(PL_tokenbuf, len)))
3987 Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
4001 LOP(OP_ACCEPT,XTERM);
4007 LOP(OP_ATAN2,XTERM);
4013 LOP(OP_BINMODE,XTERM);
4016 LOP(OP_BLESS,XTERM);
4025 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
4042 if (!PL_cryptseen) {
4043 PL_cryptseen = TRUE;
4047 LOP(OP_CRYPT,XTERM);
4050 if (ckWARN(WARN_CHMOD)) {
4051 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4052 if (*d != '0' && isDIGIT(*d))
4053 Perl_warner(aTHX_ WARN_CHMOD,
4054 "chmod() mode argument is missing initial 0");
4056 LOP(OP_CHMOD,XTERM);
4059 LOP(OP_CHOWN,XTERM);
4062 LOP(OP_CONNECT,XTERM);
4078 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4082 PL_hints |= HINT_BLOCK_SCOPE;
4092 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
4093 LOP(OP_DBMOPEN,XTERM);
4099 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4106 yylval.ival = CopLINE(PL_curcop);
4120 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
4121 UNIBRACK(OP_ENTEREVAL);
4136 case KEY_endhostent:
4142 case KEY_endservent:
4145 case KEY_endprotoent:
4156 yylval.ival = CopLINE(PL_curcop);
4158 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
4160 if ((PL_bufend - p) >= 3 &&
4161 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
4163 else if ((PL_bufend - p) >= 4 &&
4164 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
4167 if (isIDFIRST_lazy_if(p,UTF)) {
4168 p = scan_ident(p, PL_bufend,
4169 PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4173 Perl_croak(aTHX_ "Missing $ on loop variable");
4178 LOP(OP_FORMLINE,XTERM);
4184 LOP(OP_FCNTL,XTERM);
4190 LOP(OP_FLOCK,XTERM);
4199 LOP(OP_GREPSTART, XREF);
4202 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4217 case KEY_getpriority:
4218 LOP(OP_GETPRIORITY,XTERM);
4220 case KEY_getprotobyname:
4223 case KEY_getprotobynumber:
4224 LOP(OP_GPBYNUMBER,XTERM);
4226 case KEY_getprotoent:
4238 case KEY_getpeername:
4239 UNI(OP_GETPEERNAME);
4241 case KEY_gethostbyname:
4244 case KEY_gethostbyaddr:
4245 LOP(OP_GHBYADDR,XTERM);
4247 case KEY_gethostent:
4250 case KEY_getnetbyname:
4253 case KEY_getnetbyaddr:
4254 LOP(OP_GNBYADDR,XTERM);
4259 case KEY_getservbyname:
4260 LOP(OP_GSBYNAME,XTERM);
4262 case KEY_getservbyport:
4263 LOP(OP_GSBYPORT,XTERM);
4265 case KEY_getservent:
4268 case KEY_getsockname:
4269 UNI(OP_GETSOCKNAME);
4271 case KEY_getsockopt:
4272 LOP(OP_GSOCKOPT,XTERM);
4294 yylval.ival = CopLINE(PL_curcop);
4298 LOP(OP_INDEX,XTERM);
4304 LOP(OP_IOCTL,XTERM);
4316 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4348 LOP(OP_LISTEN,XTERM);
4357 s = scan_pat(s,OP_MATCH);
4358 TERM(sublex_start());
4361 LOP(OP_MAPSTART, XREF);
4364 LOP(OP_MKDIR,XTERM);
4367 LOP(OP_MSGCTL,XTERM);
4370 LOP(OP_MSGGET,XTERM);
4373 LOP(OP_MSGRCV,XTERM);
4376 LOP(OP_MSGSND,XTERM);
4382 if (isIDFIRST_lazy_if(s,UTF)) {
4383 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
4384 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
4386 PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
4387 if (!PL_in_my_stash) {
4390 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
4398 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4405 if (PL_expect != XSTATE)
4406 yyerror("\"no\" not allowed in expression");
4407 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4408 s = force_version(s);
4413 if (*s == '(' || (s = skipspace(s), *s == '('))
4420 if (isIDFIRST_lazy_if(s,UTF)) {
4422 for (d = s; isALNUM_lazy_if(d,UTF); d++) ;
4424 if (strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE))
4425 Perl_warner(aTHX_ WARN_PRECEDENCE,
4426 "Precedence problem: open %.*s should be open(%.*s)",
4432 yylval.ival = OP_OR;
4442 LOP(OP_OPEN_DIR,XTERM);
4445 checkcomma(s,PL_tokenbuf,"filehandle");
4449 checkcomma(s,PL_tokenbuf,"filehandle");
4468 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4472 LOP(OP_PIPE_OP,XTERM);
4475 s = scan_str(s,FALSE,FALSE);
4477 missingterm((char*)0);
4478 yylval.ival = OP_CONST;
4479 TERM(sublex_start());
4485 s = scan_str(s,FALSE,FALSE);
4487 missingterm((char*)0);
4489 if (SvCUR(PL_lex_stuff)) {
4492 d = SvPV_force(PL_lex_stuff, len);
4494 for (; isSPACE(*d) && len; --len, ++d) ;
4497 if (!warned && ckWARN(WARN_QW)) {
4498 for (; !isSPACE(*d) && len; --len, ++d) {
4500 Perl_warner(aTHX_ WARN_QW,
4501 "Possible attempt to separate words with commas");
4504 else if (*d == '#') {
4505 Perl_warner(aTHX_ WARN_QW,
4506 "Possible attempt to put comments in qw() list");
4512 for (; !isSPACE(*d) && len; --len, ++d) ;
4514 words = append_elem(OP_LIST, words,
4515 newSVOP(OP_CONST, 0, tokeq(newSVpvn(b, d-b))));
4519 PL_nextval[PL_nexttoke].opval = words;
4524 SvREFCNT_dec(PL_lex_stuff);
4525 PL_lex_stuff = Nullsv;
4530 s = scan_str(s,FALSE,FALSE);
4532 missingterm((char*)0);
4533 yylval.ival = OP_STRINGIFY;
4534 if (SvIVX(PL_lex_stuff) == '\'')
4535 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
4536 TERM(sublex_start());
4539 s = scan_pat(s,OP_QR);
4540 TERM(sublex_start());
4543 s = scan_str(s,FALSE,FALSE);
4545 missingterm((char*)0);
4546 yylval.ival = OP_BACKTICK;
4548 TERM(sublex_start());
4555 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4556 s = force_version(s);
4559 *PL_tokenbuf = '\0';
4560 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4561 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
4562 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
4564 yyerror("<> should be quotes");
4572 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4576 LOP(OP_RENAME,XTERM);
4585 LOP(OP_RINDEX,XTERM);
4608 LOP(OP_REVERSE,XTERM);
4619 TERM(sublex_start());
4621 TOKEN(1); /* force error */
4630 LOP(OP_SELECT,XTERM);
4636 LOP(OP_SEMCTL,XTERM);
4639 LOP(OP_SEMGET,XTERM);
4642 LOP(OP_SEMOP,XTERM);
4648 LOP(OP_SETPGRP,XTERM);
4650 case KEY_setpriority:
4651 LOP(OP_SETPRIORITY,XTERM);
4653 case KEY_sethostent:
4659 case KEY_setservent:
4662 case KEY_setprotoent:
4672 LOP(OP_SEEKDIR,XTERM);
4674 case KEY_setsockopt:
4675 LOP(OP_SSOCKOPT,XTERM);
4681 LOP(OP_SHMCTL,XTERM);
4684 LOP(OP_SHMGET,XTERM);
4687 LOP(OP_SHMREAD,XTERM);
4690 LOP(OP_SHMWRITE,XTERM);
4693 LOP(OP_SHUTDOWN,XTERM);
4702 LOP(OP_SOCKET,XTERM);
4704 case KEY_socketpair:
4705 LOP(OP_SOCKPAIR,XTERM);
4708 checkcomma(s,PL_tokenbuf,"subroutine name");
4710 if (*s == ';' || *s == ')') /* probably a close */
4711 Perl_croak(aTHX_ "sort is now a reserved word");
4713 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4717 LOP(OP_SPLIT,XTERM);
4720 LOP(OP_SPRINTF,XTERM);
4723 LOP(OP_SPLICE,XTERM);
4738 LOP(OP_SUBSTR,XTERM);
4744 char tmpbuf[sizeof PL_tokenbuf];
4746 expectation attrful;
4747 bool have_name, have_proto;
4752 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
4753 (*s == ':' && s[1] == ':'))
4756 attrful = XATTRBLOCK;
4757 /* remember buffer pos'n for later force_word */
4758 tboffset = s - PL_oldbufptr;
4759 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4760 if (strchr(tmpbuf, ':'))
4761 sv_setpv(PL_subname, tmpbuf);
4763 sv_setsv(PL_subname,PL_curstname);
4764 sv_catpvn(PL_subname,"::",2);
4765 sv_catpvn(PL_subname,tmpbuf,len);
4772 Perl_croak(aTHX_ "Missing name in \"my sub\"");
4773 PL_expect = XTERMBLOCK;
4774 attrful = XATTRTERM;
4775 sv_setpv(PL_subname,"?");
4779 if (key == KEY_format) {
4781 PL_lex_formbrack = PL_lex_brackets + 1;
4783 (void) force_word(PL_oldbufptr + tboffset, WORD,
4788 /* Look for a prototype */
4792 s = scan_str(s,FALSE,FALSE);
4795 SvREFCNT_dec(PL_lex_stuff);
4796 PL_lex_stuff = Nullsv;
4797 Perl_croak(aTHX_ "Prototype not terminated");
4800 d = SvPVX(PL_lex_stuff);
4802 for (p = d; *p; ++p) {
4807 SvCUR(PL_lex_stuff) = tmp;
4815 if (*s == ':' && s[1] != ':')
4816 PL_expect = attrful;
4819 PL_nextval[PL_nexttoke].opval =
4820 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4821 PL_lex_stuff = Nullsv;
4825 sv_setpv(PL_subname,"__ANON__");
4828 (void) force_word(PL_oldbufptr + tboffset, WORD,
4837 LOP(OP_SYSTEM,XREF);
4840 LOP(OP_SYMLINK,XTERM);
4843 LOP(OP_SYSCALL,XTERM);
4846 LOP(OP_SYSOPEN,XTERM);
4849 LOP(OP_SYSSEEK,XTERM);
4852 LOP(OP_SYSREAD,XTERM);
4855 LOP(OP_SYSWRITE,XTERM);
4859 TERM(sublex_start());
4880 LOP(OP_TRUNCATE,XTERM);
4892 yylval.ival = CopLINE(PL_curcop);
4896 yylval.ival = CopLINE(PL_curcop);
4900 LOP(OP_UNLINK,XTERM);
4906 LOP(OP_UNPACK,XTERM);
4909 LOP(OP_UTIME,XTERM);
4912 if (ckWARN(WARN_UMASK)) {
4913 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4914 if (*d != '0' && isDIGIT(*d))
4915 Perl_warner(aTHX_ WARN_UMASK,
4916 "umask: argument is missing initial 0");
4921 LOP(OP_UNSHIFT,XTERM);
4924 if (PL_expect != XSTATE)
4925 yyerror("\"use\" not allowed in expression");
4927 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4928 s = force_version(s);
4929 if (*s == ';' || (s = skipspace(s), *s == ';')) {
4930 PL_nextval[PL_nexttoke].opval = Nullop;
4935 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4936 s = force_version(s);
4948 yylval.ival = CopLINE(PL_curcop);
4952 PL_hints |= HINT_BLOCK_SCOPE;
4959 LOP(OP_WAITPID,XTERM);
4967 static char ctl_l[2];
4969 if (ctl_l[0] == '\0')
4970 ctl_l[0] = toCTRL('L');
4971 gv_fetchpv(ctl_l,TRUE, SVt_PV);
4974 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
4979 if (PL_expect == XOPERATOR)
4985 yylval.ival = OP_XOR;
4990 TERM(sublex_start());
4996 Perl_keyword(pTHX_ register char *d, I32 len)
5001 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
5002 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
5003 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
5004 if (strEQ(d,"__DATA__")) return KEY___DATA__;
5005 if (strEQ(d,"__END__")) return KEY___END__;
5009 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
5014 if (strEQ(d,"and")) return -KEY_and;
5015 if (strEQ(d,"abs")) return -KEY_abs;
5018 if (strEQ(d,"alarm")) return -KEY_alarm;
5019 if (strEQ(d,"atan2")) return -KEY_atan2;
5022 if (strEQ(d,"accept")) return -KEY_accept;
5027 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
5030 if (strEQ(d,"bless")) return -KEY_bless;
5031 if (strEQ(d,"bind")) return -KEY_bind;
5032 if (strEQ(d,"binmode")) return -KEY_binmode;
5035 if (strEQ(d,"CORE")) return -KEY_CORE;
5036 if (strEQ(d,"CHECK")) return KEY_CHECK;
5041 if (strEQ(d,"cmp")) return -KEY_cmp;
5042 if (strEQ(d,"chr")) return -KEY_chr;
5043 if (strEQ(d,"cos")) return -KEY_cos;
5046 if (strEQ(d,"chop")) return KEY_chop;
5049 if (strEQ(d,"close")) return -KEY_close;
5050 if (strEQ(d,"chdir")) return -KEY_chdir;
5051 if (strEQ(d,"chomp")) return KEY_chomp;
5052 if (strEQ(d,"chmod")) return -KEY_chmod;
5053 if (strEQ(d,"chown")) return -KEY_chown;
5054 if (strEQ(d,"crypt")) return -KEY_crypt;
5057 if (strEQ(d,"chroot")) return -KEY_chroot;
5058 if (strEQ(d,"caller")) return -KEY_caller;
5061 if (strEQ(d,"connect")) return -KEY_connect;
5064 if (strEQ(d,"closedir")) return -KEY_closedir;
5065 if (strEQ(d,"continue")) return -KEY_continue;
5070 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
5075 if (strEQ(d,"do")) return KEY_do;
5078 if (strEQ(d,"die")) return -KEY_die;
5081 if (strEQ(d,"dump")) return -KEY_dump;
5084 if (strEQ(d,"delete")) return KEY_delete;
5087 if (strEQ(d,"defined")) return KEY_defined;
5088 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
5091 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
5096 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
5097 if (strEQ(d,"END")) return KEY_END;
5102 if (strEQ(d,"eq")) return -KEY_eq;
5105 if (strEQ(d,"eof")) return -KEY_eof;
5106 if (strEQ(d,"exp")) return -KEY_exp;
5109 if (strEQ(d,"else")) return KEY_else;
5110 if (strEQ(d,"exit")) return -KEY_exit;
5111 if (strEQ(d,"eval")) return KEY_eval;
5112 if (strEQ(d,"exec")) return -KEY_exec;
5113 if (strEQ(d,"each")) return KEY_each;
5116 if (strEQ(d,"elsif")) return KEY_elsif;
5119 if (strEQ(d,"exists")) return KEY_exists;
5120 if (strEQ(d,"elseif")) Perl_warn(aTHX_ "elseif should be elsif");
5123 if (strEQ(d,"endgrent")) return -KEY_endgrent;
5124 if (strEQ(d,"endpwent")) return -KEY_endpwent;
5127 if (strEQ(d,"endnetent")) return -KEY_endnetent;
5130 if (strEQ(d,"endhostent")) return -KEY_endhostent;
5131 if (strEQ(d,"endservent")) return -KEY_endservent;
5134 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
5141 if (strEQ(d,"for")) return KEY_for;
5144 if (strEQ(d,"fork")) return -KEY_fork;
5147 if (strEQ(d,"fcntl")) return -KEY_fcntl;
5148 if (strEQ(d,"flock")) return -KEY_flock;
5151 if (strEQ(d,"format")) return KEY_format;
5152 if (strEQ(d,"fileno")) return -KEY_fileno;
5155 if (strEQ(d,"foreach")) return KEY_foreach;
5158 if (strEQ(d,"formline")) return -KEY_formline;
5164 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
5165 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
5169 if (strnEQ(d,"get",3)) {
5174 if (strEQ(d,"ppid")) return -KEY_getppid;
5175 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
5178 if (strEQ(d,"pwent")) return -KEY_getpwent;
5179 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
5180 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
5183 if (strEQ(d,"peername")) return -KEY_getpeername;
5184 if (strEQ(d,"protoent")) return -KEY_getprotoent;
5185 if (strEQ(d,"priority")) return -KEY_getpriority;
5188 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
5191 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
5195 else if (*d == 'h') {
5196 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
5197 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
5198 if (strEQ(d,"hostent")) return -KEY_gethostent;
5200 else if (*d == 'n') {
5201 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
5202 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
5203 if (strEQ(d,"netent")) return -KEY_getnetent;
5205 else if (*d == 's') {
5206 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
5207 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
5208 if (strEQ(d,"servent")) return -KEY_getservent;
5209 if (strEQ(d,"sockname")) return -KEY_getsockname;
5210 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
5212 else if (*d == 'g') {
5213 if (strEQ(d,"grent")) return -KEY_getgrent;
5214 if (strEQ(d,"grnam")) return -KEY_getgrnam;
5215 if (strEQ(d,"grgid")) return -KEY_getgrgid;
5217 else if (*d == 'l') {
5218 if (strEQ(d,"login")) return -KEY_getlogin;
5220 else if (strEQ(d,"c")) return -KEY_getc;
5225 if (strEQ(d,"gt")) return -KEY_gt;
5226 if (strEQ(d,"ge")) return -KEY_ge;
5229 if (strEQ(d,"grep")) return KEY_grep;
5230 if (strEQ(d,"goto")) return KEY_goto;
5231 if (strEQ(d,"glob")) return KEY_glob;
5234 if (strEQ(d,"gmtime")) return -KEY_gmtime;
5239 if (strEQ(d,"hex")) return -KEY_hex;
5242 if (strEQ(d,"INIT")) return KEY_INIT;
5247 if (strEQ(d,"if")) return KEY_if;
5250 if (strEQ(d,"int")) return -KEY_int;
5253 if (strEQ(d,"index")) return -KEY_index;
5254 if (strEQ(d,"ioctl")) return -KEY_ioctl;
5259 if (strEQ(d,"join")) return -KEY_join;
5263 if (strEQ(d,"keys")) return KEY_keys;
5264 if (strEQ(d,"kill")) return -KEY_kill;
5269 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
5270 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
5276 if (strEQ(d,"lt")) return -KEY_lt;
5277 if (strEQ(d,"le")) return -KEY_le;
5278 if (strEQ(d,"lc")) return -KEY_lc;
5281 if (strEQ(d,"log")) return -KEY_log;
5284 if (strEQ(d,"last")) return KEY_last;
5285 if (strEQ(d,"link")) return -KEY_link;
5286 if (strEQ(d,"lock")) return -KEY_lock;
5289 if (strEQ(d,"local")) return KEY_local;
5290 if (strEQ(d,"lstat")) return -KEY_lstat;
5293 if (strEQ(d,"length")) return -KEY_length;
5294 if (strEQ(d,"listen")) return -KEY_listen;
5297 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
5300 if (strEQ(d,"localtime")) return -KEY_localtime;
5306 case 1: return KEY_m;
5308 if (strEQ(d,"my")) return KEY_my;
5311 if (strEQ(d,"map")) return KEY_map;
5314 if (strEQ(d,"mkdir")) return -KEY_mkdir;
5317 if (strEQ(d,"msgctl")) return -KEY_msgctl;
5318 if (strEQ(d,"msgget")) return -KEY_msgget;
5319 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
5320 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
5325 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
5328 if (strEQ(d,"next")) return KEY_next;
5329 if (strEQ(d,"ne")) return -KEY_ne;
5330 if (strEQ(d,"not")) return -KEY_not;
5331 if (strEQ(d,"no")) return KEY_no;
5336 if (strEQ(d,"or")) return -KEY_or;
5339 if (strEQ(d,"ord")) return -KEY_ord;
5340 if (strEQ(d,"oct")) return -KEY_oct;
5341 if (strEQ(d,"our")) return KEY_our;
5344 if (strEQ(d,"open")) return -KEY_open;
5347 if (strEQ(d,"opendir")) return -KEY_opendir;
5354 if (strEQ(d,"pop")) return KEY_pop;
5355 if (strEQ(d,"pos")) return KEY_pos;
5358 if (strEQ(d,"push")) return KEY_push;
5359 if (strEQ(d,"pack")) return -KEY_pack;
5360 if (strEQ(d,"pipe")) return -KEY_pipe;
5363 if (strEQ(d,"print")) return KEY_print;
5366 if (strEQ(d,"printf")) return KEY_printf;
5369 if (strEQ(d,"package")) return KEY_package;
5372 if (strEQ(d,"prototype")) return KEY_prototype;
5377 if (strEQ(d,"q")) return KEY_q;
5378 if (strEQ(d,"qr")) return KEY_qr;
5379 if (strEQ(d,"qq")) return KEY_qq;
5380 if (strEQ(d,"qw")) return KEY_qw;
5381 if (strEQ(d,"qx")) return KEY_qx;
5383 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
5388 if (strEQ(d,"ref")) return -KEY_ref;
5391 if (strEQ(d,"read")) return -KEY_read;
5392 if (strEQ(d,"rand")) return -KEY_rand;
5393 if (strEQ(d,"recv")) return -KEY_recv;
5394 if (strEQ(d,"redo")) return KEY_redo;
5397 if (strEQ(d,"rmdir")) return -KEY_rmdir;
5398 if (strEQ(d,"reset")) return -KEY_reset;
5401 if (strEQ(d,"return")) return KEY_return;
5402 if (strEQ(d,"rename")) return -KEY_rename;
5403 if (strEQ(d,"rindex")) return -KEY_rindex;
5406 if (strEQ(d,"require")) return -KEY_require;
5407 if (strEQ(d,"reverse")) return -KEY_reverse;
5408 if (strEQ(d,"readdir")) return -KEY_readdir;
5411 if (strEQ(d,"readlink")) return -KEY_readlink;
5412 if (strEQ(d,"readline")) return -KEY_readline;
5413 if (strEQ(d,"readpipe")) return -KEY_readpipe;
5416 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
5422 case 0: return KEY_s;
5424 if (strEQ(d,"scalar")) return KEY_scalar;
5429 if (strEQ(d,"seek")) return -KEY_seek;
5430 if (strEQ(d,"send")) return -KEY_send;
5433 if (strEQ(d,"semop")) return -KEY_semop;
5436 if (strEQ(d,"select")) return -KEY_select;
5437 if (strEQ(d,"semctl")) return -KEY_semctl;
5438 if (strEQ(d,"semget")) return -KEY_semget;
5441 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
5442 if (strEQ(d,"seekdir")) return -KEY_seekdir;
5445 if (strEQ(d,"setpwent")) return -KEY_setpwent;
5446 if (strEQ(d,"setgrent")) return -KEY_setgrent;
5449 if (strEQ(d,"setnetent")) return -KEY_setnetent;
5452 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
5453 if (strEQ(d,"sethostent")) return -KEY_sethostent;
5454 if (strEQ(d,"setservent")) return -KEY_setservent;
5457 if (strEQ(d,"setpriority")) return -KEY_setpriority;
5458 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
5465 if (strEQ(d,"shift")) return KEY_shift;
5468 if (strEQ(d,"shmctl")) return -KEY_shmctl;
5469 if (strEQ(d,"shmget")) return -KEY_shmget;
5472 if (strEQ(d,"shmread")) return -KEY_shmread;
5475 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
5476 if (strEQ(d,"shutdown")) return -KEY_shutdown;
5481 if (strEQ(d,"sin")) return -KEY_sin;
5484 if (strEQ(d,"sleep")) return -KEY_sleep;
5487 if (strEQ(d,"sort")) return KEY_sort;
5488 if (strEQ(d,"socket")) return -KEY_socket;
5489 if (strEQ(d,"socketpair")) return -KEY_socketpair;
5492 if (strEQ(d,"split")) return KEY_split;
5493 if (strEQ(d,"sprintf")) return -KEY_sprintf;
5494 if (strEQ(d,"splice")) return KEY_splice;
5497 if (strEQ(d,"sqrt")) return -KEY_sqrt;
5500 if (strEQ(d,"srand")) return -KEY_srand;
5503 if (strEQ(d,"stat")) return -KEY_stat;
5504 if (strEQ(d,"study")) return KEY_study;
5507 if (strEQ(d,"substr")) return -KEY_substr;
5508 if (strEQ(d,"sub")) return KEY_sub;
5513 if (strEQ(d,"system")) return -KEY_system;
5516 if (strEQ(d,"symlink")) return -KEY_symlink;
5517 if (strEQ(d,"syscall")) return -KEY_syscall;
5518 if (strEQ(d,"sysopen")) return -KEY_sysopen;
5519 if (strEQ(d,"sysread")) return -KEY_sysread;
5520 if (strEQ(d,"sysseek")) return -KEY_sysseek;
5523 if (strEQ(d,"syswrite")) return -KEY_syswrite;
5532 if (strEQ(d,"tr")) return KEY_tr;
5535 if (strEQ(d,"tie")) return KEY_tie;
5538 if (strEQ(d,"tell")) return -KEY_tell;
5539 if (strEQ(d,"tied")) return KEY_tied;
5540 if (strEQ(d,"time")) return -KEY_time;
5543 if (strEQ(d,"times")) return -KEY_times;
5546 if (strEQ(d,"telldir")) return -KEY_telldir;
5549 if (strEQ(d,"truncate")) return -KEY_truncate;
5556 if (strEQ(d,"uc")) return -KEY_uc;
5559 if (strEQ(d,"use")) return KEY_use;
5562 if (strEQ(d,"undef")) return KEY_undef;
5563 if (strEQ(d,"until")) return KEY_until;
5564 if (strEQ(d,"untie")) return KEY_untie;
5565 if (strEQ(d,"utime")) return -KEY_utime;
5566 if (strEQ(d,"umask")) return -KEY_umask;
5569 if (strEQ(d,"unless")) return KEY_unless;
5570 if (strEQ(d,"unpack")) return -KEY_unpack;
5571 if (strEQ(d,"unlink")) return -KEY_unlink;
5574 if (strEQ(d,"unshift")) return KEY_unshift;
5575 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
5580 if (strEQ(d,"values")) return -KEY_values;
5581 if (strEQ(d,"vec")) return -KEY_vec;
5586 if (strEQ(d,"warn")) return -KEY_warn;
5587 if (strEQ(d,"wait")) return -KEY_wait;
5590 if (strEQ(d,"while")) return KEY_while;
5591 if (strEQ(d,"write")) return -KEY_write;
5594 if (strEQ(d,"waitpid")) return -KEY_waitpid;
5597 if (strEQ(d,"wantarray")) return -KEY_wantarray;
5602 if (len == 1) return -KEY_x;
5603 if (strEQ(d,"xor")) return -KEY_xor;
5606 if (len == 1) return KEY_y;
5615 S_checkcomma(pTHX_ register char *s, char *name, char *what)
5619 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
5620 dTHR; /* only for ckWARN */
5621 if (ckWARN(WARN_SYNTAX)) {
5623 for (w = s+2; *w && level; w++) {
5630 for (; *w && isSPACE(*w); w++) ;
5631 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
5632 Perl_warner(aTHX_ WARN_SYNTAX,
5633 "%s (...) interpreted as function",name);
5636 while (s < PL_bufend && isSPACE(*s))
5640 while (s < PL_bufend && isSPACE(*s))
5642 if (isIDFIRST_lazy_if(s,UTF)) {
5644 while (isALNUM_lazy_if(s,UTF))
5646 while (s < PL_bufend && isSPACE(*s))
5651 kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
5655 Perl_croak(aTHX_ "No comma allowed after %s", what);
5660 /* Either returns sv, or mortalizes sv and returns a new SV*.
5661 Best used as sv=new_constant(..., sv, ...).
5662 If s, pv are NULL, calls subroutine with one argument,
5663 and type is used with error messages only. */
5666 S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv,
5670 HV *table = GvHV(PL_hintgv); /* ^H */
5674 const char *why1, *why2, *why3;
5676 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
5679 why1 = "%^H is not consistent";
5680 why2 = strEQ(key,"charnames")
5681 ? " (missing \"use charnames ...\"?)"
5685 msg = Perl_newSVpvf(aTHX_ "constant(%s): %s%s%s",
5686 (type ? type: "undef"), why1, why2, why3);
5687 yyerror(SvPVX(msg));
5691 cvp = hv_fetch(table, key, strlen(key), FALSE);
5692 if (!cvp || !SvOK(*cvp)) {
5695 why3 = "} is not defined";
5698 sv_2mortal(sv); /* Parent created it permanently */
5701 pv = sv_2mortal(newSVpvn(s, len));
5703 typesv = sv_2mortal(newSVpv(type, 0));
5705 typesv = &PL_sv_undef;
5707 PUSHSTACKi(PERLSI_OVERLOAD);
5720 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
5724 /* Check the eval first */
5725 if (!PL_in_eval && SvTRUE(ERRSV)) {
5727 sv_catpv(ERRSV, "Propagated");
5728 yyerror(SvPV(ERRSV, n_a)); /* Duplicates the message inside eval */
5730 res = SvREFCNT_inc(sv);
5734 (void)SvREFCNT_inc(res);
5743 why1 = "Call to &{$^H{";
5745 why3 = "}} did not return a defined value";
5754 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
5756 register char *d = dest;
5757 register char *e = d + destlen - 3; /* two-character token, ending NUL */
5760 Perl_croak(aTHX_ ident_too_long);
5761 if (isALNUM(*s)) /* UTF handled below */
5763 else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) {
5768 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
5772 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5773 char *t = s + UTF8SKIP(s);
5774 while (*t & 0x80 && is_utf8_mark((U8*)t))
5776 if (d + (t - s) > e)
5777 Perl_croak(aTHX_ ident_too_long);
5778 Copy(s, d, t - s, char);
5791 S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
5801 e = d + destlen - 3; /* two-character token, ending NUL */
5803 while (isDIGIT(*s)) {
5805 Perl_croak(aTHX_ ident_too_long);
5812 Perl_croak(aTHX_ ident_too_long);
5813 if (isALNUM(*s)) /* UTF handled below */
5815 else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
5820 else if (*s == ':' && s[1] == ':') {
5824 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5825 char *t = s + UTF8SKIP(s);
5826 while (*t & 0x80 && is_utf8_mark((U8*)t))
5828 if (d + (t - s) > e)
5829 Perl_croak(aTHX_ ident_too_long);
5830 Copy(s, d, t - s, char);
5841 if (PL_lex_state != LEX_NORMAL)
5842 PL_lex_state = LEX_INTERPENDMAYBE;
5845 if (*s == '$' && s[1] &&
5846 (isALNUM_lazy_if(s+1,UTF) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
5859 if (*d == '^' && *s && isCONTROLVAR(*s)) {
5864 if (isSPACE(s[-1])) {
5867 if (ch != ' ' && ch != '\t') {
5873 if (isIDFIRST_lazy_if(d,UTF)) {
5877 while ((e < send && isALNUM_lazy_if(e,UTF)) || *e == ':') {
5879 while (e < send && *e & 0x80 && is_utf8_mark((U8*)e))
5882 Copy(s, d, e - s, char);
5887 while ((isALNUM(*s) || *s == ':') && d < e)
5890 Perl_croak(aTHX_ ident_too_long);
5893 while (s < send && (*s == ' ' || *s == '\t')) s++;
5894 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
5895 dTHR; /* only for ckWARN */
5896 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
5897 const char *brack = *s == '[' ? "[...]" : "{...}";
5898 Perl_warner(aTHX_ WARN_AMBIGUOUS,
5899 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
5900 funny, dest, brack, funny, dest, brack);
5903 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
5907 /* Handle extended ${^Foo} variables
5908 * 1999-02-27 mjd-perl-patch@plover.com */
5909 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
5913 while (isALNUM(*s) && d < e) {
5917 Perl_croak(aTHX_ ident_too_long);
5922 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
5923 PL_lex_state = LEX_INTERPEND;
5926 if (PL_lex_state == LEX_NORMAL) {
5927 dTHR; /* only for ckWARN */
5928 if (ckWARN(WARN_AMBIGUOUS) &&
5929 (keyword(dest, d - dest) || get_cv(dest, FALSE)))
5931 Perl_warner(aTHX_ WARN_AMBIGUOUS,
5932 "Ambiguous use of %c{%s} resolved to %c%s",
5933 funny, dest, funny, dest);
5938 s = bracket; /* let the parser handle it */
5942 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
5943 PL_lex_state = LEX_INTERPEND;
5948 Perl_pmflag(pTHX_ U16 *pmfl, int ch)
5953 *pmfl |= PMf_GLOBAL;
5955 *pmfl |= PMf_CONTINUE;
5959 *pmfl |= PMf_MULTILINE;
5961 *pmfl |= PMf_SINGLELINE;
5963 *pmfl |= PMf_EXTENDED;
5967 S_scan_pat(pTHX_ char *start, I32 type)
5972 s = scan_str(start,FALSE,FALSE);
5975 SvREFCNT_dec(PL_lex_stuff);
5976 PL_lex_stuff = Nullsv;
5977 Perl_croak(aTHX_ "Search pattern not terminated");
5980 pm = (PMOP*)newPMOP(type, 0);
5981 if (PL_multi_open == '?')
5982 pm->op_pmflags |= PMf_ONCE;
5984 while (*s && strchr("iomsx", *s))
5985 pmflag(&pm->op_pmflags,*s++);
5988 while (*s && strchr("iogcmsx", *s))
5989 pmflag(&pm->op_pmflags,*s++);
5991 pm->op_pmpermflags = pm->op_pmflags;
5993 PL_lex_op = (OP*)pm;
5994 yylval.ival = OP_MATCH;
5999 S_scan_subst(pTHX_ char *start)
6006 yylval.ival = OP_NULL;
6008 s = scan_str(start,FALSE,FALSE);
6012 SvREFCNT_dec(PL_lex_stuff);
6013 PL_lex_stuff = Nullsv;
6014 Perl_croak(aTHX_ "Substitution pattern not terminated");
6017 if (s[-1] == PL_multi_open)
6020 first_start = PL_multi_start;
6021 s = scan_str(s,FALSE,FALSE);
6024 SvREFCNT_dec(PL_lex_stuff);
6025 PL_lex_stuff = Nullsv;
6027 SvREFCNT_dec(PL_lex_repl);
6028 PL_lex_repl = Nullsv;
6029 Perl_croak(aTHX_ "Substitution replacement not terminated");
6031 PL_multi_start = first_start; /* so whole substitution is taken together */
6033 pm = (PMOP*)newPMOP(OP_SUBST, 0);
6039 else if (strchr("iogcmsx", *s))
6040 pmflag(&pm->op_pmflags,*s++);
6047 PL_sublex_info.super_bufptr = s;
6048 PL_sublex_info.super_bufend = PL_bufend;
6050 pm->op_pmflags |= PMf_EVAL;
6051 repl = newSVpvn("",0);
6053 sv_catpv(repl, es ? "eval " : "do ");
6054 sv_catpvn(repl, "{ ", 2);
6055 sv_catsv(repl, PL_lex_repl);
6056 sv_catpvn(repl, " };", 2);
6058 SvREFCNT_dec(PL_lex_repl);
6062 pm->op_pmpermflags = pm->op_pmflags;
6063 PL_lex_op = (OP*)pm;
6064 yylval.ival = OP_SUBST;
6069 S_scan_trans(pTHX_ char *start)
6080 yylval.ival = OP_NULL;
6082 s = scan_str(start,FALSE,FALSE);
6085 SvREFCNT_dec(PL_lex_stuff);
6086 PL_lex_stuff = Nullsv;
6087 Perl_croak(aTHX_ "Transliteration pattern not terminated");
6089 if (s[-1] == PL_multi_open)
6092 s = scan_str(s,FALSE,FALSE);
6095 SvREFCNT_dec(PL_lex_stuff);
6096 PL_lex_stuff = Nullsv;
6098 SvREFCNT_dec(PL_lex_repl);
6099 PL_lex_repl = Nullsv;
6100 Perl_croak(aTHX_ "Transliteration replacement not terminated");
6104 o = newSVOP(OP_TRANS, 0, 0);
6105 utf8 = OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF;
6108 New(803,tbl,256,short);
6109 o = newPVOP(OP_TRANS, 0, (char*)tbl);
6113 complement = del = squash = 0;
6114 while (strchr("cdsCU", *s)) {
6116 complement = OPpTRANS_COMPLEMENT;
6118 del = OPpTRANS_DELETE;
6120 squash = OPpTRANS_SQUASH;
6125 utf8 &= ~OPpTRANS_FROM_UTF;
6127 utf8 |= OPpTRANS_FROM_UTF;
6131 utf8 &= ~OPpTRANS_TO_UTF;
6133 utf8 |= OPpTRANS_TO_UTF;
6136 Perl_croak(aTHX_ "Too many /C and /U options");
6141 o->op_private = del|squash|complement|utf8;
6144 yylval.ival = OP_TRANS;
6149 S_scan_heredoc(pTHX_ register char *s)
6153 I32 op_type = OP_SCALAR;
6160 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
6164 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
6167 for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
6168 if (*peek && strchr("`'\"",*peek)) {
6171 s = delimcpy(d, e, s, PL_bufend, term, &len);
6181 if (!isALNUM_lazy_if(s,UTF))
6182 deprecate("bare << to mean <<\"\"");
6183 for (; isALNUM_lazy_if(s,UTF); s++) {
6188 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
6189 Perl_croak(aTHX_ "Delimiter for here document is too long");
6192 len = d - PL_tokenbuf;
6193 #ifndef PERL_STRICT_CR
6194 d = strchr(s, '\r');
6198 while (s < PL_bufend) {
6204 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
6213 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6218 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
6219 herewas = newSVpvn(s,PL_bufend-s);
6221 s--, herewas = newSVpvn(s,d-s);
6222 s += SvCUR(herewas);
6224 tmpstr = NEWSV(87,79);
6225 sv_upgrade(tmpstr, SVt_PVIV);
6230 else if (term == '`') {
6231 op_type = OP_BACKTICK;
6232 SvIVX(tmpstr) = '\\';
6236 PL_multi_start = CopLINE(PL_curcop);
6237 PL_multi_open = PL_multi_close = '<';
6238 term = *PL_tokenbuf;
6239 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
6240 char *bufptr = PL_sublex_info.super_bufptr;
6241 char *bufend = PL_sublex_info.super_bufend;
6242 char *olds = s - SvCUR(herewas);
6243 s = strchr(bufptr, '\n');
6247 while (s < bufend &&
6248 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6250 CopLINE_inc(PL_curcop);
6253 CopLINE_set(PL_curcop, PL_multi_start);
6254 missingterm(PL_tokenbuf);
6256 sv_setpvn(herewas,bufptr,d-bufptr+1);
6257 sv_setpvn(tmpstr,d+1,s-d);
6259 sv_catpvn(herewas,s,bufend-s);
6260 (void)strcpy(bufptr,SvPVX(herewas));
6267 while (s < PL_bufend &&
6268 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6270 CopLINE_inc(PL_curcop);
6272 if (s >= PL_bufend) {
6273 CopLINE_set(PL_curcop, PL_multi_start);
6274 missingterm(PL_tokenbuf);
6276 sv_setpvn(tmpstr,d+1,s-d);
6278 CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
6280 sv_catpvn(herewas,s,PL_bufend-s);
6281 sv_setsv(PL_linestr,herewas);
6282 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
6283 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6286 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
6287 while (s >= PL_bufend) { /* multiple line string? */
6289 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6290 CopLINE_set(PL_curcop, PL_multi_start);
6291 missingterm(PL_tokenbuf);
6293 CopLINE_inc(PL_curcop);
6294 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6295 #ifndef PERL_STRICT_CR
6296 if (PL_bufend - PL_linestart >= 2) {
6297 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
6298 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
6300 PL_bufend[-2] = '\n';
6302 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6304 else if (PL_bufend[-1] == '\r')
6305 PL_bufend[-1] = '\n';
6307 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
6308 PL_bufend[-1] = '\n';
6310 if (PERLDB_LINE && PL_curstash != PL_debstash) {
6311 SV *sv = NEWSV(88,0);
6313 sv_upgrade(sv, SVt_PVMG);
6314 sv_setsv(sv,PL_linestr);
6315 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop),sv);
6317 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
6320 sv_catsv(PL_linestr,herewas);
6321 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6325 sv_catsv(tmpstr,PL_linestr);
6330 PL_multi_end = CopLINE(PL_curcop);
6331 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
6332 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
6333 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
6335 SvREFCNT_dec(herewas);
6336 PL_lex_stuff = tmpstr;
6337 yylval.ival = op_type;
6342 takes: current position in input buffer
6343 returns: new position in input buffer
6344 side-effects: yylval and lex_op are set.
6349 <FH> read from filehandle
6350 <pkg::FH> read from package qualified filehandle
6351 <pkg'FH> read from package qualified filehandle
6352 <$fh> read from filehandle in $fh
6358 S_scan_inputsymbol(pTHX_ char *start)
6360 register char *s = start; /* current position in buffer */
6366 d = PL_tokenbuf; /* start of temp holding space */
6367 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
6368 end = strchr(s, '\n');
6371 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
6373 /* die if we didn't have space for the contents of the <>,
6374 or if it didn't end, or if we see a newline
6377 if (len >= sizeof PL_tokenbuf)
6378 Perl_croak(aTHX_ "Excessively long <> operator");
6380 Perl_croak(aTHX_ "Unterminated <> operator");
6385 Remember, only scalar variables are interpreted as filehandles by
6386 this code. Anything more complex (e.g., <$fh{$num}>) will be
6387 treated as a glob() call.
6388 This code makes use of the fact that except for the $ at the front,
6389 a scalar variable and a filehandle look the same.
6391 if (*d == '$' && d[1]) d++;
6393 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
6394 while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
6397 /* If we've tried to read what we allow filehandles to look like, and
6398 there's still text left, then it must be a glob() and not a getline.
6399 Use scan_str to pull out the stuff between the <> and treat it
6400 as nothing more than a string.
6403 if (d - PL_tokenbuf != len) {
6404 yylval.ival = OP_GLOB;
6406 s = scan_str(start,FALSE,FALSE);
6408 Perl_croak(aTHX_ "Glob not terminated");
6412 /* we're in a filehandle read situation */
6415 /* turn <> into <ARGV> */
6417 (void)strcpy(d,"ARGV");
6419 /* if <$fh>, create the ops to turn the variable into a
6425 /* try to find it in the pad for this block, otherwise find
6426 add symbol table ops
6428 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
6429 OP *o = newOP(OP_PADSV, 0);
6431 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, o);
6434 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
6435 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
6436 newUNOP(OP_RV2SV, 0,
6437 newGVOP(OP_GV, 0, gv)));
6439 PL_lex_op->op_flags |= OPf_SPECIAL;
6440 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
6441 yylval.ival = OP_NULL;
6444 /* If it's none of the above, it must be a literal filehandle
6445 (<Foo::BAR> or <FOO>) so build a simple readline OP */
6447 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
6448 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
6449 yylval.ival = OP_NULL;
6458 takes: start position in buffer
6459 keep_quoted preserve \ on the embedded delimiter(s)
6460 keep_delims preserve the delimiters around the string
6461 returns: position to continue reading from buffer
6462 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
6463 updates the read buffer.
6465 This subroutine pulls a string out of the input. It is called for:
6466 q single quotes q(literal text)
6467 ' single quotes 'literal text'
6468 qq double quotes qq(interpolate $here please)
6469 " double quotes "interpolate $here please"
6470 qx backticks qx(/bin/ls -l)
6471 ` backticks `/bin/ls -l`
6472 qw quote words @EXPORT_OK = qw( func() $spam )
6473 m// regexp match m/this/
6474 s/// regexp substitute s/this/that/
6475 tr/// string transliterate tr/this/that/
6476 y/// string transliterate y/this/that/
6477 ($*@) sub prototypes sub foo ($)
6478 (stuff) sub attr parameters sub foo : attr(stuff)
6479 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
6481 In most of these cases (all but <>, patterns and transliterate)
6482 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
6483 calls scan_str(). s/// makes yylex() call scan_subst() which calls
6484 scan_str(). tr/// and y/// make yylex() call scan_trans() which
6487 It skips whitespace before the string starts, and treats the first
6488 character as the delimiter. If the delimiter is one of ([{< then
6489 the corresponding "close" character )]}> is used as the closing
6490 delimiter. It allows quoting of delimiters, and if the string has
6491 balanced delimiters ([{<>}]) it allows nesting.
6493 The lexer always reads these strings into lex_stuff, except in the
6494 case of the operators which take *two* arguments (s/// and tr///)
6495 when it checks to see if lex_stuff is full (presumably with the 1st
6496 arg to s or tr) and if so puts the string into lex_repl.
6501 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
6504 SV *sv; /* scalar value: string */
6505 char *tmps; /* temp string, used for delimiter matching */
6506 register char *s = start; /* current position in the buffer */
6507 register char term; /* terminating character */
6508 register char *to; /* current position in the sv's data */
6509 I32 brackets = 1; /* bracket nesting level */
6510 bool has_utf = FALSE; /* is there any utf8 content? */
6512 /* skip space before the delimiter */
6516 /* mark where we are, in case we need to report errors */
6519 /* after skipping whitespace, the next character is the terminator */
6521 if ((term & 0x80) && UTF)
6524 /* mark where we are */
6525 PL_multi_start = CopLINE(PL_curcop);
6526 PL_multi_open = term;
6528 /* find corresponding closing delimiter */
6529 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
6531 PL_multi_close = term;
6533 /* create a new SV to hold the contents. 87 is leak category, I'm
6534 assuming. 79 is the SV's initial length. What a random number. */
6536 sv_upgrade(sv, SVt_PVIV);
6538 (void)SvPOK_only(sv); /* validate pointer */
6540 /* move past delimiter and try to read a complete string */
6542 sv_catpvn(sv, s, 1);
6545 /* extend sv if need be */
6546 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
6547 /* set 'to' to the next character in the sv's string */
6548 to = SvPVX(sv)+SvCUR(sv);
6550 /* if open delimiter is the close delimiter read unbridle */
6551 if (PL_multi_open == PL_multi_close) {
6552 for (; s < PL_bufend; s++,to++) {
6553 /* embedded newlines increment the current line number */
6554 if (*s == '\n' && !PL_rsfp)
6555 CopLINE_inc(PL_curcop);
6556 /* handle quoted delimiters */
6557 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
6558 if (!keep_quoted && s[1] == term)
6560 /* any other quotes are simply copied straight through */
6564 /* terminate when run out of buffer (the for() condition), or
6565 have found the terminator */
6566 else if (*s == term)
6568 else if (!has_utf && (*s & 0x80) && UTF)
6574 /* if the terminator isn't the same as the start character (e.g.,
6575 matched brackets), we have to allow more in the quoting, and
6576 be prepared for nested brackets.
6579 /* read until we run out of string, or we find the terminator */
6580 for (; s < PL_bufend; s++,to++) {
6581 /* embedded newlines increment the line count */
6582 if (*s == '\n' && !PL_rsfp)
6583 CopLINE_inc(PL_curcop);
6584 /* backslashes can escape the open or closing characters */
6585 if (*s == '\\' && s+1 < PL_bufend) {
6587 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
6592 /* allow nested opens and closes */
6593 else if (*s == PL_multi_close && --brackets <= 0)
6595 else if (*s == PL_multi_open)
6597 else if (!has_utf && (*s & 0x80) && UTF)
6602 /* terminate the copied string and update the sv's end-of-string */
6604 SvCUR_set(sv, to - SvPVX(sv));
6607 * this next chunk reads more into the buffer if we're not done yet
6611 break; /* handle case where we are done yet :-) */
6613 #ifndef PERL_STRICT_CR
6614 if (to - SvPVX(sv) >= 2) {
6615 if ((to[-2] == '\r' && to[-1] == '\n') ||
6616 (to[-2] == '\n' && to[-1] == '\r'))
6620 SvCUR_set(sv, to - SvPVX(sv));
6622 else if (to[-1] == '\r')
6625 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
6629 /* if we're out of file, or a read fails, bail and reset the current
6630 line marker so we can report where the unterminated string began
6633 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6635 CopLINE_set(PL_curcop, PL_multi_start);
6638 /* we read a line, so increment our line counter */
6639 CopLINE_inc(PL_curcop);
6641 /* update debugger info */
6642 if (PERLDB_LINE && PL_curstash != PL_debstash) {
6643 SV *sv = NEWSV(88,0);
6645 sv_upgrade(sv, SVt_PVMG);
6646 sv_setsv(sv,PL_linestr);
6647 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop), sv);
6650 /* having changed the buffer, we must update PL_bufend */
6651 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6654 /* at this point, we have successfully read the delimited string */
6657 sv_catpvn(sv, s, 1);
6660 PL_multi_end = CopLINE(PL_curcop);
6663 /* if we allocated too much space, give some back */
6664 if (SvCUR(sv) + 5 < SvLEN(sv)) {
6665 SvLEN_set(sv, SvCUR(sv) + 1);
6666 Renew(SvPVX(sv), SvLEN(sv), char);
6669 /* decide whether this is the first or second quoted string we've read
6682 takes: pointer to position in buffer
6683 returns: pointer to new position in buffer
6684 side-effects: builds ops for the constant in yylval.op
6686 Read a number in any of the formats that Perl accepts:
6688 0(x[0-7A-F]+)|([0-7]+)|(b[01])
6689 [\d_]+(\.[\d_]*)?[Ee](\d+)
6691 Underbars (_) are allowed in decimal numbers. If -w is on,
6692 underbars before a decimal point must be at three digit intervals.
6694 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
6697 If it reads a number without a decimal point or an exponent, it will
6698 try converting the number to an integer and see if it can do so
6699 without loss of precision.
6703 Perl_scan_num(pTHX_ char *start)
6705 register char *s = start; /* current position in buffer */
6706 register char *d; /* destination in temp buffer */
6707 register char *e; /* end of temp buffer */
6708 NV nv; /* number read, as a double */
6709 SV *sv = Nullsv; /* place to put the converted number */
6710 bool floatit; /* boolean: int or float? */
6711 char *lastub = 0; /* position of last underbar */
6712 static char number_too_long[] = "Number too long";
6714 /* We use the first character to decide what type of number this is */
6718 Perl_croak(aTHX_ "panic: scan_num");
6720 /* if it starts with a 0, it could be an octal number, a decimal in
6721 0.13 disguise, or a hexadecimal number, or a binary number. */
6725 u holds the "number so far"
6726 shift the power of 2 of the base
6727 (hex == 4, octal == 3, binary == 1)
6728 overflowed was the number more than we can hold?
6730 Shift is used when we add a digit. It also serves as an "are
6731 we in octal/hex/binary?" indicator to disallow hex characters
6738 bool overflowed = FALSE;
6739 static NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
6740 static char* bases[5] = { "", "binary", "", "octal",
6742 static char* Bases[5] = { "", "Binary", "", "Octal",
6744 static char *maxima[5] = { "",
6745 "0b11111111111111111111111111111111",
6749 char *base, *Base, *max;
6755 } else if (s[1] == 'b') {
6759 /* check for a decimal in disguise */
6760 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
6762 /* so it must be octal */
6766 base = bases[shift];
6767 Base = Bases[shift];
6768 max = maxima[shift];
6770 /* read the rest of the number */
6772 /* x is used in the overflow test,
6773 b is the digit we're adding on. */
6778 /* if we don't mention it, we're done */
6787 /* 8 and 9 are not octal */
6790 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
6794 case '2': case '3': case '4':
6795 case '5': case '6': case '7':
6797 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
6801 b = *s++ & 15; /* ASCII digit -> value of digit */
6805 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
6806 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
6807 /* make sure they said 0x */
6812 /* Prepare to put the digit we have onto the end
6813 of the number so far. We check for overflows.
6818 x = u << shift; /* make room for the digit */
6820 if ((x >> shift) != u
6821 && !(PL_hints & HINT_NEW_BINARY)) {
6825 if (ckWARN_d(WARN_OVERFLOW))
6826 Perl_warner(aTHX_ WARN_OVERFLOW,
6827 "Integer overflow in %s number",
6830 u = x | b; /* add the digit to the end */
6833 n *= nvshift[shift];
6834 /* If an NV has not enough bits in its
6835 * mantissa to represent an UV this summing of
6836 * small low-order numbers is a waste of time
6837 * (because the NV cannot preserve the
6838 * low-order bits anyway): we could just
6839 * remember when did we overflow and in the
6840 * end just multiply n by the right
6848 /* if we get here, we had success: make a scalar value from
6855 if (ckWARN(WARN_PORTABLE) && n > 4294967295.0)
6856 Perl_warner(aTHX_ WARN_PORTABLE,
6857 "%s number > %s non-portable",
6864 if (ckWARN(WARN_PORTABLE) && u > 0xffffffff)
6865 Perl_warner(aTHX_ WARN_PORTABLE,
6866 "%s number > %s non-portable",
6871 if (PL_hints & HINT_NEW_BINARY)
6872 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
6877 handle decimal numbers.
6878 we're also sent here when we read a 0 as the first digit
6880 case '1': case '2': case '3': case '4': case '5':
6881 case '6': case '7': case '8': case '9': case '.':
6884 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
6887 /* read next group of digits and _ and copy into d */
6888 while (isDIGIT(*s) || *s == '_') {
6889 /* skip underscores, checking for misplaced ones
6893 dTHR; /* only for ckWARN */
6894 if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
6895 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
6899 /* check for end of fixed-length buffer */
6901 Perl_croak(aTHX_ number_too_long);
6902 /* if we're ok, copy the character */
6907 /* final misplaced underbar check */
6908 if (lastub && s - lastub != 3) {
6910 if (ckWARN(WARN_SYNTAX))
6911 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
6914 /* read a decimal portion if there is one. avoid
6915 3..5 being interpreted as the number 3. followed
6918 if (*s == '.' && s[1] != '.') {
6922 /* copy, ignoring underbars, until we run out of
6923 digits. Note: no misplaced underbar checks!
6925 for (; isDIGIT(*s) || *s == '_'; s++) {
6926 /* fixed length buffer check */
6928 Perl_croak(aTHX_ number_too_long);
6932 if (*s == '.' && isDIGIT(s[1])) {
6933 /* oops, it's really a v-string, but without the "v" */
6939 /* read exponent part, if present */
6940 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
6944 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
6945 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
6947 /* allow positive or negative exponent */
6948 if (*s == '+' || *s == '-')
6951 /* read digits of exponent (no underbars :-) */
6952 while (isDIGIT(*s)) {
6954 Perl_croak(aTHX_ number_too_long);
6959 /* terminate the string */
6962 /* make an sv from the string */
6965 #if defined(Strtol) && defined(Strtoul)
6968 strtol/strtoll sets errno to ERANGE if the number is too big
6969 for an integer. We try to do an integer conversion first
6970 if no characters indicating "float" have been found.
6977 if (*PL_tokenbuf == '-')
6978 iv = Strtol(PL_tokenbuf, (char**)NULL, 10);
6980 uv = Strtoul(PL_tokenbuf, (char**)NULL, 10);
6982 floatit = TRUE; /* Probably just too large. */
6983 else if (*PL_tokenbuf == '-')
6985 else if (uv <= IV_MAX)
6986 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
6991 nv = Atof(PL_tokenbuf);
6996 No working strtou?ll?.
6998 Unfortunately atol() doesn't do range checks (returning
6999 LONG_MIN/LONG_MAX, and setting errno to ERANGE on overflows)
7000 everywhere [1], so we cannot use use atol() (or atoll()).
7001 If we could, they would be used, as Atol(), very much like
7002 Strtol() and Strtoul() are used above.
7004 [1] XXX Configure test needed to check for atol()
7005 (and atoll() overflow behaviour) XXX --jhi
7007 We need to do this the hard way. */
7009 nv = Atof(PL_tokenbuf);
7011 /* See if we can make do with an integer value without loss of
7012 precision. We use U_V to cast to a UV, because some
7013 compilers have issues. Then we try casting it back and see
7014 if it was the same [1]. We only do this if we know we
7015 specifically read an integer. If floatit is true, then we
7016 don't need to do the conversion at all.
7018 [1] Note that this is lossy if our NVs cannot preserve our
7019 UVs. There is a metaconfig define, NV_PRESERVES_UV, but we
7020 really do hope all such platforms have strtou?ll? to do a
7021 lossless IV/UV conversion.
7022 XXX Configure test needed to check how many UV bits
7023 do our NVs preserve, really (the current test checks
7024 for the roundtrip of ~0) XXX --jhi
7025 Maybe do some tricks with DBL_MANT_DIG and LDBL_MANT_DIG,
7026 and DBL_DIG, LDBL_DIG (this is already available as NV_DIG)?
7030 if (!floatit && (NV)uv == nv) {
7032 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
7040 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
7041 (PL_hints & HINT_NEW_INTEGER) )
7042 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
7043 (floatit ? "float" : "integer"),
7047 /* if it starts with a v, it could be a v-string */
7053 while (isDIGIT(*pos) || *pos == '_')
7055 if (!isALPHA(*pos)) {
7057 U8 tmpbuf[UTF8_MAXLEN];
7060 s++; /* get past 'v' */
7063 sv_setpvn(sv, "", 0);
7066 if (*s == '0' && isDIGIT(s[1]))
7067 yyerror("Octal number in vector unsupported");
7070 /* this is atoi() that tolerates underscores */
7073 while (--end >= s) {
7078 rev += (*end - '0') * mult;
7080 if (orev > rev && ckWARN_d(WARN_OVERFLOW))
7081 Perl_warner(aTHX_ WARN_OVERFLOW,
7082 "Integer overflow in decimal number");
7085 tmpend = uv_to_utf8(tmpbuf, rev);
7086 utf8 = utf8 || rev > 127;
7087 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
7088 if (*pos == '.' && isDIGIT(pos[1]))
7094 while (isDIGIT(*pos) || *pos == '_')
7102 sv_utf8_downgrade(sv, TRUE);
7109 /* make the op for the constant and return */
7112 yylval.opval = newSVOP(OP_CONST, 0, sv);
7114 yylval.opval = Nullop;
7120 S_scan_formline(pTHX_ register char *s)
7125 SV *stuff = newSVpvn("",0);
7126 bool needargs = FALSE;
7129 if (*s == '.' || *s == '}') {
7131 #ifdef PERL_STRICT_CR
7132 for (t = s+1;*t == ' ' || *t == '\t'; t++) ;
7134 for (t = s+1;*t == ' ' || *t == '\t' || *t == '\r'; t++) ;
7136 if (*t == '\n' || t == PL_bufend)
7139 if (PL_in_eval && !PL_rsfp) {
7140 eol = strchr(s,'\n');
7145 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7147 for (t = s; t < eol; t++) {
7148 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
7150 goto enough; /* ~~ must be first line in formline */
7152 if (*t == '@' || *t == '^')
7155 sv_catpvn(stuff, s, eol-s);
7156 #ifndef PERL_STRICT_CR
7157 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
7158 char *end = SvPVX(stuff) + SvCUR(stuff);
7167 s = filter_gets(PL_linestr, PL_rsfp, 0);
7168 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
7169 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
7172 yyerror("Format not terminated");
7182 PL_lex_state = LEX_NORMAL;
7183 PL_nextval[PL_nexttoke].ival = 0;
7187 PL_lex_state = LEX_FORMLINE;
7188 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
7190 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
7194 SvREFCNT_dec(stuff);
7195 PL_lex_formbrack = 0;
7206 PL_cshlen = strlen(PL_cshname);
7211 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
7214 I32 oldsavestack_ix = PL_savestack_ix;
7215 CV* outsidecv = PL_compcv;
7219 assert(SvTYPE(PL_compcv) == SVt_PVCV);
7221 SAVEI32(PL_subline);
7222 save_item(PL_subname);
7225 SAVESPTR(PL_comppad_name);
7226 SAVESPTR(PL_compcv);
7227 SAVEI32(PL_comppad_name_fill);
7228 SAVEI32(PL_min_intro_pending);
7229 SAVEI32(PL_max_intro_pending);
7230 SAVEI32(PL_pad_reset_pending);
7232 PL_compcv = (CV*)NEWSV(1104,0);
7233 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
7234 CvFLAGS(PL_compcv) |= flags;
7236 PL_comppad = newAV();
7237 av_push(PL_comppad, Nullsv);
7238 PL_curpad = AvARRAY(PL_comppad);
7239 PL_comppad_name = newAV();
7240 PL_comppad_name_fill = 0;
7241 PL_min_intro_pending = 0;
7243 PL_subline = CopLINE(PL_curcop);
7245 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
7246 PL_curpad[0] = (SV*)newAV();
7247 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
7248 #endif /* USE_THREADS */
7250 comppadlist = newAV();
7251 AvREAL_off(comppadlist);
7252 av_store(comppadlist, 0, (SV*)PL_comppad_name);
7253 av_store(comppadlist, 1, (SV*)PL_comppad);
7255 CvPADLIST(PL_compcv) = comppadlist;
7256 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
7258 CvOWNER(PL_compcv) = 0;
7259 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
7260 MUTEX_INIT(CvMUTEXP(PL_compcv));
7261 #endif /* USE_THREADS */
7263 return oldsavestack_ix;
7267 Perl_yywarn(pTHX_ char *s)
7270 PL_in_eval |= EVAL_WARNONLY;
7272 PL_in_eval &= ~EVAL_WARNONLY;
7277 Perl_yyerror(pTHX_ char *s)
7281 char *context = NULL;
7285 if (!yychar || (yychar == ';' && !PL_rsfp))
7287 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
7288 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
7289 while (isSPACE(*PL_oldoldbufptr))
7291 context = PL_oldoldbufptr;
7292 contlen = PL_bufptr - PL_oldoldbufptr;
7294 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
7295 PL_oldbufptr != PL_bufptr) {
7296 while (isSPACE(*PL_oldbufptr))
7298 context = PL_oldbufptr;
7299 contlen = PL_bufptr - PL_oldbufptr;
7301 else if (yychar > 255)
7302 where = "next token ???";
7303 #ifdef USE_PURE_BISON
7304 /* GNU Bison sets the value -2 */
7305 else if (yychar == -2) {
7307 else if ((yychar & 127) == 127) {
7309 if (PL_lex_state == LEX_NORMAL ||
7310 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
7311 where = "at end of line";
7312 else if (PL_lex_inpat)
7313 where = "within pattern";
7315 where = "within string";
7318 SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
7320 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
7321 else if (isPRINT_LC(yychar))
7322 Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
7324 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
7325 where = SvPVX(where_sv);
7327 msg = sv_2mortal(newSVpv(s, 0));
7328 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
7329 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
7331 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
7333 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
7334 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
7335 Perl_sv_catpvf(aTHX_ msg,
7336 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
7337 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
7340 if (PL_in_eval & EVAL_WARNONLY)
7341 Perl_warn(aTHX_ "%"SVf, msg);
7344 if (PL_error_count >= 10) {
7345 if (PL_in_eval && SvCUR(ERRSV))
7346 Perl_croak(aTHX_ "%_%s has too many errors.\n",
7347 ERRSV, CopFILE(PL_curcop));
7349 Perl_croak(aTHX_ "%s has too many errors.\n",
7350 CopFILE(PL_curcop));
7353 PL_in_my_stash = Nullhv;
7364 * Restore a source filter.
7368 restore_rsfp(pTHXo_ void *f)
7370 PerlIO *fp = (PerlIO*)f;
7372 if (PL_rsfp == PerlIO_stdin())
7373 PerlIO_clearerr(PL_rsfp);
7374 else if (PL_rsfp && (PL_rsfp != fp))
7375 PerlIO_close(PL_rsfp);