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
68 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
70 # include <unistd.h> /* Needed for execv() */
79 YYSTYPE* yylval_pointer = NULL;
80 int* yychar_pointer = NULL;
83 # define yylval (*yylval_pointer)
84 # define yychar (*yychar_pointer)
85 # define PERL_YYLEX_PARAM yylval_pointer,yychar_pointer
87 # define yylex() Perl_yylex(aTHX_ yylval_pointer, yychar_pointer)
92 /* CLINE is a macro that ensures PL_copline has a sane value */
97 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
100 * Convenience functions to return different tokens and prime the
101 * lexer for the next token. They all take an argument.
103 * TOKEN : generic token (used for '(', DOLSHARP, etc)
104 * OPERATOR : generic operator
105 * AOPERATOR : assignment operator
106 * PREBLOCK : beginning the block after an if, while, foreach, ...
107 * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
108 * PREREF : *EXPR where EXPR is not a simple identifier
109 * TERM : expression term
110 * LOOPX : loop exiting command (goto, last, dump, etc)
111 * FTST : file test operator
112 * FUN0 : zero-argument function
113 * FUN1 : not used, except for not, which isn't a UNIOP
114 * BOop : bitwise or or xor
116 * SHop : shift operator
117 * PWop : power operator
118 * PMop : pattern-matching operator
119 * Aop : addition-level operator
120 * Mop : multiplication-level operator
121 * Eop : equality-testing operator
122 * Rop : relational operator <= != gt
124 * Also see LOP and lop() below.
127 #define TOKEN(retval) return (PL_bufptr = s,(int)retval)
128 #define OPERATOR(retval) return (PL_expect = XTERM,PL_bufptr = s,(int)retval)
129 #define AOPERATOR(retval) return ao((PL_expect = XTERM,PL_bufptr = s,(int)retval))
130 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s,(int)retval)
131 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval)
132 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s,(int)retval)
133 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR,PL_bufptr = s,(int)retval)
134 #define LOOPX(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX)
135 #define FTST(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)UNIOP)
136 #define FUN0(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0)
137 #define FUN1(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1)
138 #define BOop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITOROP))
139 #define BAop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP))
140 #define SHop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP))
141 #define PWop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)POWOP))
142 #define PMop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP)
143 #define Aop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)ADDOP))
144 #define Mop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MULOP))
145 #define Eop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)EQOP)
146 #define Rop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)RELOP)
148 /* This bit of chicanery makes a unary function followed by
149 * a parenthesis into a function with one argument, highest precedence.
151 #define UNI(f) return(yylval.ival = f, \
154 PL_last_uni = PL_oldbufptr, \
155 PL_last_lop_op = f, \
156 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
158 #define UNIBRACK(f) return(yylval.ival = f, \
160 PL_last_uni = PL_oldbufptr, \
161 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
163 /* grandfather return to old style */
164 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
169 * This subroutine detects &&= and ||= and turns an ANDAND or OROR
170 * into an OP_ANDASSIGN or OP_ORASSIGN
174 S_ao(pTHX_ int toketype)
176 if (*PL_bufptr == '=') {
178 if (toketype == ANDAND)
179 yylval.ival = OP_ANDASSIGN;
180 else if (toketype == OROR)
181 yylval.ival = OP_ORASSIGN;
189 * When Perl expects an operator and finds something else, no_op
190 * prints the warning. It always prints "<something> found where
191 * operator expected. It prints "Missing semicolon on previous line?"
192 * if the surprise occurs at the start of the line. "do you need to
193 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
194 * where the compiler doesn't know if foo is a method call or a function.
195 * It prints "Missing operator before end of line" if there's nothing
196 * after the missing operator, or "... before <...>" if there is something
197 * after the missing operator.
201 S_no_op(pTHX_ char *what, char *s)
203 char *oldbp = PL_bufptr;
204 bool is_first = (PL_oldbufptr == PL_linestart);
212 yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
214 Perl_warn(aTHX_ "\t(Missing semicolon on previous line?)\n");
215 else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
217 for (t = PL_oldoldbufptr; *t && (isALNUM_lazy_if(t,UTF) || *t == ':'); t++) ;
218 if (t < PL_bufptr && isSPACE(*t))
219 Perl_warn(aTHX_ "\t(Do you need to predeclare %.*s?)\n",
220 t - PL_oldoldbufptr, PL_oldoldbufptr);
223 Perl_warn(aTHX_ "\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
229 * Complain about missing quote/regexp/heredoc terminator.
230 * If it's called with (char *)NULL then it cauterizes the line buffer.
231 * If we're in a delimited string and the delimiter is a control
232 * character, it's reformatted into a two-char sequence like ^C.
237 S_missingterm(pTHX_ char *s)
242 char *nl = strrchr(s,'\n');
248 iscntrl(PL_multi_close)
250 PL_multi_close < 32 || PL_multi_close == 127
254 tmpbuf[1] = toCTRL(PL_multi_close);
260 *tmpbuf = PL_multi_close;
264 q = strchr(s,'"') ? '\'' : '"';
265 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
273 Perl_deprecate(pTHX_ char *s)
276 if (ckWARN(WARN_DEPRECATED))
277 Perl_warner(aTHX_ WARN_DEPRECATED, "Use of %s is deprecated", s);
282 * Deprecate a comma-less variable list.
288 deprecate("comma-less variable list");
292 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
293 * utf16-to-utf8-reversed.
296 #ifdef PERL_CR_FILTER
300 register char *s = SvPVX(sv);
301 register char *e = s + SvCUR(sv);
302 /* outer loop optimized to do nothing if there are no CR-LFs */
304 if (*s++ == '\r' && *s == '\n') {
305 /* hit a CR-LF, need to copy the rest */
306 register char *d = s - 1;
309 if (*s == '\r' && s[1] == '\n')
320 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
322 I32 count = FILTER_READ(idx+1, sv, maxlen);
323 if (count > 0 && !maxlen)
330 S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
332 I32 count = FILTER_READ(idx+1, sv, maxlen);
336 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
337 tend = utf16_to_utf8((U16*)SvPVX(sv), tmps, SvCUR(sv));
338 sv_usepvn(sv, (char*)tmps, tend - tmps);
345 S_utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
347 I32 count = FILTER_READ(idx+1, sv, maxlen);
351 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
352 tend = utf16_to_utf8_reversed((U16*)SvPVX(sv), tmps, SvCUR(sv));
353 sv_usepvn(sv, (char*)tmps, tend - tmps);
361 * Initialize variables. Uses the Perl save_stack to save its state (for
362 * recursive calls to the parser).
366 Perl_lex_start(pTHX_ SV *line)
372 SAVEI32(PL_lex_dojoin);
373 SAVEI32(PL_lex_brackets);
374 SAVEI32(PL_lex_casemods);
375 SAVEI32(PL_lex_starts);
376 SAVEI32(PL_lex_state);
377 SAVEVPTR(PL_lex_inpat);
378 SAVEI32(PL_lex_inwhat);
379 if (PL_lex_state == LEX_KNOWNEXT) {
380 I32 toke = PL_nexttoke;
381 while (--toke >= 0) {
382 SAVEI32(PL_nexttype[toke]);
383 SAVEVPTR(PL_nextval[toke]);
385 SAVEI32(PL_nexttoke);
388 SAVECOPLINE(PL_curcop);
391 SAVEPPTR(PL_oldbufptr);
392 SAVEPPTR(PL_oldoldbufptr);
393 SAVEPPTR(PL_linestart);
394 SAVESPTR(PL_linestr);
395 SAVEPPTR(PL_lex_brackstack);
396 SAVEPPTR(PL_lex_casestack);
397 SAVEDESTRUCTOR_X(restore_rsfp, PL_rsfp);
398 SAVESPTR(PL_lex_stuff);
399 SAVEI32(PL_lex_defer);
400 SAVEI32(PL_sublex_info.sub_inwhat);
401 SAVESPTR(PL_lex_repl);
403 SAVEINT(PL_lex_expect);
405 PL_lex_state = LEX_NORMAL;
409 New(899, PL_lex_brackstack, 120, char);
410 New(899, PL_lex_casestack, 12, char);
411 SAVEFREEPV(PL_lex_brackstack);
412 SAVEFREEPV(PL_lex_casestack);
414 *PL_lex_casestack = '\0';
417 PL_lex_stuff = Nullsv;
418 PL_lex_repl = Nullsv;
421 PL_sublex_info.sub_inwhat = 0;
423 if (SvREADONLY(PL_linestr))
424 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
425 s = SvPV(PL_linestr, len);
426 if (len && s[len-1] != ';') {
427 if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
428 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
429 sv_catpvn(PL_linestr, "\n;", 2);
431 SvTEMP_off(PL_linestr);
432 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
433 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
435 PL_rs = newSVpvn("\n", 1);
441 * Finalizer for lexing operations. Must be called when the parser is
442 * done with the lexer.
448 PL_doextract = FALSE;
453 * This subroutine has nothing to do with tilting, whether at windmills
454 * or pinball tables. Its name is short for "increment line". It
455 * increments the current line number in CopLINE(PL_curcop) and checks
456 * to see whether the line starts with a comment of the form
457 * # line 500 "foo.pm"
458 * If so, it sets the current line number and file to the values in the comment.
462 S_incline(pTHX_ char *s)
470 CopLINE_inc(PL_curcop);
473 while (*s == ' ' || *s == '\t') s++;
474 if (strnEQ(s, "line", 4))
478 if (*s == ' ' || *s == '\t')
482 while (*s == ' ' || *s == '\t') s++;
488 while (*s == ' ' || *s == '\t')
490 if (*s == '"' && (t = strchr(s+1, '"'))) {
495 for (t = s; !isSPACE(*t); t++) ;
498 while (*e == ' ' || *e == '\t' || *e == '\r' || *e == '\f')
500 if (*e != '\n' && *e != '\0')
501 return; /* false alarm */
506 CopFILE_set(PL_curcop, s);
508 CopLINE_set(PL_curcop, atoi(n)-1);
513 * Called to gobble the appropriate amount and type of whitespace.
514 * Skips comments as well.
518 S_skipspace(pTHX_ register char *s)
521 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
522 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
528 SSize_t oldprevlen, oldoldprevlen;
529 SSize_t oldloplen, oldunilen;
530 while (s < PL_bufend && isSPACE(*s)) {
531 if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
536 if (s < PL_bufend && *s == '#') {
537 while (s < PL_bufend && *s != '\n')
541 if (PL_in_eval && !PL_rsfp) {
548 /* only continue to recharge the buffer if we're at the end
549 * of the buffer, we're not reading from a source filter, and
550 * we're in normal lexing mode
552 if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat ||
553 PL_lex_state == LEX_FORMLINE)
556 /* try to recharge the buffer */
557 if ((s = filter_gets(PL_linestr, PL_rsfp,
558 (prevlen = SvCUR(PL_linestr)))) == Nullch)
560 /* end of file. Add on the -p or -n magic */
561 if (PL_minus_n || PL_minus_p) {
562 sv_setpv(PL_linestr,PL_minus_p ?
563 ";}continue{print or die qq(-p destination: $!\\n)" :
565 sv_catpv(PL_linestr,";}");
566 PL_minus_n = PL_minus_p = 0;
569 sv_setpv(PL_linestr,";");
571 /* reset variables for next time we lex */
572 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
574 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
576 /* Close the filehandle. Could be from -P preprocessor,
577 * STDIN, or a regular file. If we were reading code from
578 * STDIN (because the commandline held no -e or filename)
579 * then we don't close it, we reset it so the code can
580 * read from STDIN too.
583 if (PL_preprocess && !PL_in_eval)
584 (void)PerlProc_pclose(PL_rsfp);
585 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
586 PerlIO_clearerr(PL_rsfp);
588 (void)PerlIO_close(PL_rsfp);
593 /* not at end of file, so we only read another line */
594 /* make corresponding updates to old pointers, for yyerror() */
595 oldprevlen = PL_oldbufptr - PL_bufend;
596 oldoldprevlen = PL_oldoldbufptr - PL_bufend;
598 oldunilen = PL_last_uni - PL_bufend;
600 oldloplen = PL_last_lop - PL_bufend;
601 PL_linestart = PL_bufptr = s + prevlen;
602 PL_bufend = s + SvCUR(PL_linestr);
604 PL_oldbufptr = s + oldprevlen;
605 PL_oldoldbufptr = s + oldoldprevlen;
607 PL_last_uni = s + oldunilen;
609 PL_last_lop = s + oldloplen;
612 /* debugger active and we're not compiling the debugger code,
613 * so store the line into the debugger's array of lines
615 if (PERLDB_LINE && PL_curstash != PL_debstash) {
616 SV *sv = NEWSV(85,0);
618 sv_upgrade(sv, SVt_PVMG);
619 sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
620 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
627 * Check the unary operators to ensure there's no ambiguity in how they're
628 * used. An ambiguous piece of code would be:
630 * This doesn't mean rand() + 5. Because rand() is a unary operator,
631 * the +5 is its argument.
641 if (PL_oldoldbufptr != PL_last_uni)
643 while (isSPACE(*PL_last_uni))
645 for (s = PL_last_uni; isALNUM_lazy_if(s,UTF) || *s == '-'; s++) ;
646 if ((t = strchr(s, '(')) && t < PL_bufptr)
648 if (ckWARN_d(WARN_AMBIGUOUS)){
651 Perl_warner(aTHX_ WARN_AMBIGUOUS,
652 "Warning: Use of \"%s\" without parens is ambiguous",
658 /* workaround to replace the UNI() macro with a function. Only the
659 * hints/uts.sh file mentions this. Other comments elsewhere in the
660 * source indicate Microport Unix might need it too.
666 #define UNI(f) return uni(f,s)
669 S_uni(pTHX_ I32 f, char *s)
674 PL_last_uni = PL_oldbufptr;
685 #endif /* CRIPPLED_CC */
688 * LOP : macro to build a list operator. Its behaviour has been replaced
689 * with a subroutine, S_lop() for which LOP is just another name.
692 #define LOP(f,x) return lop(f,x,s)
696 * Build a list operator (or something that might be one). The rules:
697 * - if we have a next token, then it's a list operator [why?]
698 * - if the next thing is an opening paren, then it's a function
699 * - else it's a list operator
703 S_lop(pTHX_ I32 f, int x, char *s)
710 PL_last_lop = PL_oldbufptr;
725 * When the lexer realizes it knows the next token (for instance,
726 * it is reordering tokens for the parser) then it can call S_force_next
727 * to know what token to return the next time the lexer is called. Caller
728 * will need to set PL_nextval[], and possibly PL_expect to ensure the lexer
729 * handles the token correctly.
733 S_force_next(pTHX_ I32 type)
735 PL_nexttype[PL_nexttoke] = type;
737 if (PL_lex_state != LEX_KNOWNEXT) {
738 PL_lex_defer = PL_lex_state;
739 PL_lex_expect = PL_expect;
740 PL_lex_state = LEX_KNOWNEXT;
746 * When the lexer knows the next thing is a word (for instance, it has
747 * just seen -> and it knows that the next char is a word char, then
748 * it calls S_force_word to stick the next word into the PL_next lookahead.
751 * char *start : buffer position (must be within PL_linestr)
752 * int token : PL_next will be this type of bare word (e.g., METHOD,WORD)
753 * int check_keyword : if true, Perl checks to make sure the word isn't
754 * a keyword (do this if the word is a label, e.g. goto FOO)
755 * int allow_pack : if true, : characters will also be allowed (require,
757 * int allow_initial_tick : used by the "sub" lexer only.
761 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
766 start = skipspace(start);
768 if (isIDFIRST_lazy_if(s,UTF) ||
769 (allow_pack && *s == ':') ||
770 (allow_initial_tick && *s == '\'') )
772 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
773 if (check_keyword && keyword(PL_tokenbuf, len))
775 if (token == METHOD) {
780 PL_expect = XOPERATOR;
783 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(PL_tokenbuf,0));
784 PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
792 * Called when the lexer wants $foo *foo &foo etc, but the program
793 * text only contains the "foo" portion. The first argument is a pointer
794 * to the "foo", and the second argument is the type symbol to prefix.
795 * Forces the next token to be a "WORD".
796 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
800 S_force_ident(pTHX_ register char *s, int kind)
803 OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
804 PL_nextval[PL_nexttoke].opval = o;
807 dTHR; /* just for in_eval */
808 o->op_private = OPpCONST_ENTERED;
809 /* XXX see note in pp_entereval() for why we forgo typo
810 warnings if the symbol must be introduced in an eval.
812 gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
813 kind == '$' ? SVt_PV :
814 kind == '@' ? SVt_PVAV :
815 kind == '%' ? SVt_PVHV :
824 * Forces the next token to be a version number.
828 S_force_version(pTHX_ char *s)
830 OP *version = Nullop;
834 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
838 for (; isDIGIT(*d) || *d == '_' || *d == '.'; d++);
839 if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
841 /* real VERSION number -- GBARR */
842 version = yylval.opval;
846 /* NOTE: The parser sees the package name and the VERSION swapped */
847 PL_nextval[PL_nexttoke].opval = version;
855 * Tokenize a quoted string passed in as an SV. It finds the next
856 * chunk, up to end of string or a backslash. It may make a new
857 * SV containing that chunk (if HINT_NEW_STRING is on). It also
862 S_tokeq(pTHX_ SV *sv)
873 s = SvPV_force(sv, len);
877 while (s < send && *s != '\\')
882 if ( PL_hints & HINT_NEW_STRING )
883 pv = sv_2mortal(newSVpvn(SvPVX(pv), len));
886 if (s + 1 < send && (s[1] == '\\'))
887 s++; /* all that, just for this */
892 SvCUR_set(sv, d - SvPVX(sv));
894 if ( PL_hints & HINT_NEW_STRING )
895 return new_constant(NULL, 0, "q", sv, pv, "q");
900 * Now come three functions related to double-quote context,
901 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
902 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
903 * interact with PL_lex_state, and create fake ( ... ) argument lists
904 * to handle functions and concatenation.
905 * They assume that whoever calls them will be setting up a fake
906 * join call, because each subthing puts a ',' after it. This lets
909 * join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
911 * (I'm not sure whether the spurious commas at the end of lcfirst's
912 * arguments and join's arguments are created or not).
917 * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST).
919 * Pattern matching will set PL_lex_op to the pattern-matching op to
920 * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise).
922 * OP_CONST and OP_READLINE are easy--just make the new op and return.
924 * Everything else becomes a FUNC.
926 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
927 * had an OP_CONST or OP_READLINE). This just sets us up for a
928 * call to S_sublex_push().
934 register I32 op_type = yylval.ival;
936 if (op_type == OP_NULL) {
937 yylval.opval = PL_lex_op;
941 if (op_type == OP_CONST || op_type == OP_READLINE) {
942 SV *sv = tokeq(PL_lex_stuff);
944 if (SvTYPE(sv) == SVt_PVIV) {
945 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
951 nsv = newSVpvn(p, len);
955 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
956 PL_lex_stuff = Nullsv;
960 PL_sublex_info.super_state = PL_lex_state;
961 PL_sublex_info.sub_inwhat = op_type;
962 PL_sublex_info.sub_op = PL_lex_op;
963 PL_lex_state = LEX_INTERPPUSH;
967 yylval.opval = PL_lex_op;
977 * Create a new scope to save the lexing state. The scope will be
978 * ended in S_sublex_done. Returns a '(', starting the function arguments
979 * to the uc, lc, etc. found before.
980 * Sets PL_lex_state to LEX_INTERPCONCAT.
989 PL_lex_state = PL_sublex_info.super_state;
990 SAVEI32(PL_lex_dojoin);
991 SAVEI32(PL_lex_brackets);
992 SAVEI32(PL_lex_casemods);
993 SAVEI32(PL_lex_starts);
994 SAVEI32(PL_lex_state);
995 SAVEVPTR(PL_lex_inpat);
996 SAVEI32(PL_lex_inwhat);
997 SAVECOPLINE(PL_curcop);
999 SAVEPPTR(PL_oldbufptr);
1000 SAVEPPTR(PL_oldoldbufptr);
1001 SAVEPPTR(PL_linestart);
1002 SAVESPTR(PL_linestr);
1003 SAVEPPTR(PL_lex_brackstack);
1004 SAVEPPTR(PL_lex_casestack);
1006 PL_linestr = PL_lex_stuff;
1007 PL_lex_stuff = Nullsv;
1009 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
1010 = SvPVX(PL_linestr);
1011 PL_bufend += SvCUR(PL_linestr);
1012 SAVEFREESV(PL_linestr);
1014 PL_lex_dojoin = FALSE;
1015 PL_lex_brackets = 0;
1016 New(899, PL_lex_brackstack, 120, char);
1017 New(899, PL_lex_casestack, 12, char);
1018 SAVEFREEPV(PL_lex_brackstack);
1019 SAVEFREEPV(PL_lex_casestack);
1020 PL_lex_casemods = 0;
1021 *PL_lex_casestack = '\0';
1023 PL_lex_state = LEX_INTERPCONCAT;
1024 CopLINE_set(PL_curcop, PL_multi_start);
1026 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1027 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1028 PL_lex_inpat = PL_sublex_info.sub_op;
1030 PL_lex_inpat = Nullop;
1037 * Restores lexer state after a S_sublex_push.
1043 if (!PL_lex_starts++) {
1044 PL_expect = XOPERATOR;
1045 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpvn("",0));
1049 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
1050 PL_lex_state = LEX_INTERPCASEMOD;
1054 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1055 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1056 PL_linestr = PL_lex_repl;
1058 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1059 PL_bufend += SvCUR(PL_linestr);
1060 SAVEFREESV(PL_linestr);
1061 PL_lex_dojoin = FALSE;
1062 PL_lex_brackets = 0;
1063 PL_lex_casemods = 0;
1064 *PL_lex_casestack = '\0';
1066 if (SvEVALED(PL_lex_repl)) {
1067 PL_lex_state = LEX_INTERPNORMAL;
1069 /* we don't clear PL_lex_repl here, so that we can check later
1070 whether this is an evalled subst; that means we rely on the
1071 logic to ensure sublex_done() is called again only via the
1072 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1075 PL_lex_state = LEX_INTERPCONCAT;
1076 PL_lex_repl = Nullsv;
1082 PL_bufend = SvPVX(PL_linestr);
1083 PL_bufend += SvCUR(PL_linestr);
1084 PL_expect = XOPERATOR;
1085 PL_sublex_info.sub_inwhat = 0;
1093 Extracts a pattern, double-quoted string, or transliteration. This
1096 It looks at lex_inwhat and PL_lex_inpat to find out whether it's
1097 processing a pattern (PL_lex_inpat is true), a transliteration
1098 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
1100 Returns a pointer to the character scanned up to. Iff this is
1101 advanced from the start pointer supplied (ie if anything was
1102 successfully parsed), will leave an OP for the substring scanned
1103 in yylval. Caller must intuit reason for not parsing further
1104 by looking at the next characters herself.
1108 double-quoted style: \r and \n
1109 regexp special ones: \D \s
1111 backrefs: \1 (deprecated in substitution replacements)
1112 case and quoting: \U \Q \E
1113 stops on @ and $, but not for $ as tail anchor
1115 In transliterations:
1116 characters are VERY literal, except for - not at the start or end
1117 of the string, which indicates a range. scan_const expands the
1118 range to the full set of intermediate characters.
1120 In double-quoted strings:
1122 double-quoted style: \r and \n
1124 backrefs: \1 (deprecated)
1125 case and quoting: \U \Q \E
1128 scan_const does *not* construct ops to handle interpolated strings.
1129 It stops processing as soon as it finds an embedded $ or @ variable
1130 and leaves it to the caller to work out what's going on.
1132 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
1134 $ in pattern could be $foo or could be tail anchor. Assumption:
1135 it's a tail anchor if $ is the last thing in the string, or if it's
1136 followed by one of ")| \n\t"
1138 \1 (backreferences) are turned into $1
1140 The structure of the code is
1141 while (there's a character to process) {
1142 handle transliteration ranges
1143 skip regexp comments
1144 skip # initiated comments in //x patterns
1145 check for embedded @foo
1146 check for embedded scalars
1148 leave intact backslashes from leave (below)
1149 deprecate \1 in strings and sub replacements
1150 handle string-changing backslashes \l \U \Q \E, etc.
1151 switch (what was escaped) {
1152 handle - in a transliteration (becomes a literal -)
1153 handle \132 octal characters
1154 handle 0x15 hex characters
1155 handle \cV (control V)
1156 handle printf backslashes (\f, \r, \n, etc)
1158 } (end if backslash)
1159 } (end while character to read)
1164 S_scan_const(pTHX_ char *start)
1166 register char *send = PL_bufend; /* end of the constant */
1167 SV *sv = NEWSV(93, send - start); /* sv for the constant */
1168 register char *s = start; /* start of the constant */
1169 register char *d = SvPVX(sv); /* destination for copies */
1170 bool dorange = FALSE; /* are we in a translit range? */
1171 bool has_utf = FALSE; /* embedded \x{} */
1173 I32 utf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op)
1174 ? (PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
1176 I32 thisutf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op)
1177 ? (PL_sublex_info.sub_op->op_private & (PL_lex_repl ?
1178 OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF))
1180 const char *leaveit = /* set of acceptably-backslashed characters */
1182 ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
1185 while (s < send || dorange) {
1186 /* get transliterations out of the way (they're most literal) */
1187 if (PL_lex_inwhat == OP_TRANS) {
1188 /* expand a range A-Z to the full set of characters. AIE! */
1190 I32 i; /* current expanded character */
1191 I32 min; /* first character in range */
1192 I32 max; /* last character in range */
1194 i = d - SvPVX(sv); /* remember current offset */
1195 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
1196 d = SvPVX(sv) + i; /* refresh d after realloc */
1197 d -= 2; /* eat the first char and the - */
1199 min = (U8)*d; /* first char in range */
1200 max = (U8)d[1]; /* last char in range */
1203 if ((isLOWER(min) && isLOWER(max)) ||
1204 (isUPPER(min) && isUPPER(max))) {
1206 for (i = min; i <= max; i++)
1210 for (i = min; i <= max; i++)
1217 for (i = min; i <= max; i++)
1220 /* mark the range as done, and continue */
1225 /* range begins (ignore - as first or last char) */
1226 else if (*s == '-' && s+1 < send && s != start) {
1228 *d++ = (char)0xff; /* use illegal utf8 byte--see pmtrans */
1237 /* if we get here, we're not doing a transliteration */
1239 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
1240 except for the last char, which will be done separately. */
1241 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
1243 while (s < send && *s != ')')
1245 } else if (s[2] == '{'
1246 || s[2] == 'p' && s[3] == '{') { /* This should march regcomp.c */
1248 char *regparse = s + (s[2] == '{' ? 3 : 4);
1251 while (count && (c = *regparse)) {
1252 if (c == '\\' && regparse[1])
1260 if (*regparse != ')') {
1261 regparse--; /* Leave one char for continuation. */
1262 yyerror("Sequence (?{...}) not terminated or not {}-balanced");
1264 while (s < regparse)
1269 /* likewise skip #-initiated comments in //x patterns */
1270 else if (*s == '#' && PL_lex_inpat &&
1271 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
1272 while (s+1 < send && *s != '\n')
1276 /* check for embedded arrays (@foo, @:foo, @'foo, @{foo}, @$foo) */
1277 else if (*s == '@' && s[1]
1278 && (isALNUM_lazy_if(s+1,UTF) || strchr(":'{$", s[1])))
1281 /* check for embedded scalars. only stop if we're sure it's a
1284 else if (*s == '$') {
1285 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
1287 if (s + 1 < send && !strchr("()| \n\t", s[1]))
1288 break; /* in regexp, $ might be tail anchor */
1291 /* (now in tr/// code again) */
1293 if (*s & 0x80 && thisutf) {
1294 dTHR; /* only for ckWARN */
1295 if (ckWARN(WARN_UTF8)) {
1296 (void)utf8_to_uv((U8*)s, &len); /* could cvt latin-1 to utf8 here... */
1305 has_utf = TRUE; /* assume valid utf8 */
1309 if (*s == '\\' && s+1 < send) {
1312 /* some backslashes we leave behind */
1313 if (*leaveit && *s && strchr(leaveit, *s)) {
1319 /* deprecate \1 in strings and substitution replacements */
1320 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1321 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1323 dTHR; /* only for ckWARN */
1324 if (ckWARN(WARN_SYNTAX))
1325 Perl_warner(aTHX_ WARN_SYNTAX, "\\%c better written as $%c", *s, *s);
1330 /* string-change backslash escapes */
1331 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1336 /* if we get here, it's either a quoted -, or a digit */
1339 /* quoted - in transliterations */
1341 if (PL_lex_inwhat == OP_TRANS) {
1349 if (ckWARN(WARN_UNSAFE) && isALPHA(*s))
1350 Perl_warner(aTHX_ WARN_UNSAFE,
1351 "Unrecognized escape \\%c passed through",
1353 /* default action is to copy the quoted character */
1358 /* \132 indicates an octal constant */
1359 case '0': case '1': case '2': case '3':
1360 case '4': case '5': case '6': case '7':
1361 *d++ = (char)scan_oct(s, 3, &len);
1365 /* \x24 indicates a hex constant */
1369 char* e = strchr(s, '}');
1373 yyerror("Missing right brace on \\x{}");
1376 /* note: utf always shorter than hex */
1377 uv = (UV)scan_hex(s + 1, e - s - 1, &len);
1379 d = (char*)uv_to_utf8((U8*)d, uv);
1387 /* XXX collapse this branch into the one above */
1388 UV uv = (UV)scan_hex(s, 2, &len);
1389 if (utf && PL_lex_inwhat == OP_TRANS &&
1390 utf != (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
1392 d = (char*)uv_to_utf8((U8*)d, uv); /* doing a CU or UC */
1396 if (uv >= 127 && UTF) {
1398 if (ckWARN(WARN_UTF8))
1399 Perl_warner(aTHX_ WARN_UTF8,
1400 "\\x%.*s will produce malformed UTF-8 character; use \\x{%.*s} for that",
1401 (int)len,s,(int)len,s);
1409 /* \N{latin small letter a} is a named character */
1413 char* e = strchr(s, '}');
1422 yyerror("Missing right brace on \\N{}");
1426 res = newSVpvn(s + 1, e - s - 1);
1427 res = new_constant( Nullch, 0, "charnames",
1428 res, Nullsv, "\\N{...}" );
1429 str = SvPV(res,len);
1430 if (len > e - s + 4) {
1431 char *odest = SvPVX(sv);
1433 SvGROW(sv, (SvCUR(sv) + len - (e - s + 4)));
1434 d = SvPVX(sv) + (d - odest);
1436 Copy(str, d, len, char);
1443 yyerror("Missing braces on \\N{}");
1446 /* \c is a control character */
1460 /* printf-style backslashes, formfeeds, newlines, etc */
1478 *d++ = '\047'; /* CP 1047 */
1481 *d++ = '\057'; /* CP 1047 */
1495 } /* end if (backslash) */
1498 } /* while loop to process each character */
1500 /* terminate the string and set up the sv */
1502 SvCUR_set(sv, d - SvPVX(sv));
1507 /* shrink the sv if we allocated more than we used */
1508 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1509 SvLEN_set(sv, SvCUR(sv) + 1);
1510 Renew(SvPVX(sv), SvLEN(sv), char);
1513 /* return the substring (via yylval) only if we parsed anything */
1514 if (s > PL_bufptr) {
1515 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1516 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1518 ( PL_lex_inwhat == OP_TRANS
1520 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1523 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1530 * Returns TRUE if there's more to the expression (e.g., a subscript),
1533 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
1535 * ->[ and ->{ return TRUE
1536 * { and [ outside a pattern are always subscripts, so return TRUE
1537 * if we're outside a pattern and it's not { or [, then return FALSE
1538 * if we're in a pattern and the first char is a {
1539 * {4,5} (any digits around the comma) returns FALSE
1540 * if we're in a pattern and the first char is a [
1542 * [SOMETHING] has a funky algorithm to decide whether it's a
1543 * character class or not. It has to deal with things like
1544 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
1545 * anything else returns TRUE
1548 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1551 S_intuit_more(pTHX_ register char *s)
1553 if (PL_lex_brackets)
1555 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1557 if (*s != '{' && *s != '[')
1562 /* In a pattern, so maybe we have {n,m}. */
1579 /* On the other hand, maybe we have a character class */
1582 if (*s == ']' || *s == '^')
1585 /* this is terrifying, and it works */
1586 int weight = 2; /* let's weigh the evidence */
1588 unsigned char un_char = 255, last_un_char;
1589 char *send = strchr(s,']');
1590 char tmpbuf[sizeof PL_tokenbuf * 4];
1592 if (!send) /* has to be an expression */
1595 Zero(seen,256,char);
1598 else if (isDIGIT(*s)) {
1600 if (isDIGIT(s[1]) && s[2] == ']')
1606 for (; s < send; s++) {
1607 last_un_char = un_char;
1608 un_char = (unsigned char)*s;
1613 weight -= seen[un_char] * 10;
1614 if (isALNUM_lazy_if(s+1,UTF)) {
1615 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1616 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1621 else if (*s == '$' && s[1] &&
1622 strchr("[#!%*<>()-=",s[1])) {
1623 if (/*{*/ strchr("])} =",s[2]))
1632 if (strchr("wds]",s[1]))
1634 else if (seen['\''] || seen['"'])
1636 else if (strchr("rnftbxcav",s[1]))
1638 else if (isDIGIT(s[1])) {
1640 while (s[1] && isDIGIT(s[1]))
1650 if (strchr("aA01! ",last_un_char))
1652 if (strchr("zZ79~",s[1]))
1654 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1655 weight -= 5; /* cope with negative subscript */
1658 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1659 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1664 if (keyword(tmpbuf, d - tmpbuf))
1667 if (un_char == last_un_char + 1)
1669 weight -= seen[un_char];
1674 if (weight >= 0) /* probably a character class */
1684 * Does all the checking to disambiguate
1686 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
1687 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
1689 * First argument is the stuff after the first token, e.g. "bar".
1691 * Not a method if bar is a filehandle.
1692 * Not a method if foo is a subroutine prototyped to take a filehandle.
1693 * Not a method if it's really "Foo $bar"
1694 * Method if it's "foo $bar"
1695 * Not a method if it's really "print foo $bar"
1696 * Method if it's really "foo package::" (interpreted as package->foo)
1697 * Not a method if bar is known to be a subroutne ("sub bar; foo bar")
1698 * Not a method if bar is a filehandle or package, but is quoted with
1703 S_intuit_method(pTHX_ char *start, GV *gv)
1705 char *s = start + (*start == '$');
1706 char tmpbuf[sizeof PL_tokenbuf];
1714 if ((cv = GvCVu(gv))) {
1715 char *proto = SvPVX(cv);
1725 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1726 /* start is the beginning of the possible filehandle/object,
1727 * and s is the end of it
1728 * tmpbuf is a copy of it
1731 if (*start == '$') {
1732 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1737 return *s == '(' ? FUNCMETH : METHOD;
1739 if (!keyword(tmpbuf, len)) {
1740 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1745 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1746 if (indirgv && GvCVu(indirgv))
1748 /* filehandle or package name makes it a method */
1749 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1751 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1752 return 0; /* no assumptions -- "=>" quotes bearword */
1754 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1755 newSVpvn(tmpbuf,len));
1756 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1760 return *s == '(' ? FUNCMETH : METHOD;
1768 * Return a string of Perl code to load the debugger. If PERL5DB
1769 * is set, it will return the contents of that, otherwise a
1770 * compile-time require of perl5db.pl.
1777 char *pdb = PerlEnv_getenv("PERL5DB");
1781 SETERRNO(0,SS$_NORMAL);
1782 return "BEGIN { require 'perl5db.pl' }";
1788 /* Encoded script support. filter_add() effectively inserts a
1789 * 'pre-processing' function into the current source input stream.
1790 * Note that the filter function only applies to the current source file
1791 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1793 * The datasv parameter (which may be NULL) can be used to pass
1794 * private data to this instance of the filter. The filter function
1795 * can recover the SV using the FILTER_DATA macro and use it to
1796 * store private buffers and state information.
1798 * The supplied datasv parameter is upgraded to a PVIO type
1799 * and the IoDIRP field is used to store the function pointer,
1800 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
1801 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1802 * private use must be set using malloc'd pointers.
1806 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
1811 if (!PL_rsfp_filters)
1812 PL_rsfp_filters = newAV();
1814 datasv = NEWSV(255,0);
1815 if (!SvUPGRADE(datasv, SVt_PVIO))
1816 Perl_die(aTHX_ "Can't upgrade filter_add data to SVt_PVIO");
1817 IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
1818 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
1819 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
1820 funcp, SvPV_nolen(datasv)));
1821 av_unshift(PL_rsfp_filters, 1);
1822 av_store(PL_rsfp_filters, 0, datasv) ;
1827 /* Delete most recently added instance of this filter function. */
1829 Perl_filter_del(pTHX_ filter_t funcp)
1832 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", funcp));
1833 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
1835 /* if filter is on top of stack (usual case) just pop it off */
1836 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
1837 if (IoDIRP(datasv) == (DIR*)funcp) {
1838 IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
1839 IoDIRP(datasv) = (DIR*)NULL;
1840 sv_free(av_pop(PL_rsfp_filters));
1844 /* we need to search for the correct entry and clear it */
1845 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
1849 /* Invoke the n'th filter function for the current rsfp. */
1851 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
1854 /* 0 = read one text line */
1859 if (!PL_rsfp_filters)
1861 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
1862 /* Provide a default input filter to make life easy. */
1863 /* Note that we append to the line. This is handy. */
1864 DEBUG_P(PerlIO_printf(Perl_debug_log,
1865 "filter_read %d: from rsfp\n", idx));
1869 int old_len = SvCUR(buf_sv) ;
1871 /* ensure buf_sv is large enough */
1872 SvGROW(buf_sv, old_len + maxlen) ;
1873 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1874 if (PerlIO_error(PL_rsfp))
1875 return -1; /* error */
1877 return 0 ; /* end of file */
1879 SvCUR_set(buf_sv, old_len + len) ;
1882 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
1883 if (PerlIO_error(PL_rsfp))
1884 return -1; /* error */
1886 return 0 ; /* end of file */
1889 return SvCUR(buf_sv);
1891 /* Skip this filter slot if filter has been deleted */
1892 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
1893 DEBUG_P(PerlIO_printf(Perl_debug_log,
1894 "filter_read %d: skipped (filter deleted)\n",
1896 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1898 /* Get function pointer hidden within datasv */
1899 funcp = (filter_t)IoDIRP(datasv);
1900 DEBUG_P(PerlIO_printf(Perl_debug_log,
1901 "filter_read %d: via function %p (%s)\n",
1902 idx, funcp, SvPV_nolen(datasv)));
1903 /* Call function. The function is expected to */
1904 /* call "FILTER_READ(idx+1, buf_sv)" first. */
1905 /* Return: <0:error, =0:eof, >0:not eof */
1906 return (*funcp)(aTHXo_ idx, buf_sv, maxlen);
1910 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
1912 #ifdef PERL_CR_FILTER
1913 if (!PL_rsfp_filters) {
1914 filter_add(S_cr_textfilter,NULL);
1917 if (PL_rsfp_filters) {
1920 SvCUR_set(sv, 0); /* start with empty line */
1921 if (FILTER_READ(0, sv, 0) > 0)
1922 return ( SvPVX(sv) ) ;
1927 return (sv_gets(sv, fp, append));
1932 static char* exp_name[] =
1933 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
1934 "ATTRTERM", "TERMBLOCK"
1941 Works out what to call the token just pulled out of the input
1942 stream. The yacc parser takes care of taking the ops we return and
1943 stitching them into a tree.
1949 if read an identifier
1950 if we're in a my declaration
1951 croak if they tried to say my($foo::bar)
1952 build the ops for a my() declaration
1953 if it's an access to a my() variable
1954 are we in a sort block?
1955 croak if my($a); $a <=> $b
1956 build ops for access to a my() variable
1957 if in a dq string, and they've said @foo and we can't find @foo
1959 build ops for a bareword
1960 if we already built the token before, use it.
1964 #ifdef USE_PURE_BISON
1965 Perl_yylex(pTHX_ YYSTYPE *lvalp, int *lcharp)
1978 #ifdef USE_PURE_BISON
1979 yylval_pointer = lvalp;
1980 yychar_pointer = lcharp;
1983 /* check if there's an identifier for us to look at */
1984 if (PL_pending_ident) {
1985 /* pit holds the identifier we read and pending_ident is reset */
1986 char pit = PL_pending_ident;
1987 PL_pending_ident = 0;
1989 /* if we're in a my(), we can't allow dynamics here.
1990 $foo'bar has already been turned into $foo::bar, so
1991 just check for colons.
1993 if it's a legal name, the OP is a PADANY.
1996 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
1997 if (strchr(PL_tokenbuf,':'))
1998 yyerror(Perl_form(aTHX_ "No package name allowed for "
1999 "variable %s in \"our\"",
2001 tmp = pad_allocmy(PL_tokenbuf);
2004 if (strchr(PL_tokenbuf,':'))
2005 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
2007 yylval.opval = newOP(OP_PADANY, 0);
2008 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
2014 build the ops for accesses to a my() variable.
2016 Deny my($a) or my($b) in a sort block, *if* $a or $b is
2017 then used in a comparison. This catches most, but not
2018 all cases. For instance, it catches
2019 sort { my($a); $a <=> $b }
2021 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
2022 (although why you'd do that is anyone's guess).
2025 if (!strchr(PL_tokenbuf,':')) {
2027 /* Check for single character per-thread SVs */
2028 if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
2029 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
2030 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
2032 yylval.opval = newOP(OP_THREADSV, 0);
2033 yylval.opval->op_targ = tmp;
2036 #endif /* USE_THREADS */
2037 if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
2038 SV *namesv = AvARRAY(PL_comppad_name)[tmp];
2039 /* might be an "our" variable" */
2040 if (SvFLAGS(namesv) & SVpad_OUR) {
2041 /* build ops for a bareword */
2042 SV *sym = newSVpv(HvNAME(GvSTASH(namesv)),0);
2043 sv_catpvn(sym, "::", 2);
2044 sv_catpv(sym, PL_tokenbuf+1);
2045 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
2046 yylval.opval->op_private = OPpCONST_ENTERED;
2047 gv_fetchpv(SvPVX(sym),
2049 ? (GV_ADDMULTI | GV_ADDINEVAL)
2052 ((PL_tokenbuf[0] == '$') ? SVt_PV
2053 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
2058 /* if it's a sort block and they're naming $a or $b */
2059 if (PL_last_lop_op == OP_SORT &&
2060 PL_tokenbuf[0] == '$' &&
2061 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
2064 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
2065 d < PL_bufend && *d != '\n';
2068 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
2069 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
2075 yylval.opval = newOP(OP_PADANY, 0);
2076 yylval.opval->op_targ = tmp;
2082 Whine if they've said @foo in a doublequoted string,
2083 and @foo isn't a variable we can find in the symbol
2086 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
2087 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
2088 if (!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
2089 yyerror(Perl_form(aTHX_ "In string, %s now must be written as \\%s",
2090 PL_tokenbuf, PL_tokenbuf));
2093 /* build ops for a bareword */
2094 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
2095 yylval.opval->op_private = OPpCONST_ENTERED;
2096 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
2097 ((PL_tokenbuf[0] == '$') ? SVt_PV
2098 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
2103 /* no identifier pending identification */
2105 switch (PL_lex_state) {
2107 case LEX_NORMAL: /* Some compilers will produce faster */
2108 case LEX_INTERPNORMAL: /* code if we comment these out. */
2112 /* when we've already built the next token, just pull it out of the queue */
2115 yylval = PL_nextval[PL_nexttoke];
2117 PL_lex_state = PL_lex_defer;
2118 PL_expect = PL_lex_expect;
2119 PL_lex_defer = LEX_NORMAL;
2121 return(PL_nexttype[PL_nexttoke]);
2123 /* interpolated case modifiers like \L \U, including \Q and \E.
2124 when we get here, PL_bufptr is at the \
2126 case LEX_INTERPCASEMOD:
2128 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
2129 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
2131 /* handle \E or end of string */
2132 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
2136 if (PL_lex_casemods) {
2137 oldmod = PL_lex_casestack[--PL_lex_casemods];
2138 PL_lex_casestack[PL_lex_casemods] = '\0';
2140 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
2142 PL_lex_state = LEX_INTERPCONCAT;
2146 if (PL_bufptr != PL_bufend)
2148 PL_lex_state = LEX_INTERPCONCAT;
2153 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
2154 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
2155 if (strchr("LU", *s) &&
2156 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
2158 PL_lex_casestack[--PL_lex_casemods] = '\0';
2161 if (PL_lex_casemods > 10) {
2162 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
2163 if (newlb != PL_lex_casestack) {
2165 PL_lex_casestack = newlb;
2168 PL_lex_casestack[PL_lex_casemods++] = *s;
2169 PL_lex_casestack[PL_lex_casemods] = '\0';
2170 PL_lex_state = LEX_INTERPCONCAT;
2171 PL_nextval[PL_nexttoke].ival = 0;
2174 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
2176 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
2178 PL_nextval[PL_nexttoke].ival = OP_LC;
2180 PL_nextval[PL_nexttoke].ival = OP_UC;
2182 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
2184 Perl_croak(aTHX_ "panic: yylex");
2187 if (PL_lex_starts) {
2196 case LEX_INTERPPUSH:
2197 return sublex_push();
2199 case LEX_INTERPSTART:
2200 if (PL_bufptr == PL_bufend)
2201 return sublex_done();
2203 PL_lex_dojoin = (*PL_bufptr == '@');
2204 PL_lex_state = LEX_INTERPNORMAL;
2205 if (PL_lex_dojoin) {
2206 PL_nextval[PL_nexttoke].ival = 0;
2209 PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
2210 PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
2211 force_next(PRIVATEREF);
2213 force_ident("\"", '$');
2214 #endif /* USE_THREADS */
2215 PL_nextval[PL_nexttoke].ival = 0;
2217 PL_nextval[PL_nexttoke].ival = 0;
2219 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
2222 if (PL_lex_starts++) {
2228 case LEX_INTERPENDMAYBE:
2229 if (intuit_more(PL_bufptr)) {
2230 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
2236 if (PL_lex_dojoin) {
2237 PL_lex_dojoin = FALSE;
2238 PL_lex_state = LEX_INTERPCONCAT;
2241 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
2242 && SvEVALED(PL_lex_repl))
2244 if (PL_bufptr != PL_bufend)
2245 Perl_croak(aTHX_ "Bad evalled substitution pattern");
2246 PL_lex_repl = Nullsv;
2249 case LEX_INTERPCONCAT:
2251 if (PL_lex_brackets)
2252 Perl_croak(aTHX_ "panic: INTERPCONCAT");
2254 if (PL_bufptr == PL_bufend)
2255 return sublex_done();
2257 if (SvIVX(PL_linestr) == '\'') {
2258 SV *sv = newSVsv(PL_linestr);
2261 else if ( PL_hints & HINT_NEW_RE )
2262 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
2263 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2267 s = scan_const(PL_bufptr);
2269 PL_lex_state = LEX_INTERPCASEMOD;
2271 PL_lex_state = LEX_INTERPSTART;
2274 if (s != PL_bufptr) {
2275 PL_nextval[PL_nexttoke] = yylval;
2278 if (PL_lex_starts++)
2288 PL_lex_state = LEX_NORMAL;
2289 s = scan_formline(PL_bufptr);
2290 if (!PL_lex_formbrack)
2296 PL_oldoldbufptr = PL_oldbufptr;
2299 PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at %s\n",
2300 exp_name[PL_expect], s);
2306 if (isIDFIRST_lazy_if(s,UTF))
2308 Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
2311 goto fake_eof; /* emulate EOF on ^D or ^Z */
2316 if (PL_lex_brackets)
2317 yyerror("Missing right curly or square bracket");
2320 if (s++ < PL_bufend)
2321 goto retry; /* ignore stray nulls */
2324 if (!PL_in_eval && !PL_preambled) {
2325 PL_preambled = TRUE;
2326 sv_setpv(PL_linestr,incl_perldb());
2327 if (SvCUR(PL_linestr))
2328 sv_catpv(PL_linestr,";");
2330 while(AvFILLp(PL_preambleav) >= 0) {
2331 SV *tmpsv = av_shift(PL_preambleav);
2332 sv_catsv(PL_linestr, tmpsv);
2333 sv_catpv(PL_linestr, ";");
2336 sv_free((SV*)PL_preambleav);
2337 PL_preambleav = NULL;
2339 if (PL_minus_n || PL_minus_p) {
2340 sv_catpv(PL_linestr, "LINE: while (<>) {");
2342 sv_catpv(PL_linestr,"chomp;");
2344 GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
2346 GvIMPORTED_AV_on(gv);
2348 if (strchr("/'\"", *PL_splitstr)
2349 && strchr(PL_splitstr + 1, *PL_splitstr))
2350 Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s);", PL_splitstr);
2353 s = "'~#\200\1'"; /* surely one char is unused...*/
2354 while (s[1] && strchr(PL_splitstr, *s)) s++;
2356 Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s%c",
2357 "q" + (delim == '\''), delim);
2358 for (s = PL_splitstr; *s; s++) {
2360 sv_catpvn(PL_linestr, "\\", 1);
2361 sv_catpvn(PL_linestr, s, 1);
2363 Perl_sv_catpvf(aTHX_ PL_linestr, "%c);", delim);
2367 sv_catpv(PL_linestr,"@F=split(' ');");
2370 sv_catpv(PL_linestr, "\n");
2371 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2372 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2373 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2374 SV *sv = NEWSV(85,0);
2376 sv_upgrade(sv, SVt_PVMG);
2377 sv_setsv(sv,PL_linestr);
2378 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2383 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
2386 if (PL_preprocess && !PL_in_eval)
2387 (void)PerlProc_pclose(PL_rsfp);
2388 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2389 PerlIO_clearerr(PL_rsfp);
2391 (void)PerlIO_close(PL_rsfp);
2393 PL_doextract = FALSE;
2395 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2396 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
2397 sv_catpv(PL_linestr,";}");
2398 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2399 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2400 PL_minus_n = PL_minus_p = 0;
2403 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2404 sv_setpv(PL_linestr,"");
2405 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
2408 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
2409 PL_doextract = FALSE;
2411 /* Incest with pod. */
2412 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2413 sv_setpv(PL_linestr, "");
2414 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2415 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2416 PL_doextract = FALSE;
2420 } while (PL_doextract);
2421 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2422 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2423 SV *sv = NEWSV(85,0);
2425 sv_upgrade(sv, SVt_PVMG);
2426 sv_setsv(sv,PL_linestr);
2427 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2429 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2430 if (CopLINE(PL_curcop) == 1) {
2431 while (s < PL_bufend && isSPACE(*s))
2433 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2437 if (*s == '#' && *(s+1) == '!')
2439 #ifdef ALTERNATE_SHEBANG
2441 static char as[] = ALTERNATE_SHEBANG;
2442 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2443 d = s + (sizeof(as) - 1);
2445 #endif /* ALTERNATE_SHEBANG */
2454 while (*d && !isSPACE(*d))
2458 #ifdef ARG_ZERO_IS_SCRIPT
2459 if (ipathend > ipath) {
2461 * HP-UX (at least) sets argv[0] to the script name,
2462 * which makes $^X incorrect. And Digital UNIX and Linux,
2463 * at least, set argv[0] to the basename of the Perl
2464 * interpreter. So, having found "#!", we'll set it right.
2466 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
2467 assert(SvPOK(x) || SvGMAGICAL(x));
2468 if (sv_eq(x, CopFILESV(PL_curcop))) {
2469 sv_setpvn(x, ipath, ipathend - ipath);
2472 TAINT_NOT; /* $^X is always tainted, but that's OK */
2474 #endif /* ARG_ZERO_IS_SCRIPT */
2479 d = instr(s,"perl -");
2481 d = instr(s,"perl");
2483 /* avoid getting into infinite loops when shebang
2484 * line contains "Perl" rather than "perl" */
2486 for (d = ipathend-4; d >= ipath; --d) {
2487 if ((*d == 'p' || *d == 'P')
2488 && !ibcmp(d, "perl", 4))
2498 #ifdef ALTERNATE_SHEBANG
2500 * If the ALTERNATE_SHEBANG on this system starts with a
2501 * character that can be part of a Perl expression, then if
2502 * we see it but not "perl", we're probably looking at the
2503 * start of Perl code, not a request to hand off to some
2504 * other interpreter. Similarly, if "perl" is there, but
2505 * not in the first 'word' of the line, we assume the line
2506 * contains the start of the Perl program.
2508 if (d && *s != '#') {
2510 while (*c && !strchr("; \t\r\n\f\v#", *c))
2513 d = Nullch; /* "perl" not in first word; ignore */
2515 *s = '#'; /* Don't try to parse shebang line */
2517 #endif /* ALTERNATE_SHEBANG */
2522 !instr(s,"indir") &&
2523 instr(PL_origargv[0],"perl"))
2529 while (s < PL_bufend && isSPACE(*s))
2531 if (s < PL_bufend) {
2532 Newz(899,newargv,PL_origargc+3,char*);
2534 while (s < PL_bufend && !isSPACE(*s))
2537 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2540 newargv = PL_origargv;
2542 PerlProc_execv(ipath, newargv);
2543 Perl_croak(aTHX_ "Can't exec %s", ipath);
2546 U32 oldpdb = PL_perldb;
2547 bool oldn = PL_minus_n;
2548 bool oldp = PL_minus_p;
2550 while (*d && !isSPACE(*d)) d++;
2551 while (*d == ' ' || *d == '\t') d++;
2555 if (*d == 'M' || *d == 'm') {
2557 while (*d && !isSPACE(*d)) d++;
2558 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2561 d = moreswitches(d);
2563 if (PERLDB_LINE && !oldpdb ||
2564 ( PL_minus_n || PL_minus_p ) && !(oldn || oldp) )
2565 /* if we have already added "LINE: while (<>) {",
2566 we must not do it again */
2568 sv_setpv(PL_linestr, "");
2569 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2570 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2571 PL_preambled = FALSE;
2573 (void)gv_fetchfile(PL_origfilename);
2580 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2582 PL_lex_state = LEX_FORMLINE;
2587 #ifdef PERL_STRICT_CR
2588 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2590 "(Maybe you didn't strip carriage returns after a network transfer?)\n");
2592 case ' ': case '\t': case '\f': case 013:
2597 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2599 while (s < d && *s != '\n')
2604 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2606 PL_lex_state = LEX_FORMLINE;
2616 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2621 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2624 if (strnEQ(s,"=>",2)) {
2625 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2626 OPERATOR('-'); /* unary minus */
2628 PL_last_uni = PL_oldbufptr;
2629 PL_last_lop_op = OP_FTEREAD; /* good enough */
2631 case 'r': FTST(OP_FTEREAD);
2632 case 'w': FTST(OP_FTEWRITE);
2633 case 'x': FTST(OP_FTEEXEC);
2634 case 'o': FTST(OP_FTEOWNED);
2635 case 'R': FTST(OP_FTRREAD);
2636 case 'W': FTST(OP_FTRWRITE);
2637 case 'X': FTST(OP_FTREXEC);
2638 case 'O': FTST(OP_FTROWNED);
2639 case 'e': FTST(OP_FTIS);
2640 case 'z': FTST(OP_FTZERO);
2641 case 's': FTST(OP_FTSIZE);
2642 case 'f': FTST(OP_FTFILE);
2643 case 'd': FTST(OP_FTDIR);
2644 case 'l': FTST(OP_FTLINK);
2645 case 'p': FTST(OP_FTPIPE);
2646 case 'S': FTST(OP_FTSOCK);
2647 case 'u': FTST(OP_FTSUID);
2648 case 'g': FTST(OP_FTSGID);
2649 case 'k': FTST(OP_FTSVTX);
2650 case 'b': FTST(OP_FTBLK);
2651 case 'c': FTST(OP_FTCHR);
2652 case 't': FTST(OP_FTTTY);
2653 case 'T': FTST(OP_FTTEXT);
2654 case 'B': FTST(OP_FTBINARY);
2655 case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2656 case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2657 case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
2659 Perl_croak(aTHX_ "Unrecognized file test: -%c", (int)tmp);
2666 if (PL_expect == XOPERATOR)
2671 else if (*s == '>') {
2674 if (isIDFIRST_lazy_if(s,UTF)) {
2675 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2683 if (PL_expect == XOPERATOR)
2686 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2688 OPERATOR('-'); /* unary minus */
2695 if (PL_expect == XOPERATOR)
2700 if (PL_expect == XOPERATOR)
2703 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2709 if (PL_expect != XOPERATOR) {
2710 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2711 PL_expect = XOPERATOR;
2712 force_ident(PL_tokenbuf, '*');
2725 if (PL_expect == XOPERATOR) {
2729 PL_tokenbuf[0] = '%';
2730 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2731 if (!PL_tokenbuf[1]) {
2733 yyerror("Final % should be \\% or %name");
2736 PL_pending_ident = '%';
2755 switch (PL_expect) {
2758 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
2760 PL_bufptr = s; /* update in case we back off */
2766 PL_expect = XTERMBLOCK;
2770 while (isIDFIRST_lazy_if(s,UTF)) {
2771 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2772 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
2773 if (tmp < 0) tmp = -tmp;
2788 d = scan_str(d,TRUE,TRUE);
2791 SvREFCNT_dec(PL_lex_stuff);
2792 PL_lex_stuff = Nullsv;
2794 /* MUST advance bufptr here to avoid bogus
2795 "at end of line" context messages from yyerror().
2797 PL_bufptr = s + len;
2798 yyerror("Unterminated attribute parameter in attribute list");
2801 return 0; /* EOF indicator */
2805 SV *sv = newSVpvn(s, len);
2806 sv_catsv(sv, PL_lex_stuff);
2807 attrs = append_elem(OP_LIST, attrs,
2808 newSVOP(OP_CONST, 0, sv));
2809 SvREFCNT_dec(PL_lex_stuff);
2810 PL_lex_stuff = Nullsv;
2813 attrs = append_elem(OP_LIST, attrs,
2814 newSVOP(OP_CONST, 0,
2818 if (*s == ':' && s[1] != ':')
2821 break; /* require real whitespace or :'s */
2823 tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
2824 if (*s != ';' && *s != tmp && (tmp != '=' || *s != ')')) {
2825 char q = ((*s == '\'') ? '"' : '\'');
2826 /* If here for an expression, and parsed no attrs, back off. */
2827 if (tmp == '=' && !attrs) {
2831 /* MUST advance bufptr here to avoid bogus "at end of line"
2832 context messages from yyerror().
2836 yyerror("Unterminated attribute list");
2838 yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list",
2846 PL_nextval[PL_nexttoke].opval = attrs;
2854 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
2855 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
2860 if (CopLINE(PL_curcop) < PL_copline)
2861 PL_copline = CopLINE(PL_curcop);
2872 if (PL_lex_brackets <= 0)
2873 yyerror("Unmatched right square bracket");
2876 if (PL_lex_state == LEX_INTERPNORMAL) {
2877 if (PL_lex_brackets == 0) {
2878 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
2879 PL_lex_state = LEX_INTERPEND;
2886 if (PL_lex_brackets > 100) {
2887 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
2888 if (newlb != PL_lex_brackstack) {
2890 PL_lex_brackstack = newlb;
2893 switch (PL_expect) {
2895 if (PL_lex_formbrack) {
2899 if (PL_oldoldbufptr == PL_last_lop)
2900 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2902 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2903 OPERATOR(HASHBRACK);
2905 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2908 PL_tokenbuf[0] = '\0';
2909 if (d < PL_bufend && *d == '-') {
2910 PL_tokenbuf[0] = '-';
2912 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2915 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
2916 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2918 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2921 char minus = (PL_tokenbuf[0] == '-');
2922 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2930 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
2935 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2940 if (PL_oldoldbufptr == PL_last_lop)
2941 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2943 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2946 OPERATOR(HASHBRACK);
2947 /* This hack serves to disambiguate a pair of curlies
2948 * as being a block or an anon hash. Normally, expectation
2949 * determines that, but in cases where we're not in a
2950 * position to expect anything in particular (like inside
2951 * eval"") we have to resolve the ambiguity. This code
2952 * covers the case where the first term in the curlies is a
2953 * quoted string. Most other cases need to be explicitly
2954 * disambiguated by prepending a `+' before the opening
2955 * curly in order to force resolution as an anon hash.
2957 * XXX should probably propagate the outer expectation
2958 * into eval"" to rely less on this hack, but that could
2959 * potentially break current behavior of eval"".
2963 if (*s == '\'' || *s == '"' || *s == '`') {
2964 /* common case: get past first string, handling escapes */
2965 for (t++; t < PL_bufend && *t != *s;)
2966 if (*t++ == '\\' && (*t == '\\' || *t == *s))
2970 else if (*s == 'q') {
2973 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
2977 char open, close, term;
2980 while (t < PL_bufend && isSPACE(*t))
2984 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
2988 for (t++; t < PL_bufend; t++) {
2989 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
2991 else if (*t == open)
2995 for (t++; t < PL_bufend; t++) {
2996 if (*t == '\\' && t+1 < PL_bufend)
2998 else if (*t == close && --brackets <= 0)
3000 else if (*t == open)
3006 else if (isALNUM_lazy_if(t,UTF)) {
3008 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3011 while (t < PL_bufend && isSPACE(*t))
3013 /* if comma follows first term, call it an anon hash */
3014 /* XXX it could be a comma expression with loop modifiers */
3015 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
3016 || (*t == '=' && t[1] == '>')))
3017 OPERATOR(HASHBRACK);
3018 if (PL_expect == XREF)
3021 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
3027 yylval.ival = CopLINE(PL_curcop);
3028 if (isSPACE(*s) || *s == '#')
3029 PL_copline = NOLINE; /* invalidate current command line number */
3034 if (PL_lex_brackets <= 0)
3035 yyerror("Unmatched right curly bracket");
3037 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
3038 if (PL_lex_brackets < PL_lex_formbrack)
3039 PL_lex_formbrack = 0;
3040 if (PL_lex_state == LEX_INTERPNORMAL) {
3041 if (PL_lex_brackets == 0) {
3042 if (PL_expect & XFAKEBRACK) {
3043 PL_expect &= XENUMMASK;
3044 PL_lex_state = LEX_INTERPEND;
3046 return yylex(); /* ignore fake brackets */
3048 if (*s == '-' && s[1] == '>')
3049 PL_lex_state = LEX_INTERPENDMAYBE;
3050 else if (*s != '[' && *s != '{')
3051 PL_lex_state = LEX_INTERPEND;
3054 if (PL_expect & XFAKEBRACK) {
3055 PL_expect &= XENUMMASK;
3057 return yylex(); /* ignore fake brackets */
3067 if (PL_expect == XOPERATOR) {
3068 if (ckWARN(WARN_SEMICOLON)
3069 && isIDFIRST_lazy_if(s,UTF) && PL_bufptr == PL_linestart)
3071 CopLINE_dec(PL_curcop);
3072 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3073 CopLINE_inc(PL_curcop);
3078 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3080 PL_expect = XOPERATOR;
3081 force_ident(PL_tokenbuf, '&');
3085 yylval.ival = (OPpENTERSUB_AMPER<<8);
3104 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
3105 Perl_warner(aTHX_ WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
3107 if (PL_expect == XSTATE && isALPHA(tmp) &&
3108 (s == PL_linestart+1 || s[-2] == '\n') )
3110 if (PL_in_eval && !PL_rsfp) {
3115 if (strnEQ(s,"=cut",4)) {
3129 PL_doextract = TRUE;
3132 if (PL_lex_brackets < PL_lex_formbrack) {
3134 #ifdef PERL_STRICT_CR
3135 for (t = s; *t == ' ' || *t == '\t'; t++) ;
3137 for (t = s; *t == ' ' || *t == '\t' || *t == '\r'; t++) ;
3139 if (*t == '\n' || *t == '#') {
3157 if (PL_expect != XOPERATOR) {
3158 if (s[1] != '<' && !strchr(s,'>'))
3161 s = scan_heredoc(s);
3163 s = scan_inputsymbol(s);
3164 TERM(sublex_start());
3169 SHop(OP_LEFT_SHIFT);
3183 SHop(OP_RIGHT_SHIFT);
3192 if (PL_expect == XOPERATOR) {
3193 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3196 return ','; /* grandfather non-comma-format format */
3200 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
3201 PL_tokenbuf[0] = '@';
3202 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3203 sizeof PL_tokenbuf - 1, FALSE);
3204 if (PL_expect == XOPERATOR)
3205 no_op("Array length", s);
3206 if (!PL_tokenbuf[1])
3208 PL_expect = XOPERATOR;
3209 PL_pending_ident = '#';
3213 PL_tokenbuf[0] = '$';
3214 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3215 sizeof PL_tokenbuf - 1, FALSE);
3216 if (PL_expect == XOPERATOR)
3218 if (!PL_tokenbuf[1]) {
3220 yyerror("Final $ should be \\$ or $name");
3224 /* This kludge not intended to be bulletproof. */
3225 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
3226 yylval.opval = newSVOP(OP_CONST, 0,
3227 newSViv((IV)PL_compiling.cop_arybase));
3228 yylval.opval->op_private = OPpCONST_ARYBASE;
3234 if (PL_lex_state == LEX_NORMAL)
3237 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3240 PL_tokenbuf[0] = '@';
3241 if (ckWARN(WARN_SYNTAX)) {
3243 isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$';
3246 PL_bufptr = skipspace(PL_bufptr);
3247 while (t < PL_bufend && *t != ']')
3249 Perl_warner(aTHX_ WARN_SYNTAX,
3250 "Multidimensional syntax %.*s not supported",
3251 (t - PL_bufptr) + 1, PL_bufptr);
3255 else if (*s == '{') {
3256 PL_tokenbuf[0] = '%';
3257 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
3258 (t = strchr(s, '}')) && (t = strchr(t, '=')))
3260 char tmpbuf[sizeof PL_tokenbuf];
3262 for (t++; isSPACE(*t); t++) ;
3263 if (isIDFIRST_lazy_if(t,UTF)) {
3264 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
3265 for (; isSPACE(*t); t++) ;
3266 if (*t == ';' && get_cv(tmpbuf, FALSE))
3267 Perl_warner(aTHX_ WARN_SYNTAX,
3268 "You need to quote \"%s\"", tmpbuf);
3274 PL_expect = XOPERATOR;
3275 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3276 bool islop = (PL_last_lop == PL_oldoldbufptr);
3277 if (!islop || PL_last_lop_op == OP_GREPSTART)
3278 PL_expect = XOPERATOR;
3279 else if (strchr("$@\"'`q", *s))
3280 PL_expect = XTERM; /* e.g. print $fh "foo" */
3281 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
3282 PL_expect = XTERM; /* e.g. print $fh &sub */
3283 else if (isIDFIRST_lazy_if(s,UTF)) {
3284 char tmpbuf[sizeof PL_tokenbuf];
3285 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3286 if (tmp = keyword(tmpbuf, len)) {
3287 /* binary operators exclude handle interpretations */
3299 PL_expect = XTERM; /* e.g. print $fh length() */
3304 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
3305 if (gv && GvCVu(gv))
3306 PL_expect = XTERM; /* e.g. print $fh subr() */
3309 else if (isDIGIT(*s))
3310 PL_expect = XTERM; /* e.g. print $fh 3 */
3311 else if (*s == '.' && isDIGIT(s[1]))
3312 PL_expect = XTERM; /* e.g. print $fh .3 */
3313 else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
3314 PL_expect = XTERM; /* e.g. print $fh -1 */
3315 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3316 PL_expect = XTERM; /* print $fh <<"EOF" */
3318 PL_pending_ident = '$';
3322 if (PL_expect == XOPERATOR)
3324 PL_tokenbuf[0] = '@';
3325 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3326 if (!PL_tokenbuf[1]) {
3328 yyerror("Final @ should be \\@ or @name");
3331 if (PL_lex_state == LEX_NORMAL)
3333 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3335 PL_tokenbuf[0] = '%';
3337 /* Warn about @ where they meant $. */
3338 if (ckWARN(WARN_SYNTAX)) {
3339 if (*s == '[' || *s == '{') {
3341 while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
3343 if (*t == '}' || *t == ']') {
3345 PL_bufptr = skipspace(PL_bufptr);
3346 Perl_warner(aTHX_ WARN_SYNTAX,
3347 "Scalar value %.*s better written as $%.*s",
3348 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
3353 PL_pending_ident = '@';
3356 case '/': /* may either be division or pattern */
3357 case '?': /* may either be conditional or pattern */
3358 if (PL_expect != XOPERATOR) {
3359 /* Disable warning on "study /blah/" */
3360 if (PL_oldoldbufptr == PL_last_uni
3361 && (*PL_last_uni != 's' || s - PL_last_uni < 5
3362 || memNE(PL_last_uni, "study", 5)
3363 || isALNUM_lazy_if(PL_last_uni+5,UTF)))
3365 s = scan_pat(s,OP_MATCH);
3366 TERM(sublex_start());
3374 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3375 #ifdef PERL_STRICT_CR
3378 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3380 && (s == PL_linestart || s[-1] == '\n') )
3382 PL_lex_formbrack = 0;
3386 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
3392 yylval.ival = OPf_SPECIAL;
3398 if (PL_expect != XOPERATOR)
3403 case '0': case '1': case '2': case '3': case '4':
3404 case '5': case '6': case '7': case '8': case '9':
3406 if (PL_expect == XOPERATOR)
3411 s = scan_str(s,FALSE,FALSE);
3412 if (PL_expect == XOPERATOR) {
3413 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3416 return ','; /* grandfather non-comma-format format */
3422 missingterm((char*)0);
3423 yylval.ival = OP_CONST;
3424 TERM(sublex_start());
3427 s = scan_str(s,FALSE,FALSE);
3428 if (PL_expect == XOPERATOR) {
3429 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3432 return ','; /* grandfather non-comma-format format */
3438 missingterm((char*)0);
3439 yylval.ival = OP_CONST;
3440 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
3441 if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
3442 yylval.ival = OP_STRINGIFY;
3446 TERM(sublex_start());
3449 s = scan_str(s,FALSE,FALSE);
3450 if (PL_expect == XOPERATOR)
3451 no_op("Backticks",s);
3453 missingterm((char*)0);
3454 yylval.ival = OP_BACKTICK;
3456 TERM(sublex_start());
3460 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
3461 Perl_warner(aTHX_ WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
3463 if (PL_expect == XOPERATOR)
3464 no_op("Backslash",s);
3468 if (isDIGIT(s[1]) && PL_expect == XTERM) {
3472 while (isDIGIT(*start))
3474 if (*start == '.' && isDIGIT(start[1])) {
3481 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
3521 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3523 /* Some keywords can be followed by any delimiter, including ':' */
3524 tmp = (len == 1 && strchr("msyq", PL_tokenbuf[0]) ||
3525 len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
3526 (PL_tokenbuf[0] == 'q' &&
3527 strchr("qwxr", PL_tokenbuf[1]))));
3529 /* x::* is just a word, unless x is "CORE" */
3530 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
3534 while (d < PL_bufend && isSPACE(*d))
3535 d++; /* no comments skipped here, or s### is misparsed */
3537 /* Is this a label? */
3538 if (!tmp && PL_expect == XSTATE
3539 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
3541 yylval.pval = savepv(PL_tokenbuf);
3546 /* Check for keywords */
3547 tmp = keyword(PL_tokenbuf, len);
3549 /* Is this a word before a => operator? */
3550 if (strnEQ(d,"=>",2)) {
3552 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
3553 yylval.opval->op_private = OPpCONST_BARE;
3557 if (tmp < 0) { /* second-class keyword? */
3558 GV *ogv = Nullgv; /* override (winner) */
3559 GV *hgv = Nullgv; /* hidden (loser) */
3560 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3562 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3565 if (GvIMPORTED_CV(gv))
3567 else if (! CvMETHOD(cv))
3571 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3572 (gv = *gvp) != (GV*)&PL_sv_undef &&
3573 GvCVu(gv) && GvIMPORTED_CV(gv))
3579 tmp = 0; /* overridden by import or by GLOBAL */
3582 && -tmp==KEY_lock /* XXX generalizable kludge */
3584 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3586 tmp = 0; /* any sub overrides "weak" keyword */
3588 else { /* no override */
3592 if (ckWARN(WARN_AMBIGUOUS) && hgv
3593 && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3594 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3595 "Ambiguous call resolved as CORE::%s(), %s",
3596 GvENAME(hgv), "qualify as such or use &");
3603 default: /* not a keyword */
3606 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3608 /* Get the rest if it looks like a package qualifier */
3610 if (*s == '\'' || *s == ':' && s[1] == ':') {
3612 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3615 Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
3616 *s == '\'' ? "'" : "::");
3620 if (PL_expect == XOPERATOR) {
3621 if (PL_bufptr == PL_linestart) {
3622 CopLINE_dec(PL_curcop);
3623 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3624 CopLINE_inc(PL_curcop);
3627 no_op("Bareword",s);
3630 /* Look for a subroutine with this name in current package,
3631 unless name is "Foo::", in which case Foo is a bearword
3632 (and a package name). */
3635 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3637 if (ckWARN(WARN_UNSAFE) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3638 Perl_warner(aTHX_ WARN_UNSAFE,
3639 "Bareword \"%s\" refers to nonexistent package",
3642 PL_tokenbuf[len] = '\0';
3649 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3652 /* if we saw a global override before, get the right name */
3655 sv = newSVpvn("CORE::GLOBAL::",14);
3656 sv_catpv(sv,PL_tokenbuf);
3659 sv = newSVpv(PL_tokenbuf,0);
3661 /* Presume this is going to be a bareword of some sort. */
3664 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3665 yylval.opval->op_private = OPpCONST_BARE;
3667 /* And if "Foo::", then that's what it certainly is. */
3672 /* See if it's the indirect object for a list operator. */
3674 if (PL_oldoldbufptr &&
3675 PL_oldoldbufptr < PL_bufptr &&
3676 (PL_oldoldbufptr == PL_last_lop
3677 || PL_oldoldbufptr == PL_last_uni) &&
3678 /* NO SKIPSPACE BEFORE HERE! */
3679 (PL_expect == XREF ||
3680 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
3682 bool immediate_paren = *s == '(';
3684 /* (Now we can afford to cross potential line boundary.) */
3687 /* Two barewords in a row may indicate method call. */
3689 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp=intuit_method(s,gv)))
3692 /* If not a declared subroutine, it's an indirect object. */
3693 /* (But it's an indir obj regardless for sort.) */
3695 if ((PL_last_lop_op == OP_SORT ||
3696 (!immediate_paren && (!gv || !GvCVu(gv)))) &&
3697 (PL_last_lop_op != OP_MAPSTART &&
3698 PL_last_lop_op != OP_GREPSTART))
3700 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3705 /* If followed by a paren, it's certainly a subroutine. */
3707 PL_expect = XOPERATOR;
3711 if (gv && GvCVu(gv)) {
3712 for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
3713 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
3718 PL_nextval[PL_nexttoke].opval = yylval.opval;
3719 PL_expect = XOPERATOR;
3725 /* If followed by var or block, call it a method (unless sub) */
3727 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3728 PL_last_lop = PL_oldbufptr;
3729 PL_last_lop_op = OP_METHOD;
3733 /* If followed by a bareword, see if it looks like indir obj. */
3735 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp = intuit_method(s,gv)))
3738 /* Not a method, so call it a subroutine (if defined) */
3740 if (gv && GvCVu(gv)) {
3742 if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
3743 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3744 "Ambiguous use of -%s resolved as -&%s()",
3745 PL_tokenbuf, PL_tokenbuf);
3746 /* Check for a constant sub */
3748 if ((sv = cv_const_sv(cv))) {
3750 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3751 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3752 yylval.opval->op_private = 0;
3756 /* Resolve to GV now. */
3757 op_free(yylval.opval);
3758 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3759 yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
3760 PL_last_lop = PL_oldbufptr;
3761 PL_last_lop_op = OP_ENTERSUB;
3762 /* Is there a prototype? */
3765 char *proto = SvPV((SV*)cv, len);
3768 if (strEQ(proto, "$"))
3770 if (*proto == '&' && *s == '{') {
3771 sv_setpv(PL_subname,"__ANON__");
3775 PL_nextval[PL_nexttoke].opval = yylval.opval;
3781 /* Call it a bare word */
3783 if (PL_hints & HINT_STRICT_SUBS)
3784 yylval.opval->op_private |= OPpCONST_STRICT;
3787 if (ckWARN(WARN_RESERVED)) {
3788 if (lastchar != '-') {
3789 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3791 Perl_warner(aTHX_ WARN_RESERVED, PL_warn_reserved,
3798 if (lastchar && strchr("*%&", lastchar) && ckWARN_d(WARN_AMBIGUOUS)) {
3799 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3800 "Operator or semicolon missing before %c%s",
3801 lastchar, PL_tokenbuf);
3802 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3803 "Ambiguous use of %c resolved as operator %c",
3804 lastchar, lastchar);
3810 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3811 newSVpv(CopFILE(PL_curcop),0));
3815 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3816 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
3819 case KEY___PACKAGE__:
3820 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3822 ? newSVsv(PL_curstname)
3831 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3832 char *pname = "main";
3833 if (PL_tokenbuf[2] == 'D')
3834 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3835 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
3838 GvIOp(gv) = newIO();
3839 IoIFP(GvIOp(gv)) = PL_rsfp;
3840 #if defined(HAS_FCNTL) && defined(F_SETFD)
3842 int fd = PerlIO_fileno(PL_rsfp);
3843 fcntl(fd,F_SETFD,fd >= 3);
3846 /* Mark this internal pseudo-handle as clean */
3847 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3849 IoTYPE(GvIOp(gv)) = '|';
3850 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
3851 IoTYPE(GvIOp(gv)) = '-';
3853 IoTYPE(GvIOp(gv)) = '<';
3854 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
3855 /* if the script was opened in binmode, we need to revert
3856 * it to text mode for compatibility; but only iff it has CRs
3857 * XXX this is a questionable hack at best. */
3858 if (PL_bufend-PL_bufptr > 2
3859 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
3862 if (IoTYPE(GvIOp(gv)) == '<') {
3863 loc = PerlIO_tell(PL_rsfp);
3864 (void)PerlIO_seek(PL_rsfp, 0L, 0);
3866 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
3867 #if defined(__BORLANDC__)
3868 /* XXX see note in do_binmode() */
3869 ((FILE*)PL_rsfp)->flags |= _F_BIN;
3872 PerlIO_seek(PL_rsfp, loc, 0);
3887 if (PL_expect == XSTATE) {
3894 if (*s == ':' && s[1] == ':') {
3897 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3898 tmp = keyword(PL_tokenbuf, len);
3912 LOP(OP_ACCEPT,XTERM);
3918 LOP(OP_ATAN2,XTERM);
3927 LOP(OP_BLESS,XTERM);
3936 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
3953 if (!PL_cryptseen) {
3954 PL_cryptseen = TRUE;
3958 LOP(OP_CRYPT,XTERM);
3961 if (ckWARN(WARN_OCTAL)) {
3962 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
3963 if (*d != '0' && isDIGIT(*d))
3964 Perl_warner(aTHX_ WARN_OCTAL,
3965 "chmod: mode argument is missing initial 0");
3967 LOP(OP_CHMOD,XTERM);
3970 LOP(OP_CHOWN,XTERM);
3973 LOP(OP_CONNECT,XTERM);
3989 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3993 PL_hints |= HINT_BLOCK_SCOPE;
4003 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
4004 LOP(OP_DBMOPEN,XTERM);
4010 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4017 yylval.ival = CopLINE(PL_curcop);
4031 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
4032 UNIBRACK(OP_ENTEREVAL);
4047 case KEY_endhostent:
4053 case KEY_endservent:
4056 case KEY_endprotoent:
4067 yylval.ival = CopLINE(PL_curcop);
4069 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
4071 if ((PL_bufend - p) >= 3 &&
4072 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
4074 else if ((PL_bufend - p) >= 4 &&
4075 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
4078 if (isIDFIRST_lazy_if(p,UTF)) {
4079 p = scan_ident(p, PL_bufend,
4080 PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4084 Perl_croak(aTHX_ "Missing $ on loop variable");
4089 LOP(OP_FORMLINE,XTERM);
4095 LOP(OP_FCNTL,XTERM);
4101 LOP(OP_FLOCK,XTERM);
4110 LOP(OP_GREPSTART, XREF);
4113 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4128 case KEY_getpriority:
4129 LOP(OP_GETPRIORITY,XTERM);
4131 case KEY_getprotobyname:
4134 case KEY_getprotobynumber:
4135 LOP(OP_GPBYNUMBER,XTERM);
4137 case KEY_getprotoent:
4149 case KEY_getpeername:
4150 UNI(OP_GETPEERNAME);
4152 case KEY_gethostbyname:
4155 case KEY_gethostbyaddr:
4156 LOP(OP_GHBYADDR,XTERM);
4158 case KEY_gethostent:
4161 case KEY_getnetbyname:
4164 case KEY_getnetbyaddr:
4165 LOP(OP_GNBYADDR,XTERM);
4170 case KEY_getservbyname:
4171 LOP(OP_GSBYNAME,XTERM);
4173 case KEY_getservbyport:
4174 LOP(OP_GSBYPORT,XTERM);
4176 case KEY_getservent:
4179 case KEY_getsockname:
4180 UNI(OP_GETSOCKNAME);
4182 case KEY_getsockopt:
4183 LOP(OP_GSOCKOPT,XTERM);
4205 yylval.ival = CopLINE(PL_curcop);
4209 LOP(OP_INDEX,XTERM);
4215 LOP(OP_IOCTL,XTERM);
4227 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4259 LOP(OP_LISTEN,XTERM);
4268 s = scan_pat(s,OP_MATCH);
4269 TERM(sublex_start());
4272 LOP(OP_MAPSTART, XREF);
4275 LOP(OP_MKDIR,XTERM);
4278 LOP(OP_MSGCTL,XTERM);
4281 LOP(OP_MSGGET,XTERM);
4284 LOP(OP_MSGRCV,XTERM);
4287 LOP(OP_MSGSND,XTERM);
4293 if (isIDFIRST_lazy_if(s,UTF)) {
4294 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
4295 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
4297 PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
4298 if (!PL_in_my_stash) {
4301 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
4309 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4316 if (PL_expect != XSTATE)
4317 yyerror("\"no\" not allowed in expression");
4318 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4319 s = force_version(s);
4324 if (*s == '(' || (s = skipspace(s), *s == '('))
4331 if (isIDFIRST_lazy_if(s,UTF)) {
4333 for (d = s; isALNUM_lazy_if(d,UTF); d++) ;
4335 if (strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_AMBIGUOUS))
4336 Perl_warner(aTHX_ WARN_AMBIGUOUS,
4337 "Precedence problem: open %.*s should be open(%.*s)",
4343 yylval.ival = OP_OR;
4353 LOP(OP_OPEN_DIR,XTERM);
4356 checkcomma(s,PL_tokenbuf,"filehandle");
4360 checkcomma(s,PL_tokenbuf,"filehandle");
4379 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4383 LOP(OP_PIPE_OP,XTERM);
4386 s = scan_str(s,FALSE,FALSE);
4388 missingterm((char*)0);
4389 yylval.ival = OP_CONST;
4390 TERM(sublex_start());
4396 s = scan_str(s,FALSE,FALSE);
4398 missingterm((char*)0);
4400 if (SvCUR(PL_lex_stuff)) {
4403 d = SvPV_force(PL_lex_stuff, len);
4405 for (; isSPACE(*d) && len; --len, ++d) ;
4408 if (!warned && ckWARN(WARN_SYNTAX)) {
4409 for (; !isSPACE(*d) && len; --len, ++d) {
4411 Perl_warner(aTHX_ WARN_SYNTAX,
4412 "Possible attempt to separate words with commas");
4415 else if (*d == '#') {
4416 Perl_warner(aTHX_ WARN_SYNTAX,
4417 "Possible attempt to put comments in qw() list");
4423 for (; !isSPACE(*d) && len; --len, ++d) ;
4425 words = append_elem(OP_LIST, words,
4426 newSVOP(OP_CONST, 0, newSVpvn(b, d-b)));
4430 PL_nextval[PL_nexttoke].opval = words;
4435 SvREFCNT_dec(PL_lex_stuff);
4436 PL_lex_stuff = Nullsv;
4441 s = scan_str(s,FALSE,FALSE);
4443 missingterm((char*)0);
4444 yylval.ival = OP_STRINGIFY;
4445 if (SvIVX(PL_lex_stuff) == '\'')
4446 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
4447 TERM(sublex_start());
4450 s = scan_pat(s,OP_QR);
4451 TERM(sublex_start());
4454 s = scan_str(s,FALSE,FALSE);
4456 missingterm((char*)0);
4457 yylval.ival = OP_BACKTICK;
4459 TERM(sublex_start());
4466 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4467 s = force_version(s);
4470 *PL_tokenbuf = '\0';
4471 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4472 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
4473 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
4475 yyerror("<> should be quotes");
4483 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4487 LOP(OP_RENAME,XTERM);
4496 LOP(OP_RINDEX,XTERM);
4519 LOP(OP_REVERSE,XTERM);
4530 TERM(sublex_start());
4532 TOKEN(1); /* force error */
4541 LOP(OP_SELECT,XTERM);
4547 LOP(OP_SEMCTL,XTERM);
4550 LOP(OP_SEMGET,XTERM);
4553 LOP(OP_SEMOP,XTERM);
4559 LOP(OP_SETPGRP,XTERM);
4561 case KEY_setpriority:
4562 LOP(OP_SETPRIORITY,XTERM);
4564 case KEY_sethostent:
4570 case KEY_setservent:
4573 case KEY_setprotoent:
4583 LOP(OP_SEEKDIR,XTERM);
4585 case KEY_setsockopt:
4586 LOP(OP_SSOCKOPT,XTERM);
4592 LOP(OP_SHMCTL,XTERM);
4595 LOP(OP_SHMGET,XTERM);
4598 LOP(OP_SHMREAD,XTERM);
4601 LOP(OP_SHMWRITE,XTERM);
4604 LOP(OP_SHUTDOWN,XTERM);
4613 LOP(OP_SOCKET,XTERM);
4615 case KEY_socketpair:
4616 LOP(OP_SOCKPAIR,XTERM);
4619 checkcomma(s,PL_tokenbuf,"subroutine name");
4621 if (*s == ';' || *s == ')') /* probably a close */
4622 Perl_croak(aTHX_ "sort is now a reserved word");
4624 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4628 LOP(OP_SPLIT,XTERM);
4631 LOP(OP_SPRINTF,XTERM);
4634 LOP(OP_SPLICE,XTERM);
4649 LOP(OP_SUBSTR,XTERM);
4655 char tmpbuf[sizeof PL_tokenbuf];
4657 expectation attrful;
4658 bool have_name, have_proto;
4663 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
4664 (*s == ':' && s[1] == ':'))
4667 attrful = XATTRBLOCK;
4668 /* remember buffer pos'n for later force_word */
4669 tboffset = s - PL_oldbufptr;
4670 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4671 if (strchr(tmpbuf, ':'))
4672 sv_setpv(PL_subname, tmpbuf);
4674 sv_setsv(PL_subname,PL_curstname);
4675 sv_catpvn(PL_subname,"::",2);
4676 sv_catpvn(PL_subname,tmpbuf,len);
4683 Perl_croak(aTHX_ "Missing name in \"my sub\"");
4684 PL_expect = XTERMBLOCK;
4685 attrful = XATTRTERM;
4686 sv_setpv(PL_subname,"?");
4690 if (key == KEY_format) {
4692 PL_lex_formbrack = PL_lex_brackets + 1;
4694 (void) force_word(PL_oldbufptr + tboffset, WORD,
4699 /* Look for a prototype */
4703 s = scan_str(s,FALSE,FALSE);
4706 SvREFCNT_dec(PL_lex_stuff);
4707 PL_lex_stuff = Nullsv;
4708 Perl_croak(aTHX_ "Prototype not terminated");
4711 d = SvPVX(PL_lex_stuff);
4713 for (p = d; *p; ++p) {
4718 SvCUR(PL_lex_stuff) = tmp;
4726 if (*s == ':' && s[1] != ':')
4727 PL_expect = attrful;
4730 PL_nextval[PL_nexttoke].opval =
4731 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4732 PL_lex_stuff = Nullsv;
4736 sv_setpv(PL_subname,"__ANON__");
4739 (void) force_word(PL_oldbufptr + tboffset, WORD,
4748 LOP(OP_SYSTEM,XREF);
4751 LOP(OP_SYMLINK,XTERM);
4754 LOP(OP_SYSCALL,XTERM);
4757 LOP(OP_SYSOPEN,XTERM);
4760 LOP(OP_SYSSEEK,XTERM);
4763 LOP(OP_SYSREAD,XTERM);
4766 LOP(OP_SYSWRITE,XTERM);
4770 TERM(sublex_start());
4791 LOP(OP_TRUNCATE,XTERM);
4803 yylval.ival = CopLINE(PL_curcop);
4807 yylval.ival = CopLINE(PL_curcop);
4811 LOP(OP_UNLINK,XTERM);
4817 LOP(OP_UNPACK,XTERM);
4820 LOP(OP_UTIME,XTERM);
4823 if (ckWARN(WARN_OCTAL)) {
4824 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4825 if (*d != '0' && isDIGIT(*d))
4826 Perl_warner(aTHX_ WARN_OCTAL,
4827 "umask: argument is missing initial 0");
4832 LOP(OP_UNSHIFT,XTERM);
4835 if (PL_expect != XSTATE)
4836 yyerror("\"use\" not allowed in expression");
4838 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4839 s = force_version(s);
4840 if (*s == ';' || (s = skipspace(s), *s == ';')) {
4841 PL_nextval[PL_nexttoke].opval = Nullop;
4846 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4847 s = force_version(s);
4859 yylval.ival = CopLINE(PL_curcop);
4863 PL_hints |= HINT_BLOCK_SCOPE;
4870 LOP(OP_WAITPID,XTERM);
4878 static char ctl_l[2];
4880 if (ctl_l[0] == '\0')
4881 ctl_l[0] = toCTRL('L');
4882 gv_fetchpv(ctl_l,TRUE, SVt_PV);
4885 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
4890 if (PL_expect == XOPERATOR)
4896 yylval.ival = OP_XOR;
4901 TERM(sublex_start());
4907 Perl_keyword(pTHX_ register char *d, I32 len)
4912 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
4913 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
4914 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
4915 if (strEQ(d,"__DATA__")) return KEY___DATA__;
4916 if (strEQ(d,"__END__")) return KEY___END__;
4920 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
4925 if (strEQ(d,"and")) return -KEY_and;
4926 if (strEQ(d,"abs")) return -KEY_abs;
4929 if (strEQ(d,"alarm")) return -KEY_alarm;
4930 if (strEQ(d,"atan2")) return -KEY_atan2;
4933 if (strEQ(d,"accept")) return -KEY_accept;
4938 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
4941 if (strEQ(d,"bless")) return -KEY_bless;
4942 if (strEQ(d,"bind")) return -KEY_bind;
4943 if (strEQ(d,"binmode")) return -KEY_binmode;
4946 if (strEQ(d,"CORE")) return -KEY_CORE;
4947 if (strEQ(d,"CHECK")) return KEY_CHECK;
4952 if (strEQ(d,"cmp")) return -KEY_cmp;
4953 if (strEQ(d,"chr")) return -KEY_chr;
4954 if (strEQ(d,"cos")) return -KEY_cos;
4957 if (strEQ(d,"chop")) return KEY_chop;
4960 if (strEQ(d,"close")) return -KEY_close;
4961 if (strEQ(d,"chdir")) return -KEY_chdir;
4962 if (strEQ(d,"chomp")) return KEY_chomp;
4963 if (strEQ(d,"chmod")) return -KEY_chmod;
4964 if (strEQ(d,"chown")) return -KEY_chown;
4965 if (strEQ(d,"crypt")) return -KEY_crypt;
4968 if (strEQ(d,"chroot")) return -KEY_chroot;
4969 if (strEQ(d,"caller")) return -KEY_caller;
4972 if (strEQ(d,"connect")) return -KEY_connect;
4975 if (strEQ(d,"closedir")) return -KEY_closedir;
4976 if (strEQ(d,"continue")) return -KEY_continue;
4981 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
4986 if (strEQ(d,"do")) return KEY_do;
4989 if (strEQ(d,"die")) return -KEY_die;
4992 if (strEQ(d,"dump")) return -KEY_dump;
4995 if (strEQ(d,"delete")) return KEY_delete;
4998 if (strEQ(d,"defined")) return KEY_defined;
4999 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
5002 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
5007 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
5008 if (strEQ(d,"END")) return KEY_END;
5013 if (strEQ(d,"eq")) return -KEY_eq;
5016 if (strEQ(d,"eof")) return -KEY_eof;
5017 if (strEQ(d,"exp")) return -KEY_exp;
5020 if (strEQ(d,"else")) return KEY_else;
5021 if (strEQ(d,"exit")) return -KEY_exit;
5022 if (strEQ(d,"eval")) return KEY_eval;
5023 if (strEQ(d,"exec")) return -KEY_exec;
5024 if (strEQ(d,"each")) return KEY_each;
5027 if (strEQ(d,"elsif")) return KEY_elsif;
5030 if (strEQ(d,"exists")) return KEY_exists;
5031 if (strEQ(d,"elseif")) Perl_warn(aTHX_ "elseif should be elsif");
5034 if (strEQ(d,"endgrent")) return -KEY_endgrent;
5035 if (strEQ(d,"endpwent")) return -KEY_endpwent;
5038 if (strEQ(d,"endnetent")) return -KEY_endnetent;
5041 if (strEQ(d,"endhostent")) return -KEY_endhostent;
5042 if (strEQ(d,"endservent")) return -KEY_endservent;
5045 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
5052 if (strEQ(d,"for")) return KEY_for;
5055 if (strEQ(d,"fork")) return -KEY_fork;
5058 if (strEQ(d,"fcntl")) return -KEY_fcntl;
5059 if (strEQ(d,"flock")) return -KEY_flock;
5062 if (strEQ(d,"format")) return KEY_format;
5063 if (strEQ(d,"fileno")) return -KEY_fileno;
5066 if (strEQ(d,"foreach")) return KEY_foreach;
5069 if (strEQ(d,"formline")) return -KEY_formline;
5075 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
5076 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
5080 if (strnEQ(d,"get",3)) {
5085 if (strEQ(d,"ppid")) return -KEY_getppid;
5086 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
5089 if (strEQ(d,"pwent")) return -KEY_getpwent;
5090 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
5091 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
5094 if (strEQ(d,"peername")) return -KEY_getpeername;
5095 if (strEQ(d,"protoent")) return -KEY_getprotoent;
5096 if (strEQ(d,"priority")) return -KEY_getpriority;
5099 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
5102 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
5106 else if (*d == 'h') {
5107 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
5108 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
5109 if (strEQ(d,"hostent")) return -KEY_gethostent;
5111 else if (*d == 'n') {
5112 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
5113 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
5114 if (strEQ(d,"netent")) return -KEY_getnetent;
5116 else if (*d == 's') {
5117 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
5118 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
5119 if (strEQ(d,"servent")) return -KEY_getservent;
5120 if (strEQ(d,"sockname")) return -KEY_getsockname;
5121 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
5123 else if (*d == 'g') {
5124 if (strEQ(d,"grent")) return -KEY_getgrent;
5125 if (strEQ(d,"grnam")) return -KEY_getgrnam;
5126 if (strEQ(d,"grgid")) return -KEY_getgrgid;
5128 else if (*d == 'l') {
5129 if (strEQ(d,"login")) return -KEY_getlogin;
5131 else if (strEQ(d,"c")) return -KEY_getc;
5136 if (strEQ(d,"gt")) return -KEY_gt;
5137 if (strEQ(d,"ge")) return -KEY_ge;
5140 if (strEQ(d,"grep")) return KEY_grep;
5141 if (strEQ(d,"goto")) return KEY_goto;
5142 if (strEQ(d,"glob")) return KEY_glob;
5145 if (strEQ(d,"gmtime")) return -KEY_gmtime;
5150 if (strEQ(d,"hex")) return -KEY_hex;
5153 if (strEQ(d,"INIT")) return KEY_INIT;
5158 if (strEQ(d,"if")) return KEY_if;
5161 if (strEQ(d,"int")) return -KEY_int;
5164 if (strEQ(d,"index")) return -KEY_index;
5165 if (strEQ(d,"ioctl")) return -KEY_ioctl;
5170 if (strEQ(d,"join")) return -KEY_join;
5174 if (strEQ(d,"keys")) return KEY_keys;
5175 if (strEQ(d,"kill")) return -KEY_kill;
5180 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
5181 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
5187 if (strEQ(d,"lt")) return -KEY_lt;
5188 if (strEQ(d,"le")) return -KEY_le;
5189 if (strEQ(d,"lc")) return -KEY_lc;
5192 if (strEQ(d,"log")) return -KEY_log;
5195 if (strEQ(d,"last")) return KEY_last;
5196 if (strEQ(d,"link")) return -KEY_link;
5197 if (strEQ(d,"lock")) return -KEY_lock;
5200 if (strEQ(d,"local")) return KEY_local;
5201 if (strEQ(d,"lstat")) return -KEY_lstat;
5204 if (strEQ(d,"length")) return -KEY_length;
5205 if (strEQ(d,"listen")) return -KEY_listen;
5208 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
5211 if (strEQ(d,"localtime")) return -KEY_localtime;
5217 case 1: return KEY_m;
5219 if (strEQ(d,"my")) return KEY_my;
5222 if (strEQ(d,"map")) return KEY_map;
5225 if (strEQ(d,"mkdir")) return -KEY_mkdir;
5228 if (strEQ(d,"msgctl")) return -KEY_msgctl;
5229 if (strEQ(d,"msgget")) return -KEY_msgget;
5230 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
5231 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
5236 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
5239 if (strEQ(d,"next")) return KEY_next;
5240 if (strEQ(d,"ne")) return -KEY_ne;
5241 if (strEQ(d,"not")) return -KEY_not;
5242 if (strEQ(d,"no")) return KEY_no;
5247 if (strEQ(d,"or")) return -KEY_or;
5250 if (strEQ(d,"ord")) return -KEY_ord;
5251 if (strEQ(d,"oct")) return -KEY_oct;
5252 if (strEQ(d,"our")) return KEY_our;
5255 if (strEQ(d,"open")) return -KEY_open;
5258 if (strEQ(d,"opendir")) return -KEY_opendir;
5265 if (strEQ(d,"pop")) return KEY_pop;
5266 if (strEQ(d,"pos")) return KEY_pos;
5269 if (strEQ(d,"push")) return KEY_push;
5270 if (strEQ(d,"pack")) return -KEY_pack;
5271 if (strEQ(d,"pipe")) return -KEY_pipe;
5274 if (strEQ(d,"print")) return KEY_print;
5277 if (strEQ(d,"printf")) return KEY_printf;
5280 if (strEQ(d,"package")) return KEY_package;
5283 if (strEQ(d,"prototype")) return KEY_prototype;
5288 if (strEQ(d,"q")) return KEY_q;
5289 if (strEQ(d,"qr")) return KEY_qr;
5290 if (strEQ(d,"qq")) return KEY_qq;
5291 if (strEQ(d,"qw")) return KEY_qw;
5292 if (strEQ(d,"qx")) return KEY_qx;
5294 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
5299 if (strEQ(d,"ref")) return -KEY_ref;
5302 if (strEQ(d,"read")) return -KEY_read;
5303 if (strEQ(d,"rand")) return -KEY_rand;
5304 if (strEQ(d,"recv")) return -KEY_recv;
5305 if (strEQ(d,"redo")) return KEY_redo;
5308 if (strEQ(d,"rmdir")) return -KEY_rmdir;
5309 if (strEQ(d,"reset")) return -KEY_reset;
5312 if (strEQ(d,"return")) return KEY_return;
5313 if (strEQ(d,"rename")) return -KEY_rename;
5314 if (strEQ(d,"rindex")) return -KEY_rindex;
5317 if (strEQ(d,"require")) return -KEY_require;
5318 if (strEQ(d,"reverse")) return -KEY_reverse;
5319 if (strEQ(d,"readdir")) return -KEY_readdir;
5322 if (strEQ(d,"readlink")) return -KEY_readlink;
5323 if (strEQ(d,"readline")) return -KEY_readline;
5324 if (strEQ(d,"readpipe")) return -KEY_readpipe;
5327 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
5333 case 0: return KEY_s;
5335 if (strEQ(d,"scalar")) return KEY_scalar;
5340 if (strEQ(d,"seek")) return -KEY_seek;
5341 if (strEQ(d,"send")) return -KEY_send;
5344 if (strEQ(d,"semop")) return -KEY_semop;
5347 if (strEQ(d,"select")) return -KEY_select;
5348 if (strEQ(d,"semctl")) return -KEY_semctl;
5349 if (strEQ(d,"semget")) return -KEY_semget;
5352 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
5353 if (strEQ(d,"seekdir")) return -KEY_seekdir;
5356 if (strEQ(d,"setpwent")) return -KEY_setpwent;
5357 if (strEQ(d,"setgrent")) return -KEY_setgrent;
5360 if (strEQ(d,"setnetent")) return -KEY_setnetent;
5363 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
5364 if (strEQ(d,"sethostent")) return -KEY_sethostent;
5365 if (strEQ(d,"setservent")) return -KEY_setservent;
5368 if (strEQ(d,"setpriority")) return -KEY_setpriority;
5369 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
5376 if (strEQ(d,"shift")) return KEY_shift;
5379 if (strEQ(d,"shmctl")) return -KEY_shmctl;
5380 if (strEQ(d,"shmget")) return -KEY_shmget;
5383 if (strEQ(d,"shmread")) return -KEY_shmread;
5386 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
5387 if (strEQ(d,"shutdown")) return -KEY_shutdown;
5392 if (strEQ(d,"sin")) return -KEY_sin;
5395 if (strEQ(d,"sleep")) return -KEY_sleep;
5398 if (strEQ(d,"sort")) return KEY_sort;
5399 if (strEQ(d,"socket")) return -KEY_socket;
5400 if (strEQ(d,"socketpair")) return -KEY_socketpair;
5403 if (strEQ(d,"split")) return KEY_split;
5404 if (strEQ(d,"sprintf")) return -KEY_sprintf;
5405 if (strEQ(d,"splice")) return KEY_splice;
5408 if (strEQ(d,"sqrt")) return -KEY_sqrt;
5411 if (strEQ(d,"srand")) return -KEY_srand;
5414 if (strEQ(d,"stat")) return -KEY_stat;
5415 if (strEQ(d,"study")) return KEY_study;
5418 if (strEQ(d,"substr")) return -KEY_substr;
5419 if (strEQ(d,"sub")) return KEY_sub;
5424 if (strEQ(d,"system")) return -KEY_system;
5427 if (strEQ(d,"symlink")) return -KEY_symlink;
5428 if (strEQ(d,"syscall")) return -KEY_syscall;
5429 if (strEQ(d,"sysopen")) return -KEY_sysopen;
5430 if (strEQ(d,"sysread")) return -KEY_sysread;
5431 if (strEQ(d,"sysseek")) return -KEY_sysseek;
5434 if (strEQ(d,"syswrite")) return -KEY_syswrite;
5443 if (strEQ(d,"tr")) return KEY_tr;
5446 if (strEQ(d,"tie")) return KEY_tie;
5449 if (strEQ(d,"tell")) return -KEY_tell;
5450 if (strEQ(d,"tied")) return KEY_tied;
5451 if (strEQ(d,"time")) return -KEY_time;
5454 if (strEQ(d,"times")) return -KEY_times;
5457 if (strEQ(d,"telldir")) return -KEY_telldir;
5460 if (strEQ(d,"truncate")) return -KEY_truncate;
5467 if (strEQ(d,"uc")) return -KEY_uc;
5470 if (strEQ(d,"use")) return KEY_use;
5473 if (strEQ(d,"undef")) return KEY_undef;
5474 if (strEQ(d,"until")) return KEY_until;
5475 if (strEQ(d,"untie")) return KEY_untie;
5476 if (strEQ(d,"utime")) return -KEY_utime;
5477 if (strEQ(d,"umask")) return -KEY_umask;
5480 if (strEQ(d,"unless")) return KEY_unless;
5481 if (strEQ(d,"unpack")) return -KEY_unpack;
5482 if (strEQ(d,"unlink")) return -KEY_unlink;
5485 if (strEQ(d,"unshift")) return KEY_unshift;
5486 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
5491 if (strEQ(d,"values")) return -KEY_values;
5492 if (strEQ(d,"vec")) return -KEY_vec;
5497 if (strEQ(d,"warn")) return -KEY_warn;
5498 if (strEQ(d,"wait")) return -KEY_wait;
5501 if (strEQ(d,"while")) return KEY_while;
5502 if (strEQ(d,"write")) return -KEY_write;
5505 if (strEQ(d,"waitpid")) return -KEY_waitpid;
5508 if (strEQ(d,"wantarray")) return -KEY_wantarray;
5513 if (len == 1) return -KEY_x;
5514 if (strEQ(d,"xor")) return -KEY_xor;
5517 if (len == 1) return KEY_y;
5526 S_checkcomma(pTHX_ register char *s, char *name, char *what)
5530 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
5531 dTHR; /* only for ckWARN */
5532 if (ckWARN(WARN_SYNTAX)) {
5534 for (w = s+2; *w && level; w++) {
5541 for (; *w && isSPACE(*w); w++) ;
5542 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
5543 Perl_warner(aTHX_ WARN_SYNTAX,
5544 "%s (...) interpreted as function",name);
5547 while (s < PL_bufend && isSPACE(*s))
5551 while (s < PL_bufend && isSPACE(*s))
5553 if (isIDFIRST_lazy_if(s,UTF)) {
5555 while (isALNUM_lazy_if(s,UTF))
5557 while (s < PL_bufend && isSPACE(*s))
5562 kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
5566 Perl_croak(aTHX_ "No comma allowed after %s", what);
5571 /* Either returns sv, or mortalizes sv and returns a new SV*.
5572 Best used as sv=new_constant(..., sv, ...).
5573 If s, pv are NULL, calls subroutine with one argument,
5574 and type is used with error messages only. */
5577 S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv,
5581 HV *table = GvHV(PL_hintgv); /* ^H */
5585 const char *why, *why1, *why2;
5587 if (!(PL_hints & HINT_LOCALIZE_HH)) {
5590 why = "%^H is not localized";
5594 msg = Perl_newSVpvf(aTHX_ "constant(%s): %s%s%s",
5595 (type ? type: "undef"), why1, why2, why);
5596 yyerror(SvPVX(msg));
5601 why = "%^H is not defined";
5604 cvp = hv_fetch(table, key, strlen(key), FALSE);
5605 if (!cvp || !SvOK(*cvp)) {
5606 why = "} is not defined";
5611 sv_2mortal(sv); /* Parent created it permanently */
5614 pv = sv_2mortal(newSVpvn(s, len));
5616 typesv = sv_2mortal(newSVpv(type, 0));
5618 typesv = &PL_sv_undef;
5620 PUSHSTACKi(PERLSI_OVERLOAD);
5633 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
5637 /* Check the eval first */
5638 if (!PL_in_eval && SvTRUE(ERRSV))
5641 sv_catpv(ERRSV, "Propagated");
5642 yyerror(SvPV(ERRSV, n_a)); /* Duplicates the message inside eval */
5644 res = SvREFCNT_inc(sv);
5648 (void)SvREFCNT_inc(res);
5657 why = "}} did not return a defined value";
5658 why1 = "Call to &{$^H{";
5668 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
5670 register char *d = dest;
5671 register char *e = d + destlen - 3; /* two-character token, ending NUL */
5674 Perl_croak(aTHX_ ident_too_long);
5675 if (isALNUM(*s)) /* UTF handled below */
5677 else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) {
5682 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
5686 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5687 char *t = s + UTF8SKIP(s);
5688 while (*t & 0x80 && is_utf8_mark((U8*)t))
5690 if (d + (t - s) > e)
5691 Perl_croak(aTHX_ ident_too_long);
5692 Copy(s, d, t - s, char);
5705 S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
5715 e = d + destlen - 3; /* two-character token, ending NUL */
5717 while (isDIGIT(*s)) {
5719 Perl_croak(aTHX_ ident_too_long);
5726 Perl_croak(aTHX_ ident_too_long);
5727 if (isALNUM(*s)) /* UTF handled below */
5729 else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
5734 else if (*s == ':' && s[1] == ':') {
5738 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5739 char *t = s + UTF8SKIP(s);
5740 while (*t & 0x80 && is_utf8_mark((U8*)t))
5742 if (d + (t - s) > e)
5743 Perl_croak(aTHX_ ident_too_long);
5744 Copy(s, d, t - s, char);
5755 if (PL_lex_state != LEX_NORMAL)
5756 PL_lex_state = LEX_INTERPENDMAYBE;
5759 if (*s == '$' && s[1] &&
5760 (isALNUM_lazy_if(s+1,UTF) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
5773 if (*d == '^' && *s && isCONTROLVAR(*s)) {
5778 if (isSPACE(s[-1])) {
5781 if (ch != ' ' && ch != '\t') {
5787 if (isIDFIRST_lazy_if(d,UTF)) {
5791 while (e < send && isALNUM_lazy_if(e,UTF) || *e == ':') {
5793 while (e < send && *e & 0x80 && is_utf8_mark((U8*)e))
5796 Copy(s, d, e - s, char);
5801 while ((isALNUM(*s) || *s == ':') && d < e)
5804 Perl_croak(aTHX_ ident_too_long);
5807 while (s < send && (*s == ' ' || *s == '\t')) s++;
5808 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
5809 dTHR; /* only for ckWARN */
5810 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
5811 const char *brack = *s == '[' ? "[...]" : "{...}";
5812 Perl_warner(aTHX_ WARN_AMBIGUOUS,
5813 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
5814 funny, dest, brack, funny, dest, brack);
5817 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
5821 /* Handle extended ${^Foo} variables
5822 * 1999-02-27 mjd-perl-patch@plover.com */
5823 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
5827 while (isALNUM(*s) && d < e) {
5831 Perl_croak(aTHX_ ident_too_long);
5836 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
5837 PL_lex_state = LEX_INTERPEND;
5840 if (PL_lex_state == LEX_NORMAL) {
5841 dTHR; /* only for ckWARN */
5842 if (ckWARN(WARN_AMBIGUOUS) &&
5843 (keyword(dest, d - dest) || get_cv(dest, FALSE)))
5845 Perl_warner(aTHX_ WARN_AMBIGUOUS,
5846 "Ambiguous use of %c{%s} resolved to %c%s",
5847 funny, dest, funny, dest);
5852 s = bracket; /* let the parser handle it */
5856 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
5857 PL_lex_state = LEX_INTERPEND;
5862 Perl_pmflag(pTHX_ U16 *pmfl, int ch)
5867 *pmfl |= PMf_GLOBAL;
5869 *pmfl |= PMf_CONTINUE;
5873 *pmfl |= PMf_MULTILINE;
5875 *pmfl |= PMf_SINGLELINE;
5877 *pmfl |= PMf_EXTENDED;
5881 S_scan_pat(pTHX_ char *start, I32 type)
5886 s = scan_str(start,FALSE,FALSE);
5889 SvREFCNT_dec(PL_lex_stuff);
5890 PL_lex_stuff = Nullsv;
5891 Perl_croak(aTHX_ "Search pattern not terminated");
5894 pm = (PMOP*)newPMOP(type, 0);
5895 if (PL_multi_open == '?')
5896 pm->op_pmflags |= PMf_ONCE;
5898 while (*s && strchr("iomsx", *s))
5899 pmflag(&pm->op_pmflags,*s++);
5902 while (*s && strchr("iogcmsx", *s))
5903 pmflag(&pm->op_pmflags,*s++);
5905 pm->op_pmpermflags = pm->op_pmflags;
5907 PL_lex_op = (OP*)pm;
5908 yylval.ival = OP_MATCH;
5913 S_scan_subst(pTHX_ char *start)
5920 yylval.ival = OP_NULL;
5922 s = scan_str(start,FALSE,FALSE);
5926 SvREFCNT_dec(PL_lex_stuff);
5927 PL_lex_stuff = Nullsv;
5928 Perl_croak(aTHX_ "Substitution pattern not terminated");
5931 if (s[-1] == PL_multi_open)
5934 first_start = PL_multi_start;
5935 s = scan_str(s,FALSE,FALSE);
5938 SvREFCNT_dec(PL_lex_stuff);
5939 PL_lex_stuff = Nullsv;
5941 SvREFCNT_dec(PL_lex_repl);
5942 PL_lex_repl = Nullsv;
5943 Perl_croak(aTHX_ "Substitution replacement not terminated");
5945 PL_multi_start = first_start; /* so whole substitution is taken together */
5947 pm = (PMOP*)newPMOP(OP_SUBST, 0);
5953 else if (strchr("iogcmsx", *s))
5954 pmflag(&pm->op_pmflags,*s++);
5961 PL_sublex_info.super_bufptr = s;
5962 PL_sublex_info.super_bufend = PL_bufend;
5964 pm->op_pmflags |= PMf_EVAL;
5965 repl = newSVpvn("",0);
5967 sv_catpv(repl, es ? "eval " : "do ");
5968 sv_catpvn(repl, "{ ", 2);
5969 sv_catsv(repl, PL_lex_repl);
5970 sv_catpvn(repl, " };", 2);
5972 SvREFCNT_dec(PL_lex_repl);
5976 pm->op_pmpermflags = pm->op_pmflags;
5977 PL_lex_op = (OP*)pm;
5978 yylval.ival = OP_SUBST;
5983 S_scan_trans(pTHX_ char *start)
5994 yylval.ival = OP_NULL;
5996 s = scan_str(start,FALSE,FALSE);
5999 SvREFCNT_dec(PL_lex_stuff);
6000 PL_lex_stuff = Nullsv;
6001 Perl_croak(aTHX_ "Transliteration pattern not terminated");
6003 if (s[-1] == PL_multi_open)
6006 s = scan_str(s,FALSE,FALSE);
6009 SvREFCNT_dec(PL_lex_stuff);
6010 PL_lex_stuff = Nullsv;
6012 SvREFCNT_dec(PL_lex_repl);
6013 PL_lex_repl = Nullsv;
6014 Perl_croak(aTHX_ "Transliteration replacement not terminated");
6018 o = newSVOP(OP_TRANS, 0, 0);
6019 utf8 = OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF;
6022 New(803,tbl,256,short);
6023 o = newPVOP(OP_TRANS, 0, (char*)tbl);
6027 complement = del = squash = 0;
6028 while (strchr("cdsCU", *s)) {
6030 complement = OPpTRANS_COMPLEMENT;
6032 del = OPpTRANS_DELETE;
6034 squash = OPpTRANS_SQUASH;
6039 utf8 &= ~OPpTRANS_FROM_UTF;
6041 utf8 |= OPpTRANS_FROM_UTF;
6045 utf8 &= ~OPpTRANS_TO_UTF;
6047 utf8 |= OPpTRANS_TO_UTF;
6050 Perl_croak(aTHX_ "Too many /C and /U options");
6055 o->op_private = del|squash|complement|utf8;
6058 yylval.ival = OP_TRANS;
6063 S_scan_heredoc(pTHX_ register char *s)
6067 I32 op_type = OP_SCALAR;
6074 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
6078 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
6081 for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
6082 if (*peek && strchr("`'\"",*peek)) {
6085 s = delimcpy(d, e, s, PL_bufend, term, &len);
6095 if (!isALNUM_lazy_if(s,UTF))
6096 deprecate("bare << to mean <<\"\"");
6097 for (; isALNUM_lazy_if(s,UTF); s++) {
6102 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
6103 Perl_croak(aTHX_ "Delimiter for here document is too long");
6106 len = d - PL_tokenbuf;
6107 #ifndef PERL_STRICT_CR
6108 d = strchr(s, '\r');
6112 while (s < PL_bufend) {
6118 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
6127 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6132 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
6133 herewas = newSVpvn(s,PL_bufend-s);
6135 s--, herewas = newSVpvn(s,d-s);
6136 s += SvCUR(herewas);
6138 tmpstr = NEWSV(87,79);
6139 sv_upgrade(tmpstr, SVt_PVIV);
6144 else if (term == '`') {
6145 op_type = OP_BACKTICK;
6146 SvIVX(tmpstr) = '\\';
6150 PL_multi_start = CopLINE(PL_curcop);
6151 PL_multi_open = PL_multi_close = '<';
6152 term = *PL_tokenbuf;
6153 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
6154 char *bufptr = PL_sublex_info.super_bufptr;
6155 char *bufend = PL_sublex_info.super_bufend;
6156 char *olds = s - SvCUR(herewas);
6157 s = strchr(bufptr, '\n');
6161 while (s < bufend &&
6162 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6164 CopLINE_inc(PL_curcop);
6167 CopLINE_set(PL_curcop, PL_multi_start);
6168 missingterm(PL_tokenbuf);
6170 sv_setpvn(herewas,bufptr,d-bufptr+1);
6171 sv_setpvn(tmpstr,d+1,s-d);
6173 sv_catpvn(herewas,s,bufend-s);
6174 (void)strcpy(bufptr,SvPVX(herewas));
6181 while (s < PL_bufend &&
6182 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6184 CopLINE_inc(PL_curcop);
6186 if (s >= PL_bufend) {
6187 CopLINE_set(PL_curcop, PL_multi_start);
6188 missingterm(PL_tokenbuf);
6190 sv_setpvn(tmpstr,d+1,s-d);
6192 CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
6194 sv_catpvn(herewas,s,PL_bufend-s);
6195 sv_setsv(PL_linestr,herewas);
6196 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
6197 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6200 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
6201 while (s >= PL_bufend) { /* multiple line string? */
6203 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6204 CopLINE_set(PL_curcop, PL_multi_start);
6205 missingterm(PL_tokenbuf);
6207 CopLINE_inc(PL_curcop);
6208 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6209 #ifndef PERL_STRICT_CR
6210 if (PL_bufend - PL_linestart >= 2) {
6211 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
6212 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
6214 PL_bufend[-2] = '\n';
6216 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6218 else if (PL_bufend[-1] == '\r')
6219 PL_bufend[-1] = '\n';
6221 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
6222 PL_bufend[-1] = '\n';
6224 if (PERLDB_LINE && PL_curstash != PL_debstash) {
6225 SV *sv = NEWSV(88,0);
6227 sv_upgrade(sv, SVt_PVMG);
6228 sv_setsv(sv,PL_linestr);
6229 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop),sv);
6231 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
6234 sv_catsv(PL_linestr,herewas);
6235 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6239 sv_catsv(tmpstr,PL_linestr);
6244 PL_multi_end = CopLINE(PL_curcop);
6245 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
6246 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
6247 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
6249 SvREFCNT_dec(herewas);
6250 PL_lex_stuff = tmpstr;
6251 yylval.ival = op_type;
6256 takes: current position in input buffer
6257 returns: new position in input buffer
6258 side-effects: yylval and lex_op are set.
6263 <FH> read from filehandle
6264 <pkg::FH> read from package qualified filehandle
6265 <pkg'FH> read from package qualified filehandle
6266 <$fh> read from filehandle in $fh
6272 S_scan_inputsymbol(pTHX_ char *start)
6274 register char *s = start; /* current position in buffer */
6280 d = PL_tokenbuf; /* start of temp holding space */
6281 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
6282 end = strchr(s, '\n');
6285 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
6287 /* die if we didn't have space for the contents of the <>,
6288 or if it didn't end, or if we see a newline
6291 if (len >= sizeof PL_tokenbuf)
6292 Perl_croak(aTHX_ "Excessively long <> operator");
6294 Perl_croak(aTHX_ "Unterminated <> operator");
6299 Remember, only scalar variables are interpreted as filehandles by
6300 this code. Anything more complex (e.g., <$fh{$num}>) will be
6301 treated as a glob() call.
6302 This code makes use of the fact that except for the $ at the front,
6303 a scalar variable and a filehandle look the same.
6305 if (*d == '$' && d[1]) d++;
6307 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
6308 while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
6311 /* If we've tried to read what we allow filehandles to look like, and
6312 there's still text left, then it must be a glob() and not a getline.
6313 Use scan_str to pull out the stuff between the <> and treat it
6314 as nothing more than a string.
6317 if (d - PL_tokenbuf != len) {
6318 yylval.ival = OP_GLOB;
6320 s = scan_str(start,FALSE,FALSE);
6322 Perl_croak(aTHX_ "Glob not terminated");
6326 /* we're in a filehandle read situation */
6329 /* turn <> into <ARGV> */
6331 (void)strcpy(d,"ARGV");
6333 /* if <$fh>, create the ops to turn the variable into a
6339 /* try to find it in the pad for this block, otherwise find
6340 add symbol table ops
6342 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
6343 OP *o = newOP(OP_PADSV, 0);
6345 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, o);
6348 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
6349 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
6350 newUNOP(OP_RV2SV, 0,
6351 newGVOP(OP_GV, 0, gv)));
6353 PL_lex_op->op_flags |= OPf_SPECIAL;
6354 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
6355 yylval.ival = OP_NULL;
6358 /* If it's none of the above, it must be a literal filehandle
6359 (<Foo::BAR> or <FOO>) so build a simple readline OP */
6361 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
6362 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
6363 yylval.ival = OP_NULL;
6372 takes: start position in buffer
6373 keep_quoted preserve \ on the embedded delimiter(s)
6374 keep_delims preserve the delimiters around the string
6375 returns: position to continue reading from buffer
6376 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
6377 updates the read buffer.
6379 This subroutine pulls a string out of the input. It is called for:
6380 q single quotes q(literal text)
6381 ' single quotes 'literal text'
6382 qq double quotes qq(interpolate $here please)
6383 " double quotes "interpolate $here please"
6384 qx backticks qx(/bin/ls -l)
6385 ` backticks `/bin/ls -l`
6386 qw quote words @EXPORT_OK = qw( func() $spam )
6387 m// regexp match m/this/
6388 s/// regexp substitute s/this/that/
6389 tr/// string transliterate tr/this/that/
6390 y/// string transliterate y/this/that/
6391 ($*@) sub prototypes sub foo ($)
6392 (stuff) sub attr parameters sub foo : attr(stuff)
6393 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
6395 In most of these cases (all but <>, patterns and transliterate)
6396 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
6397 calls scan_str(). s/// makes yylex() call scan_subst() which calls
6398 scan_str(). tr/// and y/// make yylex() call scan_trans() which
6401 It skips whitespace before the string starts, and treats the first
6402 character as the delimiter. If the delimiter is one of ([{< then
6403 the corresponding "close" character )]}> is used as the closing
6404 delimiter. It allows quoting of delimiters, and if the string has
6405 balanced delimiters ([{<>}]) it allows nesting.
6407 The lexer always reads these strings into lex_stuff, except in the
6408 case of the operators which take *two* arguments (s/// and tr///)
6409 when it checks to see if lex_stuff is full (presumably with the 1st
6410 arg to s or tr) and if so puts the string into lex_repl.
6415 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
6418 SV *sv; /* scalar value: string */
6419 char *tmps; /* temp string, used for delimiter matching */
6420 register char *s = start; /* current position in the buffer */
6421 register char term; /* terminating character */
6422 register char *to; /* current position in the sv's data */
6423 I32 brackets = 1; /* bracket nesting level */
6424 bool has_utf = FALSE; /* is there any utf8 content? */
6426 /* skip space before the delimiter */
6430 /* mark where we are, in case we need to report errors */
6433 /* after skipping whitespace, the next character is the terminator */
6435 if ((term & 0x80) && UTF)
6438 /* mark where we are */
6439 PL_multi_start = CopLINE(PL_curcop);
6440 PL_multi_open = term;
6442 /* find corresponding closing delimiter */
6443 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
6445 PL_multi_close = term;
6447 /* create a new SV to hold the contents. 87 is leak category, I'm
6448 assuming. 79 is the SV's initial length. What a random number. */
6450 sv_upgrade(sv, SVt_PVIV);
6452 (void)SvPOK_only(sv); /* validate pointer */
6454 /* move past delimiter and try to read a complete string */
6456 sv_catpvn(sv, s, 1);
6459 /* extend sv if need be */
6460 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
6461 /* set 'to' to the next character in the sv's string */
6462 to = SvPVX(sv)+SvCUR(sv);
6464 /* if open delimiter is the close delimiter read unbridle */
6465 if (PL_multi_open == PL_multi_close) {
6466 for (; s < PL_bufend; s++,to++) {
6467 /* embedded newlines increment the current line number */
6468 if (*s == '\n' && !PL_rsfp)
6469 CopLINE_inc(PL_curcop);
6470 /* handle quoted delimiters */
6471 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
6472 if (!keep_quoted && s[1] == term)
6474 /* any other quotes are simply copied straight through */
6478 /* terminate when run out of buffer (the for() condition), or
6479 have found the terminator */
6480 else if (*s == term)
6482 else if (!has_utf && (*s & 0x80) && UTF)
6488 /* if the terminator isn't the same as the start character (e.g.,
6489 matched brackets), we have to allow more in the quoting, and
6490 be prepared for nested brackets.
6493 /* read until we run out of string, or we find the terminator */
6494 for (; s < PL_bufend; s++,to++) {
6495 /* embedded newlines increment the line count */
6496 if (*s == '\n' && !PL_rsfp)
6497 CopLINE_inc(PL_curcop);
6498 /* backslashes can escape the open or closing characters */
6499 if (*s == '\\' && s+1 < PL_bufend) {
6501 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
6506 /* allow nested opens and closes */
6507 else if (*s == PL_multi_close && --brackets <= 0)
6509 else if (*s == PL_multi_open)
6511 else if (!has_utf && (*s & 0x80) && UTF)
6516 /* terminate the copied string and update the sv's end-of-string */
6518 SvCUR_set(sv, to - SvPVX(sv));
6521 * this next chunk reads more into the buffer if we're not done yet
6525 break; /* handle case where we are done yet :-) */
6527 #ifndef PERL_STRICT_CR
6528 if (to - SvPVX(sv) >= 2) {
6529 if ((to[-2] == '\r' && to[-1] == '\n') ||
6530 (to[-2] == '\n' && to[-1] == '\r'))
6534 SvCUR_set(sv, to - SvPVX(sv));
6536 else if (to[-1] == '\r')
6539 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
6543 /* if we're out of file, or a read fails, bail and reset the current
6544 line marker so we can report where the unterminated string began
6547 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6549 CopLINE_set(PL_curcop, PL_multi_start);
6552 /* we read a line, so increment our line counter */
6553 CopLINE_inc(PL_curcop);
6555 /* update debugger info */
6556 if (PERLDB_LINE && PL_curstash != PL_debstash) {
6557 SV *sv = NEWSV(88,0);
6559 sv_upgrade(sv, SVt_PVMG);
6560 sv_setsv(sv,PL_linestr);
6561 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop), sv);
6564 /* having changed the buffer, we must update PL_bufend */
6565 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6568 /* at this point, we have successfully read the delimited string */
6571 sv_catpvn(sv, s, 1);
6574 PL_multi_end = CopLINE(PL_curcop);
6577 /* if we allocated too much space, give some back */
6578 if (SvCUR(sv) + 5 < SvLEN(sv)) {
6579 SvLEN_set(sv, SvCUR(sv) + 1);
6580 Renew(SvPVX(sv), SvLEN(sv), char);
6583 /* decide whether this is the first or second quoted string we've read
6596 takes: pointer to position in buffer
6597 returns: pointer to new position in buffer
6598 side-effects: builds ops for the constant in yylval.op
6600 Read a number in any of the formats that Perl accepts:
6602 0(x[0-7A-F]+)|([0-7]+)|(b[01])
6603 [\d_]+(\.[\d_]*)?[Ee](\d+)
6605 Underbars (_) are allowed in decimal numbers. If -w is on,
6606 underbars before a decimal point must be at three digit intervals.
6608 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
6611 If it reads a number without a decimal point or an exponent, it will
6612 try converting the number to an integer and see if it can do so
6613 without loss of precision.
6617 Perl_scan_num(pTHX_ char *start)
6619 register char *s = start; /* current position in buffer */
6620 register char *d; /* destination in temp buffer */
6621 register char *e; /* end of temp buffer */
6622 IV tryiv; /* used to see if it can be an IV */
6623 NV value; /* number read, as a double */
6624 SV *sv = Nullsv; /* place to put the converted number */
6625 bool floatit; /* boolean: int or float? */
6626 char *lastub = 0; /* position of last underbar */
6627 static char number_too_long[] = "Number too long";
6629 /* We use the first character to decide what type of number this is */
6633 Perl_croak(aTHX_ "panic: scan_num");
6635 /* if it starts with a 0, it could be an octal number, a decimal in
6636 0.13 disguise, or a hexadecimal number, or a binary number. */
6640 u holds the "number so far"
6641 shift the power of 2 of the base
6642 (hex == 4, octal == 3, binary == 1)
6643 overflowed was the number more than we can hold?
6645 Shift is used when we add a digit. It also serves as an "are
6646 we in octal/hex/binary?" indicator to disallow hex characters
6653 bool overflowed = FALSE;
6654 static NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
6655 static char* bases[5] = { "", "binary", "", "octal",
6657 static char* Bases[5] = { "", "Binary", "", "Octal",
6659 static char *maxima[5] = { "",
6660 "0b11111111111111111111111111111111",
6664 char *base, *Base, *max;
6670 } else if (s[1] == 'b') {
6674 /* check for a decimal in disguise */
6675 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
6677 /* so it must be octal */
6681 base = bases[shift];
6682 Base = Bases[shift];
6683 max = maxima[shift];
6685 /* read the rest of the number */
6687 /* x is used in the overflow test,
6688 b is the digit we're adding on. */
6693 /* if we don't mention it, we're done */
6702 /* 8 and 9 are not octal */
6705 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
6709 case '2': case '3': case '4':
6710 case '5': case '6': case '7':
6712 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
6716 b = *s++ & 15; /* ASCII digit -> value of digit */
6720 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
6721 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
6722 /* make sure they said 0x */
6727 /* Prepare to put the digit we have onto the end
6728 of the number so far. We check for overflows.
6733 x = u << shift; /* make room for the digit */
6735 if ((x >> shift) != u
6736 && !(PL_hints & HINT_NEW_BINARY)) {
6740 if (ckWARN_d(WARN_OVERFLOW))
6741 Perl_warner(aTHX_ WARN_OVERFLOW,
6742 "Integer overflow in %s number",
6745 u = x | b; /* add the digit to the end */
6748 n *= nvshift[shift];
6749 /* If an NV has not enough bits in its
6750 * mantissa to represent an UV this summing of
6751 * small low-order numbers is a waste of time
6752 * (because the NV cannot preserve the
6753 * low-order bits anyway): we could just
6754 * remember when did we overflow and in the
6755 * end just multiply n by the right
6763 /* if we get here, we had success: make a scalar value from
6770 if (ckWARN(WARN_PORTABLE) && n > 4294967295.0)
6771 Perl_warner(aTHX_ WARN_PORTABLE,
6772 "%s number > %s non-portable",
6779 if (ckWARN(WARN_PORTABLE) && u > 0xffffffff)
6780 Perl_warner(aTHX_ WARN_PORTABLE,
6781 "%s number > %s non-portable",
6786 if (PL_hints & HINT_NEW_BINARY)
6787 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
6792 handle decimal numbers.
6793 we're also sent here when we read a 0 as the first digit
6795 case '1': case '2': case '3': case '4': case '5':
6796 case '6': case '7': case '8': case '9': case '.':
6799 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
6802 /* read next group of digits and _ and copy into d */
6803 while (isDIGIT(*s) || *s == '_') {
6804 /* skip underscores, checking for misplaced ones
6808 dTHR; /* only for ckWARN */
6809 if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
6810 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
6814 /* check for end of fixed-length buffer */
6816 Perl_croak(aTHX_ number_too_long);
6817 /* if we're ok, copy the character */
6822 /* final misplaced underbar check */
6823 if (lastub && s - lastub != 3) {
6825 if (ckWARN(WARN_SYNTAX))
6826 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
6829 /* read a decimal portion if there is one. avoid
6830 3..5 being interpreted as the number 3. followed
6833 if (*s == '.' && s[1] != '.') {
6837 /* copy, ignoring underbars, until we run out of
6838 digits. Note: no misplaced underbar checks!
6840 for (; isDIGIT(*s) || *s == '_'; s++) {
6841 /* fixed length buffer check */
6843 Perl_croak(aTHX_ number_too_long);
6849 /* read exponent part, if present */
6850 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
6854 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
6855 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
6857 /* allow positive or negative exponent */
6858 if (*s == '+' || *s == '-')
6861 /* read digits of exponent (no underbars :-) */
6862 while (isDIGIT(*s)) {
6864 Perl_croak(aTHX_ number_too_long);
6869 /* terminate the string */
6872 /* make an sv from the string */
6875 value = Atof(PL_tokenbuf);
6878 See if we can make do with an integer value without loss of
6879 precision. We use I_V to cast to an int, because some
6880 compilers have issues. Then we try casting it back and see
6881 if it was the same. We only do this if we know we
6882 specifically read an integer.
6884 Note: if floatit is true, then we don't need to do the
6888 if (!floatit && (NV)tryiv == value)
6889 sv_setiv(sv, tryiv);
6891 sv_setnv(sv, value);
6892 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
6893 (PL_hints & HINT_NEW_INTEGER) )
6894 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
6895 (floatit ? "float" : "integer"),
6898 /* if it starts with a v, it could be a version number */
6903 while (isDIGIT(*pos))
6905 if (*pos == '.' && isDIGIT(pos[1])) {
6911 s++; /* get past 'v' */
6914 SvUPGRADE(sv, SVt_PVNV);
6915 sv_setpvn(sv, "", 0);
6918 if (*s == '0' && isDIGIT(s[1]))
6919 yyerror("Octal number in vector unsupported");
6922 while (isDIGIT(*pos))
6926 tmpend = uv_to_utf8(tmpbuf, rev);
6930 tmpbuf[0] = (U8)rev;
6931 tmpend = &tmpbuf[1];
6934 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
6936 SvNVX(sv) += (NV)rev/nshift;
6938 } while (*pos == '.' && isDIGIT(pos[1]));
6940 if (*s == '0' && isDIGIT(s[1]))
6941 yyerror("Octal number in vector unsupported");
6944 tmpend = uv_to_utf8(tmpbuf, rev);
6945 utf8 = utf8 || rev > 127;
6947 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
6949 SvNVX(sv) += (NV)rev/nshift;
6961 /* make the op for the constant and return */
6964 yylval.opval = newSVOP(OP_CONST, 0, sv);
6966 yylval.opval = Nullop;
6972 S_scan_formline(pTHX_ register char *s)
6977 SV *stuff = newSVpvn("",0);
6978 bool needargs = FALSE;
6981 if (*s == '.' || *s == '}') {
6983 #ifdef PERL_STRICT_CR
6984 for (t = s+1;*t == ' ' || *t == '\t'; t++) ;
6986 for (t = s+1;*t == ' ' || *t == '\t' || *t == '\r'; t++) ;
6988 if (*t == '\n' || t == PL_bufend)
6991 if (PL_in_eval && !PL_rsfp) {
6992 eol = strchr(s,'\n');
6997 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6999 for (t = s; t < eol; t++) {
7000 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
7002 goto enough; /* ~~ must be first line in formline */
7004 if (*t == '@' || *t == '^')
7007 sv_catpvn(stuff, s, eol-s);
7008 #ifndef PERL_STRICT_CR
7009 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
7010 char *end = SvPVX(stuff) + SvCUR(stuff);
7019 s = filter_gets(PL_linestr, PL_rsfp, 0);
7020 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
7021 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
7024 yyerror("Format not terminated");
7034 PL_lex_state = LEX_NORMAL;
7035 PL_nextval[PL_nexttoke].ival = 0;
7039 PL_lex_state = LEX_FORMLINE;
7040 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
7042 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
7046 SvREFCNT_dec(stuff);
7047 PL_lex_formbrack = 0;
7058 PL_cshlen = strlen(PL_cshname);
7063 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
7066 I32 oldsavestack_ix = PL_savestack_ix;
7067 CV* outsidecv = PL_compcv;
7071 assert(SvTYPE(PL_compcv) == SVt_PVCV);
7073 SAVEI32(PL_subline);
7074 save_item(PL_subname);
7077 SAVESPTR(PL_comppad_name);
7078 SAVESPTR(PL_compcv);
7079 SAVEI32(PL_comppad_name_fill);
7080 SAVEI32(PL_min_intro_pending);
7081 SAVEI32(PL_max_intro_pending);
7082 SAVEI32(PL_pad_reset_pending);
7084 PL_compcv = (CV*)NEWSV(1104,0);
7085 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
7086 CvFLAGS(PL_compcv) |= flags;
7088 PL_comppad = newAV();
7089 av_push(PL_comppad, Nullsv);
7090 PL_curpad = AvARRAY(PL_comppad);
7091 PL_comppad_name = newAV();
7092 PL_comppad_name_fill = 0;
7093 PL_min_intro_pending = 0;
7095 PL_subline = CopLINE(PL_curcop);
7097 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
7098 PL_curpad[0] = (SV*)newAV();
7099 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
7100 #endif /* USE_THREADS */
7102 comppadlist = newAV();
7103 AvREAL_off(comppadlist);
7104 av_store(comppadlist, 0, (SV*)PL_comppad_name);
7105 av_store(comppadlist, 1, (SV*)PL_comppad);
7107 CvPADLIST(PL_compcv) = comppadlist;
7108 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
7110 CvOWNER(PL_compcv) = 0;
7111 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
7112 MUTEX_INIT(CvMUTEXP(PL_compcv));
7113 #endif /* USE_THREADS */
7115 return oldsavestack_ix;
7119 Perl_yywarn(pTHX_ char *s)
7122 PL_in_eval |= EVAL_WARNONLY;
7124 PL_in_eval &= ~EVAL_WARNONLY;
7129 Perl_yyerror(pTHX_ char *s)
7133 char *context = NULL;
7137 if (!yychar || (yychar == ';' && !PL_rsfp))
7139 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
7140 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
7141 while (isSPACE(*PL_oldoldbufptr))
7143 context = PL_oldoldbufptr;
7144 contlen = PL_bufptr - PL_oldoldbufptr;
7146 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
7147 PL_oldbufptr != PL_bufptr) {
7148 while (isSPACE(*PL_oldbufptr))
7150 context = PL_oldbufptr;
7151 contlen = PL_bufptr - PL_oldbufptr;
7153 else if (yychar > 255)
7154 where = "next token ???";
7155 #ifdef USE_PURE_BISON
7156 /* GNU Bison sets the value -2 */
7157 else if (yychar == -2) {
7159 else if ((yychar & 127) == 127) {
7161 if (PL_lex_state == LEX_NORMAL ||
7162 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
7163 where = "at end of line";
7164 else if (PL_lex_inpat)
7165 where = "within pattern";
7167 where = "within string";
7170 SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
7172 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
7173 else if (isPRINT_LC(yychar))
7174 Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
7176 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
7177 where = SvPVX(where_sv);
7179 msg = sv_2mortal(newSVpv(s, 0));
7180 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
7181 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
7183 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
7185 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
7186 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
7187 Perl_sv_catpvf(aTHX_ msg,
7188 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
7189 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
7192 if (PL_in_eval & EVAL_WARNONLY)
7193 Perl_warn(aTHX_ "%"SVf, msg);
7196 if (PL_error_count >= 10)
7197 Perl_croak(aTHX_ "%s has too many errors.\n", CopFILE(PL_curcop));
7199 PL_in_my_stash = Nullhv;
7210 * Restore a source filter.
7214 restore_rsfp(pTHXo_ void *f)
7216 PerlIO *fp = (PerlIO*)f;
7218 if (PL_rsfp == PerlIO_stdin())
7219 PerlIO_clearerr(PL_rsfp);
7220 else if (PL_rsfp && (PL_rsfp != fp))
7221 PerlIO_close(PL_rsfp);