3 * Copyright (c) 1991-2001, 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 */
518 Safefree(CopFILE(PL_curcop));
520 SvREFCNT_dec(CopFILEGV(PL_curcop));
522 CopFILE_set(PL_curcop, s);
525 CopLINE_set(PL_curcop, atoi(n)-1);
530 * Called to gobble the appropriate amount and type of whitespace.
531 * Skips comments as well.
535 S_skipspace(pTHX_ register char *s)
537 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
538 while (s < PL_bufend && SPACE_OR_TAB(*s))
544 SSize_t oldprevlen, oldoldprevlen;
545 SSize_t oldloplen = 0, oldunilen = 0;
546 while (s < PL_bufend && isSPACE(*s)) {
547 if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
552 if (s < PL_bufend && *s == '#') {
553 while (s < PL_bufend && *s != '\n')
557 if (PL_in_eval && !PL_rsfp) {
564 /* only continue to recharge the buffer if we're at the end
565 * of the buffer, we're not reading from a source filter, and
566 * we're in normal lexing mode
568 if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat ||
569 PL_lex_state == LEX_FORMLINE)
572 /* try to recharge the buffer */
573 if ((s = filter_gets(PL_linestr, PL_rsfp,
574 (prevlen = SvCUR(PL_linestr)))) == Nullch)
576 /* end of file. Add on the -p or -n magic */
577 if (PL_minus_n || PL_minus_p) {
578 sv_setpv(PL_linestr,PL_minus_p ?
579 ";}continue{print or die qq(-p destination: $!\\n)" :
581 sv_catpv(PL_linestr,";}");
582 PL_minus_n = PL_minus_p = 0;
585 sv_setpv(PL_linestr,";");
587 /* reset variables for next time we lex */
588 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
590 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
591 PL_last_lop = PL_last_uni = Nullch;
593 /* Close the filehandle. Could be from -P preprocessor,
594 * STDIN, or a regular file. If we were reading code from
595 * STDIN (because the commandline held no -e or filename)
596 * then we don't close it, we reset it so the code can
597 * read from STDIN too.
600 if (PL_preprocess && !PL_in_eval)
601 (void)PerlProc_pclose(PL_rsfp);
602 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
603 PerlIO_clearerr(PL_rsfp);
605 (void)PerlIO_close(PL_rsfp);
610 /* not at end of file, so we only read another line */
611 /* make corresponding updates to old pointers, for yyerror() */
612 oldprevlen = PL_oldbufptr - PL_bufend;
613 oldoldprevlen = PL_oldoldbufptr - PL_bufend;
615 oldunilen = PL_last_uni - PL_bufend;
617 oldloplen = PL_last_lop - PL_bufend;
618 PL_linestart = PL_bufptr = s + prevlen;
619 PL_bufend = s + SvCUR(PL_linestr);
621 PL_oldbufptr = s + oldprevlen;
622 PL_oldoldbufptr = s + oldoldprevlen;
624 PL_last_uni = s + oldunilen;
626 PL_last_lop = s + oldloplen;
629 /* debugger active and we're not compiling the debugger code,
630 * so store the line into the debugger's array of lines
632 if (PERLDB_LINE && PL_curstash != PL_debstash) {
633 SV *sv = NEWSV(85,0);
635 sv_upgrade(sv, SVt_PVMG);
636 sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
637 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
644 * Check the unary operators to ensure there's no ambiguity in how they're
645 * used. An ambiguous piece of code would be:
647 * This doesn't mean rand() + 5. Because rand() is a unary operator,
648 * the +5 is its argument.
657 if (PL_oldoldbufptr != PL_last_uni)
659 while (isSPACE(*PL_last_uni))
661 for (s = PL_last_uni; isALNUM_lazy_if(s,UTF) || *s == '-'; s++) ;
662 if ((t = strchr(s, '(')) && t < PL_bufptr)
664 if (ckWARN_d(WARN_AMBIGUOUS)){
667 Perl_warner(aTHX_ WARN_AMBIGUOUS,
668 "Warning: Use of \"%s\" without parens is ambiguous",
674 /* workaround to replace the UNI() macro with a function. Only the
675 * hints/uts.sh file mentions this. Other comments elsewhere in the
676 * source indicate Microport Unix might need it too.
682 #define UNI(f) return uni(f,s)
685 S_uni(pTHX_ I32 f, char *s)
690 PL_last_uni = PL_oldbufptr;
701 #endif /* CRIPPLED_CC */
704 * LOP : macro to build a list operator. Its behaviour has been replaced
705 * with a subroutine, S_lop() for which LOP is just another name.
708 #define LOP(f,x) return lop(f,x,s)
712 * Build a list operator (or something that might be one). The rules:
713 * - if we have a next token, then it's a list operator [why?]
714 * - if the next thing is an opening paren, then it's a function
715 * - else it's a list operator
719 S_lop(pTHX_ I32 f, int x, char *s)
726 PL_last_lop = PL_oldbufptr;
741 * When the lexer realizes it knows the next token (for instance,
742 * it is reordering tokens for the parser) then it can call S_force_next
743 * to know what token to return the next time the lexer is called. Caller
744 * will need to set PL_nextval[], and possibly PL_expect to ensure the lexer
745 * handles the token correctly.
749 S_force_next(pTHX_ I32 type)
751 PL_nexttype[PL_nexttoke] = type;
753 if (PL_lex_state != LEX_KNOWNEXT) {
754 PL_lex_defer = PL_lex_state;
755 PL_lex_expect = PL_expect;
756 PL_lex_state = LEX_KNOWNEXT;
762 * When the lexer knows the next thing is a word (for instance, it has
763 * just seen -> and it knows that the next char is a word char, then
764 * it calls S_force_word to stick the next word into the PL_next lookahead.
767 * char *start : buffer position (must be within PL_linestr)
768 * int token : PL_next will be this type of bare word (e.g., METHOD,WORD)
769 * int check_keyword : if true, Perl checks to make sure the word isn't
770 * a keyword (do this if the word is a label, e.g. goto FOO)
771 * int allow_pack : if true, : characters will also be allowed (require,
773 * int allow_initial_tick : used by the "sub" lexer only.
777 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
782 start = skipspace(start);
784 if (isIDFIRST_lazy_if(s,UTF) ||
785 (allow_pack && *s == ':') ||
786 (allow_initial_tick && *s == '\'') )
788 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
789 if (check_keyword && keyword(PL_tokenbuf, len))
791 if (token == METHOD) {
796 PL_expect = XOPERATOR;
799 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(PL_tokenbuf,0));
800 PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
808 * Called when the lexer wants $foo *foo &foo etc, but the program
809 * text only contains the "foo" portion. The first argument is a pointer
810 * to the "foo", and the second argument is the type symbol to prefix.
811 * Forces the next token to be a "WORD".
812 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
816 S_force_ident(pTHX_ register char *s, int kind)
819 OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
820 PL_nextval[PL_nexttoke].opval = o;
823 o->op_private = OPpCONST_ENTERED;
824 /* XXX see note in pp_entereval() for why we forgo typo
825 warnings if the symbol must be introduced in an eval.
827 gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
828 kind == '$' ? SVt_PV :
829 kind == '@' ? SVt_PVAV :
830 kind == '%' ? SVt_PVHV :
838 Perl_str_to_version(pTHX_ SV *sv)
843 char *start = SvPVx(sv,len);
844 bool utf = SvUTF8(sv) ? TRUE : FALSE;
845 char *end = start + len;
846 while (start < end) {
850 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
855 retval += ((NV)n)/nshift;
864 * Forces the next token to be a version number.
865 * If the next token appears to be an invalid version number, (e.g. "v2b"),
866 * and if "guessing" is TRUE, then no new token is created (and the caller
867 * must use an alternative parsing method).
871 S_force_version(pTHX_ char *s, int guessing)
873 OP *version = Nullop;
882 while (isDIGIT(*d) || *d == '_' || *d == '.')
884 if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
886 s = scan_num(s, &yylval);
887 version = yylval.opval;
888 ver = cSVOPx(version)->op_sv;
889 if (SvPOK(ver) && !SvNIOK(ver)) {
890 (void)SvUPGRADE(ver, SVt_PVNV);
891 SvNVX(ver) = str_to_version(ver);
892 SvNOK_on(ver); /* hint that it is a version */
899 /* NOTE: The parser sees the package name and the VERSION swapped */
900 PL_nextval[PL_nexttoke].opval = version;
908 * Tokenize a quoted string passed in as an SV. It finds the next
909 * chunk, up to end of string or a backslash. It may make a new
910 * SV containing that chunk (if HINT_NEW_STRING is on). It also
915 S_tokeq(pTHX_ SV *sv)
926 s = SvPV_force(sv, len);
927 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
930 while (s < send && *s != '\\')
935 if ( PL_hints & HINT_NEW_STRING ) {
936 pv = sv_2mortal(newSVpvn(SvPVX(pv), len));
942 if (s + 1 < send && (s[1] == '\\'))
943 s++; /* all that, just for this */
948 SvCUR_set(sv, d - SvPVX(sv));
950 if ( PL_hints & HINT_NEW_STRING )
951 return new_constant(NULL, 0, "q", sv, pv, "q");
956 * Now come three functions related to double-quote context,
957 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
958 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
959 * interact with PL_lex_state, and create fake ( ... ) argument lists
960 * to handle functions and concatenation.
961 * They assume that whoever calls them will be setting up a fake
962 * join call, because each subthing puts a ',' after it. This lets
965 * join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
967 * (I'm not sure whether the spurious commas at the end of lcfirst's
968 * arguments and join's arguments are created or not).
973 * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST).
975 * Pattern matching will set PL_lex_op to the pattern-matching op to
976 * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise).
978 * OP_CONST and OP_READLINE are easy--just make the new op and return.
980 * Everything else becomes a FUNC.
982 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
983 * had an OP_CONST or OP_READLINE). This just sets us up for a
984 * call to S_sublex_push().
990 register I32 op_type = yylval.ival;
992 if (op_type == OP_NULL) {
993 yylval.opval = PL_lex_op;
997 if (op_type == OP_CONST || op_type == OP_READLINE) {
998 SV *sv = tokeq(PL_lex_stuff);
1000 if (SvTYPE(sv) == SVt_PVIV) {
1001 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
1007 nsv = newSVpvn(p, len);
1013 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
1014 PL_lex_stuff = Nullsv;
1018 PL_sublex_info.super_state = PL_lex_state;
1019 PL_sublex_info.sub_inwhat = op_type;
1020 PL_sublex_info.sub_op = PL_lex_op;
1021 PL_lex_state = LEX_INTERPPUSH;
1025 yylval.opval = PL_lex_op;
1035 * Create a new scope to save the lexing state. The scope will be
1036 * ended in S_sublex_done. Returns a '(', starting the function arguments
1037 * to the uc, lc, etc. found before.
1038 * Sets PL_lex_state to LEX_INTERPCONCAT.
1046 PL_lex_state = PL_sublex_info.super_state;
1047 SAVEI32(PL_lex_dojoin);
1048 SAVEI32(PL_lex_brackets);
1049 SAVEI32(PL_lex_casemods);
1050 SAVEI32(PL_lex_starts);
1051 SAVEI32(PL_lex_state);
1052 SAVEVPTR(PL_lex_inpat);
1053 SAVEI32(PL_lex_inwhat);
1054 SAVECOPLINE(PL_curcop);
1055 SAVEPPTR(PL_bufptr);
1056 SAVEPPTR(PL_bufend);
1057 SAVEPPTR(PL_oldbufptr);
1058 SAVEPPTR(PL_oldoldbufptr);
1059 SAVEPPTR(PL_last_lop);
1060 SAVEPPTR(PL_last_uni);
1061 SAVEPPTR(PL_linestart);
1062 SAVESPTR(PL_linestr);
1063 SAVEPPTR(PL_lex_brackstack);
1064 SAVEPPTR(PL_lex_casestack);
1066 PL_linestr = PL_lex_stuff;
1067 PL_lex_stuff = Nullsv;
1069 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
1070 = SvPVX(PL_linestr);
1071 PL_bufend += SvCUR(PL_linestr);
1072 PL_last_lop = PL_last_uni = Nullch;
1073 SAVEFREESV(PL_linestr);
1075 PL_lex_dojoin = FALSE;
1076 PL_lex_brackets = 0;
1077 New(899, PL_lex_brackstack, 120, char);
1078 New(899, PL_lex_casestack, 12, char);
1079 SAVEFREEPV(PL_lex_brackstack);
1080 SAVEFREEPV(PL_lex_casestack);
1081 PL_lex_casemods = 0;
1082 *PL_lex_casestack = '\0';
1084 PL_lex_state = LEX_INTERPCONCAT;
1085 CopLINE_set(PL_curcop, PL_multi_start);
1087 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1088 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1089 PL_lex_inpat = PL_sublex_info.sub_op;
1091 PL_lex_inpat = Nullop;
1098 * Restores lexer state after a S_sublex_push.
1104 if (!PL_lex_starts++) {
1105 SV *sv = newSVpvn("",0);
1106 if (SvUTF8(PL_linestr))
1108 PL_expect = XOPERATOR;
1109 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1113 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
1114 PL_lex_state = LEX_INTERPCASEMOD;
1118 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1119 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1120 PL_linestr = PL_lex_repl;
1122 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1123 PL_bufend += SvCUR(PL_linestr);
1124 PL_last_lop = PL_last_uni = Nullch;
1125 SAVEFREESV(PL_linestr);
1126 PL_lex_dojoin = FALSE;
1127 PL_lex_brackets = 0;
1128 PL_lex_casemods = 0;
1129 *PL_lex_casestack = '\0';
1131 if (SvEVALED(PL_lex_repl)) {
1132 PL_lex_state = LEX_INTERPNORMAL;
1134 /* we don't clear PL_lex_repl here, so that we can check later
1135 whether this is an evalled subst; that means we rely on the
1136 logic to ensure sublex_done() is called again only via the
1137 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1140 PL_lex_state = LEX_INTERPCONCAT;
1141 PL_lex_repl = Nullsv;
1147 PL_bufend = SvPVX(PL_linestr);
1148 PL_bufend += SvCUR(PL_linestr);
1149 PL_expect = XOPERATOR;
1150 PL_sublex_info.sub_inwhat = 0;
1158 Extracts a pattern, double-quoted string, or transliteration. This
1161 It looks at lex_inwhat and PL_lex_inpat to find out whether it's
1162 processing a pattern (PL_lex_inpat is true), a transliteration
1163 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
1165 Returns a pointer to the character scanned up to. Iff this is
1166 advanced from the start pointer supplied (ie if anything was
1167 successfully parsed), will leave an OP for the substring scanned
1168 in yylval. Caller must intuit reason for not parsing further
1169 by looking at the next characters herself.
1173 double-quoted style: \r and \n
1174 regexp special ones: \D \s
1176 backrefs: \1 (deprecated in substitution replacements)
1177 case and quoting: \U \Q \E
1178 stops on @ and $, but not for $ as tail anchor
1180 In transliterations:
1181 characters are VERY literal, except for - not at the start or end
1182 of the string, which indicates a range. scan_const expands the
1183 range to the full set of intermediate characters.
1185 In double-quoted strings:
1187 double-quoted style: \r and \n
1189 backrefs: \1 (deprecated)
1190 case and quoting: \U \Q \E
1193 scan_const does *not* construct ops to handle interpolated strings.
1194 It stops processing as soon as it finds an embedded $ or @ variable
1195 and leaves it to the caller to work out what's going on.
1197 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
1199 $ in pattern could be $foo or could be tail anchor. Assumption:
1200 it's a tail anchor if $ is the last thing in the string, or if it's
1201 followed by one of ")| \n\t"
1203 \1 (backreferences) are turned into $1
1205 The structure of the code is
1206 while (there's a character to process) {
1207 handle transliteration ranges
1208 skip regexp comments
1209 skip # initiated comments in //x patterns
1210 check for embedded @foo
1211 check for embedded scalars
1213 leave intact backslashes from leave (below)
1214 deprecate \1 in strings and sub replacements
1215 handle string-changing backslashes \l \U \Q \E, etc.
1216 switch (what was escaped) {
1217 handle - in a transliteration (becomes a literal -)
1218 handle \132 octal characters
1219 handle 0x15 hex characters
1220 handle \cV (control V)
1221 handle printf backslashes (\f, \r, \n, etc)
1223 } (end if backslash)
1224 } (end while character to read)
1229 S_scan_const(pTHX_ char *start)
1231 register char *send = PL_bufend; /* end of the constant */
1232 SV *sv = NEWSV(93, send - start); /* sv for the constant */
1233 register char *s = start; /* start of the constant */
1234 register char *d = SvPVX(sv); /* destination for copies */
1235 bool dorange = FALSE; /* are we in a translit range? */
1236 bool didrange = FALSE; /* did we just finish a range? */
1237 I32 has_utf8 = FALSE; /* Output constant is UTF8 */
1238 I32 this_utf8 = UTF; /* The source string is assumed to be UTF8 */
1241 const char *leaveit = /* set of acceptably-backslashed characters */
1243 ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
1246 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1247 /* If we are doing a trans and we know we want UTF8 set expectation */
1248 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
1249 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1253 while (s < send || dorange) {
1254 /* get transliterations out of the way (they're most literal) */
1255 if (PL_lex_inwhat == OP_TRANS) {
1256 /* expand a range A-Z to the full set of characters. AIE! */
1258 I32 i; /* current expanded character */
1259 I32 min; /* first character in range */
1260 I32 max; /* last character in range */
1263 char *c = (char*)utf8_hop((U8*)d, -1);
1267 *c = (char)UTF_TO_NATIVE(0xff);
1268 /* mark the range as done, and continue */
1274 i = d - SvPVX(sv); /* remember current offset */
1275 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
1276 d = SvPVX(sv) + i; /* refresh d after realloc */
1277 d -= 2; /* eat the first char and the - */
1279 min = (U8)*d; /* first char in range */
1280 max = (U8)d[1]; /* last char in range */
1284 "Invalid [] range \"%c-%c\" in transliteration operator",
1285 (char)min, (char)max);
1289 if ((isLOWER(min) && isLOWER(max)) ||
1290 (isUPPER(min) && isUPPER(max))) {
1292 for (i = min; i <= max; i++)
1294 *d++ = NATIVE_TO_NEED(has_utf8,i);
1296 for (i = min; i <= max; i++)
1298 *d++ = NATIVE_TO_NEED(has_utf8,i);
1303 for (i = min; i <= max; i++)
1306 /* mark the range as done, and continue */
1312 /* range begins (ignore - as first or last char) */
1313 else if (*s == '-' && s+1 < send && s != start) {
1315 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
1318 *d++ = (char)UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */
1330 /* if we get here, we're not doing a transliteration */
1332 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
1333 except for the last char, which will be done separately. */
1334 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
1336 while (s < send && *s != ')')
1337 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1339 else if (s[2] == '{' /* This should match regcomp.c */
1340 || ((s[2] == 'p' || s[2] == '?') && s[3] == '{'))
1343 char *regparse = s + (s[2] == '{' ? 3 : 4);
1346 while (count && (c = *regparse)) {
1347 if (c == '\\' && regparse[1])
1355 if (*regparse != ')') {
1356 regparse--; /* Leave one char for continuation. */
1357 yyerror("Sequence (?{...}) not terminated or not {}-balanced");
1359 while (s < regparse)
1360 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1364 /* likewise skip #-initiated comments in //x patterns */
1365 else if (*s == '#' && PL_lex_inpat &&
1366 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
1367 while (s+1 < send && *s != '\n')
1368 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1371 /* check for embedded arrays
1372 (@foo, @:foo, @'foo, @{foo}, @$foo, @+, @-)
1374 else if (*s == '@' && s[1]
1375 && (isALNUM_lazy_if(s+1,UTF) || strchr(":'{$+-", s[1])))
1378 /* check for embedded scalars. only stop if we're sure it's a
1381 else if (*s == '$') {
1382 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
1384 if (s + 1 < send && !strchr("()| \r\n\t", s[1]))
1385 break; /* in regexp, $ might be tail anchor */
1388 /* End of else if chain - OP_TRANS rejoin rest */
1391 if (*s == '\\' && s+1 < send) {
1394 /* some backslashes we leave behind */
1395 if (*leaveit && *s && strchr(leaveit, *s)) {
1396 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
1397 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1401 /* deprecate \1 in strings and substitution replacements */
1402 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1403 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1405 if (ckWARN(WARN_SYNTAX))
1406 Perl_warner(aTHX_ WARN_SYNTAX, "\\%c better written as $%c", *s, *s);
1411 /* string-change backslash escapes */
1412 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1417 /* if we get here, it's either a quoted -, or a digit */
1420 /* quoted - in transliterations */
1422 if (PL_lex_inwhat == OP_TRANS) {
1429 if (ckWARN(WARN_MISC) && isALNUM(*s))
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);
1560 if (!has_utf8 && SvUTF8(res)) {
1561 char *ostart = SvPVX(sv);
1562 SvCUR_set(sv, d - ostart);
1565 sv_utf8_upgrade(sv);
1566 /* this just broke our allocation above... */
1567 SvGROW(sv, send - start);
1568 d = SvPVX(sv) + SvCUR(sv);
1571 if (len > e - s + 4) { /* I _guess_ 4 is \N{} --jhi */
1572 char *odest = SvPVX(sv);
1574 SvGROW(sv, (SvLEN(sv) + len - (e - s + 4)));
1575 d = SvPVX(sv) + (d - odest);
1577 Copy(str, d, len, char);
1584 yyerror("Missing braces on \\N{}");
1587 /* \c is a control character */
1596 *d++ = NATIVE_TO_NEED(has_utf8,toCTRL(c));
1600 /* printf-style backslashes, formfeeds, newlines, etc */
1602 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
1605 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
1608 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
1611 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
1614 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
1617 *d++ = ASCII_TO_NEED(has_utf8,'\033');
1620 *d++ = ASCII_TO_NEED(has_utf8,'\007');
1626 } /* end if (backslash) */
1629 /* If we started with encoded form, or already know we want it
1630 and then encode the next character */
1631 if ((has_utf8 || this_utf8) && !NATIVE_IS_INVARIANT((U8)(*s))) {
1633 UV uv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
1634 STRLEN need = UNISKIP(NATIVE_TO_UNI(uv));
1637 /* encoded value larger than old, need extra space (NOTE: SvCUR() not set here) */
1638 STRLEN off = d - SvPVX(sv);
1639 d = SvGROW(sv, SvLEN(sv) + (need-len)) + off;
1641 d = (char*)uvchr_to_utf8((U8*)d, uv);
1645 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1647 } /* while loop to process each character */
1649 /* terminate the string and set up the sv */
1651 SvCUR_set(sv, d - SvPVX(sv));
1652 if (SvCUR(sv) >= SvLEN(sv))
1653 Perl_croak(aTHX_ "panic: constant overflowed allocated space");
1656 if (PL_encoding && !has_utf8) {
1657 Perl_sv_recode_to_utf8(aTHX_ sv, PL_encoding);
1662 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1663 PL_sublex_info.sub_op->op_private |=
1664 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1668 /* shrink the sv if we allocated more than we used */
1669 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1670 SvLEN_set(sv, SvCUR(sv) + 1);
1671 Renew(SvPVX(sv), SvLEN(sv), char);
1674 /* return the substring (via yylval) only if we parsed anything */
1675 if (s > PL_bufptr) {
1676 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1677 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1679 ( PL_lex_inwhat == OP_TRANS
1681 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1684 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1691 * Returns TRUE if there's more to the expression (e.g., a subscript),
1694 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
1696 * ->[ and ->{ return TRUE
1697 * { and [ outside a pattern are always subscripts, so return TRUE
1698 * if we're outside a pattern and it's not { or [, then return FALSE
1699 * if we're in a pattern and the first char is a {
1700 * {4,5} (any digits around the comma) returns FALSE
1701 * if we're in a pattern and the first char is a [
1703 * [SOMETHING] has a funky algorithm to decide whether it's a
1704 * character class or not. It has to deal with things like
1705 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
1706 * anything else returns TRUE
1709 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1712 S_intuit_more(pTHX_ register char *s)
1714 if (PL_lex_brackets)
1716 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1718 if (*s != '{' && *s != '[')
1723 /* In a pattern, so maybe we have {n,m}. */
1740 /* On the other hand, maybe we have a character class */
1743 if (*s == ']' || *s == '^')
1746 /* this is terrifying, and it works */
1747 int weight = 2; /* let's weigh the evidence */
1749 unsigned char un_char = 255, last_un_char;
1750 char *send = strchr(s,']');
1751 char tmpbuf[sizeof PL_tokenbuf * 4];
1753 if (!send) /* has to be an expression */
1756 Zero(seen,256,char);
1759 else if (isDIGIT(*s)) {
1761 if (isDIGIT(s[1]) && s[2] == ']')
1767 for (; s < send; s++) {
1768 last_un_char = un_char;
1769 un_char = (unsigned char)*s;
1774 weight -= seen[un_char] * 10;
1775 if (isALNUM_lazy_if(s+1,UTF)) {
1776 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1777 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1782 else if (*s == '$' && s[1] &&
1783 strchr("[#!%*<>()-=",s[1])) {
1784 if (/*{*/ strchr("])} =",s[2]))
1793 if (strchr("wds]",s[1]))
1795 else if (seen['\''] || seen['"'])
1797 else if (strchr("rnftbxcav",s[1]))
1799 else if (isDIGIT(s[1])) {
1801 while (s[1] && isDIGIT(s[1]))
1811 if (strchr("aA01! ",last_un_char))
1813 if (strchr("zZ79~",s[1]))
1815 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1816 weight -= 5; /* cope with negative subscript */
1819 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1820 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1825 if (keyword(tmpbuf, d - tmpbuf))
1828 if (un_char == last_un_char + 1)
1830 weight -= seen[un_char];
1835 if (weight >= 0) /* probably a character class */
1845 * Does all the checking to disambiguate
1847 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
1848 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
1850 * First argument is the stuff after the first token, e.g. "bar".
1852 * Not a method if bar is a filehandle.
1853 * Not a method if foo is a subroutine prototyped to take a filehandle.
1854 * Not a method if it's really "Foo $bar"
1855 * Method if it's "foo $bar"
1856 * Not a method if it's really "print foo $bar"
1857 * Method if it's really "foo package::" (interpreted as package->foo)
1858 * Not a method if bar is known to be a subroutne ("sub bar; foo bar")
1859 * Not a method if bar is a filehandle or package, but is quoted with
1864 S_intuit_method(pTHX_ char *start, GV *gv)
1866 char *s = start + (*start == '$');
1867 char tmpbuf[sizeof PL_tokenbuf];
1875 if ((cv = GvCVu(gv))) {
1876 char *proto = SvPVX(cv);
1886 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1887 /* start is the beginning of the possible filehandle/object,
1888 * and s is the end of it
1889 * tmpbuf is a copy of it
1892 if (*start == '$') {
1893 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1898 return *s == '(' ? FUNCMETH : METHOD;
1900 if (!keyword(tmpbuf, len)) {
1901 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1906 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1907 if (indirgv && GvCVu(indirgv))
1909 /* filehandle or package name makes it a method */
1910 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1912 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1913 return 0; /* no assumptions -- "=>" quotes bearword */
1915 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1916 newSVpvn(tmpbuf,len));
1917 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1921 return *s == '(' ? FUNCMETH : METHOD;
1929 * Return a string of Perl code to load the debugger. If PERL5DB
1930 * is set, it will return the contents of that, otherwise a
1931 * compile-time require of perl5db.pl.
1938 char *pdb = PerlEnv_getenv("PERL5DB");
1942 SETERRNO(0,SS$_NORMAL);
1943 return "BEGIN { require 'perl5db.pl' }";
1949 /* Encoded script support. filter_add() effectively inserts a
1950 * 'pre-processing' function into the current source input stream.
1951 * Note that the filter function only applies to the current source file
1952 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1954 * The datasv parameter (which may be NULL) can be used to pass
1955 * private data to this instance of the filter. The filter function
1956 * can recover the SV using the FILTER_DATA macro and use it to
1957 * store private buffers and state information.
1959 * The supplied datasv parameter is upgraded to a PVIO type
1960 * and the IoDIRP/IoANY field is used to store the function pointer,
1961 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
1962 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1963 * private use must be set using malloc'd pointers.
1967 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
1972 if (!PL_rsfp_filters)
1973 PL_rsfp_filters = newAV();
1975 datasv = NEWSV(255,0);
1976 if (!SvUPGRADE(datasv, SVt_PVIO))
1977 Perl_die(aTHX_ "Can't upgrade filter_add data to SVt_PVIO");
1978 IoANY(datasv) = (void *)funcp; /* stash funcp into spare field */
1979 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
1980 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
1981 funcp, SvPV_nolen(datasv)));
1982 av_unshift(PL_rsfp_filters, 1);
1983 av_store(PL_rsfp_filters, 0, datasv) ;
1988 /* Delete most recently added instance of this filter function. */
1990 Perl_filter_del(pTHX_ filter_t funcp)
1993 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", funcp));
1994 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
1996 /* if filter is on top of stack (usual case) just pop it off */
1997 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
1998 if (IoANY(datasv) == (void *)funcp) {
1999 IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
2000 IoANY(datasv) = (void *)NULL;
2001 sv_free(av_pop(PL_rsfp_filters));
2005 /* we need to search for the correct entry and clear it */
2006 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
2010 /* Invoke the n'th filter function for the current rsfp. */
2012 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
2015 /* 0 = read one text line */
2020 if (!PL_rsfp_filters)
2022 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
2023 /* Provide a default input filter to make life easy. */
2024 /* Note that we append to the line. This is handy. */
2025 DEBUG_P(PerlIO_printf(Perl_debug_log,
2026 "filter_read %d: from rsfp\n", idx));
2030 int old_len = SvCUR(buf_sv) ;
2032 /* ensure buf_sv is large enough */
2033 SvGROW(buf_sv, old_len + maxlen) ;
2034 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
2035 if (PerlIO_error(PL_rsfp))
2036 return -1; /* error */
2038 return 0 ; /* end of file */
2040 SvCUR_set(buf_sv, old_len + len) ;
2043 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
2044 if (PerlIO_error(PL_rsfp))
2045 return -1; /* error */
2047 return 0 ; /* end of file */
2050 return SvCUR(buf_sv);
2052 /* Skip this filter slot if filter has been deleted */
2053 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
2054 DEBUG_P(PerlIO_printf(Perl_debug_log,
2055 "filter_read %d: skipped (filter deleted)\n",
2057 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
2059 /* Get function pointer hidden within datasv */
2060 funcp = (filter_t)IoANY(datasv);
2061 DEBUG_P(PerlIO_printf(Perl_debug_log,
2062 "filter_read %d: via function %p (%s)\n",
2063 idx, funcp, SvPV_nolen(datasv)));
2064 /* Call function. The function is expected to */
2065 /* call "FILTER_READ(idx+1, buf_sv)" first. */
2066 /* Return: <0:error, =0:eof, >0:not eof */
2067 return (*funcp)(aTHX_ idx, buf_sv, maxlen);
2071 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
2073 #ifdef PERL_CR_FILTER
2074 if (!PL_rsfp_filters) {
2075 filter_add(S_cr_textfilter,NULL);
2078 if (PL_rsfp_filters) {
2081 SvCUR_set(sv, 0); /* start with empty line */
2082 if (FILTER_READ(0, sv, 0) > 0)
2083 return ( SvPVX(sv) ) ;
2088 return (sv_gets(sv, fp, append));
2092 S_find_in_my_stash(pTHX_ char *pkgname, I32 len)
2096 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
2100 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
2101 (gv = gv_fetchpv(pkgname, FALSE, SVt_PVHV)))
2103 return GvHV(gv); /* Foo:: */
2106 /* use constant CLASS => 'MyClass' */
2107 if ((gv = gv_fetchpv(pkgname, FALSE, SVt_PVCV))) {
2109 if (GvCV(gv) && (sv = cv_const_sv(GvCV(gv)))) {
2110 pkgname = SvPV_nolen(sv);
2114 return gv_stashpv(pkgname, FALSE);
2118 static char* exp_name[] =
2119 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
2120 "ATTRTERM", "TERMBLOCK"
2127 Works out what to call the token just pulled out of the input
2128 stream. The yacc parser takes care of taking the ops we return and
2129 stitching them into a tree.
2135 if read an identifier
2136 if we're in a my declaration
2137 croak if they tried to say my($foo::bar)
2138 build the ops for a my() declaration
2139 if it's an access to a my() variable
2140 are we in a sort block?
2141 croak if my($a); $a <=> $b
2142 build ops for access to a my() variable
2143 if in a dq string, and they've said @foo and we can't find @foo
2145 build ops for a bareword
2146 if we already built the token before, use it.
2149 #ifdef USE_PURE_BISON
2151 Perl_yylex_r(pTHX_ YYSTYPE *lvalp, int *lcharp)
2156 yylval_pointer[yyactlevel] = lvalp;
2157 yychar_pointer[yyactlevel] = lcharp;
2158 if (yyactlevel >= YYMAXLEVEL)
2159 Perl_croak(aTHX_ "panic: YYMAXLEVEL");
2161 r = Perl_yylex(aTHX);
2171 #pragma segment Perl_yylex
2184 /* check if there's an identifier for us to look at */
2185 if (PL_pending_ident)
2186 return S_pending_ident(aTHX);
2188 /* no identifier pending identification */
2190 switch (PL_lex_state) {
2192 case LEX_NORMAL: /* Some compilers will produce faster */
2193 case LEX_INTERPNORMAL: /* code if we comment these out. */
2197 /* when we've already built the next token, just pull it out of the queue */
2200 yylval = PL_nextval[PL_nexttoke];
2202 PL_lex_state = PL_lex_defer;
2203 PL_expect = PL_lex_expect;
2204 PL_lex_defer = LEX_NORMAL;
2206 DEBUG_T({ PerlIO_printf(Perl_debug_log,
2207 "### Next token after '%s' was known, type %"IVdf"\n", PL_bufptr,
2208 (IV)PL_nexttype[PL_nexttoke]); });
2210 return(PL_nexttype[PL_nexttoke]);
2212 /* interpolated case modifiers like \L \U, including \Q and \E.
2213 when we get here, PL_bufptr is at the \
2215 case LEX_INTERPCASEMOD:
2217 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
2218 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
2220 /* handle \E or end of string */
2221 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
2225 if (PL_lex_casemods) {
2226 oldmod = PL_lex_casestack[--PL_lex_casemods];
2227 PL_lex_casestack[PL_lex_casemods] = '\0';
2229 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
2231 PL_lex_state = LEX_INTERPCONCAT;
2235 if (PL_bufptr != PL_bufend)
2237 PL_lex_state = LEX_INTERPCONCAT;
2241 DEBUG_T({ PerlIO_printf(Perl_debug_log,
2242 "### Saw case modifier at '%s'\n", PL_bufptr); });
2244 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
2245 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
2246 if (strchr("LU", *s) &&
2247 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
2249 PL_lex_casestack[--PL_lex_casemods] = '\0';
2252 if (PL_lex_casemods > 10) {
2253 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
2254 if (newlb != PL_lex_casestack) {
2256 PL_lex_casestack = newlb;
2259 PL_lex_casestack[PL_lex_casemods++] = *s;
2260 PL_lex_casestack[PL_lex_casemods] = '\0';
2261 PL_lex_state = LEX_INTERPCONCAT;
2262 PL_nextval[PL_nexttoke].ival = 0;
2265 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
2267 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
2269 PL_nextval[PL_nexttoke].ival = OP_LC;
2271 PL_nextval[PL_nexttoke].ival = OP_UC;
2273 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
2275 Perl_croak(aTHX_ "panic: yylex");
2278 if (PL_lex_starts) {
2287 case LEX_INTERPPUSH:
2288 return sublex_push();
2290 case LEX_INTERPSTART:
2291 if (PL_bufptr == PL_bufend)
2292 return sublex_done();
2293 DEBUG_T({ PerlIO_printf(Perl_debug_log,
2294 "### Interpolated variable at '%s'\n", PL_bufptr); });
2296 PL_lex_dojoin = (*PL_bufptr == '@');
2297 PL_lex_state = LEX_INTERPNORMAL;
2298 if (PL_lex_dojoin) {
2299 PL_nextval[PL_nexttoke].ival = 0;
2301 #ifdef USE_5005THREADS
2302 PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
2303 PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
2304 force_next(PRIVATEREF);
2306 force_ident("\"", '$');
2307 #endif /* USE_5005THREADS */
2308 PL_nextval[PL_nexttoke].ival = 0;
2310 PL_nextval[PL_nexttoke].ival = 0;
2312 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
2315 if (PL_lex_starts++) {
2321 case LEX_INTERPENDMAYBE:
2322 if (intuit_more(PL_bufptr)) {
2323 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
2329 if (PL_lex_dojoin) {
2330 PL_lex_dojoin = FALSE;
2331 PL_lex_state = LEX_INTERPCONCAT;
2334 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
2335 && SvEVALED(PL_lex_repl))
2337 if (PL_bufptr != PL_bufend)
2338 Perl_croak(aTHX_ "Bad evalled substitution pattern");
2339 PL_lex_repl = Nullsv;
2342 case LEX_INTERPCONCAT:
2344 if (PL_lex_brackets)
2345 Perl_croak(aTHX_ "panic: INTERPCONCAT");
2347 if (PL_bufptr == PL_bufend)
2348 return sublex_done();
2350 if (SvIVX(PL_linestr) == '\'') {
2351 SV *sv = newSVsv(PL_linestr);
2354 else if ( PL_hints & HINT_NEW_RE )
2355 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
2356 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2360 s = scan_const(PL_bufptr);
2362 PL_lex_state = LEX_INTERPCASEMOD;
2364 PL_lex_state = LEX_INTERPSTART;
2367 if (s != PL_bufptr) {
2368 PL_nextval[PL_nexttoke] = yylval;
2371 if (PL_lex_starts++)
2381 PL_lex_state = LEX_NORMAL;
2382 s = scan_formline(PL_bufptr);
2383 if (!PL_lex_formbrack)
2389 PL_oldoldbufptr = PL_oldbufptr;
2392 PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at %s\n",
2393 exp_name[PL_expect], s);
2399 if (isIDFIRST_lazy_if(s,UTF))
2401 Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
2404 goto fake_eof; /* emulate EOF on ^D or ^Z */
2409 if (PL_lex_brackets)
2410 yyerror("Missing right curly or square bracket");
2411 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2412 "### Tokener got EOF\n");
2416 if (s++ < PL_bufend)
2417 goto retry; /* ignore stray nulls */
2420 if (!PL_in_eval && !PL_preambled) {
2421 PL_preambled = TRUE;
2422 sv_setpv(PL_linestr,incl_perldb());
2423 if (SvCUR(PL_linestr))
2424 sv_catpv(PL_linestr,";");
2426 while(AvFILLp(PL_preambleav) >= 0) {
2427 SV *tmpsv = av_shift(PL_preambleav);
2428 sv_catsv(PL_linestr, tmpsv);
2429 sv_catpv(PL_linestr, ";");
2432 sv_free((SV*)PL_preambleav);
2433 PL_preambleav = NULL;
2435 if (PL_minus_n || PL_minus_p) {
2436 sv_catpv(PL_linestr, "LINE: while (<>) {");
2438 sv_catpv(PL_linestr,"chomp;");
2441 if (strchr("/'\"", *PL_splitstr)
2442 && strchr(PL_splitstr + 1, *PL_splitstr))
2443 Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s);", PL_splitstr);
2446 s = "'~#\200\1'"; /* surely one char is unused...*/
2447 while (s[1] && strchr(PL_splitstr, *s)) s++;
2449 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s%c",
2450 "q" + (delim == '\''), delim);
2451 for (s = PL_splitstr; *s; s++) {
2453 sv_catpvn(PL_linestr, "\\", 1);
2454 sv_catpvn(PL_linestr, s, 1);
2456 Perl_sv_catpvf(aTHX_ PL_linestr, "%c);", delim);
2460 sv_catpv(PL_linestr,"our @F=split(' ');");
2463 sv_catpv(PL_linestr, "\n");
2464 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2465 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2466 PL_last_lop = PL_last_uni = Nullch;
2467 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2468 SV *sv = NEWSV(85,0);
2470 sv_upgrade(sv, SVt_PVMG);
2471 sv_setsv(sv,PL_linestr);
2472 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2477 bof = PL_rsfp ? TRUE : FALSE;
2478 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
2481 if (PL_preprocess && !PL_in_eval)
2482 (void)PerlProc_pclose(PL_rsfp);
2483 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2484 PerlIO_clearerr(PL_rsfp);
2486 (void)PerlIO_close(PL_rsfp);
2488 PL_doextract = FALSE;
2490 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2491 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
2492 sv_catpv(PL_linestr,";}");
2493 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2494 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2495 PL_last_lop = PL_last_uni = Nullch;
2496 PL_minus_n = PL_minus_p = 0;
2499 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2500 PL_last_lop = PL_last_uni = Nullch;
2501 sv_setpv(PL_linestr,"");
2502 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
2504 /* if it looks like the start of a BOM, check if it in fact is */
2505 else if (bof && (!*s || *(U8*)s == 0xEF || *(U8*)s >= 0xFE)) {
2506 #ifdef PERLIO_IS_STDIO
2507 # ifdef __GNU_LIBRARY__
2508 # if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
2509 # define FTELL_FOR_PIPE_IS_BROKEN
2513 # if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
2514 # define FTELL_FOR_PIPE_IS_BROKEN
2519 #ifdef FTELL_FOR_PIPE_IS_BROKEN
2520 /* This loses the possibility to detect the bof
2521 * situation on perl -P when the libc5 is being used.
2522 * Workaround? Maybe attach some extra state to PL_rsfp?
2525 bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
2527 bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
2530 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2531 s = swallow_bom((U8*)s);
2535 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
2536 PL_doextract = FALSE;
2538 /* Incest with pod. */
2539 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2540 sv_setpv(PL_linestr, "");
2541 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2542 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2543 PL_last_lop = PL_last_uni = Nullch;
2544 PL_doextract = FALSE;
2548 } while (PL_doextract);
2549 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2550 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2551 SV *sv = NEWSV(85,0);
2553 sv_upgrade(sv, SVt_PVMG);
2554 sv_setsv(sv,PL_linestr);
2555 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2557 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2558 PL_last_lop = PL_last_uni = Nullch;
2559 if (CopLINE(PL_curcop) == 1) {
2560 while (s < PL_bufend && isSPACE(*s))
2562 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2566 if (*s == '#' && *(s+1) == '!')
2568 #ifdef ALTERNATE_SHEBANG
2570 static char as[] = ALTERNATE_SHEBANG;
2571 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2572 d = s + (sizeof(as) - 1);
2574 #endif /* ALTERNATE_SHEBANG */
2583 while (*d && !isSPACE(*d))
2587 #ifdef ARG_ZERO_IS_SCRIPT
2588 if (ipathend > ipath) {
2590 * HP-UX (at least) sets argv[0] to the script name,
2591 * which makes $^X incorrect. And Digital UNIX and Linux,
2592 * at least, set argv[0] to the basename of the Perl
2593 * interpreter. So, having found "#!", we'll set it right.
2595 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
2596 assert(SvPOK(x) || SvGMAGICAL(x));
2597 if (sv_eq(x, CopFILESV(PL_curcop))) {
2598 sv_setpvn(x, ipath, ipathend - ipath);
2601 TAINT_NOT; /* $^X is always tainted, but that's OK */
2603 #endif /* ARG_ZERO_IS_SCRIPT */
2608 d = instr(s,"perl -");
2610 d = instr(s,"perl");
2612 /* avoid getting into infinite loops when shebang
2613 * line contains "Perl" rather than "perl" */
2615 for (d = ipathend-4; d >= ipath; --d) {
2616 if ((*d == 'p' || *d == 'P')
2617 && !ibcmp(d, "perl", 4))
2627 #ifdef ALTERNATE_SHEBANG
2629 * If the ALTERNATE_SHEBANG on this system starts with a
2630 * character that can be part of a Perl expression, then if
2631 * we see it but not "perl", we're probably looking at the
2632 * start of Perl code, not a request to hand off to some
2633 * other interpreter. Similarly, if "perl" is there, but
2634 * not in the first 'word' of the line, we assume the line
2635 * contains the start of the Perl program.
2637 if (d && *s != '#') {
2639 while (*c && !strchr("; \t\r\n\f\v#", *c))
2642 d = Nullch; /* "perl" not in first word; ignore */
2644 *s = '#'; /* Don't try to parse shebang line */
2646 #endif /* ALTERNATE_SHEBANG */
2647 #ifndef MACOS_TRADITIONAL
2652 !instr(s,"indir") &&
2653 instr(PL_origargv[0],"perl"))
2659 while (s < PL_bufend && isSPACE(*s))
2661 if (s < PL_bufend) {
2662 Newz(899,newargv,PL_origargc+3,char*);
2664 while (s < PL_bufend && !isSPACE(*s))
2667 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2670 newargv = PL_origargv;
2672 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
2673 Perl_croak(aTHX_ "Can't exec %s", ipath);
2677 U32 oldpdb = PL_perldb;
2678 bool oldn = PL_minus_n;
2679 bool oldp = PL_minus_p;
2681 while (*d && !isSPACE(*d)) d++;
2682 while (SPACE_OR_TAB(*d)) d++;
2686 if (*d == 'M' || *d == 'm') {
2688 while (*d && !isSPACE(*d)) d++;
2689 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2692 d = moreswitches(d);
2694 if ((PERLDB_LINE && !oldpdb) ||
2695 ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
2696 /* if we have already added "LINE: while (<>) {",
2697 we must not do it again */
2699 sv_setpv(PL_linestr, "");
2700 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2701 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2702 PL_last_lop = PL_last_uni = Nullch;
2703 PL_preambled = FALSE;
2705 (void)gv_fetchfile(PL_origfilename);
2712 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2714 PL_lex_state = LEX_FORMLINE;
2719 #ifdef PERL_STRICT_CR
2720 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2722 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
2724 case ' ': case '\t': case '\f': case 013:
2725 #ifdef MACOS_TRADITIONAL
2732 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2733 if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
2734 /* handle eval qq[#line 1 "foo"\n ...] */
2735 CopLINE_dec(PL_curcop);
2739 while (s < d && *s != '\n')
2743 else if (s > d) /* Found by Ilya: feed random input to Perl. */
2744 Perl_croak(aTHX_ "panic: input overflow");
2746 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2748 PL_lex_state = LEX_FORMLINE;
2758 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2765 while (s < PL_bufend && SPACE_OR_TAB(*s))
2768 if (strnEQ(s,"=>",2)) {
2769 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2770 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2771 "### Saw unary minus before =>, forcing word '%s'\n", s);
2773 OPERATOR('-'); /* unary minus */
2775 PL_last_uni = PL_oldbufptr;
2777 case 'r': ftst = OP_FTEREAD; break;
2778 case 'w': ftst = OP_FTEWRITE; break;
2779 case 'x': ftst = OP_FTEEXEC; break;
2780 case 'o': ftst = OP_FTEOWNED; break;
2781 case 'R': ftst = OP_FTRREAD; break;
2782 case 'W': ftst = OP_FTRWRITE; break;
2783 case 'X': ftst = OP_FTREXEC; break;
2784 case 'O': ftst = OP_FTROWNED; break;
2785 case 'e': ftst = OP_FTIS; break;
2786 case 'z': ftst = OP_FTZERO; break;
2787 case 's': ftst = OP_FTSIZE; break;
2788 case 'f': ftst = OP_FTFILE; break;
2789 case 'd': ftst = OP_FTDIR; break;
2790 case 'l': ftst = OP_FTLINK; break;
2791 case 'p': ftst = OP_FTPIPE; break;
2792 case 'S': ftst = OP_FTSOCK; break;
2793 case 'u': ftst = OP_FTSUID; break;
2794 case 'g': ftst = OP_FTSGID; break;
2795 case 'k': ftst = OP_FTSVTX; break;
2796 case 'b': ftst = OP_FTBLK; break;
2797 case 'c': ftst = OP_FTCHR; break;
2798 case 't': ftst = OP_FTTTY; break;
2799 case 'T': ftst = OP_FTTEXT; break;
2800 case 'B': ftst = OP_FTBINARY; break;
2801 case 'M': case 'A': case 'C':
2802 gv_fetchpv("\024",TRUE, SVt_PV);
2804 case 'M': ftst = OP_FTMTIME; break;
2805 case 'A': ftst = OP_FTATIME; break;
2806 case 'C': ftst = OP_FTCTIME; break;
2814 PL_last_lop_op = ftst;
2815 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2816 "### Saw file test %c\n", (int)ftst);
2821 /* Assume it was a minus followed by a one-letter named
2822 * subroutine call (or a -bareword), then. */
2823 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2824 "### %c looked like a file test but was not\n",
2833 if (PL_expect == XOPERATOR)
2838 else if (*s == '>') {
2841 if (isIDFIRST_lazy_if(s,UTF)) {
2842 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2850 if (PL_expect == XOPERATOR)
2853 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2855 OPERATOR('-'); /* unary minus */
2862 if (PL_expect == XOPERATOR)
2867 if (PL_expect == XOPERATOR)
2870 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2876 if (PL_expect != XOPERATOR) {
2877 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2878 PL_expect = XOPERATOR;
2879 force_ident(PL_tokenbuf, '*');
2892 if (PL_expect == XOPERATOR) {
2896 PL_tokenbuf[0] = '%';
2897 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2898 if (!PL_tokenbuf[1]) {
2900 yyerror("Final % should be \\% or %name");
2903 PL_pending_ident = '%';
2922 switch (PL_expect) {
2925 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
2927 PL_bufptr = s; /* update in case we back off */
2933 PL_expect = XTERMBLOCK;
2937 while (isIDFIRST_lazy_if(s,UTF)) {
2938 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2939 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
2940 if (tmp < 0) tmp = -tmp;
2955 d = scan_str(d,TRUE,TRUE);
2957 /* MUST advance bufptr here to avoid bogus
2958 "at end of line" context messages from yyerror().
2960 PL_bufptr = s + len;
2961 yyerror("Unterminated attribute parameter in attribute list");
2964 return 0; /* EOF indicator */
2968 SV *sv = newSVpvn(s, len);
2969 sv_catsv(sv, PL_lex_stuff);
2970 attrs = append_elem(OP_LIST, attrs,
2971 newSVOP(OP_CONST, 0, sv));
2972 SvREFCNT_dec(PL_lex_stuff);
2973 PL_lex_stuff = Nullsv;
2976 if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len))
2977 CvLVALUE_on(PL_compcv);
2978 else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len))
2979 CvLOCKED_on(PL_compcv);
2980 else if (!PL_in_my && len == 6 && strnEQ(s, "method", len))
2981 CvMETHOD_on(PL_compcv);
2983 else if (PL_in_my == KEY_our && len == 6 && strnEQ(s, "unique", len))
2984 GvUNIQUE_on(cGVOPx_gv(yylval.opval));
2986 /* After we've set the flags, it could be argued that
2987 we don't need to do the attributes.pm-based setting
2988 process, and shouldn't bother appending recognized
2989 flags. To experiment with that, uncomment the
2990 following "else": */
2992 attrs = append_elem(OP_LIST, attrs,
2993 newSVOP(OP_CONST, 0,
2997 if (*s == ':' && s[1] != ':')
3000 break; /* require real whitespace or :'s */
3002 tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
3003 if (*s != ';' && *s != tmp && (tmp != '=' || *s != ')')) {
3004 char q = ((*s == '\'') ? '"' : '\'');
3005 /* If here for an expression, and parsed no attrs, back off. */
3006 if (tmp == '=' && !attrs) {
3010 /* MUST advance bufptr here to avoid bogus "at end of line"
3011 context messages from yyerror().
3015 yyerror("Unterminated attribute list");
3017 yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list",
3025 PL_nextval[PL_nexttoke].opval = attrs;
3033 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
3034 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
3050 if (PL_lex_brackets <= 0)
3051 yyerror("Unmatched right square bracket");
3054 if (PL_lex_state == LEX_INTERPNORMAL) {
3055 if (PL_lex_brackets == 0) {
3056 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
3057 PL_lex_state = LEX_INTERPEND;
3064 if (PL_lex_brackets > 100) {
3065 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
3066 if (newlb != PL_lex_brackstack) {
3068 PL_lex_brackstack = newlb;
3071 switch (PL_expect) {
3073 if (PL_lex_formbrack) {
3077 if (PL_oldoldbufptr == PL_last_lop)
3078 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3080 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3081 OPERATOR(HASHBRACK);
3083 while (s < PL_bufend && SPACE_OR_TAB(*s))
3086 PL_tokenbuf[0] = '\0';
3087 if (d < PL_bufend && *d == '-') {
3088 PL_tokenbuf[0] = '-';
3090 while (d < PL_bufend && SPACE_OR_TAB(*d))
3093 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
3094 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
3096 while (d < PL_bufend && SPACE_OR_TAB(*d))
3099 char minus = (PL_tokenbuf[0] == '-');
3100 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
3108 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
3113 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3118 if (PL_oldoldbufptr == PL_last_lop)
3119 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3121 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3124 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
3126 /* This hack is to get the ${} in the message. */
3128 yyerror("syntax error");
3131 OPERATOR(HASHBRACK);
3133 /* This hack serves to disambiguate a pair of curlies
3134 * as being a block or an anon hash. Normally, expectation
3135 * determines that, but in cases where we're not in a
3136 * position to expect anything in particular (like inside
3137 * eval"") we have to resolve the ambiguity. This code
3138 * covers the case where the first term in the curlies is a
3139 * quoted string. Most other cases need to be explicitly
3140 * disambiguated by prepending a `+' before the opening
3141 * curly in order to force resolution as an anon hash.
3143 * XXX should probably propagate the outer expectation
3144 * into eval"" to rely less on this hack, but that could
3145 * potentially break current behavior of eval"".
3149 if (*s == '\'' || *s == '"' || *s == '`') {
3150 /* common case: get past first string, handling escapes */
3151 for (t++; t < PL_bufend && *t != *s;)
3152 if (*t++ == '\\' && (*t == '\\' || *t == *s))
3156 else if (*s == 'q') {
3159 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
3163 char open, close, term;
3166 while (t < PL_bufend && isSPACE(*t))
3170 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
3174 for (t++; t < PL_bufend; t++) {
3175 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
3177 else if (*t == open)
3181 for (t++; t < PL_bufend; t++) {
3182 if (*t == '\\' && t+1 < PL_bufend)
3184 else if (*t == close && --brackets <= 0)
3186 else if (*t == open)
3192 else if (isALNUM_lazy_if(t,UTF)) {
3194 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3197 while (t < PL_bufend && isSPACE(*t))
3199 /* if comma follows first term, call it an anon hash */
3200 /* XXX it could be a comma expression with loop modifiers */
3201 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
3202 || (*t == '=' && t[1] == '>')))
3203 OPERATOR(HASHBRACK);
3204 if (PL_expect == XREF)
3207 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
3213 yylval.ival = CopLINE(PL_curcop);
3214 if (isSPACE(*s) || *s == '#')
3215 PL_copline = NOLINE; /* invalidate current command line number */
3220 if (PL_lex_brackets <= 0)
3221 yyerror("Unmatched right curly bracket");
3223 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
3224 if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
3225 PL_lex_formbrack = 0;
3226 if (PL_lex_state == LEX_INTERPNORMAL) {
3227 if (PL_lex_brackets == 0) {
3228 if (PL_expect & XFAKEBRACK) {
3229 PL_expect &= XENUMMASK;
3230 PL_lex_state = LEX_INTERPEND;
3232 return yylex(); /* ignore fake brackets */
3234 if (*s == '-' && s[1] == '>')
3235 PL_lex_state = LEX_INTERPENDMAYBE;
3236 else if (*s != '[' && *s != '{')
3237 PL_lex_state = LEX_INTERPEND;
3240 if (PL_expect & XFAKEBRACK) {
3241 PL_expect &= XENUMMASK;
3243 return yylex(); /* ignore fake brackets */
3253 if (PL_expect == XOPERATOR) {
3254 if (ckWARN(WARN_SEMICOLON)
3255 && isIDFIRST_lazy_if(s,UTF) && PL_bufptr == PL_linestart)
3257 CopLINE_dec(PL_curcop);
3258 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3259 CopLINE_inc(PL_curcop);
3264 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3266 PL_expect = XOPERATOR;
3267 force_ident(PL_tokenbuf, '&');
3271 yylval.ival = (OPpENTERSUB_AMPER<<8);
3290 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
3291 Perl_warner(aTHX_ WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
3293 if (PL_expect == XSTATE && isALPHA(tmp) &&
3294 (s == PL_linestart+1 || s[-2] == '\n') )
3296 if (PL_in_eval && !PL_rsfp) {
3301 if (strnEQ(s,"=cut",4)) {
3315 PL_doextract = TRUE;
3318 if (PL_lex_brackets < PL_lex_formbrack) {
3320 #ifdef PERL_STRICT_CR
3321 for (t = s; SPACE_OR_TAB(*t); t++) ;
3323 for (t = s; SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
3325 if (*t == '\n' || *t == '#') {
3343 if (PL_expect != XOPERATOR) {
3344 if (s[1] != '<' && !strchr(s,'>'))
3347 s = scan_heredoc(s);
3349 s = scan_inputsymbol(s);
3350 TERM(sublex_start());
3355 SHop(OP_LEFT_SHIFT);
3369 SHop(OP_RIGHT_SHIFT);
3378 if (PL_expect == XOPERATOR) {
3379 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3382 return ','; /* grandfather non-comma-format format */
3386 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
3387 PL_tokenbuf[0] = '@';
3388 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3389 sizeof PL_tokenbuf - 1, FALSE);
3390 if (PL_expect == XOPERATOR)
3391 no_op("Array length", s);
3392 if (!PL_tokenbuf[1])
3394 PL_expect = XOPERATOR;
3395 PL_pending_ident = '#';
3399 PL_tokenbuf[0] = '$';
3400 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3401 sizeof PL_tokenbuf - 1, FALSE);
3402 if (PL_expect == XOPERATOR)
3404 if (!PL_tokenbuf[1]) {
3406 yyerror("Final $ should be \\$ or $name");
3410 /* This kludge not intended to be bulletproof. */
3411 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
3412 yylval.opval = newSVOP(OP_CONST, 0,
3413 newSViv(PL_compiling.cop_arybase));
3414 yylval.opval->op_private = OPpCONST_ARYBASE;
3420 if (PL_lex_state == LEX_NORMAL)
3423 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3426 PL_tokenbuf[0] = '@';
3427 if (ckWARN(WARN_SYNTAX)) {
3429 isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$';
3432 PL_bufptr = skipspace(PL_bufptr);
3433 while (t < PL_bufend && *t != ']')
3435 Perl_warner(aTHX_ WARN_SYNTAX,
3436 "Multidimensional syntax %.*s not supported",
3437 (t - PL_bufptr) + 1, PL_bufptr);
3441 else if (*s == '{') {
3442 PL_tokenbuf[0] = '%';
3443 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
3444 (t = strchr(s, '}')) && (t = strchr(t, '=')))
3446 char tmpbuf[sizeof PL_tokenbuf];
3448 for (t++; isSPACE(*t); t++) ;
3449 if (isIDFIRST_lazy_if(t,UTF)) {
3450 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
3451 for (; isSPACE(*t); t++) ;
3452 if (*t == ';' && get_cv(tmpbuf, FALSE))
3453 Perl_warner(aTHX_ WARN_SYNTAX,
3454 "You need to quote \"%s\"", tmpbuf);
3460 PL_expect = XOPERATOR;
3461 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3462 bool islop = (PL_last_lop == PL_oldoldbufptr);
3463 if (!islop || PL_last_lop_op == OP_GREPSTART)
3464 PL_expect = XOPERATOR;
3465 else if (strchr("$@\"'`q", *s))
3466 PL_expect = XTERM; /* e.g. print $fh "foo" */
3467 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
3468 PL_expect = XTERM; /* e.g. print $fh &sub */
3469 else if (isIDFIRST_lazy_if(s,UTF)) {
3470 char tmpbuf[sizeof PL_tokenbuf];
3471 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3472 if ((tmp = keyword(tmpbuf, len))) {
3473 /* binary operators exclude handle interpretations */
3485 PL_expect = XTERM; /* e.g. print $fh length() */
3490 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
3491 if (gv && GvCVu(gv))
3492 PL_expect = XTERM; /* e.g. print $fh subr() */
3495 else if (isDIGIT(*s))
3496 PL_expect = XTERM; /* e.g. print $fh 3 */
3497 else if (*s == '.' && isDIGIT(s[1]))
3498 PL_expect = XTERM; /* e.g. print $fh .3 */
3499 else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
3500 PL_expect = XTERM; /* e.g. print $fh -1 */
3501 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3502 PL_expect = XTERM; /* print $fh <<"EOF" */
3504 PL_pending_ident = '$';
3508 if (PL_expect == XOPERATOR)
3510 PL_tokenbuf[0] = '@';
3511 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3512 if (!PL_tokenbuf[1]) {
3514 yyerror("Final @ should be \\@ or @name");
3517 if (PL_lex_state == LEX_NORMAL)
3519 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3521 PL_tokenbuf[0] = '%';
3523 /* Warn about @ where they meant $. */
3524 if (ckWARN(WARN_SYNTAX)) {
3525 if (*s == '[' || *s == '{') {
3527 while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
3529 if (*t == '}' || *t == ']') {
3531 PL_bufptr = skipspace(PL_bufptr);
3532 Perl_warner(aTHX_ WARN_SYNTAX,
3533 "Scalar value %.*s better written as $%.*s",
3534 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
3539 PL_pending_ident = '@';
3542 case '/': /* may either be division or pattern */
3543 case '?': /* may either be conditional or pattern */
3544 if (PL_expect != XOPERATOR) {
3545 /* Disable warning on "study /blah/" */
3546 if (PL_oldoldbufptr == PL_last_uni
3547 && (*PL_last_uni != 's' || s - PL_last_uni < 5
3548 || memNE(PL_last_uni, "study", 5)
3549 || isALNUM_lazy_if(PL_last_uni+5,UTF)))
3551 s = scan_pat(s,OP_MATCH);
3552 TERM(sublex_start());
3560 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3561 #ifdef PERL_STRICT_CR
3564 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3566 && (s == PL_linestart || s[-1] == '\n') )
3568 PL_lex_formbrack = 0;
3572 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
3578 yylval.ival = OPf_SPECIAL;
3584 if (PL_expect != XOPERATOR)
3589 case '0': case '1': case '2': case '3': case '4':
3590 case '5': case '6': case '7': case '8': case '9':
3591 s = scan_num(s, &yylval);
3592 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3593 "### Saw number in '%s'\n", s);
3595 if (PL_expect == XOPERATOR)
3600 s = scan_str(s,FALSE,FALSE);
3601 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3602 "### Saw string before '%s'\n", s);
3604 if (PL_expect == XOPERATOR) {
3605 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3608 return ','; /* grandfather non-comma-format format */
3614 missingterm((char*)0);
3615 yylval.ival = OP_CONST;
3616 TERM(sublex_start());
3619 s = scan_str(s,FALSE,FALSE);
3620 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3621 "### Saw string before '%s'\n", s);
3623 if (PL_expect == XOPERATOR) {
3624 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3627 return ','; /* grandfather non-comma-format format */
3633 missingterm((char*)0);
3634 yylval.ival = OP_CONST;
3635 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
3636 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
3637 yylval.ival = OP_STRINGIFY;
3641 TERM(sublex_start());
3644 s = scan_str(s,FALSE,FALSE);
3645 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3646 "### Saw backtick string before '%s'\n", s);
3648 if (PL_expect == XOPERATOR)
3649 no_op("Backticks",s);
3651 missingterm((char*)0);
3652 yylval.ival = OP_BACKTICK;
3654 TERM(sublex_start());
3658 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
3659 Perl_warner(aTHX_ WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
3661 if (PL_expect == XOPERATOR)
3662 no_op("Backslash",s);
3666 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
3670 while (isDIGIT(*start) || *start == '_')
3672 if (*start == '.' && isDIGIT(start[1])) {
3673 s = scan_num(s, &yylval);
3676 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
3677 else if (!isALPHA(*start) && (PL_expect == XTERM || PL_expect == XREF || PL_expect == XSTATE)) {
3681 gv = gv_fetchpv(s, FALSE, SVt_PVCV);
3684 s = scan_num(s, &yylval);
3691 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
3730 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3732 /* Some keywords can be followed by any delimiter, including ':' */
3733 tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
3734 (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
3735 (PL_tokenbuf[0] == 'q' &&
3736 strchr("qwxr", PL_tokenbuf[1])))));
3738 /* x::* is just a word, unless x is "CORE" */
3739 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
3743 while (d < PL_bufend && isSPACE(*d))
3744 d++; /* no comments skipped here, or s### is misparsed */
3746 /* Is this a label? */
3747 if (!tmp && PL_expect == XSTATE
3748 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
3750 yylval.pval = savepv(PL_tokenbuf);
3755 /* Check for keywords */
3756 tmp = keyword(PL_tokenbuf, len);
3758 /* Is this a word before a => operator? */
3759 if (*d == '=' && d[1] == '>') {
3761 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
3762 yylval.opval->op_private = OPpCONST_BARE;
3763 if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
3764 SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
3768 if (tmp < 0) { /* second-class keyword? */
3769 GV *ogv = Nullgv; /* override (winner) */
3770 GV *hgv = Nullgv; /* hidden (loser) */
3771 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3773 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3776 if (GvIMPORTED_CV(gv))
3778 else if (! CvMETHOD(cv))
3782 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3783 (gv = *gvp) != (GV*)&PL_sv_undef &&
3784 GvCVu(gv) && GvIMPORTED_CV(gv))
3790 tmp = 0; /* overridden by import or by GLOBAL */
3793 && -tmp==KEY_lock /* XXX generalizable kludge */
3795 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3797 tmp = 0; /* any sub overrides "weak" keyword */
3799 else { /* no override */
3803 if (ckWARN(WARN_AMBIGUOUS) && hgv
3804 && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3805 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3806 "Ambiguous call resolved as CORE::%s(), %s",
3807 GvENAME(hgv), "qualify as such or use &");
3814 default: /* not a keyword */
3818 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3820 /* Get the rest if it looks like a package qualifier */
3822 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
3824 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3827 Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
3828 *s == '\'' ? "'" : "::");
3833 if (PL_expect == XOPERATOR) {
3834 if (PL_bufptr == PL_linestart) {
3835 CopLINE_dec(PL_curcop);
3836 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3837 CopLINE_inc(PL_curcop);
3840 no_op("Bareword",s);
3843 /* Look for a subroutine with this name in current package,
3844 unless name is "Foo::", in which case Foo is a bearword
3845 (and a package name). */
3848 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3850 if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3851 Perl_warner(aTHX_ WARN_BAREWORD,
3852 "Bareword \"%s\" refers to nonexistent package",
3855 PL_tokenbuf[len] = '\0';
3862 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3865 /* if we saw a global override before, get the right name */
3868 sv = newSVpvn("CORE::GLOBAL::",14);
3869 sv_catpv(sv,PL_tokenbuf);
3872 sv = newSVpv(PL_tokenbuf,0);
3874 /* Presume this is going to be a bareword of some sort. */
3877 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3878 yylval.opval->op_private = OPpCONST_BARE;
3880 /* And if "Foo::", then that's what it certainly is. */
3885 /* See if it's the indirect object for a list operator. */
3887 if (PL_oldoldbufptr &&
3888 PL_oldoldbufptr < PL_bufptr &&
3889 (PL_oldoldbufptr == PL_last_lop
3890 || PL_oldoldbufptr == PL_last_uni) &&
3891 /* NO SKIPSPACE BEFORE HERE! */
3892 (PL_expect == XREF ||
3893 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
3895 bool immediate_paren = *s == '(';
3897 /* (Now we can afford to cross potential line boundary.) */
3900 /* Two barewords in a row may indicate method call. */
3902 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp=intuit_method(s,gv)))
3905 /* If not a declared subroutine, it's an indirect object. */
3906 /* (But it's an indir obj regardless for sort.) */
3908 if ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
3909 ((!gv || !GvCVu(gv)) &&
3910 (PL_last_lop_op != OP_MAPSTART &&
3911 PL_last_lop_op != OP_GREPSTART))))
3913 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3918 PL_expect = XOPERATOR;
3921 /* Is this a word before a => operator? */
3922 if (*s == '=' && s[1] == '>' && !pkgname) {
3924 sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
3925 if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
3926 SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
3930 /* If followed by a paren, it's certainly a subroutine. */
3933 if (gv && GvCVu(gv)) {
3934 for (d = s + 1; SPACE_OR_TAB(*d); d++) ;
3935 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
3940 PL_nextval[PL_nexttoke].opval = yylval.opval;
3941 PL_expect = XOPERATOR;
3947 /* If followed by var or block, call it a method (unless sub) */
3949 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3950 PL_last_lop = PL_oldbufptr;
3951 PL_last_lop_op = OP_METHOD;
3955 /* If followed by a bareword, see if it looks like indir obj. */
3957 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp = intuit_method(s,gv)))
3960 /* Not a method, so call it a subroutine (if defined) */
3962 if (gv && GvCVu(gv)) {
3964 if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
3965 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3966 "Ambiguous use of -%s resolved as -&%s()",
3967 PL_tokenbuf, PL_tokenbuf);
3968 /* Check for a constant sub */
3970 if ((sv = cv_const_sv(cv))) {
3972 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3973 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3974 yylval.opval->op_private = 0;
3978 /* Resolve to GV now. */
3979 op_free(yylval.opval);
3980 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3981 yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
3982 PL_last_lop = PL_oldbufptr;
3983 PL_last_lop_op = OP_ENTERSUB;
3984 /* Is there a prototype? */
3987 char *proto = SvPV((SV*)cv, len);
3990 if (strEQ(proto, "$"))
3992 if (*proto == '&' && *s == '{') {
3993 sv_setpv(PL_subname,"__ANON__");
3997 PL_nextval[PL_nexttoke].opval = yylval.opval;
4003 /* Call it a bare word */
4005 if (PL_hints & HINT_STRICT_SUBS)
4006 yylval.opval->op_private |= OPpCONST_STRICT;
4009 if (ckWARN(WARN_RESERVED)) {
4010 if (lastchar != '-') {
4011 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
4012 if (!*d && strNE(PL_tokenbuf,"main"))
4013 Perl_warner(aTHX_ WARN_RESERVED, PL_warn_reserved,
4020 if (lastchar && strchr("*%&", lastchar) && ckWARN_d(WARN_AMBIGUOUS)) {
4021 Perl_warner(aTHX_ WARN_AMBIGUOUS,
4022 "Operator or semicolon missing before %c%s",
4023 lastchar, PL_tokenbuf);
4024 Perl_warner(aTHX_ WARN_AMBIGUOUS,
4025 "Ambiguous use of %c resolved as operator %c",
4026 lastchar, lastchar);
4032 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4033 newSVpv(CopFILE(PL_curcop),0));
4037 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4038 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
4041 case KEY___PACKAGE__:
4042 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4044 ? newSVsv(PL_curstname)
4053 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
4054 char *pname = "main";
4055 if (PL_tokenbuf[2] == 'D')
4056 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
4057 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
4060 GvIOp(gv) = newIO();
4061 IoIFP(GvIOp(gv)) = PL_rsfp;
4062 #if defined(HAS_FCNTL) && defined(F_SETFD)
4064 int fd = PerlIO_fileno(PL_rsfp);
4065 fcntl(fd,F_SETFD,fd >= 3);
4068 /* Mark this internal pseudo-handle as clean */
4069 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
4071 IoTYPE(GvIOp(gv)) = IoTYPE_PIPE;
4072 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
4073 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
4075 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
4076 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
4077 /* if the script was opened in binmode, we need to revert
4078 * it to text mode for compatibility; but only iff it has CRs
4079 * XXX this is a questionable hack at best. */
4080 if (PL_bufend-PL_bufptr > 2
4081 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
4084 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
4085 loc = PerlIO_tell(PL_rsfp);
4086 (void)PerlIO_seek(PL_rsfp, 0L, 0);
4089 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
4091 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
4092 #endif /* NETWARE */
4093 #ifdef PERLIO_IS_STDIO /* really? */
4094 # if defined(__BORLANDC__)
4095 /* XXX see note in do_binmode() */
4096 ((FILE*)PL_rsfp)->flags &= ~_F_BIN;
4100 PerlIO_seek(PL_rsfp, loc, 0);
4104 #ifdef PERLIO_LAYERS
4105 if (UTF && !IN_BYTES)
4106 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
4119 if (PL_expect == XSTATE) {
4126 if (*s == ':' && s[1] == ':') {
4129 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4130 if (!(tmp = keyword(PL_tokenbuf, len)))
4131 Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
4145 LOP(OP_ACCEPT,XTERM);
4151 LOP(OP_ATAN2,XTERM);
4157 LOP(OP_BINMODE,XTERM);
4160 LOP(OP_BLESS,XTERM);
4169 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
4186 if (!PL_cryptseen) {
4187 PL_cryptseen = TRUE;
4191 LOP(OP_CRYPT,XTERM);
4194 LOP(OP_CHMOD,XTERM);
4197 LOP(OP_CHOWN,XTERM);
4200 LOP(OP_CONNECT,XTERM);
4216 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4220 PL_hints |= HINT_BLOCK_SCOPE;
4230 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
4231 LOP(OP_DBMOPEN,XTERM);
4237 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4244 yylval.ival = CopLINE(PL_curcop);
4258 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
4259 UNIBRACK(OP_ENTEREVAL);
4274 case KEY_endhostent:
4280 case KEY_endservent:
4283 case KEY_endprotoent:
4294 yylval.ival = CopLINE(PL_curcop);
4296 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
4298 if ((PL_bufend - p) >= 3 &&
4299 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
4301 else if ((PL_bufend - p) >= 4 &&
4302 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
4305 if (isIDFIRST_lazy_if(p,UTF)) {
4306 p = scan_ident(p, PL_bufend,
4307 PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4311 Perl_croak(aTHX_ "Missing $ on loop variable");
4316 LOP(OP_FORMLINE,XTERM);
4322 LOP(OP_FCNTL,XTERM);
4328 LOP(OP_FLOCK,XTERM);
4337 LOP(OP_GREPSTART, XREF);
4340 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4355 case KEY_getpriority:
4356 LOP(OP_GETPRIORITY,XTERM);
4358 case KEY_getprotobyname:
4361 case KEY_getprotobynumber:
4362 LOP(OP_GPBYNUMBER,XTERM);
4364 case KEY_getprotoent:
4376 case KEY_getpeername:
4377 UNI(OP_GETPEERNAME);
4379 case KEY_gethostbyname:
4382 case KEY_gethostbyaddr:
4383 LOP(OP_GHBYADDR,XTERM);
4385 case KEY_gethostent:
4388 case KEY_getnetbyname:
4391 case KEY_getnetbyaddr:
4392 LOP(OP_GNBYADDR,XTERM);
4397 case KEY_getservbyname:
4398 LOP(OP_GSBYNAME,XTERM);
4400 case KEY_getservbyport:
4401 LOP(OP_GSBYPORT,XTERM);
4403 case KEY_getservent:
4406 case KEY_getsockname:
4407 UNI(OP_GETSOCKNAME);
4409 case KEY_getsockopt:
4410 LOP(OP_GSOCKOPT,XTERM);
4432 yylval.ival = CopLINE(PL_curcop);
4436 LOP(OP_INDEX,XTERM);
4442 LOP(OP_IOCTL,XTERM);
4454 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4486 LOP(OP_LISTEN,XTERM);
4495 s = scan_pat(s,OP_MATCH);
4496 TERM(sublex_start());
4499 LOP(OP_MAPSTART, XREF);
4502 LOP(OP_MKDIR,XTERM);
4505 LOP(OP_MSGCTL,XTERM);
4508 LOP(OP_MSGGET,XTERM);
4511 LOP(OP_MSGRCV,XTERM);
4514 LOP(OP_MSGSND,XTERM);
4520 if (isIDFIRST_lazy_if(s,UTF)) {
4521 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
4522 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
4524 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
4525 if (!PL_in_my_stash) {
4528 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
4536 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4543 if (PL_expect != XSTATE)
4544 yyerror("\"no\" not allowed in expression");
4545 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4546 s = force_version(s, FALSE);
4551 if (*s == '(' || (s = skipspace(s), *s == '('))
4558 if (isIDFIRST_lazy_if(s,UTF)) {
4560 for (d = s; isALNUM_lazy_if(d,UTF); d++) ;
4562 if (strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE))
4563 Perl_warner(aTHX_ WARN_PRECEDENCE,
4564 "Precedence problem: open %.*s should be open(%.*s)",
4570 yylval.ival = OP_OR;
4580 LOP(OP_OPEN_DIR,XTERM);
4583 checkcomma(s,PL_tokenbuf,"filehandle");
4587 checkcomma(s,PL_tokenbuf,"filehandle");
4606 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4610 LOP(OP_PIPE_OP,XTERM);
4613 s = scan_str(s,FALSE,FALSE);
4615 missingterm((char*)0);
4616 yylval.ival = OP_CONST;
4617 TERM(sublex_start());
4623 s = scan_str(s,FALSE,FALSE);
4625 missingterm((char*)0);
4627 if (SvCUR(PL_lex_stuff)) {
4630 d = SvPV_force(PL_lex_stuff, len);
4633 for (; isSPACE(*d) && len; --len, ++d) ;
4636 if (!warned && ckWARN(WARN_QW)) {
4637 for (; !isSPACE(*d) && len; --len, ++d) {
4639 Perl_warner(aTHX_ WARN_QW,
4640 "Possible attempt to separate words with commas");
4643 else if (*d == '#') {
4644 Perl_warner(aTHX_ WARN_QW,
4645 "Possible attempt to put comments in qw() list");
4651 for (; !isSPACE(*d) && len; --len, ++d) ;
4653 sv = newSVpvn(b, d-b);
4654 if (DO_UTF8(PL_lex_stuff))
4656 words = append_elem(OP_LIST, words,
4657 newSVOP(OP_CONST, 0, tokeq(sv)));
4661 PL_nextval[PL_nexttoke].opval = words;
4666 SvREFCNT_dec(PL_lex_stuff);
4667 PL_lex_stuff = Nullsv;
4673 s = scan_str(s,FALSE,FALSE);
4675 missingterm((char*)0);
4676 yylval.ival = OP_STRINGIFY;
4677 if (SvIVX(PL_lex_stuff) == '\'')
4678 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
4679 TERM(sublex_start());
4682 s = scan_pat(s,OP_QR);
4683 TERM(sublex_start());
4686 s = scan_str(s,FALSE,FALSE);
4688 missingterm((char*)0);
4689 yylval.ival = OP_BACKTICK;
4691 TERM(sublex_start());
4699 s = force_version(s, FALSE);
4701 else if (*s != 'v' || !isDIGIT(s[1])
4702 || (s = force_version(s, TRUE), *s == 'v'))
4704 *PL_tokenbuf = '\0';
4705 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4706 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
4707 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
4709 yyerror("<> should be quotes");
4717 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4721 LOP(OP_RENAME,XTERM);
4730 LOP(OP_RINDEX,XTERM);
4753 LOP(OP_REVERSE,XTERM);
4764 TERM(sublex_start());
4766 TOKEN(1); /* force error */
4775 LOP(OP_SELECT,XTERM);
4781 LOP(OP_SEMCTL,XTERM);
4784 LOP(OP_SEMGET,XTERM);
4787 LOP(OP_SEMOP,XTERM);
4793 LOP(OP_SETPGRP,XTERM);
4795 case KEY_setpriority:
4796 LOP(OP_SETPRIORITY,XTERM);
4798 case KEY_sethostent:
4804 case KEY_setservent:
4807 case KEY_setprotoent:
4817 LOP(OP_SEEKDIR,XTERM);
4819 case KEY_setsockopt:
4820 LOP(OP_SSOCKOPT,XTERM);
4826 LOP(OP_SHMCTL,XTERM);
4829 LOP(OP_SHMGET,XTERM);
4832 LOP(OP_SHMREAD,XTERM);
4835 LOP(OP_SHMWRITE,XTERM);
4838 LOP(OP_SHUTDOWN,XTERM);
4847 LOP(OP_SOCKET,XTERM);
4849 case KEY_socketpair:
4850 LOP(OP_SOCKPAIR,XTERM);
4853 checkcomma(s,PL_tokenbuf,"subroutine name");
4855 if (*s == ';' || *s == ')') /* probably a close */
4856 Perl_croak(aTHX_ "sort is now a reserved word");
4858 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4862 LOP(OP_SPLIT,XTERM);
4865 LOP(OP_SPRINTF,XTERM);
4868 LOP(OP_SPLICE,XTERM);
4883 LOP(OP_SUBSTR,XTERM);
4889 char tmpbuf[sizeof PL_tokenbuf];
4890 SSize_t tboffset = 0;
4891 expectation attrful;
4892 bool have_name, have_proto;
4897 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
4898 (*s == ':' && s[1] == ':'))
4901 attrful = XATTRBLOCK;
4902 /* remember buffer pos'n for later force_word */
4903 tboffset = s - PL_oldbufptr;
4904 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4905 if (strchr(tmpbuf, ':'))
4906 sv_setpv(PL_subname, tmpbuf);
4908 sv_setsv(PL_subname,PL_curstname);
4909 sv_catpvn(PL_subname,"::",2);
4910 sv_catpvn(PL_subname,tmpbuf,len);
4917 Perl_croak(aTHX_ "Missing name in \"my sub\"");
4918 PL_expect = XTERMBLOCK;
4919 attrful = XATTRTERM;
4920 sv_setpv(PL_subname,"?");
4924 if (key == KEY_format) {
4926 PL_lex_formbrack = PL_lex_brackets + 1;
4928 (void) force_word(PL_oldbufptr + tboffset, WORD,
4933 /* Look for a prototype */
4937 s = scan_str(s,FALSE,FALSE);
4939 Perl_croak(aTHX_ "Prototype not terminated");
4941 d = SvPVX(PL_lex_stuff);
4943 for (p = d; *p; ++p) {
4948 SvCUR(PL_lex_stuff) = tmp;
4956 if (*s == ':' && s[1] != ':')
4957 PL_expect = attrful;
4960 PL_nextval[PL_nexttoke].opval =
4961 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4962 PL_lex_stuff = Nullsv;
4966 sv_setpv(PL_subname,"__ANON__");
4969 (void) force_word(PL_oldbufptr + tboffset, WORD,
4978 LOP(OP_SYSTEM,XREF);
4981 LOP(OP_SYMLINK,XTERM);
4984 LOP(OP_SYSCALL,XTERM);
4987 LOP(OP_SYSOPEN,XTERM);
4990 LOP(OP_SYSSEEK,XTERM);
4993 LOP(OP_SYSREAD,XTERM);
4996 LOP(OP_SYSWRITE,XTERM);
5000 TERM(sublex_start());
5021 LOP(OP_TRUNCATE,XTERM);
5033 yylval.ival = CopLINE(PL_curcop);
5037 yylval.ival = CopLINE(PL_curcop);
5041 LOP(OP_UNLINK,XTERM);
5047 LOP(OP_UNPACK,XTERM);
5050 LOP(OP_UTIME,XTERM);
5056 LOP(OP_UNSHIFT,XTERM);
5059 if (PL_expect != XSTATE)
5060 yyerror("\"use\" not allowed in expression");
5062 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
5063 s = force_version(s, TRUE);
5064 if (*s == ';' || (s = skipspace(s), *s == ';')) {
5065 PL_nextval[PL_nexttoke].opval = Nullop;
5068 else if (*s == 'v') {
5069 s = force_word(s,WORD,FALSE,TRUE,FALSE);
5070 s = force_version(s, FALSE);
5074 s = force_word(s,WORD,FALSE,TRUE,FALSE);
5075 s = force_version(s, FALSE);
5087 yylval.ival = CopLINE(PL_curcop);
5091 PL_hints |= HINT_BLOCK_SCOPE;
5098 LOP(OP_WAITPID,XTERM);
5107 ctl_l[0] = toCTRL('L');
5109 gv_fetchpv(ctl_l,TRUE, SVt_PV);
5112 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
5117 if (PL_expect == XOPERATOR)
5123 yylval.ival = OP_XOR;
5128 TERM(sublex_start());
5133 #pragma segment Main
5137 S_pending_ident(pTHX)
5141 /* pit holds the identifier we read and pending_ident is reset */
5142 char pit = PL_pending_ident;
5143 PL_pending_ident = 0;
5145 DEBUG_T({ PerlIO_printf(Perl_debug_log,
5146 "### Tokener saw identifier '%s'\n", PL_tokenbuf); });
5148 /* if we're in a my(), we can't allow dynamics here.
5149 $foo'bar has already been turned into $foo::bar, so
5150 just check for colons.
5152 if it's a legal name, the OP is a PADANY.
5155 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
5156 if (strchr(PL_tokenbuf,':'))
5157 yyerror(Perl_form(aTHX_ "No package name allowed for "
5158 "variable %s in \"our\"",
5160 tmp = pad_allocmy(PL_tokenbuf);
5163 if (strchr(PL_tokenbuf,':'))
5164 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
5166 yylval.opval = newOP(OP_PADANY, 0);
5167 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
5173 build the ops for accesses to a my() variable.
5175 Deny my($a) or my($b) in a sort block, *if* $a or $b is
5176 then used in a comparison. This catches most, but not
5177 all cases. For instance, it catches
5178 sort { my($a); $a <=> $b }
5180 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
5181 (although why you'd do that is anyone's guess).
5184 if (!strchr(PL_tokenbuf,':')) {
5185 #ifdef USE_5005THREADS
5186 /* Check for single character per-thread SVs */
5187 if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
5188 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
5189 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
5191 yylval.opval = newOP(OP_THREADSV, 0);
5192 yylval.opval->op_targ = tmp;
5195 #endif /* USE_5005THREADS */
5196 if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
5197 SV *namesv = AvARRAY(PL_comppad_name)[tmp];
5198 /* might be an "our" variable" */
5199 if (SvFLAGS(namesv) & SVpad_OUR) {
5200 /* build ops for a bareword */
5201 SV *sym = newSVpv(HvNAME(GvSTASH(namesv)),0);
5202 sv_catpvn(sym, "::", 2);
5203 sv_catpv(sym, PL_tokenbuf+1);
5204 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
5205 yylval.opval->op_private = OPpCONST_ENTERED;
5206 gv_fetchpv(SvPVX(sym),
5208 ? (GV_ADDMULTI | GV_ADDINEVAL)
5211 ((PL_tokenbuf[0] == '$') ? SVt_PV
5212 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5217 /* if it's a sort block and they're naming $a or $b */
5218 if (PL_last_lop_op == OP_SORT &&
5219 PL_tokenbuf[0] == '$' &&
5220 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
5223 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
5224 d < PL_bufend && *d != '\n';
5227 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
5228 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
5234 yylval.opval = newOP(OP_PADANY, 0);
5235 yylval.opval->op_targ = tmp;
5241 Whine if they've said @foo in a doublequoted string,
5242 and @foo isn't a variable we can find in the symbol
5245 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
5246 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
5247 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
5248 && ckWARN(WARN_AMBIGUOUS))
5250 /* Downgraded from fatal to warning 20000522 mjd */
5251 Perl_warner(aTHX_ WARN_AMBIGUOUS,
5252 "Possible unintended interpolation of %s in string",
5257 /* build ops for a bareword */
5258 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
5259 yylval.opval->op_private = OPpCONST_ENTERED;
5260 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
5261 ((PL_tokenbuf[0] == '$') ? SVt_PV
5262 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5268 Perl_keyword(pTHX_ register char *d, I32 len)
5273 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
5274 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
5275 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
5276 if (strEQ(d,"__DATA__")) return KEY___DATA__;
5277 if (strEQ(d,"__END__")) return KEY___END__;
5281 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
5286 if (strEQ(d,"and")) return -KEY_and;
5287 if (strEQ(d,"abs")) return -KEY_abs;
5290 if (strEQ(d,"alarm")) return -KEY_alarm;
5291 if (strEQ(d,"atan2")) return -KEY_atan2;
5294 if (strEQ(d,"accept")) return -KEY_accept;
5299 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
5302 if (strEQ(d,"bless")) return -KEY_bless;
5303 if (strEQ(d,"bind")) return -KEY_bind;
5304 if (strEQ(d,"binmode")) return -KEY_binmode;
5307 if (strEQ(d,"CORE")) return -KEY_CORE;
5308 if (strEQ(d,"CHECK")) return KEY_CHECK;
5313 if (strEQ(d,"cmp")) return -KEY_cmp;
5314 if (strEQ(d,"chr")) return -KEY_chr;
5315 if (strEQ(d,"cos")) return -KEY_cos;
5318 if (strEQ(d,"chop")) return -KEY_chop;
5321 if (strEQ(d,"close")) return -KEY_close;
5322 if (strEQ(d,"chdir")) return -KEY_chdir;
5323 if (strEQ(d,"chomp")) return -KEY_chomp;
5324 if (strEQ(d,"chmod")) return -KEY_chmod;
5325 if (strEQ(d,"chown")) return -KEY_chown;
5326 if (strEQ(d,"crypt")) return -KEY_crypt;
5329 if (strEQ(d,"chroot")) return -KEY_chroot;
5330 if (strEQ(d,"caller")) return -KEY_caller;
5333 if (strEQ(d,"connect")) return -KEY_connect;
5336 if (strEQ(d,"closedir")) return -KEY_closedir;
5337 if (strEQ(d,"continue")) return -KEY_continue;
5342 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
5347 if (strEQ(d,"do")) return KEY_do;
5350 if (strEQ(d,"die")) return -KEY_die;
5353 if (strEQ(d,"dump")) return -KEY_dump;
5356 if (strEQ(d,"delete")) return KEY_delete;
5359 if (strEQ(d,"defined")) return KEY_defined;
5360 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
5363 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
5368 if (strEQ(d,"END")) return KEY_END;
5373 if (strEQ(d,"eq")) return -KEY_eq;
5376 if (strEQ(d,"eof")) return -KEY_eof;
5377 if (strEQ(d,"exp")) return -KEY_exp;
5380 if (strEQ(d,"else")) return KEY_else;
5381 if (strEQ(d,"exit")) return -KEY_exit;
5382 if (strEQ(d,"eval")) return KEY_eval;
5383 if (strEQ(d,"exec")) return -KEY_exec;
5384 if (strEQ(d,"each")) return -KEY_each;
5387 if (strEQ(d,"elsif")) return KEY_elsif;
5390 if (strEQ(d,"exists")) return KEY_exists;
5391 if (strEQ(d,"elseif")) Perl_warn(aTHX_ "elseif should be elsif");
5394 if (strEQ(d,"endgrent")) return -KEY_endgrent;
5395 if (strEQ(d,"endpwent")) return -KEY_endpwent;
5398 if (strEQ(d,"endnetent")) return -KEY_endnetent;
5401 if (strEQ(d,"endhostent")) return -KEY_endhostent;
5402 if (strEQ(d,"endservent")) return -KEY_endservent;
5405 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
5412 if (strEQ(d,"for")) return KEY_for;
5415 if (strEQ(d,"fork")) return -KEY_fork;
5418 if (strEQ(d,"fcntl")) return -KEY_fcntl;
5419 if (strEQ(d,"flock")) return -KEY_flock;
5422 if (strEQ(d,"format")) return KEY_format;
5423 if (strEQ(d,"fileno")) return -KEY_fileno;
5426 if (strEQ(d,"foreach")) return KEY_foreach;
5429 if (strEQ(d,"formline")) return -KEY_formline;
5434 if (strnEQ(d,"get",3)) {
5439 if (strEQ(d,"ppid")) return -KEY_getppid;
5440 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
5443 if (strEQ(d,"pwent")) return -KEY_getpwent;
5444 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
5445 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
5448 if (strEQ(d,"peername")) return -KEY_getpeername;
5449 if (strEQ(d,"protoent")) return -KEY_getprotoent;
5450 if (strEQ(d,"priority")) return -KEY_getpriority;
5453 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
5456 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
5460 else if (*d == 'h') {
5461 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
5462 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
5463 if (strEQ(d,"hostent")) return -KEY_gethostent;
5465 else if (*d == 'n') {
5466 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
5467 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
5468 if (strEQ(d,"netent")) return -KEY_getnetent;
5470 else if (*d == 's') {
5471 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
5472 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
5473 if (strEQ(d,"servent")) return -KEY_getservent;
5474 if (strEQ(d,"sockname")) return -KEY_getsockname;
5475 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
5477 else if (*d == 'g') {
5478 if (strEQ(d,"grent")) return -KEY_getgrent;
5479 if (strEQ(d,"grnam")) return -KEY_getgrnam;
5480 if (strEQ(d,"grgid")) return -KEY_getgrgid;
5482 else if (*d == 'l') {
5483 if (strEQ(d,"login")) return -KEY_getlogin;
5485 else if (strEQ(d,"c")) return -KEY_getc;
5490 if (strEQ(d,"gt")) return -KEY_gt;
5491 if (strEQ(d,"ge")) return -KEY_ge;
5494 if (strEQ(d,"grep")) return KEY_grep;
5495 if (strEQ(d,"goto")) return KEY_goto;
5496 if (strEQ(d,"glob")) return KEY_glob;
5499 if (strEQ(d,"gmtime")) return -KEY_gmtime;
5504 if (strEQ(d,"hex")) return -KEY_hex;
5507 if (strEQ(d,"INIT")) return KEY_INIT;
5512 if (strEQ(d,"if")) return KEY_if;
5515 if (strEQ(d,"int")) return -KEY_int;
5518 if (strEQ(d,"index")) return -KEY_index;
5519 if (strEQ(d,"ioctl")) return -KEY_ioctl;
5524 if (strEQ(d,"join")) return -KEY_join;
5528 if (strEQ(d,"keys")) return -KEY_keys;
5529 if (strEQ(d,"kill")) return -KEY_kill;
5535 if (strEQ(d,"lt")) return -KEY_lt;
5536 if (strEQ(d,"le")) return -KEY_le;
5537 if (strEQ(d,"lc")) return -KEY_lc;
5540 if (strEQ(d,"log")) return -KEY_log;
5543 if (strEQ(d,"last")) return KEY_last;
5544 if (strEQ(d,"link")) return -KEY_link;
5545 if (strEQ(d,"lock")) return -KEY_lock;
5548 if (strEQ(d,"local")) return KEY_local;
5549 if (strEQ(d,"lstat")) return -KEY_lstat;
5552 if (strEQ(d,"length")) return -KEY_length;
5553 if (strEQ(d,"listen")) return -KEY_listen;
5556 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
5559 if (strEQ(d,"localtime")) return -KEY_localtime;
5565 case 1: return KEY_m;
5567 if (strEQ(d,"my")) return KEY_my;
5570 if (strEQ(d,"map")) return KEY_map;
5573 if (strEQ(d,"mkdir")) return -KEY_mkdir;
5576 if (strEQ(d,"msgctl")) return -KEY_msgctl;
5577 if (strEQ(d,"msgget")) return -KEY_msgget;
5578 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
5579 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
5584 if (strEQ(d,"next")) return KEY_next;
5585 if (strEQ(d,"ne")) return -KEY_ne;
5586 if (strEQ(d,"not")) return -KEY_not;
5587 if (strEQ(d,"no")) return KEY_no;
5592 if (strEQ(d,"or")) return -KEY_or;
5595 if (strEQ(d,"ord")) return -KEY_ord;
5596 if (strEQ(d,"oct")) return -KEY_oct;
5597 if (strEQ(d,"our")) return KEY_our;
5600 if (strEQ(d,"open")) return -KEY_open;
5603 if (strEQ(d,"opendir")) return -KEY_opendir;
5610 if (strEQ(d,"pop")) return -KEY_pop;
5611 if (strEQ(d,"pos")) return KEY_pos;
5614 if (strEQ(d,"push")) return -KEY_push;
5615 if (strEQ(d,"pack")) return -KEY_pack;
5616 if (strEQ(d,"pipe")) return -KEY_pipe;
5619 if (strEQ(d,"print")) return KEY_print;
5622 if (strEQ(d,"printf")) return KEY_printf;
5625 if (strEQ(d,"package")) return KEY_package;
5628 if (strEQ(d,"prototype")) return KEY_prototype;
5633 if (strEQ(d,"q")) return KEY_q;
5634 if (strEQ(d,"qr")) return KEY_qr;
5635 if (strEQ(d,"qq")) return KEY_qq;
5636 if (strEQ(d,"qw")) return KEY_qw;
5637 if (strEQ(d,"qx")) return KEY_qx;
5639 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
5644 if (strEQ(d,"ref")) return -KEY_ref;
5647 if (strEQ(d,"read")) return -KEY_read;
5648 if (strEQ(d,"rand")) return -KEY_rand;
5649 if (strEQ(d,"recv")) return -KEY_recv;
5650 if (strEQ(d,"redo")) return KEY_redo;
5653 if (strEQ(d,"rmdir")) return -KEY_rmdir;
5654 if (strEQ(d,"reset")) return -KEY_reset;
5657 if (strEQ(d,"return")) return KEY_return;
5658 if (strEQ(d,"rename")) return -KEY_rename;
5659 if (strEQ(d,"rindex")) return -KEY_rindex;
5662 if (strEQ(d,"require")) return KEY_require;
5663 if (strEQ(d,"reverse")) return -KEY_reverse;
5664 if (strEQ(d,"readdir")) return -KEY_readdir;
5667 if (strEQ(d,"readlink")) return -KEY_readlink;
5668 if (strEQ(d,"readline")) return -KEY_readline;
5669 if (strEQ(d,"readpipe")) return -KEY_readpipe;
5672 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
5678 case 0: return KEY_s;
5680 if (strEQ(d,"scalar")) return KEY_scalar;
5685 if (strEQ(d,"seek")) return -KEY_seek;
5686 if (strEQ(d,"send")) return -KEY_send;
5689 if (strEQ(d,"semop")) return -KEY_semop;
5692 if (strEQ(d,"select")) return -KEY_select;
5693 if (strEQ(d,"semctl")) return -KEY_semctl;
5694 if (strEQ(d,"semget")) return -KEY_semget;
5697 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
5698 if (strEQ(d,"seekdir")) return -KEY_seekdir;
5701 if (strEQ(d,"setpwent")) return -KEY_setpwent;
5702 if (strEQ(d,"setgrent")) return -KEY_setgrent;
5705 if (strEQ(d,"setnetent")) return -KEY_setnetent;
5708 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
5709 if (strEQ(d,"sethostent")) return -KEY_sethostent;
5710 if (strEQ(d,"setservent")) return -KEY_setservent;
5713 if (strEQ(d,"setpriority")) return -KEY_setpriority;
5714 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
5721 if (strEQ(d,"shift")) return -KEY_shift;
5724 if (strEQ(d,"shmctl")) return -KEY_shmctl;
5725 if (strEQ(d,"shmget")) return -KEY_shmget;
5728 if (strEQ(d,"shmread")) return -KEY_shmread;
5731 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
5732 if (strEQ(d,"shutdown")) return -KEY_shutdown;
5737 if (strEQ(d,"sin")) return -KEY_sin;
5740 if (strEQ(d,"sleep")) return -KEY_sleep;
5743 if (strEQ(d,"sort")) return KEY_sort;
5744 if (strEQ(d,"socket")) return -KEY_socket;
5745 if (strEQ(d,"socketpair")) return -KEY_socketpair;
5748 if (strEQ(d,"split")) return KEY_split;
5749 if (strEQ(d,"sprintf")) return -KEY_sprintf;
5750 if (strEQ(d,"splice")) return -KEY_splice;
5753 if (strEQ(d,"sqrt")) return -KEY_sqrt;
5756 if (strEQ(d,"srand")) return -KEY_srand;
5759 if (strEQ(d,"stat")) return -KEY_stat;
5760 if (strEQ(d,"study")) return KEY_study;
5763 if (strEQ(d,"substr")) return -KEY_substr;
5764 if (strEQ(d,"sub")) return KEY_sub;
5769 if (strEQ(d,"system")) return -KEY_system;
5772 if (strEQ(d,"symlink")) return -KEY_symlink;
5773 if (strEQ(d,"syscall")) return -KEY_syscall;
5774 if (strEQ(d,"sysopen")) return -KEY_sysopen;
5775 if (strEQ(d,"sysread")) return -KEY_sysread;
5776 if (strEQ(d,"sysseek")) return -KEY_sysseek;
5779 if (strEQ(d,"syswrite")) return -KEY_syswrite;
5788 if (strEQ(d,"tr")) return KEY_tr;
5791 if (strEQ(d,"tie")) return KEY_tie;
5794 if (strEQ(d,"tell")) return -KEY_tell;
5795 if (strEQ(d,"tied")) return KEY_tied;
5796 if (strEQ(d,"time")) return -KEY_time;
5799 if (strEQ(d,"times")) return -KEY_times;
5802 if (strEQ(d,"telldir")) return -KEY_telldir;
5805 if (strEQ(d,"truncate")) return -KEY_truncate;
5812 if (strEQ(d,"uc")) return -KEY_uc;
5815 if (strEQ(d,"use")) return KEY_use;
5818 if (strEQ(d,"undef")) return KEY_undef;
5819 if (strEQ(d,"until")) return KEY_until;
5820 if (strEQ(d,"untie")) return KEY_untie;
5821 if (strEQ(d,"utime")) return -KEY_utime;
5822 if (strEQ(d,"umask")) return -KEY_umask;
5825 if (strEQ(d,"unless")) return KEY_unless;
5826 if (strEQ(d,"unpack")) return -KEY_unpack;
5827 if (strEQ(d,"unlink")) return -KEY_unlink;
5830 if (strEQ(d,"unshift")) return -KEY_unshift;
5831 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
5836 if (strEQ(d,"values")) return -KEY_values;
5837 if (strEQ(d,"vec")) return -KEY_vec;
5842 if (strEQ(d,"warn")) return -KEY_warn;
5843 if (strEQ(d,"wait")) return -KEY_wait;
5846 if (strEQ(d,"while")) return KEY_while;
5847 if (strEQ(d,"write")) return -KEY_write;
5850 if (strEQ(d,"waitpid")) return -KEY_waitpid;
5853 if (strEQ(d,"wantarray")) return -KEY_wantarray;
5858 if (len == 1) return -KEY_x;
5859 if (strEQ(d,"xor")) return -KEY_xor;
5862 if (len == 1) return KEY_y;
5871 S_checkcomma(pTHX_ register char *s, char *name, char *what)
5875 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
5876 if (ckWARN(WARN_SYNTAX)) {
5878 for (w = s+2; *w && level; w++) {
5885 for (; *w && isSPACE(*w); w++) ;
5886 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
5887 Perl_warner(aTHX_ WARN_SYNTAX,
5888 "%s (...) interpreted as function",name);
5891 while (s < PL_bufend && isSPACE(*s))
5895 while (s < PL_bufend && isSPACE(*s))
5897 if (isIDFIRST_lazy_if(s,UTF)) {
5899 while (isALNUM_lazy_if(s,UTF))
5901 while (s < PL_bufend && isSPACE(*s))
5906 kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
5910 Perl_croak(aTHX_ "No comma allowed after %s", what);
5915 /* Either returns sv, or mortalizes sv and returns a new SV*.
5916 Best used as sv=new_constant(..., sv, ...).
5917 If s, pv are NULL, calls subroutine with one argument,
5918 and type is used with error messages only. */
5921 S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv,
5925 HV *table = GvHV(PL_hintgv); /* ^H */
5929 const char *why1, *why2, *why3;
5931 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
5934 why2 = strEQ(key,"charnames")
5935 ? "(possibly a missing \"use charnames ...\")"
5937 msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
5938 (type ? type: "undef"), why2);
5940 /* This is convoluted and evil ("goto considered harmful")
5941 * but I do not understand the intricacies of all the different
5942 * failure modes of %^H in here. The goal here is to make
5943 * the most probable error message user-friendly. --jhi */
5948 msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
5949 (type ? type: "undef"), why1, why2, why3);
5951 yyerror(SvPVX(msg));
5955 cvp = hv_fetch(table, key, strlen(key), FALSE);
5956 if (!cvp || !SvOK(*cvp)) {
5959 why3 = "} is not defined";
5962 sv_2mortal(sv); /* Parent created it permanently */
5965 pv = sv_2mortal(newSVpvn(s, len));
5967 typesv = sv_2mortal(newSVpv(type, 0));
5969 typesv = &PL_sv_undef;
5971 PUSHSTACKi(PERLSI_OVERLOAD);
5983 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
5987 /* Check the eval first */
5988 if (!PL_in_eval && SvTRUE(ERRSV)) {
5990 sv_catpv(ERRSV, "Propagated");
5991 yyerror(SvPV(ERRSV, n_a)); /* Duplicates the message inside eval */
5993 res = SvREFCNT_inc(sv);
5997 (void)SvREFCNT_inc(res);
6006 why1 = "Call to &{$^H{";
6008 why3 = "}} did not return a defined value";
6017 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
6019 register char *d = dest;
6020 register char *e = d + destlen - 3; /* two-character token, ending NUL */
6023 Perl_croak(aTHX_ ident_too_long);
6024 if (isALNUM(*s)) /* UTF handled below */
6026 else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) {
6031 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
6035 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
6036 char *t = s + UTF8SKIP(s);
6037 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
6039 if (d + (t - s) > e)
6040 Perl_croak(aTHX_ ident_too_long);
6041 Copy(s, d, t - s, char);
6054 S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
6064 e = d + destlen - 3; /* two-character token, ending NUL */
6066 while (isDIGIT(*s)) {
6068 Perl_croak(aTHX_ ident_too_long);
6075 Perl_croak(aTHX_ ident_too_long);
6076 if (isALNUM(*s)) /* UTF handled below */
6078 else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
6083 else if (*s == ':' && s[1] == ':') {
6087 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
6088 char *t = s + UTF8SKIP(s);
6089 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
6091 if (d + (t - s) > e)
6092 Perl_croak(aTHX_ ident_too_long);
6093 Copy(s, d, t - s, char);
6104 if (PL_lex_state != LEX_NORMAL)
6105 PL_lex_state = LEX_INTERPENDMAYBE;
6108 if (*s == '$' && s[1] &&
6109 (isALNUM_lazy_if(s+1,UTF) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
6122 if (*d == '^' && *s && isCONTROLVAR(*s)) {
6127 if (isSPACE(s[-1])) {
6130 if (!SPACE_OR_TAB(ch)) {
6136 if (isIDFIRST_lazy_if(d,UTF)) {
6140 while ((e < send && isALNUM_lazy_if(e,UTF)) || *e == ':') {
6142 while (e < send && UTF8_IS_CONTINUED(*e) && is_utf8_mark((U8*)e))
6145 Copy(s, d, e - s, char);
6150 while ((isALNUM(*s) || *s == ':') && d < e)
6153 Perl_croak(aTHX_ ident_too_long);
6156 while (s < send && SPACE_OR_TAB(*s)) s++;
6157 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
6158 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
6159 const char *brack = *s == '[' ? "[...]" : "{...}";
6160 Perl_warner(aTHX_ WARN_AMBIGUOUS,
6161 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
6162 funny, dest, brack, funny, dest, brack);
6165 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
6169 /* Handle extended ${^Foo} variables
6170 * 1999-02-27 mjd-perl-patch@plover.com */
6171 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
6175 while (isALNUM(*s) && d < e) {
6179 Perl_croak(aTHX_ ident_too_long);
6184 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
6185 PL_lex_state = LEX_INTERPEND;
6188 if (PL_lex_state == LEX_NORMAL) {
6189 if (ckWARN(WARN_AMBIGUOUS) &&
6190 (keyword(dest, d - dest) || get_cv(dest, FALSE)))
6192 Perl_warner(aTHX_ WARN_AMBIGUOUS,
6193 "Ambiguous use of %c{%s} resolved to %c%s",
6194 funny, dest, funny, dest);
6199 s = bracket; /* let the parser handle it */
6203 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
6204 PL_lex_state = LEX_INTERPEND;
6209 Perl_pmflag(pTHX_ U16 *pmfl, int ch)
6214 *pmfl |= PMf_GLOBAL;
6216 *pmfl |= PMf_CONTINUE;
6220 *pmfl |= PMf_MULTILINE;
6222 *pmfl |= PMf_SINGLELINE;
6224 *pmfl |= PMf_EXTENDED;
6228 S_scan_pat(pTHX_ char *start, I32 type)
6233 s = scan_str(start,FALSE,FALSE);
6235 Perl_croak(aTHX_ "Search pattern not terminated");
6237 pm = (PMOP*)newPMOP(type, 0);
6238 if (PL_multi_open == '?')
6239 pm->op_pmflags |= PMf_ONCE;
6241 while (*s && strchr("iomsx", *s))
6242 pmflag(&pm->op_pmflags,*s++);
6245 while (*s && strchr("iogcmsx", *s))
6246 pmflag(&pm->op_pmflags,*s++);
6248 pm->op_pmpermflags = pm->op_pmflags;
6250 PL_lex_op = (OP*)pm;
6251 yylval.ival = OP_MATCH;
6256 S_scan_subst(pTHX_ char *start)
6263 yylval.ival = OP_NULL;
6265 s = scan_str(start,FALSE,FALSE);
6268 Perl_croak(aTHX_ "Substitution pattern not terminated");
6270 if (s[-1] == PL_multi_open)
6273 first_start = PL_multi_start;
6274 s = scan_str(s,FALSE,FALSE);
6277 SvREFCNT_dec(PL_lex_stuff);
6278 PL_lex_stuff = Nullsv;
6280 Perl_croak(aTHX_ "Substitution replacement not terminated");
6282 PL_multi_start = first_start; /* so whole substitution is taken together */
6284 pm = (PMOP*)newPMOP(OP_SUBST, 0);
6290 else if (strchr("iogcmsx", *s))
6291 pmflag(&pm->op_pmflags,*s++);
6298 PL_sublex_info.super_bufptr = s;
6299 PL_sublex_info.super_bufend = PL_bufend;
6301 pm->op_pmflags |= PMf_EVAL;
6302 repl = newSVpvn("",0);
6304 sv_catpv(repl, es ? "eval " : "do ");
6305 sv_catpvn(repl, "{ ", 2);
6306 sv_catsv(repl, PL_lex_repl);
6307 sv_catpvn(repl, " };", 2);
6309 SvREFCNT_dec(PL_lex_repl);
6313 pm->op_pmpermflags = pm->op_pmflags;
6314 PL_lex_op = (OP*)pm;
6315 yylval.ival = OP_SUBST;
6320 S_scan_trans(pTHX_ char *start)
6329 yylval.ival = OP_NULL;
6331 s = scan_str(start,FALSE,FALSE);
6333 Perl_croak(aTHX_ "Transliteration pattern not terminated");
6334 if (s[-1] == PL_multi_open)
6337 s = scan_str(s,FALSE,FALSE);
6340 SvREFCNT_dec(PL_lex_stuff);
6341 PL_lex_stuff = Nullsv;
6343 Perl_croak(aTHX_ "Transliteration replacement not terminated");
6346 complement = del = squash = 0;
6347 while (strchr("cds", *s)) {
6349 complement = OPpTRANS_COMPLEMENT;
6351 del = OPpTRANS_DELETE;
6353 squash = OPpTRANS_SQUASH;
6357 New(803, tbl, complement&&!del?258:256, short);
6358 o = newPVOP(OP_TRANS, 0, (char*)tbl);
6359 o->op_private = del|squash|complement|
6360 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
6361 (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0);
6364 yylval.ival = OP_TRANS;
6369 S_scan_heredoc(pTHX_ register char *s)
6372 I32 op_type = OP_SCALAR;
6379 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
6383 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
6386 for (peek = s; SPACE_OR_TAB(*peek); peek++) ;
6387 if (*peek && strchr("`'\"",*peek)) {
6390 s = delimcpy(d, e, s, PL_bufend, term, &len);
6400 if (!isALNUM_lazy_if(s,UTF))
6401 deprecate("bare << to mean <<\"\"");
6402 for (; isALNUM_lazy_if(s,UTF); s++) {
6407 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
6408 Perl_croak(aTHX_ "Delimiter for here document is too long");
6411 len = d - PL_tokenbuf;
6412 #ifndef PERL_STRICT_CR
6413 d = strchr(s, '\r');
6417 while (s < PL_bufend) {
6423 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
6432 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6437 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
6438 herewas = newSVpvn(s,PL_bufend-s);
6440 s--, herewas = newSVpvn(s,d-s);
6441 s += SvCUR(herewas);
6443 tmpstr = NEWSV(87,79);
6444 sv_upgrade(tmpstr, SVt_PVIV);
6449 else if (term == '`') {
6450 op_type = OP_BACKTICK;
6451 SvIVX(tmpstr) = '\\';
6455 PL_multi_start = CopLINE(PL_curcop);
6456 PL_multi_open = PL_multi_close = '<';
6457 term = *PL_tokenbuf;
6458 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
6459 char *bufptr = PL_sublex_info.super_bufptr;
6460 char *bufend = PL_sublex_info.super_bufend;
6461 char *olds = s - SvCUR(herewas);
6462 s = strchr(bufptr, '\n');
6466 while (s < bufend &&
6467 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6469 CopLINE_inc(PL_curcop);
6472 CopLINE_set(PL_curcop, PL_multi_start);
6473 missingterm(PL_tokenbuf);
6475 sv_setpvn(herewas,bufptr,d-bufptr+1);
6476 sv_setpvn(tmpstr,d+1,s-d);
6478 sv_catpvn(herewas,s,bufend-s);
6479 (void)strcpy(bufptr,SvPVX(herewas));
6486 while (s < PL_bufend &&
6487 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6489 CopLINE_inc(PL_curcop);
6491 if (s >= PL_bufend) {
6492 CopLINE_set(PL_curcop, PL_multi_start);
6493 missingterm(PL_tokenbuf);
6495 sv_setpvn(tmpstr,d+1,s-d);
6497 CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
6499 sv_catpvn(herewas,s,PL_bufend-s);
6500 sv_setsv(PL_linestr,herewas);
6501 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
6502 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6503 PL_last_lop = PL_last_uni = Nullch;
6506 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
6507 while (s >= PL_bufend) { /* multiple line string? */
6509 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6510 CopLINE_set(PL_curcop, PL_multi_start);
6511 missingterm(PL_tokenbuf);
6513 CopLINE_inc(PL_curcop);
6514 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6515 PL_last_lop = PL_last_uni = Nullch;
6516 #ifndef PERL_STRICT_CR
6517 if (PL_bufend - PL_linestart >= 2) {
6518 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
6519 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
6521 PL_bufend[-2] = '\n';
6523 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6525 else if (PL_bufend[-1] == '\r')
6526 PL_bufend[-1] = '\n';
6528 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
6529 PL_bufend[-1] = '\n';
6531 if (PERLDB_LINE && PL_curstash != PL_debstash) {
6532 SV *sv = NEWSV(88,0);
6534 sv_upgrade(sv, SVt_PVMG);
6535 sv_setsv(sv,PL_linestr);
6536 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop),sv);
6538 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
6541 sv_catsv(PL_linestr,herewas);
6542 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6546 sv_catsv(tmpstr,PL_linestr);
6551 PL_multi_end = CopLINE(PL_curcop);
6552 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
6553 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
6554 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
6556 SvREFCNT_dec(herewas);
6557 if (UTF && !IN_BYTES && is_utf8_string((U8*)SvPVX(tmpstr), SvCUR(tmpstr)))
6559 PL_lex_stuff = tmpstr;
6560 yylval.ival = op_type;
6565 takes: current position in input buffer
6566 returns: new position in input buffer
6567 side-effects: yylval and lex_op are set.
6572 <FH> read from filehandle
6573 <pkg::FH> read from package qualified filehandle
6574 <pkg'FH> read from package qualified filehandle
6575 <$fh> read from filehandle in $fh
6581 S_scan_inputsymbol(pTHX_ char *start)
6583 register char *s = start; /* current position in buffer */
6589 d = PL_tokenbuf; /* start of temp holding space */
6590 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
6591 end = strchr(s, '\n');
6594 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
6596 /* die if we didn't have space for the contents of the <>,
6597 or if it didn't end, or if we see a newline
6600 if (len >= sizeof PL_tokenbuf)
6601 Perl_croak(aTHX_ "Excessively long <> operator");
6603 Perl_croak(aTHX_ "Unterminated <> operator");
6608 Remember, only scalar variables are interpreted as filehandles by
6609 this code. Anything more complex (e.g., <$fh{$num}>) will be
6610 treated as a glob() call.
6611 This code makes use of the fact that except for the $ at the front,
6612 a scalar variable and a filehandle look the same.
6614 if (*d == '$' && d[1]) d++;
6616 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
6617 while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
6620 /* If we've tried to read what we allow filehandles to look like, and
6621 there's still text left, then it must be a glob() and not a getline.
6622 Use scan_str to pull out the stuff between the <> and treat it
6623 as nothing more than a string.
6626 if (d - PL_tokenbuf != len) {
6627 yylval.ival = OP_GLOB;
6629 s = scan_str(start,FALSE,FALSE);
6631 Perl_croak(aTHX_ "Glob not terminated");
6635 /* we're in a filehandle read situation */
6638 /* turn <> into <ARGV> */
6640 (void)strcpy(d,"ARGV");
6642 /* if <$fh>, create the ops to turn the variable into a
6648 /* try to find it in the pad for this block, otherwise find
6649 add symbol table ops
6651 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
6652 SV *namesv = AvARRAY(PL_comppad_name)[tmp];
6653 if (SvFLAGS(namesv) & SVpad_OUR) {
6654 SV *sym = sv_2mortal(newSVpv(HvNAME(GvSTASH(namesv)),0));
6655 sv_catpvn(sym, "::", 2);
6661 OP *o = newOP(OP_PADSV, 0);
6663 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, o);
6672 ? (GV_ADDMULTI | GV_ADDINEVAL)
6675 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
6676 newUNOP(OP_RV2SV, 0,
6677 newGVOP(OP_GV, 0, gv)));
6679 PL_lex_op->op_flags |= OPf_SPECIAL;
6680 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
6681 yylval.ival = OP_NULL;
6684 /* If it's none of the above, it must be a literal filehandle
6685 (<Foo::BAR> or <FOO>) so build a simple readline OP */
6687 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
6688 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
6689 yylval.ival = OP_NULL;
6698 takes: start position in buffer
6699 keep_quoted preserve \ on the embedded delimiter(s)
6700 keep_delims preserve the delimiters around the string
6701 returns: position to continue reading from buffer
6702 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
6703 updates the read buffer.
6705 This subroutine pulls a string out of the input. It is called for:
6706 q single quotes q(literal text)
6707 ' single quotes 'literal text'
6708 qq double quotes qq(interpolate $here please)
6709 " double quotes "interpolate $here please"
6710 qx backticks qx(/bin/ls -l)
6711 ` backticks `/bin/ls -l`
6712 qw quote words @EXPORT_OK = qw( func() $spam )
6713 m// regexp match m/this/
6714 s/// regexp substitute s/this/that/
6715 tr/// string transliterate tr/this/that/
6716 y/// string transliterate y/this/that/
6717 ($*@) sub prototypes sub foo ($)
6718 (stuff) sub attr parameters sub foo : attr(stuff)
6719 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
6721 In most of these cases (all but <>, patterns and transliterate)
6722 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
6723 calls scan_str(). s/// makes yylex() call scan_subst() which calls
6724 scan_str(). tr/// and y/// make yylex() call scan_trans() which
6727 It skips whitespace before the string starts, and treats the first
6728 character as the delimiter. If the delimiter is one of ([{< then
6729 the corresponding "close" character )]}> is used as the closing
6730 delimiter. It allows quoting of delimiters, and if the string has
6731 balanced delimiters ([{<>}]) it allows nesting.
6733 On success, the SV with the resulting string is put into lex_stuff or,
6734 if that is already non-NULL, into lex_repl. The second case occurs only
6735 when parsing the RHS of the special constructs s/// and tr/// (y///).
6736 For convenience, the terminating delimiter character is stuffed into
6741 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
6743 SV *sv; /* scalar value: string */
6744 char *tmps; /* temp string, used for delimiter matching */
6745 register char *s = start; /* current position in the buffer */
6746 register char term; /* terminating character */
6747 register char *to; /* current position in the sv's data */
6748 I32 brackets = 1; /* bracket nesting level */
6749 bool has_utf8 = FALSE; /* is there any utf8 content? */
6751 /* skip space before the delimiter */
6755 /* mark where we are, in case we need to report errors */
6758 /* after skipping whitespace, the next character is the terminator */
6760 if (!UTF8_IS_INVARIANT((U8)term) && UTF)
6763 /* mark where we are */
6764 PL_multi_start = CopLINE(PL_curcop);
6765 PL_multi_open = term;
6767 /* find corresponding closing delimiter */
6768 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
6770 PL_multi_close = term;
6772 /* create a new SV to hold the contents. 87 is leak category, I'm
6773 assuming. 79 is the SV's initial length. What a random number. */
6775 sv_upgrade(sv, SVt_PVIV);
6777 (void)SvPOK_only(sv); /* validate pointer */
6779 /* move past delimiter and try to read a complete string */
6781 sv_catpvn(sv, s, 1);
6784 /* extend sv if need be */
6785 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
6786 /* set 'to' to the next character in the sv's string */
6787 to = SvPVX(sv)+SvCUR(sv);
6789 /* if open delimiter is the close delimiter read unbridle */
6790 if (PL_multi_open == PL_multi_close) {
6791 for (; s < PL_bufend; s++,to++) {
6792 /* embedded newlines increment the current line number */
6793 if (*s == '\n' && !PL_rsfp)
6794 CopLINE_inc(PL_curcop);
6795 /* handle quoted delimiters */
6796 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
6797 if (!keep_quoted && s[1] == term)
6799 /* any other quotes are simply copied straight through */
6803 /* terminate when run out of buffer (the for() condition), or
6804 have found the terminator */
6805 else if (*s == term)
6807 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
6813 /* if the terminator isn't the same as the start character (e.g.,
6814 matched brackets), we have to allow more in the quoting, and
6815 be prepared for nested brackets.
6818 /* read until we run out of string, or we find the terminator */
6819 for (; s < PL_bufend; s++,to++) {
6820 /* embedded newlines increment the line count */
6821 if (*s == '\n' && !PL_rsfp)
6822 CopLINE_inc(PL_curcop);
6823 /* backslashes can escape the open or closing characters */
6824 if (*s == '\\' && s+1 < PL_bufend) {
6826 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
6831 /* allow nested opens and closes */
6832 else if (*s == PL_multi_close && --brackets <= 0)
6834 else if (*s == PL_multi_open)
6836 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
6841 /* terminate the copied string and update the sv's end-of-string */
6843 SvCUR_set(sv, to - SvPVX(sv));
6846 * this next chunk reads more into the buffer if we're not done yet
6850 break; /* handle case where we are done yet :-) */
6852 #ifndef PERL_STRICT_CR
6853 if (to - SvPVX(sv) >= 2) {
6854 if ((to[-2] == '\r' && to[-1] == '\n') ||
6855 (to[-2] == '\n' && to[-1] == '\r'))
6859 SvCUR_set(sv, to - SvPVX(sv));
6861 else if (to[-1] == '\r')
6864 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
6868 /* if we're out of file, or a read fails, bail and reset the current
6869 line marker so we can report where the unterminated string began
6872 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6874 CopLINE_set(PL_curcop, PL_multi_start);
6877 /* we read a line, so increment our line counter */
6878 CopLINE_inc(PL_curcop);
6880 /* update debugger info */
6881 if (PERLDB_LINE && PL_curstash != PL_debstash) {
6882 SV *sv = NEWSV(88,0);
6884 sv_upgrade(sv, SVt_PVMG);
6885 sv_setsv(sv,PL_linestr);
6886 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop), sv);
6889 /* having changed the buffer, we must update PL_bufend */
6890 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6891 PL_last_lop = PL_last_uni = Nullch;
6894 /* at this point, we have successfully read the delimited string */
6897 sv_catpvn(sv, s, 1);
6900 PL_multi_end = CopLINE(PL_curcop);
6903 /* if we allocated too much space, give some back */
6904 if (SvCUR(sv) + 5 < SvLEN(sv)) {
6905 SvLEN_set(sv, SvCUR(sv) + 1);
6906 Renew(SvPVX(sv), SvLEN(sv), char);
6909 /* decide whether this is the first or second quoted string we've read
6922 takes: pointer to position in buffer
6923 returns: pointer to new position in buffer
6924 side-effects: builds ops for the constant in yylval.op
6926 Read a number in any of the formats that Perl accepts:
6928 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
6929 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
6932 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
6934 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
6937 If it reads a number without a decimal point or an exponent, it will
6938 try converting the number to an integer and see if it can do so
6939 without loss of precision.
6943 Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp)
6945 register char *s = start; /* current position in buffer */
6946 register char *d; /* destination in temp buffer */
6947 register char *e; /* end of temp buffer */
6948 NV nv; /* number read, as a double */
6949 SV *sv = Nullsv; /* place to put the converted number */
6950 bool floatit; /* boolean: int or float? */
6951 char *lastub = 0; /* position of last underbar */
6952 static char number_too_long[] = "Number too long";
6954 /* We use the first character to decide what type of number this is */
6958 Perl_croak(aTHX_ "panic: scan_num");
6960 /* if it starts with a 0, it could be an octal number, a decimal in
6961 0.13 disguise, or a hexadecimal number, or a binary number. */
6965 u holds the "number so far"
6966 shift the power of 2 of the base
6967 (hex == 4, octal == 3, binary == 1)
6968 overflowed was the number more than we can hold?
6970 Shift is used when we add a digit. It also serves as an "are
6971 we in octal/hex/binary?" indicator to disallow hex characters
6977 bool overflowed = FALSE;
6978 static NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
6979 static char* bases[5] = { "", "binary", "", "octal",
6981 static char* Bases[5] = { "", "Binary", "", "Octal",
6983 static char *maxima[5] = { "",
6984 "0b11111111111111111111111111111111",
6988 char *base, *Base, *max;
6994 } else if (s[1] == 'b') {
6998 /* check for a decimal in disguise */
6999 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
7001 /* so it must be octal */
7008 if (ckWARN(WARN_SYNTAX))
7009 Perl_warner(aTHX_ WARN_SYNTAX,
7010 "Misplaced _ in number");
7014 base = bases[shift];
7015 Base = Bases[shift];
7016 max = maxima[shift];
7018 /* read the rest of the number */
7020 /* x is used in the overflow test,
7021 b is the digit we're adding on. */
7026 /* if we don't mention it, we're done */
7030 /* _ are ignored -- but warned about if consecutive */
7032 if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
7033 Perl_warner(aTHX_ WARN_SYNTAX,
7034 "Misplaced _ in number");
7038 /* 8 and 9 are not octal */
7041 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
7045 case '2': case '3': case '4':
7046 case '5': case '6': case '7':
7048 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
7052 b = *s++ & 15; /* ASCII digit -> value of digit */
7056 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
7057 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
7058 /* make sure they said 0x */
7063 /* Prepare to put the digit we have onto the end
7064 of the number so far. We check for overflows.
7069 x = u << shift; /* make room for the digit */
7071 if ((x >> shift) != u
7072 && !(PL_hints & HINT_NEW_BINARY)) {
7075 if (ckWARN_d(WARN_OVERFLOW))
7076 Perl_warner(aTHX_ WARN_OVERFLOW,
7077 "Integer overflow in %s number",
7080 u = x | b; /* add the digit to the end */
7083 n *= nvshift[shift];
7084 /* If an NV has not enough bits in its
7085 * mantissa to represent an UV this summing of
7086 * small low-order numbers is a waste of time
7087 * (because the NV cannot preserve the
7088 * low-order bits anyway): we could just
7089 * remember when did we overflow and in the
7090 * end just multiply n by the right
7098 /* if we get here, we had success: make a scalar value from
7103 /* final misplaced underbar check */
7105 if (ckWARN(WARN_SYNTAX))
7106 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
7111 if (ckWARN(WARN_PORTABLE) && n > 4294967295.0)
7112 Perl_warner(aTHX_ WARN_PORTABLE,
7113 "%s number > %s non-portable",
7119 if (ckWARN(WARN_PORTABLE) && u > 0xffffffff)
7120 Perl_warner(aTHX_ WARN_PORTABLE,
7121 "%s number > %s non-portable",
7126 if (PL_hints & HINT_NEW_BINARY)
7127 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
7132 handle decimal numbers.
7133 we're also sent here when we read a 0 as the first digit
7135 case '1': case '2': case '3': case '4': case '5':
7136 case '6': case '7': case '8': case '9': case '.':
7139 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
7142 /* read next group of digits and _ and copy into d */
7143 while (isDIGIT(*s) || *s == '_') {
7144 /* skip underscores, checking for misplaced ones
7148 if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
7149 Perl_warner(aTHX_ WARN_SYNTAX,
7150 "Misplaced _ in number");
7154 /* check for end of fixed-length buffer */
7156 Perl_croak(aTHX_ number_too_long);
7157 /* if we're ok, copy the character */
7162 /* final misplaced underbar check */
7163 if (lastub && s == lastub + 1) {
7164 if (ckWARN(WARN_SYNTAX))
7165 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
7168 /* read a decimal portion if there is one. avoid
7169 3..5 being interpreted as the number 3. followed
7172 if (*s == '.' && s[1] != '.') {
7177 if (ckWARN(WARN_SYNTAX))
7178 Perl_warner(aTHX_ WARN_SYNTAX,
7179 "Misplaced _ in number");
7183 /* copy, ignoring underbars, until we run out of digits.
7185 for (; isDIGIT(*s) || *s == '_'; s++) {
7186 /* fixed length buffer check */
7188 Perl_croak(aTHX_ number_too_long);
7190 if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
7191 Perl_warner(aTHX_ WARN_SYNTAX,
7192 "Misplaced _ in number");
7198 /* fractional part ending in underbar? */
7200 if (ckWARN(WARN_SYNTAX))
7201 Perl_warner(aTHX_ WARN_SYNTAX,
7202 "Misplaced _ in number");
7204 if (*s == '.' && isDIGIT(s[1])) {
7205 /* oops, it's really a v-string, but without the "v" */
7211 /* read exponent part, if present */
7212 if (*s && strchr("eE",*s) && strchr("+-0123456789_", s[1])) {
7216 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
7217 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
7219 /* stray preinitial _ */
7221 if (ckWARN(WARN_SYNTAX))
7222 Perl_warner(aTHX_ WARN_SYNTAX,
7223 "Misplaced _ in number");
7227 /* allow positive or negative exponent */
7228 if (*s == '+' || *s == '-')
7231 /* stray initial _ */
7233 if (ckWARN(WARN_SYNTAX))
7234 Perl_warner(aTHX_ WARN_SYNTAX,
7235 "Misplaced _ in number");
7239 /* read digits of exponent */
7240 while (isDIGIT(*s) || *s == '_') {
7243 Perl_croak(aTHX_ number_too_long);
7247 if (ckWARN(WARN_SYNTAX) &&
7248 ((lastub && s == lastub + 1) ||
7249 (!isDIGIT(s[1]) && s[1] != '_')))
7250 Perl_warner(aTHX_ WARN_SYNTAX,
7251 "Misplaced _ in number");
7258 /* make an sv from the string */
7262 We try to do an integer conversion first if no characters
7263 indicating "float" have been found.
7268 int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
7270 if (flags == IS_NUMBER_IN_UV) {
7272 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
7275 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
7276 if (uv <= (UV) IV_MIN)
7277 sv_setiv(sv, -(IV)uv);
7284 /* terminate the string */
7286 nv = Atof(PL_tokenbuf);
7290 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
7291 (PL_hints & HINT_NEW_INTEGER) )
7292 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
7293 (floatit ? "float" : "integer"),
7297 /* if it starts with a v, it could be a v-string */
7303 while (isDIGIT(*pos) || *pos == '_')
7305 if (!isALPHA(*pos)) {
7307 U8 tmpbuf[UTF8_MAXLEN+1];
7309 s++; /* get past 'v' */
7312 sv_setpvn(sv, "", 0);
7315 if (*s == '0' && isDIGIT(s[1]))
7316 yyerror("Octal number in vector unsupported");
7319 /* this is atoi() that tolerates underscores */
7322 while (--end >= s) {
7327 rev += (*end - '0') * mult;
7329 if (orev > rev && ckWARN_d(WARN_OVERFLOW))
7330 Perl_warner(aTHX_ WARN_OVERFLOW,
7331 "Integer overflow in decimal number");
7334 /* Append native character for the rev point */
7335 tmpend = uvchr_to_utf8(tmpbuf, rev);
7336 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
7337 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
7339 if (*pos == '.' && isDIGIT(pos[1]))
7345 while (isDIGIT(*pos) || *pos == '_')
7355 /* make the op for the constant and return */
7358 lvalp->opval = newSVOP(OP_CONST, 0, sv);
7360 lvalp->opval = Nullop;
7366 S_scan_formline(pTHX_ register char *s)
7370 SV *stuff = newSVpvn("",0);
7371 bool needargs = FALSE;
7374 if (*s == '.' || *s == /*{*/'}') {
7376 #ifdef PERL_STRICT_CR
7377 for (t = s+1;SPACE_OR_TAB(*t); t++) ;
7379 for (t = s+1;SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
7381 if (*t == '\n' || t == PL_bufend)
7384 if (PL_in_eval && !PL_rsfp) {
7385 eol = strchr(s,'\n');
7390 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7392 for (t = s; t < eol; t++) {
7393 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
7395 goto enough; /* ~~ must be first line in formline */
7397 if (*t == '@' || *t == '^')
7401 sv_catpvn(stuff, s, eol-s);
7402 #ifndef PERL_STRICT_CR
7403 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
7404 char *end = SvPVX(stuff) + SvCUR(stuff);
7416 s = filter_gets(PL_linestr, PL_rsfp, 0);
7417 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
7418 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
7419 PL_last_lop = PL_last_uni = Nullch;
7422 yyerror("Format not terminated");
7432 PL_lex_state = LEX_NORMAL;
7433 PL_nextval[PL_nexttoke].ival = 0;
7437 PL_lex_state = LEX_FORMLINE;
7438 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
7440 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
7444 SvREFCNT_dec(stuff);
7445 PL_lex_formbrack = 0;
7456 PL_cshlen = strlen(PL_cshname);
7461 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
7463 I32 oldsavestack_ix = PL_savestack_ix;
7464 CV* outsidecv = PL_compcv;
7468 assert(SvTYPE(PL_compcv) == SVt_PVCV);
7470 SAVEI32(PL_subline);
7471 save_item(PL_subname);
7474 SAVESPTR(PL_comppad_name);
7475 SAVESPTR(PL_compcv);
7476 SAVEI32(PL_comppad_name_fill);
7477 SAVEI32(PL_min_intro_pending);
7478 SAVEI32(PL_max_intro_pending);
7479 SAVEI32(PL_pad_reset_pending);
7481 PL_compcv = (CV*)NEWSV(1104,0);
7482 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
7483 CvFLAGS(PL_compcv) |= flags;
7485 PL_comppad = newAV();
7486 av_push(PL_comppad, Nullsv);
7487 PL_curpad = AvARRAY(PL_comppad);
7488 PL_comppad_name = newAV();
7489 PL_comppad_name_fill = 0;
7490 PL_min_intro_pending = 0;
7492 PL_subline = CopLINE(PL_curcop);
7493 #ifdef USE_5005THREADS
7494 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
7495 PL_curpad[0] = (SV*)newAV();
7496 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
7497 #endif /* USE_5005THREADS */
7499 comppadlist = newAV();
7500 AvREAL_off(comppadlist);
7501 av_store(comppadlist, 0, (SV*)PL_comppad_name);
7502 av_store(comppadlist, 1, (SV*)PL_comppad);
7504 CvPADLIST(PL_compcv) = comppadlist;
7505 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
7506 #ifdef USE_5005THREADS
7507 CvOWNER(PL_compcv) = 0;
7508 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
7509 MUTEX_INIT(CvMUTEXP(PL_compcv));
7510 #endif /* USE_5005THREADS */
7512 return oldsavestack_ix;
7516 #pragma segment Perl_yylex
7519 Perl_yywarn(pTHX_ char *s)
7521 PL_in_eval |= EVAL_WARNONLY;
7523 PL_in_eval &= ~EVAL_WARNONLY;
7528 Perl_yyerror(pTHX_ char *s)
7531 char *context = NULL;
7535 if (!yychar || (yychar == ';' && !PL_rsfp))
7537 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
7538 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
7539 while (isSPACE(*PL_oldoldbufptr))
7541 context = PL_oldoldbufptr;
7542 contlen = PL_bufptr - PL_oldoldbufptr;
7544 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
7545 PL_oldbufptr != PL_bufptr) {
7546 while (isSPACE(*PL_oldbufptr))
7548 context = PL_oldbufptr;
7549 contlen = PL_bufptr - PL_oldbufptr;
7551 else if (yychar > 255)
7552 where = "next token ???";
7553 #ifdef USE_PURE_BISON
7554 /* GNU Bison sets the value -2 */
7555 else if (yychar == -2) {
7557 else if ((yychar & 127) == 127) {
7559 if (PL_lex_state == LEX_NORMAL ||
7560 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
7561 where = "at end of line";
7562 else if (PL_lex_inpat)
7563 where = "within pattern";
7565 where = "within string";
7568 SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
7570 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
7571 else if (isPRINT_LC(yychar))
7572 Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
7574 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
7575 where = SvPVX(where_sv);
7577 msg = sv_2mortal(newSVpv(s, 0));
7578 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
7579 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
7581 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
7583 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
7584 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
7585 Perl_sv_catpvf(aTHX_ msg,
7586 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
7587 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
7590 if (PL_in_eval & EVAL_WARNONLY)
7591 Perl_warn(aTHX_ "%"SVf, msg);
7594 if (PL_error_count >= 10) {
7595 if (PL_in_eval && SvCUR(ERRSV))
7596 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
7597 ERRSV, CopFILE(PL_curcop));
7599 Perl_croak(aTHX_ "%s has too many errors.\n",
7600 CopFILE(PL_curcop));
7603 PL_in_my_stash = Nullhv;
7607 #pragma segment Main
7611 S_swallow_bom(pTHX_ U8 *s)
7614 slen = SvCUR(PL_linestr);
7618 /* UTF-16 little-endian */
7619 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
7620 Perl_croak(aTHX_ "Unsupported script encoding");
7621 #ifndef PERL_NO_UTF16_FILTER
7622 DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-LE script encoding\n"));
7624 if (PL_bufend > (char*)s) {
7628 filter_add(utf16rev_textfilter, NULL);
7629 New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
7630 PL_bufend = (char*)utf16_to_utf8_reversed(s, news,
7631 PL_bufend - (char*)s - 1,
7633 Copy(news, s, newlen, U8);
7634 SvCUR_set(PL_linestr, newlen);
7635 PL_bufend = SvPVX(PL_linestr) + newlen;
7636 news[newlen++] = '\0';
7640 Perl_croak(aTHX_ "Unsupported script encoding");
7645 if (s[1] == 0xFF) { /* UTF-16 big-endian */
7646 #ifndef PERL_NO_UTF16_FILTER
7647 DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding\n"));
7649 if (PL_bufend > (char *)s) {
7653 filter_add(utf16_textfilter, NULL);
7654 New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
7655 PL_bufend = (char*)utf16_to_utf8(s, news,
7656 PL_bufend - (char*)s,
7658 Copy(news, s, newlen, U8);
7659 SvCUR_set(PL_linestr, newlen);
7660 PL_bufend = SvPVX(PL_linestr) + newlen;
7661 news[newlen++] = '\0';
7665 Perl_croak(aTHX_ "Unsupported script encoding");
7670 if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
7671 DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-8 script encoding\n"));
7676 if (slen > 3 && s[1] == 0 && /* UTF-32 big-endian */
7677 s[2] == 0xFE && s[3] == 0xFF)
7679 Perl_croak(aTHX_ "Unsupported script encoding");
7687 * Restore a source filter.
7691 restore_rsfp(pTHX_ void *f)
7693 PerlIO *fp = (PerlIO*)f;
7695 if (PL_rsfp == PerlIO_stdin())
7696 PerlIO_clearerr(PL_rsfp);
7697 else if (PL_rsfp && (PL_rsfp != fp))
7698 PerlIO_close(PL_rsfp);
7702 #ifndef PERL_NO_UTF16_FILTER
7704 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
7706 I32 count = FILTER_READ(idx+1, sv, maxlen);
7711 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
7712 if (!*SvPV_nolen(sv))
7713 /* Game over, but don't feed an odd-length string to utf16_to_utf8 */
7716 tend = utf16_to_utf8((U8*)SvPVX(sv), tmps, SvCUR(sv), &newlen);
7717 sv_usepvn(sv, (char*)tmps, tend - tmps);
7723 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
7725 I32 count = FILTER_READ(idx+1, sv, maxlen);
7730 if (!*SvPV_nolen(sv))
7731 /* Game over, but don't feed an odd-length string to utf16_to_utf8 */
7734 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
7735 tend = utf16_to_utf8_reversed((U8*)SvPVX(sv), tmps, SvCUR(sv), &newlen);
7736 sv_usepvn(sv, (char*)tmps, tend - tmps);