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) {
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");
1658 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1659 PL_sublex_info.sub_op->op_private |=
1660 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1664 /* shrink the sv if we allocated more than we used */
1665 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1666 SvLEN_set(sv, SvCUR(sv) + 1);
1667 Renew(SvPVX(sv), SvLEN(sv), char);
1670 /* return the substring (via yylval) only if we parsed anything */
1671 if (s > PL_bufptr) {
1672 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1673 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1675 ( PL_lex_inwhat == OP_TRANS
1677 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1680 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1687 * Returns TRUE if there's more to the expression (e.g., a subscript),
1690 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
1692 * ->[ and ->{ return TRUE
1693 * { and [ outside a pattern are always subscripts, so return TRUE
1694 * if we're outside a pattern and it's not { or [, then return FALSE
1695 * if we're in a pattern and the first char is a {
1696 * {4,5} (any digits around the comma) returns FALSE
1697 * if we're in a pattern and the first char is a [
1699 * [SOMETHING] has a funky algorithm to decide whether it's a
1700 * character class or not. It has to deal with things like
1701 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
1702 * anything else returns TRUE
1705 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1708 S_intuit_more(pTHX_ register char *s)
1710 if (PL_lex_brackets)
1712 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1714 if (*s != '{' && *s != '[')
1719 /* In a pattern, so maybe we have {n,m}. */
1736 /* On the other hand, maybe we have a character class */
1739 if (*s == ']' || *s == '^')
1742 /* this is terrifying, and it works */
1743 int weight = 2; /* let's weigh the evidence */
1745 unsigned char un_char = 255, last_un_char;
1746 char *send = strchr(s,']');
1747 char tmpbuf[sizeof PL_tokenbuf * 4];
1749 if (!send) /* has to be an expression */
1752 Zero(seen,256,char);
1755 else if (isDIGIT(*s)) {
1757 if (isDIGIT(s[1]) && s[2] == ']')
1763 for (; s < send; s++) {
1764 last_un_char = un_char;
1765 un_char = (unsigned char)*s;
1770 weight -= seen[un_char] * 10;
1771 if (isALNUM_lazy_if(s+1,UTF)) {
1772 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1773 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1778 else if (*s == '$' && s[1] &&
1779 strchr("[#!%*<>()-=",s[1])) {
1780 if (/*{*/ strchr("])} =",s[2]))
1789 if (strchr("wds]",s[1]))
1791 else if (seen['\''] || seen['"'])
1793 else if (strchr("rnftbxcav",s[1]))
1795 else if (isDIGIT(s[1])) {
1797 while (s[1] && isDIGIT(s[1]))
1807 if (strchr("aA01! ",last_un_char))
1809 if (strchr("zZ79~",s[1]))
1811 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1812 weight -= 5; /* cope with negative subscript */
1815 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1816 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1821 if (keyword(tmpbuf, d - tmpbuf))
1824 if (un_char == last_un_char + 1)
1826 weight -= seen[un_char];
1831 if (weight >= 0) /* probably a character class */
1841 * Does all the checking to disambiguate
1843 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
1844 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
1846 * First argument is the stuff after the first token, e.g. "bar".
1848 * Not a method if bar is a filehandle.
1849 * Not a method if foo is a subroutine prototyped to take a filehandle.
1850 * Not a method if it's really "Foo $bar"
1851 * Method if it's "foo $bar"
1852 * Not a method if it's really "print foo $bar"
1853 * Method if it's really "foo package::" (interpreted as package->foo)
1854 * Not a method if bar is known to be a subroutne ("sub bar; foo bar")
1855 * Not a method if bar is a filehandle or package, but is quoted with
1860 S_intuit_method(pTHX_ char *start, GV *gv)
1862 char *s = start + (*start == '$');
1863 char tmpbuf[sizeof PL_tokenbuf];
1871 if ((cv = GvCVu(gv))) {
1872 char *proto = SvPVX(cv);
1882 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1883 /* start is the beginning of the possible filehandle/object,
1884 * and s is the end of it
1885 * tmpbuf is a copy of it
1888 if (*start == '$') {
1889 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1894 return *s == '(' ? FUNCMETH : METHOD;
1896 if (!keyword(tmpbuf, len)) {
1897 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1902 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1903 if (indirgv && GvCVu(indirgv))
1905 /* filehandle or package name makes it a method */
1906 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1908 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1909 return 0; /* no assumptions -- "=>" quotes bearword */
1911 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1912 newSVpvn(tmpbuf,len));
1913 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1917 return *s == '(' ? FUNCMETH : METHOD;
1925 * Return a string of Perl code to load the debugger. If PERL5DB
1926 * is set, it will return the contents of that, otherwise a
1927 * compile-time require of perl5db.pl.
1934 char *pdb = PerlEnv_getenv("PERL5DB");
1938 SETERRNO(0,SS$_NORMAL);
1939 return "BEGIN { require 'perl5db.pl' }";
1945 /* Encoded script support. filter_add() effectively inserts a
1946 * 'pre-processing' function into the current source input stream.
1947 * Note that the filter function only applies to the current source file
1948 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1950 * The datasv parameter (which may be NULL) can be used to pass
1951 * private data to this instance of the filter. The filter function
1952 * can recover the SV using the FILTER_DATA macro and use it to
1953 * store private buffers and state information.
1955 * The supplied datasv parameter is upgraded to a PVIO type
1956 * and the IoDIRP/IoANY field is used to store the function pointer,
1957 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
1958 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1959 * private use must be set using malloc'd pointers.
1963 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
1968 if (!PL_rsfp_filters)
1969 PL_rsfp_filters = newAV();
1971 datasv = NEWSV(255,0);
1972 if (!SvUPGRADE(datasv, SVt_PVIO))
1973 Perl_die(aTHX_ "Can't upgrade filter_add data to SVt_PVIO");
1974 IoANY(datasv) = (void *)funcp; /* stash funcp into spare field */
1975 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
1976 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
1977 funcp, SvPV_nolen(datasv)));
1978 av_unshift(PL_rsfp_filters, 1);
1979 av_store(PL_rsfp_filters, 0, datasv) ;
1984 /* Delete most recently added instance of this filter function. */
1986 Perl_filter_del(pTHX_ filter_t funcp)
1989 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", funcp));
1990 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
1992 /* if filter is on top of stack (usual case) just pop it off */
1993 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
1994 if (IoANY(datasv) == (void *)funcp) {
1995 IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
1996 IoANY(datasv) = (void *)NULL;
1997 sv_free(av_pop(PL_rsfp_filters));
2001 /* we need to search for the correct entry and clear it */
2002 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
2006 /* Invoke the n'th filter function for the current rsfp. */
2008 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
2011 /* 0 = read one text line */
2016 if (!PL_rsfp_filters)
2018 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
2019 /* Provide a default input filter to make life easy. */
2020 /* Note that we append to the line. This is handy. */
2021 DEBUG_P(PerlIO_printf(Perl_debug_log,
2022 "filter_read %d: from rsfp\n", idx));
2026 int old_len = SvCUR(buf_sv) ;
2028 /* ensure buf_sv is large enough */
2029 SvGROW(buf_sv, old_len + maxlen) ;
2030 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
2031 if (PerlIO_error(PL_rsfp))
2032 return -1; /* error */
2034 return 0 ; /* end of file */
2036 SvCUR_set(buf_sv, old_len + len) ;
2039 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
2040 if (PerlIO_error(PL_rsfp))
2041 return -1; /* error */
2043 return 0 ; /* end of file */
2046 return SvCUR(buf_sv);
2048 /* Skip this filter slot if filter has been deleted */
2049 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
2050 DEBUG_P(PerlIO_printf(Perl_debug_log,
2051 "filter_read %d: skipped (filter deleted)\n",
2053 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
2055 /* Get function pointer hidden within datasv */
2056 funcp = (filter_t)IoANY(datasv);
2057 DEBUG_P(PerlIO_printf(Perl_debug_log,
2058 "filter_read %d: via function %p (%s)\n",
2059 idx, funcp, SvPV_nolen(datasv)));
2060 /* Call function. The function is expected to */
2061 /* call "FILTER_READ(idx+1, buf_sv)" first. */
2062 /* Return: <0:error, =0:eof, >0:not eof */
2063 return (*funcp)(aTHX_ idx, buf_sv, maxlen);
2067 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
2069 #ifdef PERL_CR_FILTER
2070 if (!PL_rsfp_filters) {
2071 filter_add(S_cr_textfilter,NULL);
2074 if (PL_rsfp_filters) {
2077 SvCUR_set(sv, 0); /* start with empty line */
2078 if (FILTER_READ(0, sv, 0) > 0)
2079 return ( SvPVX(sv) ) ;
2084 return (sv_gets(sv, fp, append));
2088 S_find_in_my_stash(pTHX_ char *pkgname, I32 len)
2092 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
2096 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
2097 (gv = gv_fetchpv(pkgname, FALSE, SVt_PVHV)))
2099 return GvHV(gv); /* Foo:: */
2102 /* use constant CLASS => 'MyClass' */
2103 if ((gv = gv_fetchpv(pkgname, FALSE, SVt_PVCV))) {
2105 if (GvCV(gv) && (sv = cv_const_sv(GvCV(gv)))) {
2106 pkgname = SvPV_nolen(sv);
2110 return gv_stashpv(pkgname, FALSE);
2114 static char* exp_name[] =
2115 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
2116 "ATTRTERM", "TERMBLOCK"
2123 Works out what to call the token just pulled out of the input
2124 stream. The yacc parser takes care of taking the ops we return and
2125 stitching them into a tree.
2131 if read an identifier
2132 if we're in a my declaration
2133 croak if they tried to say my($foo::bar)
2134 build the ops for a my() declaration
2135 if it's an access to a my() variable
2136 are we in a sort block?
2137 croak if my($a); $a <=> $b
2138 build ops for access to a my() variable
2139 if in a dq string, and they've said @foo and we can't find @foo
2141 build ops for a bareword
2142 if we already built the token before, use it.
2145 #ifdef USE_PURE_BISON
2147 Perl_yylex_r(pTHX_ YYSTYPE *lvalp, int *lcharp)
2152 yylval_pointer[yyactlevel] = lvalp;
2153 yychar_pointer[yyactlevel] = lcharp;
2154 if (yyactlevel >= YYMAXLEVEL)
2155 Perl_croak(aTHX_ "panic: YYMAXLEVEL");
2157 r = Perl_yylex(aTHX);
2167 #pragma segment Perl_yylex
2180 /* check if there's an identifier for us to look at */
2181 if (PL_pending_ident)
2182 return S_pending_ident(aTHX);
2184 /* no identifier pending identification */
2186 switch (PL_lex_state) {
2188 case LEX_NORMAL: /* Some compilers will produce faster */
2189 case LEX_INTERPNORMAL: /* code if we comment these out. */
2193 /* when we've already built the next token, just pull it out of the queue */
2196 yylval = PL_nextval[PL_nexttoke];
2198 PL_lex_state = PL_lex_defer;
2199 PL_expect = PL_lex_expect;
2200 PL_lex_defer = LEX_NORMAL;
2202 DEBUG_T({ PerlIO_printf(Perl_debug_log,
2203 "### Next token after '%s' was known, type %"IVdf"\n", PL_bufptr,
2204 (IV)PL_nexttype[PL_nexttoke]); });
2206 return(PL_nexttype[PL_nexttoke]);
2208 /* interpolated case modifiers like \L \U, including \Q and \E.
2209 when we get here, PL_bufptr is at the \
2211 case LEX_INTERPCASEMOD:
2213 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
2214 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
2216 /* handle \E or end of string */
2217 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
2221 if (PL_lex_casemods) {
2222 oldmod = PL_lex_casestack[--PL_lex_casemods];
2223 PL_lex_casestack[PL_lex_casemods] = '\0';
2225 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
2227 PL_lex_state = LEX_INTERPCONCAT;
2231 if (PL_bufptr != PL_bufend)
2233 PL_lex_state = LEX_INTERPCONCAT;
2237 DEBUG_T({ PerlIO_printf(Perl_debug_log,
2238 "### Saw case modifier at '%s'\n", PL_bufptr); });
2240 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
2241 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
2242 if (strchr("LU", *s) &&
2243 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
2245 PL_lex_casestack[--PL_lex_casemods] = '\0';
2248 if (PL_lex_casemods > 10) {
2249 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
2250 if (newlb != PL_lex_casestack) {
2252 PL_lex_casestack = newlb;
2255 PL_lex_casestack[PL_lex_casemods++] = *s;
2256 PL_lex_casestack[PL_lex_casemods] = '\0';
2257 PL_lex_state = LEX_INTERPCONCAT;
2258 PL_nextval[PL_nexttoke].ival = 0;
2261 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
2263 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
2265 PL_nextval[PL_nexttoke].ival = OP_LC;
2267 PL_nextval[PL_nexttoke].ival = OP_UC;
2269 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
2271 Perl_croak(aTHX_ "panic: yylex");
2274 if (PL_lex_starts) {
2283 case LEX_INTERPPUSH:
2284 return sublex_push();
2286 case LEX_INTERPSTART:
2287 if (PL_bufptr == PL_bufend)
2288 return sublex_done();
2289 DEBUG_T({ PerlIO_printf(Perl_debug_log,
2290 "### Interpolated variable at '%s'\n", PL_bufptr); });
2292 PL_lex_dojoin = (*PL_bufptr == '@');
2293 PL_lex_state = LEX_INTERPNORMAL;
2294 if (PL_lex_dojoin) {
2295 PL_nextval[PL_nexttoke].ival = 0;
2297 #ifdef USE_5005THREADS
2298 PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
2299 PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
2300 force_next(PRIVATEREF);
2302 force_ident("\"", '$');
2303 #endif /* USE_5005THREADS */
2304 PL_nextval[PL_nexttoke].ival = 0;
2306 PL_nextval[PL_nexttoke].ival = 0;
2308 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
2311 if (PL_lex_starts++) {
2317 case LEX_INTERPENDMAYBE:
2318 if (intuit_more(PL_bufptr)) {
2319 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
2325 if (PL_lex_dojoin) {
2326 PL_lex_dojoin = FALSE;
2327 PL_lex_state = LEX_INTERPCONCAT;
2330 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
2331 && SvEVALED(PL_lex_repl))
2333 if (PL_bufptr != PL_bufend)
2334 Perl_croak(aTHX_ "Bad evalled substitution pattern");
2335 PL_lex_repl = Nullsv;
2338 case LEX_INTERPCONCAT:
2340 if (PL_lex_brackets)
2341 Perl_croak(aTHX_ "panic: INTERPCONCAT");
2343 if (PL_bufptr == PL_bufend)
2344 return sublex_done();
2346 if (SvIVX(PL_linestr) == '\'') {
2347 SV *sv = newSVsv(PL_linestr);
2350 else if ( PL_hints & HINT_NEW_RE )
2351 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
2352 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2356 s = scan_const(PL_bufptr);
2358 PL_lex_state = LEX_INTERPCASEMOD;
2360 PL_lex_state = LEX_INTERPSTART;
2363 if (s != PL_bufptr) {
2364 PL_nextval[PL_nexttoke] = yylval;
2367 if (PL_lex_starts++)
2377 PL_lex_state = LEX_NORMAL;
2378 s = scan_formline(PL_bufptr);
2379 if (!PL_lex_formbrack)
2385 PL_oldoldbufptr = PL_oldbufptr;
2388 PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at %s\n",
2389 exp_name[PL_expect], s);
2395 if (isIDFIRST_lazy_if(s,UTF))
2397 Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
2400 goto fake_eof; /* emulate EOF on ^D or ^Z */
2405 if (PL_lex_brackets)
2406 yyerror("Missing right curly or square bracket");
2407 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2408 "### Tokener got EOF\n");
2412 if (s++ < PL_bufend)
2413 goto retry; /* ignore stray nulls */
2416 if (!PL_in_eval && !PL_preambled) {
2417 PL_preambled = TRUE;
2418 sv_setpv(PL_linestr,incl_perldb());
2419 if (SvCUR(PL_linestr))
2420 sv_catpv(PL_linestr,";");
2422 while(AvFILLp(PL_preambleav) >= 0) {
2423 SV *tmpsv = av_shift(PL_preambleav);
2424 sv_catsv(PL_linestr, tmpsv);
2425 sv_catpv(PL_linestr, ";");
2428 sv_free((SV*)PL_preambleav);
2429 PL_preambleav = NULL;
2431 if (PL_minus_n || PL_minus_p) {
2432 sv_catpv(PL_linestr, "LINE: while (<>) {");
2434 sv_catpv(PL_linestr,"chomp;");
2437 if (strchr("/'\"", *PL_splitstr)
2438 && strchr(PL_splitstr + 1, *PL_splitstr))
2439 Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s);", PL_splitstr);
2442 s = "'~#\200\1'"; /* surely one char is unused...*/
2443 while (s[1] && strchr(PL_splitstr, *s)) s++;
2445 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s%c",
2446 "q" + (delim == '\''), delim);
2447 for (s = PL_splitstr; *s; s++) {
2449 sv_catpvn(PL_linestr, "\\", 1);
2450 sv_catpvn(PL_linestr, s, 1);
2452 Perl_sv_catpvf(aTHX_ PL_linestr, "%c);", delim);
2456 sv_catpv(PL_linestr,"our @F=split(' ');");
2459 sv_catpv(PL_linestr, "\n");
2460 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2461 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2462 PL_last_lop = PL_last_uni = Nullch;
2463 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2464 SV *sv = NEWSV(85,0);
2466 sv_upgrade(sv, SVt_PVMG);
2467 sv_setsv(sv,PL_linestr);
2468 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2473 bof = PL_rsfp ? TRUE : FALSE;
2474 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
2477 if (PL_preprocess && !PL_in_eval)
2478 (void)PerlProc_pclose(PL_rsfp);
2479 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2480 PerlIO_clearerr(PL_rsfp);
2482 (void)PerlIO_close(PL_rsfp);
2484 PL_doextract = FALSE;
2486 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2487 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
2488 sv_catpv(PL_linestr,";}");
2489 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2490 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2491 PL_last_lop = PL_last_uni = Nullch;
2492 PL_minus_n = PL_minus_p = 0;
2495 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2496 PL_last_lop = PL_last_uni = Nullch;
2497 sv_setpv(PL_linestr,"");
2498 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
2500 /* if it looks like the start of a BOM, check if it in fact is */
2501 else if (bof && (!*s || *(U8*)s == 0xEF || *(U8*)s >= 0xFE)) {
2502 #ifdef PERLIO_IS_STDIO
2503 # ifdef __GNU_LIBRARY__
2504 # if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
2505 # define FTELL_FOR_PIPE_IS_BROKEN
2509 # if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
2510 # define FTELL_FOR_PIPE_IS_BROKEN
2515 #ifdef FTELL_FOR_PIPE_IS_BROKEN
2516 /* This loses the possibility to detect the bof
2517 * situation on perl -P when the libc5 is being used.
2518 * Workaround? Maybe attach some extra state to PL_rsfp?
2521 bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
2523 bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
2526 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2527 s = swallow_bom((U8*)s);
2531 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
2532 PL_doextract = FALSE;
2534 /* Incest with pod. */
2535 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2536 sv_setpv(PL_linestr, "");
2537 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2538 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2539 PL_last_lop = PL_last_uni = Nullch;
2540 PL_doextract = FALSE;
2544 } while (PL_doextract);
2545 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2546 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2547 SV *sv = NEWSV(85,0);
2549 sv_upgrade(sv, SVt_PVMG);
2550 sv_setsv(sv,PL_linestr);
2551 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2553 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2554 PL_last_lop = PL_last_uni = Nullch;
2555 if (CopLINE(PL_curcop) == 1) {
2556 while (s < PL_bufend && isSPACE(*s))
2558 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2562 if (*s == '#' && *(s+1) == '!')
2564 #ifdef ALTERNATE_SHEBANG
2566 static char as[] = ALTERNATE_SHEBANG;
2567 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2568 d = s + (sizeof(as) - 1);
2570 #endif /* ALTERNATE_SHEBANG */
2579 while (*d && !isSPACE(*d))
2583 #ifdef ARG_ZERO_IS_SCRIPT
2584 if (ipathend > ipath) {
2586 * HP-UX (at least) sets argv[0] to the script name,
2587 * which makes $^X incorrect. And Digital UNIX and Linux,
2588 * at least, set argv[0] to the basename of the Perl
2589 * interpreter. So, having found "#!", we'll set it right.
2591 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
2592 assert(SvPOK(x) || SvGMAGICAL(x));
2593 if (sv_eq(x, CopFILESV(PL_curcop))) {
2594 sv_setpvn(x, ipath, ipathend - ipath);
2597 TAINT_NOT; /* $^X is always tainted, but that's OK */
2599 #endif /* ARG_ZERO_IS_SCRIPT */
2604 d = instr(s,"perl -");
2606 d = instr(s,"perl");
2608 /* avoid getting into infinite loops when shebang
2609 * line contains "Perl" rather than "perl" */
2611 for (d = ipathend-4; d >= ipath; --d) {
2612 if ((*d == 'p' || *d == 'P')
2613 && !ibcmp(d, "perl", 4))
2623 #ifdef ALTERNATE_SHEBANG
2625 * If the ALTERNATE_SHEBANG on this system starts with a
2626 * character that can be part of a Perl expression, then if
2627 * we see it but not "perl", we're probably looking at the
2628 * start of Perl code, not a request to hand off to some
2629 * other interpreter. Similarly, if "perl" is there, but
2630 * not in the first 'word' of the line, we assume the line
2631 * contains the start of the Perl program.
2633 if (d && *s != '#') {
2635 while (*c && !strchr("; \t\r\n\f\v#", *c))
2638 d = Nullch; /* "perl" not in first word; ignore */
2640 *s = '#'; /* Don't try to parse shebang line */
2642 #endif /* ALTERNATE_SHEBANG */
2643 #ifndef MACOS_TRADITIONAL
2648 !instr(s,"indir") &&
2649 instr(PL_origargv[0],"perl"))
2655 while (s < PL_bufend && isSPACE(*s))
2657 if (s < PL_bufend) {
2658 Newz(899,newargv,PL_origargc+3,char*);
2660 while (s < PL_bufend && !isSPACE(*s))
2663 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2666 newargv = PL_origargv;
2668 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
2669 Perl_croak(aTHX_ "Can't exec %s", ipath);
2673 U32 oldpdb = PL_perldb;
2674 bool oldn = PL_minus_n;
2675 bool oldp = PL_minus_p;
2677 while (*d && !isSPACE(*d)) d++;
2678 while (SPACE_OR_TAB(*d)) d++;
2682 if (*d == 'M' || *d == 'm') {
2684 while (*d && !isSPACE(*d)) d++;
2685 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2688 d = moreswitches(d);
2690 if ((PERLDB_LINE && !oldpdb) ||
2691 ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
2692 /* if we have already added "LINE: while (<>) {",
2693 we must not do it again */
2695 sv_setpv(PL_linestr, "");
2696 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2697 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2698 PL_last_lop = PL_last_uni = Nullch;
2699 PL_preambled = FALSE;
2701 (void)gv_fetchfile(PL_origfilename);
2708 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2710 PL_lex_state = LEX_FORMLINE;
2715 #ifdef PERL_STRICT_CR
2716 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2718 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
2720 case ' ': case '\t': case '\f': case 013:
2721 #ifdef MACOS_TRADITIONAL
2728 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2729 if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
2730 /* handle eval qq[#line 1 "foo"\n ...] */
2731 CopLINE_dec(PL_curcop);
2735 while (s < d && *s != '\n')
2739 else if (s > d) /* Found by Ilya: feed random input to Perl. */
2740 Perl_croak(aTHX_ "panic: input overflow");
2742 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2744 PL_lex_state = LEX_FORMLINE;
2754 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2761 while (s < PL_bufend && SPACE_OR_TAB(*s))
2764 if (strnEQ(s,"=>",2)) {
2765 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2766 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2767 "### Saw unary minus before =>, forcing word '%s'\n", s);
2769 OPERATOR('-'); /* unary minus */
2771 PL_last_uni = PL_oldbufptr;
2773 case 'r': ftst = OP_FTEREAD; break;
2774 case 'w': ftst = OP_FTEWRITE; break;
2775 case 'x': ftst = OP_FTEEXEC; break;
2776 case 'o': ftst = OP_FTEOWNED; break;
2777 case 'R': ftst = OP_FTRREAD; break;
2778 case 'W': ftst = OP_FTRWRITE; break;
2779 case 'X': ftst = OP_FTREXEC; break;
2780 case 'O': ftst = OP_FTROWNED; break;
2781 case 'e': ftst = OP_FTIS; break;
2782 case 'z': ftst = OP_FTZERO; break;
2783 case 's': ftst = OP_FTSIZE; break;
2784 case 'f': ftst = OP_FTFILE; break;
2785 case 'd': ftst = OP_FTDIR; break;
2786 case 'l': ftst = OP_FTLINK; break;
2787 case 'p': ftst = OP_FTPIPE; break;
2788 case 'S': ftst = OP_FTSOCK; break;
2789 case 'u': ftst = OP_FTSUID; break;
2790 case 'g': ftst = OP_FTSGID; break;
2791 case 'k': ftst = OP_FTSVTX; break;
2792 case 'b': ftst = OP_FTBLK; break;
2793 case 'c': ftst = OP_FTCHR; break;
2794 case 't': ftst = OP_FTTTY; break;
2795 case 'T': ftst = OP_FTTEXT; break;
2796 case 'B': ftst = OP_FTBINARY; break;
2797 case 'M': case 'A': case 'C':
2798 gv_fetchpv("\024",TRUE, SVt_PV);
2800 case 'M': ftst = OP_FTMTIME; break;
2801 case 'A': ftst = OP_FTATIME; break;
2802 case 'C': ftst = OP_FTCTIME; break;
2810 PL_last_lop_op = ftst;
2811 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2812 "### Saw file test %c\n", (int)ftst);
2817 /* Assume it was a minus followed by a one-letter named
2818 * subroutine call (or a -bareword), then. */
2819 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2820 "### %c looked like a file test but was not\n",
2829 if (PL_expect == XOPERATOR)
2834 else if (*s == '>') {
2837 if (isIDFIRST_lazy_if(s,UTF)) {
2838 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2846 if (PL_expect == XOPERATOR)
2849 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2851 OPERATOR('-'); /* unary minus */
2858 if (PL_expect == XOPERATOR)
2863 if (PL_expect == XOPERATOR)
2866 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2872 if (PL_expect != XOPERATOR) {
2873 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2874 PL_expect = XOPERATOR;
2875 force_ident(PL_tokenbuf, '*');
2888 if (PL_expect == XOPERATOR) {
2892 PL_tokenbuf[0] = '%';
2893 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2894 if (!PL_tokenbuf[1]) {
2896 yyerror("Final % should be \\% or %name");
2899 PL_pending_ident = '%';
2918 switch (PL_expect) {
2921 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
2923 PL_bufptr = s; /* update in case we back off */
2929 PL_expect = XTERMBLOCK;
2933 while (isIDFIRST_lazy_if(s,UTF)) {
2934 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2935 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
2936 if (tmp < 0) tmp = -tmp;
2951 d = scan_str(d,TRUE,TRUE);
2953 /* MUST advance bufptr here to avoid bogus
2954 "at end of line" context messages from yyerror().
2956 PL_bufptr = s + len;
2957 yyerror("Unterminated attribute parameter in attribute list");
2960 return 0; /* EOF indicator */
2964 SV *sv = newSVpvn(s, len);
2965 sv_catsv(sv, PL_lex_stuff);
2966 attrs = append_elem(OP_LIST, attrs,
2967 newSVOP(OP_CONST, 0, sv));
2968 SvREFCNT_dec(PL_lex_stuff);
2969 PL_lex_stuff = Nullsv;
2972 if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len))
2973 CvLVALUE_on(PL_compcv);
2974 else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len))
2975 CvLOCKED_on(PL_compcv);
2976 else if (!PL_in_my && len == 6 && strnEQ(s, "method", len))
2977 CvMETHOD_on(PL_compcv);
2979 else if (PL_in_my == KEY_our && len == 6 && strnEQ(s, "unique", len))
2980 GvUNIQUE_on(cGVOPx_gv(yylval.opval));
2982 /* After we've set the flags, it could be argued that
2983 we don't need to do the attributes.pm-based setting
2984 process, and shouldn't bother appending recognized
2985 flags. To experiment with that, uncomment the
2986 following "else": */
2988 attrs = append_elem(OP_LIST, attrs,
2989 newSVOP(OP_CONST, 0,
2993 if (*s == ':' && s[1] != ':')
2996 break; /* require real whitespace or :'s */
2998 tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
2999 if (*s != ';' && *s != tmp && (tmp != '=' || *s != ')')) {
3000 char q = ((*s == '\'') ? '"' : '\'');
3001 /* If here for an expression, and parsed no attrs, back off. */
3002 if (tmp == '=' && !attrs) {
3006 /* MUST advance bufptr here to avoid bogus "at end of line"
3007 context messages from yyerror().
3011 yyerror("Unterminated attribute list");
3013 yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list",
3021 PL_nextval[PL_nexttoke].opval = attrs;
3029 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
3030 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
3046 if (PL_lex_brackets <= 0)
3047 yyerror("Unmatched right square bracket");
3050 if (PL_lex_state == LEX_INTERPNORMAL) {
3051 if (PL_lex_brackets == 0) {
3052 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
3053 PL_lex_state = LEX_INTERPEND;
3060 if (PL_lex_brackets > 100) {
3061 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
3062 if (newlb != PL_lex_brackstack) {
3064 PL_lex_brackstack = newlb;
3067 switch (PL_expect) {
3069 if (PL_lex_formbrack) {
3073 if (PL_oldoldbufptr == PL_last_lop)
3074 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3076 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3077 OPERATOR(HASHBRACK);
3079 while (s < PL_bufend && SPACE_OR_TAB(*s))
3082 PL_tokenbuf[0] = '\0';
3083 if (d < PL_bufend && *d == '-') {
3084 PL_tokenbuf[0] = '-';
3086 while (d < PL_bufend && SPACE_OR_TAB(*d))
3089 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
3090 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
3092 while (d < PL_bufend && SPACE_OR_TAB(*d))
3095 char minus = (PL_tokenbuf[0] == '-');
3096 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
3104 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
3109 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3114 if (PL_oldoldbufptr == PL_last_lop)
3115 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3117 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3120 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
3122 /* This hack is to get the ${} in the message. */
3124 yyerror("syntax error");
3127 OPERATOR(HASHBRACK);
3129 /* This hack serves to disambiguate a pair of curlies
3130 * as being a block or an anon hash. Normally, expectation
3131 * determines that, but in cases where we're not in a
3132 * position to expect anything in particular (like inside
3133 * eval"") we have to resolve the ambiguity. This code
3134 * covers the case where the first term in the curlies is a
3135 * quoted string. Most other cases need to be explicitly
3136 * disambiguated by prepending a `+' before the opening
3137 * curly in order to force resolution as an anon hash.
3139 * XXX should probably propagate the outer expectation
3140 * into eval"" to rely less on this hack, but that could
3141 * potentially break current behavior of eval"".
3145 if (*s == '\'' || *s == '"' || *s == '`') {
3146 /* common case: get past first string, handling escapes */
3147 for (t++; t < PL_bufend && *t != *s;)
3148 if (*t++ == '\\' && (*t == '\\' || *t == *s))
3152 else if (*s == 'q') {
3155 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
3159 char open, close, term;
3162 while (t < PL_bufend && isSPACE(*t))
3166 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
3170 for (t++; t < PL_bufend; t++) {
3171 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
3173 else if (*t == open)
3177 for (t++; t < PL_bufend; t++) {
3178 if (*t == '\\' && t+1 < PL_bufend)
3180 else if (*t == close && --brackets <= 0)
3182 else if (*t == open)
3188 else if (isALNUM_lazy_if(t,UTF)) {
3190 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3193 while (t < PL_bufend && isSPACE(*t))
3195 /* if comma follows first term, call it an anon hash */
3196 /* XXX it could be a comma expression with loop modifiers */
3197 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
3198 || (*t == '=' && t[1] == '>')))
3199 OPERATOR(HASHBRACK);
3200 if (PL_expect == XREF)
3203 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
3209 yylval.ival = CopLINE(PL_curcop);
3210 if (isSPACE(*s) || *s == '#')
3211 PL_copline = NOLINE; /* invalidate current command line number */
3216 if (PL_lex_brackets <= 0)
3217 yyerror("Unmatched right curly bracket");
3219 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
3220 if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
3221 PL_lex_formbrack = 0;
3222 if (PL_lex_state == LEX_INTERPNORMAL) {
3223 if (PL_lex_brackets == 0) {
3224 if (PL_expect & XFAKEBRACK) {
3225 PL_expect &= XENUMMASK;
3226 PL_lex_state = LEX_INTERPEND;
3228 return yylex(); /* ignore fake brackets */
3230 if (*s == '-' && s[1] == '>')
3231 PL_lex_state = LEX_INTERPENDMAYBE;
3232 else if (*s != '[' && *s != '{')
3233 PL_lex_state = LEX_INTERPEND;
3236 if (PL_expect & XFAKEBRACK) {
3237 PL_expect &= XENUMMASK;
3239 return yylex(); /* ignore fake brackets */
3249 if (PL_expect == XOPERATOR) {
3250 if (ckWARN(WARN_SEMICOLON)
3251 && isIDFIRST_lazy_if(s,UTF) && PL_bufptr == PL_linestart)
3253 CopLINE_dec(PL_curcop);
3254 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3255 CopLINE_inc(PL_curcop);
3260 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3262 PL_expect = XOPERATOR;
3263 force_ident(PL_tokenbuf, '&');
3267 yylval.ival = (OPpENTERSUB_AMPER<<8);
3286 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
3287 Perl_warner(aTHX_ WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
3289 if (PL_expect == XSTATE && isALPHA(tmp) &&
3290 (s == PL_linestart+1 || s[-2] == '\n') )
3292 if (PL_in_eval && !PL_rsfp) {
3297 if (strnEQ(s,"=cut",4)) {
3311 PL_doextract = TRUE;
3314 if (PL_lex_brackets < PL_lex_formbrack) {
3316 #ifdef PERL_STRICT_CR
3317 for (t = s; SPACE_OR_TAB(*t); t++) ;
3319 for (t = s; SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
3321 if (*t == '\n' || *t == '#') {
3339 if (PL_expect != XOPERATOR) {
3340 if (s[1] != '<' && !strchr(s,'>'))
3343 s = scan_heredoc(s);
3345 s = scan_inputsymbol(s);
3346 TERM(sublex_start());
3351 SHop(OP_LEFT_SHIFT);
3365 SHop(OP_RIGHT_SHIFT);
3374 if (PL_expect == XOPERATOR) {
3375 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3378 return ','; /* grandfather non-comma-format format */
3382 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
3383 PL_tokenbuf[0] = '@';
3384 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3385 sizeof PL_tokenbuf - 1, FALSE);
3386 if (PL_expect == XOPERATOR)
3387 no_op("Array length", s);
3388 if (!PL_tokenbuf[1])
3390 PL_expect = XOPERATOR;
3391 PL_pending_ident = '#';
3395 PL_tokenbuf[0] = '$';
3396 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3397 sizeof PL_tokenbuf - 1, FALSE);
3398 if (PL_expect == XOPERATOR)
3400 if (!PL_tokenbuf[1]) {
3402 yyerror("Final $ should be \\$ or $name");
3406 /* This kludge not intended to be bulletproof. */
3407 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
3408 yylval.opval = newSVOP(OP_CONST, 0,
3409 newSViv(PL_compiling.cop_arybase));
3410 yylval.opval->op_private = OPpCONST_ARYBASE;
3416 if (PL_lex_state == LEX_NORMAL)
3419 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3422 PL_tokenbuf[0] = '@';
3423 if (ckWARN(WARN_SYNTAX)) {
3425 isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$';
3428 PL_bufptr = skipspace(PL_bufptr);
3429 while (t < PL_bufend && *t != ']')
3431 Perl_warner(aTHX_ WARN_SYNTAX,
3432 "Multidimensional syntax %.*s not supported",
3433 (t - PL_bufptr) + 1, PL_bufptr);
3437 else if (*s == '{') {
3438 PL_tokenbuf[0] = '%';
3439 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
3440 (t = strchr(s, '}')) && (t = strchr(t, '=')))
3442 char tmpbuf[sizeof PL_tokenbuf];
3444 for (t++; isSPACE(*t); t++) ;
3445 if (isIDFIRST_lazy_if(t,UTF)) {
3446 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
3447 for (; isSPACE(*t); t++) ;
3448 if (*t == ';' && get_cv(tmpbuf, FALSE))
3449 Perl_warner(aTHX_ WARN_SYNTAX,
3450 "You need to quote \"%s\"", tmpbuf);
3456 PL_expect = XOPERATOR;
3457 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3458 bool islop = (PL_last_lop == PL_oldoldbufptr);
3459 if (!islop || PL_last_lop_op == OP_GREPSTART)
3460 PL_expect = XOPERATOR;
3461 else if (strchr("$@\"'`q", *s))
3462 PL_expect = XTERM; /* e.g. print $fh "foo" */
3463 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
3464 PL_expect = XTERM; /* e.g. print $fh &sub */
3465 else if (isIDFIRST_lazy_if(s,UTF)) {
3466 char tmpbuf[sizeof PL_tokenbuf];
3467 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3468 if ((tmp = keyword(tmpbuf, len))) {
3469 /* binary operators exclude handle interpretations */
3481 PL_expect = XTERM; /* e.g. print $fh length() */
3486 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
3487 if (gv && GvCVu(gv))
3488 PL_expect = XTERM; /* e.g. print $fh subr() */
3491 else if (isDIGIT(*s))
3492 PL_expect = XTERM; /* e.g. print $fh 3 */
3493 else if (*s == '.' && isDIGIT(s[1]))
3494 PL_expect = XTERM; /* e.g. print $fh .3 */
3495 else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
3496 PL_expect = XTERM; /* e.g. print $fh -1 */
3497 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3498 PL_expect = XTERM; /* print $fh <<"EOF" */
3500 PL_pending_ident = '$';
3504 if (PL_expect == XOPERATOR)
3506 PL_tokenbuf[0] = '@';
3507 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3508 if (!PL_tokenbuf[1]) {
3510 yyerror("Final @ should be \\@ or @name");
3513 if (PL_lex_state == LEX_NORMAL)
3515 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3517 PL_tokenbuf[0] = '%';
3519 /* Warn about @ where they meant $. */
3520 if (ckWARN(WARN_SYNTAX)) {
3521 if (*s == '[' || *s == '{') {
3523 while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
3525 if (*t == '}' || *t == ']') {
3527 PL_bufptr = skipspace(PL_bufptr);
3528 Perl_warner(aTHX_ WARN_SYNTAX,
3529 "Scalar value %.*s better written as $%.*s",
3530 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
3535 PL_pending_ident = '@';
3538 case '/': /* may either be division or pattern */
3539 case '?': /* may either be conditional or pattern */
3540 if (PL_expect != XOPERATOR) {
3541 /* Disable warning on "study /blah/" */
3542 if (PL_oldoldbufptr == PL_last_uni
3543 && (*PL_last_uni != 's' || s - PL_last_uni < 5
3544 || memNE(PL_last_uni, "study", 5)
3545 || isALNUM_lazy_if(PL_last_uni+5,UTF)))
3547 s = scan_pat(s,OP_MATCH);
3548 TERM(sublex_start());
3556 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3557 #ifdef PERL_STRICT_CR
3560 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3562 && (s == PL_linestart || s[-1] == '\n') )
3564 PL_lex_formbrack = 0;
3568 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
3574 yylval.ival = OPf_SPECIAL;
3580 if (PL_expect != XOPERATOR)
3585 case '0': case '1': case '2': case '3': case '4':
3586 case '5': case '6': case '7': case '8': case '9':
3587 s = scan_num(s, &yylval);
3588 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3589 "### Saw number in '%s'\n", s);
3591 if (PL_expect == XOPERATOR)
3596 s = scan_str(s,FALSE,FALSE);
3597 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3598 "### Saw string before '%s'\n", s);
3600 if (PL_expect == XOPERATOR) {
3601 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3604 return ','; /* grandfather non-comma-format format */
3610 missingterm((char*)0);
3611 yylval.ival = OP_CONST;
3612 TERM(sublex_start());
3615 s = scan_str(s,FALSE,FALSE);
3616 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3617 "### Saw string before '%s'\n", s);
3619 if (PL_expect == XOPERATOR) {
3620 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3623 return ','; /* grandfather non-comma-format format */
3629 missingterm((char*)0);
3630 yylval.ival = OP_CONST;
3631 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
3632 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
3633 yylval.ival = OP_STRINGIFY;
3637 TERM(sublex_start());
3640 s = scan_str(s,FALSE,FALSE);
3641 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3642 "### Saw backtick string before '%s'\n", s);
3644 if (PL_expect == XOPERATOR)
3645 no_op("Backticks",s);
3647 missingterm((char*)0);
3648 yylval.ival = OP_BACKTICK;
3650 TERM(sublex_start());
3654 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
3655 Perl_warner(aTHX_ WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
3657 if (PL_expect == XOPERATOR)
3658 no_op("Backslash",s);
3662 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
3666 while (isDIGIT(*start) || *start == '_')
3668 if (*start == '.' && isDIGIT(start[1])) {
3669 s = scan_num(s, &yylval);
3672 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
3673 else if (!isALPHA(*start) && (PL_expect == XTERM || PL_expect == XREF || PL_expect == XSTATE)) {
3677 gv = gv_fetchpv(s, FALSE, SVt_PVCV);
3680 s = scan_num(s, &yylval);
3687 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
3726 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3728 /* Some keywords can be followed by any delimiter, including ':' */
3729 tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
3730 (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
3731 (PL_tokenbuf[0] == 'q' &&
3732 strchr("qwxr", PL_tokenbuf[1])))));
3734 /* x::* is just a word, unless x is "CORE" */
3735 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
3739 while (d < PL_bufend && isSPACE(*d))
3740 d++; /* no comments skipped here, or s### is misparsed */
3742 /* Is this a label? */
3743 if (!tmp && PL_expect == XSTATE
3744 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
3746 yylval.pval = savepv(PL_tokenbuf);
3751 /* Check for keywords */
3752 tmp = keyword(PL_tokenbuf, len);
3754 /* Is this a word before a => operator? */
3755 if (*d == '=' && d[1] == '>') {
3757 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
3758 yylval.opval->op_private = OPpCONST_BARE;
3759 if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
3760 SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
3764 if (tmp < 0) { /* second-class keyword? */
3765 GV *ogv = Nullgv; /* override (winner) */
3766 GV *hgv = Nullgv; /* hidden (loser) */
3767 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3769 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3772 if (GvIMPORTED_CV(gv))
3774 else if (! CvMETHOD(cv))
3778 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3779 (gv = *gvp) != (GV*)&PL_sv_undef &&
3780 GvCVu(gv) && GvIMPORTED_CV(gv))
3786 tmp = 0; /* overridden by import or by GLOBAL */
3789 && -tmp==KEY_lock /* XXX generalizable kludge */
3791 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3793 tmp = 0; /* any sub overrides "weak" keyword */
3795 else { /* no override */
3799 if (ckWARN(WARN_AMBIGUOUS) && hgv
3800 && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3801 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3802 "Ambiguous call resolved as CORE::%s(), %s",
3803 GvENAME(hgv), "qualify as such or use &");
3810 default: /* not a keyword */
3814 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3816 /* Get the rest if it looks like a package qualifier */
3818 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
3820 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3823 Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
3824 *s == '\'' ? "'" : "::");
3829 if (PL_expect == XOPERATOR) {
3830 if (PL_bufptr == PL_linestart) {
3831 CopLINE_dec(PL_curcop);
3832 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3833 CopLINE_inc(PL_curcop);
3836 no_op("Bareword",s);
3839 /* Look for a subroutine with this name in current package,
3840 unless name is "Foo::", in which case Foo is a bearword
3841 (and a package name). */
3844 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3846 if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3847 Perl_warner(aTHX_ WARN_BAREWORD,
3848 "Bareword \"%s\" refers to nonexistent package",
3851 PL_tokenbuf[len] = '\0';
3858 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3861 /* if we saw a global override before, get the right name */
3864 sv = newSVpvn("CORE::GLOBAL::",14);
3865 sv_catpv(sv,PL_tokenbuf);
3868 sv = newSVpv(PL_tokenbuf,0);
3870 /* Presume this is going to be a bareword of some sort. */
3873 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3874 yylval.opval->op_private = OPpCONST_BARE;
3876 /* And if "Foo::", then that's what it certainly is. */
3881 /* See if it's the indirect object for a list operator. */
3883 if (PL_oldoldbufptr &&
3884 PL_oldoldbufptr < PL_bufptr &&
3885 (PL_oldoldbufptr == PL_last_lop
3886 || PL_oldoldbufptr == PL_last_uni) &&
3887 /* NO SKIPSPACE BEFORE HERE! */
3888 (PL_expect == XREF ||
3889 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
3891 bool immediate_paren = *s == '(';
3893 /* (Now we can afford to cross potential line boundary.) */
3896 /* Two barewords in a row may indicate method call. */
3898 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp=intuit_method(s,gv)))
3901 /* If not a declared subroutine, it's an indirect object. */
3902 /* (But it's an indir obj regardless for sort.) */
3904 if ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
3905 ((!gv || !GvCVu(gv)) &&
3906 (PL_last_lop_op != OP_MAPSTART &&
3907 PL_last_lop_op != OP_GREPSTART))))
3909 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3914 PL_expect = XOPERATOR;
3917 /* Is this a word before a => operator? */
3918 if (*s == '=' && s[1] == '>' && !pkgname) {
3920 sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
3921 if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
3922 SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
3926 /* If followed by a paren, it's certainly a subroutine. */
3929 if (gv && GvCVu(gv)) {
3930 for (d = s + 1; SPACE_OR_TAB(*d); d++) ;
3931 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
3936 PL_nextval[PL_nexttoke].opval = yylval.opval;
3937 PL_expect = XOPERATOR;
3943 /* If followed by var or block, call it a method (unless sub) */
3945 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3946 PL_last_lop = PL_oldbufptr;
3947 PL_last_lop_op = OP_METHOD;
3951 /* If followed by a bareword, see if it looks like indir obj. */
3953 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp = intuit_method(s,gv)))
3956 /* Not a method, so call it a subroutine (if defined) */
3958 if (gv && GvCVu(gv)) {
3960 if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
3961 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3962 "Ambiguous use of -%s resolved as -&%s()",
3963 PL_tokenbuf, PL_tokenbuf);
3964 /* Check for a constant sub */
3966 if ((sv = cv_const_sv(cv))) {
3968 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3969 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3970 yylval.opval->op_private = 0;
3974 /* Resolve to GV now. */
3975 op_free(yylval.opval);
3976 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3977 yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
3978 PL_last_lop = PL_oldbufptr;
3979 PL_last_lop_op = OP_ENTERSUB;
3980 /* Is there a prototype? */
3983 char *proto = SvPV((SV*)cv, len);
3986 if (strEQ(proto, "$"))
3988 if (*proto == '&' && *s == '{') {
3989 sv_setpv(PL_subname,"__ANON__");
3993 PL_nextval[PL_nexttoke].opval = yylval.opval;
3999 /* Call it a bare word */
4001 if (PL_hints & HINT_STRICT_SUBS)
4002 yylval.opval->op_private |= OPpCONST_STRICT;
4005 if (ckWARN(WARN_RESERVED)) {
4006 if (lastchar != '-') {
4007 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
4008 if (!*d && strNE(PL_tokenbuf,"main"))
4009 Perl_warner(aTHX_ WARN_RESERVED, PL_warn_reserved,
4016 if (lastchar && strchr("*%&", lastchar) && ckWARN_d(WARN_AMBIGUOUS)) {
4017 Perl_warner(aTHX_ WARN_AMBIGUOUS,
4018 "Operator or semicolon missing before %c%s",
4019 lastchar, PL_tokenbuf);
4020 Perl_warner(aTHX_ WARN_AMBIGUOUS,
4021 "Ambiguous use of %c resolved as operator %c",
4022 lastchar, lastchar);
4028 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4029 newSVpv(CopFILE(PL_curcop),0));
4033 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4034 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
4037 case KEY___PACKAGE__:
4038 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4040 ? newSVsv(PL_curstname)
4049 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
4050 char *pname = "main";
4051 if (PL_tokenbuf[2] == 'D')
4052 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
4053 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
4056 GvIOp(gv) = newIO();
4057 IoIFP(GvIOp(gv)) = PL_rsfp;
4058 #if defined(HAS_FCNTL) && defined(F_SETFD)
4060 int fd = PerlIO_fileno(PL_rsfp);
4061 fcntl(fd,F_SETFD,fd >= 3);
4064 /* Mark this internal pseudo-handle as clean */
4065 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
4067 IoTYPE(GvIOp(gv)) = IoTYPE_PIPE;
4068 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
4069 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
4071 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
4072 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
4073 /* if the script was opened in binmode, we need to revert
4074 * it to text mode for compatibility; but only iff it has CRs
4075 * XXX this is a questionable hack at best. */
4076 if (PL_bufend-PL_bufptr > 2
4077 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
4080 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
4081 loc = PerlIO_tell(PL_rsfp);
4082 (void)PerlIO_seek(PL_rsfp, 0L, 0);
4085 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
4087 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
4088 #endif /* NETWARE */
4089 #ifdef PERLIO_IS_STDIO /* really? */
4090 # if defined(__BORLANDC__)
4091 /* XXX see note in do_binmode() */
4092 ((FILE*)PL_rsfp)->flags &= ~_F_BIN;
4096 PerlIO_seek(PL_rsfp, loc, 0);
4100 #ifdef PERLIO_LAYERS
4101 if (UTF && !IN_BYTES)
4102 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
4115 if (PL_expect == XSTATE) {
4122 if (*s == ':' && s[1] == ':') {
4125 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4126 if (!(tmp = keyword(PL_tokenbuf, len)))
4127 Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
4141 LOP(OP_ACCEPT,XTERM);
4147 LOP(OP_ATAN2,XTERM);
4153 LOP(OP_BINMODE,XTERM);
4156 LOP(OP_BLESS,XTERM);
4165 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
4182 if (!PL_cryptseen) {
4183 PL_cryptseen = TRUE;
4187 LOP(OP_CRYPT,XTERM);
4190 LOP(OP_CHMOD,XTERM);
4193 LOP(OP_CHOWN,XTERM);
4196 LOP(OP_CONNECT,XTERM);
4212 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4216 PL_hints |= HINT_BLOCK_SCOPE;
4226 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
4227 LOP(OP_DBMOPEN,XTERM);
4233 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4240 yylval.ival = CopLINE(PL_curcop);
4254 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
4255 UNIBRACK(OP_ENTEREVAL);
4270 case KEY_endhostent:
4276 case KEY_endservent:
4279 case KEY_endprotoent:
4290 yylval.ival = CopLINE(PL_curcop);
4292 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
4294 if ((PL_bufend - p) >= 3 &&
4295 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
4297 else if ((PL_bufend - p) >= 4 &&
4298 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
4301 if (isIDFIRST_lazy_if(p,UTF)) {
4302 p = scan_ident(p, PL_bufend,
4303 PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4307 Perl_croak(aTHX_ "Missing $ on loop variable");
4312 LOP(OP_FORMLINE,XTERM);
4318 LOP(OP_FCNTL,XTERM);
4324 LOP(OP_FLOCK,XTERM);
4333 LOP(OP_GREPSTART, XREF);
4336 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4351 case KEY_getpriority:
4352 LOP(OP_GETPRIORITY,XTERM);
4354 case KEY_getprotobyname:
4357 case KEY_getprotobynumber:
4358 LOP(OP_GPBYNUMBER,XTERM);
4360 case KEY_getprotoent:
4372 case KEY_getpeername:
4373 UNI(OP_GETPEERNAME);
4375 case KEY_gethostbyname:
4378 case KEY_gethostbyaddr:
4379 LOP(OP_GHBYADDR,XTERM);
4381 case KEY_gethostent:
4384 case KEY_getnetbyname:
4387 case KEY_getnetbyaddr:
4388 LOP(OP_GNBYADDR,XTERM);
4393 case KEY_getservbyname:
4394 LOP(OP_GSBYNAME,XTERM);
4396 case KEY_getservbyport:
4397 LOP(OP_GSBYPORT,XTERM);
4399 case KEY_getservent:
4402 case KEY_getsockname:
4403 UNI(OP_GETSOCKNAME);
4405 case KEY_getsockopt:
4406 LOP(OP_GSOCKOPT,XTERM);
4428 yylval.ival = CopLINE(PL_curcop);
4432 LOP(OP_INDEX,XTERM);
4438 LOP(OP_IOCTL,XTERM);
4450 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4482 LOP(OP_LISTEN,XTERM);
4491 s = scan_pat(s,OP_MATCH);
4492 TERM(sublex_start());
4495 LOP(OP_MAPSTART, XREF);
4498 LOP(OP_MKDIR,XTERM);
4501 LOP(OP_MSGCTL,XTERM);
4504 LOP(OP_MSGGET,XTERM);
4507 LOP(OP_MSGRCV,XTERM);
4510 LOP(OP_MSGSND,XTERM);
4516 if (isIDFIRST_lazy_if(s,UTF)) {
4517 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
4518 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
4520 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
4521 if (!PL_in_my_stash) {
4524 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
4532 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4539 if (PL_expect != XSTATE)
4540 yyerror("\"no\" not allowed in expression");
4541 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4542 s = force_version(s, FALSE);
4547 if (*s == '(' || (s = skipspace(s), *s == '('))
4554 if (isIDFIRST_lazy_if(s,UTF)) {
4556 for (d = s; isALNUM_lazy_if(d,UTF); d++) ;
4558 if (strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE))
4559 Perl_warner(aTHX_ WARN_PRECEDENCE,
4560 "Precedence problem: open %.*s should be open(%.*s)",
4566 yylval.ival = OP_OR;
4576 LOP(OP_OPEN_DIR,XTERM);
4579 checkcomma(s,PL_tokenbuf,"filehandle");
4583 checkcomma(s,PL_tokenbuf,"filehandle");
4602 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4606 LOP(OP_PIPE_OP,XTERM);
4609 s = scan_str(s,FALSE,FALSE);
4611 missingterm((char*)0);
4612 yylval.ival = OP_CONST;
4613 TERM(sublex_start());
4619 s = scan_str(s,FALSE,FALSE);
4621 missingterm((char*)0);
4623 if (SvCUR(PL_lex_stuff)) {
4626 d = SvPV_force(PL_lex_stuff, len);
4629 for (; isSPACE(*d) && len; --len, ++d) ;
4632 if (!warned && ckWARN(WARN_QW)) {
4633 for (; !isSPACE(*d) && len; --len, ++d) {
4635 Perl_warner(aTHX_ WARN_QW,
4636 "Possible attempt to separate words with commas");
4639 else if (*d == '#') {
4640 Perl_warner(aTHX_ WARN_QW,
4641 "Possible attempt to put comments in qw() list");
4647 for (; !isSPACE(*d) && len; --len, ++d) ;
4649 sv = newSVpvn(b, d-b);
4650 if (DO_UTF8(PL_lex_stuff))
4652 words = append_elem(OP_LIST, words,
4653 newSVOP(OP_CONST, 0, tokeq(sv)));
4657 PL_nextval[PL_nexttoke].opval = words;
4662 SvREFCNT_dec(PL_lex_stuff);
4663 PL_lex_stuff = Nullsv;
4669 s = scan_str(s,FALSE,FALSE);
4671 missingterm((char*)0);
4672 yylval.ival = OP_STRINGIFY;
4673 if (SvIVX(PL_lex_stuff) == '\'')
4674 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
4675 TERM(sublex_start());
4678 s = scan_pat(s,OP_QR);
4679 TERM(sublex_start());
4682 s = scan_str(s,FALSE,FALSE);
4684 missingterm((char*)0);
4685 yylval.ival = OP_BACKTICK;
4687 TERM(sublex_start());
4695 s = force_version(s, FALSE);
4697 else if (*s != 'v' || !isDIGIT(s[1])
4698 || (s = force_version(s, TRUE), *s == 'v'))
4700 *PL_tokenbuf = '\0';
4701 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4702 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
4703 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
4705 yyerror("<> should be quotes");
4713 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4717 LOP(OP_RENAME,XTERM);
4726 LOP(OP_RINDEX,XTERM);
4749 LOP(OP_REVERSE,XTERM);
4760 TERM(sublex_start());
4762 TOKEN(1); /* force error */
4771 LOP(OP_SELECT,XTERM);
4777 LOP(OP_SEMCTL,XTERM);
4780 LOP(OP_SEMGET,XTERM);
4783 LOP(OP_SEMOP,XTERM);
4789 LOP(OP_SETPGRP,XTERM);
4791 case KEY_setpriority:
4792 LOP(OP_SETPRIORITY,XTERM);
4794 case KEY_sethostent:
4800 case KEY_setservent:
4803 case KEY_setprotoent:
4813 LOP(OP_SEEKDIR,XTERM);
4815 case KEY_setsockopt:
4816 LOP(OP_SSOCKOPT,XTERM);
4822 LOP(OP_SHMCTL,XTERM);
4825 LOP(OP_SHMGET,XTERM);
4828 LOP(OP_SHMREAD,XTERM);
4831 LOP(OP_SHMWRITE,XTERM);
4834 LOP(OP_SHUTDOWN,XTERM);
4843 LOP(OP_SOCKET,XTERM);
4845 case KEY_socketpair:
4846 LOP(OP_SOCKPAIR,XTERM);
4849 checkcomma(s,PL_tokenbuf,"subroutine name");
4851 if (*s == ';' || *s == ')') /* probably a close */
4852 Perl_croak(aTHX_ "sort is now a reserved word");
4854 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4858 LOP(OP_SPLIT,XTERM);
4861 LOP(OP_SPRINTF,XTERM);
4864 LOP(OP_SPLICE,XTERM);
4879 LOP(OP_SUBSTR,XTERM);
4885 char tmpbuf[sizeof PL_tokenbuf];
4886 SSize_t tboffset = 0;
4887 expectation attrful;
4888 bool have_name, have_proto;
4893 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
4894 (*s == ':' && s[1] == ':'))
4897 attrful = XATTRBLOCK;
4898 /* remember buffer pos'n for later force_word */
4899 tboffset = s - PL_oldbufptr;
4900 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4901 if (strchr(tmpbuf, ':'))
4902 sv_setpv(PL_subname, tmpbuf);
4904 sv_setsv(PL_subname,PL_curstname);
4905 sv_catpvn(PL_subname,"::",2);
4906 sv_catpvn(PL_subname,tmpbuf,len);
4913 Perl_croak(aTHX_ "Missing name in \"my sub\"");
4914 PL_expect = XTERMBLOCK;
4915 attrful = XATTRTERM;
4916 sv_setpv(PL_subname,"?");
4920 if (key == KEY_format) {
4922 PL_lex_formbrack = PL_lex_brackets + 1;
4924 (void) force_word(PL_oldbufptr + tboffset, WORD,
4929 /* Look for a prototype */
4933 s = scan_str(s,FALSE,FALSE);
4935 Perl_croak(aTHX_ "Prototype not terminated");
4937 d = SvPVX(PL_lex_stuff);
4939 for (p = d; *p; ++p) {
4944 SvCUR(PL_lex_stuff) = tmp;
4952 if (*s == ':' && s[1] != ':')
4953 PL_expect = attrful;
4956 PL_nextval[PL_nexttoke].opval =
4957 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4958 PL_lex_stuff = Nullsv;
4962 sv_setpv(PL_subname,"__ANON__");
4965 (void) force_word(PL_oldbufptr + tboffset, WORD,
4974 LOP(OP_SYSTEM,XREF);
4977 LOP(OP_SYMLINK,XTERM);
4980 LOP(OP_SYSCALL,XTERM);
4983 LOP(OP_SYSOPEN,XTERM);
4986 LOP(OP_SYSSEEK,XTERM);
4989 LOP(OP_SYSREAD,XTERM);
4992 LOP(OP_SYSWRITE,XTERM);
4996 TERM(sublex_start());
5017 LOP(OP_TRUNCATE,XTERM);
5029 yylval.ival = CopLINE(PL_curcop);
5033 yylval.ival = CopLINE(PL_curcop);
5037 LOP(OP_UNLINK,XTERM);
5043 LOP(OP_UNPACK,XTERM);
5046 LOP(OP_UTIME,XTERM);
5052 LOP(OP_UNSHIFT,XTERM);
5055 if (PL_expect != XSTATE)
5056 yyerror("\"use\" not allowed in expression");
5058 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
5059 s = force_version(s, TRUE);
5060 if (*s == ';' || (s = skipspace(s), *s == ';')) {
5061 PL_nextval[PL_nexttoke].opval = Nullop;
5064 else if (*s == 'v') {
5065 s = force_word(s,WORD,FALSE,TRUE,FALSE);
5066 s = force_version(s, FALSE);
5070 s = force_word(s,WORD,FALSE,TRUE,FALSE);
5071 s = force_version(s, FALSE);
5083 yylval.ival = CopLINE(PL_curcop);
5087 PL_hints |= HINT_BLOCK_SCOPE;
5094 LOP(OP_WAITPID,XTERM);
5103 ctl_l[0] = toCTRL('L');
5105 gv_fetchpv(ctl_l,TRUE, SVt_PV);
5108 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
5113 if (PL_expect == XOPERATOR)
5119 yylval.ival = OP_XOR;
5124 TERM(sublex_start());
5129 #pragma segment Main
5133 S_pending_ident(pTHX)
5137 /* pit holds the identifier we read and pending_ident is reset */
5138 char pit = PL_pending_ident;
5139 PL_pending_ident = 0;
5141 DEBUG_T({ PerlIO_printf(Perl_debug_log,
5142 "### Tokener saw identifier '%s'\n", PL_tokenbuf); });
5144 /* if we're in a my(), we can't allow dynamics here.
5145 $foo'bar has already been turned into $foo::bar, so
5146 just check for colons.
5148 if it's a legal name, the OP is a PADANY.
5151 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
5152 if (strchr(PL_tokenbuf,':'))
5153 yyerror(Perl_form(aTHX_ "No package name allowed for "
5154 "variable %s in \"our\"",
5156 tmp = pad_allocmy(PL_tokenbuf);
5159 if (strchr(PL_tokenbuf,':'))
5160 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
5162 yylval.opval = newOP(OP_PADANY, 0);
5163 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
5169 build the ops for accesses to a my() variable.
5171 Deny my($a) or my($b) in a sort block, *if* $a or $b is
5172 then used in a comparison. This catches most, but not
5173 all cases. For instance, it catches
5174 sort { my($a); $a <=> $b }
5176 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
5177 (although why you'd do that is anyone's guess).
5180 if (!strchr(PL_tokenbuf,':')) {
5181 #ifdef USE_5005THREADS
5182 /* Check for single character per-thread SVs */
5183 if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
5184 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
5185 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
5187 yylval.opval = newOP(OP_THREADSV, 0);
5188 yylval.opval->op_targ = tmp;
5191 #endif /* USE_5005THREADS */
5192 if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
5193 SV *namesv = AvARRAY(PL_comppad_name)[tmp];
5194 /* might be an "our" variable" */
5195 if (SvFLAGS(namesv) & SVpad_OUR) {
5196 /* build ops for a bareword */
5197 SV *sym = newSVpv(HvNAME(GvSTASH(namesv)),0);
5198 sv_catpvn(sym, "::", 2);
5199 sv_catpv(sym, PL_tokenbuf+1);
5200 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
5201 yylval.opval->op_private = OPpCONST_ENTERED;
5202 gv_fetchpv(SvPVX(sym),
5204 ? (GV_ADDMULTI | GV_ADDINEVAL)
5207 ((PL_tokenbuf[0] == '$') ? SVt_PV
5208 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5213 /* if it's a sort block and they're naming $a or $b */
5214 if (PL_last_lop_op == OP_SORT &&
5215 PL_tokenbuf[0] == '$' &&
5216 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
5219 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
5220 d < PL_bufend && *d != '\n';
5223 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
5224 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
5230 yylval.opval = newOP(OP_PADANY, 0);
5231 yylval.opval->op_targ = tmp;
5237 Whine if they've said @foo in a doublequoted string,
5238 and @foo isn't a variable we can find in the symbol
5241 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
5242 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
5243 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
5244 && ckWARN(WARN_AMBIGUOUS))
5246 /* Downgraded from fatal to warning 20000522 mjd */
5247 Perl_warner(aTHX_ WARN_AMBIGUOUS,
5248 "Possible unintended interpolation of %s in string",
5253 /* build ops for a bareword */
5254 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
5255 yylval.opval->op_private = OPpCONST_ENTERED;
5256 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
5257 ((PL_tokenbuf[0] == '$') ? SVt_PV
5258 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5264 Perl_keyword(pTHX_ register char *d, I32 len)
5269 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
5270 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
5271 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
5272 if (strEQ(d,"__DATA__")) return KEY___DATA__;
5273 if (strEQ(d,"__END__")) return KEY___END__;
5277 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
5282 if (strEQ(d,"and")) return -KEY_and;
5283 if (strEQ(d,"abs")) return -KEY_abs;
5286 if (strEQ(d,"alarm")) return -KEY_alarm;
5287 if (strEQ(d,"atan2")) return -KEY_atan2;
5290 if (strEQ(d,"accept")) return -KEY_accept;
5295 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
5298 if (strEQ(d,"bless")) return -KEY_bless;
5299 if (strEQ(d,"bind")) return -KEY_bind;
5300 if (strEQ(d,"binmode")) return -KEY_binmode;
5303 if (strEQ(d,"CORE")) return -KEY_CORE;
5304 if (strEQ(d,"CHECK")) return KEY_CHECK;
5309 if (strEQ(d,"cmp")) return -KEY_cmp;
5310 if (strEQ(d,"chr")) return -KEY_chr;
5311 if (strEQ(d,"cos")) return -KEY_cos;
5314 if (strEQ(d,"chop")) return -KEY_chop;
5317 if (strEQ(d,"close")) return -KEY_close;
5318 if (strEQ(d,"chdir")) return -KEY_chdir;
5319 if (strEQ(d,"chomp")) return -KEY_chomp;
5320 if (strEQ(d,"chmod")) return -KEY_chmod;
5321 if (strEQ(d,"chown")) return -KEY_chown;
5322 if (strEQ(d,"crypt")) return -KEY_crypt;
5325 if (strEQ(d,"chroot")) return -KEY_chroot;
5326 if (strEQ(d,"caller")) return -KEY_caller;
5329 if (strEQ(d,"connect")) return -KEY_connect;
5332 if (strEQ(d,"closedir")) return -KEY_closedir;
5333 if (strEQ(d,"continue")) return -KEY_continue;
5338 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
5343 if (strEQ(d,"do")) return KEY_do;
5346 if (strEQ(d,"die")) return -KEY_die;
5349 if (strEQ(d,"dump")) return -KEY_dump;
5352 if (strEQ(d,"delete")) return KEY_delete;
5355 if (strEQ(d,"defined")) return KEY_defined;
5356 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
5359 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
5364 if (strEQ(d,"END")) return KEY_END;
5369 if (strEQ(d,"eq")) return -KEY_eq;
5372 if (strEQ(d,"eof")) return -KEY_eof;
5373 if (strEQ(d,"exp")) return -KEY_exp;
5376 if (strEQ(d,"else")) return KEY_else;
5377 if (strEQ(d,"exit")) return -KEY_exit;
5378 if (strEQ(d,"eval")) return KEY_eval;
5379 if (strEQ(d,"exec")) return -KEY_exec;
5380 if (strEQ(d,"each")) return -KEY_each;
5383 if (strEQ(d,"elsif")) return KEY_elsif;
5386 if (strEQ(d,"exists")) return KEY_exists;
5387 if (strEQ(d,"elseif")) Perl_warn(aTHX_ "elseif should be elsif");
5390 if (strEQ(d,"endgrent")) return -KEY_endgrent;
5391 if (strEQ(d,"endpwent")) return -KEY_endpwent;
5394 if (strEQ(d,"endnetent")) return -KEY_endnetent;
5397 if (strEQ(d,"endhostent")) return -KEY_endhostent;
5398 if (strEQ(d,"endservent")) return -KEY_endservent;
5401 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
5408 if (strEQ(d,"for")) return KEY_for;
5411 if (strEQ(d,"fork")) return -KEY_fork;
5414 if (strEQ(d,"fcntl")) return -KEY_fcntl;
5415 if (strEQ(d,"flock")) return -KEY_flock;
5418 if (strEQ(d,"format")) return KEY_format;
5419 if (strEQ(d,"fileno")) return -KEY_fileno;
5422 if (strEQ(d,"foreach")) return KEY_foreach;
5425 if (strEQ(d,"formline")) return -KEY_formline;
5430 if (strnEQ(d,"get",3)) {
5435 if (strEQ(d,"ppid")) return -KEY_getppid;
5436 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
5439 if (strEQ(d,"pwent")) return -KEY_getpwent;
5440 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
5441 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
5444 if (strEQ(d,"peername")) return -KEY_getpeername;
5445 if (strEQ(d,"protoent")) return -KEY_getprotoent;
5446 if (strEQ(d,"priority")) return -KEY_getpriority;
5449 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
5452 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
5456 else if (*d == 'h') {
5457 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
5458 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
5459 if (strEQ(d,"hostent")) return -KEY_gethostent;
5461 else if (*d == 'n') {
5462 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
5463 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
5464 if (strEQ(d,"netent")) return -KEY_getnetent;
5466 else if (*d == 's') {
5467 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
5468 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
5469 if (strEQ(d,"servent")) return -KEY_getservent;
5470 if (strEQ(d,"sockname")) return -KEY_getsockname;
5471 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
5473 else if (*d == 'g') {
5474 if (strEQ(d,"grent")) return -KEY_getgrent;
5475 if (strEQ(d,"grnam")) return -KEY_getgrnam;
5476 if (strEQ(d,"grgid")) return -KEY_getgrgid;
5478 else if (*d == 'l') {
5479 if (strEQ(d,"login")) return -KEY_getlogin;
5481 else if (strEQ(d,"c")) return -KEY_getc;
5486 if (strEQ(d,"gt")) return -KEY_gt;
5487 if (strEQ(d,"ge")) return -KEY_ge;
5490 if (strEQ(d,"grep")) return KEY_grep;
5491 if (strEQ(d,"goto")) return KEY_goto;
5492 if (strEQ(d,"glob")) return KEY_glob;
5495 if (strEQ(d,"gmtime")) return -KEY_gmtime;
5500 if (strEQ(d,"hex")) return -KEY_hex;
5503 if (strEQ(d,"INIT")) return KEY_INIT;
5508 if (strEQ(d,"if")) return KEY_if;
5511 if (strEQ(d,"int")) return -KEY_int;
5514 if (strEQ(d,"index")) return -KEY_index;
5515 if (strEQ(d,"ioctl")) return -KEY_ioctl;
5520 if (strEQ(d,"join")) return -KEY_join;
5524 if (strEQ(d,"keys")) return -KEY_keys;
5525 if (strEQ(d,"kill")) return -KEY_kill;
5531 if (strEQ(d,"lt")) return -KEY_lt;
5532 if (strEQ(d,"le")) return -KEY_le;
5533 if (strEQ(d,"lc")) return -KEY_lc;
5536 if (strEQ(d,"log")) return -KEY_log;
5539 if (strEQ(d,"last")) return KEY_last;
5540 if (strEQ(d,"link")) return -KEY_link;
5541 if (strEQ(d,"lock")) return -KEY_lock;
5544 if (strEQ(d,"local")) return KEY_local;
5545 if (strEQ(d,"lstat")) return -KEY_lstat;
5548 if (strEQ(d,"length")) return -KEY_length;
5549 if (strEQ(d,"listen")) return -KEY_listen;
5552 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
5555 if (strEQ(d,"localtime")) return -KEY_localtime;
5561 case 1: return KEY_m;
5563 if (strEQ(d,"my")) return KEY_my;
5566 if (strEQ(d,"map")) return KEY_map;
5569 if (strEQ(d,"mkdir")) return -KEY_mkdir;
5572 if (strEQ(d,"msgctl")) return -KEY_msgctl;
5573 if (strEQ(d,"msgget")) return -KEY_msgget;
5574 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
5575 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
5580 if (strEQ(d,"next")) return KEY_next;
5581 if (strEQ(d,"ne")) return -KEY_ne;
5582 if (strEQ(d,"not")) return -KEY_not;
5583 if (strEQ(d,"no")) return KEY_no;
5588 if (strEQ(d,"or")) return -KEY_or;
5591 if (strEQ(d,"ord")) return -KEY_ord;
5592 if (strEQ(d,"oct")) return -KEY_oct;
5593 if (strEQ(d,"our")) return KEY_our;
5596 if (strEQ(d,"open")) return -KEY_open;
5599 if (strEQ(d,"opendir")) return -KEY_opendir;
5606 if (strEQ(d,"pop")) return -KEY_pop;
5607 if (strEQ(d,"pos")) return KEY_pos;
5610 if (strEQ(d,"push")) return -KEY_push;
5611 if (strEQ(d,"pack")) return -KEY_pack;
5612 if (strEQ(d,"pipe")) return -KEY_pipe;
5615 if (strEQ(d,"print")) return KEY_print;
5618 if (strEQ(d,"printf")) return KEY_printf;
5621 if (strEQ(d,"package")) return KEY_package;
5624 if (strEQ(d,"prototype")) return KEY_prototype;
5629 if (strEQ(d,"q")) return KEY_q;
5630 if (strEQ(d,"qr")) return KEY_qr;
5631 if (strEQ(d,"qq")) return KEY_qq;
5632 if (strEQ(d,"qw")) return KEY_qw;
5633 if (strEQ(d,"qx")) return KEY_qx;
5635 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
5640 if (strEQ(d,"ref")) return -KEY_ref;
5643 if (strEQ(d,"read")) return -KEY_read;
5644 if (strEQ(d,"rand")) return -KEY_rand;
5645 if (strEQ(d,"recv")) return -KEY_recv;
5646 if (strEQ(d,"redo")) return KEY_redo;
5649 if (strEQ(d,"rmdir")) return -KEY_rmdir;
5650 if (strEQ(d,"reset")) return -KEY_reset;
5653 if (strEQ(d,"return")) return KEY_return;
5654 if (strEQ(d,"rename")) return -KEY_rename;
5655 if (strEQ(d,"rindex")) return -KEY_rindex;
5658 if (strEQ(d,"require")) return KEY_require;
5659 if (strEQ(d,"reverse")) return -KEY_reverse;
5660 if (strEQ(d,"readdir")) return -KEY_readdir;
5663 if (strEQ(d,"readlink")) return -KEY_readlink;
5664 if (strEQ(d,"readline")) return -KEY_readline;
5665 if (strEQ(d,"readpipe")) return -KEY_readpipe;
5668 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
5674 case 0: return KEY_s;
5676 if (strEQ(d,"scalar")) return KEY_scalar;
5681 if (strEQ(d,"seek")) return -KEY_seek;
5682 if (strEQ(d,"send")) return -KEY_send;
5685 if (strEQ(d,"semop")) return -KEY_semop;
5688 if (strEQ(d,"select")) return -KEY_select;
5689 if (strEQ(d,"semctl")) return -KEY_semctl;
5690 if (strEQ(d,"semget")) return -KEY_semget;
5693 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
5694 if (strEQ(d,"seekdir")) return -KEY_seekdir;
5697 if (strEQ(d,"setpwent")) return -KEY_setpwent;
5698 if (strEQ(d,"setgrent")) return -KEY_setgrent;
5701 if (strEQ(d,"setnetent")) return -KEY_setnetent;
5704 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
5705 if (strEQ(d,"sethostent")) return -KEY_sethostent;
5706 if (strEQ(d,"setservent")) return -KEY_setservent;
5709 if (strEQ(d,"setpriority")) return -KEY_setpriority;
5710 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
5717 if (strEQ(d,"shift")) return -KEY_shift;
5720 if (strEQ(d,"shmctl")) return -KEY_shmctl;
5721 if (strEQ(d,"shmget")) return -KEY_shmget;
5724 if (strEQ(d,"shmread")) return -KEY_shmread;
5727 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
5728 if (strEQ(d,"shutdown")) return -KEY_shutdown;
5733 if (strEQ(d,"sin")) return -KEY_sin;
5736 if (strEQ(d,"sleep")) return -KEY_sleep;
5739 if (strEQ(d,"sort")) return KEY_sort;
5740 if (strEQ(d,"socket")) return -KEY_socket;
5741 if (strEQ(d,"socketpair")) return -KEY_socketpair;
5744 if (strEQ(d,"split")) return KEY_split;
5745 if (strEQ(d,"sprintf")) return -KEY_sprintf;
5746 if (strEQ(d,"splice")) return -KEY_splice;
5749 if (strEQ(d,"sqrt")) return -KEY_sqrt;
5752 if (strEQ(d,"srand")) return -KEY_srand;
5755 if (strEQ(d,"stat")) return -KEY_stat;
5756 if (strEQ(d,"study")) return KEY_study;
5759 if (strEQ(d,"substr")) return -KEY_substr;
5760 if (strEQ(d,"sub")) return KEY_sub;
5765 if (strEQ(d,"system")) return -KEY_system;
5768 if (strEQ(d,"symlink")) return -KEY_symlink;
5769 if (strEQ(d,"syscall")) return -KEY_syscall;
5770 if (strEQ(d,"sysopen")) return -KEY_sysopen;
5771 if (strEQ(d,"sysread")) return -KEY_sysread;
5772 if (strEQ(d,"sysseek")) return -KEY_sysseek;
5775 if (strEQ(d,"syswrite")) return -KEY_syswrite;
5784 if (strEQ(d,"tr")) return KEY_tr;
5787 if (strEQ(d,"tie")) return KEY_tie;
5790 if (strEQ(d,"tell")) return -KEY_tell;
5791 if (strEQ(d,"tied")) return KEY_tied;
5792 if (strEQ(d,"time")) return -KEY_time;
5795 if (strEQ(d,"times")) return -KEY_times;
5798 if (strEQ(d,"telldir")) return -KEY_telldir;
5801 if (strEQ(d,"truncate")) return -KEY_truncate;
5808 if (strEQ(d,"uc")) return -KEY_uc;
5811 if (strEQ(d,"use")) return KEY_use;
5814 if (strEQ(d,"undef")) return KEY_undef;
5815 if (strEQ(d,"until")) return KEY_until;
5816 if (strEQ(d,"untie")) return KEY_untie;
5817 if (strEQ(d,"utime")) return -KEY_utime;
5818 if (strEQ(d,"umask")) return -KEY_umask;
5821 if (strEQ(d,"unless")) return KEY_unless;
5822 if (strEQ(d,"unpack")) return -KEY_unpack;
5823 if (strEQ(d,"unlink")) return -KEY_unlink;
5826 if (strEQ(d,"unshift")) return -KEY_unshift;
5827 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
5832 if (strEQ(d,"values")) return -KEY_values;
5833 if (strEQ(d,"vec")) return -KEY_vec;
5838 if (strEQ(d,"warn")) return -KEY_warn;
5839 if (strEQ(d,"wait")) return -KEY_wait;
5842 if (strEQ(d,"while")) return KEY_while;
5843 if (strEQ(d,"write")) return -KEY_write;
5846 if (strEQ(d,"waitpid")) return -KEY_waitpid;
5849 if (strEQ(d,"wantarray")) return -KEY_wantarray;
5854 if (len == 1) return -KEY_x;
5855 if (strEQ(d,"xor")) return -KEY_xor;
5858 if (len == 1) return KEY_y;
5867 S_checkcomma(pTHX_ register char *s, char *name, char *what)
5871 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
5872 if (ckWARN(WARN_SYNTAX)) {
5874 for (w = s+2; *w && level; w++) {
5881 for (; *w && isSPACE(*w); w++) ;
5882 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
5883 Perl_warner(aTHX_ WARN_SYNTAX,
5884 "%s (...) interpreted as function",name);
5887 while (s < PL_bufend && isSPACE(*s))
5891 while (s < PL_bufend && isSPACE(*s))
5893 if (isIDFIRST_lazy_if(s,UTF)) {
5895 while (isALNUM_lazy_if(s,UTF))
5897 while (s < PL_bufend && isSPACE(*s))
5902 kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
5906 Perl_croak(aTHX_ "No comma allowed after %s", what);
5911 /* Either returns sv, or mortalizes sv and returns a new SV*.
5912 Best used as sv=new_constant(..., sv, ...).
5913 If s, pv are NULL, calls subroutine with one argument,
5914 and type is used with error messages only. */
5917 S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv,
5921 HV *table = GvHV(PL_hintgv); /* ^H */
5925 const char *why1, *why2, *why3;
5927 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
5930 why2 = strEQ(key,"charnames")
5931 ? "(possibly a missing \"use charnames ...\")"
5933 msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
5934 (type ? type: "undef"), why2);
5936 /* This is convoluted and evil ("goto considered harmful")
5937 * but I do not understand the intricacies of all the different
5938 * failure modes of %^H in here. The goal here is to make
5939 * the most probable error message user-friendly. --jhi */
5944 msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
5945 (type ? type: "undef"), why1, why2, why3);
5947 yyerror(SvPVX(msg));
5951 cvp = hv_fetch(table, key, strlen(key), FALSE);
5952 if (!cvp || !SvOK(*cvp)) {
5955 why3 = "} is not defined";
5958 sv_2mortal(sv); /* Parent created it permanently */
5961 pv = sv_2mortal(newSVpvn(s, len));
5963 typesv = sv_2mortal(newSVpv(type, 0));
5965 typesv = &PL_sv_undef;
5967 PUSHSTACKi(PERLSI_OVERLOAD);
5979 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
5983 /* Check the eval first */
5984 if (!PL_in_eval && SvTRUE(ERRSV)) {
5986 sv_catpv(ERRSV, "Propagated");
5987 yyerror(SvPV(ERRSV, n_a)); /* Duplicates the message inside eval */
5989 res = SvREFCNT_inc(sv);
5993 (void)SvREFCNT_inc(res);
6002 why1 = "Call to &{$^H{";
6004 why3 = "}} did not return a defined value";
6013 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
6015 register char *d = dest;
6016 register char *e = d + destlen - 3; /* two-character token, ending NUL */
6019 Perl_croak(aTHX_ ident_too_long);
6020 if (isALNUM(*s)) /* UTF handled below */
6022 else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) {
6027 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
6031 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
6032 char *t = s + UTF8SKIP(s);
6033 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
6035 if (d + (t - s) > e)
6036 Perl_croak(aTHX_ ident_too_long);
6037 Copy(s, d, t - s, char);
6050 S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
6060 e = d + destlen - 3; /* two-character token, ending NUL */
6062 while (isDIGIT(*s)) {
6064 Perl_croak(aTHX_ ident_too_long);
6071 Perl_croak(aTHX_ ident_too_long);
6072 if (isALNUM(*s)) /* UTF handled below */
6074 else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
6079 else if (*s == ':' && s[1] == ':') {
6083 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
6084 char *t = s + UTF8SKIP(s);
6085 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
6087 if (d + (t - s) > e)
6088 Perl_croak(aTHX_ ident_too_long);
6089 Copy(s, d, t - s, char);
6100 if (PL_lex_state != LEX_NORMAL)
6101 PL_lex_state = LEX_INTERPENDMAYBE;
6104 if (*s == '$' && s[1] &&
6105 (isALNUM_lazy_if(s+1,UTF) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
6118 if (*d == '^' && *s && isCONTROLVAR(*s)) {
6123 if (isSPACE(s[-1])) {
6126 if (!SPACE_OR_TAB(ch)) {
6132 if (isIDFIRST_lazy_if(d,UTF)) {
6136 while ((e < send && isALNUM_lazy_if(e,UTF)) || *e == ':') {
6138 while (e < send && UTF8_IS_CONTINUED(*e) && is_utf8_mark((U8*)e))
6141 Copy(s, d, e - s, char);
6146 while ((isALNUM(*s) || *s == ':') && d < e)
6149 Perl_croak(aTHX_ ident_too_long);
6152 while (s < send && SPACE_OR_TAB(*s)) s++;
6153 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
6154 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
6155 const char *brack = *s == '[' ? "[...]" : "{...}";
6156 Perl_warner(aTHX_ WARN_AMBIGUOUS,
6157 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
6158 funny, dest, brack, funny, dest, brack);
6161 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
6165 /* Handle extended ${^Foo} variables
6166 * 1999-02-27 mjd-perl-patch@plover.com */
6167 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
6171 while (isALNUM(*s) && d < e) {
6175 Perl_croak(aTHX_ ident_too_long);
6180 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
6181 PL_lex_state = LEX_INTERPEND;
6184 if (PL_lex_state == LEX_NORMAL) {
6185 if (ckWARN(WARN_AMBIGUOUS) &&
6186 (keyword(dest, d - dest) || get_cv(dest, FALSE)))
6188 Perl_warner(aTHX_ WARN_AMBIGUOUS,
6189 "Ambiguous use of %c{%s} resolved to %c%s",
6190 funny, dest, funny, dest);
6195 s = bracket; /* let the parser handle it */
6199 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
6200 PL_lex_state = LEX_INTERPEND;
6205 Perl_pmflag(pTHX_ U16 *pmfl, int ch)
6210 *pmfl |= PMf_GLOBAL;
6212 *pmfl |= PMf_CONTINUE;
6216 *pmfl |= PMf_MULTILINE;
6218 *pmfl |= PMf_SINGLELINE;
6220 *pmfl |= PMf_EXTENDED;
6224 S_scan_pat(pTHX_ char *start, I32 type)
6229 s = scan_str(start,FALSE,FALSE);
6231 Perl_croak(aTHX_ "Search pattern not terminated");
6233 pm = (PMOP*)newPMOP(type, 0);
6234 if (PL_multi_open == '?')
6235 pm->op_pmflags |= PMf_ONCE;
6237 while (*s && strchr("iomsx", *s))
6238 pmflag(&pm->op_pmflags,*s++);
6241 while (*s && strchr("iogcmsx", *s))
6242 pmflag(&pm->op_pmflags,*s++);
6244 pm->op_pmpermflags = pm->op_pmflags;
6246 PL_lex_op = (OP*)pm;
6247 yylval.ival = OP_MATCH;
6252 S_scan_subst(pTHX_ char *start)
6259 yylval.ival = OP_NULL;
6261 s = scan_str(start,FALSE,FALSE);
6264 Perl_croak(aTHX_ "Substitution pattern not terminated");
6266 if (s[-1] == PL_multi_open)
6269 first_start = PL_multi_start;
6270 s = scan_str(s,FALSE,FALSE);
6273 SvREFCNT_dec(PL_lex_stuff);
6274 PL_lex_stuff = Nullsv;
6276 Perl_croak(aTHX_ "Substitution replacement not terminated");
6278 PL_multi_start = first_start; /* so whole substitution is taken together */
6280 pm = (PMOP*)newPMOP(OP_SUBST, 0);
6286 else if (strchr("iogcmsx", *s))
6287 pmflag(&pm->op_pmflags,*s++);
6294 PL_sublex_info.super_bufptr = s;
6295 PL_sublex_info.super_bufend = PL_bufend;
6297 pm->op_pmflags |= PMf_EVAL;
6298 repl = newSVpvn("",0);
6300 sv_catpv(repl, es ? "eval " : "do ");
6301 sv_catpvn(repl, "{ ", 2);
6302 sv_catsv(repl, PL_lex_repl);
6303 sv_catpvn(repl, " };", 2);
6305 SvREFCNT_dec(PL_lex_repl);
6309 pm->op_pmpermflags = pm->op_pmflags;
6310 PL_lex_op = (OP*)pm;
6311 yylval.ival = OP_SUBST;
6316 S_scan_trans(pTHX_ char *start)
6325 yylval.ival = OP_NULL;
6327 s = scan_str(start,FALSE,FALSE);
6329 Perl_croak(aTHX_ "Transliteration pattern not terminated");
6330 if (s[-1] == PL_multi_open)
6333 s = scan_str(s,FALSE,FALSE);
6336 SvREFCNT_dec(PL_lex_stuff);
6337 PL_lex_stuff = Nullsv;
6339 Perl_croak(aTHX_ "Transliteration replacement not terminated");
6342 complement = del = squash = 0;
6343 while (strchr("cds", *s)) {
6345 complement = OPpTRANS_COMPLEMENT;
6347 del = OPpTRANS_DELETE;
6349 squash = OPpTRANS_SQUASH;
6353 New(803, tbl, complement&&!del?258:256, short);
6354 o = newPVOP(OP_TRANS, 0, (char*)tbl);
6355 o->op_private = del|squash|complement|
6356 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
6357 (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0);
6360 yylval.ival = OP_TRANS;
6365 S_scan_heredoc(pTHX_ register char *s)
6368 I32 op_type = OP_SCALAR;
6375 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
6379 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
6382 for (peek = s; SPACE_OR_TAB(*peek); peek++) ;
6383 if (*peek && strchr("`'\"",*peek)) {
6386 s = delimcpy(d, e, s, PL_bufend, term, &len);
6396 if (!isALNUM_lazy_if(s,UTF))
6397 deprecate("bare << to mean <<\"\"");
6398 for (; isALNUM_lazy_if(s,UTF); s++) {
6403 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
6404 Perl_croak(aTHX_ "Delimiter for here document is too long");
6407 len = d - PL_tokenbuf;
6408 #ifndef PERL_STRICT_CR
6409 d = strchr(s, '\r');
6413 while (s < PL_bufend) {
6419 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
6428 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6433 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
6434 herewas = newSVpvn(s,PL_bufend-s);
6436 s--, herewas = newSVpvn(s,d-s);
6437 s += SvCUR(herewas);
6439 tmpstr = NEWSV(87,79);
6440 sv_upgrade(tmpstr, SVt_PVIV);
6445 else if (term == '`') {
6446 op_type = OP_BACKTICK;
6447 SvIVX(tmpstr) = '\\';
6451 PL_multi_start = CopLINE(PL_curcop);
6452 PL_multi_open = PL_multi_close = '<';
6453 term = *PL_tokenbuf;
6454 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
6455 char *bufptr = PL_sublex_info.super_bufptr;
6456 char *bufend = PL_sublex_info.super_bufend;
6457 char *olds = s - SvCUR(herewas);
6458 s = strchr(bufptr, '\n');
6462 while (s < bufend &&
6463 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6465 CopLINE_inc(PL_curcop);
6468 CopLINE_set(PL_curcop, PL_multi_start);
6469 missingterm(PL_tokenbuf);
6471 sv_setpvn(herewas,bufptr,d-bufptr+1);
6472 sv_setpvn(tmpstr,d+1,s-d);
6474 sv_catpvn(herewas,s,bufend-s);
6475 (void)strcpy(bufptr,SvPVX(herewas));
6482 while (s < PL_bufend &&
6483 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6485 CopLINE_inc(PL_curcop);
6487 if (s >= PL_bufend) {
6488 CopLINE_set(PL_curcop, PL_multi_start);
6489 missingterm(PL_tokenbuf);
6491 sv_setpvn(tmpstr,d+1,s-d);
6493 CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
6495 sv_catpvn(herewas,s,PL_bufend-s);
6496 sv_setsv(PL_linestr,herewas);
6497 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
6498 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6499 PL_last_lop = PL_last_uni = Nullch;
6502 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
6503 while (s >= PL_bufend) { /* multiple line string? */
6505 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6506 CopLINE_set(PL_curcop, PL_multi_start);
6507 missingterm(PL_tokenbuf);
6509 CopLINE_inc(PL_curcop);
6510 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6511 PL_last_lop = PL_last_uni = Nullch;
6512 #ifndef PERL_STRICT_CR
6513 if (PL_bufend - PL_linestart >= 2) {
6514 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
6515 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
6517 PL_bufend[-2] = '\n';
6519 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6521 else if (PL_bufend[-1] == '\r')
6522 PL_bufend[-1] = '\n';
6524 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
6525 PL_bufend[-1] = '\n';
6527 if (PERLDB_LINE && PL_curstash != PL_debstash) {
6528 SV *sv = NEWSV(88,0);
6530 sv_upgrade(sv, SVt_PVMG);
6531 sv_setsv(sv,PL_linestr);
6532 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop),sv);
6534 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
6537 sv_catsv(PL_linestr,herewas);
6538 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6542 sv_catsv(tmpstr,PL_linestr);
6547 PL_multi_end = CopLINE(PL_curcop);
6548 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
6549 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
6550 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
6552 SvREFCNT_dec(herewas);
6553 if (UTF && !IN_BYTES && is_utf8_string((U8*)SvPVX(tmpstr), SvCUR(tmpstr)))
6555 PL_lex_stuff = tmpstr;
6556 yylval.ival = op_type;
6561 takes: current position in input buffer
6562 returns: new position in input buffer
6563 side-effects: yylval and lex_op are set.
6568 <FH> read from filehandle
6569 <pkg::FH> read from package qualified filehandle
6570 <pkg'FH> read from package qualified filehandle
6571 <$fh> read from filehandle in $fh
6577 S_scan_inputsymbol(pTHX_ char *start)
6579 register char *s = start; /* current position in buffer */
6585 d = PL_tokenbuf; /* start of temp holding space */
6586 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
6587 end = strchr(s, '\n');
6590 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
6592 /* die if we didn't have space for the contents of the <>,
6593 or if it didn't end, or if we see a newline
6596 if (len >= sizeof PL_tokenbuf)
6597 Perl_croak(aTHX_ "Excessively long <> operator");
6599 Perl_croak(aTHX_ "Unterminated <> operator");
6604 Remember, only scalar variables are interpreted as filehandles by
6605 this code. Anything more complex (e.g., <$fh{$num}>) will be
6606 treated as a glob() call.
6607 This code makes use of the fact that except for the $ at the front,
6608 a scalar variable and a filehandle look the same.
6610 if (*d == '$' && d[1]) d++;
6612 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
6613 while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
6616 /* If we've tried to read what we allow filehandles to look like, and
6617 there's still text left, then it must be a glob() and not a getline.
6618 Use scan_str to pull out the stuff between the <> and treat it
6619 as nothing more than a string.
6622 if (d - PL_tokenbuf != len) {
6623 yylval.ival = OP_GLOB;
6625 s = scan_str(start,FALSE,FALSE);
6627 Perl_croak(aTHX_ "Glob not terminated");
6631 /* we're in a filehandle read situation */
6634 /* turn <> into <ARGV> */
6636 (void)strcpy(d,"ARGV");
6638 /* if <$fh>, create the ops to turn the variable into a
6644 /* try to find it in the pad for this block, otherwise find
6645 add symbol table ops
6647 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
6648 SV *namesv = AvARRAY(PL_comppad_name)[tmp];
6649 if (SvFLAGS(namesv) & SVpad_OUR) {
6650 SV *sym = sv_2mortal(newSVpv(HvNAME(GvSTASH(namesv)),0));
6651 sv_catpvn(sym, "::", 2);
6657 OP *o = newOP(OP_PADSV, 0);
6659 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, o);
6668 ? (GV_ADDMULTI | GV_ADDINEVAL)
6671 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
6672 newUNOP(OP_RV2SV, 0,
6673 newGVOP(OP_GV, 0, gv)));
6675 PL_lex_op->op_flags |= OPf_SPECIAL;
6676 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
6677 yylval.ival = OP_NULL;
6680 /* If it's none of the above, it must be a literal filehandle
6681 (<Foo::BAR> or <FOO>) so build a simple readline OP */
6683 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
6684 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
6685 yylval.ival = OP_NULL;
6694 takes: start position in buffer
6695 keep_quoted preserve \ on the embedded delimiter(s)
6696 keep_delims preserve the delimiters around the string
6697 returns: position to continue reading from buffer
6698 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
6699 updates the read buffer.
6701 This subroutine pulls a string out of the input. It is called for:
6702 q single quotes q(literal text)
6703 ' single quotes 'literal text'
6704 qq double quotes qq(interpolate $here please)
6705 " double quotes "interpolate $here please"
6706 qx backticks qx(/bin/ls -l)
6707 ` backticks `/bin/ls -l`
6708 qw quote words @EXPORT_OK = qw( func() $spam )
6709 m// regexp match m/this/
6710 s/// regexp substitute s/this/that/
6711 tr/// string transliterate tr/this/that/
6712 y/// string transliterate y/this/that/
6713 ($*@) sub prototypes sub foo ($)
6714 (stuff) sub attr parameters sub foo : attr(stuff)
6715 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
6717 In most of these cases (all but <>, patterns and transliterate)
6718 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
6719 calls scan_str(). s/// makes yylex() call scan_subst() which calls
6720 scan_str(). tr/// and y/// make yylex() call scan_trans() which
6723 It skips whitespace before the string starts, and treats the first
6724 character as the delimiter. If the delimiter is one of ([{< then
6725 the corresponding "close" character )]}> is used as the closing
6726 delimiter. It allows quoting of delimiters, and if the string has
6727 balanced delimiters ([{<>}]) it allows nesting.
6729 On success, the SV with the resulting string is put into lex_stuff or,
6730 if that is already non-NULL, into lex_repl. The second case occurs only
6731 when parsing the RHS of the special constructs s/// and tr/// (y///).
6732 For convenience, the terminating delimiter character is stuffed into
6737 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
6739 SV *sv; /* scalar value: string */
6740 char *tmps; /* temp string, used for delimiter matching */
6741 register char *s = start; /* current position in the buffer */
6742 register char term; /* terminating character */
6743 register char *to; /* current position in the sv's data */
6744 I32 brackets = 1; /* bracket nesting level */
6745 bool has_utf8 = FALSE; /* is there any utf8 content? */
6747 /* skip space before the delimiter */
6751 /* mark where we are, in case we need to report errors */
6754 /* after skipping whitespace, the next character is the terminator */
6756 if (!UTF8_IS_INVARIANT((U8)term) && UTF)
6759 /* mark where we are */
6760 PL_multi_start = CopLINE(PL_curcop);
6761 PL_multi_open = term;
6763 /* find corresponding closing delimiter */
6764 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
6766 PL_multi_close = term;
6768 /* create a new SV to hold the contents. 87 is leak category, I'm
6769 assuming. 79 is the SV's initial length. What a random number. */
6771 sv_upgrade(sv, SVt_PVIV);
6773 (void)SvPOK_only(sv); /* validate pointer */
6775 /* move past delimiter and try to read a complete string */
6777 sv_catpvn(sv, s, 1);
6780 /* extend sv if need be */
6781 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
6782 /* set 'to' to the next character in the sv's string */
6783 to = SvPVX(sv)+SvCUR(sv);
6785 /* if open delimiter is the close delimiter read unbridle */
6786 if (PL_multi_open == PL_multi_close) {
6787 for (; s < PL_bufend; s++,to++) {
6788 /* embedded newlines increment the current line number */
6789 if (*s == '\n' && !PL_rsfp)
6790 CopLINE_inc(PL_curcop);
6791 /* handle quoted delimiters */
6792 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
6793 if (!keep_quoted && s[1] == term)
6795 /* any other quotes are simply copied straight through */
6799 /* terminate when run out of buffer (the for() condition), or
6800 have found the terminator */
6801 else if (*s == term)
6803 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
6809 /* if the terminator isn't the same as the start character (e.g.,
6810 matched brackets), we have to allow more in the quoting, and
6811 be prepared for nested brackets.
6814 /* read until we run out of string, or we find the terminator */
6815 for (; s < PL_bufend; s++,to++) {
6816 /* embedded newlines increment the line count */
6817 if (*s == '\n' && !PL_rsfp)
6818 CopLINE_inc(PL_curcop);
6819 /* backslashes can escape the open or closing characters */
6820 if (*s == '\\' && s+1 < PL_bufend) {
6822 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
6827 /* allow nested opens and closes */
6828 else if (*s == PL_multi_close && --brackets <= 0)
6830 else if (*s == PL_multi_open)
6832 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
6837 /* terminate the copied string and update the sv's end-of-string */
6839 SvCUR_set(sv, to - SvPVX(sv));
6842 * this next chunk reads more into the buffer if we're not done yet
6846 break; /* handle case where we are done yet :-) */
6848 #ifndef PERL_STRICT_CR
6849 if (to - SvPVX(sv) >= 2) {
6850 if ((to[-2] == '\r' && to[-1] == '\n') ||
6851 (to[-2] == '\n' && to[-1] == '\r'))
6855 SvCUR_set(sv, to - SvPVX(sv));
6857 else if (to[-1] == '\r')
6860 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
6864 /* if we're out of file, or a read fails, bail and reset the current
6865 line marker so we can report where the unterminated string began
6868 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6870 CopLINE_set(PL_curcop, PL_multi_start);
6873 /* we read a line, so increment our line counter */
6874 CopLINE_inc(PL_curcop);
6876 /* update debugger info */
6877 if (PERLDB_LINE && PL_curstash != PL_debstash) {
6878 SV *sv = NEWSV(88,0);
6880 sv_upgrade(sv, SVt_PVMG);
6881 sv_setsv(sv,PL_linestr);
6882 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop), sv);
6885 /* having changed the buffer, we must update PL_bufend */
6886 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6887 PL_last_lop = PL_last_uni = Nullch;
6890 /* at this point, we have successfully read the delimited string */
6893 sv_catpvn(sv, s, 1);
6896 PL_multi_end = CopLINE(PL_curcop);
6899 /* if we allocated too much space, give some back */
6900 if (SvCUR(sv) + 5 < SvLEN(sv)) {
6901 SvLEN_set(sv, SvCUR(sv) + 1);
6902 Renew(SvPVX(sv), SvLEN(sv), char);
6905 /* decide whether this is the first or second quoted string we've read
6918 takes: pointer to position in buffer
6919 returns: pointer to new position in buffer
6920 side-effects: builds ops for the constant in yylval.op
6922 Read a number in any of the formats that Perl accepts:
6924 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
6925 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
6928 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
6930 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
6933 If it reads a number without a decimal point or an exponent, it will
6934 try converting the number to an integer and see if it can do so
6935 without loss of precision.
6939 Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp)
6941 register char *s = start; /* current position in buffer */
6942 register char *d; /* destination in temp buffer */
6943 register char *e; /* end of temp buffer */
6944 NV nv; /* number read, as a double */
6945 SV *sv = Nullsv; /* place to put the converted number */
6946 bool floatit; /* boolean: int or float? */
6947 char *lastub = 0; /* position of last underbar */
6948 static char number_too_long[] = "Number too long";
6950 /* We use the first character to decide what type of number this is */
6954 Perl_croak(aTHX_ "panic: scan_num");
6956 /* if it starts with a 0, it could be an octal number, a decimal in
6957 0.13 disguise, or a hexadecimal number, or a binary number. */
6961 u holds the "number so far"
6962 shift the power of 2 of the base
6963 (hex == 4, octal == 3, binary == 1)
6964 overflowed was the number more than we can hold?
6966 Shift is used when we add a digit. It also serves as an "are
6967 we in octal/hex/binary?" indicator to disallow hex characters
6973 bool overflowed = FALSE;
6974 static NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
6975 static char* bases[5] = { "", "binary", "", "octal",
6977 static char* Bases[5] = { "", "Binary", "", "Octal",
6979 static char *maxima[5] = { "",
6980 "0b11111111111111111111111111111111",
6984 char *base, *Base, *max;
6990 } else if (s[1] == 'b') {
6994 /* check for a decimal in disguise */
6995 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
6997 /* so it must be octal */
7004 if (ckWARN(WARN_SYNTAX))
7005 Perl_warner(aTHX_ WARN_SYNTAX,
7006 "Misplaced _ in number");
7010 base = bases[shift];
7011 Base = Bases[shift];
7012 max = maxima[shift];
7014 /* read the rest of the number */
7016 /* x is used in the overflow test,
7017 b is the digit we're adding on. */
7022 /* if we don't mention it, we're done */
7026 /* _ are ignored -- but warned about if consecutive */
7028 if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
7029 Perl_warner(aTHX_ WARN_SYNTAX,
7030 "Misplaced _ in number");
7034 /* 8 and 9 are not octal */
7037 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
7041 case '2': case '3': case '4':
7042 case '5': case '6': case '7':
7044 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
7048 b = *s++ & 15; /* ASCII digit -> value of digit */
7052 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
7053 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
7054 /* make sure they said 0x */
7059 /* Prepare to put the digit we have onto the end
7060 of the number so far. We check for overflows.
7065 x = u << shift; /* make room for the digit */
7067 if ((x >> shift) != u
7068 && !(PL_hints & HINT_NEW_BINARY)) {
7071 if (ckWARN_d(WARN_OVERFLOW))
7072 Perl_warner(aTHX_ WARN_OVERFLOW,
7073 "Integer overflow in %s number",
7076 u = x | b; /* add the digit to the end */
7079 n *= nvshift[shift];
7080 /* If an NV has not enough bits in its
7081 * mantissa to represent an UV this summing of
7082 * small low-order numbers is a waste of time
7083 * (because the NV cannot preserve the
7084 * low-order bits anyway): we could just
7085 * remember when did we overflow and in the
7086 * end just multiply n by the right
7094 /* if we get here, we had success: make a scalar value from
7099 /* final misplaced underbar check */
7101 if (ckWARN(WARN_SYNTAX))
7102 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
7107 if (ckWARN(WARN_PORTABLE) && n > 4294967295.0)
7108 Perl_warner(aTHX_ WARN_PORTABLE,
7109 "%s number > %s non-portable",
7115 if (ckWARN(WARN_PORTABLE) && u > 0xffffffff)
7116 Perl_warner(aTHX_ WARN_PORTABLE,
7117 "%s number > %s non-portable",
7122 if (PL_hints & HINT_NEW_BINARY)
7123 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
7128 handle decimal numbers.
7129 we're also sent here when we read a 0 as the first digit
7131 case '1': case '2': case '3': case '4': case '5':
7132 case '6': case '7': case '8': case '9': case '.':
7135 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
7138 /* read next group of digits and _ and copy into d */
7139 while (isDIGIT(*s) || *s == '_') {
7140 /* skip underscores, checking for misplaced ones
7144 if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
7145 Perl_warner(aTHX_ WARN_SYNTAX,
7146 "Misplaced _ in number");
7150 /* check for end of fixed-length buffer */
7152 Perl_croak(aTHX_ number_too_long);
7153 /* if we're ok, copy the character */
7158 /* final misplaced underbar check */
7159 if (lastub && s == lastub + 1) {
7160 if (ckWARN(WARN_SYNTAX))
7161 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
7164 /* read a decimal portion if there is one. avoid
7165 3..5 being interpreted as the number 3. followed
7168 if (*s == '.' && s[1] != '.') {
7173 if (ckWARN(WARN_SYNTAX))
7174 Perl_warner(aTHX_ WARN_SYNTAX,
7175 "Misplaced _ in number");
7179 /* copy, ignoring underbars, until we run out of digits.
7181 for (; isDIGIT(*s) || *s == '_'; s++) {
7182 /* fixed length buffer check */
7184 Perl_croak(aTHX_ number_too_long);
7186 if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
7187 Perl_warner(aTHX_ WARN_SYNTAX,
7188 "Misplaced _ in number");
7194 /* fractional part ending in underbar? */
7196 if (ckWARN(WARN_SYNTAX))
7197 Perl_warner(aTHX_ WARN_SYNTAX,
7198 "Misplaced _ in number");
7200 if (*s == '.' && isDIGIT(s[1])) {
7201 /* oops, it's really a v-string, but without the "v" */
7207 /* read exponent part, if present */
7208 if (*s && strchr("eE",*s) && strchr("+-0123456789_", s[1])) {
7212 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
7213 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
7215 /* stray preinitial _ */
7217 if (ckWARN(WARN_SYNTAX))
7218 Perl_warner(aTHX_ WARN_SYNTAX,
7219 "Misplaced _ in number");
7223 /* allow positive or negative exponent */
7224 if (*s == '+' || *s == '-')
7227 /* stray initial _ */
7229 if (ckWARN(WARN_SYNTAX))
7230 Perl_warner(aTHX_ WARN_SYNTAX,
7231 "Misplaced _ in number");
7235 /* read digits of exponent */
7236 while (isDIGIT(*s) || *s == '_') {
7239 Perl_croak(aTHX_ number_too_long);
7243 if (ckWARN(WARN_SYNTAX) &&
7244 ((lastub && s == lastub + 1) ||
7245 (!isDIGIT(s[1]) && s[1] != '_')))
7246 Perl_warner(aTHX_ WARN_SYNTAX,
7247 "Misplaced _ in number");
7254 /* make an sv from the string */
7258 We try to do an integer conversion first if no characters
7259 indicating "float" have been found.
7264 int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
7266 if (flags == IS_NUMBER_IN_UV) {
7268 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
7271 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
7272 if (uv <= (UV) IV_MIN)
7273 sv_setiv(sv, -(IV)uv);
7280 /* terminate the string */
7282 nv = Atof(PL_tokenbuf);
7286 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
7287 (PL_hints & HINT_NEW_INTEGER) )
7288 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
7289 (floatit ? "float" : "integer"),
7293 /* if it starts with a v, it could be a v-string */
7299 while (isDIGIT(*pos) || *pos == '_')
7301 if (!isALPHA(*pos)) {
7303 U8 tmpbuf[UTF8_MAXLEN+1];
7305 s++; /* get past 'v' */
7308 sv_setpvn(sv, "", 0);
7311 if (*s == '0' && isDIGIT(s[1]))
7312 yyerror("Octal number in vector unsupported");
7315 /* this is atoi() that tolerates underscores */
7318 while (--end >= s) {
7323 rev += (*end - '0') * mult;
7325 if (orev > rev && ckWARN_d(WARN_OVERFLOW))
7326 Perl_warner(aTHX_ WARN_OVERFLOW,
7327 "Integer overflow in decimal number");
7330 /* Append native character for the rev point */
7331 tmpend = uvchr_to_utf8(tmpbuf, rev);
7332 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
7333 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
7335 if (*pos == '.' && isDIGIT(pos[1]))
7341 while (isDIGIT(*pos) || *pos == '_')
7351 /* make the op for the constant and return */
7354 lvalp->opval = newSVOP(OP_CONST, 0, sv);
7356 lvalp->opval = Nullop;
7362 S_scan_formline(pTHX_ register char *s)
7366 SV *stuff = newSVpvn("",0);
7367 bool needargs = FALSE;
7370 if (*s == '.' || *s == /*{*/'}') {
7372 #ifdef PERL_STRICT_CR
7373 for (t = s+1;SPACE_OR_TAB(*t); t++) ;
7375 for (t = s+1;SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
7377 if (*t == '\n' || t == PL_bufend)
7380 if (PL_in_eval && !PL_rsfp) {
7381 eol = strchr(s,'\n');
7386 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7388 for (t = s; t < eol; t++) {
7389 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
7391 goto enough; /* ~~ must be first line in formline */
7393 if (*t == '@' || *t == '^')
7397 sv_catpvn(stuff, s, eol-s);
7398 #ifndef PERL_STRICT_CR
7399 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
7400 char *end = SvPVX(stuff) + SvCUR(stuff);
7412 s = filter_gets(PL_linestr, PL_rsfp, 0);
7413 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
7414 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
7415 PL_last_lop = PL_last_uni = Nullch;
7418 yyerror("Format not terminated");
7428 PL_lex_state = LEX_NORMAL;
7429 PL_nextval[PL_nexttoke].ival = 0;
7433 PL_lex_state = LEX_FORMLINE;
7434 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
7436 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
7440 SvREFCNT_dec(stuff);
7441 PL_lex_formbrack = 0;
7452 PL_cshlen = strlen(PL_cshname);
7457 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
7459 I32 oldsavestack_ix = PL_savestack_ix;
7460 CV* outsidecv = PL_compcv;
7464 assert(SvTYPE(PL_compcv) == SVt_PVCV);
7466 SAVEI32(PL_subline);
7467 save_item(PL_subname);
7470 SAVESPTR(PL_comppad_name);
7471 SAVESPTR(PL_compcv);
7472 SAVEI32(PL_comppad_name_fill);
7473 SAVEI32(PL_min_intro_pending);
7474 SAVEI32(PL_max_intro_pending);
7475 SAVEI32(PL_pad_reset_pending);
7477 PL_compcv = (CV*)NEWSV(1104,0);
7478 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
7479 CvFLAGS(PL_compcv) |= flags;
7481 PL_comppad = newAV();
7482 av_push(PL_comppad, Nullsv);
7483 PL_curpad = AvARRAY(PL_comppad);
7484 PL_comppad_name = newAV();
7485 PL_comppad_name_fill = 0;
7486 PL_min_intro_pending = 0;
7488 PL_subline = CopLINE(PL_curcop);
7489 #ifdef USE_5005THREADS
7490 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
7491 PL_curpad[0] = (SV*)newAV();
7492 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
7493 #endif /* USE_5005THREADS */
7495 comppadlist = newAV();
7496 AvREAL_off(comppadlist);
7497 av_store(comppadlist, 0, (SV*)PL_comppad_name);
7498 av_store(comppadlist, 1, (SV*)PL_comppad);
7500 CvPADLIST(PL_compcv) = comppadlist;
7501 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
7502 #ifdef USE_5005THREADS
7503 CvOWNER(PL_compcv) = 0;
7504 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
7505 MUTEX_INIT(CvMUTEXP(PL_compcv));
7506 #endif /* USE_5005THREADS */
7508 return oldsavestack_ix;
7512 #pragma segment Perl_yylex
7515 Perl_yywarn(pTHX_ char *s)
7517 PL_in_eval |= EVAL_WARNONLY;
7519 PL_in_eval &= ~EVAL_WARNONLY;
7524 Perl_yyerror(pTHX_ char *s)
7527 char *context = NULL;
7531 if (!yychar || (yychar == ';' && !PL_rsfp))
7533 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
7534 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
7535 while (isSPACE(*PL_oldoldbufptr))
7537 context = PL_oldoldbufptr;
7538 contlen = PL_bufptr - PL_oldoldbufptr;
7540 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
7541 PL_oldbufptr != PL_bufptr) {
7542 while (isSPACE(*PL_oldbufptr))
7544 context = PL_oldbufptr;
7545 contlen = PL_bufptr - PL_oldbufptr;
7547 else if (yychar > 255)
7548 where = "next token ???";
7549 #ifdef USE_PURE_BISON
7550 /* GNU Bison sets the value -2 */
7551 else if (yychar == -2) {
7553 else if ((yychar & 127) == 127) {
7555 if (PL_lex_state == LEX_NORMAL ||
7556 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
7557 where = "at end of line";
7558 else if (PL_lex_inpat)
7559 where = "within pattern";
7561 where = "within string";
7564 SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
7566 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
7567 else if (isPRINT_LC(yychar))
7568 Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
7570 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
7571 where = SvPVX(where_sv);
7573 msg = sv_2mortal(newSVpv(s, 0));
7574 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
7575 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
7577 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
7579 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
7580 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
7581 Perl_sv_catpvf(aTHX_ msg,
7582 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
7583 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
7586 if (PL_in_eval & EVAL_WARNONLY)
7587 Perl_warn(aTHX_ "%"SVf, msg);
7590 if (PL_error_count >= 10) {
7591 if (PL_in_eval && SvCUR(ERRSV))
7592 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
7593 ERRSV, CopFILE(PL_curcop));
7595 Perl_croak(aTHX_ "%s has too many errors.\n",
7596 CopFILE(PL_curcop));
7599 PL_in_my_stash = Nullhv;
7603 #pragma segment Main
7607 S_swallow_bom(pTHX_ U8 *s)
7610 slen = SvCUR(PL_linestr);
7614 /* UTF-16 little-endian */
7615 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
7616 Perl_croak(aTHX_ "Unsupported script encoding");
7617 #ifndef PERL_NO_UTF16_FILTER
7618 DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-LE script encoding\n"));
7620 if (PL_bufend > (char*)s) {
7624 filter_add(utf16rev_textfilter, NULL);
7625 New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
7626 PL_bufend = (char*)utf16_to_utf8_reversed(s, news,
7627 PL_bufend - (char*)s - 1,
7629 Copy(news, s, newlen, U8);
7630 SvCUR_set(PL_linestr, newlen);
7631 PL_bufend = SvPVX(PL_linestr) + newlen;
7632 news[newlen++] = '\0';
7636 Perl_croak(aTHX_ "Unsupported script encoding");
7641 if (s[1] == 0xFF) { /* UTF-16 big-endian */
7642 #ifndef PERL_NO_UTF16_FILTER
7643 DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding\n"));
7645 if (PL_bufend > (char *)s) {
7649 filter_add(utf16_textfilter, NULL);
7650 New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
7651 PL_bufend = (char*)utf16_to_utf8(s, news,
7652 PL_bufend - (char*)s,
7654 Copy(news, s, newlen, U8);
7655 SvCUR_set(PL_linestr, newlen);
7656 PL_bufend = SvPVX(PL_linestr) + newlen;
7657 news[newlen++] = '\0';
7661 Perl_croak(aTHX_ "Unsupported script encoding");
7666 if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
7667 DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-8 script encoding\n"));
7672 if (slen > 3 && s[1] == 0 && /* UTF-32 big-endian */
7673 s[2] == 0xFE && s[3] == 0xFF)
7675 Perl_croak(aTHX_ "Unsupported script encoding");
7683 * Restore a source filter.
7687 restore_rsfp(pTHX_ void *f)
7689 PerlIO *fp = (PerlIO*)f;
7691 if (PL_rsfp == PerlIO_stdin())
7692 PerlIO_clearerr(PL_rsfp);
7693 else if (PL_rsfp && (PL_rsfp != fp))
7694 PerlIO_close(PL_rsfp);
7698 #ifndef PERL_NO_UTF16_FILTER
7700 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
7702 I32 count = FILTER_READ(idx+1, sv, maxlen);
7707 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
7708 if (!*SvPV_nolen(sv))
7709 /* Game over, but don't feed an odd-length string to utf16_to_utf8 */
7712 tend = utf16_to_utf8((U8*)SvPVX(sv), tmps, SvCUR(sv), &newlen);
7713 sv_usepvn(sv, (char*)tmps, tend - tmps);
7719 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
7721 I32 count = FILTER_READ(idx+1, sv, maxlen);
7726 if (!*SvPV_nolen(sv))
7727 /* Game over, but don't feed an odd-length string to utf16_to_utf8 */
7730 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
7731 tend = utf16_to_utf8_reversed((U8*)SvPVX(sv), tmps, SvCUR(sv), &newlen);
7732 sv_usepvn(sv, (char*)tmps, tend - tmps);