3 * Copyright (c) 1991-1999, 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 SAVECOPLINE(PL_curcop);
382 SAVEPPTR(PL_oldbufptr);
383 SAVEPPTR(PL_oldoldbufptr);
384 SAVEPPTR(PL_linestart);
385 SAVESPTR(PL_linestr);
386 SAVEPPTR(PL_lex_brackstack);
387 SAVEPPTR(PL_lex_casestack);
388 SAVEDESTRUCTOR_X(restore_rsfp, PL_rsfp);
389 SAVESPTR(PL_lex_stuff);
390 SAVEI32(PL_lex_defer);
391 SAVEI32(PL_sublex_info.sub_inwhat);
392 SAVESPTR(PL_lex_repl);
394 SAVEINT(PL_lex_expect);
396 PL_lex_state = LEX_NORMAL;
400 New(899, PL_lex_brackstack, 120, char);
401 New(899, PL_lex_casestack, 12, char);
402 SAVEFREEPV(PL_lex_brackstack);
403 SAVEFREEPV(PL_lex_casestack);
405 *PL_lex_casestack = '\0';
408 PL_lex_stuff = Nullsv;
409 PL_lex_repl = Nullsv;
412 PL_sublex_info.sub_inwhat = 0;
414 if (SvREADONLY(PL_linestr))
415 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
416 s = SvPV(PL_linestr, len);
417 if (len && s[len-1] != ';') {
418 if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
419 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
420 sv_catpvn(PL_linestr, "\n;", 2);
422 SvTEMP_off(PL_linestr);
423 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
424 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
426 PL_rs = newSVpvn("\n", 1);
432 * Finalizer for lexing operations. Must be called when the parser is
433 * done with the lexer.
439 PL_doextract = FALSE;
444 * This subroutine has nothing to do with tilting, whether at windmills
445 * or pinball tables. Its name is short for "increment line". It
446 * increments the current line number in CopLINE(PL_curcop) and checks
447 * to see whether the line starts with a comment of the form
448 * # line 500 "foo.pm"
449 * If so, it sets the current line number and file to the values in the comment.
453 S_incline(pTHX_ char *s)
461 CopLINE_inc(PL_curcop);
464 while (*s == ' ' || *s == '\t') s++;
465 if (strnEQ(s, "line ", 5)) {
474 while (*s == ' ' || *s == '\t')
476 if (*s == '"' && (t = strchr(s+1, '"')))
480 return; /* false alarm */
481 for (t = s; !isSPACE(*t); t++) ;
486 CopFILE_set(PL_curcop, s);
488 CopLINE_set(PL_curcop, atoi(n)-1);
493 * Called to gobble the appropriate amount and type of whitespace.
494 * Skips comments as well.
498 S_skipspace(pTHX_ register char *s)
501 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
502 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
508 SSize_t oldprevlen, oldoldprevlen;
509 SSize_t oldloplen, oldunilen;
510 while (s < PL_bufend && isSPACE(*s)) {
511 if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
516 if (s < PL_bufend && *s == '#') {
517 while (s < PL_bufend && *s != '\n')
521 if (PL_in_eval && !PL_rsfp) {
528 /* only continue to recharge the buffer if we're at the end
529 * of the buffer, we're not reading from a source filter, and
530 * we're in normal lexing mode
532 if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat ||
533 PL_lex_state == LEX_FORMLINE)
536 /* try to recharge the buffer */
537 if ((s = filter_gets(PL_linestr, PL_rsfp,
538 (prevlen = SvCUR(PL_linestr)))) == Nullch)
540 /* end of file. Add on the -p or -n magic */
541 if (PL_minus_n || PL_minus_p) {
542 sv_setpv(PL_linestr,PL_minus_p ?
543 ";}continue{print or die qq(-p destination: $!\\n)" :
545 sv_catpv(PL_linestr,";}");
546 PL_minus_n = PL_minus_p = 0;
549 sv_setpv(PL_linestr,";");
551 /* reset variables for next time we lex */
552 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
554 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
556 /* Close the filehandle. Could be from -P preprocessor,
557 * STDIN, or a regular file. If we were reading code from
558 * STDIN (because the commandline held no -e or filename)
559 * then we don't close it, we reset it so the code can
560 * read from STDIN too.
563 if (PL_preprocess && !PL_in_eval)
564 (void)PerlProc_pclose(PL_rsfp);
565 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
566 PerlIO_clearerr(PL_rsfp);
568 (void)PerlIO_close(PL_rsfp);
573 /* not at end of file, so we only read another line */
574 /* make corresponding updates to old pointers, for yyerror() */
575 oldprevlen = PL_oldbufptr - PL_bufend;
576 oldoldprevlen = PL_oldoldbufptr - PL_bufend;
578 oldunilen = PL_last_uni - PL_bufend;
580 oldloplen = PL_last_lop - PL_bufend;
581 PL_linestart = PL_bufptr = s + prevlen;
582 PL_bufend = s + SvCUR(PL_linestr);
584 PL_oldbufptr = s + oldprevlen;
585 PL_oldoldbufptr = s + oldoldprevlen;
587 PL_last_uni = s + oldunilen;
589 PL_last_lop = s + oldloplen;
592 /* debugger active and we're not compiling the debugger code,
593 * so store the line into the debugger's array of lines
595 if (PERLDB_LINE && PL_curstash != PL_debstash) {
596 SV *sv = NEWSV(85,0);
598 sv_upgrade(sv, SVt_PVMG);
599 sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
600 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
607 * Check the unary operators to ensure there's no ambiguity in how they're
608 * used. An ambiguous piece of code would be:
610 * This doesn't mean rand() + 5. Because rand() is a unary operator,
611 * the +5 is its argument.
621 if (PL_oldoldbufptr != PL_last_uni)
623 while (isSPACE(*PL_last_uni))
625 for (s = PL_last_uni; isALNUM_lazy_if(s,UTF) || *s == '-'; s++) ;
626 if ((t = strchr(s, '(')) && t < PL_bufptr)
628 if (ckWARN_d(WARN_AMBIGUOUS)){
631 Perl_warner(aTHX_ WARN_AMBIGUOUS,
632 "Warning: Use of \"%s\" without parens is ambiguous",
638 /* workaround to replace the UNI() macro with a function. Only the
639 * hints/uts.sh file mentions this. Other comments elsewhere in the
640 * source indicate Microport Unix might need it too.
646 #define UNI(f) return uni(f,s)
649 S_uni(pTHX_ I32 f, char *s)
654 PL_last_uni = PL_oldbufptr;
665 #endif /* CRIPPLED_CC */
668 * LOP : macro to build a list operator. Its behaviour has been replaced
669 * with a subroutine, S_lop() for which LOP is just another name.
672 #define LOP(f,x) return lop(f,x,s)
676 * Build a list operator (or something that might be one). The rules:
677 * - if we have a next token, then it's a list operator [why?]
678 * - if the next thing is an opening paren, then it's a function
679 * - else it's a list operator
683 S_lop(pTHX_ I32 f, int x, char *s)
690 PL_last_lop = PL_oldbufptr;
705 * When the lexer realizes it knows the next token (for instance,
706 * it is reordering tokens for the parser) then it can call S_force_next
707 * to know what token to return the next time the lexer is called. Caller
708 * will need to set PL_nextval[], and possibly PL_expect to ensure the lexer
709 * handles the token correctly.
713 S_force_next(pTHX_ I32 type)
715 PL_nexttype[PL_nexttoke] = type;
717 if (PL_lex_state != LEX_KNOWNEXT) {
718 PL_lex_defer = PL_lex_state;
719 PL_lex_expect = PL_expect;
720 PL_lex_state = LEX_KNOWNEXT;
726 * When the lexer knows the next thing is a word (for instance, it has
727 * just seen -> and it knows that the next char is a word char, then
728 * it calls S_force_word to stick the next word into the PL_next lookahead.
731 * char *start : buffer position (must be within PL_linestr)
732 * int token : PL_next will be this type of bare word (e.g., METHOD,WORD)
733 * int check_keyword : if true, Perl checks to make sure the word isn't
734 * a keyword (do this if the word is a label, e.g. goto FOO)
735 * int allow_pack : if true, : characters will also be allowed (require,
737 * int allow_initial_tick : used by the "sub" lexer only.
741 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
746 start = skipspace(start);
748 if (isIDFIRST_lazy_if(s,UTF) ||
749 (allow_pack && *s == ':') ||
750 (allow_initial_tick && *s == '\'') )
752 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
753 if (check_keyword && keyword(PL_tokenbuf, len))
755 if (token == METHOD) {
760 PL_expect = XOPERATOR;
763 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(PL_tokenbuf,0));
764 PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
772 * Called when the lexer wants $foo *foo &foo etc, but the program
773 * text only contains the "foo" portion. The first argument is a pointer
774 * to the "foo", and the second argument is the type symbol to prefix.
775 * Forces the next token to be a "WORD".
776 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
780 S_force_ident(pTHX_ register char *s, int kind)
783 OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
784 PL_nextval[PL_nexttoke].opval = o;
787 dTHR; /* just for in_eval */
788 o->op_private = OPpCONST_ENTERED;
789 /* XXX see note in pp_entereval() for why we forgo typo
790 warnings if the symbol must be introduced in an eval.
792 gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
793 kind == '$' ? SVt_PV :
794 kind == '@' ? SVt_PVAV :
795 kind == '%' ? SVt_PVHV :
804 * Forces the next token to be a version number.
808 S_force_version(pTHX_ char *s)
810 OP *version = Nullop;
814 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
818 for (; isDIGIT(*d) || *d == '_' || *d == '.'; d++);
819 if ((*d == ';' || isSPACE(*d)) && *(skipspace(d)) != ',') {
821 /* real VERSION number -- GBARR */
822 version = yylval.opval;
826 /* NOTE: The parser sees the package name and the VERSION swapped */
827 PL_nextval[PL_nexttoke].opval = version;
835 * Tokenize a quoted string passed in as an SV. It finds the next
836 * chunk, up to end of string or a backslash. It may make a new
837 * SV containing that chunk (if HINT_NEW_STRING is on). It also
842 S_tokeq(pTHX_ SV *sv)
853 s = SvPV_force(sv, len);
857 while (s < send && *s != '\\')
862 if ( PL_hints & HINT_NEW_STRING )
863 pv = sv_2mortal(newSVpvn(SvPVX(pv), len));
866 if (s + 1 < send && (s[1] == '\\'))
867 s++; /* all that, just for this */
872 SvCUR_set(sv, d - SvPVX(sv));
874 if ( PL_hints & HINT_NEW_STRING )
875 return new_constant(NULL, 0, "q", sv, pv, "q");
880 * Now come three functions related to double-quote context,
881 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
882 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
883 * interact with PL_lex_state, and create fake ( ... ) argument lists
884 * to handle functions and concatenation.
885 * They assume that whoever calls them will be setting up a fake
886 * join call, because each subthing puts a ',' after it. This lets
889 * join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
891 * (I'm not sure whether the spurious commas at the end of lcfirst's
892 * arguments and join's arguments are created or not).
897 * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST).
899 * Pattern matching will set PL_lex_op to the pattern-matching op to
900 * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise).
902 * OP_CONST and OP_READLINE are easy--just make the new op and return.
904 * Everything else becomes a FUNC.
906 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
907 * had an OP_CONST or OP_READLINE). This just sets us up for a
908 * call to S_sublex_push().
914 register I32 op_type = yylval.ival;
916 if (op_type == OP_NULL) {
917 yylval.opval = PL_lex_op;
921 if (op_type == OP_CONST || op_type == OP_READLINE) {
922 SV *sv = tokeq(PL_lex_stuff);
924 if (SvTYPE(sv) == SVt_PVIV) {
925 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
931 nsv = newSVpvn(p, len);
935 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
936 PL_lex_stuff = Nullsv;
940 PL_sublex_info.super_state = PL_lex_state;
941 PL_sublex_info.sub_inwhat = op_type;
942 PL_sublex_info.sub_op = PL_lex_op;
943 PL_lex_state = LEX_INTERPPUSH;
947 yylval.opval = PL_lex_op;
957 * Create a new scope to save the lexing state. The scope will be
958 * ended in S_sublex_done. Returns a '(', starting the function arguments
959 * to the uc, lc, etc. found before.
960 * Sets PL_lex_state to LEX_INTERPCONCAT.
969 PL_lex_state = PL_sublex_info.super_state;
970 SAVEI32(PL_lex_dojoin);
971 SAVEI32(PL_lex_brackets);
972 SAVEI32(PL_lex_casemods);
973 SAVEI32(PL_lex_starts);
974 SAVEI32(PL_lex_state);
975 SAVEVPTR(PL_lex_inpat);
976 SAVEI32(PL_lex_inwhat);
977 SAVECOPLINE(PL_curcop);
979 SAVEPPTR(PL_oldbufptr);
980 SAVEPPTR(PL_oldoldbufptr);
981 SAVEPPTR(PL_linestart);
982 SAVESPTR(PL_linestr);
983 SAVEPPTR(PL_lex_brackstack);
984 SAVEPPTR(PL_lex_casestack);
986 PL_linestr = PL_lex_stuff;
987 PL_lex_stuff = Nullsv;
989 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
991 PL_bufend += SvCUR(PL_linestr);
992 SAVEFREESV(PL_linestr);
994 PL_lex_dojoin = FALSE;
996 New(899, PL_lex_brackstack, 120, char);
997 New(899, PL_lex_casestack, 12, char);
998 SAVEFREEPV(PL_lex_brackstack);
999 SAVEFREEPV(PL_lex_casestack);
1000 PL_lex_casemods = 0;
1001 *PL_lex_casestack = '\0';
1003 PL_lex_state = LEX_INTERPCONCAT;
1004 CopLINE_set(PL_curcop, PL_multi_start);
1006 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1007 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1008 PL_lex_inpat = PL_sublex_info.sub_op;
1010 PL_lex_inpat = Nullop;
1017 * Restores lexer state after a S_sublex_push.
1023 if (!PL_lex_starts++) {
1024 PL_expect = XOPERATOR;
1025 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpvn("",0));
1029 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
1030 PL_lex_state = LEX_INTERPCASEMOD;
1034 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1035 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1036 PL_linestr = PL_lex_repl;
1038 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1039 PL_bufend += SvCUR(PL_linestr);
1040 SAVEFREESV(PL_linestr);
1041 PL_lex_dojoin = FALSE;
1042 PL_lex_brackets = 0;
1043 PL_lex_casemods = 0;
1044 *PL_lex_casestack = '\0';
1046 if (SvEVALED(PL_lex_repl)) {
1047 PL_lex_state = LEX_INTERPNORMAL;
1049 /* we don't clear PL_lex_repl here, so that we can check later
1050 whether this is an evalled subst; that means we rely on the
1051 logic to ensure sublex_done() is called again only via the
1052 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1055 PL_lex_state = LEX_INTERPCONCAT;
1056 PL_lex_repl = Nullsv;
1062 PL_bufend = SvPVX(PL_linestr);
1063 PL_bufend += SvCUR(PL_linestr);
1064 PL_expect = XOPERATOR;
1065 PL_sublex_info.sub_inwhat = 0;
1073 Extracts a pattern, double-quoted string, or transliteration. This
1076 It looks at lex_inwhat and PL_lex_inpat to find out whether it's
1077 processing a pattern (PL_lex_inpat is true), a transliteration
1078 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
1080 Returns a pointer to the character scanned up to. Iff this is
1081 advanced from the start pointer supplied (ie if anything was
1082 successfully parsed), will leave an OP for the substring scanned
1083 in yylval. Caller must intuit reason for not parsing further
1084 by looking at the next characters herself.
1088 double-quoted style: \r and \n
1089 regexp special ones: \D \s
1091 backrefs: \1 (deprecated in substitution replacements)
1092 case and quoting: \U \Q \E
1093 stops on @ and $, but not for $ as tail anchor
1095 In transliterations:
1096 characters are VERY literal, except for - not at the start or end
1097 of the string, which indicates a range. scan_const expands the
1098 range to the full set of intermediate characters.
1100 In double-quoted strings:
1102 double-quoted style: \r and \n
1104 backrefs: \1 (deprecated)
1105 case and quoting: \U \Q \E
1108 scan_const does *not* construct ops to handle interpolated strings.
1109 It stops processing as soon as it finds an embedded $ or @ variable
1110 and leaves it to the caller to work out what's going on.
1112 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
1114 $ in pattern could be $foo or could be tail anchor. Assumption:
1115 it's a tail anchor if $ is the last thing in the string, or if it's
1116 followed by one of ")| \n\t"
1118 \1 (backreferences) are turned into $1
1120 The structure of the code is
1121 while (there's a character to process) {
1122 handle transliteration ranges
1123 skip regexp comments
1124 skip # initiated comments in //x patterns
1125 check for embedded @foo
1126 check for embedded scalars
1128 leave intact backslashes from leave (below)
1129 deprecate \1 in strings and sub replacements
1130 handle string-changing backslashes \l \U \Q \E, etc.
1131 switch (what was escaped) {
1132 handle - in a transliteration (becomes a literal -)
1133 handle \132 octal characters
1134 handle 0x15 hex characters
1135 handle \cV (control V)
1136 handle printf backslashes (\f, \r, \n, etc)
1138 } (end if backslash)
1139 } (end while character to read)
1144 S_scan_const(pTHX_ char *start)
1146 register char *send = PL_bufend; /* end of the constant */
1147 SV *sv = NEWSV(93, send - start); /* sv for the constant */
1148 register char *s = start; /* start of the constant */
1149 register char *d = SvPVX(sv); /* destination for copies */
1150 bool dorange = FALSE; /* are we in a translit range? */
1151 bool has_utf = FALSE; /* embedded \x{} */
1153 I32 utf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op)
1154 ? (PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
1156 I32 thisutf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op)
1157 ? (PL_sublex_info.sub_op->op_private & (PL_lex_repl ?
1158 OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF))
1160 const char *leaveit = /* set of acceptably-backslashed characters */
1162 ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
1165 while (s < send || dorange) {
1166 /* get transliterations out of the way (they're most literal) */
1167 if (PL_lex_inwhat == OP_TRANS) {
1168 /* expand a range A-Z to the full set of characters. AIE! */
1170 I32 i; /* current expanded character */
1171 I32 min; /* first character in range */
1172 I32 max; /* last character in range */
1174 i = d - SvPVX(sv); /* remember current offset */
1175 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
1176 d = SvPVX(sv) + i; /* refresh d after realloc */
1177 d -= 2; /* eat the first char and the - */
1179 min = (U8)*d; /* first char in range */
1180 max = (U8)d[1]; /* last char in range */
1183 if ((isLOWER(min) && isLOWER(max)) ||
1184 (isUPPER(min) && isUPPER(max))) {
1186 for (i = min; i <= max; i++)
1190 for (i = min; i <= max; i++)
1197 for (i = min; i <= max; i++)
1200 /* mark the range as done, and continue */
1205 /* range begins (ignore - as first or last char) */
1206 else if (*s == '-' && s+1 < send && s != start) {
1208 *d++ = (char)0xff; /* use illegal utf8 byte--see pmtrans */
1217 /* if we get here, we're not doing a transliteration */
1219 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
1220 except for the last char, which will be done separately. */
1221 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
1223 while (s < send && *s != ')')
1225 } else if (s[2] == '{'
1226 || s[2] == 'p' && s[3] == '{') { /* This should march regcomp.c */
1228 char *regparse = s + (s[2] == '{' ? 3 : 4);
1231 while (count && (c = *regparse)) {
1232 if (c == '\\' && regparse[1])
1240 if (*regparse != ')') {
1241 regparse--; /* Leave one char for continuation. */
1242 yyerror("Sequence (?{...}) not terminated or not {}-balanced");
1244 while (s < regparse)
1249 /* likewise skip #-initiated comments in //x patterns */
1250 else if (*s == '#' && PL_lex_inpat &&
1251 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
1252 while (s+1 < send && *s != '\n')
1256 /* check for embedded arrays (@foo, @:foo, @'foo, @{foo}, @$foo) */
1257 else if (*s == '@' && s[1]
1258 && (isALNUM_lazy_if(s+1,UTF) || strchr(":'{$", s[1])))
1261 /* check for embedded scalars. only stop if we're sure it's a
1264 else if (*s == '$') {
1265 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
1267 if (s + 1 < send && !strchr("()| \n\t", s[1]))
1268 break; /* in regexp, $ might be tail anchor */
1271 /* (now in tr/// code again) */
1273 if (*s & 0x80 && thisutf) {
1274 dTHR; /* only for ckWARN */
1275 if (ckWARN(WARN_UTF8)) {
1276 (void)utf8_to_uv((U8*)s, &len); /* could cvt latin-1 to utf8 here... */
1285 has_utf = TRUE; /* assume valid utf8 */
1289 if (*s == '\\' && s+1 < send) {
1292 /* some backslashes we leave behind */
1293 if (*leaveit && *s && strchr(leaveit, *s)) {
1299 /* deprecate \1 in strings and substitution replacements */
1300 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1301 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1303 dTHR; /* only for ckWARN */
1304 if (ckWARN(WARN_SYNTAX))
1305 Perl_warner(aTHX_ WARN_SYNTAX, "\\%c better written as $%c", *s, *s);
1310 /* string-change backslash escapes */
1311 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1316 /* if we get here, it's either a quoted -, or a digit */
1319 /* quoted - in transliterations */
1321 if (PL_lex_inwhat == OP_TRANS) {
1329 if (ckWARN(WARN_UNSAFE) && isALPHA(*s))
1330 Perl_warner(aTHX_ WARN_UNSAFE,
1331 "Unrecognized escape \\%c passed through",
1333 /* default action is to copy the quoted character */
1338 /* \132 indicates an octal constant */
1339 case '0': case '1': case '2': case '3':
1340 case '4': case '5': case '6': case '7':
1341 *d++ = (char)scan_oct(s, 3, &len);
1345 /* \x24 indicates a hex constant */
1349 char* e = strchr(s, '}');
1352 yyerror("Missing right brace on \\x{}");
1357 if (ckWARN(WARN_UTF8))
1358 Perl_warner(aTHX_ WARN_UTF8,
1359 "Use of \\x{} without utf8 declaration");
1361 /* note: utf always shorter than hex */
1362 d = (char*)uv_to_utf8((U8*)d,
1363 (UV)scan_hex(s + 1, e - s - 1, &len));
1368 UV uv = (UV)scan_hex(s, 2, &len);
1369 if (utf && PL_lex_inwhat == OP_TRANS &&
1370 utf != (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
1372 d = (char*)uv_to_utf8((U8*)d, uv); /* doing a CU or UC */
1376 if (uv >= 127 && UTF) {
1378 if (ckWARN(WARN_UTF8))
1379 Perl_warner(aTHX_ WARN_UTF8,
1380 "\\x%.*s will produce malformed UTF-8 character; use \\x{%.*s} for that",
1381 (int)len,s,(int)len,s);
1389 /* \N{latin small letter a} is a named character */
1393 char* e = strchr(s, '}');
1402 yyerror("Missing right brace on \\N{}");
1406 res = newSVpvn(s + 1, e - s - 1);
1407 res = new_constant( Nullch, 0, "charnames",
1408 res, Nullsv, "\\N{...}" );
1409 str = SvPV(res,len);
1410 if (len > e - s + 4) {
1411 char *odest = SvPVX(sv);
1413 SvGROW(sv, (SvCUR(sv) + len - (e - s + 4)));
1414 d = SvPVX(sv) + (d - odest);
1416 Copy(str, d, len, char);
1423 yyerror("Missing braces on \\N{}");
1426 /* \c is a control character */
1440 /* printf-style backslashes, formfeeds, newlines, etc */
1458 *d++ = '\047'; /* CP 1047 */
1461 *d++ = '\057'; /* CP 1047 */
1475 } /* end if (backslash) */
1478 } /* while loop to process each character */
1480 /* terminate the string and set up the sv */
1482 SvCUR_set(sv, d - SvPVX(sv));
1487 /* shrink the sv if we allocated more than we used */
1488 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1489 SvLEN_set(sv, SvCUR(sv) + 1);
1490 Renew(SvPVX(sv), SvLEN(sv), char);
1493 /* return the substring (via yylval) only if we parsed anything */
1494 if (s > PL_bufptr) {
1495 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1496 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1498 ( PL_lex_inwhat == OP_TRANS
1500 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1503 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1510 * Returns TRUE if there's more to the expression (e.g., a subscript),
1513 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
1515 * ->[ and ->{ return TRUE
1516 * { and [ outside a pattern are always subscripts, so return TRUE
1517 * if we're outside a pattern and it's not { or [, then return FALSE
1518 * if we're in a pattern and the first char is a {
1519 * {4,5} (any digits around the comma) returns FALSE
1520 * if we're in a pattern and the first char is a [
1522 * [SOMETHING] has a funky algorithm to decide whether it's a
1523 * character class or not. It has to deal with things like
1524 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
1525 * anything else returns TRUE
1528 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1531 S_intuit_more(pTHX_ register char *s)
1533 if (PL_lex_brackets)
1535 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1537 if (*s != '{' && *s != '[')
1542 /* In a pattern, so maybe we have {n,m}. */
1559 /* On the other hand, maybe we have a character class */
1562 if (*s == ']' || *s == '^')
1565 /* this is terrifying, and it works */
1566 int weight = 2; /* let's weigh the evidence */
1568 unsigned char un_char = 255, last_un_char;
1569 char *send = strchr(s,']');
1570 char tmpbuf[sizeof PL_tokenbuf * 4];
1572 if (!send) /* has to be an expression */
1575 Zero(seen,256,char);
1578 else if (isDIGIT(*s)) {
1580 if (isDIGIT(s[1]) && s[2] == ']')
1586 for (; s < send; s++) {
1587 last_un_char = un_char;
1588 un_char = (unsigned char)*s;
1593 weight -= seen[un_char] * 10;
1594 if (isALNUM_lazy_if(s+1,UTF)) {
1595 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1596 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1601 else if (*s == '$' && s[1] &&
1602 strchr("[#!%*<>()-=",s[1])) {
1603 if (/*{*/ strchr("])} =",s[2]))
1612 if (strchr("wds]",s[1]))
1614 else if (seen['\''] || seen['"'])
1616 else if (strchr("rnftbxcav",s[1]))
1618 else if (isDIGIT(s[1])) {
1620 while (s[1] && isDIGIT(s[1]))
1630 if (strchr("aA01! ",last_un_char))
1632 if (strchr("zZ79~",s[1]))
1634 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1635 weight -= 5; /* cope with negative subscript */
1638 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1639 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1644 if (keyword(tmpbuf, d - tmpbuf))
1647 if (un_char == last_un_char + 1)
1649 weight -= seen[un_char];
1654 if (weight >= 0) /* probably a character class */
1664 * Does all the checking to disambiguate
1666 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
1667 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
1669 * First argument is the stuff after the first token, e.g. "bar".
1671 * Not a method if bar is a filehandle.
1672 * Not a method if foo is a subroutine prototyped to take a filehandle.
1673 * Not a method if it's really "Foo $bar"
1674 * Method if it's "foo $bar"
1675 * Not a method if it's really "print foo $bar"
1676 * Method if it's really "foo package::" (interpreted as package->foo)
1677 * Not a method if bar is known to be a subroutne ("sub bar; foo bar")
1678 * Not a method if bar is a filehandle or package, but is quotd with
1683 S_intuit_method(pTHX_ char *start, GV *gv)
1685 char *s = start + (*start == '$');
1686 char tmpbuf[sizeof PL_tokenbuf];
1694 if ((cv = GvCVu(gv))) {
1695 char *proto = SvPVX(cv);
1705 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1706 /* start is the beginning of the possible filehandle/object,
1707 * and s is the end of it
1708 * tmpbuf is a copy of it
1711 if (*start == '$') {
1712 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1717 return *s == '(' ? FUNCMETH : METHOD;
1719 if (!keyword(tmpbuf, len)) {
1720 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1725 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1726 if (indirgv && GvCVu(indirgv))
1728 /* filehandle or package name makes it a method */
1729 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1731 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1732 return 0; /* no assumptions -- "=>" quotes bearword */
1734 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1735 newSVpvn(tmpbuf,len));
1736 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1740 return *s == '(' ? FUNCMETH : METHOD;
1748 * Return a string of Perl code to load the debugger. If PERL5DB
1749 * is set, it will return the contents of that, otherwise a
1750 * compile-time require of perl5db.pl.
1757 char *pdb = PerlEnv_getenv("PERL5DB");
1761 SETERRNO(0,SS$_NORMAL);
1762 return "BEGIN { require 'perl5db.pl' }";
1768 /* Encoded script support. filter_add() effectively inserts a
1769 * 'pre-processing' function into the current source input stream.
1770 * Note that the filter function only applies to the current source file
1771 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1773 * The datasv parameter (which may be NULL) can be used to pass
1774 * private data to this instance of the filter. The filter function
1775 * can recover the SV using the FILTER_DATA macro and use it to
1776 * store private buffers and state information.
1778 * The supplied datasv parameter is upgraded to a PVIO type
1779 * and the IoDIRP field is used to store the function pointer,
1780 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
1781 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1782 * private use must be set using malloc'd pointers.
1786 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
1791 if (!PL_rsfp_filters)
1792 PL_rsfp_filters = newAV();
1794 datasv = NEWSV(255,0);
1795 if (!SvUPGRADE(datasv, SVt_PVIO))
1796 Perl_die(aTHX_ "Can't upgrade filter_add data to SVt_PVIO");
1797 IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
1798 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
1799 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
1800 funcp, SvPV_nolen(datasv)));
1801 av_unshift(PL_rsfp_filters, 1);
1802 av_store(PL_rsfp_filters, 0, datasv) ;
1807 /* Delete most recently added instance of this filter function. */
1809 Perl_filter_del(pTHX_ filter_t funcp)
1812 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", funcp));
1813 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
1815 /* if filter is on top of stack (usual case) just pop it off */
1816 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
1817 if (IoDIRP(datasv) == (DIR*)funcp) {
1818 IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
1819 IoDIRP(datasv) = (DIR*)NULL;
1820 sv_free(av_pop(PL_rsfp_filters));
1824 /* we need to search for the correct entry and clear it */
1825 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
1829 /* Invoke the n'th filter function for the current rsfp. */
1831 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
1834 /* 0 = read one text line */
1839 if (!PL_rsfp_filters)
1841 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
1842 /* Provide a default input filter to make life easy. */
1843 /* Note that we append to the line. This is handy. */
1844 DEBUG_P(PerlIO_printf(Perl_debug_log,
1845 "filter_read %d: from rsfp\n", idx));
1849 int old_len = SvCUR(buf_sv) ;
1851 /* ensure buf_sv is large enough */
1852 SvGROW(buf_sv, old_len + maxlen) ;
1853 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1854 if (PerlIO_error(PL_rsfp))
1855 return -1; /* error */
1857 return 0 ; /* end of file */
1859 SvCUR_set(buf_sv, old_len + len) ;
1862 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
1863 if (PerlIO_error(PL_rsfp))
1864 return -1; /* error */
1866 return 0 ; /* end of file */
1869 return SvCUR(buf_sv);
1871 /* Skip this filter slot if filter has been deleted */
1872 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
1873 DEBUG_P(PerlIO_printf(Perl_debug_log,
1874 "filter_read %d: skipped (filter deleted)\n",
1876 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1878 /* Get function pointer hidden within datasv */
1879 funcp = (filter_t)IoDIRP(datasv);
1880 DEBUG_P(PerlIO_printf(Perl_debug_log,
1881 "filter_read %d: via function %p (%s)\n",
1882 idx, funcp, SvPV_nolen(datasv)));
1883 /* Call function. The function is expected to */
1884 /* call "FILTER_READ(idx+1, buf_sv)" first. */
1885 /* Return: <0:error, =0:eof, >0:not eof */
1886 return (*funcp)(aTHXo_ idx, buf_sv, maxlen);
1890 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
1892 #ifdef PERL_CR_FILTER
1893 if (!PL_rsfp_filters) {
1894 filter_add(S_cr_textfilter,NULL);
1897 if (PL_rsfp_filters) {
1900 SvCUR_set(sv, 0); /* start with empty line */
1901 if (FILTER_READ(0, sv, 0) > 0)
1902 return ( SvPVX(sv) ) ;
1907 return (sv_gets(sv, fp, append));
1912 static char* exp_name[] =
1913 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
1914 "ATTRTERM", "TERMBLOCK"
1921 Works out what to call the token just pulled out of the input
1922 stream. The yacc parser takes care of taking the ops we return and
1923 stitching them into a tree.
1929 if read an identifier
1930 if we're in a my declaration
1931 croak if they tried to say my($foo::bar)
1932 build the ops for a my() declaration
1933 if it's an access to a my() variable
1934 are we in a sort block?
1935 croak if my($a); $a <=> $b
1936 build ops for access to a my() variable
1937 if in a dq string, and they've said @foo and we can't find @foo
1939 build ops for a bareword
1940 if we already built the token before, use it.
1944 #ifdef USE_PURE_BISON
1945 Perl_yylex(pTHX_ YYSTYPE *lvalp, int *lcharp)
1958 #ifdef USE_PURE_BISON
1959 yylval_pointer = lvalp;
1960 yychar_pointer = lcharp;
1963 /* check if there's an identifier for us to look at */
1964 if (PL_pending_ident) {
1965 /* pit holds the identifier we read and pending_ident is reset */
1966 char pit = PL_pending_ident;
1967 PL_pending_ident = 0;
1969 /* if we're in a my(), we can't allow dynamics here.
1970 $foo'bar has already been turned into $foo::bar, so
1971 just check for colons.
1973 if it's a legal name, the OP is a PADANY.
1976 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
1977 if (strchr(PL_tokenbuf,':'))
1978 yyerror(Perl_form(aTHX_ "No package name allowed for "
1979 "variable %s in \"our\"",
1981 tmp = pad_allocmy(PL_tokenbuf);
1984 if (strchr(PL_tokenbuf,':'))
1985 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
1987 yylval.opval = newOP(OP_PADANY, 0);
1988 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
1994 build the ops for accesses to a my() variable.
1996 Deny my($a) or my($b) in a sort block, *if* $a or $b is
1997 then used in a comparison. This catches most, but not
1998 all cases. For instance, it catches
1999 sort { my($a); $a <=> $b }
2001 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
2002 (although why you'd do that is anyone's guess).
2005 if (!strchr(PL_tokenbuf,':')) {
2007 /* Check for single character per-thread SVs */
2008 if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
2009 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
2010 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
2012 yylval.opval = newOP(OP_THREADSV, 0);
2013 yylval.opval->op_targ = tmp;
2016 #endif /* USE_THREADS */
2017 if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
2018 SV *namesv = AvARRAY(PL_comppad_name)[tmp];
2019 /* might be an "our" variable" */
2020 if (SvFLAGS(namesv) & SVpad_OUR) {
2021 /* build ops for a bareword */
2022 SV *sym = newSVpv(HvNAME(GvSTASH(namesv)),0);
2023 sv_catpvn(sym, "::", 2);
2024 sv_catpv(sym, PL_tokenbuf+1);
2025 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
2026 yylval.opval->op_private = OPpCONST_ENTERED;
2027 gv_fetchpv(SvPVX(sym),
2029 ? (GV_ADDMULTI | GV_ADDINEVAL)
2032 ((PL_tokenbuf[0] == '$') ? SVt_PV
2033 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
2038 /* if it's a sort block and they're naming $a or $b */
2039 if (PL_last_lop_op == OP_SORT &&
2040 PL_tokenbuf[0] == '$' &&
2041 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
2044 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
2045 d < PL_bufend && *d != '\n';
2048 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
2049 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
2055 yylval.opval = newOP(OP_PADANY, 0);
2056 yylval.opval->op_targ = tmp;
2062 Whine if they've said @foo in a doublequoted string,
2063 and @foo isn't a variable we can find in the symbol
2066 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
2067 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
2068 if (!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
2069 yyerror(Perl_form(aTHX_ "In string, %s now must be written as \\%s",
2070 PL_tokenbuf, PL_tokenbuf));
2073 /* build ops for a bareword */
2074 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
2075 yylval.opval->op_private = OPpCONST_ENTERED;
2076 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
2077 ((PL_tokenbuf[0] == '$') ? SVt_PV
2078 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
2083 /* no identifier pending identification */
2085 switch (PL_lex_state) {
2087 case LEX_NORMAL: /* Some compilers will produce faster */
2088 case LEX_INTERPNORMAL: /* code if we comment these out. */
2092 /* when we've already built the next token, just pull it out of the queue */
2095 yylval = PL_nextval[PL_nexttoke];
2097 PL_lex_state = PL_lex_defer;
2098 PL_expect = PL_lex_expect;
2099 PL_lex_defer = LEX_NORMAL;
2101 return(PL_nexttype[PL_nexttoke]);
2103 /* interpolated case modifiers like \L \U, including \Q and \E.
2104 when we get here, PL_bufptr is at the \
2106 case LEX_INTERPCASEMOD:
2108 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
2109 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
2111 /* handle \E or end of string */
2112 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
2116 if (PL_lex_casemods) {
2117 oldmod = PL_lex_casestack[--PL_lex_casemods];
2118 PL_lex_casestack[PL_lex_casemods] = '\0';
2120 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
2122 PL_lex_state = LEX_INTERPCONCAT;
2126 if (PL_bufptr != PL_bufend)
2128 PL_lex_state = LEX_INTERPCONCAT;
2133 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
2134 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
2135 if (strchr("LU", *s) &&
2136 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
2138 PL_lex_casestack[--PL_lex_casemods] = '\0';
2141 if (PL_lex_casemods > 10) {
2142 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
2143 if (newlb != PL_lex_casestack) {
2145 PL_lex_casestack = newlb;
2148 PL_lex_casestack[PL_lex_casemods++] = *s;
2149 PL_lex_casestack[PL_lex_casemods] = '\0';
2150 PL_lex_state = LEX_INTERPCONCAT;
2151 PL_nextval[PL_nexttoke].ival = 0;
2154 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
2156 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
2158 PL_nextval[PL_nexttoke].ival = OP_LC;
2160 PL_nextval[PL_nexttoke].ival = OP_UC;
2162 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
2164 Perl_croak(aTHX_ "panic: yylex");
2167 if (PL_lex_starts) {
2176 case LEX_INTERPPUSH:
2177 return sublex_push();
2179 case LEX_INTERPSTART:
2180 if (PL_bufptr == PL_bufend)
2181 return sublex_done();
2183 PL_lex_dojoin = (*PL_bufptr == '@');
2184 PL_lex_state = LEX_INTERPNORMAL;
2185 if (PL_lex_dojoin) {
2186 PL_nextval[PL_nexttoke].ival = 0;
2189 PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
2190 PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
2191 force_next(PRIVATEREF);
2193 force_ident("\"", '$');
2194 #endif /* USE_THREADS */
2195 PL_nextval[PL_nexttoke].ival = 0;
2197 PL_nextval[PL_nexttoke].ival = 0;
2199 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
2202 if (PL_lex_starts++) {
2208 case LEX_INTERPENDMAYBE:
2209 if (intuit_more(PL_bufptr)) {
2210 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
2216 if (PL_lex_dojoin) {
2217 PL_lex_dojoin = FALSE;
2218 PL_lex_state = LEX_INTERPCONCAT;
2221 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
2222 && SvEVALED(PL_lex_repl))
2224 if (PL_bufptr != PL_bufend)
2225 Perl_croak(aTHX_ "Bad evalled substitution pattern");
2226 PL_lex_repl = Nullsv;
2229 case LEX_INTERPCONCAT:
2231 if (PL_lex_brackets)
2232 Perl_croak(aTHX_ "panic: INTERPCONCAT");
2234 if (PL_bufptr == PL_bufend)
2235 return sublex_done();
2237 if (SvIVX(PL_linestr) == '\'') {
2238 SV *sv = newSVsv(PL_linestr);
2241 else if ( PL_hints & HINT_NEW_RE )
2242 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
2243 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2247 s = scan_const(PL_bufptr);
2249 PL_lex_state = LEX_INTERPCASEMOD;
2251 PL_lex_state = LEX_INTERPSTART;
2254 if (s != PL_bufptr) {
2255 PL_nextval[PL_nexttoke] = yylval;
2258 if (PL_lex_starts++)
2268 PL_lex_state = LEX_NORMAL;
2269 s = scan_formline(PL_bufptr);
2270 if (!PL_lex_formbrack)
2276 PL_oldoldbufptr = PL_oldbufptr;
2279 PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at %s\n",
2280 exp_name[PL_expect], s);
2286 if (isIDFIRST_lazy_if(s,UTF))
2288 Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
2291 goto fake_eof; /* emulate EOF on ^D or ^Z */
2296 if (PL_lex_brackets)
2297 yyerror("Missing right curly or square bracket");
2300 if (s++ < PL_bufend)
2301 goto retry; /* ignore stray nulls */
2304 if (!PL_in_eval && !PL_preambled) {
2305 PL_preambled = TRUE;
2306 sv_setpv(PL_linestr,incl_perldb());
2307 if (SvCUR(PL_linestr))
2308 sv_catpv(PL_linestr,";");
2310 while(AvFILLp(PL_preambleav) >= 0) {
2311 SV *tmpsv = av_shift(PL_preambleav);
2312 sv_catsv(PL_linestr, tmpsv);
2313 sv_catpv(PL_linestr, ";");
2316 sv_free((SV*)PL_preambleav);
2317 PL_preambleav = NULL;
2319 if (PL_minus_n || PL_minus_p) {
2320 sv_catpv(PL_linestr, "LINE: while (<>) {");
2322 sv_catpv(PL_linestr,"chomp;");
2324 GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
2326 GvIMPORTED_AV_on(gv);
2328 if (strchr("/'\"", *PL_splitstr)
2329 && strchr(PL_splitstr + 1, *PL_splitstr))
2330 Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s);", PL_splitstr);
2333 s = "'~#\200\1'"; /* surely one char is unused...*/
2334 while (s[1] && strchr(PL_splitstr, *s)) s++;
2336 Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s%c",
2337 "q" + (delim == '\''), delim);
2338 for (s = PL_splitstr; *s; s++) {
2340 sv_catpvn(PL_linestr, "\\", 1);
2341 sv_catpvn(PL_linestr, s, 1);
2343 Perl_sv_catpvf(aTHX_ PL_linestr, "%c);", delim);
2347 sv_catpv(PL_linestr,"@F=split(' ');");
2350 sv_catpv(PL_linestr, "\n");
2351 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2352 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2353 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2354 SV *sv = NEWSV(85,0);
2356 sv_upgrade(sv, SVt_PVMG);
2357 sv_setsv(sv,PL_linestr);
2358 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2363 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
2366 if (PL_preprocess && !PL_in_eval)
2367 (void)PerlProc_pclose(PL_rsfp);
2368 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2369 PerlIO_clearerr(PL_rsfp);
2371 (void)PerlIO_close(PL_rsfp);
2373 PL_doextract = FALSE;
2375 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2376 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
2377 sv_catpv(PL_linestr,";}");
2378 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2379 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2380 PL_minus_n = PL_minus_p = 0;
2383 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2384 sv_setpv(PL_linestr,"");
2385 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
2388 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
2389 PL_doextract = FALSE;
2391 /* Incest with pod. */
2392 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2393 sv_setpv(PL_linestr, "");
2394 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2395 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2396 PL_doextract = FALSE;
2400 } while (PL_doextract);
2401 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2402 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2403 SV *sv = NEWSV(85,0);
2405 sv_upgrade(sv, SVt_PVMG);
2406 sv_setsv(sv,PL_linestr);
2407 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2409 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2410 if (CopLINE(PL_curcop) == 1) {
2411 while (s < PL_bufend && isSPACE(*s))
2413 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2417 if (*s == '#' && *(s+1) == '!')
2419 #ifdef ALTERNATE_SHEBANG
2421 static char as[] = ALTERNATE_SHEBANG;
2422 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2423 d = s + (sizeof(as) - 1);
2425 #endif /* ALTERNATE_SHEBANG */
2434 while (*d && !isSPACE(*d))
2438 #ifdef ARG_ZERO_IS_SCRIPT
2439 if (ipathend > ipath) {
2441 * HP-UX (at least) sets argv[0] to the script name,
2442 * which makes $^X incorrect. And Digital UNIX and Linux,
2443 * at least, set argv[0] to the basename of the Perl
2444 * interpreter. So, having found "#!", we'll set it right.
2446 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
2447 assert(SvPOK(x) || SvGMAGICAL(x));
2448 if (sv_eq(x, CopFILESV(PL_curcop))) {
2449 sv_setpvn(x, ipath, ipathend - ipath);
2452 TAINT_NOT; /* $^X is always tainted, but that's OK */
2454 #endif /* ARG_ZERO_IS_SCRIPT */
2459 d = instr(s,"perl -");
2461 d = instr(s,"perl");
2463 /* avoid getting into infinite loops when shebang
2464 * line contains "Perl" rather than "perl" */
2466 for (d = ipathend-4; d >= ipath; --d) {
2467 if ((*d == 'p' || *d == 'P')
2468 && !ibcmp(d, "perl", 4))
2478 #ifdef ALTERNATE_SHEBANG
2480 * If the ALTERNATE_SHEBANG on this system starts with a
2481 * character that can be part of a Perl expression, then if
2482 * we see it but not "perl", we're probably looking at the
2483 * start of Perl code, not a request to hand off to some
2484 * other interpreter. Similarly, if "perl" is there, but
2485 * not in the first 'word' of the line, we assume the line
2486 * contains the start of the Perl program.
2488 if (d && *s != '#') {
2490 while (*c && !strchr("; \t\r\n\f\v#", *c))
2493 d = Nullch; /* "perl" not in first word; ignore */
2495 *s = '#'; /* Don't try to parse shebang line */
2497 #endif /* ALTERNATE_SHEBANG */
2502 !instr(s,"indir") &&
2503 instr(PL_origargv[0],"perl"))
2509 while (s < PL_bufend && isSPACE(*s))
2511 if (s < PL_bufend) {
2512 Newz(899,newargv,PL_origargc+3,char*);
2514 while (s < PL_bufend && !isSPACE(*s))
2517 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2520 newargv = PL_origargv;
2522 PerlProc_execv(ipath, newargv);
2523 Perl_croak(aTHX_ "Can't exec %s", ipath);
2526 U32 oldpdb = PL_perldb;
2527 bool oldn = PL_minus_n;
2528 bool oldp = PL_minus_p;
2530 while (*d && !isSPACE(*d)) d++;
2531 while (*d == ' ' || *d == '\t') d++;
2535 if (*d == 'M' || *d == 'm') {
2537 while (*d && !isSPACE(*d)) d++;
2538 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2541 d = moreswitches(d);
2543 if (PERLDB_LINE && !oldpdb ||
2544 ( PL_minus_n || PL_minus_p ) && !(oldn || oldp) )
2545 /* if we have already added "LINE: while (<>) {",
2546 we must not do it again */
2548 sv_setpv(PL_linestr, "");
2549 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2550 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2551 PL_preambled = FALSE;
2553 (void)gv_fetchfile(PL_origfilename);
2560 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2562 PL_lex_state = LEX_FORMLINE;
2567 #ifdef PERL_STRICT_CR
2568 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2570 "(Maybe you didn't strip carriage returns after a network transfer?)\n");
2572 case ' ': case '\t': case '\f': case 013:
2577 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2579 while (s < d && *s != '\n')
2584 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2586 PL_lex_state = LEX_FORMLINE;
2596 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2601 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2604 if (strnEQ(s,"=>",2)) {
2605 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2606 OPERATOR('-'); /* unary minus */
2608 PL_last_uni = PL_oldbufptr;
2609 PL_last_lop_op = OP_FTEREAD; /* good enough */
2611 case 'r': FTST(OP_FTEREAD);
2612 case 'w': FTST(OP_FTEWRITE);
2613 case 'x': FTST(OP_FTEEXEC);
2614 case 'o': FTST(OP_FTEOWNED);
2615 case 'R': FTST(OP_FTRREAD);
2616 case 'W': FTST(OP_FTRWRITE);
2617 case 'X': FTST(OP_FTREXEC);
2618 case 'O': FTST(OP_FTROWNED);
2619 case 'e': FTST(OP_FTIS);
2620 case 'z': FTST(OP_FTZERO);
2621 case 's': FTST(OP_FTSIZE);
2622 case 'f': FTST(OP_FTFILE);
2623 case 'd': FTST(OP_FTDIR);
2624 case 'l': FTST(OP_FTLINK);
2625 case 'p': FTST(OP_FTPIPE);
2626 case 'S': FTST(OP_FTSOCK);
2627 case 'u': FTST(OP_FTSUID);
2628 case 'g': FTST(OP_FTSGID);
2629 case 'k': FTST(OP_FTSVTX);
2630 case 'b': FTST(OP_FTBLK);
2631 case 'c': FTST(OP_FTCHR);
2632 case 't': FTST(OP_FTTTY);
2633 case 'T': FTST(OP_FTTEXT);
2634 case 'B': FTST(OP_FTBINARY);
2635 case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2636 case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2637 case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
2639 Perl_croak(aTHX_ "Unrecognized file test: -%c", (int)tmp);
2646 if (PL_expect == XOPERATOR)
2651 else if (*s == '>') {
2654 if (isIDFIRST_lazy_if(s,UTF)) {
2655 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2663 if (PL_expect == XOPERATOR)
2666 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2668 OPERATOR('-'); /* unary minus */
2675 if (PL_expect == XOPERATOR)
2680 if (PL_expect == XOPERATOR)
2683 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2689 if (PL_expect != XOPERATOR) {
2690 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2691 PL_expect = XOPERATOR;
2692 force_ident(PL_tokenbuf, '*');
2705 if (PL_expect == XOPERATOR) {
2709 PL_tokenbuf[0] = '%';
2710 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2711 if (!PL_tokenbuf[1]) {
2713 yyerror("Final % should be \\% or %name");
2716 PL_pending_ident = '%';
2735 switch (PL_expect) {
2738 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
2740 PL_bufptr = s; /* update in case we back off */
2746 PL_expect = XTERMBLOCK;
2750 while (isIDFIRST_lazy_if(s,UTF)) {
2751 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2752 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
2753 if (tmp < 0) tmp = -tmp;
2768 d = scan_str(d,TRUE,TRUE);
2771 SvREFCNT_dec(PL_lex_stuff);
2772 PL_lex_stuff = Nullsv;
2774 /* MUST advance bufptr here to avoid bogus
2775 "at end of line" context messages from yyerror().
2777 PL_bufptr = s + len;
2778 yyerror("Unterminated attribute parameter in attribute list");
2781 return 0; /* EOF indicator */
2785 SV *sv = newSVpvn(s, len);
2786 sv_catsv(sv, PL_lex_stuff);
2787 attrs = append_elem(OP_LIST, attrs,
2788 newSVOP(OP_CONST, 0, sv));
2789 SvREFCNT_dec(PL_lex_stuff);
2790 PL_lex_stuff = Nullsv;
2793 attrs = append_elem(OP_LIST, attrs,
2794 newSVOP(OP_CONST, 0,
2798 if (*s == ':' && s[1] != ':')
2801 break; /* require real whitespace or :'s */
2803 tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
2804 if (*s != ';' && *s != tmp && (tmp != '=' || *s != ')')) {
2805 char q = ((*s == '\'') ? '"' : '\'');
2806 /* If here for an expression, and parsed no attrs, back off. */
2807 if (tmp == '=' && !attrs) {
2811 /* MUST advance bufptr here to avoid bogus "at end of line"
2812 context messages from yyerror().
2816 yyerror("Unterminated attribute list");
2818 yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list",
2826 PL_nextval[PL_nexttoke].opval = attrs;
2834 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
2835 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
2840 if (CopLINE(PL_curcop) < PL_copline)
2841 PL_copline = CopLINE(PL_curcop);
2852 if (PL_lex_brackets <= 0)
2853 yyerror("Unmatched right square bracket");
2856 if (PL_lex_state == LEX_INTERPNORMAL) {
2857 if (PL_lex_brackets == 0) {
2858 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
2859 PL_lex_state = LEX_INTERPEND;
2866 if (PL_lex_brackets > 100) {
2867 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
2868 if (newlb != PL_lex_brackstack) {
2870 PL_lex_brackstack = newlb;
2873 switch (PL_expect) {
2875 if (PL_lex_formbrack) {
2879 if (PL_oldoldbufptr == PL_last_lop)
2880 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2882 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2883 OPERATOR(HASHBRACK);
2885 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2888 PL_tokenbuf[0] = '\0';
2889 if (d < PL_bufend && *d == '-') {
2890 PL_tokenbuf[0] = '-';
2892 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2895 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
2896 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2898 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2901 char minus = (PL_tokenbuf[0] == '-');
2902 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2910 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
2915 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2920 if (PL_oldoldbufptr == PL_last_lop)
2921 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2923 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2926 OPERATOR(HASHBRACK);
2927 /* This hack serves to disambiguate a pair of curlies
2928 * as being a block or an anon hash. Normally, expectation
2929 * determines that, but in cases where we're not in a
2930 * position to expect anything in particular (like inside
2931 * eval"") we have to resolve the ambiguity. This code
2932 * covers the case where the first term in the curlies is a
2933 * quoted string. Most other cases need to be explicitly
2934 * disambiguated by prepending a `+' before the opening
2935 * curly in order to force resolution as an anon hash.
2937 * XXX should probably propagate the outer expectation
2938 * into eval"" to rely less on this hack, but that could
2939 * potentially break current behavior of eval"".
2943 if (*s == '\'' || *s == '"' || *s == '`') {
2944 /* common case: get past first string, handling escapes */
2945 for (t++; t < PL_bufend && *t != *s;)
2946 if (*t++ == '\\' && (*t == '\\' || *t == *s))
2950 else if (*s == 'q') {
2953 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
2957 char open, close, term;
2960 while (t < PL_bufend && isSPACE(*t))
2964 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
2968 for (t++; t < PL_bufend; t++) {
2969 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
2971 else if (*t == open)
2975 for (t++; t < PL_bufend; t++) {
2976 if (*t == '\\' && t+1 < PL_bufend)
2978 else if (*t == close && --brackets <= 0)
2980 else if (*t == open)
2986 else if (isALNUM_lazy_if(t,UTF)) {
2988 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
2991 while (t < PL_bufend && isSPACE(*t))
2993 /* if comma follows first term, call it an anon hash */
2994 /* XXX it could be a comma expression with loop modifiers */
2995 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
2996 || (*t == '=' && t[1] == '>')))
2997 OPERATOR(HASHBRACK);
2998 if (PL_expect == XREF)
3001 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
3007 yylval.ival = CopLINE(PL_curcop);
3008 if (isSPACE(*s) || *s == '#')
3009 PL_copline = NOLINE; /* invalidate current command line number */
3014 if (PL_lex_brackets <= 0)
3015 yyerror("Unmatched right curly bracket");
3017 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
3018 if (PL_lex_brackets < PL_lex_formbrack)
3019 PL_lex_formbrack = 0;
3020 if (PL_lex_state == LEX_INTERPNORMAL) {
3021 if (PL_lex_brackets == 0) {
3022 if (PL_expect & XFAKEBRACK) {
3023 PL_expect &= XENUMMASK;
3024 PL_lex_state = LEX_INTERPEND;
3026 return yylex(); /* ignore fake brackets */
3028 if (*s == '-' && s[1] == '>')
3029 PL_lex_state = LEX_INTERPENDMAYBE;
3030 else if (*s != '[' && *s != '{')
3031 PL_lex_state = LEX_INTERPEND;
3034 if (PL_expect & XFAKEBRACK) {
3035 PL_expect &= XENUMMASK;
3037 return yylex(); /* ignore fake brackets */
3047 if (PL_expect == XOPERATOR) {
3048 if (ckWARN(WARN_SEMICOLON)
3049 && isIDFIRST_lazy_if(s,UTF) && PL_bufptr == PL_linestart)
3051 CopLINE_dec(PL_curcop);
3052 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3053 CopLINE_inc(PL_curcop);
3058 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3060 PL_expect = XOPERATOR;
3061 force_ident(PL_tokenbuf, '&');
3065 yylval.ival = (OPpENTERSUB_AMPER<<8);
3084 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
3085 Perl_warner(aTHX_ WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
3087 if (PL_expect == XSTATE && isALPHA(tmp) &&
3088 (s == PL_linestart+1 || s[-2] == '\n') )
3090 if (PL_in_eval && !PL_rsfp) {
3095 if (strnEQ(s,"=cut",4)) {
3109 PL_doextract = TRUE;
3112 if (PL_lex_brackets < PL_lex_formbrack) {
3114 #ifdef PERL_STRICT_CR
3115 for (t = s; *t == ' ' || *t == '\t'; t++) ;
3117 for (t = s; *t == ' ' || *t == '\t' || *t == '\r'; t++) ;
3119 if (*t == '\n' || *t == '#') {
3137 if (PL_expect != XOPERATOR) {
3138 if (s[1] != '<' && !strchr(s,'>'))
3141 s = scan_heredoc(s);
3143 s = scan_inputsymbol(s);
3144 TERM(sublex_start());
3149 SHop(OP_LEFT_SHIFT);
3163 SHop(OP_RIGHT_SHIFT);
3172 if (PL_expect == XOPERATOR) {
3173 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3176 return ','; /* grandfather non-comma-format format */
3180 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
3181 PL_tokenbuf[0] = '@';
3182 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3183 sizeof PL_tokenbuf - 1, FALSE);
3184 if (PL_expect == XOPERATOR)
3185 no_op("Array length", s);
3186 if (!PL_tokenbuf[1])
3188 PL_expect = XOPERATOR;
3189 PL_pending_ident = '#';
3193 PL_tokenbuf[0] = '$';
3194 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3195 sizeof PL_tokenbuf - 1, FALSE);
3196 if (PL_expect == XOPERATOR)
3198 if (!PL_tokenbuf[1]) {
3200 yyerror("Final $ should be \\$ or $name");
3204 /* This kludge not intended to be bulletproof. */
3205 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
3206 yylval.opval = newSVOP(OP_CONST, 0,
3207 newSViv((IV)PL_compiling.cop_arybase));
3208 yylval.opval->op_private = OPpCONST_ARYBASE;
3214 if (PL_lex_state == LEX_NORMAL)
3217 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3220 PL_tokenbuf[0] = '@';
3221 if (ckWARN(WARN_SYNTAX)) {
3223 isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$';
3226 PL_bufptr = skipspace(PL_bufptr);
3227 while (t < PL_bufend && *t != ']')
3229 Perl_warner(aTHX_ WARN_SYNTAX,
3230 "Multidimensional syntax %.*s not supported",
3231 (t - PL_bufptr) + 1, PL_bufptr);
3235 else if (*s == '{') {
3236 PL_tokenbuf[0] = '%';
3237 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
3238 (t = strchr(s, '}')) && (t = strchr(t, '=')))
3240 char tmpbuf[sizeof PL_tokenbuf];
3242 for (t++; isSPACE(*t); t++) ;
3243 if (isIDFIRST_lazy_if(t,UTF)) {
3244 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
3245 for (; isSPACE(*t); t++) ;
3246 if (*t == ';' && get_cv(tmpbuf, FALSE))
3247 Perl_warner(aTHX_ WARN_SYNTAX,
3248 "You need to quote \"%s\"", tmpbuf);
3254 PL_expect = XOPERATOR;
3255 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3256 bool islop = (PL_last_lop == PL_oldoldbufptr);
3257 if (!islop || PL_last_lop_op == OP_GREPSTART)
3258 PL_expect = XOPERATOR;
3259 else if (strchr("$@\"'`q", *s))
3260 PL_expect = XTERM; /* e.g. print $fh "foo" */
3261 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
3262 PL_expect = XTERM; /* e.g. print $fh &sub */
3263 else if (isIDFIRST_lazy_if(s,UTF)) {
3264 char tmpbuf[sizeof PL_tokenbuf];
3265 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3266 if (tmp = keyword(tmpbuf, len)) {
3267 /* binary operators exclude handle interpretations */
3279 PL_expect = XTERM; /* e.g. print $fh length() */
3284 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
3285 if (gv && GvCVu(gv))
3286 PL_expect = XTERM; /* e.g. print $fh subr() */
3289 else if (isDIGIT(*s))
3290 PL_expect = XTERM; /* e.g. print $fh 3 */
3291 else if (*s == '.' && isDIGIT(s[1]))
3292 PL_expect = XTERM; /* e.g. print $fh .3 */
3293 else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
3294 PL_expect = XTERM; /* e.g. print $fh -1 */
3295 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3296 PL_expect = XTERM; /* print $fh <<"EOF" */
3298 PL_pending_ident = '$';
3302 if (PL_expect == XOPERATOR)
3304 PL_tokenbuf[0] = '@';
3305 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3306 if (!PL_tokenbuf[1]) {
3308 yyerror("Final @ should be \\@ or @name");
3311 if (PL_lex_state == LEX_NORMAL)
3313 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3315 PL_tokenbuf[0] = '%';
3317 /* Warn about @ where they meant $. */
3318 if (ckWARN(WARN_SYNTAX)) {
3319 if (*s == '[' || *s == '{') {
3321 while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
3323 if (*t == '}' || *t == ']') {
3325 PL_bufptr = skipspace(PL_bufptr);
3326 Perl_warner(aTHX_ WARN_SYNTAX,
3327 "Scalar value %.*s better written as $%.*s",
3328 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
3333 PL_pending_ident = '@';
3336 case '/': /* may either be division or pattern */
3337 case '?': /* may either be conditional or pattern */
3338 if (PL_expect != XOPERATOR) {
3339 /* Disable warning on "study /blah/" */
3340 if (PL_oldoldbufptr == PL_last_uni
3341 && (*PL_last_uni != 's' || s - PL_last_uni < 5
3342 || memNE(PL_last_uni, "study", 5)
3343 || isALNUM_lazy_if(PL_last_uni+5,UTF)))
3345 s = scan_pat(s,OP_MATCH);
3346 TERM(sublex_start());
3354 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3355 #ifdef PERL_STRICT_CR
3358 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3360 && (s == PL_linestart || s[-1] == '\n') )
3362 PL_lex_formbrack = 0;
3366 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
3372 yylval.ival = OPf_SPECIAL;
3378 if (PL_expect != XOPERATOR)
3383 case '0': case '1': case '2': case '3': case '4':
3384 case '5': case '6': case '7': case '8': case '9':
3386 if (PL_expect == XOPERATOR)
3391 s = scan_str(s,FALSE,FALSE);
3392 if (PL_expect == XOPERATOR) {
3393 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3396 return ','; /* grandfather non-comma-format format */
3402 missingterm((char*)0);
3403 yylval.ival = OP_CONST;
3404 TERM(sublex_start());
3407 s = scan_str(s,FALSE,FALSE);
3408 if (PL_expect == XOPERATOR) {
3409 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3412 return ','; /* grandfather non-comma-format format */
3418 missingterm((char*)0);
3419 yylval.ival = OP_CONST;
3420 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
3421 if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
3422 yylval.ival = OP_STRINGIFY;
3426 TERM(sublex_start());
3429 s = scan_str(s,FALSE,FALSE);
3430 if (PL_expect == XOPERATOR)
3431 no_op("Backticks",s);
3433 missingterm((char*)0);
3434 yylval.ival = OP_BACKTICK;
3436 TERM(sublex_start());
3440 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
3441 Perl_warner(aTHX_ WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
3443 if (PL_expect == XOPERATOR)
3444 no_op("Backslash",s);
3448 if (isDIGIT(s[1]) && PL_expect == XTERM) {
3452 while (isDIGIT(*start))
3454 if (*start == '.' && isDIGIT(start[1])) {
3461 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
3501 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3503 /* Some keywords can be followed by any delimiter, including ':' */
3504 tmp = (len == 1 && strchr("msyq", PL_tokenbuf[0]) ||
3505 len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
3506 (PL_tokenbuf[0] == 'q' &&
3507 strchr("qwxr", PL_tokenbuf[1]))));
3509 /* x::* is just a word, unless x is "CORE" */
3510 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
3514 while (d < PL_bufend && isSPACE(*d))
3515 d++; /* no comments skipped here, or s### is misparsed */
3517 /* Is this a label? */
3518 if (!tmp && PL_expect == XSTATE
3519 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
3521 yylval.pval = savepv(PL_tokenbuf);
3526 /* Check for keywords */
3527 tmp = keyword(PL_tokenbuf, len);
3529 /* Is this a word before a => operator? */
3530 if (strnEQ(d,"=>",2)) {
3532 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
3533 yylval.opval->op_private = OPpCONST_BARE;
3537 if (tmp < 0) { /* second-class keyword? */
3538 GV *ogv = Nullgv; /* override (winner) */
3539 GV *hgv = Nullgv; /* hidden (loser) */
3540 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3542 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3545 if (GvIMPORTED_CV(gv))
3547 else if (! CvMETHOD(cv))
3551 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3552 (gv = *gvp) != (GV*)&PL_sv_undef &&
3553 GvCVu(gv) && GvIMPORTED_CV(gv))
3559 tmp = 0; /* overridden by import or by GLOBAL */
3562 && -tmp==KEY_lock /* XXX generalizable kludge */
3564 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3566 tmp = 0; /* any sub overrides "weak" keyword */
3568 else { /* no override */
3572 if (ckWARN(WARN_AMBIGUOUS) && hgv
3573 && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3574 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3575 "Ambiguous call resolved as CORE::%s(), %s",
3576 GvENAME(hgv), "qualify as such or use &");
3583 default: /* not a keyword */
3586 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3588 /* Get the rest if it looks like a package qualifier */
3590 if (*s == '\'' || *s == ':' && s[1] == ':') {
3592 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3595 Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
3596 *s == '\'' ? "'" : "::");
3600 if (PL_expect == XOPERATOR) {
3601 if (PL_bufptr == PL_linestart) {
3602 CopLINE_dec(PL_curcop);
3603 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3604 CopLINE_inc(PL_curcop);
3607 no_op("Bareword",s);
3610 /* Look for a subroutine with this name in current package,
3611 unless name is "Foo::", in which case Foo is a bearword
3612 (and a package name). */
3615 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3617 if (ckWARN(WARN_UNSAFE) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3618 Perl_warner(aTHX_ WARN_UNSAFE,
3619 "Bareword \"%s\" refers to nonexistent package",
3622 PL_tokenbuf[len] = '\0';
3629 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3632 /* if we saw a global override before, get the right name */
3635 sv = newSVpvn("CORE::GLOBAL::",14);
3636 sv_catpv(sv,PL_tokenbuf);
3639 sv = newSVpv(PL_tokenbuf,0);
3641 /* Presume this is going to be a bareword of some sort. */
3644 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3645 yylval.opval->op_private = OPpCONST_BARE;
3647 /* And if "Foo::", then that's what it certainly is. */
3652 /* See if it's the indirect object for a list operator. */
3654 if (PL_oldoldbufptr &&
3655 PL_oldoldbufptr < PL_bufptr &&
3656 (PL_oldoldbufptr == PL_last_lop
3657 || PL_oldoldbufptr == PL_last_uni) &&
3658 /* NO SKIPSPACE BEFORE HERE! */
3659 (PL_expect == XREF ||
3660 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
3662 bool immediate_paren = *s == '(';
3664 /* (Now we can afford to cross potential line boundary.) */
3667 /* Two barewords in a row may indicate method call. */
3669 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp=intuit_method(s,gv)))
3672 /* If not a declared subroutine, it's an indirect object. */
3673 /* (But it's an indir obj regardless for sort.) */
3675 if ((PL_last_lop_op == OP_SORT ||
3676 (!immediate_paren && (!gv || !GvCVu(gv)))) &&
3677 (PL_last_lop_op != OP_MAPSTART &&
3678 PL_last_lop_op != OP_GREPSTART))
3680 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3685 /* If followed by a paren, it's certainly a subroutine. */
3687 PL_expect = XOPERATOR;
3691 if (gv && GvCVu(gv)) {
3692 for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
3693 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
3698 PL_nextval[PL_nexttoke].opval = yylval.opval;
3699 PL_expect = XOPERATOR;
3705 /* If followed by var or block, call it a method (unless sub) */
3707 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3708 PL_last_lop = PL_oldbufptr;
3709 PL_last_lop_op = OP_METHOD;
3713 /* If followed by a bareword, see if it looks like indir obj. */
3715 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp = intuit_method(s,gv)))
3718 /* Not a method, so call it a subroutine (if defined) */
3720 if (gv && GvCVu(gv)) {
3722 if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
3723 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3724 "Ambiguous use of -%s resolved as -&%s()",
3725 PL_tokenbuf, PL_tokenbuf);
3726 /* Check for a constant sub */
3728 if ((sv = cv_const_sv(cv))) {
3730 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3731 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3732 yylval.opval->op_private = 0;
3736 /* Resolve to GV now. */
3737 op_free(yylval.opval);
3738 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3739 yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
3740 PL_last_lop = PL_oldbufptr;
3741 PL_last_lop_op = OP_ENTERSUB;
3742 /* Is there a prototype? */
3745 char *proto = SvPV((SV*)cv, len);
3748 if (strEQ(proto, "$"))
3750 if (*proto == '&' && *s == '{') {
3751 sv_setpv(PL_subname,"__ANON__");
3755 PL_nextval[PL_nexttoke].opval = yylval.opval;
3761 /* Call it a bare word */
3763 if (PL_hints & HINT_STRICT_SUBS)
3764 yylval.opval->op_private |= OPpCONST_STRICT;
3767 if (ckWARN(WARN_RESERVED)) {
3768 if (lastchar != '-') {
3769 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3771 Perl_warner(aTHX_ WARN_RESERVED, PL_warn_reserved,
3778 if (lastchar && strchr("*%&", lastchar) && ckWARN_d(WARN_AMBIGUOUS)) {
3779 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3780 "Operator or semicolon missing before %c%s",
3781 lastchar, PL_tokenbuf);
3782 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3783 "Ambiguous use of %c resolved as operator %c",
3784 lastchar, lastchar);
3790 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3791 newSVpv(CopFILE(PL_curcop),0));
3795 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3796 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
3799 case KEY___PACKAGE__:
3800 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3802 ? newSVsv(PL_curstname)
3811 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3812 char *pname = "main";
3813 if (PL_tokenbuf[2] == 'D')
3814 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3815 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
3818 GvIOp(gv) = newIO();
3819 IoIFP(GvIOp(gv)) = PL_rsfp;
3820 #if defined(HAS_FCNTL) && defined(F_SETFD)
3822 int fd = PerlIO_fileno(PL_rsfp);
3823 fcntl(fd,F_SETFD,fd >= 3);
3826 /* Mark this internal pseudo-handle as clean */
3827 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3829 IoTYPE(GvIOp(gv)) = '|';
3830 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
3831 IoTYPE(GvIOp(gv)) = '-';
3833 IoTYPE(GvIOp(gv)) = '<';
3834 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
3835 /* if the script was opened in binmode, we need to revert
3836 * it to text mode for compatibility; but only iff it has CRs
3837 * XXX this is a questionable hack at best. */
3838 if (PL_bufend-PL_bufptr > 2
3839 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
3842 if (IoTYPE(GvIOp(gv)) == '<') {
3843 loc = PerlIO_tell(PL_rsfp);
3844 (void)PerlIO_seek(PL_rsfp, 0L, 0);
3846 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
3847 #if defined(__BORLANDC__)
3848 /* XXX see note in do_binmode() */
3849 ((FILE*)PL_rsfp)->flags |= _F_BIN;
3852 PerlIO_seek(PL_rsfp, loc, 0);
3867 if (PL_expect == XSTATE) {
3874 if (*s == ':' && s[1] == ':') {
3877 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3878 tmp = keyword(PL_tokenbuf, len);
3892 LOP(OP_ACCEPT,XTERM);
3898 LOP(OP_ATAN2,XTERM);
3907 LOP(OP_BLESS,XTERM);
3916 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
3933 if (!PL_cryptseen) {
3934 PL_cryptseen = TRUE;
3938 LOP(OP_CRYPT,XTERM);
3941 if (ckWARN(WARN_OCTAL)) {
3942 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
3943 if (*d != '0' && isDIGIT(*d))
3944 Perl_warner(aTHX_ WARN_OCTAL,
3945 "chmod: mode argument is missing initial 0");
3947 LOP(OP_CHMOD,XTERM);
3950 LOP(OP_CHOWN,XTERM);
3953 LOP(OP_CONNECT,XTERM);
3969 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3973 PL_hints |= HINT_BLOCK_SCOPE;
3983 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3984 LOP(OP_DBMOPEN,XTERM);
3990 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3997 yylval.ival = CopLINE(PL_curcop);
4011 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
4012 UNIBRACK(OP_ENTEREVAL);
4027 case KEY_endhostent:
4033 case KEY_endservent:
4036 case KEY_endprotoent:
4047 yylval.ival = CopLINE(PL_curcop);
4049 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
4051 if ((PL_bufend - p) >= 3 &&
4052 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
4054 else if ((PL_bufend - p) >= 4 &&
4055 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
4058 if (isIDFIRST_lazy_if(p,UTF)) {
4059 p = scan_ident(p, PL_bufend,
4060 PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4064 Perl_croak(aTHX_ "Missing $ on loop variable");
4069 LOP(OP_FORMLINE,XTERM);
4075 LOP(OP_FCNTL,XTERM);
4081 LOP(OP_FLOCK,XTERM);
4090 LOP(OP_GREPSTART, XREF);
4093 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4108 case KEY_getpriority:
4109 LOP(OP_GETPRIORITY,XTERM);
4111 case KEY_getprotobyname:
4114 case KEY_getprotobynumber:
4115 LOP(OP_GPBYNUMBER,XTERM);
4117 case KEY_getprotoent:
4129 case KEY_getpeername:
4130 UNI(OP_GETPEERNAME);
4132 case KEY_gethostbyname:
4135 case KEY_gethostbyaddr:
4136 LOP(OP_GHBYADDR,XTERM);
4138 case KEY_gethostent:
4141 case KEY_getnetbyname:
4144 case KEY_getnetbyaddr:
4145 LOP(OP_GNBYADDR,XTERM);
4150 case KEY_getservbyname:
4151 LOP(OP_GSBYNAME,XTERM);
4153 case KEY_getservbyport:
4154 LOP(OP_GSBYPORT,XTERM);
4156 case KEY_getservent:
4159 case KEY_getsockname:
4160 UNI(OP_GETSOCKNAME);
4162 case KEY_getsockopt:
4163 LOP(OP_GSOCKOPT,XTERM);
4185 yylval.ival = CopLINE(PL_curcop);
4189 LOP(OP_INDEX,XTERM);
4195 LOP(OP_IOCTL,XTERM);
4207 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4239 LOP(OP_LISTEN,XTERM);
4248 s = scan_pat(s,OP_MATCH);
4249 TERM(sublex_start());
4252 LOP(OP_MAPSTART, XREF);
4255 LOP(OP_MKDIR,XTERM);
4258 LOP(OP_MSGCTL,XTERM);
4261 LOP(OP_MSGGET,XTERM);
4264 LOP(OP_MSGRCV,XTERM);
4267 LOP(OP_MSGSND,XTERM);
4273 if (isIDFIRST_lazy_if(s,UTF)) {
4274 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
4275 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
4277 PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
4278 if (!PL_in_my_stash) {
4281 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
4289 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4296 if (PL_expect != XSTATE)
4297 yyerror("\"no\" not allowed in expression");
4298 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4299 s = force_version(s);
4304 if (*s == '(' || (s = skipspace(s), *s == '('))
4311 if (isIDFIRST_lazy_if(s,UTF)) {
4313 for (d = s; isALNUM_lazy_if(d,UTF); d++) ;
4315 if (strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_AMBIGUOUS))
4316 Perl_warner(aTHX_ WARN_AMBIGUOUS,
4317 "Precedence problem: open %.*s should be open(%.*s)",
4323 yylval.ival = OP_OR;
4333 LOP(OP_OPEN_DIR,XTERM);
4336 checkcomma(s,PL_tokenbuf,"filehandle");
4340 checkcomma(s,PL_tokenbuf,"filehandle");
4359 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4363 LOP(OP_PIPE_OP,XTERM);
4366 s = scan_str(s,FALSE,FALSE);
4368 missingterm((char*)0);
4369 yylval.ival = OP_CONST;
4370 TERM(sublex_start());
4376 s = scan_str(s,FALSE,FALSE);
4378 missingterm((char*)0);
4380 if (SvCUR(PL_lex_stuff)) {
4383 d = SvPV_force(PL_lex_stuff, len);
4385 for (; isSPACE(*d) && len; --len, ++d) ;
4388 if (!warned && ckWARN(WARN_SYNTAX)) {
4389 for (; !isSPACE(*d) && len; --len, ++d) {
4391 Perl_warner(aTHX_ WARN_SYNTAX,
4392 "Possible attempt to separate words with commas");
4395 else if (*d == '#') {
4396 Perl_warner(aTHX_ WARN_SYNTAX,
4397 "Possible attempt to put comments in qw() list");
4403 for (; !isSPACE(*d) && len; --len, ++d) ;
4405 words = append_elem(OP_LIST, words,
4406 newSVOP(OP_CONST, 0, newSVpvn(b, d-b)));
4410 PL_nextval[PL_nexttoke].opval = words;
4415 SvREFCNT_dec(PL_lex_stuff);
4416 PL_lex_stuff = Nullsv;
4421 s = scan_str(s,FALSE,FALSE);
4423 missingterm((char*)0);
4424 yylval.ival = OP_STRINGIFY;
4425 if (SvIVX(PL_lex_stuff) == '\'')
4426 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
4427 TERM(sublex_start());
4430 s = scan_pat(s,OP_QR);
4431 TERM(sublex_start());
4434 s = scan_str(s,FALSE,FALSE);
4436 missingterm((char*)0);
4437 yylval.ival = OP_BACKTICK;
4439 TERM(sublex_start());
4446 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4447 s = force_version(s);
4450 *PL_tokenbuf = '\0';
4451 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4452 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
4453 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
4455 yyerror("<> should be quotes");
4463 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4467 LOP(OP_RENAME,XTERM);
4476 LOP(OP_RINDEX,XTERM);
4499 LOP(OP_REVERSE,XTERM);
4510 TERM(sublex_start());
4512 TOKEN(1); /* force error */
4521 LOP(OP_SELECT,XTERM);
4527 LOP(OP_SEMCTL,XTERM);
4530 LOP(OP_SEMGET,XTERM);
4533 LOP(OP_SEMOP,XTERM);
4539 LOP(OP_SETPGRP,XTERM);
4541 case KEY_setpriority:
4542 LOP(OP_SETPRIORITY,XTERM);
4544 case KEY_sethostent:
4550 case KEY_setservent:
4553 case KEY_setprotoent:
4563 LOP(OP_SEEKDIR,XTERM);
4565 case KEY_setsockopt:
4566 LOP(OP_SSOCKOPT,XTERM);
4572 LOP(OP_SHMCTL,XTERM);
4575 LOP(OP_SHMGET,XTERM);
4578 LOP(OP_SHMREAD,XTERM);
4581 LOP(OP_SHMWRITE,XTERM);
4584 LOP(OP_SHUTDOWN,XTERM);
4593 LOP(OP_SOCKET,XTERM);
4595 case KEY_socketpair:
4596 LOP(OP_SOCKPAIR,XTERM);
4599 checkcomma(s,PL_tokenbuf,"subroutine name");
4601 if (*s == ';' || *s == ')') /* probably a close */
4602 Perl_croak(aTHX_ "sort is now a reserved word");
4604 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4608 LOP(OP_SPLIT,XTERM);
4611 LOP(OP_SPRINTF,XTERM);
4614 LOP(OP_SPLICE,XTERM);
4629 LOP(OP_SUBSTR,XTERM);
4635 char tmpbuf[sizeof PL_tokenbuf];
4637 expectation attrful;
4638 bool have_name, have_proto;
4643 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
4644 (*s == ':' && s[1] == ':'))
4647 attrful = XATTRBLOCK;
4648 /* remember buffer pos'n for later force_word */
4649 tboffset = s - PL_oldbufptr;
4650 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4651 if (strchr(tmpbuf, ':'))
4652 sv_setpv(PL_subname, tmpbuf);
4654 sv_setsv(PL_subname,PL_curstname);
4655 sv_catpvn(PL_subname,"::",2);
4656 sv_catpvn(PL_subname,tmpbuf,len);
4663 Perl_croak(aTHX_ "Missing name in \"my sub\"");
4664 PL_expect = XTERMBLOCK;
4665 attrful = XATTRTERM;
4666 sv_setpv(PL_subname,"?");
4670 if (key == KEY_format) {
4672 PL_lex_formbrack = PL_lex_brackets + 1;
4674 (void) force_word(PL_oldbufptr + tboffset, WORD,
4679 /* Look for a prototype */
4683 s = scan_str(s,FALSE,FALSE);
4686 SvREFCNT_dec(PL_lex_stuff);
4687 PL_lex_stuff = Nullsv;
4688 Perl_croak(aTHX_ "Prototype not terminated");
4691 d = SvPVX(PL_lex_stuff);
4693 for (p = d; *p; ++p) {
4698 SvCUR(PL_lex_stuff) = tmp;
4706 if (*s == ':' && s[1] != ':')
4707 PL_expect = attrful;
4710 PL_nextval[PL_nexttoke].opval =
4711 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4712 PL_lex_stuff = Nullsv;
4716 sv_setpv(PL_subname,"__ANON__");
4719 (void) force_word(PL_oldbufptr + tboffset, WORD,
4728 LOP(OP_SYSTEM,XREF);
4731 LOP(OP_SYMLINK,XTERM);
4734 LOP(OP_SYSCALL,XTERM);
4737 LOP(OP_SYSOPEN,XTERM);
4740 LOP(OP_SYSSEEK,XTERM);
4743 LOP(OP_SYSREAD,XTERM);
4746 LOP(OP_SYSWRITE,XTERM);
4750 TERM(sublex_start());
4771 LOP(OP_TRUNCATE,XTERM);
4783 yylval.ival = CopLINE(PL_curcop);
4787 yylval.ival = CopLINE(PL_curcop);
4791 LOP(OP_UNLINK,XTERM);
4797 LOP(OP_UNPACK,XTERM);
4800 LOP(OP_UTIME,XTERM);
4803 if (ckWARN(WARN_OCTAL)) {
4804 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4805 if (*d != '0' && isDIGIT(*d))
4806 Perl_warner(aTHX_ WARN_OCTAL,
4807 "umask: argument is missing initial 0");
4812 LOP(OP_UNSHIFT,XTERM);
4815 if (PL_expect != XSTATE)
4816 yyerror("\"use\" not allowed in expression");
4818 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4819 s = force_version(s);
4820 if (*s == ';' || (s = skipspace(s), *s == ';')) {
4821 PL_nextval[PL_nexttoke].opval = Nullop;
4826 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4827 s = force_version(s);
4839 yylval.ival = CopLINE(PL_curcop);
4843 PL_hints |= HINT_BLOCK_SCOPE;
4850 LOP(OP_WAITPID,XTERM);
4858 static char ctl_l[2];
4860 if (ctl_l[0] == '\0')
4861 ctl_l[0] = toCTRL('L');
4862 gv_fetchpv(ctl_l,TRUE, SVt_PV);
4865 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
4870 if (PL_expect == XOPERATOR)
4876 yylval.ival = OP_XOR;
4881 TERM(sublex_start());
4887 Perl_keyword(pTHX_ register char *d, I32 len)
4892 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
4893 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
4894 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
4895 if (strEQ(d,"__DATA__")) return KEY___DATA__;
4896 if (strEQ(d,"__END__")) return KEY___END__;
4900 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
4905 if (strEQ(d,"and")) return -KEY_and;
4906 if (strEQ(d,"abs")) return -KEY_abs;
4909 if (strEQ(d,"alarm")) return -KEY_alarm;
4910 if (strEQ(d,"atan2")) return -KEY_atan2;
4913 if (strEQ(d,"accept")) return -KEY_accept;
4918 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
4921 if (strEQ(d,"bless")) return -KEY_bless;
4922 if (strEQ(d,"bind")) return -KEY_bind;
4923 if (strEQ(d,"binmode")) return -KEY_binmode;
4926 if (strEQ(d,"CORE")) return -KEY_CORE;
4927 if (strEQ(d,"CHECK")) return KEY_CHECK;
4932 if (strEQ(d,"cmp")) return -KEY_cmp;
4933 if (strEQ(d,"chr")) return -KEY_chr;
4934 if (strEQ(d,"cos")) return -KEY_cos;
4937 if (strEQ(d,"chop")) return KEY_chop;
4940 if (strEQ(d,"close")) return -KEY_close;
4941 if (strEQ(d,"chdir")) return -KEY_chdir;
4942 if (strEQ(d,"chomp")) return KEY_chomp;
4943 if (strEQ(d,"chmod")) return -KEY_chmod;
4944 if (strEQ(d,"chown")) return -KEY_chown;
4945 if (strEQ(d,"crypt")) return -KEY_crypt;
4948 if (strEQ(d,"chroot")) return -KEY_chroot;
4949 if (strEQ(d,"caller")) return -KEY_caller;
4952 if (strEQ(d,"connect")) return -KEY_connect;
4955 if (strEQ(d,"closedir")) return -KEY_closedir;
4956 if (strEQ(d,"continue")) return -KEY_continue;
4961 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
4966 if (strEQ(d,"do")) return KEY_do;
4969 if (strEQ(d,"die")) return -KEY_die;
4972 if (strEQ(d,"dump")) return -KEY_dump;
4975 if (strEQ(d,"delete")) return KEY_delete;
4978 if (strEQ(d,"defined")) return KEY_defined;
4979 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
4982 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
4987 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
4988 if (strEQ(d,"END")) return KEY_END;
4993 if (strEQ(d,"eq")) return -KEY_eq;
4996 if (strEQ(d,"eof")) return -KEY_eof;
4997 if (strEQ(d,"exp")) return -KEY_exp;
5000 if (strEQ(d,"else")) return KEY_else;
5001 if (strEQ(d,"exit")) return -KEY_exit;
5002 if (strEQ(d,"eval")) return KEY_eval;
5003 if (strEQ(d,"exec")) return -KEY_exec;
5004 if (strEQ(d,"each")) return KEY_each;
5007 if (strEQ(d,"elsif")) return KEY_elsif;
5010 if (strEQ(d,"exists")) return KEY_exists;
5011 if (strEQ(d,"elseif")) Perl_warn(aTHX_ "elseif should be elsif");
5014 if (strEQ(d,"endgrent")) return -KEY_endgrent;
5015 if (strEQ(d,"endpwent")) return -KEY_endpwent;
5018 if (strEQ(d,"endnetent")) return -KEY_endnetent;
5021 if (strEQ(d,"endhostent")) return -KEY_endhostent;
5022 if (strEQ(d,"endservent")) return -KEY_endservent;
5025 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
5032 if (strEQ(d,"for")) return KEY_for;
5035 if (strEQ(d,"fork")) return -KEY_fork;
5038 if (strEQ(d,"fcntl")) return -KEY_fcntl;
5039 if (strEQ(d,"flock")) return -KEY_flock;
5042 if (strEQ(d,"format")) return KEY_format;
5043 if (strEQ(d,"fileno")) return -KEY_fileno;
5046 if (strEQ(d,"foreach")) return KEY_foreach;
5049 if (strEQ(d,"formline")) return -KEY_formline;
5055 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
5056 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
5060 if (strnEQ(d,"get",3)) {
5065 if (strEQ(d,"ppid")) return -KEY_getppid;
5066 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
5069 if (strEQ(d,"pwent")) return -KEY_getpwent;
5070 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
5071 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
5074 if (strEQ(d,"peername")) return -KEY_getpeername;
5075 if (strEQ(d,"protoent")) return -KEY_getprotoent;
5076 if (strEQ(d,"priority")) return -KEY_getpriority;
5079 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
5082 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
5086 else if (*d == 'h') {
5087 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
5088 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
5089 if (strEQ(d,"hostent")) return -KEY_gethostent;
5091 else if (*d == 'n') {
5092 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
5093 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
5094 if (strEQ(d,"netent")) return -KEY_getnetent;
5096 else if (*d == 's') {
5097 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
5098 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
5099 if (strEQ(d,"servent")) return -KEY_getservent;
5100 if (strEQ(d,"sockname")) return -KEY_getsockname;
5101 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
5103 else if (*d == 'g') {
5104 if (strEQ(d,"grent")) return -KEY_getgrent;
5105 if (strEQ(d,"grnam")) return -KEY_getgrnam;
5106 if (strEQ(d,"grgid")) return -KEY_getgrgid;
5108 else if (*d == 'l') {
5109 if (strEQ(d,"login")) return -KEY_getlogin;
5111 else if (strEQ(d,"c")) return -KEY_getc;
5116 if (strEQ(d,"gt")) return -KEY_gt;
5117 if (strEQ(d,"ge")) return -KEY_ge;
5120 if (strEQ(d,"grep")) return KEY_grep;
5121 if (strEQ(d,"goto")) return KEY_goto;
5122 if (strEQ(d,"glob")) return KEY_glob;
5125 if (strEQ(d,"gmtime")) return -KEY_gmtime;
5130 if (strEQ(d,"hex")) return -KEY_hex;
5133 if (strEQ(d,"INIT")) return KEY_INIT;
5138 if (strEQ(d,"if")) return KEY_if;
5141 if (strEQ(d,"int")) return -KEY_int;
5144 if (strEQ(d,"index")) return -KEY_index;
5145 if (strEQ(d,"ioctl")) return -KEY_ioctl;
5150 if (strEQ(d,"join")) return -KEY_join;
5154 if (strEQ(d,"keys")) return KEY_keys;
5155 if (strEQ(d,"kill")) return -KEY_kill;
5160 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
5161 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
5167 if (strEQ(d,"lt")) return -KEY_lt;
5168 if (strEQ(d,"le")) return -KEY_le;
5169 if (strEQ(d,"lc")) return -KEY_lc;
5172 if (strEQ(d,"log")) return -KEY_log;
5175 if (strEQ(d,"last")) return KEY_last;
5176 if (strEQ(d,"link")) return -KEY_link;
5177 if (strEQ(d,"lock")) return -KEY_lock;
5180 if (strEQ(d,"local")) return KEY_local;
5181 if (strEQ(d,"lstat")) return -KEY_lstat;
5184 if (strEQ(d,"length")) return -KEY_length;
5185 if (strEQ(d,"listen")) return -KEY_listen;
5188 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
5191 if (strEQ(d,"localtime")) return -KEY_localtime;
5197 case 1: return KEY_m;
5199 if (strEQ(d,"my")) return KEY_my;
5202 if (strEQ(d,"map")) return KEY_map;
5205 if (strEQ(d,"mkdir")) return -KEY_mkdir;
5208 if (strEQ(d,"msgctl")) return -KEY_msgctl;
5209 if (strEQ(d,"msgget")) return -KEY_msgget;
5210 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
5211 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
5216 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
5219 if (strEQ(d,"next")) return KEY_next;
5220 if (strEQ(d,"ne")) return -KEY_ne;
5221 if (strEQ(d,"not")) return -KEY_not;
5222 if (strEQ(d,"no")) return KEY_no;
5227 if (strEQ(d,"or")) return -KEY_or;
5230 if (strEQ(d,"ord")) return -KEY_ord;
5231 if (strEQ(d,"oct")) return -KEY_oct;
5232 if (strEQ(d,"our")) return KEY_our;
5235 if (strEQ(d,"open")) return -KEY_open;
5238 if (strEQ(d,"opendir")) return -KEY_opendir;
5245 if (strEQ(d,"pop")) return KEY_pop;
5246 if (strEQ(d,"pos")) return KEY_pos;
5249 if (strEQ(d,"push")) return KEY_push;
5250 if (strEQ(d,"pack")) return -KEY_pack;
5251 if (strEQ(d,"pipe")) return -KEY_pipe;
5254 if (strEQ(d,"print")) return KEY_print;
5257 if (strEQ(d,"printf")) return KEY_printf;
5260 if (strEQ(d,"package")) return KEY_package;
5263 if (strEQ(d,"prototype")) return KEY_prototype;
5268 if (strEQ(d,"q")) return KEY_q;
5269 if (strEQ(d,"qr")) return KEY_qr;
5270 if (strEQ(d,"qq")) return KEY_qq;
5271 if (strEQ(d,"qw")) return KEY_qw;
5272 if (strEQ(d,"qx")) return KEY_qx;
5274 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
5279 if (strEQ(d,"ref")) return -KEY_ref;
5282 if (strEQ(d,"read")) return -KEY_read;
5283 if (strEQ(d,"rand")) return -KEY_rand;
5284 if (strEQ(d,"recv")) return -KEY_recv;
5285 if (strEQ(d,"redo")) return KEY_redo;
5288 if (strEQ(d,"rmdir")) return -KEY_rmdir;
5289 if (strEQ(d,"reset")) return -KEY_reset;
5292 if (strEQ(d,"return")) return KEY_return;
5293 if (strEQ(d,"rename")) return -KEY_rename;
5294 if (strEQ(d,"rindex")) return -KEY_rindex;
5297 if (strEQ(d,"require")) return -KEY_require;
5298 if (strEQ(d,"reverse")) return -KEY_reverse;
5299 if (strEQ(d,"readdir")) return -KEY_readdir;
5302 if (strEQ(d,"readlink")) return -KEY_readlink;
5303 if (strEQ(d,"readline")) return -KEY_readline;
5304 if (strEQ(d,"readpipe")) return -KEY_readpipe;
5307 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
5313 case 0: return KEY_s;
5315 if (strEQ(d,"scalar")) return KEY_scalar;
5320 if (strEQ(d,"seek")) return -KEY_seek;
5321 if (strEQ(d,"send")) return -KEY_send;
5324 if (strEQ(d,"semop")) return -KEY_semop;
5327 if (strEQ(d,"select")) return -KEY_select;
5328 if (strEQ(d,"semctl")) return -KEY_semctl;
5329 if (strEQ(d,"semget")) return -KEY_semget;
5332 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
5333 if (strEQ(d,"seekdir")) return -KEY_seekdir;
5336 if (strEQ(d,"setpwent")) return -KEY_setpwent;
5337 if (strEQ(d,"setgrent")) return -KEY_setgrent;
5340 if (strEQ(d,"setnetent")) return -KEY_setnetent;
5343 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
5344 if (strEQ(d,"sethostent")) return -KEY_sethostent;
5345 if (strEQ(d,"setservent")) return -KEY_setservent;
5348 if (strEQ(d,"setpriority")) return -KEY_setpriority;
5349 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
5356 if (strEQ(d,"shift")) return KEY_shift;
5359 if (strEQ(d,"shmctl")) return -KEY_shmctl;
5360 if (strEQ(d,"shmget")) return -KEY_shmget;
5363 if (strEQ(d,"shmread")) return -KEY_shmread;
5366 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
5367 if (strEQ(d,"shutdown")) return -KEY_shutdown;
5372 if (strEQ(d,"sin")) return -KEY_sin;
5375 if (strEQ(d,"sleep")) return -KEY_sleep;
5378 if (strEQ(d,"sort")) return KEY_sort;
5379 if (strEQ(d,"socket")) return -KEY_socket;
5380 if (strEQ(d,"socketpair")) return -KEY_socketpair;
5383 if (strEQ(d,"split")) return KEY_split;
5384 if (strEQ(d,"sprintf")) return -KEY_sprintf;
5385 if (strEQ(d,"splice")) return KEY_splice;
5388 if (strEQ(d,"sqrt")) return -KEY_sqrt;
5391 if (strEQ(d,"srand")) return -KEY_srand;
5394 if (strEQ(d,"stat")) return -KEY_stat;
5395 if (strEQ(d,"study")) return KEY_study;
5398 if (strEQ(d,"substr")) return -KEY_substr;
5399 if (strEQ(d,"sub")) return KEY_sub;
5404 if (strEQ(d,"system")) return -KEY_system;
5407 if (strEQ(d,"symlink")) return -KEY_symlink;
5408 if (strEQ(d,"syscall")) return -KEY_syscall;
5409 if (strEQ(d,"sysopen")) return -KEY_sysopen;
5410 if (strEQ(d,"sysread")) return -KEY_sysread;
5411 if (strEQ(d,"sysseek")) return -KEY_sysseek;
5414 if (strEQ(d,"syswrite")) return -KEY_syswrite;
5423 if (strEQ(d,"tr")) return KEY_tr;
5426 if (strEQ(d,"tie")) return KEY_tie;
5429 if (strEQ(d,"tell")) return -KEY_tell;
5430 if (strEQ(d,"tied")) return KEY_tied;
5431 if (strEQ(d,"time")) return -KEY_time;
5434 if (strEQ(d,"times")) return -KEY_times;
5437 if (strEQ(d,"telldir")) return -KEY_telldir;
5440 if (strEQ(d,"truncate")) return -KEY_truncate;
5447 if (strEQ(d,"uc")) return -KEY_uc;
5450 if (strEQ(d,"use")) return KEY_use;
5453 if (strEQ(d,"undef")) return KEY_undef;
5454 if (strEQ(d,"until")) return KEY_until;
5455 if (strEQ(d,"untie")) return KEY_untie;
5456 if (strEQ(d,"utime")) return -KEY_utime;
5457 if (strEQ(d,"umask")) return -KEY_umask;
5460 if (strEQ(d,"unless")) return KEY_unless;
5461 if (strEQ(d,"unpack")) return -KEY_unpack;
5462 if (strEQ(d,"unlink")) return -KEY_unlink;
5465 if (strEQ(d,"unshift")) return KEY_unshift;
5466 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
5471 if (strEQ(d,"values")) return -KEY_values;
5472 if (strEQ(d,"vec")) return -KEY_vec;
5477 if (strEQ(d,"warn")) return -KEY_warn;
5478 if (strEQ(d,"wait")) return -KEY_wait;
5481 if (strEQ(d,"while")) return KEY_while;
5482 if (strEQ(d,"write")) return -KEY_write;
5485 if (strEQ(d,"waitpid")) return -KEY_waitpid;
5488 if (strEQ(d,"wantarray")) return -KEY_wantarray;
5493 if (len == 1) return -KEY_x;
5494 if (strEQ(d,"xor")) return -KEY_xor;
5497 if (len == 1) return KEY_y;
5506 S_checkcomma(pTHX_ register char *s, char *name, char *what)
5510 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
5511 dTHR; /* only for ckWARN */
5512 if (ckWARN(WARN_SYNTAX)) {
5514 for (w = s+2; *w && level; w++) {
5521 for (; *w && isSPACE(*w); w++) ;
5522 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
5523 Perl_warner(aTHX_ WARN_SYNTAX,
5524 "%s (...) interpreted as function",name);
5527 while (s < PL_bufend && isSPACE(*s))
5531 while (s < PL_bufend && isSPACE(*s))
5533 if (isIDFIRST_lazy_if(s,UTF)) {
5535 while (isALNUM_lazy_if(s,UTF))
5537 while (s < PL_bufend && isSPACE(*s))
5542 kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
5546 Perl_croak(aTHX_ "No comma allowed after %s", what);
5551 /* Either returns sv, or mortalizes sv and returns a new SV*.
5552 Best used as sv=new_constant(..., sv, ...).
5553 If s, pv are NULL, calls subroutine with one argument,
5554 and type is used with error messages only. */
5557 S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv,
5561 HV *table = GvHV(PL_hintgv); /* ^H */
5565 const char *why, *why1, *why2;
5567 if (!(PL_hints & HINT_LOCALIZE_HH)) {
5570 why = "%^H is not localized";
5574 msg = Perl_newSVpvf(aTHX_ "constant(%s): %s%s%s",
5575 (type ? type: "undef"), why1, why2, why);
5576 yyerror(SvPVX(msg));
5581 why = "%^H is not defined";
5584 cvp = hv_fetch(table, key, strlen(key), FALSE);
5585 if (!cvp || !SvOK(*cvp)) {
5586 why = "} is not defined";
5591 sv_2mortal(sv); /* Parent created it permanently */
5594 pv = sv_2mortal(newSVpvn(s, len));
5596 typesv = sv_2mortal(newSVpv(type, 0));
5598 typesv = &PL_sv_undef;
5600 PUSHSTACKi(PERLSI_OVERLOAD);
5613 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
5617 /* Check the eval first */
5618 if (!PL_in_eval && SvTRUE(ERRSV))
5621 sv_catpv(ERRSV, "Propagated");
5622 yyerror(SvPV(ERRSV, n_a)); /* Duplicates the message inside eval */
5624 res = SvREFCNT_inc(sv);
5628 (void)SvREFCNT_inc(res);
5637 why = "}} did not return a defined value";
5638 why1 = "Call to &{$^H{";
5648 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
5650 register char *d = dest;
5651 register char *e = d + destlen - 3; /* two-character token, ending NUL */
5654 Perl_croak(aTHX_ ident_too_long);
5655 if (isALNUM(*s)) /* UTF handled below */
5657 else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) {
5662 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
5666 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5667 char *t = s + UTF8SKIP(s);
5668 while (*t & 0x80 && is_utf8_mark((U8*)t))
5670 if (d + (t - s) > e)
5671 Perl_croak(aTHX_ ident_too_long);
5672 Copy(s, d, t - s, char);
5685 S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
5695 e = d + destlen - 3; /* two-character token, ending NUL */
5697 while (isDIGIT(*s)) {
5699 Perl_croak(aTHX_ ident_too_long);
5706 Perl_croak(aTHX_ ident_too_long);
5707 if (isALNUM(*s)) /* UTF handled below */
5709 else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
5714 else if (*s == ':' && s[1] == ':') {
5718 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5719 char *t = s + UTF8SKIP(s);
5720 while (*t & 0x80 && is_utf8_mark((U8*)t))
5722 if (d + (t - s) > e)
5723 Perl_croak(aTHX_ ident_too_long);
5724 Copy(s, d, t - s, char);
5735 if (PL_lex_state != LEX_NORMAL)
5736 PL_lex_state = LEX_INTERPENDMAYBE;
5739 if (*s == '$' && s[1] &&
5740 (isALNUM_lazy_if(s+1,UTF) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
5753 if (*d == '^' && *s && isCONTROLVAR(*s)) {
5758 if (isSPACE(s[-1])) {
5761 if (ch != ' ' && ch != '\t') {
5767 if (isIDFIRST_lazy_if(d,UTF)) {
5771 while (e < send && isALNUM_lazy_if(e,UTF) || *e == ':') {
5773 while (e < send && *e & 0x80 && is_utf8_mark((U8*)e))
5776 Copy(s, d, e - s, char);
5781 while ((isALNUM(*s) || *s == ':') && d < e)
5784 Perl_croak(aTHX_ ident_too_long);
5787 while (s < send && (*s == ' ' || *s == '\t')) s++;
5788 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
5789 dTHR; /* only for ckWARN */
5790 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
5791 const char *brack = *s == '[' ? "[...]" : "{...}";
5792 Perl_warner(aTHX_ WARN_AMBIGUOUS,
5793 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
5794 funny, dest, brack, funny, dest, brack);
5797 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
5801 /* Handle extended ${^Foo} variables
5802 * 1999-02-27 mjd-perl-patch@plover.com */
5803 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
5807 while (isALNUM(*s) && d < e) {
5811 Perl_croak(aTHX_ ident_too_long);
5816 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
5817 PL_lex_state = LEX_INTERPEND;
5820 if (PL_lex_state == LEX_NORMAL) {
5821 dTHR; /* only for ckWARN */
5822 if (ckWARN(WARN_AMBIGUOUS) &&
5823 (keyword(dest, d - dest) || get_cv(dest, FALSE)))
5825 Perl_warner(aTHX_ WARN_AMBIGUOUS,
5826 "Ambiguous use of %c{%s} resolved to %c%s",
5827 funny, dest, funny, dest);
5832 s = bracket; /* let the parser handle it */
5836 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
5837 PL_lex_state = LEX_INTERPEND;
5842 Perl_pmflag(pTHX_ U16 *pmfl, int ch)
5847 *pmfl |= PMf_GLOBAL;
5849 *pmfl |= PMf_CONTINUE;
5853 *pmfl |= PMf_MULTILINE;
5855 *pmfl |= PMf_SINGLELINE;
5857 *pmfl |= PMf_EXTENDED;
5861 S_scan_pat(pTHX_ char *start, I32 type)
5866 s = scan_str(start,FALSE,FALSE);
5869 SvREFCNT_dec(PL_lex_stuff);
5870 PL_lex_stuff = Nullsv;
5871 Perl_croak(aTHX_ "Search pattern not terminated");
5874 pm = (PMOP*)newPMOP(type, 0);
5875 if (PL_multi_open == '?')
5876 pm->op_pmflags |= PMf_ONCE;
5878 while (*s && strchr("iomsx", *s))
5879 pmflag(&pm->op_pmflags,*s++);
5882 while (*s && strchr("iogcmsx", *s))
5883 pmflag(&pm->op_pmflags,*s++);
5885 pm->op_pmpermflags = pm->op_pmflags;
5887 PL_lex_op = (OP*)pm;
5888 yylval.ival = OP_MATCH;
5893 S_scan_subst(pTHX_ char *start)
5900 yylval.ival = OP_NULL;
5902 s = scan_str(start,FALSE,FALSE);
5906 SvREFCNT_dec(PL_lex_stuff);
5907 PL_lex_stuff = Nullsv;
5908 Perl_croak(aTHX_ "Substitution pattern not terminated");
5911 if (s[-1] == PL_multi_open)
5914 first_start = PL_multi_start;
5915 s = scan_str(s,FALSE,FALSE);
5918 SvREFCNT_dec(PL_lex_stuff);
5919 PL_lex_stuff = Nullsv;
5921 SvREFCNT_dec(PL_lex_repl);
5922 PL_lex_repl = Nullsv;
5923 Perl_croak(aTHX_ "Substitution replacement not terminated");
5925 PL_multi_start = first_start; /* so whole substitution is taken together */
5927 pm = (PMOP*)newPMOP(OP_SUBST, 0);
5933 else if (strchr("iogcmsx", *s))
5934 pmflag(&pm->op_pmflags,*s++);
5941 PL_sublex_info.super_bufptr = s;
5942 PL_sublex_info.super_bufend = PL_bufend;
5944 pm->op_pmflags |= PMf_EVAL;
5945 repl = newSVpvn("",0);
5947 sv_catpv(repl, es ? "eval " : "do ");
5948 sv_catpvn(repl, "{ ", 2);
5949 sv_catsv(repl, PL_lex_repl);
5950 sv_catpvn(repl, " };", 2);
5952 SvREFCNT_dec(PL_lex_repl);
5956 pm->op_pmpermflags = pm->op_pmflags;
5957 PL_lex_op = (OP*)pm;
5958 yylval.ival = OP_SUBST;
5963 S_scan_trans(pTHX_ char *start)
5974 yylval.ival = OP_NULL;
5976 s = scan_str(start,FALSE,FALSE);
5979 SvREFCNT_dec(PL_lex_stuff);
5980 PL_lex_stuff = Nullsv;
5981 Perl_croak(aTHX_ "Transliteration pattern not terminated");
5983 if (s[-1] == PL_multi_open)
5986 s = scan_str(s,FALSE,FALSE);
5989 SvREFCNT_dec(PL_lex_stuff);
5990 PL_lex_stuff = Nullsv;
5992 SvREFCNT_dec(PL_lex_repl);
5993 PL_lex_repl = Nullsv;
5994 Perl_croak(aTHX_ "Transliteration replacement not terminated");
5998 o = newSVOP(OP_TRANS, 0, 0);
5999 utf8 = OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF;
6002 New(803,tbl,256,short);
6003 o = newPVOP(OP_TRANS, 0, (char*)tbl);
6007 complement = del = squash = 0;
6008 while (strchr("cdsCU", *s)) {
6010 complement = OPpTRANS_COMPLEMENT;
6012 del = OPpTRANS_DELETE;
6014 squash = OPpTRANS_SQUASH;
6019 utf8 &= ~OPpTRANS_FROM_UTF;
6021 utf8 |= OPpTRANS_FROM_UTF;
6025 utf8 &= ~OPpTRANS_TO_UTF;
6027 utf8 |= OPpTRANS_TO_UTF;
6030 Perl_croak(aTHX_ "Too many /C and /U options");
6035 o->op_private = del|squash|complement|utf8;
6038 yylval.ival = OP_TRANS;
6043 S_scan_heredoc(pTHX_ register char *s)
6047 I32 op_type = OP_SCALAR;
6054 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
6058 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
6061 for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
6062 if (*peek && strchr("`'\"",*peek)) {
6065 s = delimcpy(d, e, s, PL_bufend, term, &len);
6075 if (!isALNUM_lazy_if(s,UTF))
6076 deprecate("bare << to mean <<\"\"");
6077 for (; isALNUM_lazy_if(s,UTF); s++) {
6082 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
6083 Perl_croak(aTHX_ "Delimiter for here document is too long");
6086 len = d - PL_tokenbuf;
6087 #ifndef PERL_STRICT_CR
6088 d = strchr(s, '\r');
6092 while (s < PL_bufend) {
6098 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
6107 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6112 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
6113 herewas = newSVpvn(s,PL_bufend-s);
6115 s--, herewas = newSVpvn(s,d-s);
6116 s += SvCUR(herewas);
6118 tmpstr = NEWSV(87,79);
6119 sv_upgrade(tmpstr, SVt_PVIV);
6124 else if (term == '`') {
6125 op_type = OP_BACKTICK;
6126 SvIVX(tmpstr) = '\\';
6130 PL_multi_start = CopLINE(PL_curcop);
6131 PL_multi_open = PL_multi_close = '<';
6132 term = *PL_tokenbuf;
6133 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
6134 char *bufptr = PL_sublex_info.super_bufptr;
6135 char *bufend = PL_sublex_info.super_bufend;
6136 char *olds = s - SvCUR(herewas);
6137 s = strchr(bufptr, '\n');
6141 while (s < bufend &&
6142 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6144 CopLINE_inc(PL_curcop);
6147 CopLINE_set(PL_curcop, PL_multi_start);
6148 missingterm(PL_tokenbuf);
6150 sv_setpvn(herewas,bufptr,d-bufptr+1);
6151 sv_setpvn(tmpstr,d+1,s-d);
6153 sv_catpvn(herewas,s,bufend-s);
6154 (void)strcpy(bufptr,SvPVX(herewas));
6161 while (s < PL_bufend &&
6162 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6164 CopLINE_inc(PL_curcop);
6166 if (s >= PL_bufend) {
6167 CopLINE_set(PL_curcop, PL_multi_start);
6168 missingterm(PL_tokenbuf);
6170 sv_setpvn(tmpstr,d+1,s-d);
6172 CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
6174 sv_catpvn(herewas,s,PL_bufend-s);
6175 sv_setsv(PL_linestr,herewas);
6176 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
6177 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6180 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
6181 while (s >= PL_bufend) { /* multiple line string? */
6183 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6184 CopLINE_set(PL_curcop, PL_multi_start);
6185 missingterm(PL_tokenbuf);
6187 CopLINE_inc(PL_curcop);
6188 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6189 #ifndef PERL_STRICT_CR
6190 if (PL_bufend - PL_linestart >= 2) {
6191 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
6192 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
6194 PL_bufend[-2] = '\n';
6196 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6198 else if (PL_bufend[-1] == '\r')
6199 PL_bufend[-1] = '\n';
6201 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
6202 PL_bufend[-1] = '\n';
6204 if (PERLDB_LINE && PL_curstash != PL_debstash) {
6205 SV *sv = NEWSV(88,0);
6207 sv_upgrade(sv, SVt_PVMG);
6208 sv_setsv(sv,PL_linestr);
6209 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop),sv);
6211 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
6214 sv_catsv(PL_linestr,herewas);
6215 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6219 sv_catsv(tmpstr,PL_linestr);
6224 PL_multi_end = CopLINE(PL_curcop);
6225 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
6226 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
6227 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
6229 SvREFCNT_dec(herewas);
6230 PL_lex_stuff = tmpstr;
6231 yylval.ival = op_type;
6236 takes: current position in input buffer
6237 returns: new position in input buffer
6238 side-effects: yylval and lex_op are set.
6243 <FH> read from filehandle
6244 <pkg::FH> read from package qualified filehandle
6245 <pkg'FH> read from package qualified filehandle
6246 <$fh> read from filehandle in $fh
6252 S_scan_inputsymbol(pTHX_ char *start)
6254 register char *s = start; /* current position in buffer */
6260 d = PL_tokenbuf; /* start of temp holding space */
6261 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
6262 end = strchr(s, '\n');
6265 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
6267 /* die if we didn't have space for the contents of the <>,
6268 or if it didn't end, or if we see a newline
6271 if (len >= sizeof PL_tokenbuf)
6272 Perl_croak(aTHX_ "Excessively long <> operator");
6274 Perl_croak(aTHX_ "Unterminated <> operator");
6279 Remember, only scalar variables are interpreted as filehandles by
6280 this code. Anything more complex (e.g., <$fh{$num}>) will be
6281 treated as a glob() call.
6282 This code makes use of the fact that except for the $ at the front,
6283 a scalar variable and a filehandle look the same.
6285 if (*d == '$' && d[1]) d++;
6287 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
6288 while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
6291 /* If we've tried to read what we allow filehandles to look like, and
6292 there's still text left, then it must be a glob() and not a getline.
6293 Use scan_str to pull out the stuff between the <> and treat it
6294 as nothing more than a string.
6297 if (d - PL_tokenbuf != len) {
6298 yylval.ival = OP_GLOB;
6300 s = scan_str(start,FALSE,FALSE);
6302 Perl_croak(aTHX_ "Glob not terminated");
6306 /* we're in a filehandle read situation */
6309 /* turn <> into <ARGV> */
6311 (void)strcpy(d,"ARGV");
6313 /* if <$fh>, create the ops to turn the variable into a
6319 /* try to find it in the pad for this block, otherwise find
6320 add symbol table ops
6322 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
6323 OP *o = newOP(OP_PADSV, 0);
6325 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, o);
6328 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
6329 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
6330 newUNOP(OP_RV2SV, 0,
6331 newGVOP(OP_GV, 0, gv)));
6333 PL_lex_op->op_flags |= OPf_SPECIAL;
6334 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
6335 yylval.ival = OP_NULL;
6338 /* If it's none of the above, it must be a literal filehandle
6339 (<Foo::BAR> or <FOO>) so build a simple readline OP */
6341 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
6342 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
6343 yylval.ival = OP_NULL;
6352 takes: start position in buffer
6353 keep_quoted preserve \ on the embedded delimiter(s)
6354 keep_delims preserve the delimiters around the string
6355 returns: position to continue reading from buffer
6356 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
6357 updates the read buffer.
6359 This subroutine pulls a string out of the input. It is called for:
6360 q single quotes q(literal text)
6361 ' single quotes 'literal text'
6362 qq double quotes qq(interpolate $here please)
6363 " double quotes "interpolate $here please"
6364 qx backticks qx(/bin/ls -l)
6365 ` backticks `/bin/ls -l`
6366 qw quote words @EXPORT_OK = qw( func() $spam )
6367 m// regexp match m/this/
6368 s/// regexp substitute s/this/that/
6369 tr/// string transliterate tr/this/that/
6370 y/// string transliterate y/this/that/
6371 ($*@) sub prototypes sub foo ($)
6372 (stuff) sub attr parameters sub foo : attr(stuff)
6373 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
6375 In most of these cases (all but <>, patterns and transliterate)
6376 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
6377 calls scan_str(). s/// makes yylex() call scan_subst() which calls
6378 scan_str(). tr/// and y/// make yylex() call scan_trans() which
6381 It skips whitespace before the string starts, and treats the first
6382 character as the delimiter. If the delimiter is one of ([{< then
6383 the corresponding "close" character )]}> is used as the closing
6384 delimiter. It allows quoting of delimiters, and if the string has
6385 balanced delimiters ([{<>}]) it allows nesting.
6387 The lexer always reads these strings into lex_stuff, except in the
6388 case of the operators which take *two* arguments (s/// and tr///)
6389 when it checks to see if lex_stuff is full (presumably with the 1st
6390 arg to s or tr) and if so puts the string into lex_repl.
6395 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
6398 SV *sv; /* scalar value: string */
6399 char *tmps; /* temp string, used for delimiter matching */
6400 register char *s = start; /* current position in the buffer */
6401 register char term; /* terminating character */
6402 register char *to; /* current position in the sv's data */
6403 I32 brackets = 1; /* bracket nesting level */
6404 bool has_utf = FALSE; /* is there any utf8 content? */
6406 /* skip space before the delimiter */
6410 /* mark where we are, in case we need to report errors */
6413 /* after skipping whitespace, the next character is the terminator */
6415 if ((term & 0x80) && UTF)
6418 /* mark where we are */
6419 PL_multi_start = CopLINE(PL_curcop);
6420 PL_multi_open = term;
6422 /* find corresponding closing delimiter */
6423 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
6425 PL_multi_close = term;
6427 /* create a new SV to hold the contents. 87 is leak category, I'm
6428 assuming. 79 is the SV's initial length. What a random number. */
6430 sv_upgrade(sv, SVt_PVIV);
6432 (void)SvPOK_only(sv); /* validate pointer */
6434 /* move past delimiter and try to read a complete string */
6436 sv_catpvn(sv, s, 1);
6439 /* extend sv if need be */
6440 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
6441 /* set 'to' to the next character in the sv's string */
6442 to = SvPVX(sv)+SvCUR(sv);
6444 /* if open delimiter is the close delimiter read unbridle */
6445 if (PL_multi_open == PL_multi_close) {
6446 for (; s < PL_bufend; s++,to++) {
6447 /* embedded newlines increment the current line number */
6448 if (*s == '\n' && !PL_rsfp)
6449 CopLINE_inc(PL_curcop);
6450 /* handle quoted delimiters */
6451 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
6452 if (!keep_quoted && s[1] == term)
6454 /* any other quotes are simply copied straight through */
6458 /* terminate when run out of buffer (the for() condition), or
6459 have found the terminator */
6460 else if (*s == term)
6462 else if (!has_utf && (*s & 0x80) && UTF)
6468 /* if the terminator isn't the same as the start character (e.g.,
6469 matched brackets), we have to allow more in the quoting, and
6470 be prepared for nested brackets.
6473 /* read until we run out of string, or we find the terminator */
6474 for (; s < PL_bufend; s++,to++) {
6475 /* embedded newlines increment the line count */
6476 if (*s == '\n' && !PL_rsfp)
6477 CopLINE_inc(PL_curcop);
6478 /* backslashes can escape the open or closing characters */
6479 if (*s == '\\' && s+1 < PL_bufend) {
6481 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
6486 /* allow nested opens and closes */
6487 else if (*s == PL_multi_close && --brackets <= 0)
6489 else if (*s == PL_multi_open)
6491 else if (!has_utf && (*s & 0x80) && UTF)
6496 /* terminate the copied string and update the sv's end-of-string */
6498 SvCUR_set(sv, to - SvPVX(sv));
6501 * this next chunk reads more into the buffer if we're not done yet
6505 break; /* handle case where we are done yet :-) */
6507 #ifndef PERL_STRICT_CR
6508 if (to - SvPVX(sv) >= 2) {
6509 if ((to[-2] == '\r' && to[-1] == '\n') ||
6510 (to[-2] == '\n' && to[-1] == '\r'))
6514 SvCUR_set(sv, to - SvPVX(sv));
6516 else if (to[-1] == '\r')
6519 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
6523 /* if we're out of file, or a read fails, bail and reset the current
6524 line marker so we can report where the unterminated string began
6527 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6529 CopLINE_set(PL_curcop, PL_multi_start);
6532 /* we read a line, so increment our line counter */
6533 CopLINE_inc(PL_curcop);
6535 /* update debugger info */
6536 if (PERLDB_LINE && PL_curstash != PL_debstash) {
6537 SV *sv = NEWSV(88,0);
6539 sv_upgrade(sv, SVt_PVMG);
6540 sv_setsv(sv,PL_linestr);
6541 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop), sv);
6544 /* having changed the buffer, we must update PL_bufend */
6545 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6548 /* at this point, we have successfully read the delimited string */
6551 sv_catpvn(sv, s, 1);
6554 PL_multi_end = CopLINE(PL_curcop);
6557 /* if we allocated too much space, give some back */
6558 if (SvCUR(sv) + 5 < SvLEN(sv)) {
6559 SvLEN_set(sv, SvCUR(sv) + 1);
6560 Renew(SvPVX(sv), SvLEN(sv), char);
6563 /* decide whether this is the first or second quoted string we've read
6576 takes: pointer to position in buffer
6577 returns: pointer to new position in buffer
6578 side-effects: builds ops for the constant in yylval.op
6580 Read a number in any of the formats that Perl accepts:
6582 0(x[0-7A-F]+)|([0-7]+)|(b[01])
6583 [\d_]+(\.[\d_]*)?[Ee](\d+)
6585 Underbars (_) are allowed in decimal numbers. If -w is on,
6586 underbars before a decimal point must be at three digit intervals.
6588 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
6591 If it reads a number without a decimal point or an exponent, it will
6592 try converting the number to an integer and see if it can do so
6593 without loss of precision.
6597 Perl_scan_num(pTHX_ char *start)
6599 register char *s = start; /* current position in buffer */
6600 register char *d; /* destination in temp buffer */
6601 register char *e; /* end of temp buffer */
6602 IV tryiv; /* used to see if it can be an IV */
6603 NV value; /* number read, as a double */
6604 SV *sv = Nullsv; /* place to put the converted number */
6605 bool floatit; /* boolean: int or float? */
6606 char *lastub = 0; /* position of last underbar */
6607 static char number_too_long[] = "Number too long";
6609 /* We use the first character to decide what type of number this is */
6613 Perl_croak(aTHX_ "panic: scan_num");
6615 /* if it starts with a 0, it could be an octal number, a decimal in
6616 0.13 disguise, or a hexadecimal number, or a binary number. */
6620 u holds the "number so far"
6621 shift the power of 2 of the base
6622 (hex == 4, octal == 3, binary == 1)
6623 overflowed was the number more than we can hold?
6625 Shift is used when we add a digit. It also serves as an "are
6626 we in octal/hex/binary?" indicator to disallow hex characters
6633 bool overflowed = FALSE;
6634 static NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
6635 static char* bases[5] = { "", "binary", "", "octal",
6637 static char* Bases[5] = { "", "Binary", "", "Octal",
6639 static char *maxima[5] = { "",
6640 "0b11111111111111111111111111111111",
6644 char *base, *Base, *max;
6650 } else if (s[1] == 'b') {
6654 /* check for a decimal in disguise */
6655 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
6657 /* so it must be octal */
6661 base = bases[shift];
6662 Base = Bases[shift];
6663 max = maxima[shift];
6665 /* read the rest of the number */
6667 /* x is used in the overflow test,
6668 b is the digit we're adding on. */
6673 /* if we don't mention it, we're done */
6682 /* 8 and 9 are not octal */
6685 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
6689 case '2': case '3': case '4':
6690 case '5': case '6': case '7':
6692 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
6696 b = *s++ & 15; /* ASCII digit -> value of digit */
6700 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
6701 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
6702 /* make sure they said 0x */
6707 /* Prepare to put the digit we have onto the end
6708 of the number so far. We check for overflows.
6713 x = u << shift; /* make room for the digit */
6715 if ((x >> shift) != u
6716 && !(PL_hints & HINT_NEW_BINARY)) {
6720 if (ckWARN_d(WARN_OVERFLOW))
6721 Perl_warner(aTHX_ WARN_OVERFLOW,
6722 "Integer overflow in %s number",
6725 u = x | b; /* add the digit to the end */
6728 n *= nvshift[shift];
6729 /* If an NV has not enough bits in its
6730 * mantissa to represent an UV this summing of
6731 * small low-order numbers is a waste of time
6732 * (because the NV cannot preserve the
6733 * low-order bits anyway): we could just
6734 * remember when did we overflow and in the
6735 * end just multiply n by the right
6743 /* if we get here, we had success: make a scalar value from
6750 if (ckWARN(WARN_PORTABLE) && n > 4294967295.0)
6751 Perl_warner(aTHX_ WARN_PORTABLE,
6752 "%s number > %s non-portable",
6759 if (ckWARN(WARN_PORTABLE) && u > 0xffffffff)
6760 Perl_warner(aTHX_ WARN_PORTABLE,
6761 "%s number > %s non-portable",
6766 if (PL_hints & HINT_NEW_BINARY)
6767 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
6772 handle decimal numbers.
6773 we're also sent here when we read a 0 as the first digit
6775 case '1': case '2': case '3': case '4': case '5':
6776 case '6': case '7': case '8': case '9': case '.':
6779 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
6782 /* read next group of digits and _ and copy into d */
6783 while (isDIGIT(*s) || *s == '_') {
6784 /* skip underscores, checking for misplaced ones
6788 dTHR; /* only for ckWARN */
6789 if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
6790 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
6794 /* check for end of fixed-length buffer */
6796 Perl_croak(aTHX_ number_too_long);
6797 /* if we're ok, copy the character */
6802 /* final misplaced underbar check */
6803 if (lastub && s - lastub != 3) {
6805 if (ckWARN(WARN_SYNTAX))
6806 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
6809 /* read a decimal portion if there is one. avoid
6810 3..5 being interpreted as the number 3. followed
6813 if (*s == '.' && s[1] != '.') {
6817 /* copy, ignoring underbars, until we run out of
6818 digits. Note: no misplaced underbar checks!
6820 for (; isDIGIT(*s) || *s == '_'; s++) {
6821 /* fixed length buffer check */
6823 Perl_croak(aTHX_ number_too_long);
6829 /* read exponent part, if present */
6830 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
6834 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
6835 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
6837 /* allow positive or negative exponent */
6838 if (*s == '+' || *s == '-')
6841 /* read digits of exponent (no underbars :-) */
6842 while (isDIGIT(*s)) {
6844 Perl_croak(aTHX_ number_too_long);
6849 /* terminate the string */
6852 /* make an sv from the string */
6855 value = Atof(PL_tokenbuf);
6858 See if we can make do with an integer value without loss of
6859 precision. We use I_V to cast to an int, because some
6860 compilers have issues. Then we try casting it back and see
6861 if it was the same. We only do this if we know we
6862 specifically read an integer.
6864 Note: if floatit is true, then we don't need to do the
6868 if (!floatit && (NV)tryiv == value)
6869 sv_setiv(sv, tryiv);
6871 sv_setnv(sv, value);
6872 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
6873 (PL_hints & HINT_NEW_INTEGER) )
6874 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
6875 (floatit ? "float" : "integer"),
6878 /* if it starts with a v, it could be a version number */
6883 while (isDIGIT(*pos))
6885 if (*pos == '.' && isDIGIT(pos[1])) {
6890 s++; /* get past 'v' */
6893 SvUPGRADE(sv, SVt_PVNV);
6894 sv_setpvn(sv, "", 0);
6899 while (isDIGIT(*pos))
6902 tmpend = uv_to_utf8(tmpbuf, rev);
6904 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
6906 SvNVX(sv) += (NV)rev/nshift;
6908 } while (*pos == '.' && isDIGIT(pos[1]));
6912 tmpend = uv_to_utf8(tmpbuf, rev);
6914 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
6916 SvNVX(sv) += (NV)rev/nshift;
6927 /* make the op for the constant and return */
6930 yylval.opval = newSVOP(OP_CONST, 0, sv);
6932 yylval.opval = Nullop;
6938 S_scan_formline(pTHX_ register char *s)
6943 SV *stuff = newSVpvn("",0);
6944 bool needargs = FALSE;
6947 if (*s == '.' || *s == '}') {
6949 #ifdef PERL_STRICT_CR
6950 for (t = s+1;*t == ' ' || *t == '\t'; t++) ;
6952 for (t = s+1;*t == ' ' || *t == '\t' || *t == '\r'; t++) ;
6954 if (*t == '\n' || t == PL_bufend)
6957 if (PL_in_eval && !PL_rsfp) {
6958 eol = strchr(s,'\n');
6963 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6965 for (t = s; t < eol; t++) {
6966 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
6968 goto enough; /* ~~ must be first line in formline */
6970 if (*t == '@' || *t == '^')
6973 sv_catpvn(stuff, s, eol-s);
6974 #ifndef PERL_STRICT_CR
6975 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
6976 char *end = SvPVX(stuff) + SvCUR(stuff);
6985 s = filter_gets(PL_linestr, PL_rsfp, 0);
6986 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
6987 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
6990 yyerror("Format not terminated");
7000 PL_lex_state = LEX_NORMAL;
7001 PL_nextval[PL_nexttoke].ival = 0;
7005 PL_lex_state = LEX_FORMLINE;
7006 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
7008 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
7012 SvREFCNT_dec(stuff);
7013 PL_lex_formbrack = 0;
7024 PL_cshlen = strlen(PL_cshname);
7029 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
7032 I32 oldsavestack_ix = PL_savestack_ix;
7033 CV* outsidecv = PL_compcv;
7037 assert(SvTYPE(PL_compcv) == SVt_PVCV);
7039 SAVEI32(PL_subline);
7040 save_item(PL_subname);
7042 SAVEVPTR(PL_curpad);
7043 SAVESPTR(PL_comppad);
7044 SAVESPTR(PL_comppad_name);
7045 SAVESPTR(PL_compcv);
7046 SAVEI32(PL_comppad_name_fill);
7047 SAVEI32(PL_min_intro_pending);
7048 SAVEI32(PL_max_intro_pending);
7049 SAVEI32(PL_pad_reset_pending);
7051 PL_compcv = (CV*)NEWSV(1104,0);
7052 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
7053 CvFLAGS(PL_compcv) |= flags;
7055 PL_comppad = newAV();
7056 av_push(PL_comppad, Nullsv);
7057 PL_curpad = AvARRAY(PL_comppad);
7058 PL_comppad_name = newAV();
7059 PL_comppad_name_fill = 0;
7060 PL_min_intro_pending = 0;
7062 PL_subline = CopLINE(PL_curcop);
7064 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
7065 PL_curpad[0] = (SV*)newAV();
7066 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
7067 #endif /* USE_THREADS */
7069 comppadlist = newAV();
7070 AvREAL_off(comppadlist);
7071 av_store(comppadlist, 0, (SV*)PL_comppad_name);
7072 av_store(comppadlist, 1, (SV*)PL_comppad);
7074 CvPADLIST(PL_compcv) = comppadlist;
7075 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
7077 CvOWNER(PL_compcv) = 0;
7078 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
7079 MUTEX_INIT(CvMUTEXP(PL_compcv));
7080 #endif /* USE_THREADS */
7082 return oldsavestack_ix;
7086 Perl_yywarn(pTHX_ char *s)
7089 PL_in_eval |= EVAL_WARNONLY;
7091 PL_in_eval &= ~EVAL_WARNONLY;
7096 Perl_yyerror(pTHX_ char *s)
7100 char *context = NULL;
7104 if (!yychar || (yychar == ';' && !PL_rsfp))
7106 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
7107 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
7108 while (isSPACE(*PL_oldoldbufptr))
7110 context = PL_oldoldbufptr;
7111 contlen = PL_bufptr - PL_oldoldbufptr;
7113 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
7114 PL_oldbufptr != PL_bufptr) {
7115 while (isSPACE(*PL_oldbufptr))
7117 context = PL_oldbufptr;
7118 contlen = PL_bufptr - PL_oldbufptr;
7120 else if (yychar > 255)
7121 where = "next token ???";
7122 else if ((yychar & 127) == 127) {
7123 if (PL_lex_state == LEX_NORMAL ||
7124 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
7125 where = "at end of line";
7126 else if (PL_lex_inpat)
7127 where = "within pattern";
7129 where = "within string";
7132 SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
7134 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
7135 else if (isPRINT_LC(yychar))
7136 Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
7138 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
7139 where = SvPVX(where_sv);
7141 msg = sv_2mortal(newSVpv(s, 0));
7142 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
7143 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
7145 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
7147 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
7148 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
7149 Perl_sv_catpvf(aTHX_ msg,
7150 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
7151 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
7154 if (PL_in_eval & EVAL_WARNONLY)
7155 Perl_warn(aTHX_ "%"SVf, msg);
7158 if (PL_error_count >= 10)
7159 Perl_croak(aTHX_ "%s has too many errors.\n", CopFILE(PL_curcop));
7161 PL_in_my_stash = Nullhv;
7172 * Restore a source filter.
7176 restore_rsfp(pTHXo_ void *f)
7178 PerlIO *fp = (PerlIO*)f;
7180 if (PL_rsfp == PerlIO_stdin())
7181 PerlIO_clearerr(PL_rsfp);
7182 else if (PL_rsfp && (PL_rsfp != fp))
7183 PerlIO_close(PL_rsfp);