3 * Copyright (c) 1991-2002, 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(pTHX_ void *f);
31 #ifndef PERL_NO_UTF16_FILTER
32 static I32 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen);
33 static I32 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen);
36 #define XFAKEBRACK 128
39 #ifdef USE_UTF8_SCRIPTS
40 # define UTF (!IN_BYTES)
42 # ifdef EBCDIC /* For now 'use utf8' does not affect tokenizer on EBCDIC */
43 # define UTF (PL_linestr && DO_UTF8(PL_linestr))
45 # define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || (PL_hints & HINT_UTF8))
49 /* In variables named $^X, these are the legal values for X.
50 * 1999-02-27 mjd-perl-patch@plover.com */
51 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
53 /* On MacOS, respect nonbreaking spaces */
54 #ifdef MACOS_TRADITIONAL
55 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\312'||(c)=='\t')
57 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\t')
60 /* LEX_* are values for PL_lex_state, the state of the lexer.
61 * They are arranged oddly so that the guard on the switch statement
62 * can get by with a single comparison (if the compiler is smart enough).
65 /* #define LEX_NOTPARSING 11 is done in perl.h. */
68 #define LEX_INTERPNORMAL 9
69 #define LEX_INTERPCASEMOD 8
70 #define LEX_INTERPPUSH 7
71 #define LEX_INTERPSTART 6
72 #define LEX_INTERPEND 5
73 #define LEX_INTERPENDMAYBE 4
74 #define LEX_INTERPCONCAT 3
75 #define LEX_INTERPCONST 2
76 #define LEX_FORMLINE 1
77 #define LEX_KNOWNEXT 0
85 # define YYMAXLEVEL 100
87 YYSTYPE* yylval_pointer[YYMAXLEVEL];
88 int* yychar_pointer[YYMAXLEVEL];
92 # define yylval (*yylval_pointer[yyactlevel])
93 # define yychar (*yychar_pointer[yyactlevel])
94 # define PERL_YYLEX_PARAM yylval_pointer[yyactlevel],yychar_pointer[yyactlevel]
96 # define yylex() Perl_yylex_r(aTHX_ yylval_pointer[yyactlevel],yychar_pointer[yyactlevel])
101 /* CLINE is a macro that ensures PL_copline has a sane value */
106 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
109 * Convenience functions to return different tokens and prime the
110 * lexer for the next token. They all take an argument.
112 * TOKEN : generic token (used for '(', DOLSHARP, etc)
113 * OPERATOR : generic operator
114 * AOPERATOR : assignment operator
115 * PREBLOCK : beginning the block after an if, while, foreach, ...
116 * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
117 * PREREF : *EXPR where EXPR is not a simple identifier
118 * TERM : expression term
119 * LOOPX : loop exiting command (goto, last, dump, etc)
120 * FTST : file test operator
121 * FUN0 : zero-argument function
122 * FUN1 : not used, except for not, which isn't a UNIOP
123 * BOop : bitwise or or xor
125 * SHop : shift operator
126 * PWop : power operator
127 * PMop : pattern-matching operator
128 * Aop : addition-level operator
129 * Mop : multiplication-level operator
130 * Eop : equality-testing operator
131 * Rop : relational operator <= != gt
133 * Also see LOP and lop() below.
136 /* Note that REPORT() and REPORT2() will be expressions that supply
137 * their own trailing comma, not suitable for statements as such. */
138 #ifdef DEBUGGING /* Serve -DT. */
139 # define REPORT(x,retval) tokereport(x,s,(int)retval),
140 # define REPORT2(x,retval) tokereport(x,s, yylval.ival),
142 # define REPORT(x,retval)
143 # define REPORT2(x,retval)
146 #define TOKEN(retval) return (REPORT2("token",retval) PL_bufptr = s,(int)retval)
147 #define OPERATOR(retval) return (REPORT2("operator",retval) PL_expect = XTERM, PL_bufptr = s,(int)retval)
148 #define AOPERATOR(retval) return ao((REPORT2("aop",retval) PL_expect = XTERM, PL_bufptr = s,(int)retval))
149 #define PREBLOCK(retval) return (REPORT2("preblock",retval) PL_expect = XBLOCK,PL_bufptr = s,(int)retval)
150 #define PRETERMBLOCK(retval) return (REPORT2("pretermblock",retval) PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval)
151 #define PREREF(retval) return (REPORT2("preref",retval) PL_expect = XREF,PL_bufptr = s,(int)retval)
152 #define TERM(retval) return (CLINE, REPORT2("term",retval) PL_expect = XOPERATOR, PL_bufptr = s,(int)retval)
153 #define LOOPX(f) return(yylval.ival=f, REPORT("loopx",f) PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX)
154 #define FTST(f) return(yylval.ival=f, REPORT("ftst",f) PL_expect = XTERM,PL_bufptr = s,(int)UNIOP)
155 #define FUN0(f) return(yylval.ival = f, REPORT("fun0",f) PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0)
156 #define FUN1(f) return(yylval.ival = f, REPORT("fun1",f) PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1)
157 #define BOop(f) return ao((yylval.ival=f, REPORT("bitorop",f) PL_expect = XTERM,PL_bufptr = s,(int)BITOROP))
158 #define BAop(f) return ao((yylval.ival=f, REPORT("bitandop",f) PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP))
159 #define SHop(f) return ao((yylval.ival=f, REPORT("shiftop",f) PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP))
160 #define PWop(f) return ao((yylval.ival=f, REPORT("powop",f) PL_expect = XTERM,PL_bufptr = s,(int)POWOP))
161 #define PMop(f) return(yylval.ival=f, REPORT("matchop",f) PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP)
162 #define Aop(f) return ao((yylval.ival=f, REPORT("add",f) PL_expect = XTERM,PL_bufptr = s,(int)ADDOP))
163 #define Mop(f) return ao((yylval.ival=f, REPORT("mul",f) PL_expect = XTERM,PL_bufptr = s,(int)MULOP))
164 #define Eop(f) return(yylval.ival=f, REPORT("eq",f) PL_expect = XTERM,PL_bufptr = s,(int)EQOP)
165 #define Rop(f) return(yylval.ival=f, REPORT("rel",f) PL_expect = XTERM,PL_bufptr = s,(int)RELOP)
167 /* This bit of chicanery makes a unary function followed by
168 * a parenthesis into a function with one argument, highest precedence.
170 #define UNI(f) return(yylval.ival = f, \
174 PL_last_uni = PL_oldbufptr, \
175 PL_last_lop_op = f, \
176 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
178 #define UNIBRACK(f) return(yylval.ival = f, \
181 PL_last_uni = PL_oldbufptr, \
182 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
184 /* grandfather return to old style */
185 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
190 S_tokereport(pTHX_ char *thing, char* s, I32 rv)
193 SV* report = newSVpv(thing, 0);
194 Perl_sv_catpvf(aTHX_ report, ":line %d:%"IVdf":", CopLINE(PL_curcop),
197 if (s - PL_bufptr > 0)
198 sv_catpvn(report, PL_bufptr, s - PL_bufptr);
200 if (PL_oldbufptr && *PL_oldbufptr)
201 sv_catpv(report, PL_tokenbuf);
203 PerlIO_printf(Perl_debug_log, "### %s\n", SvPV_nolen(report));
212 * This subroutine detects &&= and ||= and turns an ANDAND or OROR
213 * into an OP_ANDASSIGN or OP_ORASSIGN
217 S_ao(pTHX_ int toketype)
219 if (*PL_bufptr == '=') {
221 if (toketype == ANDAND)
222 yylval.ival = OP_ANDASSIGN;
223 else if (toketype == OROR)
224 yylval.ival = OP_ORASSIGN;
232 * When Perl expects an operator and finds something else, no_op
233 * prints the warning. It always prints "<something> found where
234 * operator expected. It prints "Missing semicolon on previous line?"
235 * if the surprise occurs at the start of the line. "do you need to
236 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
237 * where the compiler doesn't know if foo is a method call or a function.
238 * It prints "Missing operator before end of line" if there's nothing
239 * after the missing operator, or "... before <...>" if there is something
240 * after the missing operator.
244 S_no_op(pTHX_ char *what, char *s)
246 char *oldbp = PL_bufptr;
247 bool is_first = (PL_oldbufptr == PL_linestart);
253 yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
255 Perl_warn(aTHX_ "\t(Missing semicolon on previous line?)\n");
256 else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
258 for (t = PL_oldoldbufptr; *t && (isALNUM_lazy_if(t,UTF) || *t == ':'); t++) ;
259 if (t < PL_bufptr && isSPACE(*t))
260 Perl_warn(aTHX_ "\t(Do you need to predeclare %.*s?)\n",
261 t - PL_oldoldbufptr, PL_oldoldbufptr);
265 Perl_warn(aTHX_ "\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
272 * Complain about missing quote/regexp/heredoc terminator.
273 * If it's called with (char *)NULL then it cauterizes the line buffer.
274 * If we're in a delimited string and the delimiter is a control
275 * character, it's reformatted into a two-char sequence like ^C.
280 S_missingterm(pTHX_ char *s)
285 char *nl = strrchr(s,'\n');
291 iscntrl(PL_multi_close)
293 PL_multi_close < 32 || PL_multi_close == 127
297 tmpbuf[1] = toCTRL(PL_multi_close);
303 *tmpbuf = PL_multi_close;
307 q = strchr(s,'"') ? '\'' : '"';
308 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
316 Perl_deprecate(pTHX_ char *s)
318 if (ckWARN(WARN_DEPRECATED))
319 Perl_warner(aTHX_ WARN_DEPRECATED, "Use of %s is deprecated", s);
324 * Deprecate a comma-less variable list.
330 deprecate("comma-less variable list");
334 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
335 * utf16-to-utf8-reversed.
338 #ifdef PERL_CR_FILTER
342 register char *s = SvPVX(sv);
343 register char *e = s + SvCUR(sv);
344 /* outer loop optimized to do nothing if there are no CR-LFs */
346 if (*s++ == '\r' && *s == '\n') {
347 /* hit a CR-LF, need to copy the rest */
348 register char *d = s - 1;
351 if (*s == '\r' && s[1] == '\n')
362 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
364 I32 count = FILTER_READ(idx+1, sv, maxlen);
365 if (count > 0 && !maxlen)
373 * Initialize variables. Uses the Perl save_stack to save its state (for
374 * recursive calls to the parser).
378 Perl_lex_start(pTHX_ SV *line)
383 SAVEI32(PL_lex_dojoin);
384 SAVEI32(PL_lex_brackets);
385 SAVEI32(PL_lex_casemods);
386 SAVEI32(PL_lex_starts);
387 SAVEI32(PL_lex_state);
388 SAVEVPTR(PL_lex_inpat);
389 SAVEI32(PL_lex_inwhat);
390 if (PL_lex_state == LEX_KNOWNEXT) {
391 I32 toke = PL_nexttoke;
392 while (--toke >= 0) {
393 SAVEI32(PL_nexttype[toke]);
394 SAVEVPTR(PL_nextval[toke]);
396 SAVEI32(PL_nexttoke);
398 SAVECOPLINE(PL_curcop);
401 SAVEPPTR(PL_oldbufptr);
402 SAVEPPTR(PL_oldoldbufptr);
403 SAVEPPTR(PL_last_lop);
404 SAVEPPTR(PL_last_uni);
405 SAVEPPTR(PL_linestart);
406 SAVESPTR(PL_linestr);
407 SAVEPPTR(PL_lex_brackstack);
408 SAVEPPTR(PL_lex_casestack);
409 SAVEDESTRUCTOR_X(restore_rsfp, PL_rsfp);
410 SAVESPTR(PL_lex_stuff);
411 SAVEI32(PL_lex_defer);
412 SAVEI32(PL_sublex_info.sub_inwhat);
413 SAVESPTR(PL_lex_repl);
415 SAVEINT(PL_lex_expect);
417 PL_lex_state = LEX_NORMAL;
421 New(899, PL_lex_brackstack, 120, char);
422 New(899, PL_lex_casestack, 12, char);
423 SAVEFREEPV(PL_lex_brackstack);
424 SAVEFREEPV(PL_lex_casestack);
426 *PL_lex_casestack = '\0';
429 PL_lex_stuff = Nullsv;
430 PL_lex_repl = Nullsv;
434 PL_sublex_info.sub_inwhat = 0;
436 if (SvREADONLY(PL_linestr))
437 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
438 s = SvPV(PL_linestr, len);
439 if (len && s[len-1] != ';') {
440 if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
441 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
442 sv_catpvn(PL_linestr, "\n;", 2);
444 SvTEMP_off(PL_linestr);
445 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
446 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
447 PL_last_lop = PL_last_uni = Nullch;
453 * Finalizer for lexing operations. Must be called when the parser is
454 * done with the lexer.
460 PL_doextract = FALSE;
465 * This subroutine has nothing to do with tilting, whether at windmills
466 * or pinball tables. Its name is short for "increment line". It
467 * increments the current line number in CopLINE(PL_curcop) and checks
468 * to see whether the line starts with a comment of the form
469 * # line 500 "foo.pm"
470 * If so, it sets the current line number and file to the values in the comment.
474 S_incline(pTHX_ char *s)
481 CopLINE_inc(PL_curcop);
484 while (SPACE_OR_TAB(*s)) s++;
485 if (strnEQ(s, "line", 4))
489 if (SPACE_OR_TAB(*s))
493 while (SPACE_OR_TAB(*s)) s++;
499 while (SPACE_OR_TAB(*s))
501 if (*s == '"' && (t = strchr(s+1, '"'))) {
506 for (t = s; !isSPACE(*t); t++) ;
509 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
511 if (*e != '\n' && *e != '\0')
512 return; /* false alarm */
517 CopFILE_free(PL_curcop);
518 CopFILE_set(PL_curcop, s);
521 CopLINE_set(PL_curcop, atoi(n)-1);
526 * Called to gobble the appropriate amount and type of whitespace.
527 * Skips comments as well.
531 S_skipspace(pTHX_ register char *s)
533 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
534 while (s < PL_bufend && SPACE_OR_TAB(*s))
540 SSize_t oldprevlen, oldoldprevlen;
541 SSize_t oldloplen = 0, oldunilen = 0;
542 while (s < PL_bufend && isSPACE(*s)) {
543 if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
548 if (s < PL_bufend && *s == '#') {
549 while (s < PL_bufend && *s != '\n')
553 if (PL_in_eval && !PL_rsfp) {
560 /* only continue to recharge the buffer if we're at the end
561 * of the buffer, we're not reading from a source filter, and
562 * we're in normal lexing mode
564 if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat ||
565 PL_lex_state == LEX_FORMLINE)
568 /* try to recharge the buffer */
569 if ((s = filter_gets(PL_linestr, PL_rsfp,
570 (prevlen = SvCUR(PL_linestr)))) == Nullch)
572 /* end of file. Add on the -p or -n magic */
573 if (PL_minus_n || PL_minus_p) {
574 sv_setpv(PL_linestr,PL_minus_p ?
575 ";}continue{print or die qq(-p destination: $!\\n)" :
577 sv_catpv(PL_linestr,";}");
578 PL_minus_n = PL_minus_p = 0;
581 sv_setpv(PL_linestr,";");
583 /* reset variables for next time we lex */
584 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
586 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
587 PL_last_lop = PL_last_uni = Nullch;
589 /* Close the filehandle. Could be from -P preprocessor,
590 * STDIN, or a regular file. If we were reading code from
591 * STDIN (because the commandline held no -e or filename)
592 * then we don't close it, we reset it so the code can
593 * read from STDIN too.
596 if (PL_preprocess && !PL_in_eval)
597 (void)PerlProc_pclose(PL_rsfp);
598 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
599 PerlIO_clearerr(PL_rsfp);
601 (void)PerlIO_close(PL_rsfp);
606 /* not at end of file, so we only read another line */
607 /* make corresponding updates to old pointers, for yyerror() */
608 oldprevlen = PL_oldbufptr - PL_bufend;
609 oldoldprevlen = PL_oldoldbufptr - PL_bufend;
611 oldunilen = PL_last_uni - PL_bufend;
613 oldloplen = PL_last_lop - PL_bufend;
614 PL_linestart = PL_bufptr = s + prevlen;
615 PL_bufend = s + SvCUR(PL_linestr);
617 PL_oldbufptr = s + oldprevlen;
618 PL_oldoldbufptr = s + oldoldprevlen;
620 PL_last_uni = s + oldunilen;
622 PL_last_lop = s + oldloplen;
625 /* debugger active and we're not compiling the debugger code,
626 * so store the line into the debugger's array of lines
628 if (PERLDB_LINE && PL_curstash != PL_debstash) {
629 SV *sv = NEWSV(85,0);
631 sv_upgrade(sv, SVt_PVMG);
632 sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
635 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
642 * Check the unary operators to ensure there's no ambiguity in how they're
643 * used. An ambiguous piece of code would be:
645 * This doesn't mean rand() + 5. Because rand() is a unary operator,
646 * the +5 is its argument.
655 if (PL_oldoldbufptr != PL_last_uni)
657 while (isSPACE(*PL_last_uni))
659 for (s = PL_last_uni; isALNUM_lazy_if(s,UTF) || *s == '-'; s++) ;
660 if ((t = strchr(s, '(')) && t < PL_bufptr)
662 if (ckWARN_d(WARN_AMBIGUOUS)){
665 Perl_warner(aTHX_ WARN_AMBIGUOUS,
666 "Warning: Use of \"%s\" without parens is ambiguous",
672 /* workaround to replace the UNI() macro with a function. Only the
673 * hints/uts.sh file mentions this. Other comments elsewhere in the
674 * source indicate Microport Unix might need it too.
680 #define UNI(f) return uni(f,s)
683 S_uni(pTHX_ I32 f, char *s)
688 PL_last_uni = PL_oldbufptr;
699 #endif /* CRIPPLED_CC */
702 * LOP : macro to build a list operator. Its behaviour has been replaced
703 * with a subroutine, S_lop() for which LOP is just another name.
706 #define LOP(f,x) return lop(f,x,s)
710 * Build a list operator (or something that might be one). The rules:
711 * - if we have a next token, then it's a list operator [why?]
712 * - if the next thing is an opening paren, then it's a function
713 * - else it's a list operator
717 S_lop(pTHX_ I32 f, int x, char *s)
724 PL_last_lop = PL_oldbufptr;
739 * When the lexer realizes it knows the next token (for instance,
740 * it is reordering tokens for the parser) then it can call S_force_next
741 * to know what token to return the next time the lexer is called. Caller
742 * will need to set PL_nextval[], and possibly PL_expect to ensure the lexer
743 * handles the token correctly.
747 S_force_next(pTHX_ I32 type)
749 PL_nexttype[PL_nexttoke] = type;
751 if (PL_lex_state != LEX_KNOWNEXT) {
752 PL_lex_defer = PL_lex_state;
753 PL_lex_expect = PL_expect;
754 PL_lex_state = LEX_KNOWNEXT;
760 * When the lexer knows the next thing is a word (for instance, it has
761 * just seen -> and it knows that the next char is a word char, then
762 * it calls S_force_word to stick the next word into the PL_next lookahead.
765 * char *start : buffer position (must be within PL_linestr)
766 * int token : PL_next will be this type of bare word (e.g., METHOD,WORD)
767 * int check_keyword : if true, Perl checks to make sure the word isn't
768 * a keyword (do this if the word is a label, e.g. goto FOO)
769 * int allow_pack : if true, : characters will also be allowed (require,
771 * int allow_initial_tick : used by the "sub" lexer only.
775 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
780 start = skipspace(start);
782 if (isIDFIRST_lazy_if(s,UTF) ||
783 (allow_pack && *s == ':') ||
784 (allow_initial_tick && *s == '\'') )
786 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
787 if (check_keyword && keyword(PL_tokenbuf, len))
789 if (token == METHOD) {
794 PL_expect = XOPERATOR;
797 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(PL_tokenbuf,0));
798 PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
806 * Called when the lexer wants $foo *foo &foo etc, but the program
807 * text only contains the "foo" portion. The first argument is a pointer
808 * to the "foo", and the second argument is the type symbol to prefix.
809 * Forces the next token to be a "WORD".
810 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
814 S_force_ident(pTHX_ register char *s, int kind)
817 OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
818 PL_nextval[PL_nexttoke].opval = o;
821 o->op_private = OPpCONST_ENTERED;
822 /* XXX see note in pp_entereval() for why we forgo typo
823 warnings if the symbol must be introduced in an eval.
825 gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
826 kind == '$' ? SVt_PV :
827 kind == '@' ? SVt_PVAV :
828 kind == '%' ? SVt_PVHV :
836 Perl_str_to_version(pTHX_ SV *sv)
841 char *start = SvPVx(sv,len);
842 bool utf = SvUTF8(sv) ? TRUE : FALSE;
843 char *end = start + len;
844 while (start < end) {
848 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
853 retval += ((NV)n)/nshift;
862 * Forces the next token to be a version number.
863 * If the next token appears to be an invalid version number, (e.g. "v2b"),
864 * and if "guessing" is TRUE, then no new token is created (and the caller
865 * must use an alternative parsing method).
869 S_force_version(pTHX_ char *s, int guessing)
871 OP *version = Nullop;
880 while (isDIGIT(*d) || *d == '_' || *d == '.')
882 if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
884 s = scan_num(s, &yylval);
885 version = yylval.opval;
886 ver = cSVOPx(version)->op_sv;
887 if (SvPOK(ver) && !SvNIOK(ver)) {
888 (void)SvUPGRADE(ver, SVt_PVNV);
889 SvNVX(ver) = str_to_version(ver);
890 SvNOK_on(ver); /* hint that it is a version */
897 /* NOTE: The parser sees the package name and the VERSION swapped */
898 PL_nextval[PL_nexttoke].opval = version;
906 * Tokenize a quoted string passed in as an SV. It finds the next
907 * chunk, up to end of string or a backslash. It may make a new
908 * SV containing that chunk (if HINT_NEW_STRING is on). It also
913 S_tokeq(pTHX_ SV *sv)
924 s = SvPV_force(sv, len);
925 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
928 while (s < send && *s != '\\')
933 if ( PL_hints & HINT_NEW_STRING ) {
934 pv = sv_2mortal(newSVpvn(SvPVX(pv), len));
940 if (s + 1 < send && (s[1] == '\\'))
941 s++; /* all that, just for this */
946 SvCUR_set(sv, d - SvPVX(sv));
948 if ( PL_hints & HINT_NEW_STRING )
949 return new_constant(NULL, 0, "q", sv, pv, "q");
954 * Now come three functions related to double-quote context,
955 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
956 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
957 * interact with PL_lex_state, and create fake ( ... ) argument lists
958 * to handle functions and concatenation.
959 * They assume that whoever calls them will be setting up a fake
960 * join call, because each subthing puts a ',' after it. This lets
963 * join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
965 * (I'm not sure whether the spurious commas at the end of lcfirst's
966 * arguments and join's arguments are created or not).
971 * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST).
973 * Pattern matching will set PL_lex_op to the pattern-matching op to
974 * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise).
976 * OP_CONST and OP_READLINE are easy--just make the new op and return.
978 * Everything else becomes a FUNC.
980 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
981 * had an OP_CONST or OP_READLINE). This just sets us up for a
982 * call to S_sublex_push().
988 register I32 op_type = yylval.ival;
990 if (op_type == OP_NULL) {
991 yylval.opval = PL_lex_op;
995 if (op_type == OP_CONST || op_type == OP_READLINE) {
996 SV *sv = tokeq(PL_lex_stuff);
998 if (SvTYPE(sv) == SVt_PVIV) {
999 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
1005 nsv = newSVpvn(p, len);
1011 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
1012 PL_lex_stuff = Nullsv;
1016 PL_sublex_info.super_state = PL_lex_state;
1017 PL_sublex_info.sub_inwhat = op_type;
1018 PL_sublex_info.sub_op = PL_lex_op;
1019 PL_lex_state = LEX_INTERPPUSH;
1023 yylval.opval = PL_lex_op;
1033 * Create a new scope to save the lexing state. The scope will be
1034 * ended in S_sublex_done. Returns a '(', starting the function arguments
1035 * to the uc, lc, etc. found before.
1036 * Sets PL_lex_state to LEX_INTERPCONCAT.
1044 PL_lex_state = PL_sublex_info.super_state;
1045 SAVEI32(PL_lex_dojoin);
1046 SAVEI32(PL_lex_brackets);
1047 SAVEI32(PL_lex_casemods);
1048 SAVEI32(PL_lex_starts);
1049 SAVEI32(PL_lex_state);
1050 SAVEVPTR(PL_lex_inpat);
1051 SAVEI32(PL_lex_inwhat);
1052 SAVECOPLINE(PL_curcop);
1053 SAVEPPTR(PL_bufptr);
1054 SAVEPPTR(PL_bufend);
1055 SAVEPPTR(PL_oldbufptr);
1056 SAVEPPTR(PL_oldoldbufptr);
1057 SAVEPPTR(PL_last_lop);
1058 SAVEPPTR(PL_last_uni);
1059 SAVEPPTR(PL_linestart);
1060 SAVESPTR(PL_linestr);
1061 SAVEPPTR(PL_lex_brackstack);
1062 SAVEPPTR(PL_lex_casestack);
1064 PL_linestr = PL_lex_stuff;
1065 PL_lex_stuff = Nullsv;
1067 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
1068 = SvPVX(PL_linestr);
1069 PL_bufend += SvCUR(PL_linestr);
1070 PL_last_lop = PL_last_uni = Nullch;
1071 SAVEFREESV(PL_linestr);
1073 PL_lex_dojoin = FALSE;
1074 PL_lex_brackets = 0;
1075 New(899, PL_lex_brackstack, 120, char);
1076 New(899, PL_lex_casestack, 12, char);
1077 SAVEFREEPV(PL_lex_brackstack);
1078 SAVEFREEPV(PL_lex_casestack);
1079 PL_lex_casemods = 0;
1080 *PL_lex_casestack = '\0';
1082 PL_lex_state = LEX_INTERPCONCAT;
1083 CopLINE_set(PL_curcop, PL_multi_start);
1085 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1086 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1087 PL_lex_inpat = PL_sublex_info.sub_op;
1089 PL_lex_inpat = Nullop;
1096 * Restores lexer state after a S_sublex_push.
1102 if (!PL_lex_starts++) {
1103 SV *sv = newSVpvn("",0);
1104 if (SvUTF8(PL_linestr))
1106 PL_expect = XOPERATOR;
1107 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1111 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
1112 PL_lex_state = LEX_INTERPCASEMOD;
1116 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1117 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1118 PL_linestr = PL_lex_repl;
1120 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1121 PL_bufend += SvCUR(PL_linestr);
1122 PL_last_lop = PL_last_uni = Nullch;
1123 SAVEFREESV(PL_linestr);
1124 PL_lex_dojoin = FALSE;
1125 PL_lex_brackets = 0;
1126 PL_lex_casemods = 0;
1127 *PL_lex_casestack = '\0';
1129 if (SvEVALED(PL_lex_repl)) {
1130 PL_lex_state = LEX_INTERPNORMAL;
1132 /* we don't clear PL_lex_repl here, so that we can check later
1133 whether this is an evalled subst; that means we rely on the
1134 logic to ensure sublex_done() is called again only via the
1135 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1138 PL_lex_state = LEX_INTERPCONCAT;
1139 PL_lex_repl = Nullsv;
1145 PL_bufend = SvPVX(PL_linestr);
1146 PL_bufend += SvCUR(PL_linestr);
1147 PL_expect = XOPERATOR;
1148 PL_sublex_info.sub_inwhat = 0;
1156 Extracts a pattern, double-quoted string, or transliteration. This
1159 It looks at lex_inwhat and PL_lex_inpat to find out whether it's
1160 processing a pattern (PL_lex_inpat is true), a transliteration
1161 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
1163 Returns a pointer to the character scanned up to. Iff this is
1164 advanced from the start pointer supplied (ie if anything was
1165 successfully parsed), will leave an OP for the substring scanned
1166 in yylval. Caller must intuit reason for not parsing further
1167 by looking at the next characters herself.
1171 double-quoted style: \r and \n
1172 regexp special ones: \D \s
1174 backrefs: \1 (deprecated in substitution replacements)
1175 case and quoting: \U \Q \E
1176 stops on @ and $, but not for $ as tail anchor
1178 In transliterations:
1179 characters are VERY literal, except for - not at the start or end
1180 of the string, which indicates a range. scan_const expands the
1181 range to the full set of intermediate characters.
1183 In double-quoted strings:
1185 double-quoted style: \r and \n
1187 backrefs: \1 (deprecated)
1188 case and quoting: \U \Q \E
1191 scan_const does *not* construct ops to handle interpolated strings.
1192 It stops processing as soon as it finds an embedded $ or @ variable
1193 and leaves it to the caller to work out what's going on.
1195 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
1197 $ in pattern could be $foo or could be tail anchor. Assumption:
1198 it's a tail anchor if $ is the last thing in the string, or if it's
1199 followed by one of ")| \n\t"
1201 \1 (backreferences) are turned into $1
1203 The structure of the code is
1204 while (there's a character to process) {
1205 handle transliteration ranges
1206 skip regexp comments
1207 skip # initiated comments in //x patterns
1208 check for embedded @foo
1209 check for embedded scalars
1211 leave intact backslashes from leave (below)
1212 deprecate \1 in strings and sub replacements
1213 handle string-changing backslashes \l \U \Q \E, etc.
1214 switch (what was escaped) {
1215 handle - in a transliteration (becomes a literal -)
1216 handle \132 octal characters
1217 handle 0x15 hex characters
1218 handle \cV (control V)
1219 handle printf backslashes (\f, \r, \n, etc)
1221 } (end if backslash)
1222 } (end while character to read)
1227 S_scan_const(pTHX_ char *start)
1229 register char *send = PL_bufend; /* end of the constant */
1230 SV *sv = NEWSV(93, send - start); /* sv for the constant */
1231 register char *s = start; /* start of the constant */
1232 register char *d = SvPVX(sv); /* destination for copies */
1233 bool dorange = FALSE; /* are we in a translit range? */
1234 bool didrange = FALSE; /* did we just finish a range? */
1235 I32 has_utf8 = FALSE; /* Output constant is UTF8 */
1236 I32 this_utf8 = UTF; /* The source string is assumed to be UTF8 */
1239 const char *leaveit = /* set of acceptably-backslashed characters */
1241 ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
1244 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1245 /* If we are doing a trans and we know we want UTF8 set expectation */
1246 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
1247 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1251 while (s < send || dorange) {
1252 /* get transliterations out of the way (they're most literal) */
1253 if (PL_lex_inwhat == OP_TRANS) {
1254 /* expand a range A-Z to the full set of characters. AIE! */
1256 I32 i; /* current expanded character */
1257 I32 min; /* first character in range */
1258 I32 max; /* last character in range */
1261 char *c = (char*)utf8_hop((U8*)d, -1);
1265 *c = (char)UTF_TO_NATIVE(0xff);
1266 /* mark the range as done, and continue */
1272 i = d - SvPVX(sv); /* remember current offset */
1273 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
1274 d = SvPVX(sv) + i; /* refresh d after realloc */
1275 d -= 2; /* eat the first char and the - */
1277 min = (U8)*d; /* first char in range */
1278 max = (U8)d[1]; /* last char in range */
1282 "Invalid [] range \"%c-%c\" in transliteration operator",
1283 (char)min, (char)max);
1287 if ((isLOWER(min) && isLOWER(max)) ||
1288 (isUPPER(min) && isUPPER(max))) {
1290 for (i = min; i <= max; i++)
1292 *d++ = NATIVE_TO_NEED(has_utf8,i);
1294 for (i = min; i <= max; i++)
1296 *d++ = NATIVE_TO_NEED(has_utf8,i);
1301 for (i = min; i <= max; i++)
1304 /* mark the range as done, and continue */
1310 /* range begins (ignore - as first or last char) */
1311 else if (*s == '-' && s+1 < send && s != start) {
1313 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
1316 *d++ = (char)UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */
1328 /* if we get here, we're not doing a transliteration */
1330 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
1331 except for the last char, which will be done separately. */
1332 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
1334 while (s < send && *s != ')')
1335 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1337 else if (s[2] == '{' /* This should match regcomp.c */
1338 || ((s[2] == 'p' || s[2] == '?') && s[3] == '{'))
1341 char *regparse = s + (s[2] == '{' ? 3 : 4);
1344 while (count && (c = *regparse)) {
1345 if (c == '\\' && regparse[1])
1353 if (*regparse != ')') {
1354 regparse--; /* Leave one char for continuation. */
1355 yyerror("Sequence (?{...}) not terminated or not {}-balanced");
1357 while (s < regparse)
1358 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1362 /* likewise skip #-initiated comments in //x patterns */
1363 else if (*s == '#' && PL_lex_inpat &&
1364 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
1365 while (s+1 < send && *s != '\n')
1366 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1369 /* check for embedded arrays
1370 (@foo, @:foo, @'foo, @{foo}, @$foo, @+, @-)
1372 else if (*s == '@' && s[1]
1373 && (isALNUM_lazy_if(s+1,UTF) || strchr(":'{$+-", s[1])))
1376 /* check for embedded scalars. only stop if we're sure it's a
1379 else if (*s == '$') {
1380 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
1382 if (s + 1 < send && !strchr("()| \r\n\t", s[1]))
1383 break; /* in regexp, $ might be tail anchor */
1386 /* End of else if chain - OP_TRANS rejoin rest */
1389 if (*s == '\\' && s+1 < send) {
1392 /* some backslashes we leave behind */
1393 if (*leaveit && *s && strchr(leaveit, *s)) {
1394 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
1395 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1399 /* deprecate \1 in strings and substitution replacements */
1400 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1401 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1403 if (ckWARN(WARN_SYNTAX))
1404 Perl_warner(aTHX_ WARN_SYNTAX, "\\%c better written as $%c", *s, *s);
1409 /* string-change backslash escapes */
1410 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1415 /* if we get here, it's either a quoted -, or a digit */
1418 /* quoted - in transliterations */
1420 if (PL_lex_inwhat == OP_TRANS) {
1427 if (ckWARN(WARN_MISC) &&
1430 Perl_warner(aTHX_ WARN_MISC,
1431 "Unrecognized escape \\%c passed through",
1433 /* default action is to copy the quoted character */
1434 goto default_action;
1437 /* \132 indicates an octal constant */
1438 case '0': case '1': case '2': case '3':
1439 case '4': case '5': case '6': case '7':
1443 uv = grok_oct(s, &len, &flags, NULL);
1446 goto NUM_ESCAPE_INSERT;
1448 /* \x24 indicates a hex constant */
1452 char* e = strchr(s, '}');
1453 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
1454 PERL_SCAN_DISALLOW_PREFIX;
1459 yyerror("Missing right brace on \\x{}");
1463 uv = grok_hex(s, &len, &flags, NULL);
1469 I32 flags = PERL_SCAN_DISALLOW_PREFIX;
1470 uv = grok_hex(s, &len, &flags, NULL);
1476 /* Insert oct or hex escaped character.
1477 * There will always enough room in sv since such
1478 * escapes will be longer than any UTF-8 sequence
1479 * they can end up as. */
1481 /* We need to map to chars to ASCII before doing the tests
1484 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(uv))) {
1485 if (!has_utf8 && uv > 255) {
1486 /* Might need to recode whatever we have
1487 * accumulated so far if it contains any
1490 * (Can't we keep track of that and avoid
1491 * this rescan? --jhi)
1495 for (c = (U8 *) SvPVX(sv); c < (U8 *)d; c++) {
1496 if (!NATIVE_IS_INVARIANT(*c)) {
1501 STRLEN offset = d - SvPVX(sv);
1503 d = SvGROW(sv, SvLEN(sv) + hicount + 1) + offset;
1507 while (src >= (U8 *)SvPVX(sv)) {
1508 if (!NATIVE_IS_INVARIANT(*src)) {
1509 U8 ch = NATIVE_TO_ASCII(*src);
1510 *dst-- = UTF8_EIGHT_BIT_LO(ch);
1511 *dst-- = UTF8_EIGHT_BIT_HI(ch);
1521 if (has_utf8 || uv > 255) {
1522 d = (char*)uvchr_to_utf8((U8*)d, uv);
1524 if (PL_lex_inwhat == OP_TRANS &&
1525 PL_sublex_info.sub_op) {
1526 PL_sublex_info.sub_op->op_private |=
1527 (PL_lex_repl ? OPpTRANS_FROM_UTF
1540 /* \N{LATIN SMALL LETTER A} is a named character */
1544 char* e = strchr(s, '}');
1550 yyerror("Missing right brace on \\N{}");
1554 res = newSVpvn(s + 1, e - s - 1);
1555 res = new_constant( Nullch, 0, "charnames",
1556 res, Nullsv, "\\N{...}" );
1558 sv_utf8_upgrade(res);
1559 str = SvPV(res,len);
1562 UV uv = utf8_to_uvchr((U8*)str, 0);
1565 U8 tmpbuf[UTF8_MAXLEN+1], *d;
1567 d = uvchr_to_utf8(tmpbuf, UNI_TO_NATIVE(uv));
1568 sv_setpvn(res, (char *)tmpbuf, d - tmpbuf);
1569 str = SvPV(res, len);
1573 if (!has_utf8 && SvUTF8(res)) {
1574 char *ostart = SvPVX(sv);
1575 SvCUR_set(sv, d - ostart);
1578 sv_utf8_upgrade(sv);
1579 /* this just broke our allocation above... */
1580 SvGROW(sv, send - start);
1581 d = SvPVX(sv) + SvCUR(sv);
1584 if (len > e - s + 4) { /* I _guess_ 4 is \N{} --jhi */
1585 char *odest = SvPVX(sv);
1587 SvGROW(sv, (SvLEN(sv) + len - (e - s + 4)));
1588 d = SvPVX(sv) + (d - odest);
1590 Copy(str, d, len, char);
1597 yyerror("Missing braces on \\N{}");
1600 /* \c is a control character */
1609 *d++ = NATIVE_TO_NEED(has_utf8,toCTRL(c));
1613 /* printf-style backslashes, formfeeds, newlines, etc */
1615 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
1618 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
1621 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
1624 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
1627 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
1630 *d++ = ASCII_TO_NEED(has_utf8,'\033');
1633 *d++ = ASCII_TO_NEED(has_utf8,'\007');
1639 } /* end if (backslash) */
1642 /* If we started with encoded form, or already know we want it
1643 and then encode the next character */
1644 if ((has_utf8 || this_utf8) && !NATIVE_IS_INVARIANT((U8)(*s))) {
1646 UV uv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
1647 STRLEN need = UNISKIP(NATIVE_TO_UNI(uv));
1650 /* encoded value larger than old, need extra space (NOTE: SvCUR() not set here) */
1651 STRLEN off = d - SvPVX(sv);
1652 d = SvGROW(sv, SvLEN(sv) + (need-len)) + off;
1654 d = (char*)uvchr_to_utf8((U8*)d, uv);
1658 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1660 } /* while loop to process each character */
1662 /* terminate the string and set up the sv */
1664 SvCUR_set(sv, d - SvPVX(sv));
1665 if (SvCUR(sv) >= SvLEN(sv))
1666 Perl_croak(aTHX_ "panic: constant overflowed allocated space");
1669 if (PL_encoding && !has_utf8) {
1670 Perl_sv_recode_to_utf8(aTHX_ sv, PL_encoding);
1675 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1676 PL_sublex_info.sub_op->op_private |=
1677 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1681 /* shrink the sv if we allocated more than we used */
1682 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1683 SvLEN_set(sv, SvCUR(sv) + 1);
1684 Renew(SvPVX(sv), SvLEN(sv), char);
1687 /* return the substring (via yylval) only if we parsed anything */
1688 if (s > PL_bufptr) {
1689 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1690 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1692 ( PL_lex_inwhat == OP_TRANS
1694 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1697 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1704 * Returns TRUE if there's more to the expression (e.g., a subscript),
1707 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
1709 * ->[ and ->{ return TRUE
1710 * { and [ outside a pattern are always subscripts, so return TRUE
1711 * if we're outside a pattern and it's not { or [, then return FALSE
1712 * if we're in a pattern and the first char is a {
1713 * {4,5} (any digits around the comma) returns FALSE
1714 * if we're in a pattern and the first char is a [
1716 * [SOMETHING] has a funky algorithm to decide whether it's a
1717 * character class or not. It has to deal with things like
1718 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
1719 * anything else returns TRUE
1722 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1725 S_intuit_more(pTHX_ register char *s)
1727 if (PL_lex_brackets)
1729 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1731 if (*s != '{' && *s != '[')
1736 /* In a pattern, so maybe we have {n,m}. */
1753 /* On the other hand, maybe we have a character class */
1756 if (*s == ']' || *s == '^')
1759 /* this is terrifying, and it works */
1760 int weight = 2; /* let's weigh the evidence */
1762 unsigned char un_char = 255, last_un_char;
1763 char *send = strchr(s,']');
1764 char tmpbuf[sizeof PL_tokenbuf * 4];
1766 if (!send) /* has to be an expression */
1769 Zero(seen,256,char);
1772 else if (isDIGIT(*s)) {
1774 if (isDIGIT(s[1]) && s[2] == ']')
1780 for (; s < send; s++) {
1781 last_un_char = un_char;
1782 un_char = (unsigned char)*s;
1787 weight -= seen[un_char] * 10;
1788 if (isALNUM_lazy_if(s+1,UTF)) {
1789 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1790 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1795 else if (*s == '$' && s[1] &&
1796 strchr("[#!%*<>()-=",s[1])) {
1797 if (/*{*/ strchr("])} =",s[2]))
1806 if (strchr("wds]",s[1]))
1808 else if (seen['\''] || seen['"'])
1810 else if (strchr("rnftbxcav",s[1]))
1812 else if (isDIGIT(s[1])) {
1814 while (s[1] && isDIGIT(s[1]))
1824 if (strchr("aA01! ",last_un_char))
1826 if (strchr("zZ79~",s[1]))
1828 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1829 weight -= 5; /* cope with negative subscript */
1832 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1833 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1838 if (keyword(tmpbuf, d - tmpbuf))
1841 if (un_char == last_un_char + 1)
1843 weight -= seen[un_char];
1848 if (weight >= 0) /* probably a character class */
1858 * Does all the checking to disambiguate
1860 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
1861 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
1863 * First argument is the stuff after the first token, e.g. "bar".
1865 * Not a method if bar is a filehandle.
1866 * Not a method if foo is a subroutine prototyped to take a filehandle.
1867 * Not a method if it's really "Foo $bar"
1868 * Method if it's "foo $bar"
1869 * Not a method if it's really "print foo $bar"
1870 * Method if it's really "foo package::" (interpreted as package->foo)
1871 * Not a method if bar is known to be a subroutne ("sub bar; foo bar")
1872 * Not a method if bar is a filehandle or package, but is quoted with
1877 S_intuit_method(pTHX_ char *start, GV *gv)
1879 char *s = start + (*start == '$');
1880 char tmpbuf[sizeof PL_tokenbuf];
1888 if ((cv = GvCVu(gv))) {
1889 char *proto = SvPVX(cv);
1899 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1900 /* start is the beginning of the possible filehandle/object,
1901 * and s is the end of it
1902 * tmpbuf is a copy of it
1905 if (*start == '$') {
1906 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1911 return *s == '(' ? FUNCMETH : METHOD;
1913 if (!keyword(tmpbuf, len)) {
1914 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1919 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1920 if (indirgv && GvCVu(indirgv))
1922 /* filehandle or package name makes it a method */
1923 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1925 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1926 return 0; /* no assumptions -- "=>" quotes bearword */
1928 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1929 newSVpvn(tmpbuf,len));
1930 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1934 return *s == '(' ? FUNCMETH : METHOD;
1942 * Return a string of Perl code to load the debugger. If PERL5DB
1943 * is set, it will return the contents of that, otherwise a
1944 * compile-time require of perl5db.pl.
1951 char *pdb = PerlEnv_getenv("PERL5DB");
1955 SETERRNO(0,SS$_NORMAL);
1956 return "BEGIN { require 'perl5db.pl' }";
1962 /* Encoded script support. filter_add() effectively inserts a
1963 * 'pre-processing' function into the current source input stream.
1964 * Note that the filter function only applies to the current source file
1965 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1967 * The datasv parameter (which may be NULL) can be used to pass
1968 * private data to this instance of the filter. The filter function
1969 * can recover the SV using the FILTER_DATA macro and use it to
1970 * store private buffers and state information.
1972 * The supplied datasv parameter is upgraded to a PVIO type
1973 * and the IoDIRP/IoANY field is used to store the function pointer,
1974 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
1975 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1976 * private use must be set using malloc'd pointers.
1980 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
1985 if (!PL_rsfp_filters)
1986 PL_rsfp_filters = newAV();
1988 datasv = NEWSV(255,0);
1989 if (!SvUPGRADE(datasv, SVt_PVIO))
1990 Perl_die(aTHX_ "Can't upgrade filter_add data to SVt_PVIO");
1991 IoANY(datasv) = (void *)funcp; /* stash funcp into spare field */
1992 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
1993 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
1994 (void*)funcp, SvPV_nolen(datasv)));
1995 av_unshift(PL_rsfp_filters, 1);
1996 av_store(PL_rsfp_filters, 0, datasv) ;
2001 /* Delete most recently added instance of this filter function. */
2003 Perl_filter_del(pTHX_ filter_t funcp)
2006 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", (void*)funcp));
2007 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
2009 /* if filter is on top of stack (usual case) just pop it off */
2010 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
2011 if (IoANY(datasv) == (void *)funcp) {
2012 IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
2013 IoANY(datasv) = (void *)NULL;
2014 sv_free(av_pop(PL_rsfp_filters));
2018 /* we need to search for the correct entry and clear it */
2019 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
2023 /* Invoke the n'th filter function for the current rsfp. */
2025 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
2028 /* 0 = read one text line */
2033 if (!PL_rsfp_filters)
2035 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
2036 /* Provide a default input filter to make life easy. */
2037 /* Note that we append to the line. This is handy. */
2038 DEBUG_P(PerlIO_printf(Perl_debug_log,
2039 "filter_read %d: from rsfp\n", idx));
2043 int old_len = SvCUR(buf_sv) ;
2045 /* ensure buf_sv is large enough */
2046 SvGROW(buf_sv, old_len + maxlen) ;
2047 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
2048 if (PerlIO_error(PL_rsfp))
2049 return -1; /* error */
2051 return 0 ; /* end of file */
2053 SvCUR_set(buf_sv, old_len + len) ;
2056 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
2057 if (PerlIO_error(PL_rsfp))
2058 return -1; /* error */
2060 return 0 ; /* end of file */
2063 return SvCUR(buf_sv);
2065 /* Skip this filter slot if filter has been deleted */
2066 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
2067 DEBUG_P(PerlIO_printf(Perl_debug_log,
2068 "filter_read %d: skipped (filter deleted)\n",
2070 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
2072 /* Get function pointer hidden within datasv */
2073 funcp = (filter_t)IoANY(datasv);
2074 DEBUG_P(PerlIO_printf(Perl_debug_log,
2075 "filter_read %d: via function %p (%s)\n",
2076 idx, (void*)funcp, SvPV_nolen(datasv)));
2077 /* Call function. The function is expected to */
2078 /* call "FILTER_READ(idx+1, buf_sv)" first. */
2079 /* Return: <0:error, =0:eof, >0:not eof */
2080 return (*funcp)(aTHX_ idx, buf_sv, maxlen);
2084 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
2086 #ifdef PERL_CR_FILTER
2087 if (!PL_rsfp_filters) {
2088 filter_add(S_cr_textfilter,NULL);
2091 if (PL_rsfp_filters) {
2094 SvCUR_set(sv, 0); /* start with empty line */
2095 if (FILTER_READ(0, sv, 0) > 0)
2096 return ( SvPVX(sv) ) ;
2101 return (sv_gets(sv, fp, append));
2105 S_find_in_my_stash(pTHX_ char *pkgname, I32 len)
2109 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
2113 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
2114 (gv = gv_fetchpv(pkgname, FALSE, SVt_PVHV)))
2116 return GvHV(gv); /* Foo:: */
2119 /* use constant CLASS => 'MyClass' */
2120 if ((gv = gv_fetchpv(pkgname, FALSE, SVt_PVCV))) {
2122 if (GvCV(gv) && (sv = cv_const_sv(GvCV(gv)))) {
2123 pkgname = SvPV_nolen(sv);
2127 return gv_stashpv(pkgname, FALSE);
2131 static char* exp_name[] =
2132 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
2133 "ATTRTERM", "TERMBLOCK"
2140 Works out what to call the token just pulled out of the input
2141 stream. The yacc parser takes care of taking the ops we return and
2142 stitching them into a tree.
2148 if read an identifier
2149 if we're in a my declaration
2150 croak if they tried to say my($foo::bar)
2151 build the ops for a my() declaration
2152 if it's an access to a my() variable
2153 are we in a sort block?
2154 croak if my($a); $a <=> $b
2155 build ops for access to a my() variable
2156 if in a dq string, and they've said @foo and we can't find @foo
2158 build ops for a bareword
2159 if we already built the token before, use it.
2162 #ifdef USE_PURE_BISON
2164 Perl_yylex_r(pTHX_ YYSTYPE *lvalp, int *lcharp)
2169 yylval_pointer[yyactlevel] = lvalp;
2170 yychar_pointer[yyactlevel] = lcharp;
2171 if (yyactlevel >= YYMAXLEVEL)
2172 Perl_croak(aTHX_ "panic: YYMAXLEVEL");
2174 r = Perl_yylex(aTHX);
2184 #pragma segment Perl_yylex
2197 /* check if there's an identifier for us to look at */
2198 if (PL_pending_ident)
2199 return S_pending_ident(aTHX);
2201 /* no identifier pending identification */
2203 switch (PL_lex_state) {
2205 case LEX_NORMAL: /* Some compilers will produce faster */
2206 case LEX_INTERPNORMAL: /* code if we comment these out. */
2210 /* when we've already built the next token, just pull it out of the queue */
2213 yylval = PL_nextval[PL_nexttoke];
2215 PL_lex_state = PL_lex_defer;
2216 PL_expect = PL_lex_expect;
2217 PL_lex_defer = LEX_NORMAL;
2219 DEBUG_T({ PerlIO_printf(Perl_debug_log,
2220 "### Next token after '%s' was known, type %"IVdf"\n", PL_bufptr,
2221 (IV)PL_nexttype[PL_nexttoke]); });
2223 return(PL_nexttype[PL_nexttoke]);
2225 /* interpolated case modifiers like \L \U, including \Q and \E.
2226 when we get here, PL_bufptr is at the \
2228 case LEX_INTERPCASEMOD:
2230 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
2231 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
2233 /* handle \E or end of string */
2234 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
2238 if (PL_lex_casemods) {
2239 oldmod = PL_lex_casestack[--PL_lex_casemods];
2240 PL_lex_casestack[PL_lex_casemods] = '\0';
2242 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
2244 PL_lex_state = LEX_INTERPCONCAT;
2248 if (PL_bufptr != PL_bufend)
2250 PL_lex_state = LEX_INTERPCONCAT;
2254 DEBUG_T({ PerlIO_printf(Perl_debug_log,
2255 "### Saw case modifier at '%s'\n", PL_bufptr); });
2257 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
2258 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
2259 if (strchr("LU", *s) &&
2260 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
2262 PL_lex_casestack[--PL_lex_casemods] = '\0';
2265 if (PL_lex_casemods > 10) {
2266 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
2267 if (newlb != PL_lex_casestack) {
2269 PL_lex_casestack = newlb;
2272 PL_lex_casestack[PL_lex_casemods++] = *s;
2273 PL_lex_casestack[PL_lex_casemods] = '\0';
2274 PL_lex_state = LEX_INTERPCONCAT;
2275 PL_nextval[PL_nexttoke].ival = 0;
2278 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
2280 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
2282 PL_nextval[PL_nexttoke].ival = OP_LC;
2284 PL_nextval[PL_nexttoke].ival = OP_UC;
2286 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
2288 Perl_croak(aTHX_ "panic: yylex");
2291 if (PL_lex_starts) {
2300 case LEX_INTERPPUSH:
2301 return sublex_push();
2303 case LEX_INTERPSTART:
2304 if (PL_bufptr == PL_bufend)
2305 return sublex_done();
2306 DEBUG_T({ PerlIO_printf(Perl_debug_log,
2307 "### Interpolated variable at '%s'\n", PL_bufptr); });
2309 PL_lex_dojoin = (*PL_bufptr == '@');
2310 PL_lex_state = LEX_INTERPNORMAL;
2311 if (PL_lex_dojoin) {
2312 PL_nextval[PL_nexttoke].ival = 0;
2314 #ifdef USE_5005THREADS
2315 PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
2316 PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
2317 force_next(PRIVATEREF);
2319 force_ident("\"", '$');
2320 #endif /* USE_5005THREADS */
2321 PL_nextval[PL_nexttoke].ival = 0;
2323 PL_nextval[PL_nexttoke].ival = 0;
2325 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
2328 if (PL_lex_starts++) {
2334 case LEX_INTERPENDMAYBE:
2335 if (intuit_more(PL_bufptr)) {
2336 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
2342 if (PL_lex_dojoin) {
2343 PL_lex_dojoin = FALSE;
2344 PL_lex_state = LEX_INTERPCONCAT;
2347 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
2348 && SvEVALED(PL_lex_repl))
2350 if (PL_bufptr != PL_bufend)
2351 Perl_croak(aTHX_ "Bad evalled substitution pattern");
2352 PL_lex_repl = Nullsv;
2355 case LEX_INTERPCONCAT:
2357 if (PL_lex_brackets)
2358 Perl_croak(aTHX_ "panic: INTERPCONCAT");
2360 if (PL_bufptr == PL_bufend)
2361 return sublex_done();
2363 if (SvIVX(PL_linestr) == '\'') {
2364 SV *sv = newSVsv(PL_linestr);
2367 else if ( PL_hints & HINT_NEW_RE )
2368 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
2369 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2373 s = scan_const(PL_bufptr);
2375 PL_lex_state = LEX_INTERPCASEMOD;
2377 PL_lex_state = LEX_INTERPSTART;
2380 if (s != PL_bufptr) {
2381 PL_nextval[PL_nexttoke] = yylval;
2384 if (PL_lex_starts++)
2394 PL_lex_state = LEX_NORMAL;
2395 s = scan_formline(PL_bufptr);
2396 if (!PL_lex_formbrack)
2402 PL_oldoldbufptr = PL_oldbufptr;
2405 PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at %s\n",
2406 exp_name[PL_expect], s);
2412 if (isIDFIRST_lazy_if(s,UTF))
2414 Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
2417 goto fake_eof; /* emulate EOF on ^D or ^Z */
2422 if (PL_lex_brackets)
2423 yyerror("Missing right curly or square bracket");
2424 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2425 "### Tokener got EOF\n");
2429 if (s++ < PL_bufend)
2430 goto retry; /* ignore stray nulls */
2433 if (!PL_in_eval && !PL_preambled) {
2434 PL_preambled = TRUE;
2435 sv_setpv(PL_linestr,incl_perldb());
2436 if (SvCUR(PL_linestr))
2437 sv_catpv(PL_linestr,";");
2439 while(AvFILLp(PL_preambleav) >= 0) {
2440 SV *tmpsv = av_shift(PL_preambleav);
2441 sv_catsv(PL_linestr, tmpsv);
2442 sv_catpv(PL_linestr, ";");
2445 sv_free((SV*)PL_preambleav);
2446 PL_preambleav = NULL;
2448 if (PL_minus_n || PL_minus_p) {
2449 sv_catpv(PL_linestr, "LINE: while (<>) {");
2451 sv_catpv(PL_linestr,"chomp;");
2454 if (strchr("/'\"", *PL_splitstr)
2455 && strchr(PL_splitstr + 1, *PL_splitstr))
2456 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
2459 s = "'~#\200\1'"; /* surely one char is unused...*/
2460 while (s[1] && strchr(PL_splitstr, *s)) s++;
2462 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s%c",
2463 "q" + (delim == '\''), delim);
2464 for (s = PL_splitstr; *s; s++) {
2466 sv_catpvn(PL_linestr, "\\", 1);
2467 sv_catpvn(PL_linestr, s, 1);
2469 Perl_sv_catpvf(aTHX_ PL_linestr, "%c);", delim);
2473 sv_catpv(PL_linestr,"our @F=split(' ');");
2476 sv_catpv(PL_linestr, "\n");
2477 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2478 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2479 PL_last_lop = PL_last_uni = Nullch;
2480 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2481 SV *sv = NEWSV(85,0);
2483 sv_upgrade(sv, SVt_PVMG);
2484 sv_setsv(sv,PL_linestr);
2487 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2492 bof = PL_rsfp ? TRUE : FALSE;
2493 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
2496 if (PL_preprocess && !PL_in_eval)
2497 (void)PerlProc_pclose(PL_rsfp);
2498 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2499 PerlIO_clearerr(PL_rsfp);
2501 (void)PerlIO_close(PL_rsfp);
2503 PL_doextract = FALSE;
2505 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2506 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
2507 sv_catpv(PL_linestr,";}");
2508 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2509 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2510 PL_last_lop = PL_last_uni = Nullch;
2511 PL_minus_n = PL_minus_p = 0;
2514 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2515 PL_last_lop = PL_last_uni = Nullch;
2516 sv_setpv(PL_linestr,"");
2517 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
2519 /* if it looks like the start of a BOM, check if it in fact is */
2520 else if (bof && (!*s || *(U8*)s == 0xEF || *(U8*)s >= 0xFE)) {
2521 #ifdef PERLIO_IS_STDIO
2522 # ifdef __GNU_LIBRARY__
2523 # if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
2524 # define FTELL_FOR_PIPE_IS_BROKEN
2528 # if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
2529 # define FTELL_FOR_PIPE_IS_BROKEN
2534 #ifdef FTELL_FOR_PIPE_IS_BROKEN
2535 /* This loses the possibility to detect the bof
2536 * situation on perl -P when the libc5 is being used.
2537 * Workaround? Maybe attach some extra state to PL_rsfp?
2540 bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
2542 bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
2545 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2546 s = swallow_bom((U8*)s);
2550 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
2551 PL_doextract = FALSE;
2553 /* Incest with pod. */
2554 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2555 sv_setpv(PL_linestr, "");
2556 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2557 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2558 PL_last_lop = PL_last_uni = Nullch;
2559 PL_doextract = FALSE;
2563 } while (PL_doextract);
2564 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2565 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2566 SV *sv = NEWSV(85,0);
2568 sv_upgrade(sv, SVt_PVMG);
2569 sv_setsv(sv,PL_linestr);
2572 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2574 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2575 PL_last_lop = PL_last_uni = Nullch;
2576 if (CopLINE(PL_curcop) == 1) {
2577 while (s < PL_bufend && isSPACE(*s))
2579 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2583 if (*s == '#' && *(s+1) == '!')
2585 #ifdef ALTERNATE_SHEBANG
2587 static char as[] = ALTERNATE_SHEBANG;
2588 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2589 d = s + (sizeof(as) - 1);
2591 #endif /* ALTERNATE_SHEBANG */
2600 while (*d && !isSPACE(*d))
2604 #ifdef ARG_ZERO_IS_SCRIPT
2605 if (ipathend > ipath) {
2607 * HP-UX (at least) sets argv[0] to the script name,
2608 * which makes $^X incorrect. And Digital UNIX and Linux,
2609 * at least, set argv[0] to the basename of the Perl
2610 * interpreter. So, having found "#!", we'll set it right.
2612 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV)); /* $^X */
2613 assert(SvPOK(x) || SvGMAGICAL(x));
2614 if (sv_eq(x, CopFILESV(PL_curcop))) {
2615 sv_setpvn(x, ipath, ipathend - ipath);
2618 TAINT_NOT; /* $^X is always tainted, but that's OK */
2620 #endif /* ARG_ZERO_IS_SCRIPT */
2625 d = instr(s,"perl -");
2627 d = instr(s,"perl");
2629 /* avoid getting into infinite loops when shebang
2630 * line contains "Perl" rather than "perl" */
2632 for (d = ipathend-4; d >= ipath; --d) {
2633 if ((*d == 'p' || *d == 'P')
2634 && !ibcmp(d, "perl", 4))
2644 #ifdef ALTERNATE_SHEBANG
2646 * If the ALTERNATE_SHEBANG on this system starts with a
2647 * character that can be part of a Perl expression, then if
2648 * we see it but not "perl", we're probably looking at the
2649 * start of Perl code, not a request to hand off to some
2650 * other interpreter. Similarly, if "perl" is there, but
2651 * not in the first 'word' of the line, we assume the line
2652 * contains the start of the Perl program.
2654 if (d && *s != '#') {
2656 while (*c && !strchr("; \t\r\n\f\v#", *c))
2659 d = Nullch; /* "perl" not in first word; ignore */
2661 *s = '#'; /* Don't try to parse shebang line */
2663 #endif /* ALTERNATE_SHEBANG */
2664 #ifndef MACOS_TRADITIONAL
2669 !instr(s,"indir") &&
2670 instr(PL_origargv[0],"perl"))
2676 while (s < PL_bufend && isSPACE(*s))
2678 if (s < PL_bufend) {
2679 Newz(899,newargv,PL_origargc+3,char*);
2681 while (s < PL_bufend && !isSPACE(*s))
2684 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2687 newargv = PL_origargv;
2689 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
2690 Perl_croak(aTHX_ "Can't exec %s", ipath);
2694 U32 oldpdb = PL_perldb;
2695 bool oldn = PL_minus_n;
2696 bool oldp = PL_minus_p;
2698 while (*d && !isSPACE(*d)) d++;
2699 while (SPACE_OR_TAB(*d)) d++;
2702 bool switches_done = PL_doswitches;
2704 if (*d == 'M' || *d == 'm') {
2706 while (*d && !isSPACE(*d)) d++;
2707 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2710 d = moreswitches(d);
2712 if ((PERLDB_LINE && !oldpdb) ||
2713 ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
2714 /* if we have already added "LINE: while (<>) {",
2715 we must not do it again */
2717 sv_setpv(PL_linestr, "");
2718 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2719 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2720 PL_last_lop = PL_last_uni = Nullch;
2721 PL_preambled = FALSE;
2723 (void)gv_fetchfile(PL_origfilename);
2726 if (PL_doswitches && !switches_done) {
2727 int argc = PL_origargc;
2728 char **argv = PL_origargv;
2731 } while (argc && argv[0][0] == '-' && argv[0][1]);
2732 init_argv_symbols(argc,argv);
2738 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2740 PL_lex_state = LEX_FORMLINE;
2745 #ifdef PERL_STRICT_CR
2746 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2748 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
2750 case ' ': case '\t': case '\f': case 013:
2751 #ifdef MACOS_TRADITIONAL
2758 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2759 if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
2760 /* handle eval qq[#line 1 "foo"\n ...] */
2761 CopLINE_dec(PL_curcop);
2765 while (s < d && *s != '\n')
2769 else if (s > d) /* Found by Ilya: feed random input to Perl. */
2770 Perl_croak(aTHX_ "panic: input overflow");
2772 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2774 PL_lex_state = LEX_FORMLINE;
2784 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2791 while (s < PL_bufend && SPACE_OR_TAB(*s))
2794 if (strnEQ(s,"=>",2)) {
2795 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2796 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2797 "### Saw unary minus before =>, forcing word '%s'\n", s);
2799 OPERATOR('-'); /* unary minus */
2801 PL_last_uni = PL_oldbufptr;
2803 case 'r': ftst = OP_FTEREAD; break;
2804 case 'w': ftst = OP_FTEWRITE; break;
2805 case 'x': ftst = OP_FTEEXEC; break;
2806 case 'o': ftst = OP_FTEOWNED; break;
2807 case 'R': ftst = OP_FTRREAD; break;
2808 case 'W': ftst = OP_FTRWRITE; break;
2809 case 'X': ftst = OP_FTREXEC; break;
2810 case 'O': ftst = OP_FTROWNED; break;
2811 case 'e': ftst = OP_FTIS; break;
2812 case 'z': ftst = OP_FTZERO; break;
2813 case 's': ftst = OP_FTSIZE; break;
2814 case 'f': ftst = OP_FTFILE; break;
2815 case 'd': ftst = OP_FTDIR; break;
2816 case 'l': ftst = OP_FTLINK; break;
2817 case 'p': ftst = OP_FTPIPE; break;
2818 case 'S': ftst = OP_FTSOCK; break;
2819 case 'u': ftst = OP_FTSUID; break;
2820 case 'g': ftst = OP_FTSGID; break;
2821 case 'k': ftst = OP_FTSVTX; break;
2822 case 'b': ftst = OP_FTBLK; break;
2823 case 'c': ftst = OP_FTCHR; break;
2824 case 't': ftst = OP_FTTTY; break;
2825 case 'T': ftst = OP_FTTEXT; break;
2826 case 'B': ftst = OP_FTBINARY; break;
2827 case 'M': case 'A': case 'C':
2828 gv_fetchpv("\024",TRUE, SVt_PV);
2830 case 'M': ftst = OP_FTMTIME; break;
2831 case 'A': ftst = OP_FTATIME; break;
2832 case 'C': ftst = OP_FTCTIME; break;
2840 PL_last_lop_op = ftst;
2841 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2842 "### Saw file test %c\n", (int)ftst);
2847 /* Assume it was a minus followed by a one-letter named
2848 * subroutine call (or a -bareword), then. */
2849 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2850 "### %c looked like a file test but was not\n",
2859 if (PL_expect == XOPERATOR)
2864 else if (*s == '>') {
2867 if (isIDFIRST_lazy_if(s,UTF)) {
2868 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2876 if (PL_expect == XOPERATOR)
2879 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2881 OPERATOR('-'); /* unary minus */
2888 if (PL_expect == XOPERATOR)
2893 if (PL_expect == XOPERATOR)
2896 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2902 if (PL_expect != XOPERATOR) {
2903 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2904 PL_expect = XOPERATOR;
2905 force_ident(PL_tokenbuf, '*');
2918 if (PL_expect == XOPERATOR) {
2922 PL_tokenbuf[0] = '%';
2923 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2924 if (!PL_tokenbuf[1]) {
2926 yyerror("Final % should be \\% or %name");
2929 PL_pending_ident = '%';
2948 switch (PL_expect) {
2951 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
2953 PL_bufptr = s; /* update in case we back off */
2959 PL_expect = XTERMBLOCK;
2963 while (isIDFIRST_lazy_if(s,UTF)) {
2964 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2965 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
2966 if (tmp < 0) tmp = -tmp;
2981 d = scan_str(d,TRUE,TRUE);
2983 /* MUST advance bufptr here to avoid bogus
2984 "at end of line" context messages from yyerror().
2986 PL_bufptr = s + len;
2987 yyerror("Unterminated attribute parameter in attribute list");
2990 return 0; /* EOF indicator */
2994 SV *sv = newSVpvn(s, len);
2995 sv_catsv(sv, PL_lex_stuff);
2996 attrs = append_elem(OP_LIST, attrs,
2997 newSVOP(OP_CONST, 0, sv));
2998 SvREFCNT_dec(PL_lex_stuff);
2999 PL_lex_stuff = Nullsv;
3002 if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len))
3003 CvLVALUE_on(PL_compcv);
3004 else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len))
3005 CvLOCKED_on(PL_compcv);
3006 else if (!PL_in_my && len == 6 && strnEQ(s, "method", len))
3007 CvMETHOD_on(PL_compcv);
3009 else if (PL_in_my == KEY_our && len == 6 && strnEQ(s, "unique", len))
3010 GvUNIQUE_on(cGVOPx_gv(yylval.opval));
3012 /* After we've set the flags, it could be argued that
3013 we don't need to do the attributes.pm-based setting
3014 process, and shouldn't bother appending recognized
3015 flags. To experiment with that, uncomment the
3016 following "else": */
3018 attrs = append_elem(OP_LIST, attrs,
3019 newSVOP(OP_CONST, 0,
3023 if (*s == ':' && s[1] != ':')
3026 break; /* require real whitespace or :'s */
3028 tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
3029 if (*s != ';' && *s != tmp && (tmp != '=' || *s != ')')) {
3030 char q = ((*s == '\'') ? '"' : '\'');
3031 /* If here for an expression, and parsed no attrs, back off. */
3032 if (tmp == '=' && !attrs) {
3036 /* MUST advance bufptr here to avoid bogus "at end of line"
3037 context messages from yyerror().
3041 yyerror("Unterminated attribute list");
3043 yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list",
3051 PL_nextval[PL_nexttoke].opval = attrs;
3059 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
3060 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
3076 if (PL_lex_brackets <= 0)
3077 yyerror("Unmatched right square bracket");
3080 if (PL_lex_state == LEX_INTERPNORMAL) {
3081 if (PL_lex_brackets == 0) {
3082 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
3083 PL_lex_state = LEX_INTERPEND;
3090 if (PL_lex_brackets > 100) {
3091 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
3092 if (newlb != PL_lex_brackstack) {
3094 PL_lex_brackstack = newlb;
3097 switch (PL_expect) {
3099 if (PL_lex_formbrack) {
3103 if (PL_oldoldbufptr == PL_last_lop)
3104 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3106 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3107 OPERATOR(HASHBRACK);
3109 while (s < PL_bufend && SPACE_OR_TAB(*s))
3112 PL_tokenbuf[0] = '\0';
3113 if (d < PL_bufend && *d == '-') {
3114 PL_tokenbuf[0] = '-';
3116 while (d < PL_bufend && SPACE_OR_TAB(*d))
3119 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
3120 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
3122 while (d < PL_bufend && SPACE_OR_TAB(*d))
3125 char minus = (PL_tokenbuf[0] == '-');
3126 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
3134 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
3139 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3144 if (PL_oldoldbufptr == PL_last_lop)
3145 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3147 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3150 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
3152 /* This hack is to get the ${} in the message. */
3154 yyerror("syntax error");
3157 OPERATOR(HASHBRACK);
3159 /* This hack serves to disambiguate a pair of curlies
3160 * as being a block or an anon hash. Normally, expectation
3161 * determines that, but in cases where we're not in a
3162 * position to expect anything in particular (like inside
3163 * eval"") we have to resolve the ambiguity. This code
3164 * covers the case where the first term in the curlies is a
3165 * quoted string. Most other cases need to be explicitly
3166 * disambiguated by prepending a `+' before the opening
3167 * curly in order to force resolution as an anon hash.
3169 * XXX should probably propagate the outer expectation
3170 * into eval"" to rely less on this hack, but that could
3171 * potentially break current behavior of eval"".
3175 if (*s == '\'' || *s == '"' || *s == '`') {
3176 /* common case: get past first string, handling escapes */
3177 for (t++; t < PL_bufend && *t != *s;)
3178 if (*t++ == '\\' && (*t == '\\' || *t == *s))
3182 else if (*s == 'q') {
3185 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
3189 char open, close, term;
3192 while (t < PL_bufend && isSPACE(*t))
3196 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
3200 for (t++; t < PL_bufend; t++) {
3201 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
3203 else if (*t == open)
3207 for (t++; t < PL_bufend; t++) {
3208 if (*t == '\\' && t+1 < PL_bufend)
3210 else if (*t == close && --brackets <= 0)
3212 else if (*t == open)
3218 else if (isALNUM_lazy_if(t,UTF)) {
3220 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3223 while (t < PL_bufend && isSPACE(*t))
3225 /* if comma follows first term, call it an anon hash */
3226 /* XXX it could be a comma expression with loop modifiers */
3227 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
3228 || (*t == '=' && t[1] == '>')))
3229 OPERATOR(HASHBRACK);
3230 if (PL_expect == XREF)
3233 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
3239 yylval.ival = CopLINE(PL_curcop);
3240 if (isSPACE(*s) || *s == '#')
3241 PL_copline = NOLINE; /* invalidate current command line number */
3246 if (PL_lex_brackets <= 0)
3247 yyerror("Unmatched right curly bracket");
3249 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
3250 if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
3251 PL_lex_formbrack = 0;
3252 if (PL_lex_state == LEX_INTERPNORMAL) {
3253 if (PL_lex_brackets == 0) {
3254 if (PL_expect & XFAKEBRACK) {
3255 PL_expect &= XENUMMASK;
3256 PL_lex_state = LEX_INTERPEND;
3258 return yylex(); /* ignore fake brackets */
3260 if (*s == '-' && s[1] == '>')
3261 PL_lex_state = LEX_INTERPENDMAYBE;
3262 else if (*s != '[' && *s != '{')
3263 PL_lex_state = LEX_INTERPEND;
3266 if (PL_expect & XFAKEBRACK) {
3267 PL_expect &= XENUMMASK;
3269 return yylex(); /* ignore fake brackets */
3279 if (PL_expect == XOPERATOR) {
3280 if (ckWARN(WARN_SEMICOLON)
3281 && isIDFIRST_lazy_if(s,UTF) && PL_bufptr == PL_linestart)
3283 CopLINE_dec(PL_curcop);
3284 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3285 CopLINE_inc(PL_curcop);
3290 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3292 PL_expect = XOPERATOR;
3293 force_ident(PL_tokenbuf, '&');
3297 yylval.ival = (OPpENTERSUB_AMPER<<8);
3316 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
3317 Perl_warner(aTHX_ WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
3319 if (PL_expect == XSTATE && isALPHA(tmp) &&
3320 (s == PL_linestart+1 || s[-2] == '\n') )
3322 if (PL_in_eval && !PL_rsfp) {
3327 if (strnEQ(s,"=cut",4)) {
3341 PL_doextract = TRUE;
3344 if (PL_lex_brackets < PL_lex_formbrack) {
3346 #ifdef PERL_STRICT_CR
3347 for (t = s; SPACE_OR_TAB(*t); t++) ;
3349 for (t = s; SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
3351 if (*t == '\n' || *t == '#') {
3369 if (PL_expect != XOPERATOR) {
3370 if (s[1] != '<' && !strchr(s,'>'))
3373 s = scan_heredoc(s);
3375 s = scan_inputsymbol(s);
3376 TERM(sublex_start());
3381 SHop(OP_LEFT_SHIFT);
3395 SHop(OP_RIGHT_SHIFT);
3404 if (PL_expect == XOPERATOR) {
3405 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3408 return ','; /* grandfather non-comma-format format */
3412 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
3413 PL_tokenbuf[0] = '@';
3414 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3415 sizeof PL_tokenbuf - 1, FALSE);
3416 if (PL_expect == XOPERATOR)
3417 no_op("Array length", s);
3418 if (!PL_tokenbuf[1])
3420 PL_expect = XOPERATOR;
3421 PL_pending_ident = '#';
3425 PL_tokenbuf[0] = '$';
3426 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3427 sizeof PL_tokenbuf - 1, FALSE);
3428 if (PL_expect == XOPERATOR)
3430 if (!PL_tokenbuf[1]) {
3432 yyerror("Final $ should be \\$ or $name");
3436 /* This kludge not intended to be bulletproof. */
3437 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
3438 yylval.opval = newSVOP(OP_CONST, 0,
3439 newSViv(PL_compiling.cop_arybase));
3440 yylval.opval->op_private = OPpCONST_ARYBASE;
3446 if (PL_lex_state == LEX_NORMAL)
3449 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3452 PL_tokenbuf[0] = '@';
3453 if (ckWARN(WARN_SYNTAX)) {
3455 isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$';
3458 PL_bufptr = skipspace(PL_bufptr);
3459 while (t < PL_bufend && *t != ']')
3461 Perl_warner(aTHX_ WARN_SYNTAX,
3462 "Multidimensional syntax %.*s not supported",
3463 (t - PL_bufptr) + 1, PL_bufptr);
3467 else if (*s == '{') {
3468 PL_tokenbuf[0] = '%';
3469 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
3470 (t = strchr(s, '}')) && (t = strchr(t, '=')))
3472 char tmpbuf[sizeof PL_tokenbuf];
3474 for (t++; isSPACE(*t); t++) ;
3475 if (isIDFIRST_lazy_if(t,UTF)) {
3476 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
3477 for (; isSPACE(*t); t++) ;
3478 if (*t == ';' && get_cv(tmpbuf, FALSE))
3479 Perl_warner(aTHX_ WARN_SYNTAX,
3480 "You need to quote \"%s\"", tmpbuf);
3486 PL_expect = XOPERATOR;
3487 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3488 bool islop = (PL_last_lop == PL_oldoldbufptr);
3489 if (!islop || PL_last_lop_op == OP_GREPSTART)
3490 PL_expect = XOPERATOR;
3491 else if (strchr("$@\"'`q", *s))
3492 PL_expect = XTERM; /* e.g. print $fh "foo" */
3493 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
3494 PL_expect = XTERM; /* e.g. print $fh &sub */
3495 else if (isIDFIRST_lazy_if(s,UTF)) {
3496 char tmpbuf[sizeof PL_tokenbuf];
3497 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3498 if ((tmp = keyword(tmpbuf, len))) {
3499 /* binary operators exclude handle interpretations */
3511 PL_expect = XTERM; /* e.g. print $fh length() */
3516 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
3517 if (gv && GvCVu(gv))
3518 PL_expect = XTERM; /* e.g. print $fh subr() */
3521 else if (isDIGIT(*s))
3522 PL_expect = XTERM; /* e.g. print $fh 3 */
3523 else if (*s == '.' && isDIGIT(s[1]))
3524 PL_expect = XTERM; /* e.g. print $fh .3 */
3525 else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
3526 PL_expect = XTERM; /* e.g. print $fh -1 */
3527 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3528 PL_expect = XTERM; /* print $fh <<"EOF" */
3530 PL_pending_ident = '$';
3534 if (PL_expect == XOPERATOR)
3536 PL_tokenbuf[0] = '@';
3537 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3538 if (!PL_tokenbuf[1]) {
3540 yyerror("Final @ should be \\@ or @name");
3543 if (PL_lex_state == LEX_NORMAL)
3545 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3547 PL_tokenbuf[0] = '%';
3549 /* Warn about @ where they meant $. */
3550 if (ckWARN(WARN_SYNTAX)) {
3551 if (*s == '[' || *s == '{') {
3553 while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
3555 if (*t == '}' || *t == ']') {
3557 PL_bufptr = skipspace(PL_bufptr);
3558 Perl_warner(aTHX_ WARN_SYNTAX,
3559 "Scalar value %.*s better written as $%.*s",
3560 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
3565 PL_pending_ident = '@';
3568 case '/': /* may either be division or pattern */
3569 case '?': /* may either be conditional or pattern */
3570 if (PL_expect != XOPERATOR) {
3571 /* Disable warning on "study /blah/" */
3572 if (PL_oldoldbufptr == PL_last_uni
3573 && (*PL_last_uni != 's' || s - PL_last_uni < 5
3574 || memNE(PL_last_uni, "study", 5)
3575 || isALNUM_lazy_if(PL_last_uni+5,UTF)))
3577 s = scan_pat(s,OP_MATCH);
3578 TERM(sublex_start());
3586 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3587 #ifdef PERL_STRICT_CR
3590 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3592 && (s == PL_linestart || s[-1] == '\n') )
3594 PL_lex_formbrack = 0;
3598 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
3604 yylval.ival = OPf_SPECIAL;
3610 if (PL_expect != XOPERATOR)
3615 case '0': case '1': case '2': case '3': case '4':
3616 case '5': case '6': case '7': case '8': case '9':
3617 s = scan_num(s, &yylval);
3618 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3619 "### Saw number in '%s'\n", s);
3621 if (PL_expect == XOPERATOR)
3626 s = scan_str(s,FALSE,FALSE);
3627 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3628 "### Saw string before '%s'\n", s);
3630 if (PL_expect == XOPERATOR) {
3631 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3634 return ','; /* grandfather non-comma-format format */
3640 missingterm((char*)0);
3641 yylval.ival = OP_CONST;
3642 TERM(sublex_start());
3645 s = scan_str(s,FALSE,FALSE);
3646 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3647 "### Saw string before '%s'\n", s);
3649 if (PL_expect == XOPERATOR) {
3650 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3653 return ','; /* grandfather non-comma-format format */
3659 missingterm((char*)0);
3660 yylval.ival = OP_CONST;
3661 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
3662 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
3663 yylval.ival = OP_STRINGIFY;
3667 TERM(sublex_start());
3670 s = scan_str(s,FALSE,FALSE);
3671 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3672 "### Saw backtick string before '%s'\n", s);
3674 if (PL_expect == XOPERATOR)
3675 no_op("Backticks",s);
3677 missingterm((char*)0);
3678 yylval.ival = OP_BACKTICK;
3680 TERM(sublex_start());
3684 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
3685 Perl_warner(aTHX_ WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
3687 if (PL_expect == XOPERATOR)
3688 no_op("Backslash",s);
3692 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
3696 while (isDIGIT(*start) || *start == '_')
3698 if (*start == '.' && isDIGIT(start[1])) {
3699 s = scan_num(s, &yylval);
3702 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
3703 else if (!isALPHA(*start) && (PL_expect == XTERM || PL_expect == XREF || PL_expect == XSTATE)) {
3707 gv = gv_fetchpv(s, FALSE, SVt_PVCV);
3710 s = scan_num(s, &yylval);
3717 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
3756 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3758 /* Some keywords can be followed by any delimiter, including ':' */
3759 tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
3760 (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
3761 (PL_tokenbuf[0] == 'q' &&
3762 strchr("qwxr", PL_tokenbuf[1])))));
3764 /* x::* is just a word, unless x is "CORE" */
3765 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
3769 while (d < PL_bufend && isSPACE(*d))
3770 d++; /* no comments skipped here, or s### is misparsed */
3772 /* Is this a label? */
3773 if (!tmp && PL_expect == XSTATE
3774 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
3776 yylval.pval = savepv(PL_tokenbuf);
3781 /* Check for keywords */
3782 tmp = keyword(PL_tokenbuf, len);
3784 /* Is this a word before a => operator? */
3785 if (*d == '=' && d[1] == '>') {
3787 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
3788 yylval.opval->op_private = OPpCONST_BARE;
3789 if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
3790 SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
3794 if (tmp < 0) { /* second-class keyword? */
3795 GV *ogv = Nullgv; /* override (winner) */
3796 GV *hgv = Nullgv; /* hidden (loser) */
3797 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3799 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3802 if (GvIMPORTED_CV(gv))
3804 else if (! CvMETHOD(cv))
3808 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3809 (gv = *gvp) != (GV*)&PL_sv_undef &&
3810 GvCVu(gv) && GvIMPORTED_CV(gv))
3816 tmp = 0; /* overridden by import or by GLOBAL */
3819 && -tmp==KEY_lock /* XXX generalizable kludge */
3821 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3823 tmp = 0; /* any sub overrides "weak" keyword */
3825 else { /* no override */
3827 if (tmp == KEY_dump && ckWARN(WARN_MISC)) {
3828 Perl_warner(aTHX_ WARN_MISC,
3829 "dump() better written as CORE::dump()");
3833 if (ckWARN(WARN_AMBIGUOUS) && hgv
3834 && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3835 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3836 "Ambiguous call resolved as CORE::%s(), %s",
3837 GvENAME(hgv), "qualify as such or use &");
3844 default: /* not a keyword */
3848 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3850 /* Get the rest if it looks like a package qualifier */
3852 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
3854 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3857 Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
3858 *s == '\'' ? "'" : "::");
3863 if (PL_expect == XOPERATOR) {
3864 if (PL_bufptr == PL_linestart) {
3865 CopLINE_dec(PL_curcop);
3866 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3867 CopLINE_inc(PL_curcop);
3870 no_op("Bareword",s);
3873 /* Look for a subroutine with this name in current package,
3874 unless name is "Foo::", in which case Foo is a bearword
3875 (and a package name). */
3878 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3880 if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3881 Perl_warner(aTHX_ WARN_BAREWORD,
3882 "Bareword \"%s\" refers to nonexistent package",
3885 PL_tokenbuf[len] = '\0';
3892 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3895 /* if we saw a global override before, get the right name */
3898 sv = newSVpvn("CORE::GLOBAL::",14);
3899 sv_catpv(sv,PL_tokenbuf);
3902 sv = newSVpv(PL_tokenbuf,0);
3904 /* Presume this is going to be a bareword of some sort. */
3907 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3908 yylval.opval->op_private = OPpCONST_BARE;
3910 /* And if "Foo::", then that's what it certainly is. */
3915 /* See if it's the indirect object for a list operator. */
3917 if (PL_oldoldbufptr &&
3918 PL_oldoldbufptr < PL_bufptr &&
3919 (PL_oldoldbufptr == PL_last_lop
3920 || PL_oldoldbufptr == PL_last_uni) &&
3921 /* NO SKIPSPACE BEFORE HERE! */
3922 (PL_expect == XREF ||
3923 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
3925 bool immediate_paren = *s == '(';
3927 /* (Now we can afford to cross potential line boundary.) */
3930 /* Two barewords in a row may indicate method call. */
3932 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp=intuit_method(s,gv)))
3935 /* If not a declared subroutine, it's an indirect object. */
3936 /* (But it's an indir obj regardless for sort.) */
3938 if ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
3939 ((!gv || !GvCVu(gv)) &&
3940 (PL_last_lop_op != OP_MAPSTART &&
3941 PL_last_lop_op != OP_GREPSTART))))
3943 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3948 PL_expect = XOPERATOR;
3951 /* Is this a word before a => operator? */
3952 if (*s == '=' && s[1] == '>' && !pkgname) {
3954 sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
3955 if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
3956 SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
3960 /* If followed by a paren, it's certainly a subroutine. */
3963 if (gv && GvCVu(gv)) {
3964 for (d = s + 1; SPACE_OR_TAB(*d); d++) ;
3965 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
3970 PL_nextval[PL_nexttoke].opval = yylval.opval;
3971 PL_expect = XOPERATOR;
3977 /* If followed by var or block, call it a method (unless sub) */
3979 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3980 PL_last_lop = PL_oldbufptr;
3981 PL_last_lop_op = OP_METHOD;
3985 /* If followed by a bareword, see if it looks like indir obj. */
3987 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp = intuit_method(s,gv)))
3990 /* Not a method, so call it a subroutine (if defined) */
3992 if (gv && GvCVu(gv)) {
3994 if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
3995 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3996 "Ambiguous use of -%s resolved as -&%s()",
3997 PL_tokenbuf, PL_tokenbuf);
3998 /* Check for a constant sub */
4000 if ((sv = cv_const_sv(cv))) {
4002 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
4003 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
4004 yylval.opval->op_private = 0;
4008 /* Resolve to GV now. */
4009 op_free(yylval.opval);
4010 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
4011 yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
4012 PL_last_lop = PL_oldbufptr;
4013 PL_last_lop_op = OP_ENTERSUB;
4014 /* Is there a prototype? */
4017 char *proto = SvPV((SV*)cv, len);
4020 if (strEQ(proto, "$"))
4022 if (*proto == '&' && *s == '{') {
4023 sv_setpv(PL_subname,"__ANON__");
4027 PL_nextval[PL_nexttoke].opval = yylval.opval;
4033 /* Call it a bare word */
4035 if (PL_hints & HINT_STRICT_SUBS)
4036 yylval.opval->op_private |= OPpCONST_STRICT;
4039 if (ckWARN(WARN_RESERVED)) {
4040 if (lastchar != '-') {
4041 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
4042 if (!*d && strNE(PL_tokenbuf,"main"))
4043 Perl_warner(aTHX_ WARN_RESERVED, PL_warn_reserved,
4050 if (lastchar && strchr("*%&", lastchar) && ckWARN_d(WARN_AMBIGUOUS)) {
4051 Perl_warner(aTHX_ WARN_AMBIGUOUS,
4052 "Operator or semicolon missing before %c%s",
4053 lastchar, PL_tokenbuf);
4054 Perl_warner(aTHX_ WARN_AMBIGUOUS,
4055 "Ambiguous use of %c resolved as operator %c",
4056 lastchar, lastchar);
4062 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4063 newSVpv(CopFILE(PL_curcop),0));
4067 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4068 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
4071 case KEY___PACKAGE__:
4072 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4074 ? newSVsv(PL_curstname)
4083 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
4084 char *pname = "main";
4085 if (PL_tokenbuf[2] == 'D')
4086 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
4087 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
4090 GvIOp(gv) = newIO();
4091 IoIFP(GvIOp(gv)) = PL_rsfp;
4092 #if defined(HAS_FCNTL) && defined(F_SETFD)
4094 int fd = PerlIO_fileno(PL_rsfp);
4095 fcntl(fd,F_SETFD,fd >= 3);
4098 /* Mark this internal pseudo-handle as clean */
4099 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
4101 IoTYPE(GvIOp(gv)) = IoTYPE_PIPE;
4102 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
4103 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
4105 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
4106 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
4107 /* if the script was opened in binmode, we need to revert
4108 * it to text mode for compatibility; but only iff it has CRs
4109 * XXX this is a questionable hack at best. */
4110 if (PL_bufend-PL_bufptr > 2
4111 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
4114 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
4115 loc = PerlIO_tell(PL_rsfp);
4116 (void)PerlIO_seek(PL_rsfp, 0L, 0);
4119 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
4121 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
4122 #endif /* NETWARE */
4123 #ifdef PERLIO_IS_STDIO /* really? */
4124 # if defined(__BORLANDC__)
4125 /* XXX see note in do_binmode() */
4126 ((FILE*)PL_rsfp)->flags &= ~_F_BIN;
4130 PerlIO_seek(PL_rsfp, loc, 0);
4134 #ifdef PERLIO_LAYERS
4135 if (UTF && !IN_BYTES)
4136 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
4149 if (PL_expect == XSTATE) {
4156 if (*s == ':' && s[1] == ':') {
4159 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4160 if (!(tmp = keyword(PL_tokenbuf, len)))
4161 Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
4175 LOP(OP_ACCEPT,XTERM);
4181 LOP(OP_ATAN2,XTERM);
4187 LOP(OP_BINMODE,XTERM);
4190 LOP(OP_BLESS,XTERM);
4199 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
4216 if (!PL_cryptseen) {
4217 PL_cryptseen = TRUE;
4221 LOP(OP_CRYPT,XTERM);
4224 LOP(OP_CHMOD,XTERM);
4227 LOP(OP_CHOWN,XTERM);
4230 LOP(OP_CONNECT,XTERM);
4246 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4250 PL_hints |= HINT_BLOCK_SCOPE;
4260 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
4261 LOP(OP_DBMOPEN,XTERM);
4267 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4274 yylval.ival = CopLINE(PL_curcop);
4288 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
4289 UNIBRACK(OP_ENTEREVAL);
4304 case KEY_endhostent:
4310 case KEY_endservent:
4313 case KEY_endprotoent:
4324 yylval.ival = CopLINE(PL_curcop);
4326 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
4328 if ((PL_bufend - p) >= 3 &&
4329 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
4331 else if ((PL_bufend - p) >= 4 &&
4332 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
4335 if (isIDFIRST_lazy_if(p,UTF)) {
4336 p = scan_ident(p, PL_bufend,
4337 PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4341 Perl_croak(aTHX_ "Missing $ on loop variable");
4346 LOP(OP_FORMLINE,XTERM);
4352 LOP(OP_FCNTL,XTERM);
4358 LOP(OP_FLOCK,XTERM);
4367 LOP(OP_GREPSTART, XREF);
4370 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4385 case KEY_getpriority:
4386 LOP(OP_GETPRIORITY,XTERM);
4388 case KEY_getprotobyname:
4391 case KEY_getprotobynumber:
4392 LOP(OP_GPBYNUMBER,XTERM);
4394 case KEY_getprotoent:
4406 case KEY_getpeername:
4407 UNI(OP_GETPEERNAME);
4409 case KEY_gethostbyname:
4412 case KEY_gethostbyaddr:
4413 LOP(OP_GHBYADDR,XTERM);
4415 case KEY_gethostent:
4418 case KEY_getnetbyname:
4421 case KEY_getnetbyaddr:
4422 LOP(OP_GNBYADDR,XTERM);
4427 case KEY_getservbyname:
4428 LOP(OP_GSBYNAME,XTERM);
4430 case KEY_getservbyport:
4431 LOP(OP_GSBYPORT,XTERM);
4433 case KEY_getservent:
4436 case KEY_getsockname:
4437 UNI(OP_GETSOCKNAME);
4439 case KEY_getsockopt:
4440 LOP(OP_GSOCKOPT,XTERM);
4462 yylval.ival = CopLINE(PL_curcop);
4466 LOP(OP_INDEX,XTERM);
4472 LOP(OP_IOCTL,XTERM);
4484 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4516 LOP(OP_LISTEN,XTERM);
4525 s = scan_pat(s,OP_MATCH);
4526 TERM(sublex_start());
4529 LOP(OP_MAPSTART, XREF);
4532 LOP(OP_MKDIR,XTERM);
4535 LOP(OP_MSGCTL,XTERM);
4538 LOP(OP_MSGGET,XTERM);
4541 LOP(OP_MSGRCV,XTERM);
4544 LOP(OP_MSGSND,XTERM);
4550 if (isIDFIRST_lazy_if(s,UTF)) {
4551 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
4552 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
4554 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
4555 if (!PL_in_my_stash) {
4558 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
4566 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4573 if (PL_expect != XSTATE)
4574 yyerror("\"no\" not allowed in expression");
4575 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4576 s = force_version(s, FALSE);
4581 if (*s == '(' || (s = skipspace(s), *s == '('))
4588 if (isIDFIRST_lazy_if(s,UTF)) {
4590 for (d = s; isALNUM_lazy_if(d,UTF); d++) ;
4592 if (strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE))
4593 Perl_warner(aTHX_ WARN_PRECEDENCE,
4594 "Precedence problem: open %.*s should be open(%.*s)",
4600 yylval.ival = OP_OR;
4610 LOP(OP_OPEN_DIR,XTERM);
4613 checkcomma(s,PL_tokenbuf,"filehandle");
4617 checkcomma(s,PL_tokenbuf,"filehandle");
4636 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4640 LOP(OP_PIPE_OP,XTERM);
4643 s = scan_str(s,FALSE,FALSE);
4645 missingterm((char*)0);
4646 yylval.ival = OP_CONST;
4647 TERM(sublex_start());
4653 s = scan_str(s,FALSE,FALSE);
4655 missingterm((char*)0);
4657 if (SvCUR(PL_lex_stuff)) {
4660 d = SvPV_force(PL_lex_stuff, len);
4663 for (; isSPACE(*d) && len; --len, ++d) ;
4666 if (!warned && ckWARN(WARN_QW)) {
4667 for (; !isSPACE(*d) && len; --len, ++d) {
4669 Perl_warner(aTHX_ WARN_QW,
4670 "Possible attempt to separate words with commas");
4673 else if (*d == '#') {
4674 Perl_warner(aTHX_ WARN_QW,
4675 "Possible attempt to put comments in qw() list");
4681 for (; !isSPACE(*d) && len; --len, ++d) ;
4683 sv = newSVpvn(b, d-b);
4684 if (DO_UTF8(PL_lex_stuff))
4686 words = append_elem(OP_LIST, words,
4687 newSVOP(OP_CONST, 0, tokeq(sv)));
4691 PL_nextval[PL_nexttoke].opval = words;
4696 SvREFCNT_dec(PL_lex_stuff);
4697 PL_lex_stuff = Nullsv;
4703 s = scan_str(s,FALSE,FALSE);
4705 missingterm((char*)0);
4706 yylval.ival = OP_STRINGIFY;
4707 if (SvIVX(PL_lex_stuff) == '\'')
4708 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
4709 TERM(sublex_start());
4712 s = scan_pat(s,OP_QR);
4713 TERM(sublex_start());
4716 s = scan_str(s,FALSE,FALSE);
4718 missingterm((char*)0);
4719 yylval.ival = OP_BACKTICK;
4721 TERM(sublex_start());
4729 s = force_version(s, FALSE);
4731 else if (*s != 'v' || !isDIGIT(s[1])
4732 || (s = force_version(s, TRUE), *s == 'v'))
4734 *PL_tokenbuf = '\0';
4735 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4736 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
4737 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
4739 yyerror("<> should be quotes");
4747 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4751 LOP(OP_RENAME,XTERM);
4760 LOP(OP_RINDEX,XTERM);
4783 LOP(OP_REVERSE,XTERM);
4794 TERM(sublex_start());
4796 TOKEN(1); /* force error */
4805 LOP(OP_SELECT,XTERM);
4811 LOP(OP_SEMCTL,XTERM);
4814 LOP(OP_SEMGET,XTERM);
4817 LOP(OP_SEMOP,XTERM);
4823 LOP(OP_SETPGRP,XTERM);
4825 case KEY_setpriority:
4826 LOP(OP_SETPRIORITY,XTERM);
4828 case KEY_sethostent:
4834 case KEY_setservent:
4837 case KEY_setprotoent:
4847 LOP(OP_SEEKDIR,XTERM);
4849 case KEY_setsockopt:
4850 LOP(OP_SSOCKOPT,XTERM);
4856 LOP(OP_SHMCTL,XTERM);
4859 LOP(OP_SHMGET,XTERM);
4862 LOP(OP_SHMREAD,XTERM);
4865 LOP(OP_SHMWRITE,XTERM);
4868 LOP(OP_SHUTDOWN,XTERM);
4877 LOP(OP_SOCKET,XTERM);
4879 case KEY_socketpair:
4880 LOP(OP_SOCKPAIR,XTERM);
4883 checkcomma(s,PL_tokenbuf,"subroutine name");
4885 if (*s == ';' || *s == ')') /* probably a close */
4886 Perl_croak(aTHX_ "sort is now a reserved word");
4888 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4892 LOP(OP_SPLIT,XTERM);
4895 LOP(OP_SPRINTF,XTERM);
4898 LOP(OP_SPLICE,XTERM);
4913 LOP(OP_SUBSTR,XTERM);
4919 char tmpbuf[sizeof PL_tokenbuf];
4920 SSize_t tboffset = 0;
4921 expectation attrful;
4922 bool have_name, have_proto, bad_proto;
4927 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
4928 (*s == ':' && s[1] == ':'))
4931 attrful = XATTRBLOCK;
4932 /* remember buffer pos'n for later force_word */
4933 tboffset = s - PL_oldbufptr;
4934 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4935 if (strchr(tmpbuf, ':'))
4936 sv_setpv(PL_subname, tmpbuf);
4938 sv_setsv(PL_subname,PL_curstname);
4939 sv_catpvn(PL_subname,"::",2);
4940 sv_catpvn(PL_subname,tmpbuf,len);
4947 Perl_croak(aTHX_ "Missing name in \"my sub\"");
4948 PL_expect = XTERMBLOCK;
4949 attrful = XATTRTERM;
4950 sv_setpv(PL_subname,"?");
4954 if (key == KEY_format) {
4956 PL_lex_formbrack = PL_lex_brackets + 1;
4958 (void) force_word(PL_oldbufptr + tboffset, WORD,
4963 /* Look for a prototype */
4967 s = scan_str(s,FALSE,FALSE);
4969 Perl_croak(aTHX_ "Prototype not terminated");
4970 /* strip spaces and check for bad characters */
4971 d = SvPVX(PL_lex_stuff);
4974 for (p = d; *p; ++p) {
4977 if (!strchr("$@%*;[]&\\", *p))
4982 if (bad_proto && ckWARN(WARN_SYNTAX))
4983 Perl_warner(aTHX_ WARN_SYNTAX,
4984 "Illegal character in prototype for %s : %s",
4985 SvPVX(PL_subname), d);
4986 SvCUR(PL_lex_stuff) = tmp;
4994 if (*s == ':' && s[1] != ':')
4995 PL_expect = attrful;
4998 PL_nextval[PL_nexttoke].opval =
4999 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
5000 PL_lex_stuff = Nullsv;
5004 sv_setpv(PL_subname,"__ANON__");
5007 (void) force_word(PL_oldbufptr + tboffset, WORD,
5016 LOP(OP_SYSTEM,XREF);
5019 LOP(OP_SYMLINK,XTERM);
5022 LOP(OP_SYSCALL,XTERM);
5025 LOP(OP_SYSOPEN,XTERM);
5028 LOP(OP_SYSSEEK,XTERM);
5031 LOP(OP_SYSREAD,XTERM);
5034 LOP(OP_SYSWRITE,XTERM);
5038 TERM(sublex_start());
5059 LOP(OP_TRUNCATE,XTERM);
5071 yylval.ival = CopLINE(PL_curcop);
5075 yylval.ival = CopLINE(PL_curcop);
5079 LOP(OP_UNLINK,XTERM);
5085 LOP(OP_UNPACK,XTERM);
5088 LOP(OP_UTIME,XTERM);
5094 LOP(OP_UNSHIFT,XTERM);
5097 if (PL_expect != XSTATE)
5098 yyerror("\"use\" not allowed in expression");
5100 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
5101 s = force_version(s, TRUE);
5102 if (*s == ';' || (s = skipspace(s), *s == ';')) {
5103 PL_nextval[PL_nexttoke].opval = Nullop;
5106 else if (*s == 'v') {
5107 s = force_word(s,WORD,FALSE,TRUE,FALSE);
5108 s = force_version(s, FALSE);
5112 s = force_word(s,WORD,FALSE,TRUE,FALSE);
5113 s = force_version(s, FALSE);
5125 yylval.ival = CopLINE(PL_curcop);
5129 PL_hints |= HINT_BLOCK_SCOPE;
5136 LOP(OP_WAITPID,XTERM);
5145 ctl_l[0] = toCTRL('L');
5147 gv_fetchpv(ctl_l,TRUE, SVt_PV);
5150 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
5155 if (PL_expect == XOPERATOR)
5161 yylval.ival = OP_XOR;
5166 TERM(sublex_start());
5171 #pragma segment Main
5175 S_pending_ident(pTHX)
5179 /* pit holds the identifier we read and pending_ident is reset */
5180 char pit = PL_pending_ident;
5181 PL_pending_ident = 0;
5183 DEBUG_T({ PerlIO_printf(Perl_debug_log,
5184 "### Tokener saw identifier '%s'\n", PL_tokenbuf); });
5186 /* if we're in a my(), we can't allow dynamics here.
5187 $foo'bar has already been turned into $foo::bar, so
5188 just check for colons.
5190 if it's a legal name, the OP is a PADANY.
5193 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
5194 if (strchr(PL_tokenbuf,':'))
5195 yyerror(Perl_form(aTHX_ "No package name allowed for "
5196 "variable %s in \"our\"",
5198 tmp = pad_allocmy(PL_tokenbuf);
5201 if (strchr(PL_tokenbuf,':'))
5202 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
5204 yylval.opval = newOP(OP_PADANY, 0);
5205 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
5211 build the ops for accesses to a my() variable.
5213 Deny my($a) or my($b) in a sort block, *if* $a or $b is
5214 then used in a comparison. This catches most, but not
5215 all cases. For instance, it catches
5216 sort { my($a); $a <=> $b }
5218 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
5219 (although why you'd do that is anyone's guess).
5222 if (!strchr(PL_tokenbuf,':')) {
5223 #ifdef USE_5005THREADS
5224 /* Check for single character per-thread SVs */
5225 if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
5226 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
5227 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
5229 yylval.opval = newOP(OP_THREADSV, 0);
5230 yylval.opval->op_targ = tmp;
5233 #endif /* USE_5005THREADS */
5234 if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
5235 SV *namesv = AvARRAY(PL_comppad_name)[tmp];
5236 /* might be an "our" variable" */
5237 if (SvFLAGS(namesv) & SVpad_OUR) {
5238 /* build ops for a bareword */
5239 SV *sym = newSVpv(HvNAME(GvSTASH(namesv)),0);
5240 sv_catpvn(sym, "::", 2);
5241 sv_catpv(sym, PL_tokenbuf+1);
5242 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
5243 yylval.opval->op_private = OPpCONST_ENTERED;
5244 gv_fetchpv(SvPVX(sym),
5246 ? (GV_ADDMULTI | GV_ADDINEVAL)
5249 ((PL_tokenbuf[0] == '$') ? SVt_PV
5250 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5255 /* if it's a sort block and they're naming $a or $b */
5256 if (PL_last_lop_op == OP_SORT &&
5257 PL_tokenbuf[0] == '$' &&
5258 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
5261 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
5262 d < PL_bufend && *d != '\n';
5265 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
5266 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
5272 yylval.opval = newOP(OP_PADANY, 0);
5273 yylval.opval->op_targ = tmp;
5279 Whine if they've said @foo in a doublequoted string,
5280 and @foo isn't a variable we can find in the symbol
5283 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
5284 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
5285 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
5286 && ckWARN(WARN_AMBIGUOUS))
5288 /* Downgraded from fatal to warning 20000522 mjd */
5289 Perl_warner(aTHX_ WARN_AMBIGUOUS,
5290 "Possible unintended interpolation of %s in string",
5295 /* build ops for a bareword */
5296 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
5297 yylval.opval->op_private = OPpCONST_ENTERED;
5298 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
5299 ((PL_tokenbuf[0] == '$') ? SVt_PV
5300 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5306 Perl_keyword(pTHX_ register char *d, I32 len)
5311 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
5312 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
5313 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
5314 if (strEQ(d,"__DATA__")) return KEY___DATA__;
5315 if (strEQ(d,"__END__")) return KEY___END__;
5319 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
5324 if (strEQ(d,"and")) return -KEY_and;
5325 if (strEQ(d,"abs")) return -KEY_abs;
5328 if (strEQ(d,"alarm")) return -KEY_alarm;
5329 if (strEQ(d,"atan2")) return -KEY_atan2;
5332 if (strEQ(d,"accept")) return -KEY_accept;
5337 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
5340 if (strEQ(d,"bless")) return -KEY_bless;
5341 if (strEQ(d,"bind")) return -KEY_bind;
5342 if (strEQ(d,"binmode")) return -KEY_binmode;
5345 if (strEQ(d,"CORE")) return -KEY_CORE;
5346 if (strEQ(d,"CHECK")) return KEY_CHECK;
5351 if (strEQ(d,"cmp")) return -KEY_cmp;
5352 if (strEQ(d,"chr")) return -KEY_chr;
5353 if (strEQ(d,"cos")) return -KEY_cos;
5356 if (strEQ(d,"chop")) return -KEY_chop;
5359 if (strEQ(d,"close")) return -KEY_close;
5360 if (strEQ(d,"chdir")) return -KEY_chdir;
5361 if (strEQ(d,"chomp")) return -KEY_chomp;
5362 if (strEQ(d,"chmod")) return -KEY_chmod;
5363 if (strEQ(d,"chown")) return -KEY_chown;
5364 if (strEQ(d,"crypt")) return -KEY_crypt;
5367 if (strEQ(d,"chroot")) return -KEY_chroot;
5368 if (strEQ(d,"caller")) return -KEY_caller;
5371 if (strEQ(d,"connect")) return -KEY_connect;
5374 if (strEQ(d,"closedir")) return -KEY_closedir;
5375 if (strEQ(d,"continue")) return -KEY_continue;
5380 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
5385 if (strEQ(d,"do")) return KEY_do;
5388 if (strEQ(d,"die")) return -KEY_die;
5391 if (strEQ(d,"dump")) return -KEY_dump;
5394 if (strEQ(d,"delete")) return KEY_delete;
5397 if (strEQ(d,"defined")) return KEY_defined;
5398 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
5401 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
5406 if (strEQ(d,"END")) return KEY_END;
5411 if (strEQ(d,"eq")) return -KEY_eq;
5414 if (strEQ(d,"eof")) return -KEY_eof;
5415 if (strEQ(d,"exp")) return -KEY_exp;
5418 if (strEQ(d,"else")) return KEY_else;
5419 if (strEQ(d,"exit")) return -KEY_exit;
5420 if (strEQ(d,"eval")) return KEY_eval;
5421 if (strEQ(d,"exec")) return -KEY_exec;
5422 if (strEQ(d,"each")) return -KEY_each;
5425 if (strEQ(d,"elsif")) return KEY_elsif;
5428 if (strEQ(d,"exists")) return KEY_exists;
5429 if (strEQ(d,"elseif")) Perl_warn(aTHX_ "elseif should be elsif");
5432 if (strEQ(d,"endgrent")) return -KEY_endgrent;
5433 if (strEQ(d,"endpwent")) return -KEY_endpwent;
5436 if (strEQ(d,"endnetent")) return -KEY_endnetent;
5439 if (strEQ(d,"endhostent")) return -KEY_endhostent;
5440 if (strEQ(d,"endservent")) return -KEY_endservent;
5443 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
5450 if (strEQ(d,"for")) return KEY_for;
5453 if (strEQ(d,"fork")) return -KEY_fork;
5456 if (strEQ(d,"fcntl")) return -KEY_fcntl;
5457 if (strEQ(d,"flock")) return -KEY_flock;
5460 if (strEQ(d,"format")) return KEY_format;
5461 if (strEQ(d,"fileno")) return -KEY_fileno;
5464 if (strEQ(d,"foreach")) return KEY_foreach;
5467 if (strEQ(d,"formline")) return -KEY_formline;
5472 if (strnEQ(d,"get",3)) {
5477 if (strEQ(d,"ppid")) return -KEY_getppid;
5478 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
5481 if (strEQ(d,"pwent")) return -KEY_getpwent;
5482 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
5483 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
5486 if (strEQ(d,"peername")) return -KEY_getpeername;
5487 if (strEQ(d,"protoent")) return -KEY_getprotoent;
5488 if (strEQ(d,"priority")) return -KEY_getpriority;
5491 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
5494 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
5498 else if (*d == 'h') {
5499 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
5500 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
5501 if (strEQ(d,"hostent")) return -KEY_gethostent;
5503 else if (*d == 'n') {
5504 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
5505 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
5506 if (strEQ(d,"netent")) return -KEY_getnetent;
5508 else if (*d == 's') {
5509 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
5510 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
5511 if (strEQ(d,"servent")) return -KEY_getservent;
5512 if (strEQ(d,"sockname")) return -KEY_getsockname;
5513 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
5515 else if (*d == 'g') {
5516 if (strEQ(d,"grent")) return -KEY_getgrent;
5517 if (strEQ(d,"grnam")) return -KEY_getgrnam;
5518 if (strEQ(d,"grgid")) return -KEY_getgrgid;
5520 else if (*d == 'l') {
5521 if (strEQ(d,"login")) return -KEY_getlogin;
5523 else if (strEQ(d,"c")) return -KEY_getc;
5528 if (strEQ(d,"gt")) return -KEY_gt;
5529 if (strEQ(d,"ge")) return -KEY_ge;
5532 if (strEQ(d,"grep")) return KEY_grep;
5533 if (strEQ(d,"goto")) return KEY_goto;
5534 if (strEQ(d,"glob")) return KEY_glob;
5537 if (strEQ(d,"gmtime")) return -KEY_gmtime;
5542 if (strEQ(d,"hex")) return -KEY_hex;
5545 if (strEQ(d,"INIT")) return KEY_INIT;
5550 if (strEQ(d,"if")) return KEY_if;
5553 if (strEQ(d,"int")) return -KEY_int;
5556 if (strEQ(d,"index")) return -KEY_index;
5557 if (strEQ(d,"ioctl")) return -KEY_ioctl;
5562 if (strEQ(d,"join")) return -KEY_join;
5566 if (strEQ(d,"keys")) return -KEY_keys;
5567 if (strEQ(d,"kill")) return -KEY_kill;
5573 if (strEQ(d,"lt")) return -KEY_lt;
5574 if (strEQ(d,"le")) return -KEY_le;
5575 if (strEQ(d,"lc")) return -KEY_lc;
5578 if (strEQ(d,"log")) return -KEY_log;
5581 if (strEQ(d,"last")) return KEY_last;
5582 if (strEQ(d,"link")) return -KEY_link;
5583 if (strEQ(d,"lock")) return -KEY_lock;
5586 if (strEQ(d,"local")) return KEY_local;
5587 if (strEQ(d,"lstat")) return -KEY_lstat;
5590 if (strEQ(d,"length")) return -KEY_length;
5591 if (strEQ(d,"listen")) return -KEY_listen;
5594 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
5597 if (strEQ(d,"localtime")) return -KEY_localtime;
5603 case 1: return KEY_m;
5605 if (strEQ(d,"my")) return KEY_my;
5608 if (strEQ(d,"map")) return KEY_map;
5611 if (strEQ(d,"mkdir")) return -KEY_mkdir;
5614 if (strEQ(d,"msgctl")) return -KEY_msgctl;
5615 if (strEQ(d,"msgget")) return -KEY_msgget;
5616 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
5617 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
5622 if (strEQ(d,"next")) return KEY_next;
5623 if (strEQ(d,"ne")) return -KEY_ne;
5624 if (strEQ(d,"not")) return -KEY_not;
5625 if (strEQ(d,"no")) return KEY_no;
5630 if (strEQ(d,"or")) return -KEY_or;
5633 if (strEQ(d,"ord")) return -KEY_ord;
5634 if (strEQ(d,"oct")) return -KEY_oct;
5635 if (strEQ(d,"our")) return KEY_our;
5638 if (strEQ(d,"open")) return -KEY_open;
5641 if (strEQ(d,"opendir")) return -KEY_opendir;
5648 if (strEQ(d,"pop")) return -KEY_pop;
5649 if (strEQ(d,"pos")) return KEY_pos;
5652 if (strEQ(d,"push")) return -KEY_push;
5653 if (strEQ(d,"pack")) return -KEY_pack;
5654 if (strEQ(d,"pipe")) return -KEY_pipe;
5657 if (strEQ(d,"print")) return KEY_print;
5660 if (strEQ(d,"printf")) return KEY_printf;
5663 if (strEQ(d,"package")) return KEY_package;
5666 if (strEQ(d,"prototype")) return KEY_prototype;
5671 if (strEQ(d,"q")) return KEY_q;
5672 if (strEQ(d,"qr")) return KEY_qr;
5673 if (strEQ(d,"qq")) return KEY_qq;
5674 if (strEQ(d,"qw")) return KEY_qw;
5675 if (strEQ(d,"qx")) return KEY_qx;
5677 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
5682 if (strEQ(d,"ref")) return -KEY_ref;
5685 if (strEQ(d,"read")) return -KEY_read;
5686 if (strEQ(d,"rand")) return -KEY_rand;
5687 if (strEQ(d,"recv")) return -KEY_recv;
5688 if (strEQ(d,"redo")) return KEY_redo;
5691 if (strEQ(d,"rmdir")) return -KEY_rmdir;
5692 if (strEQ(d,"reset")) return -KEY_reset;
5695 if (strEQ(d,"return")) return KEY_return;
5696 if (strEQ(d,"rename")) return -KEY_rename;
5697 if (strEQ(d,"rindex")) return -KEY_rindex;
5700 if (strEQ(d,"require")) return KEY_require;
5701 if (strEQ(d,"reverse")) return -KEY_reverse;
5702 if (strEQ(d,"readdir")) return -KEY_readdir;
5705 if (strEQ(d,"readlink")) return -KEY_readlink;
5706 if (strEQ(d,"readline")) return -KEY_readline;
5707 if (strEQ(d,"readpipe")) return -KEY_readpipe;
5710 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
5716 case 0: return KEY_s;
5718 if (strEQ(d,"scalar")) return KEY_scalar;
5723 if (strEQ(d,"seek")) return -KEY_seek;
5724 if (strEQ(d,"send")) return -KEY_send;
5727 if (strEQ(d,"semop")) return -KEY_semop;
5730 if (strEQ(d,"select")) return -KEY_select;
5731 if (strEQ(d,"semctl")) return -KEY_semctl;
5732 if (strEQ(d,"semget")) return -KEY_semget;
5735 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
5736 if (strEQ(d,"seekdir")) return -KEY_seekdir;
5739 if (strEQ(d,"setpwent")) return -KEY_setpwent;
5740 if (strEQ(d,"setgrent")) return -KEY_setgrent;
5743 if (strEQ(d,"setnetent")) return -KEY_setnetent;
5746 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
5747 if (strEQ(d,"sethostent")) return -KEY_sethostent;
5748 if (strEQ(d,"setservent")) return -KEY_setservent;
5751 if (strEQ(d,"setpriority")) return -KEY_setpriority;
5752 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
5759 if (strEQ(d,"shift")) return -KEY_shift;
5762 if (strEQ(d,"shmctl")) return -KEY_shmctl;
5763 if (strEQ(d,"shmget")) return -KEY_shmget;
5766 if (strEQ(d,"shmread")) return -KEY_shmread;
5769 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
5770 if (strEQ(d,"shutdown")) return -KEY_shutdown;
5775 if (strEQ(d,"sin")) return -KEY_sin;
5778 if (strEQ(d,"sleep")) return -KEY_sleep;
5781 if (strEQ(d,"sort")) return KEY_sort;
5782 if (strEQ(d,"socket")) return -KEY_socket;
5783 if (strEQ(d,"socketpair")) return -KEY_socketpair;
5786 if (strEQ(d,"split")) return KEY_split;
5787 if (strEQ(d,"sprintf")) return -KEY_sprintf;
5788 if (strEQ(d,"splice")) return -KEY_splice;
5791 if (strEQ(d,"sqrt")) return -KEY_sqrt;
5794 if (strEQ(d,"srand")) return -KEY_srand;
5797 if (strEQ(d,"stat")) return -KEY_stat;
5798 if (strEQ(d,"study")) return KEY_study;
5801 if (strEQ(d,"substr")) return -KEY_substr;
5802 if (strEQ(d,"sub")) return KEY_sub;
5807 if (strEQ(d,"system")) return -KEY_system;
5810 if (strEQ(d,"symlink")) return -KEY_symlink;
5811 if (strEQ(d,"syscall")) return -KEY_syscall;
5812 if (strEQ(d,"sysopen")) return -KEY_sysopen;
5813 if (strEQ(d,"sysread")) return -KEY_sysread;
5814 if (strEQ(d,"sysseek")) return -KEY_sysseek;
5817 if (strEQ(d,"syswrite")) return -KEY_syswrite;
5826 if (strEQ(d,"tr")) return KEY_tr;
5829 if (strEQ(d,"tie")) return KEY_tie;
5832 if (strEQ(d,"tell")) return -KEY_tell;
5833 if (strEQ(d,"tied")) return KEY_tied;
5834 if (strEQ(d,"time")) return -KEY_time;
5837 if (strEQ(d,"times")) return -KEY_times;
5840 if (strEQ(d,"telldir")) return -KEY_telldir;
5843 if (strEQ(d,"truncate")) return -KEY_truncate;
5850 if (strEQ(d,"uc")) return -KEY_uc;
5853 if (strEQ(d,"use")) return KEY_use;
5856 if (strEQ(d,"undef")) return KEY_undef;
5857 if (strEQ(d,"until")) return KEY_until;
5858 if (strEQ(d,"untie")) return KEY_untie;
5859 if (strEQ(d,"utime")) return -KEY_utime;
5860 if (strEQ(d,"umask")) return -KEY_umask;
5863 if (strEQ(d,"unless")) return KEY_unless;
5864 if (strEQ(d,"unpack")) return -KEY_unpack;
5865 if (strEQ(d,"unlink")) return -KEY_unlink;
5868 if (strEQ(d,"unshift")) return -KEY_unshift;
5869 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
5874 if (strEQ(d,"values")) return -KEY_values;
5875 if (strEQ(d,"vec")) return -KEY_vec;
5880 if (strEQ(d,"warn")) return -KEY_warn;
5881 if (strEQ(d,"wait")) return -KEY_wait;
5884 if (strEQ(d,"while")) return KEY_while;
5885 if (strEQ(d,"write")) return -KEY_write;
5888 if (strEQ(d,"waitpid")) return -KEY_waitpid;
5891 if (strEQ(d,"wantarray")) return -KEY_wantarray;
5896 if (len == 1) return -KEY_x;
5897 if (strEQ(d,"xor")) return -KEY_xor;
5900 if (len == 1) return KEY_y;
5909 S_checkcomma(pTHX_ register char *s, char *name, char *what)
5913 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
5914 if (ckWARN(WARN_SYNTAX)) {
5916 for (w = s+2; *w && level; w++) {
5923 for (; *w && isSPACE(*w); w++) ;
5924 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
5925 Perl_warner(aTHX_ WARN_SYNTAX,
5926 "%s (...) interpreted as function",name);
5929 while (s < PL_bufend && isSPACE(*s))
5933 while (s < PL_bufend && isSPACE(*s))
5935 if (isIDFIRST_lazy_if(s,UTF)) {
5937 while (isALNUM_lazy_if(s,UTF))
5939 while (s < PL_bufend && isSPACE(*s))
5944 kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
5948 Perl_croak(aTHX_ "No comma allowed after %s", what);
5953 /* Either returns sv, or mortalizes sv and returns a new SV*.
5954 Best used as sv=new_constant(..., sv, ...).
5955 If s, pv are NULL, calls subroutine with one argument,
5956 and type is used with error messages only. */
5959 S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv,
5963 HV *table = GvHV(PL_hintgv); /* ^H */
5967 const char *why1, *why2, *why3;
5969 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
5972 why2 = strEQ(key,"charnames")
5973 ? "(possibly a missing \"use charnames ...\")"
5975 msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
5976 (type ? type: "undef"), why2);
5978 /* This is convoluted and evil ("goto considered harmful")
5979 * but I do not understand the intricacies of all the different
5980 * failure modes of %^H in here. The goal here is to make
5981 * the most probable error message user-friendly. --jhi */
5986 msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
5987 (type ? type: "undef"), why1, why2, why3);
5989 yyerror(SvPVX(msg));
5993 cvp = hv_fetch(table, key, strlen(key), FALSE);
5994 if (!cvp || !SvOK(*cvp)) {
5997 why3 = "} is not defined";
6000 sv_2mortal(sv); /* Parent created it permanently */
6003 pv = sv_2mortal(newSVpvn(s, len));
6005 typesv = sv_2mortal(newSVpv(type, 0));
6007 typesv = &PL_sv_undef;
6009 PUSHSTACKi(PERLSI_OVERLOAD);
6021 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
6025 /* Check the eval first */
6026 if (!PL_in_eval && SvTRUE(ERRSV)) {
6028 sv_catpv(ERRSV, "Propagated");
6029 yyerror(SvPV(ERRSV, n_a)); /* Duplicates the message inside eval */
6031 res = SvREFCNT_inc(sv);
6035 (void)SvREFCNT_inc(res);
6044 why1 = "Call to &{$^H{";
6046 why3 = "}} did not return a defined value";
6055 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
6057 register char *d = dest;
6058 register char *e = d + destlen - 3; /* two-character token, ending NUL */
6061 Perl_croak(aTHX_ ident_too_long);
6062 if (isALNUM(*s)) /* UTF handled below */
6064 else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) {
6069 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
6073 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
6074 char *t = s + UTF8SKIP(s);
6075 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
6077 if (d + (t - s) > e)
6078 Perl_croak(aTHX_ ident_too_long);
6079 Copy(s, d, t - s, char);
6092 S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
6102 e = d + destlen - 3; /* two-character token, ending NUL */
6104 while (isDIGIT(*s)) {
6106 Perl_croak(aTHX_ ident_too_long);
6113 Perl_croak(aTHX_ ident_too_long);
6114 if (isALNUM(*s)) /* UTF handled below */
6116 else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
6121 else if (*s == ':' && s[1] == ':') {
6125 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
6126 char *t = s + UTF8SKIP(s);
6127 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
6129 if (d + (t - s) > e)
6130 Perl_croak(aTHX_ ident_too_long);
6131 Copy(s, d, t - s, char);
6142 if (PL_lex_state != LEX_NORMAL)
6143 PL_lex_state = LEX_INTERPENDMAYBE;
6146 if (*s == '$' && s[1] &&
6147 (isALNUM_lazy_if(s+1,UTF) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
6160 if (*d == '^' && *s && isCONTROLVAR(*s)) {
6165 if (isSPACE(s[-1])) {
6168 if (!SPACE_OR_TAB(ch)) {
6174 if (isIDFIRST_lazy_if(d,UTF)) {
6178 while ((e < send && isALNUM_lazy_if(e,UTF)) || *e == ':') {
6180 while (e < send && UTF8_IS_CONTINUED(*e) && is_utf8_mark((U8*)e))
6183 Copy(s, d, e - s, char);
6188 while ((isALNUM(*s) || *s == ':') && d < e)
6191 Perl_croak(aTHX_ ident_too_long);
6194 while (s < send && SPACE_OR_TAB(*s)) s++;
6195 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
6196 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
6197 const char *brack = *s == '[' ? "[...]" : "{...}";
6198 Perl_warner(aTHX_ WARN_AMBIGUOUS,
6199 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
6200 funny, dest, brack, funny, dest, brack);
6203 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
6207 /* Handle extended ${^Foo} variables
6208 * 1999-02-27 mjd-perl-patch@plover.com */
6209 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
6213 while (isALNUM(*s) && d < e) {
6217 Perl_croak(aTHX_ ident_too_long);
6222 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
6223 PL_lex_state = LEX_INTERPEND;
6226 if (PL_lex_state == LEX_NORMAL) {
6227 if (ckWARN(WARN_AMBIGUOUS) &&
6228 (keyword(dest, d - dest) || get_cv(dest, FALSE)))
6230 Perl_warner(aTHX_ WARN_AMBIGUOUS,
6231 "Ambiguous use of %c{%s} resolved to %c%s",
6232 funny, dest, funny, dest);
6237 s = bracket; /* let the parser handle it */
6241 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
6242 PL_lex_state = LEX_INTERPEND;
6247 Perl_pmflag(pTHX_ U16 *pmfl, int ch)
6252 *pmfl |= PMf_GLOBAL;
6254 *pmfl |= PMf_CONTINUE;
6258 *pmfl |= PMf_MULTILINE;
6260 *pmfl |= PMf_SINGLELINE;
6262 *pmfl |= PMf_EXTENDED;
6266 S_scan_pat(pTHX_ char *start, I32 type)
6271 s = scan_str(start,FALSE,FALSE);
6273 Perl_croak(aTHX_ "Search pattern not terminated");
6275 pm = (PMOP*)newPMOP(type, 0);
6276 if (PL_multi_open == '?')
6277 pm->op_pmflags |= PMf_ONCE;
6279 while (*s && strchr("iomsx", *s))
6280 pmflag(&pm->op_pmflags,*s++);
6283 while (*s && strchr("iogcmsx", *s))
6284 pmflag(&pm->op_pmflags,*s++);
6286 pm->op_pmpermflags = pm->op_pmflags;
6288 PL_lex_op = (OP*)pm;
6289 yylval.ival = OP_MATCH;
6294 S_scan_subst(pTHX_ char *start)
6301 yylval.ival = OP_NULL;
6303 s = scan_str(start,FALSE,FALSE);
6306 Perl_croak(aTHX_ "Substitution pattern not terminated");
6308 if (s[-1] == PL_multi_open)
6311 first_start = PL_multi_start;
6312 s = scan_str(s,FALSE,FALSE);
6315 SvREFCNT_dec(PL_lex_stuff);
6316 PL_lex_stuff = Nullsv;
6318 Perl_croak(aTHX_ "Substitution replacement not terminated");
6320 PL_multi_start = first_start; /* so whole substitution is taken together */
6322 pm = (PMOP*)newPMOP(OP_SUBST, 0);
6328 else if (strchr("iogcmsx", *s))
6329 pmflag(&pm->op_pmflags,*s++);
6336 PL_sublex_info.super_bufptr = s;
6337 PL_sublex_info.super_bufend = PL_bufend;
6339 pm->op_pmflags |= PMf_EVAL;
6340 repl = newSVpvn("",0);
6342 sv_catpv(repl, es ? "eval " : "do ");
6343 sv_catpvn(repl, "{ ", 2);
6344 sv_catsv(repl, PL_lex_repl);
6345 sv_catpvn(repl, " };", 2);
6347 SvREFCNT_dec(PL_lex_repl);
6351 pm->op_pmpermflags = pm->op_pmflags;
6352 PL_lex_op = (OP*)pm;
6353 yylval.ival = OP_SUBST;
6358 S_scan_trans(pTHX_ char *start)
6367 yylval.ival = OP_NULL;
6369 s = scan_str(start,FALSE,FALSE);
6371 Perl_croak(aTHX_ "Transliteration pattern not terminated");
6372 if (s[-1] == PL_multi_open)
6375 s = scan_str(s,FALSE,FALSE);
6378 SvREFCNT_dec(PL_lex_stuff);
6379 PL_lex_stuff = Nullsv;
6381 Perl_croak(aTHX_ "Transliteration replacement not terminated");
6384 complement = del = squash = 0;
6385 while (strchr("cds", *s)) {
6387 complement = OPpTRANS_COMPLEMENT;
6389 del = OPpTRANS_DELETE;
6391 squash = OPpTRANS_SQUASH;
6395 New(803, tbl, complement&&!del?258:256, short);
6396 o = newPVOP(OP_TRANS, 0, (char*)tbl);
6397 o->op_private = del|squash|complement|
6398 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
6399 (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0);
6402 yylval.ival = OP_TRANS;
6407 S_scan_heredoc(pTHX_ register char *s)
6410 I32 op_type = OP_SCALAR;
6417 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
6421 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
6424 for (peek = s; SPACE_OR_TAB(*peek); peek++) ;
6425 if (*peek && strchr("`'\"",*peek)) {
6428 s = delimcpy(d, e, s, PL_bufend, term, &len);
6438 if (!isALNUM_lazy_if(s,UTF))
6439 deprecate("bare << to mean <<\"\"");
6440 for (; isALNUM_lazy_if(s,UTF); s++) {
6445 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
6446 Perl_croak(aTHX_ "Delimiter for here document is too long");
6449 len = d - PL_tokenbuf;
6450 #ifndef PERL_STRICT_CR
6451 d = strchr(s, '\r');
6455 while (s < PL_bufend) {
6461 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
6470 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6475 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
6476 herewas = newSVpvn(s,PL_bufend-s);
6478 s--, herewas = newSVpvn(s,d-s);
6479 s += SvCUR(herewas);
6481 tmpstr = NEWSV(87,79);
6482 sv_upgrade(tmpstr, SVt_PVIV);
6487 else if (term == '`') {
6488 op_type = OP_BACKTICK;
6489 SvIVX(tmpstr) = '\\';
6493 PL_multi_start = CopLINE(PL_curcop);
6494 PL_multi_open = PL_multi_close = '<';
6495 term = *PL_tokenbuf;
6496 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
6497 char *bufptr = PL_sublex_info.super_bufptr;
6498 char *bufend = PL_sublex_info.super_bufend;
6499 char *olds = s - SvCUR(herewas);
6500 s = strchr(bufptr, '\n');
6504 while (s < bufend &&
6505 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6507 CopLINE_inc(PL_curcop);
6510 CopLINE_set(PL_curcop, PL_multi_start);
6511 missingterm(PL_tokenbuf);
6513 sv_setpvn(herewas,bufptr,d-bufptr+1);
6514 sv_setpvn(tmpstr,d+1,s-d);
6516 sv_catpvn(herewas,s,bufend-s);
6517 (void)strcpy(bufptr,SvPVX(herewas));
6524 while (s < PL_bufend &&
6525 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6527 CopLINE_inc(PL_curcop);
6529 if (s >= PL_bufend) {
6530 CopLINE_set(PL_curcop, PL_multi_start);
6531 missingterm(PL_tokenbuf);
6533 sv_setpvn(tmpstr,d+1,s-d);
6535 CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
6537 sv_catpvn(herewas,s,PL_bufend-s);
6538 sv_setsv(PL_linestr,herewas);
6539 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
6540 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6541 PL_last_lop = PL_last_uni = Nullch;
6544 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
6545 while (s >= PL_bufend) { /* multiple line string? */
6547 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6548 CopLINE_set(PL_curcop, PL_multi_start);
6549 missingterm(PL_tokenbuf);
6551 CopLINE_inc(PL_curcop);
6552 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6553 PL_last_lop = PL_last_uni = Nullch;
6554 #ifndef PERL_STRICT_CR
6555 if (PL_bufend - PL_linestart >= 2) {
6556 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
6557 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
6559 PL_bufend[-2] = '\n';
6561 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6563 else if (PL_bufend[-1] == '\r')
6564 PL_bufend[-1] = '\n';
6566 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
6567 PL_bufend[-1] = '\n';
6569 if (PERLDB_LINE && PL_curstash != PL_debstash) {
6570 SV *sv = NEWSV(88,0);
6572 sv_upgrade(sv, SVt_PVMG);
6573 sv_setsv(sv,PL_linestr);
6576 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop),sv);
6578 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
6581 sv_catsv(PL_linestr,herewas);
6582 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6586 sv_catsv(tmpstr,PL_linestr);
6591 PL_multi_end = CopLINE(PL_curcop);
6592 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
6593 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
6594 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
6596 SvREFCNT_dec(herewas);
6597 if (UTF && !IN_BYTES && is_utf8_string((U8*)SvPVX(tmpstr), SvCUR(tmpstr)))
6599 PL_lex_stuff = tmpstr;
6600 yylval.ival = op_type;
6605 takes: current position in input buffer
6606 returns: new position in input buffer
6607 side-effects: yylval and lex_op are set.
6612 <FH> read from filehandle
6613 <pkg::FH> read from package qualified filehandle
6614 <pkg'FH> read from package qualified filehandle
6615 <$fh> read from filehandle in $fh
6621 S_scan_inputsymbol(pTHX_ char *start)
6623 register char *s = start; /* current position in buffer */
6629 d = PL_tokenbuf; /* start of temp holding space */
6630 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
6631 end = strchr(s, '\n');
6634 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
6636 /* die if we didn't have space for the contents of the <>,
6637 or if it didn't end, or if we see a newline
6640 if (len >= sizeof PL_tokenbuf)
6641 Perl_croak(aTHX_ "Excessively long <> operator");
6643 Perl_croak(aTHX_ "Unterminated <> operator");
6648 Remember, only scalar variables are interpreted as filehandles by
6649 this code. Anything more complex (e.g., <$fh{$num}>) will be
6650 treated as a glob() call.
6651 This code makes use of the fact that except for the $ at the front,
6652 a scalar variable and a filehandle look the same.
6654 if (*d == '$' && d[1]) d++;
6656 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
6657 while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
6660 /* If we've tried to read what we allow filehandles to look like, and
6661 there's still text left, then it must be a glob() and not a getline.
6662 Use scan_str to pull out the stuff between the <> and treat it
6663 as nothing more than a string.
6666 if (d - PL_tokenbuf != len) {
6667 yylval.ival = OP_GLOB;
6669 s = scan_str(start,FALSE,FALSE);
6671 Perl_croak(aTHX_ "Glob not terminated");
6675 bool readline_overriden = FALSE;
6676 GV *gv_readline = Nullgv;
6678 /* we're in a filehandle read situation */
6681 /* turn <> into <ARGV> */
6683 (void)strcpy(d,"ARGV");
6685 /* Check whether readline() is overriden */
6686 if (((gv_readline = gv_fetchpv("readline", FALSE, SVt_PVCV))
6687 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
6689 ((gvp = (GV**)hv_fetch(PL_globalstash, "readline", 8, FALSE))
6690 && (gv_readline = *gvp) != (GV*)&PL_sv_undef
6691 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
6692 readline_overriden = TRUE;
6694 /* if <$fh>, create the ops to turn the variable into a
6700 /* try to find it in the pad for this block, otherwise find
6701 add symbol table ops
6703 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
6704 SV *namesv = AvARRAY(PL_comppad_name)[tmp];
6705 if (SvFLAGS(namesv) & SVpad_OUR) {
6706 SV *sym = sv_2mortal(newSVpv(HvNAME(GvSTASH(namesv)),0));
6707 sv_catpvn(sym, "::", 2);
6713 OP *o = newOP(OP_PADSV, 0);
6715 PL_lex_op = readline_overriden
6716 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
6717 append_elem(OP_LIST, o,
6718 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
6719 : (OP*)newUNOP(OP_READLINE, 0, o);
6728 ? (GV_ADDMULTI | GV_ADDINEVAL)
6731 PL_lex_op = readline_overriden
6732 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
6733 append_elem(OP_LIST,
6734 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
6735 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
6736 : (OP*)newUNOP(OP_READLINE, 0,
6737 newUNOP(OP_RV2SV, 0,
6738 newGVOP(OP_GV, 0, gv)));
6740 PL_lex_op->op_flags |= OPf_SPECIAL;
6741 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
6742 yylval.ival = OP_NULL;
6745 /* If it's none of the above, it must be a literal filehandle
6746 (<Foo::BAR> or <FOO>) so build a simple readline OP */
6748 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
6749 PL_lex_op = readline_overriden
6750 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
6751 append_elem(OP_LIST,
6752 newGVOP(OP_GV, 0, gv),
6753 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
6754 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
6755 yylval.ival = OP_NULL;
6764 takes: start position in buffer
6765 keep_quoted preserve \ on the embedded delimiter(s)
6766 keep_delims preserve the delimiters around the string
6767 returns: position to continue reading from buffer
6768 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
6769 updates the read buffer.
6771 This subroutine pulls a string out of the input. It is called for:
6772 q single quotes q(literal text)
6773 ' single quotes 'literal text'
6774 qq double quotes qq(interpolate $here please)
6775 " double quotes "interpolate $here please"
6776 qx backticks qx(/bin/ls -l)
6777 ` backticks `/bin/ls -l`
6778 qw quote words @EXPORT_OK = qw( func() $spam )
6779 m// regexp match m/this/
6780 s/// regexp substitute s/this/that/
6781 tr/// string transliterate tr/this/that/
6782 y/// string transliterate y/this/that/
6783 ($*@) sub prototypes sub foo ($)
6784 (stuff) sub attr parameters sub foo : attr(stuff)
6785 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
6787 In most of these cases (all but <>, patterns and transliterate)
6788 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
6789 calls scan_str(). s/// makes yylex() call scan_subst() which calls
6790 scan_str(). tr/// and y/// make yylex() call scan_trans() which
6793 It skips whitespace before the string starts, and treats the first
6794 character as the delimiter. If the delimiter is one of ([{< then
6795 the corresponding "close" character )]}> is used as the closing
6796 delimiter. It allows quoting of delimiters, and if the string has
6797 balanced delimiters ([{<>}]) it allows nesting.
6799 On success, the SV with the resulting string is put into lex_stuff or,
6800 if that is already non-NULL, into lex_repl. The second case occurs only
6801 when parsing the RHS of the special constructs s/// and tr/// (y///).
6802 For convenience, the terminating delimiter character is stuffed into
6807 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
6809 SV *sv; /* scalar value: string */
6810 char *tmps; /* temp string, used for delimiter matching */
6811 register char *s = start; /* current position in the buffer */
6812 register char term; /* terminating character */
6813 register char *to; /* current position in the sv's data */
6814 I32 brackets = 1; /* bracket nesting level */
6815 bool has_utf8 = FALSE; /* is there any utf8 content? */
6817 /* skip space before the delimiter */
6821 /* mark where we are, in case we need to report errors */
6824 /* after skipping whitespace, the next character is the terminator */
6826 if (!UTF8_IS_INVARIANT((U8)term) && UTF)
6829 /* mark where we are */
6830 PL_multi_start = CopLINE(PL_curcop);
6831 PL_multi_open = term;
6833 /* find corresponding closing delimiter */
6834 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
6836 PL_multi_close = term;
6838 /* create a new SV to hold the contents. 87 is leak category, I'm
6839 assuming. 79 is the SV's initial length. What a random number. */
6841 sv_upgrade(sv, SVt_PVIV);
6843 (void)SvPOK_only(sv); /* validate pointer */
6845 /* move past delimiter and try to read a complete string */
6847 sv_catpvn(sv, s, 1);
6850 /* extend sv if need be */
6851 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
6852 /* set 'to' to the next character in the sv's string */
6853 to = SvPVX(sv)+SvCUR(sv);
6855 /* if open delimiter is the close delimiter read unbridle */
6856 if (PL_multi_open == PL_multi_close) {
6857 for (; s < PL_bufend; s++,to++) {
6858 /* embedded newlines increment the current line number */
6859 if (*s == '\n' && !PL_rsfp)
6860 CopLINE_inc(PL_curcop);
6861 /* handle quoted delimiters */
6862 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
6863 if (!keep_quoted && s[1] == term)
6865 /* any other quotes are simply copied straight through */
6869 /* terminate when run out of buffer (the for() condition), or
6870 have found the terminator */
6871 else if (*s == term)
6873 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
6879 /* if the terminator isn't the same as the start character (e.g.,
6880 matched brackets), we have to allow more in the quoting, and
6881 be prepared for nested brackets.
6884 /* read until we run out of string, or we find the terminator */
6885 for (; s < PL_bufend; s++,to++) {
6886 /* embedded newlines increment the line count */
6887 if (*s == '\n' && !PL_rsfp)
6888 CopLINE_inc(PL_curcop);
6889 /* backslashes can escape the open or closing characters */
6890 if (*s == '\\' && s+1 < PL_bufend) {
6892 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
6897 /* allow nested opens and closes */
6898 else if (*s == PL_multi_close && --brackets <= 0)
6900 else if (*s == PL_multi_open)
6902 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
6907 /* terminate the copied string and update the sv's end-of-string */
6909 SvCUR_set(sv, to - SvPVX(sv));
6912 * this next chunk reads more into the buffer if we're not done yet
6916 break; /* handle case where we are done yet :-) */
6918 #ifndef PERL_STRICT_CR
6919 if (to - SvPVX(sv) >= 2) {
6920 if ((to[-2] == '\r' && to[-1] == '\n') ||
6921 (to[-2] == '\n' && to[-1] == '\r'))
6925 SvCUR_set(sv, to - SvPVX(sv));
6927 else if (to[-1] == '\r')
6930 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
6934 /* if we're out of file, or a read fails, bail and reset the current
6935 line marker so we can report where the unterminated string began
6938 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6940 CopLINE_set(PL_curcop, PL_multi_start);
6943 /* we read a line, so increment our line counter */
6944 CopLINE_inc(PL_curcop);
6946 /* update debugger info */
6947 if (PERLDB_LINE && PL_curstash != PL_debstash) {
6948 SV *sv = NEWSV(88,0);
6950 sv_upgrade(sv, SVt_PVMG);
6951 sv_setsv(sv,PL_linestr);
6954 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop), sv);
6957 /* having changed the buffer, we must update PL_bufend */
6958 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6959 PL_last_lop = PL_last_uni = Nullch;
6962 /* at this point, we have successfully read the delimited string */
6965 sv_catpvn(sv, s, 1);
6968 PL_multi_end = CopLINE(PL_curcop);
6971 /* if we allocated too much space, give some back */
6972 if (SvCUR(sv) + 5 < SvLEN(sv)) {
6973 SvLEN_set(sv, SvCUR(sv) + 1);
6974 Renew(SvPVX(sv), SvLEN(sv), char);
6977 /* decide whether this is the first or second quoted string we've read
6990 takes: pointer to position in buffer
6991 returns: pointer to new position in buffer
6992 side-effects: builds ops for the constant in yylval.op
6994 Read a number in any of the formats that Perl accepts:
6996 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
6997 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
7000 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
7002 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
7005 If it reads a number without a decimal point or an exponent, it will
7006 try converting the number to an integer and see if it can do so
7007 without loss of precision.
7011 Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp)
7013 register char *s = start; /* current position in buffer */
7014 register char *d; /* destination in temp buffer */
7015 register char *e; /* end of temp buffer */
7016 NV nv; /* number read, as a double */
7017 SV *sv = Nullsv; /* place to put the converted number */
7018 bool floatit; /* boolean: int or float? */
7019 char *lastub = 0; /* position of last underbar */
7020 static char number_too_long[] = "Number too long";
7022 /* We use the first character to decide what type of number this is */
7026 Perl_croak(aTHX_ "panic: scan_num");
7028 /* if it starts with a 0, it could be an octal number, a decimal in
7029 0.13 disguise, or a hexadecimal number, or a binary number. */
7033 u holds the "number so far"
7034 shift the power of 2 of the base
7035 (hex == 4, octal == 3, binary == 1)
7036 overflowed was the number more than we can hold?
7038 Shift is used when we add a digit. It also serves as an "are
7039 we in octal/hex/binary?" indicator to disallow hex characters
7045 bool overflowed = FALSE;
7046 static NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
7047 static char* bases[5] = { "", "binary", "", "octal",
7049 static char* Bases[5] = { "", "Binary", "", "Octal",
7051 static char *maxima[5] = { "",
7052 "0b11111111111111111111111111111111",
7056 char *base, *Base, *max;
7062 } else if (s[1] == 'b') {
7066 /* check for a decimal in disguise */
7067 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
7069 /* so it must be octal */
7076 if (ckWARN(WARN_SYNTAX))
7077 Perl_warner(aTHX_ WARN_SYNTAX,
7078 "Misplaced _ in number");
7082 base = bases[shift];
7083 Base = Bases[shift];
7084 max = maxima[shift];
7086 /* read the rest of the number */
7088 /* x is used in the overflow test,
7089 b is the digit we're adding on. */
7094 /* if we don't mention it, we're done */
7098 /* _ are ignored -- but warned about if consecutive */
7100 if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
7101 Perl_warner(aTHX_ WARN_SYNTAX,
7102 "Misplaced _ in number");
7106 /* 8 and 9 are not octal */
7109 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
7113 case '2': case '3': case '4':
7114 case '5': case '6': case '7':
7116 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
7120 b = *s++ & 15; /* ASCII digit -> value of digit */
7124 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
7125 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
7126 /* make sure they said 0x */
7131 /* Prepare to put the digit we have onto the end
7132 of the number so far. We check for overflows.
7137 x = u << shift; /* make room for the digit */
7139 if ((x >> shift) != u
7140 && !(PL_hints & HINT_NEW_BINARY)) {
7143 if (ckWARN_d(WARN_OVERFLOW))
7144 Perl_warner(aTHX_ WARN_OVERFLOW,
7145 "Integer overflow in %s number",
7148 u = x | b; /* add the digit to the end */
7151 n *= nvshift[shift];
7152 /* If an NV has not enough bits in its
7153 * mantissa to represent an UV this summing of
7154 * small low-order numbers is a waste of time
7155 * (because the NV cannot preserve the
7156 * low-order bits anyway): we could just
7157 * remember when did we overflow and in the
7158 * end just multiply n by the right
7166 /* if we get here, we had success: make a scalar value from
7171 /* final misplaced underbar check */
7173 if (ckWARN(WARN_SYNTAX))
7174 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
7179 if (ckWARN(WARN_PORTABLE) && n > 4294967295.0)
7180 Perl_warner(aTHX_ WARN_PORTABLE,
7181 "%s number > %s non-portable",
7187 if (ckWARN(WARN_PORTABLE) && u > 0xffffffff)
7188 Perl_warner(aTHX_ WARN_PORTABLE,
7189 "%s number > %s non-portable",
7194 if (PL_hints & HINT_NEW_BINARY)
7195 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
7200 handle decimal numbers.
7201 we're also sent here when we read a 0 as the first digit
7203 case '1': case '2': case '3': case '4': case '5':
7204 case '6': case '7': case '8': case '9': case '.':
7207 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
7210 /* read next group of digits and _ and copy into d */
7211 while (isDIGIT(*s) || *s == '_') {
7212 /* skip underscores, checking for misplaced ones
7216 if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
7217 Perl_warner(aTHX_ WARN_SYNTAX,
7218 "Misplaced _ in number");
7222 /* check for end of fixed-length buffer */
7224 Perl_croak(aTHX_ number_too_long);
7225 /* if we're ok, copy the character */
7230 /* final misplaced underbar check */
7231 if (lastub && s == lastub + 1) {
7232 if (ckWARN(WARN_SYNTAX))
7233 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
7236 /* read a decimal portion if there is one. avoid
7237 3..5 being interpreted as the number 3. followed
7240 if (*s == '.' && s[1] != '.') {
7245 if (ckWARN(WARN_SYNTAX))
7246 Perl_warner(aTHX_ WARN_SYNTAX,
7247 "Misplaced _ in number");
7251 /* copy, ignoring underbars, until we run out of digits.
7253 for (; isDIGIT(*s) || *s == '_'; s++) {
7254 /* fixed length buffer check */
7256 Perl_croak(aTHX_ number_too_long);
7258 if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
7259 Perl_warner(aTHX_ WARN_SYNTAX,
7260 "Misplaced _ in number");
7266 /* fractional part ending in underbar? */
7268 if (ckWARN(WARN_SYNTAX))
7269 Perl_warner(aTHX_ WARN_SYNTAX,
7270 "Misplaced _ in number");
7272 if (*s == '.' && isDIGIT(s[1])) {
7273 /* oops, it's really a v-string, but without the "v" */
7279 /* read exponent part, if present */
7280 if (*s && strchr("eE",*s) && strchr("+-0123456789_", s[1])) {
7284 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
7285 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
7287 /* stray preinitial _ */
7289 if (ckWARN(WARN_SYNTAX))
7290 Perl_warner(aTHX_ WARN_SYNTAX,
7291 "Misplaced _ in number");
7295 /* allow positive or negative exponent */
7296 if (*s == '+' || *s == '-')
7299 /* stray initial _ */
7301 if (ckWARN(WARN_SYNTAX))
7302 Perl_warner(aTHX_ WARN_SYNTAX,
7303 "Misplaced _ in number");
7307 /* read digits of exponent */
7308 while (isDIGIT(*s) || *s == '_') {
7311 Perl_croak(aTHX_ number_too_long);
7315 if (ckWARN(WARN_SYNTAX) &&
7316 ((lastub && s == lastub + 1) ||
7317 (!isDIGIT(s[1]) && s[1] != '_')))
7318 Perl_warner(aTHX_ WARN_SYNTAX,
7319 "Misplaced _ in number");
7326 /* make an sv from the string */
7330 We try to do an integer conversion first if no characters
7331 indicating "float" have been found.
7336 int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
7338 if (flags == IS_NUMBER_IN_UV) {
7340 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
7343 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
7344 if (uv <= (UV) IV_MIN)
7345 sv_setiv(sv, -(IV)uv);
7352 /* terminate the string */
7354 nv = Atof(PL_tokenbuf);
7358 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
7359 (PL_hints & HINT_NEW_INTEGER) )
7360 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
7361 (floatit ? "float" : "integer"),
7365 /* if it starts with a v, it could be a v-string */
7368 sv = NEWSV(92,5); /* preallocate storage space */
7369 s = new_vstring(s,sv);
7373 /* make the op for the constant and return */
7376 lvalp->opval = newSVOP(OP_CONST, 0, sv);
7378 lvalp->opval = Nullop;
7384 S_scan_formline(pTHX_ register char *s)
7388 SV *stuff = newSVpvn("",0);
7389 bool needargs = FALSE;
7392 if (*s == '.' || *s == /*{*/'}') {
7394 #ifdef PERL_STRICT_CR
7395 for (t = s+1;SPACE_OR_TAB(*t); t++) ;
7397 for (t = s+1;SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
7399 if (*t == '\n' || t == PL_bufend)
7402 if (PL_in_eval && !PL_rsfp) {
7403 eol = strchr(s,'\n');
7408 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7410 for (t = s; t < eol; t++) {
7411 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
7413 goto enough; /* ~~ must be first line in formline */
7415 if (*t == '@' || *t == '^')
7419 sv_catpvn(stuff, s, eol-s);
7420 #ifndef PERL_STRICT_CR
7421 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
7422 char *end = SvPVX(stuff) + SvCUR(stuff);
7434 s = filter_gets(PL_linestr, PL_rsfp, 0);
7435 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
7436 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
7437 PL_last_lop = PL_last_uni = Nullch;
7440 yyerror("Format not terminated");
7450 PL_lex_state = LEX_NORMAL;
7451 PL_nextval[PL_nexttoke].ival = 0;
7455 PL_lex_state = LEX_FORMLINE;
7456 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
7458 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
7462 SvREFCNT_dec(stuff);
7463 PL_lex_formbrack = 0;
7474 PL_cshlen = strlen(PL_cshname);
7479 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
7481 I32 oldsavestack_ix = PL_savestack_ix;
7482 CV* outsidecv = PL_compcv;
7486 assert(SvTYPE(PL_compcv) == SVt_PVCV);
7488 SAVEI32(PL_subline);
7489 save_item(PL_subname);
7492 SAVESPTR(PL_comppad_name);
7493 SAVESPTR(PL_compcv);
7494 SAVEI32(PL_comppad_name_fill);
7495 SAVEI32(PL_min_intro_pending);
7496 SAVEI32(PL_max_intro_pending);
7497 SAVEI32(PL_pad_reset_pending);
7499 PL_compcv = (CV*)NEWSV(1104,0);
7500 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
7501 CvFLAGS(PL_compcv) |= flags;
7503 PL_comppad = newAV();
7504 av_push(PL_comppad, Nullsv);
7505 PL_curpad = AvARRAY(PL_comppad);
7506 PL_comppad_name = newAV();
7507 PL_comppad_name_fill = 0;
7508 PL_min_intro_pending = 0;
7510 PL_subline = CopLINE(PL_curcop);
7511 #ifdef USE_5005THREADS
7512 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
7513 PL_curpad[0] = (SV*)newAV();
7514 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
7515 #endif /* USE_5005THREADS */
7517 comppadlist = newAV();
7518 AvREAL_off(comppadlist);
7519 av_store(comppadlist, 0, (SV*)PL_comppad_name);
7520 av_store(comppadlist, 1, (SV*)PL_comppad);
7522 CvPADLIST(PL_compcv) = comppadlist;
7523 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
7524 #ifdef USE_5005THREADS
7525 CvOWNER(PL_compcv) = 0;
7526 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
7527 MUTEX_INIT(CvMUTEXP(PL_compcv));
7528 #endif /* USE_5005THREADS */
7530 return oldsavestack_ix;
7534 #pragma segment Perl_yylex
7537 Perl_yywarn(pTHX_ char *s)
7539 PL_in_eval |= EVAL_WARNONLY;
7541 PL_in_eval &= ~EVAL_WARNONLY;
7546 Perl_yyerror(pTHX_ char *s)
7549 char *context = NULL;
7553 if (!yychar || (yychar == ';' && !PL_rsfp))
7555 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
7556 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
7557 while (isSPACE(*PL_oldoldbufptr))
7559 context = PL_oldoldbufptr;
7560 contlen = PL_bufptr - PL_oldoldbufptr;
7562 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
7563 PL_oldbufptr != PL_bufptr) {
7564 while (isSPACE(*PL_oldbufptr))
7566 context = PL_oldbufptr;
7567 contlen = PL_bufptr - PL_oldbufptr;
7569 else if (yychar > 255)
7570 where = "next token ???";
7571 #ifdef USE_PURE_BISON
7572 /* GNU Bison sets the value -2 */
7573 else if (yychar == -2) {
7575 else if ((yychar & 127) == 127) {
7577 if (PL_lex_state == LEX_NORMAL ||
7578 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
7579 where = "at end of line";
7580 else if (PL_lex_inpat)
7581 where = "within pattern";
7583 where = "within string";
7586 SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
7588 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
7589 else if (isPRINT_LC(yychar))
7590 Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
7592 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
7593 where = SvPVX(where_sv);
7595 msg = sv_2mortal(newSVpv(s, 0));
7596 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
7597 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
7599 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
7601 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
7602 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
7603 Perl_sv_catpvf(aTHX_ msg,
7604 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
7605 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
7608 if (PL_in_eval & EVAL_WARNONLY)
7609 Perl_warn(aTHX_ "%"SVf, msg);
7612 if (PL_error_count >= 10) {
7613 if (PL_in_eval && SvCUR(ERRSV))
7614 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
7615 ERRSV, CopFILE(PL_curcop));
7617 Perl_croak(aTHX_ "%s has too many errors.\n",
7618 CopFILE(PL_curcop));
7621 PL_in_my_stash = Nullhv;
7625 #pragma segment Main
7629 S_swallow_bom(pTHX_ U8 *s)
7632 slen = SvCUR(PL_linestr);
7636 /* UTF-16 little-endian */
7637 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
7638 Perl_croak(aTHX_ "Unsupported script encoding");
7639 #ifndef PERL_NO_UTF16_FILTER
7640 DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-LE script encoding\n"));
7642 if (PL_bufend > (char*)s) {
7646 filter_add(utf16rev_textfilter, NULL);
7647 New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
7648 PL_bufend = (char*)utf16_to_utf8_reversed(s, news,
7649 PL_bufend - (char*)s - 1,
7651 Copy(news, s, newlen, U8);
7652 SvCUR_set(PL_linestr, newlen);
7653 PL_bufend = SvPVX(PL_linestr) + newlen;
7654 news[newlen++] = '\0';
7658 Perl_croak(aTHX_ "Unsupported script encoding");
7663 if (s[1] == 0xFF) { /* UTF-16 big-endian */
7664 #ifndef PERL_NO_UTF16_FILTER
7665 DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding\n"));
7667 if (PL_bufend > (char *)s) {
7671 filter_add(utf16_textfilter, NULL);
7672 New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
7673 PL_bufend = (char*)utf16_to_utf8(s, news,
7674 PL_bufend - (char*)s,
7676 Copy(news, s, newlen, U8);
7677 SvCUR_set(PL_linestr, newlen);
7678 PL_bufend = SvPVX(PL_linestr) + newlen;
7679 news[newlen++] = '\0';
7683 Perl_croak(aTHX_ "Unsupported script encoding");
7688 if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
7689 DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-8 script encoding\n"));
7694 if (slen > 3 && s[1] == 0 && /* UTF-32 big-endian */
7695 s[2] == 0xFE && s[3] == 0xFF)
7697 Perl_croak(aTHX_ "Unsupported script encoding");
7705 * Restore a source filter.
7709 restore_rsfp(pTHX_ void *f)
7711 PerlIO *fp = (PerlIO*)f;
7713 if (PL_rsfp == PerlIO_stdin())
7714 PerlIO_clearerr(PL_rsfp);
7715 else if (PL_rsfp && (PL_rsfp != fp))
7716 PerlIO_close(PL_rsfp);
7720 #ifndef PERL_NO_UTF16_FILTER
7722 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
7724 I32 count = FILTER_READ(idx+1, sv, maxlen);
7729 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
7730 if (!*SvPV_nolen(sv))
7731 /* Game over, but don't feed an odd-length string to utf16_to_utf8 */
7734 tend = utf16_to_utf8((U8*)SvPVX(sv), tmps, SvCUR(sv), &newlen);
7735 sv_usepvn(sv, (char*)tmps, tend - tmps);
7741 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
7743 I32 count = FILTER_READ(idx+1, sv, maxlen);
7748 if (!*SvPV_nolen(sv))
7749 /* Game over, but don't feed an odd-length string to utf16_to_utf8 */
7752 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
7753 tend = utf16_to_utf8_reversed((U8*)SvPVX(sv), tmps, SvCUR(sv), &newlen);
7754 sv_usepvn(sv, (char*)tmps, tend - tmps);