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;
449 PL_rs = newSVpvn("\n", 1);
455 * Finalizer for lexing operations. Must be called when the parser is
456 * done with the lexer.
462 PL_doextract = FALSE;
467 * This subroutine has nothing to do with tilting, whether at windmills
468 * or pinball tables. Its name is short for "increment line". It
469 * increments the current line number in CopLINE(PL_curcop) and checks
470 * to see whether the line starts with a comment of the form
471 * # line 500 "foo.pm"
472 * If so, it sets the current line number and file to the values in the comment.
476 S_incline(pTHX_ char *s)
483 CopLINE_inc(PL_curcop);
486 while (SPACE_OR_TAB(*s)) s++;
487 if (strnEQ(s, "line", 4))
491 if (SPACE_OR_TAB(*s))
495 while (SPACE_OR_TAB(*s)) s++;
501 while (SPACE_OR_TAB(*s))
503 if (*s == '"' && (t = strchr(s+1, '"'))) {
508 for (t = s; !isSPACE(*t); t++) ;
511 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
513 if (*e != '\n' && *e != '\0')
514 return; /* false alarm */
520 Safefree(CopFILE(PL_curcop));
522 SvREFCNT_dec(CopFILEGV(PL_curcop));
524 CopFILE_set(PL_curcop, s);
527 CopLINE_set(PL_curcop, atoi(n)-1);
532 * Called to gobble the appropriate amount and type of whitespace.
533 * Skips comments as well.
537 S_skipspace(pTHX_ register char *s)
539 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
540 while (s < PL_bufend && SPACE_OR_TAB(*s))
546 SSize_t oldprevlen, oldoldprevlen;
547 SSize_t oldloplen = 0, oldunilen = 0;
548 while (s < PL_bufend && isSPACE(*s)) {
549 if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
554 if (s < PL_bufend && *s == '#') {
555 while (s < PL_bufend && *s != '\n')
559 if (PL_in_eval && !PL_rsfp) {
566 /* only continue to recharge the buffer if we're at the end
567 * of the buffer, we're not reading from a source filter, and
568 * we're in normal lexing mode
570 if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat ||
571 PL_lex_state == LEX_FORMLINE)
574 /* try to recharge the buffer */
575 if ((s = filter_gets(PL_linestr, PL_rsfp,
576 (prevlen = SvCUR(PL_linestr)))) == Nullch)
578 /* end of file. Add on the -p or -n magic */
579 if (PL_minus_n || PL_minus_p) {
580 sv_setpv(PL_linestr,PL_minus_p ?
581 ";}continue{print or die qq(-p destination: $!\\n)" :
583 sv_catpv(PL_linestr,";}");
584 PL_minus_n = PL_minus_p = 0;
587 sv_setpv(PL_linestr,";");
589 /* reset variables for next time we lex */
590 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
592 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
593 PL_last_lop = PL_last_uni = Nullch;
595 /* Close the filehandle. Could be from -P preprocessor,
596 * STDIN, or a regular file. If we were reading code from
597 * STDIN (because the commandline held no -e or filename)
598 * then we don't close it, we reset it so the code can
599 * read from STDIN too.
602 if (PL_preprocess && !PL_in_eval)
603 (void)PerlProc_pclose(PL_rsfp);
604 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
605 PerlIO_clearerr(PL_rsfp);
607 (void)PerlIO_close(PL_rsfp);
612 /* not at end of file, so we only read another line */
613 /* make corresponding updates to old pointers, for yyerror() */
614 oldprevlen = PL_oldbufptr - PL_bufend;
615 oldoldprevlen = PL_oldoldbufptr - PL_bufend;
617 oldunilen = PL_last_uni - PL_bufend;
619 oldloplen = PL_last_lop - PL_bufend;
620 PL_linestart = PL_bufptr = s + prevlen;
621 PL_bufend = s + SvCUR(PL_linestr);
623 PL_oldbufptr = s + oldprevlen;
624 PL_oldoldbufptr = s + oldoldprevlen;
626 PL_last_uni = s + oldunilen;
628 PL_last_lop = s + oldloplen;
631 /* debugger active and we're not compiling the debugger code,
632 * so store the line into the debugger's array of lines
634 if (PERLDB_LINE && PL_curstash != PL_debstash) {
635 SV *sv = NEWSV(85,0);
637 sv_upgrade(sv, SVt_PVMG);
638 sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
639 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
646 * Check the unary operators to ensure there's no ambiguity in how they're
647 * used. An ambiguous piece of code would be:
649 * This doesn't mean rand() + 5. Because rand() is a unary operator,
650 * the +5 is its argument.
659 if (PL_oldoldbufptr != PL_last_uni)
661 while (isSPACE(*PL_last_uni))
663 for (s = PL_last_uni; isALNUM_lazy_if(s,UTF) || *s == '-'; s++) ;
664 if ((t = strchr(s, '(')) && t < PL_bufptr)
666 if (ckWARN_d(WARN_AMBIGUOUS)){
669 Perl_warner(aTHX_ WARN_AMBIGUOUS,
670 "Warning: Use of \"%s\" without parens is ambiguous",
676 /* workaround to replace the UNI() macro with a function. Only the
677 * hints/uts.sh file mentions this. Other comments elsewhere in the
678 * source indicate Microport Unix might need it too.
684 #define UNI(f) return uni(f,s)
687 S_uni(pTHX_ I32 f, char *s)
692 PL_last_uni = PL_oldbufptr;
703 #endif /* CRIPPLED_CC */
706 * LOP : macro to build a list operator. Its behaviour has been replaced
707 * with a subroutine, S_lop() for which LOP is just another name.
710 #define LOP(f,x) return lop(f,x,s)
714 * Build a list operator (or something that might be one). The rules:
715 * - if we have a next token, then it's a list operator [why?]
716 * - if the next thing is an opening paren, then it's a function
717 * - else it's a list operator
721 S_lop(pTHX_ I32 f, int x, char *s)
728 PL_last_lop = PL_oldbufptr;
743 * When the lexer realizes it knows the next token (for instance,
744 * it is reordering tokens for the parser) then it can call S_force_next
745 * to know what token to return the next time the lexer is called. Caller
746 * will need to set PL_nextval[], and possibly PL_expect to ensure the lexer
747 * handles the token correctly.
751 S_force_next(pTHX_ I32 type)
753 PL_nexttype[PL_nexttoke] = type;
755 if (PL_lex_state != LEX_KNOWNEXT) {
756 PL_lex_defer = PL_lex_state;
757 PL_lex_expect = PL_expect;
758 PL_lex_state = LEX_KNOWNEXT;
764 * When the lexer knows the next thing is a word (for instance, it has
765 * just seen -> and it knows that the next char is a word char, then
766 * it calls S_force_word to stick the next word into the PL_next lookahead.
769 * char *start : buffer position (must be within PL_linestr)
770 * int token : PL_next will be this type of bare word (e.g., METHOD,WORD)
771 * int check_keyword : if true, Perl checks to make sure the word isn't
772 * a keyword (do this if the word is a label, e.g. goto FOO)
773 * int allow_pack : if true, : characters will also be allowed (require,
775 * int allow_initial_tick : used by the "sub" lexer only.
779 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
784 start = skipspace(start);
786 if (isIDFIRST_lazy_if(s,UTF) ||
787 (allow_pack && *s == ':') ||
788 (allow_initial_tick && *s == '\'') )
790 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
791 if (check_keyword && keyword(PL_tokenbuf, len))
793 if (token == METHOD) {
798 PL_expect = XOPERATOR;
801 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(PL_tokenbuf,0));
802 PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
810 * Called when the lexer wants $foo *foo &foo etc, but the program
811 * text only contains the "foo" portion. The first argument is a pointer
812 * to the "foo", and the second argument is the type symbol to prefix.
813 * Forces the next token to be a "WORD".
814 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
818 S_force_ident(pTHX_ register char *s, int kind)
821 OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
822 PL_nextval[PL_nexttoke].opval = o;
825 o->op_private = OPpCONST_ENTERED;
826 /* XXX see note in pp_entereval() for why we forgo typo
827 warnings if the symbol must be introduced in an eval.
829 gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
830 kind == '$' ? SVt_PV :
831 kind == '@' ? SVt_PVAV :
832 kind == '%' ? SVt_PVHV :
840 Perl_str_to_version(pTHX_ SV *sv)
845 char *start = SvPVx(sv,len);
846 bool utf = SvUTF8(sv) ? TRUE : FALSE;
847 char *end = start + len;
848 while (start < end) {
852 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
857 retval += ((NV)n)/nshift;
866 * Forces the next token to be a version number.
870 S_force_version(pTHX_ char *s)
872 OP *version = Nullop;
881 for (; isDIGIT(*d) || *d == '_' || *d == '.'; d++);
882 if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
884 s = scan_num(s, &yylval);
885 version = yylval.opval;
886 ver = cSVOPx(version)->op_sv;
887 if (SvPOK(ver) && !SvNIOK(ver)) {
888 (void)SvUPGRADE(ver, SVt_PVNV);
889 SvNVX(ver) = str_to_version(ver);
890 SvNOK_on(ver); /* hint that it is a version */
895 /* NOTE: The parser sees the package name and the VERSION swapped */
896 PL_nextval[PL_nexttoke].opval = version;
904 * Tokenize a quoted string passed in as an SV. It finds the next
905 * chunk, up to end of string or a backslash. It may make a new
906 * SV containing that chunk (if HINT_NEW_STRING is on). It also
911 S_tokeq(pTHX_ SV *sv)
922 s = SvPV_force(sv, len);
923 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
926 while (s < send && *s != '\\')
931 if ( PL_hints & HINT_NEW_STRING ) {
932 pv = sv_2mortal(newSVpvn(SvPVX(pv), len));
938 if (s + 1 < send && (s[1] == '\\'))
939 s++; /* all that, just for this */
944 SvCUR_set(sv, d - SvPVX(sv));
946 if ( PL_hints & HINT_NEW_STRING )
947 return new_constant(NULL, 0, "q", sv, pv, "q");
952 * Now come three functions related to double-quote context,
953 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
954 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
955 * interact with PL_lex_state, and create fake ( ... ) argument lists
956 * to handle functions and concatenation.
957 * They assume that whoever calls them will be setting up a fake
958 * join call, because each subthing puts a ',' after it. This lets
961 * join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
963 * (I'm not sure whether the spurious commas at the end of lcfirst's
964 * arguments and join's arguments are created or not).
969 * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST).
971 * Pattern matching will set PL_lex_op to the pattern-matching op to
972 * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise).
974 * OP_CONST and OP_READLINE are easy--just make the new op and return.
976 * Everything else becomes a FUNC.
978 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
979 * had an OP_CONST or OP_READLINE). This just sets us up for a
980 * call to S_sublex_push().
986 register I32 op_type = yylval.ival;
988 if (op_type == OP_NULL) {
989 yylval.opval = PL_lex_op;
993 if (op_type == OP_CONST || op_type == OP_READLINE) {
994 SV *sv = tokeq(PL_lex_stuff);
996 if (SvTYPE(sv) == SVt_PVIV) {
997 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
1003 nsv = newSVpvn(p, len);
1009 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
1010 PL_lex_stuff = Nullsv;
1014 PL_sublex_info.super_state = PL_lex_state;
1015 PL_sublex_info.sub_inwhat = op_type;
1016 PL_sublex_info.sub_op = PL_lex_op;
1017 PL_lex_state = LEX_INTERPPUSH;
1021 yylval.opval = PL_lex_op;
1031 * Create a new scope to save the lexing state. The scope will be
1032 * ended in S_sublex_done. Returns a '(', starting the function arguments
1033 * to the uc, lc, etc. found before.
1034 * Sets PL_lex_state to LEX_INTERPCONCAT.
1042 PL_lex_state = PL_sublex_info.super_state;
1043 SAVEI32(PL_lex_dojoin);
1044 SAVEI32(PL_lex_brackets);
1045 SAVEI32(PL_lex_casemods);
1046 SAVEI32(PL_lex_starts);
1047 SAVEI32(PL_lex_state);
1048 SAVEVPTR(PL_lex_inpat);
1049 SAVEI32(PL_lex_inwhat);
1050 SAVECOPLINE(PL_curcop);
1051 SAVEPPTR(PL_bufptr);
1052 SAVEPPTR(PL_bufend);
1053 SAVEPPTR(PL_oldbufptr);
1054 SAVEPPTR(PL_oldoldbufptr);
1055 SAVEPPTR(PL_last_lop);
1056 SAVEPPTR(PL_last_uni);
1057 SAVEPPTR(PL_linestart);
1058 SAVESPTR(PL_linestr);
1059 SAVEPPTR(PL_lex_brackstack);
1060 SAVEPPTR(PL_lex_casestack);
1062 PL_linestr = PL_lex_stuff;
1063 PL_lex_stuff = Nullsv;
1065 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
1066 = SvPVX(PL_linestr);
1067 PL_bufend += SvCUR(PL_linestr);
1068 PL_last_lop = PL_last_uni = Nullch;
1069 SAVEFREESV(PL_linestr);
1071 PL_lex_dojoin = FALSE;
1072 PL_lex_brackets = 0;
1073 New(899, PL_lex_brackstack, 120, char);
1074 New(899, PL_lex_casestack, 12, char);
1075 SAVEFREEPV(PL_lex_brackstack);
1076 SAVEFREEPV(PL_lex_casestack);
1077 PL_lex_casemods = 0;
1078 *PL_lex_casestack = '\0';
1080 PL_lex_state = LEX_INTERPCONCAT;
1081 CopLINE_set(PL_curcop, PL_multi_start);
1083 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1084 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1085 PL_lex_inpat = PL_sublex_info.sub_op;
1087 PL_lex_inpat = Nullop;
1094 * Restores lexer state after a S_sublex_push.
1100 if (!PL_lex_starts++) {
1101 SV *sv = newSVpvn("",0);
1102 if (SvUTF8(PL_linestr))
1104 PL_expect = XOPERATOR;
1105 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1109 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
1110 PL_lex_state = LEX_INTERPCASEMOD;
1114 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1115 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1116 PL_linestr = PL_lex_repl;
1118 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1119 PL_bufend += SvCUR(PL_linestr);
1120 PL_last_lop = PL_last_uni = Nullch;
1121 SAVEFREESV(PL_linestr);
1122 PL_lex_dojoin = FALSE;
1123 PL_lex_brackets = 0;
1124 PL_lex_casemods = 0;
1125 *PL_lex_casestack = '\0';
1127 if (SvEVALED(PL_lex_repl)) {
1128 PL_lex_state = LEX_INTERPNORMAL;
1130 /* we don't clear PL_lex_repl here, so that we can check later
1131 whether this is an evalled subst; that means we rely on the
1132 logic to ensure sublex_done() is called again only via the
1133 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1136 PL_lex_state = LEX_INTERPCONCAT;
1137 PL_lex_repl = Nullsv;
1143 PL_bufend = SvPVX(PL_linestr);
1144 PL_bufend += SvCUR(PL_linestr);
1145 PL_expect = XOPERATOR;
1146 PL_sublex_info.sub_inwhat = 0;
1154 Extracts a pattern, double-quoted string, or transliteration. This
1157 It looks at lex_inwhat and PL_lex_inpat to find out whether it's
1158 processing a pattern (PL_lex_inpat is true), a transliteration
1159 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
1161 Returns a pointer to the character scanned up to. Iff this is
1162 advanced from the start pointer supplied (ie if anything was
1163 successfully parsed), will leave an OP for the substring scanned
1164 in yylval. Caller must intuit reason for not parsing further
1165 by looking at the next characters herself.
1169 double-quoted style: \r and \n
1170 regexp special ones: \D \s
1172 backrefs: \1 (deprecated in substitution replacements)
1173 case and quoting: \U \Q \E
1174 stops on @ and $, but not for $ as tail anchor
1176 In transliterations:
1177 characters are VERY literal, except for - not at the start or end
1178 of the string, which indicates a range. scan_const expands the
1179 range to the full set of intermediate characters.
1181 In double-quoted strings:
1183 double-quoted style: \r and \n
1185 backrefs: \1 (deprecated)
1186 case and quoting: \U \Q \E
1189 scan_const does *not* construct ops to handle interpolated strings.
1190 It stops processing as soon as it finds an embedded $ or @ variable
1191 and leaves it to the caller to work out what's going on.
1193 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
1195 $ in pattern could be $foo or could be tail anchor. Assumption:
1196 it's a tail anchor if $ is the last thing in the string, or if it's
1197 followed by one of ")| \n\t"
1199 \1 (backreferences) are turned into $1
1201 The structure of the code is
1202 while (there's a character to process) {
1203 handle transliteration ranges
1204 skip regexp comments
1205 skip # initiated comments in //x patterns
1206 check for embedded @foo
1207 check for embedded scalars
1209 leave intact backslashes from leave (below)
1210 deprecate \1 in strings and sub replacements
1211 handle string-changing backslashes \l \U \Q \E, etc.
1212 switch (what was escaped) {
1213 handle - in a transliteration (becomes a literal -)
1214 handle \132 octal characters
1215 handle 0x15 hex characters
1216 handle \cV (control V)
1217 handle printf backslashes (\f, \r, \n, etc)
1219 } (end if backslash)
1220 } (end while character to read)
1225 S_scan_const(pTHX_ char *start)
1227 register char *send = PL_bufend; /* end of the constant */
1228 SV *sv = NEWSV(93, send - start); /* sv for the constant */
1229 register char *s = start; /* start of the constant */
1230 register char *d = SvPVX(sv); /* destination for copies */
1231 bool dorange = FALSE; /* are we in a translit range? */
1232 bool didrange = FALSE; /* did we just finish a range? */
1233 I32 has_utf8 = FALSE; /* Output constant is UTF8 */
1234 I32 this_utf8 = UTF; /* The source string is assumed to be UTF8 */
1237 const char *leaveit = /* set of acceptably-backslashed characters */
1239 ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
1242 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1243 /* If we are doing a trans and we know we want UTF8 set expectation */
1244 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
1245 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1249 while (s < send || dorange) {
1250 /* get transliterations out of the way (they're most literal) */
1251 if (PL_lex_inwhat == OP_TRANS) {
1252 /* expand a range A-Z to the full set of characters. AIE! */
1254 I32 i; /* current expanded character */
1255 I32 min; /* first character in range */
1256 I32 max; /* last character in range */
1259 char *c = (char*)utf8_hop((U8*)d, -1);
1263 *c = (char)UTF_TO_NATIVE(0xff);
1264 /* mark the range as done, and continue */
1270 i = d - SvPVX(sv); /* remember current offset */
1271 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
1272 d = SvPVX(sv) + i; /* refresh d after realloc */
1273 d -= 2; /* eat the first char and the - */
1275 min = (U8)*d; /* first char in range */
1276 max = (U8)d[1]; /* last char in range */
1280 "Invalid [] range \"%c-%c\" in transliteration operator",
1281 (char)min, (char)max);
1285 if ((isLOWER(min) && isLOWER(max)) ||
1286 (isUPPER(min) && isUPPER(max))) {
1288 for (i = min; i <= max; i++)
1290 *d++ = NATIVE_TO_NEED(has_utf8,i);
1292 for (i = min; i <= max; i++)
1294 *d++ = NATIVE_TO_NEED(has_utf8,i);
1299 for (i = min; i <= max; i++)
1302 /* mark the range as done, and continue */
1308 /* range begins (ignore - as first or last char) */
1309 else if (*s == '-' && s+1 < send && s != start) {
1311 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
1314 *d++ = (char)UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */
1326 /* if we get here, we're not doing a transliteration */
1328 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
1329 except for the last char, which will be done separately. */
1330 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
1332 while (s < send && *s != ')')
1333 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1335 else if (s[2] == '{' /* This should match regcomp.c */
1336 || ((s[2] == 'p' || s[2] == '?') && s[3] == '{'))
1339 char *regparse = s + (s[2] == '{' ? 3 : 4);
1342 while (count && (c = *regparse)) {
1343 if (c == '\\' && regparse[1])
1351 if (*regparse != ')') {
1352 regparse--; /* Leave one char for continuation. */
1353 yyerror("Sequence (?{...}) not terminated or not {}-balanced");
1355 while (s < regparse)
1356 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1360 /* likewise skip #-initiated comments in //x patterns */
1361 else if (*s == '#' && PL_lex_inpat &&
1362 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
1363 while (s+1 < send && *s != '\n')
1364 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1367 /* check for embedded arrays
1368 (@foo, @:foo, @'foo, @{foo}, @$foo, @+, @-)
1370 else if (*s == '@' && s[1]
1371 && (isALNUM_lazy_if(s+1,UTF) || strchr(":'{$+-", s[1])))
1374 /* check for embedded scalars. only stop if we're sure it's a
1377 else if (*s == '$') {
1378 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
1380 if (s + 1 < send && !strchr("()| \r\n\t", s[1]))
1381 break; /* in regexp, $ might be tail anchor */
1384 /* End of else if chain - OP_TRANS rejoin rest */
1387 if (*s == '\\' && s+1 < send) {
1390 /* some backslashes we leave behind */
1391 if (*leaveit && *s && strchr(leaveit, *s)) {
1392 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
1393 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1397 /* deprecate \1 in strings and substitution replacements */
1398 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1399 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1401 if (ckWARN(WARN_SYNTAX))
1402 Perl_warner(aTHX_ WARN_SYNTAX, "\\%c better written as $%c", *s, *s);
1407 /* string-change backslash escapes */
1408 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1413 /* if we get here, it's either a quoted -, or a digit */
1416 /* quoted - in transliterations */
1418 if (PL_lex_inwhat == OP_TRANS) {
1425 if (ckWARN(WARN_MISC) && isALNUM(*s))
1426 Perl_warner(aTHX_ WARN_MISC,
1427 "Unrecognized escape \\%c passed through",
1429 /* default action is to copy the quoted character */
1430 goto default_action;
1433 /* \132 indicates an octal constant */
1434 case '0': case '1': case '2': case '3':
1435 case '4': case '5': case '6': case '7':
1439 uv = grok_oct(s, &len, &flags, NULL);
1442 goto NUM_ESCAPE_INSERT;
1444 /* \x24 indicates a hex constant */
1448 char* e = strchr(s, '}');
1449 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
1454 yyerror("Missing right brace on \\x{}");
1458 uv = grok_hex(s, &len, &flags, NULL);
1465 uv = grok_hex(s, &len, &flags, NULL);
1471 /* Insert oct or hex escaped character.
1472 * There will always enough room in sv since such
1473 * escapes will be longer than any UTF-8 sequence
1474 * they can end up as. */
1476 /* We need to map to chars to ASCII before doing the tests
1479 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(uv))) {
1480 if (!has_utf8 && uv > 255) {
1481 /* Might need to recode whatever we have
1482 * accumulated so far if it contains any
1485 * (Can't we keep track of that and avoid
1486 * this rescan? --jhi)
1490 for (c = (U8 *) SvPVX(sv); c < (U8 *)d; c++) {
1491 if (!NATIVE_IS_INVARIANT(*c)) {
1496 STRLEN offset = d - SvPVX(sv);
1498 d = SvGROW(sv, SvLEN(sv) + hicount + 1) + offset;
1502 while (src >= (U8 *)SvPVX(sv)) {
1503 if (!NATIVE_IS_INVARIANT(*src)) {
1504 U8 ch = NATIVE_TO_ASCII(*src);
1505 *dst-- = UTF8_EIGHT_BIT_LO(ch);
1506 *dst-- = UTF8_EIGHT_BIT_HI(ch);
1516 if (has_utf8 || uv > 255) {
1517 d = (char*)uvchr_to_utf8((U8*)d, uv);
1519 if (PL_lex_inwhat == OP_TRANS &&
1520 PL_sublex_info.sub_op) {
1521 PL_sublex_info.sub_op->op_private |=
1522 (PL_lex_repl ? OPpTRANS_FROM_UTF
1535 /* \N{latin small letter a} is a named character */
1539 char* e = strchr(s, '}');
1545 yyerror("Missing right brace on \\N{}");
1549 res = newSVpvn(s + 1, e - s - 1);
1550 res = new_constant( Nullch, 0, "charnames",
1551 res, Nullsv, "\\N{...}" );
1553 sv_utf8_upgrade(res);
1554 str = SvPV(res,len);
1555 if (!has_utf8 && SvUTF8(res)) {
1556 char *ostart = SvPVX(sv);
1557 SvCUR_set(sv, d - ostart);
1560 sv_utf8_upgrade(sv);
1561 /* this just broke our allocation above... */
1562 SvGROW(sv, send - start);
1563 d = SvPVX(sv) + SvCUR(sv);
1566 if (len > e - s + 4) {
1567 char *odest = SvPVX(sv);
1569 SvGROW(sv, (SvLEN(sv) + len - (e - s + 4)));
1570 d = SvPVX(sv) + (d - odest);
1572 Copy(str, d, len, char);
1579 yyerror("Missing braces on \\N{}");
1582 /* \c is a control character */
1591 *d++ = NATIVE_TO_NEED(has_utf8,toCTRL(c));
1595 /* printf-style backslashes, formfeeds, newlines, etc */
1597 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
1600 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
1603 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
1606 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
1609 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
1612 *d++ = ASCII_TO_NEED(has_utf8,'\033');
1615 *d++ = ASCII_TO_NEED(has_utf8,'\007');
1621 } /* end if (backslash) */
1624 /* If we started with encoded form, or already know we want it
1625 and then encode the next character */
1626 if ((has_utf8 || this_utf8) && !NATIVE_IS_INVARIANT((U8)(*s))) {
1628 UV uv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
1629 STRLEN need = UNISKIP(NATIVE_TO_UNI(uv));
1632 /* encoded value larger than old, need extra space (NOTE: SvCUR() not set here) */
1633 STRLEN off = d - SvPVX(sv);
1634 d = SvGROW(sv, SvLEN(sv) + (need-len)) + off;
1636 d = (char*)uvchr_to_utf8((U8*)d, uv);
1640 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1642 } /* while loop to process each character */
1644 /* terminate the string and set up the sv */
1646 SvCUR_set(sv, d - SvPVX(sv));
1647 if (SvCUR(sv) >= SvLEN(sv))
1648 Perl_croak(aTHX_ "panic: constant overflowed allocated space");
1653 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1654 PL_sublex_info.sub_op->op_private |=
1655 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1659 /* shrink the sv if we allocated more than we used */
1660 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1661 SvLEN_set(sv, SvCUR(sv) + 1);
1662 Renew(SvPVX(sv), SvLEN(sv), char);
1665 /* return the substring (via yylval) only if we parsed anything */
1666 if (s > PL_bufptr) {
1667 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1668 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1670 ( PL_lex_inwhat == OP_TRANS
1672 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1675 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1682 * Returns TRUE if there's more to the expression (e.g., a subscript),
1685 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
1687 * ->[ and ->{ return TRUE
1688 * { and [ outside a pattern are always subscripts, so return TRUE
1689 * if we're outside a pattern and it's not { or [, then return FALSE
1690 * if we're in a pattern and the first char is a {
1691 * {4,5} (any digits around the comma) returns FALSE
1692 * if we're in a pattern and the first char is a [
1694 * [SOMETHING] has a funky algorithm to decide whether it's a
1695 * character class or not. It has to deal with things like
1696 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
1697 * anything else returns TRUE
1700 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1703 S_intuit_more(pTHX_ register char *s)
1705 if (PL_lex_brackets)
1707 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1709 if (*s != '{' && *s != '[')
1714 /* In a pattern, so maybe we have {n,m}. */
1731 /* On the other hand, maybe we have a character class */
1734 if (*s == ']' || *s == '^')
1737 /* this is terrifying, and it works */
1738 int weight = 2; /* let's weigh the evidence */
1740 unsigned char un_char = 255, last_un_char;
1741 char *send = strchr(s,']');
1742 char tmpbuf[sizeof PL_tokenbuf * 4];
1744 if (!send) /* has to be an expression */
1747 Zero(seen,256,char);
1750 else if (isDIGIT(*s)) {
1752 if (isDIGIT(s[1]) && s[2] == ']')
1758 for (; s < send; s++) {
1759 last_un_char = un_char;
1760 un_char = (unsigned char)*s;
1765 weight -= seen[un_char] * 10;
1766 if (isALNUM_lazy_if(s+1,UTF)) {
1767 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1768 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1773 else if (*s == '$' && s[1] &&
1774 strchr("[#!%*<>()-=",s[1])) {
1775 if (/*{*/ strchr("])} =",s[2]))
1784 if (strchr("wds]",s[1]))
1786 else if (seen['\''] || seen['"'])
1788 else if (strchr("rnftbxcav",s[1]))
1790 else if (isDIGIT(s[1])) {
1792 while (s[1] && isDIGIT(s[1]))
1802 if (strchr("aA01! ",last_un_char))
1804 if (strchr("zZ79~",s[1]))
1806 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1807 weight -= 5; /* cope with negative subscript */
1810 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1811 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1816 if (keyword(tmpbuf, d - tmpbuf))
1819 if (un_char == last_un_char + 1)
1821 weight -= seen[un_char];
1826 if (weight >= 0) /* probably a character class */
1836 * Does all the checking to disambiguate
1838 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
1839 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
1841 * First argument is the stuff after the first token, e.g. "bar".
1843 * Not a method if bar is a filehandle.
1844 * Not a method if foo is a subroutine prototyped to take a filehandle.
1845 * Not a method if it's really "Foo $bar"
1846 * Method if it's "foo $bar"
1847 * Not a method if it's really "print foo $bar"
1848 * Method if it's really "foo package::" (interpreted as package->foo)
1849 * Not a method if bar is known to be a subroutne ("sub bar; foo bar")
1850 * Not a method if bar is a filehandle or package, but is quoted with
1855 S_intuit_method(pTHX_ char *start, GV *gv)
1857 char *s = start + (*start == '$');
1858 char tmpbuf[sizeof PL_tokenbuf];
1866 if ((cv = GvCVu(gv))) {
1867 char *proto = SvPVX(cv);
1877 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1878 /* start is the beginning of the possible filehandle/object,
1879 * and s is the end of it
1880 * tmpbuf is a copy of it
1883 if (*start == '$') {
1884 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1889 return *s == '(' ? FUNCMETH : METHOD;
1891 if (!keyword(tmpbuf, len)) {
1892 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1897 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1898 if (indirgv && GvCVu(indirgv))
1900 /* filehandle or package name makes it a method */
1901 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1903 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1904 return 0; /* no assumptions -- "=>" quotes bearword */
1906 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1907 newSVpvn(tmpbuf,len));
1908 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1912 return *s == '(' ? FUNCMETH : METHOD;
1920 * Return a string of Perl code to load the debugger. If PERL5DB
1921 * is set, it will return the contents of that, otherwise a
1922 * compile-time require of perl5db.pl.
1929 char *pdb = PerlEnv_getenv("PERL5DB");
1933 SETERRNO(0,SS$_NORMAL);
1934 return "BEGIN { require 'perl5db.pl' }";
1940 /* Encoded script support. filter_add() effectively inserts a
1941 * 'pre-processing' function into the current source input stream.
1942 * Note that the filter function only applies to the current source file
1943 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1945 * The datasv parameter (which may be NULL) can be used to pass
1946 * private data to this instance of the filter. The filter function
1947 * can recover the SV using the FILTER_DATA macro and use it to
1948 * store private buffers and state information.
1950 * The supplied datasv parameter is upgraded to a PVIO type
1951 * and the IoDIRP/IoANY field is used to store the function pointer,
1952 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
1953 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1954 * private use must be set using malloc'd pointers.
1958 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
1963 if (!PL_rsfp_filters)
1964 PL_rsfp_filters = newAV();
1966 datasv = NEWSV(255,0);
1967 if (!SvUPGRADE(datasv, SVt_PVIO))
1968 Perl_die(aTHX_ "Can't upgrade filter_add data to SVt_PVIO");
1969 IoANY(datasv) = (void *)funcp; /* stash funcp into spare field */
1970 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
1971 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
1972 funcp, SvPV_nolen(datasv)));
1973 av_unshift(PL_rsfp_filters, 1);
1974 av_store(PL_rsfp_filters, 0, datasv) ;
1979 /* Delete most recently added instance of this filter function. */
1981 Perl_filter_del(pTHX_ filter_t funcp)
1984 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", funcp));
1985 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
1987 /* if filter is on top of stack (usual case) just pop it off */
1988 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
1989 if (IoANY(datasv) == (void *)funcp) {
1990 IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
1991 IoANY(datasv) = (void *)NULL;
1992 sv_free(av_pop(PL_rsfp_filters));
1996 /* we need to search for the correct entry and clear it */
1997 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
2001 /* Invoke the n'th filter function for the current rsfp. */
2003 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
2006 /* 0 = read one text line */
2011 if (!PL_rsfp_filters)
2013 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
2014 /* Provide a default input filter to make life easy. */
2015 /* Note that we append to the line. This is handy. */
2016 DEBUG_P(PerlIO_printf(Perl_debug_log,
2017 "filter_read %d: from rsfp\n", idx));
2021 int old_len = SvCUR(buf_sv) ;
2023 /* ensure buf_sv is large enough */
2024 SvGROW(buf_sv, old_len + maxlen) ;
2025 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
2026 if (PerlIO_error(PL_rsfp))
2027 return -1; /* error */
2029 return 0 ; /* end of file */
2031 SvCUR_set(buf_sv, old_len + len) ;
2034 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
2035 if (PerlIO_error(PL_rsfp))
2036 return -1; /* error */
2038 return 0 ; /* end of file */
2041 return SvCUR(buf_sv);
2043 /* Skip this filter slot if filter has been deleted */
2044 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
2045 DEBUG_P(PerlIO_printf(Perl_debug_log,
2046 "filter_read %d: skipped (filter deleted)\n",
2048 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
2050 /* Get function pointer hidden within datasv */
2051 funcp = (filter_t)IoANY(datasv);
2052 DEBUG_P(PerlIO_printf(Perl_debug_log,
2053 "filter_read %d: via function %p (%s)\n",
2054 idx, funcp, SvPV_nolen(datasv)));
2055 /* Call function. The function is expected to */
2056 /* call "FILTER_READ(idx+1, buf_sv)" first. */
2057 /* Return: <0:error, =0:eof, >0:not eof */
2058 return (*funcp)(aTHX_ idx, buf_sv, maxlen);
2062 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
2064 #ifdef PERL_CR_FILTER
2065 if (!PL_rsfp_filters) {
2066 filter_add(S_cr_textfilter,NULL);
2069 if (PL_rsfp_filters) {
2072 SvCUR_set(sv, 0); /* start with empty line */
2073 if (FILTER_READ(0, sv, 0) > 0)
2074 return ( SvPVX(sv) ) ;
2079 return (sv_gets(sv, fp, append));
2083 S_find_in_my_stash(pTHX_ char *pkgname, I32 len)
2087 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
2091 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
2092 (gv = gv_fetchpv(pkgname, FALSE, SVt_PVHV)))
2094 return GvHV(gv); /* Foo:: */
2097 /* use constant CLASS => 'MyClass' */
2098 if ((gv = gv_fetchpv(pkgname, FALSE, SVt_PVCV))) {
2100 if (GvCV(gv) && (sv = cv_const_sv(GvCV(gv)))) {
2101 pkgname = SvPV_nolen(sv);
2105 return gv_stashpv(pkgname, FALSE);
2109 static char* exp_name[] =
2110 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
2111 "ATTRTERM", "TERMBLOCK"
2118 Works out what to call the token just pulled out of the input
2119 stream. The yacc parser takes care of taking the ops we return and
2120 stitching them into a tree.
2126 if read an identifier
2127 if we're in a my declaration
2128 croak if they tried to say my($foo::bar)
2129 build the ops for a my() declaration
2130 if it's an access to a my() variable
2131 are we in a sort block?
2132 croak if my($a); $a <=> $b
2133 build ops for access to a my() variable
2134 if in a dq string, and they've said @foo and we can't find @foo
2136 build ops for a bareword
2137 if we already built the token before, use it.
2140 #ifdef USE_PURE_BISON
2142 Perl_yylex_r(pTHX_ YYSTYPE *lvalp, int *lcharp)
2147 yylval_pointer[yyactlevel] = lvalp;
2148 yychar_pointer[yyactlevel] = lcharp;
2149 if (yyactlevel >= YYMAXLEVEL)
2150 Perl_croak(aTHX_ "panic: YYMAXLEVEL");
2152 r = Perl_yylex(aTHX);
2162 #pragma segment Perl_yylex
2175 /* check if there's an identifier for us to look at */
2176 if (PL_pending_ident)
2177 return S_pending_ident(aTHX);
2179 /* no identifier pending identification */
2181 switch (PL_lex_state) {
2183 case LEX_NORMAL: /* Some compilers will produce faster */
2184 case LEX_INTERPNORMAL: /* code if we comment these out. */
2188 /* when we've already built the next token, just pull it out of the queue */
2191 yylval = PL_nextval[PL_nexttoke];
2193 PL_lex_state = PL_lex_defer;
2194 PL_expect = PL_lex_expect;
2195 PL_lex_defer = LEX_NORMAL;
2197 DEBUG_T({ PerlIO_printf(Perl_debug_log,
2198 "### Next token after '%s' was known, type %"IVdf"\n", PL_bufptr,
2199 (IV)PL_nexttype[PL_nexttoke]); });
2201 return(PL_nexttype[PL_nexttoke]);
2203 /* interpolated case modifiers like \L \U, including \Q and \E.
2204 when we get here, PL_bufptr is at the \
2206 case LEX_INTERPCASEMOD:
2208 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
2209 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
2211 /* handle \E or end of string */
2212 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
2216 if (PL_lex_casemods) {
2217 oldmod = PL_lex_casestack[--PL_lex_casemods];
2218 PL_lex_casestack[PL_lex_casemods] = '\0';
2220 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
2222 PL_lex_state = LEX_INTERPCONCAT;
2226 if (PL_bufptr != PL_bufend)
2228 PL_lex_state = LEX_INTERPCONCAT;
2232 DEBUG_T({ PerlIO_printf(Perl_debug_log,
2233 "### Saw case modifier at '%s'\n", PL_bufptr); });
2235 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
2236 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
2237 if (strchr("LU", *s) &&
2238 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
2240 PL_lex_casestack[--PL_lex_casemods] = '\0';
2243 if (PL_lex_casemods > 10) {
2244 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
2245 if (newlb != PL_lex_casestack) {
2247 PL_lex_casestack = newlb;
2250 PL_lex_casestack[PL_lex_casemods++] = *s;
2251 PL_lex_casestack[PL_lex_casemods] = '\0';
2252 PL_lex_state = LEX_INTERPCONCAT;
2253 PL_nextval[PL_nexttoke].ival = 0;
2256 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
2258 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
2260 PL_nextval[PL_nexttoke].ival = OP_LC;
2262 PL_nextval[PL_nexttoke].ival = OP_UC;
2264 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
2266 Perl_croak(aTHX_ "panic: yylex");
2269 if (PL_lex_starts) {
2278 case LEX_INTERPPUSH:
2279 return sublex_push();
2281 case LEX_INTERPSTART:
2282 if (PL_bufptr == PL_bufend)
2283 return sublex_done();
2284 DEBUG_T({ PerlIO_printf(Perl_debug_log,
2285 "### Interpolated variable at '%s'\n", PL_bufptr); });
2287 PL_lex_dojoin = (*PL_bufptr == '@');
2288 PL_lex_state = LEX_INTERPNORMAL;
2289 if (PL_lex_dojoin) {
2290 PL_nextval[PL_nexttoke].ival = 0;
2292 #ifdef USE_5005THREADS
2293 PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
2294 PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
2295 force_next(PRIVATEREF);
2297 force_ident("\"", '$');
2298 #endif /* USE_5005THREADS */
2299 PL_nextval[PL_nexttoke].ival = 0;
2301 PL_nextval[PL_nexttoke].ival = 0;
2303 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
2306 if (PL_lex_starts++) {
2312 case LEX_INTERPENDMAYBE:
2313 if (intuit_more(PL_bufptr)) {
2314 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
2320 if (PL_lex_dojoin) {
2321 PL_lex_dojoin = FALSE;
2322 PL_lex_state = LEX_INTERPCONCAT;
2325 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
2326 && SvEVALED(PL_lex_repl))
2328 if (PL_bufptr != PL_bufend)
2329 Perl_croak(aTHX_ "Bad evalled substitution pattern");
2330 PL_lex_repl = Nullsv;
2333 case LEX_INTERPCONCAT:
2335 if (PL_lex_brackets)
2336 Perl_croak(aTHX_ "panic: INTERPCONCAT");
2338 if (PL_bufptr == PL_bufend)
2339 return sublex_done();
2341 if (SvIVX(PL_linestr) == '\'') {
2342 SV *sv = newSVsv(PL_linestr);
2345 else if ( PL_hints & HINT_NEW_RE )
2346 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
2347 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2351 s = scan_const(PL_bufptr);
2353 PL_lex_state = LEX_INTERPCASEMOD;
2355 PL_lex_state = LEX_INTERPSTART;
2358 if (s != PL_bufptr) {
2359 PL_nextval[PL_nexttoke] = yylval;
2362 if (PL_lex_starts++)
2372 PL_lex_state = LEX_NORMAL;
2373 s = scan_formline(PL_bufptr);
2374 if (!PL_lex_formbrack)
2380 PL_oldoldbufptr = PL_oldbufptr;
2383 PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at %s\n",
2384 exp_name[PL_expect], s);
2390 if (isIDFIRST_lazy_if(s,UTF))
2392 Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
2395 goto fake_eof; /* emulate EOF on ^D or ^Z */
2400 if (PL_lex_brackets)
2401 yyerror("Missing right curly or square bracket");
2402 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2403 "### Tokener got EOF\n");
2407 if (s++ < PL_bufend)
2408 goto retry; /* ignore stray nulls */
2411 if (!PL_in_eval && !PL_preambled) {
2412 PL_preambled = TRUE;
2413 sv_setpv(PL_linestr,incl_perldb());
2414 if (SvCUR(PL_linestr))
2415 sv_catpv(PL_linestr,";");
2417 while(AvFILLp(PL_preambleav) >= 0) {
2418 SV *tmpsv = av_shift(PL_preambleav);
2419 sv_catsv(PL_linestr, tmpsv);
2420 sv_catpv(PL_linestr, ";");
2423 sv_free((SV*)PL_preambleav);
2424 PL_preambleav = NULL;
2426 if (PL_minus_n || PL_minus_p) {
2427 sv_catpv(PL_linestr, "LINE: while (<>) {");
2429 sv_catpv(PL_linestr,"chomp;");
2432 if (strchr("/'\"", *PL_splitstr)
2433 && strchr(PL_splitstr + 1, *PL_splitstr))
2434 Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s);", PL_splitstr);
2437 s = "'~#\200\1'"; /* surely one char is unused...*/
2438 while (s[1] && strchr(PL_splitstr, *s)) s++;
2440 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s%c",
2441 "q" + (delim == '\''), delim);
2442 for (s = PL_splitstr; *s; s++) {
2444 sv_catpvn(PL_linestr, "\\", 1);
2445 sv_catpvn(PL_linestr, s, 1);
2447 Perl_sv_catpvf(aTHX_ PL_linestr, "%c);", delim);
2451 sv_catpv(PL_linestr,"our @F=split(' ');");
2454 sv_catpv(PL_linestr, "\n");
2455 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2456 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2457 PL_last_lop = PL_last_uni = Nullch;
2458 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2459 SV *sv = NEWSV(85,0);
2461 sv_upgrade(sv, SVt_PVMG);
2462 sv_setsv(sv,PL_linestr);
2463 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2468 bof = PL_rsfp ? TRUE : FALSE;
2469 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
2472 if (PL_preprocess && !PL_in_eval)
2473 (void)PerlProc_pclose(PL_rsfp);
2474 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2475 PerlIO_clearerr(PL_rsfp);
2477 (void)PerlIO_close(PL_rsfp);
2479 PL_doextract = FALSE;
2481 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2482 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
2483 sv_catpv(PL_linestr,";}");
2484 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2485 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2486 PL_last_lop = PL_last_uni = Nullch;
2487 PL_minus_n = PL_minus_p = 0;
2490 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2491 PL_last_lop = PL_last_uni = Nullch;
2492 sv_setpv(PL_linestr,"");
2493 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
2495 /* if it looks like the start of a BOM, check if it in fact is */
2496 else if (bof && (!*s || *(U8*)s == 0xEF || *(U8*)s >= 0xFE)) {
2497 #ifdef PERLIO_IS_STDIO
2498 # ifdef __GNU_LIBRARY__
2499 # if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
2500 # define FTELL_FOR_PIPE_IS_BROKEN
2504 # if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
2505 # define FTELL_FOR_PIPE_IS_BROKEN
2510 #ifdef FTELL_FOR_PIPE_IS_BROKEN
2511 /* This loses the possibility to detect the bof
2512 * situation on perl -P when the libc5 is being used.
2513 * Workaround? Maybe attach some extra state to PL_rsfp?
2516 bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
2518 bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
2521 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2522 s = swallow_bom((U8*)s);
2526 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
2527 PL_doextract = FALSE;
2529 /* Incest with pod. */
2530 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2531 sv_setpv(PL_linestr, "");
2532 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2533 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2534 PL_last_lop = PL_last_uni = Nullch;
2535 PL_doextract = FALSE;
2539 } while (PL_doextract);
2540 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2541 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2542 SV *sv = NEWSV(85,0);
2544 sv_upgrade(sv, SVt_PVMG);
2545 sv_setsv(sv,PL_linestr);
2546 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2548 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2549 PL_last_lop = PL_last_uni = Nullch;
2550 if (CopLINE(PL_curcop) == 1) {
2551 while (s < PL_bufend && isSPACE(*s))
2553 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2557 if (*s == '#' && *(s+1) == '!')
2559 #ifdef ALTERNATE_SHEBANG
2561 static char as[] = ALTERNATE_SHEBANG;
2562 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2563 d = s + (sizeof(as) - 1);
2565 #endif /* ALTERNATE_SHEBANG */
2574 while (*d && !isSPACE(*d))
2578 #ifdef ARG_ZERO_IS_SCRIPT
2579 if (ipathend > ipath) {
2581 * HP-UX (at least) sets argv[0] to the script name,
2582 * which makes $^X incorrect. And Digital UNIX and Linux,
2583 * at least, set argv[0] to the basename of the Perl
2584 * interpreter. So, having found "#!", we'll set it right.
2586 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
2587 assert(SvPOK(x) || SvGMAGICAL(x));
2588 if (sv_eq(x, CopFILESV(PL_curcop))) {
2589 sv_setpvn(x, ipath, ipathend - ipath);
2592 TAINT_NOT; /* $^X is always tainted, but that's OK */
2594 #endif /* ARG_ZERO_IS_SCRIPT */
2599 d = instr(s,"perl -");
2601 d = instr(s,"perl");
2603 /* avoid getting into infinite loops when shebang
2604 * line contains "Perl" rather than "perl" */
2606 for (d = ipathend-4; d >= ipath; --d) {
2607 if ((*d == 'p' || *d == 'P')
2608 && !ibcmp(d, "perl", 4))
2618 #ifdef ALTERNATE_SHEBANG
2620 * If the ALTERNATE_SHEBANG on this system starts with a
2621 * character that can be part of a Perl expression, then if
2622 * we see it but not "perl", we're probably looking at the
2623 * start of Perl code, not a request to hand off to some
2624 * other interpreter. Similarly, if "perl" is there, but
2625 * not in the first 'word' of the line, we assume the line
2626 * contains the start of the Perl program.
2628 if (d && *s != '#') {
2630 while (*c && !strchr("; \t\r\n\f\v#", *c))
2633 d = Nullch; /* "perl" not in first word; ignore */
2635 *s = '#'; /* Don't try to parse shebang line */
2637 #endif /* ALTERNATE_SHEBANG */
2638 #ifndef MACOS_TRADITIONAL
2643 !instr(s,"indir") &&
2644 instr(PL_origargv[0],"perl"))
2650 while (s < PL_bufend && isSPACE(*s))
2652 if (s < PL_bufend) {
2653 Newz(899,newargv,PL_origargc+3,char*);
2655 while (s < PL_bufend && !isSPACE(*s))
2658 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2661 newargv = PL_origargv;
2663 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
2664 Perl_croak(aTHX_ "Can't exec %s", ipath);
2668 U32 oldpdb = PL_perldb;
2669 bool oldn = PL_minus_n;
2670 bool oldp = PL_minus_p;
2672 while (*d && !isSPACE(*d)) d++;
2673 while (SPACE_OR_TAB(*d)) d++;
2677 if (*d == 'M' || *d == 'm') {
2679 while (*d && !isSPACE(*d)) d++;
2680 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2683 d = moreswitches(d);
2685 if ((PERLDB_LINE && !oldpdb) ||
2686 ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
2687 /* if we have already added "LINE: while (<>) {",
2688 we must not do it again */
2690 sv_setpv(PL_linestr, "");
2691 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2692 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2693 PL_last_lop = PL_last_uni = Nullch;
2694 PL_preambled = FALSE;
2696 (void)gv_fetchfile(PL_origfilename);
2703 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2705 PL_lex_state = LEX_FORMLINE;
2710 #ifdef PERL_STRICT_CR
2711 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2713 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
2715 case ' ': case '\t': case '\f': case 013:
2716 #ifdef MACOS_TRADITIONAL
2723 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2724 if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
2725 /* handle eval qq[#line 1 "foo"\n ...] */
2726 CopLINE_dec(PL_curcop);
2730 while (s < d && *s != '\n')
2734 else if (s > d) /* Found by Ilya: feed random input to Perl. */
2735 Perl_croak(aTHX_ "panic: input overflow");
2737 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2739 PL_lex_state = LEX_FORMLINE;
2749 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2756 while (s < PL_bufend && SPACE_OR_TAB(*s))
2759 if (strnEQ(s,"=>",2)) {
2760 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2761 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2762 "### Saw unary minus before =>, forcing word '%s'\n", s);
2764 OPERATOR('-'); /* unary minus */
2766 PL_last_uni = PL_oldbufptr;
2768 case 'r': ftst = OP_FTEREAD; break;
2769 case 'w': ftst = OP_FTEWRITE; break;
2770 case 'x': ftst = OP_FTEEXEC; break;
2771 case 'o': ftst = OP_FTEOWNED; break;
2772 case 'R': ftst = OP_FTRREAD; break;
2773 case 'W': ftst = OP_FTRWRITE; break;
2774 case 'X': ftst = OP_FTREXEC; break;
2775 case 'O': ftst = OP_FTROWNED; break;
2776 case 'e': ftst = OP_FTIS; break;
2777 case 'z': ftst = OP_FTZERO; break;
2778 case 's': ftst = OP_FTSIZE; break;
2779 case 'f': ftst = OP_FTFILE; break;
2780 case 'd': ftst = OP_FTDIR; break;
2781 case 'l': ftst = OP_FTLINK; break;
2782 case 'p': ftst = OP_FTPIPE; break;
2783 case 'S': ftst = OP_FTSOCK; break;
2784 case 'u': ftst = OP_FTSUID; break;
2785 case 'g': ftst = OP_FTSGID; break;
2786 case 'k': ftst = OP_FTSVTX; break;
2787 case 'b': ftst = OP_FTBLK; break;
2788 case 'c': ftst = OP_FTCHR; break;
2789 case 't': ftst = OP_FTTTY; break;
2790 case 'T': ftst = OP_FTTEXT; break;
2791 case 'B': ftst = OP_FTBINARY; break;
2792 case 'M': case 'A': case 'C':
2793 gv_fetchpv("\024",TRUE, SVt_PV);
2795 case 'M': ftst = OP_FTMTIME; break;
2796 case 'A': ftst = OP_FTATIME; break;
2797 case 'C': ftst = OP_FTCTIME; break;
2805 PL_last_lop_op = ftst;
2806 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2807 "### Saw file test %c\n", (int)ftst);
2812 /* Assume it was a minus followed by a one-letter named
2813 * subroutine call (or a -bareword), then. */
2814 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2815 "### %c looked like a file test but was not\n",
2824 if (PL_expect == XOPERATOR)
2829 else if (*s == '>') {
2832 if (isIDFIRST_lazy_if(s,UTF)) {
2833 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2841 if (PL_expect == XOPERATOR)
2844 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2846 OPERATOR('-'); /* unary minus */
2853 if (PL_expect == XOPERATOR)
2858 if (PL_expect == XOPERATOR)
2861 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2867 if (PL_expect != XOPERATOR) {
2868 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2869 PL_expect = XOPERATOR;
2870 force_ident(PL_tokenbuf, '*');
2883 if (PL_expect == XOPERATOR) {
2887 PL_tokenbuf[0] = '%';
2888 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2889 if (!PL_tokenbuf[1]) {
2891 yyerror("Final % should be \\% or %name");
2894 PL_pending_ident = '%';
2913 switch (PL_expect) {
2916 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
2918 PL_bufptr = s; /* update in case we back off */
2924 PL_expect = XTERMBLOCK;
2928 while (isIDFIRST_lazy_if(s,UTF)) {
2929 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2930 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
2931 if (tmp < 0) tmp = -tmp;
2946 d = scan_str(d,TRUE,TRUE);
2948 /* MUST advance bufptr here to avoid bogus
2949 "at end of line" context messages from yyerror().
2951 PL_bufptr = s + len;
2952 yyerror("Unterminated attribute parameter in attribute list");
2955 return 0; /* EOF indicator */
2959 SV *sv = newSVpvn(s, len);
2960 sv_catsv(sv, PL_lex_stuff);
2961 attrs = append_elem(OP_LIST, attrs,
2962 newSVOP(OP_CONST, 0, sv));
2963 SvREFCNT_dec(PL_lex_stuff);
2964 PL_lex_stuff = Nullsv;
2967 if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len))
2968 CvLVALUE_on(PL_compcv);
2969 else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len))
2970 CvLOCKED_on(PL_compcv);
2971 else if (!PL_in_my && len == 6 && strnEQ(s, "method", len))
2972 CvMETHOD_on(PL_compcv);
2974 else if (PL_in_my == KEY_our && len == 6 && strnEQ(s, "unique", len))
2975 GvUNIQUE_on(cGVOPx_gv(yylval.opval));
2977 /* After we've set the flags, it could be argued that
2978 we don't need to do the attributes.pm-based setting
2979 process, and shouldn't bother appending recognized
2980 flags. To experiment with that, uncomment the
2981 following "else": */
2983 attrs = append_elem(OP_LIST, attrs,
2984 newSVOP(OP_CONST, 0,
2988 if (*s == ':' && s[1] != ':')
2991 break; /* require real whitespace or :'s */
2993 tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
2994 if (*s != ';' && *s != tmp && (tmp != '=' || *s != ')')) {
2995 char q = ((*s == '\'') ? '"' : '\'');
2996 /* If here for an expression, and parsed no attrs, back off. */
2997 if (tmp == '=' && !attrs) {
3001 /* MUST advance bufptr here to avoid bogus "at end of line"
3002 context messages from yyerror().
3006 yyerror("Unterminated attribute list");
3008 yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list",
3016 PL_nextval[PL_nexttoke].opval = attrs;
3024 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
3025 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
3041 if (PL_lex_brackets <= 0)
3042 yyerror("Unmatched right square bracket");
3045 if (PL_lex_state == LEX_INTERPNORMAL) {
3046 if (PL_lex_brackets == 0) {
3047 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
3048 PL_lex_state = LEX_INTERPEND;
3055 if (PL_lex_brackets > 100) {
3056 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
3057 if (newlb != PL_lex_brackstack) {
3059 PL_lex_brackstack = newlb;
3062 switch (PL_expect) {
3064 if (PL_lex_formbrack) {
3068 if (PL_oldoldbufptr == PL_last_lop)
3069 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3071 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3072 OPERATOR(HASHBRACK);
3074 while (s < PL_bufend && SPACE_OR_TAB(*s))
3077 PL_tokenbuf[0] = '\0';
3078 if (d < PL_bufend && *d == '-') {
3079 PL_tokenbuf[0] = '-';
3081 while (d < PL_bufend && SPACE_OR_TAB(*d))
3084 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
3085 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
3087 while (d < PL_bufend && SPACE_OR_TAB(*d))
3090 char minus = (PL_tokenbuf[0] == '-');
3091 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
3099 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
3104 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3109 if (PL_oldoldbufptr == PL_last_lop)
3110 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3112 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3115 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
3117 /* This hack is to get the ${} in the message. */
3119 yyerror("syntax error");
3122 OPERATOR(HASHBRACK);
3124 /* This hack serves to disambiguate a pair of curlies
3125 * as being a block or an anon hash. Normally, expectation
3126 * determines that, but in cases where we're not in a
3127 * position to expect anything in particular (like inside
3128 * eval"") we have to resolve the ambiguity. This code
3129 * covers the case where the first term in the curlies is a
3130 * quoted string. Most other cases need to be explicitly
3131 * disambiguated by prepending a `+' before the opening
3132 * curly in order to force resolution as an anon hash.
3134 * XXX should probably propagate the outer expectation
3135 * into eval"" to rely less on this hack, but that could
3136 * potentially break current behavior of eval"".
3140 if (*s == '\'' || *s == '"' || *s == '`') {
3141 /* common case: get past first string, handling escapes */
3142 for (t++; t < PL_bufend && *t != *s;)
3143 if (*t++ == '\\' && (*t == '\\' || *t == *s))
3147 else if (*s == 'q') {
3150 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
3154 char open, close, term;
3157 while (t < PL_bufend && isSPACE(*t))
3161 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
3165 for (t++; t < PL_bufend; t++) {
3166 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
3168 else if (*t == open)
3172 for (t++; t < PL_bufend; t++) {
3173 if (*t == '\\' && t+1 < PL_bufend)
3175 else if (*t == close && --brackets <= 0)
3177 else if (*t == open)
3183 else if (isALNUM_lazy_if(t,UTF)) {
3185 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3188 while (t < PL_bufend && isSPACE(*t))
3190 /* if comma follows first term, call it an anon hash */
3191 /* XXX it could be a comma expression with loop modifiers */
3192 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
3193 || (*t == '=' && t[1] == '>')))
3194 OPERATOR(HASHBRACK);
3195 if (PL_expect == XREF)
3198 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
3204 yylval.ival = CopLINE(PL_curcop);
3205 if (isSPACE(*s) || *s == '#')
3206 PL_copline = NOLINE; /* invalidate current command line number */
3211 if (PL_lex_brackets <= 0)
3212 yyerror("Unmatched right curly bracket");
3214 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
3215 if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
3216 PL_lex_formbrack = 0;
3217 if (PL_lex_state == LEX_INTERPNORMAL) {
3218 if (PL_lex_brackets == 0) {
3219 if (PL_expect & XFAKEBRACK) {
3220 PL_expect &= XENUMMASK;
3221 PL_lex_state = LEX_INTERPEND;
3223 return yylex(); /* ignore fake brackets */
3225 if (*s == '-' && s[1] == '>')
3226 PL_lex_state = LEX_INTERPENDMAYBE;
3227 else if (*s != '[' && *s != '{')
3228 PL_lex_state = LEX_INTERPEND;
3231 if (PL_expect & XFAKEBRACK) {
3232 PL_expect &= XENUMMASK;
3234 return yylex(); /* ignore fake brackets */
3244 if (PL_expect == XOPERATOR) {
3245 if (ckWARN(WARN_SEMICOLON)
3246 && isIDFIRST_lazy_if(s,UTF) && PL_bufptr == PL_linestart)
3248 CopLINE_dec(PL_curcop);
3249 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3250 CopLINE_inc(PL_curcop);
3255 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3257 PL_expect = XOPERATOR;
3258 force_ident(PL_tokenbuf, '&');
3262 yylval.ival = (OPpENTERSUB_AMPER<<8);
3281 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
3282 Perl_warner(aTHX_ WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
3284 if (PL_expect == XSTATE && isALPHA(tmp) &&
3285 (s == PL_linestart+1 || s[-2] == '\n') )
3287 if (PL_in_eval && !PL_rsfp) {
3292 if (strnEQ(s,"=cut",4)) {
3306 PL_doextract = TRUE;
3309 if (PL_lex_brackets < PL_lex_formbrack) {
3311 #ifdef PERL_STRICT_CR
3312 for (t = s; SPACE_OR_TAB(*t); t++) ;
3314 for (t = s; SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
3316 if (*t == '\n' || *t == '#') {
3334 if (PL_expect != XOPERATOR) {
3335 if (s[1] != '<' && !strchr(s,'>'))
3338 s = scan_heredoc(s);
3340 s = scan_inputsymbol(s);
3341 TERM(sublex_start());
3346 SHop(OP_LEFT_SHIFT);
3360 SHop(OP_RIGHT_SHIFT);
3369 if (PL_expect == XOPERATOR) {
3370 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3373 return ','; /* grandfather non-comma-format format */
3377 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
3378 PL_tokenbuf[0] = '@';
3379 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3380 sizeof PL_tokenbuf - 1, FALSE);
3381 if (PL_expect == XOPERATOR)
3382 no_op("Array length", s);
3383 if (!PL_tokenbuf[1])
3385 PL_expect = XOPERATOR;
3386 PL_pending_ident = '#';
3390 PL_tokenbuf[0] = '$';
3391 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3392 sizeof PL_tokenbuf - 1, FALSE);
3393 if (PL_expect == XOPERATOR)
3395 if (!PL_tokenbuf[1]) {
3397 yyerror("Final $ should be \\$ or $name");
3401 /* This kludge not intended to be bulletproof. */
3402 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
3403 yylval.opval = newSVOP(OP_CONST, 0,
3404 newSViv(PL_compiling.cop_arybase));
3405 yylval.opval->op_private = OPpCONST_ARYBASE;
3411 if (PL_lex_state == LEX_NORMAL)
3414 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3417 PL_tokenbuf[0] = '@';
3418 if (ckWARN(WARN_SYNTAX)) {
3420 isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$';
3423 PL_bufptr = skipspace(PL_bufptr);
3424 while (t < PL_bufend && *t != ']')
3426 Perl_warner(aTHX_ WARN_SYNTAX,
3427 "Multidimensional syntax %.*s not supported",
3428 (t - PL_bufptr) + 1, PL_bufptr);
3432 else if (*s == '{') {
3433 PL_tokenbuf[0] = '%';
3434 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
3435 (t = strchr(s, '}')) && (t = strchr(t, '=')))
3437 char tmpbuf[sizeof PL_tokenbuf];
3439 for (t++; isSPACE(*t); t++) ;
3440 if (isIDFIRST_lazy_if(t,UTF)) {
3441 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
3442 for (; isSPACE(*t); t++) ;
3443 if (*t == ';' && get_cv(tmpbuf, FALSE))
3444 Perl_warner(aTHX_ WARN_SYNTAX,
3445 "You need to quote \"%s\"", tmpbuf);
3451 PL_expect = XOPERATOR;
3452 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3453 bool islop = (PL_last_lop == PL_oldoldbufptr);
3454 if (!islop || PL_last_lop_op == OP_GREPSTART)
3455 PL_expect = XOPERATOR;
3456 else if (strchr("$@\"'`q", *s))
3457 PL_expect = XTERM; /* e.g. print $fh "foo" */
3458 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
3459 PL_expect = XTERM; /* e.g. print $fh &sub */
3460 else if (isIDFIRST_lazy_if(s,UTF)) {
3461 char tmpbuf[sizeof PL_tokenbuf];
3462 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3463 if ((tmp = keyword(tmpbuf, len))) {
3464 /* binary operators exclude handle interpretations */
3476 PL_expect = XTERM; /* e.g. print $fh length() */
3481 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
3482 if (gv && GvCVu(gv))
3483 PL_expect = XTERM; /* e.g. print $fh subr() */
3486 else if (isDIGIT(*s))
3487 PL_expect = XTERM; /* e.g. print $fh 3 */
3488 else if (*s == '.' && isDIGIT(s[1]))
3489 PL_expect = XTERM; /* e.g. print $fh .3 */
3490 else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
3491 PL_expect = XTERM; /* e.g. print $fh -1 */
3492 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3493 PL_expect = XTERM; /* print $fh <<"EOF" */
3495 PL_pending_ident = '$';
3499 if (PL_expect == XOPERATOR)
3501 PL_tokenbuf[0] = '@';
3502 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3503 if (!PL_tokenbuf[1]) {
3505 yyerror("Final @ should be \\@ or @name");
3508 if (PL_lex_state == LEX_NORMAL)
3510 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3512 PL_tokenbuf[0] = '%';
3514 /* Warn about @ where they meant $. */
3515 if (ckWARN(WARN_SYNTAX)) {
3516 if (*s == '[' || *s == '{') {
3518 while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
3520 if (*t == '}' || *t == ']') {
3522 PL_bufptr = skipspace(PL_bufptr);
3523 Perl_warner(aTHX_ WARN_SYNTAX,
3524 "Scalar value %.*s better written as $%.*s",
3525 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
3530 PL_pending_ident = '@';
3533 case '/': /* may either be division or pattern */
3534 case '?': /* may either be conditional or pattern */
3535 if (PL_expect != XOPERATOR) {
3536 /* Disable warning on "study /blah/" */
3537 if (PL_oldoldbufptr == PL_last_uni
3538 && (*PL_last_uni != 's' || s - PL_last_uni < 5
3539 || memNE(PL_last_uni, "study", 5)
3540 || isALNUM_lazy_if(PL_last_uni+5,UTF)))
3542 s = scan_pat(s,OP_MATCH);
3543 TERM(sublex_start());
3551 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3552 #ifdef PERL_STRICT_CR
3555 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3557 && (s == PL_linestart || s[-1] == '\n') )
3559 PL_lex_formbrack = 0;
3563 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
3569 yylval.ival = OPf_SPECIAL;
3575 if (PL_expect != XOPERATOR)
3580 case '0': case '1': case '2': case '3': case '4':
3581 case '5': case '6': case '7': case '8': case '9':
3582 s = scan_num(s, &yylval);
3583 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3584 "### Saw number in '%s'\n", s);
3586 if (PL_expect == XOPERATOR)
3591 s = scan_str(s,FALSE,FALSE);
3592 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3593 "### Saw string before '%s'\n", s);
3595 if (PL_expect == XOPERATOR) {
3596 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3599 return ','; /* grandfather non-comma-format format */
3605 missingterm((char*)0);
3606 yylval.ival = OP_CONST;
3607 TERM(sublex_start());
3610 s = scan_str(s,FALSE,FALSE);
3611 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3612 "### Saw string before '%s'\n", s);
3614 if (PL_expect == XOPERATOR) {
3615 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3618 return ','; /* grandfather non-comma-format format */
3624 missingterm((char*)0);
3625 yylval.ival = OP_CONST;
3626 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
3627 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
3628 yylval.ival = OP_STRINGIFY;
3632 TERM(sublex_start());
3635 s = scan_str(s,FALSE,FALSE);
3636 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3637 "### Saw backtick string before '%s'\n", s);
3639 if (PL_expect == XOPERATOR)
3640 no_op("Backticks",s);
3642 missingterm((char*)0);
3643 yylval.ival = OP_BACKTICK;
3645 TERM(sublex_start());
3649 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
3650 Perl_warner(aTHX_ WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
3652 if (PL_expect == XOPERATOR)
3653 no_op("Backslash",s);
3657 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
3661 while (isDIGIT(*start) || *start == '_')
3663 if (*start == '.' && isDIGIT(start[1])) {
3664 s = scan_num(s, &yylval);
3667 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
3668 else if (!isALPHA(*start) && (PL_expect == XTERM || PL_expect == XREF || PL_expect == XSTATE)) {
3672 gv = gv_fetchpv(s, FALSE, SVt_PVCV);
3675 s = scan_num(s, &yylval);
3682 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
3721 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3723 /* Some keywords can be followed by any delimiter, including ':' */
3724 tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
3725 (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
3726 (PL_tokenbuf[0] == 'q' &&
3727 strchr("qwxr", PL_tokenbuf[1])))));
3729 /* x::* is just a word, unless x is "CORE" */
3730 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
3734 while (d < PL_bufend && isSPACE(*d))
3735 d++; /* no comments skipped here, or s### is misparsed */
3737 /* Is this a label? */
3738 if (!tmp && PL_expect == XSTATE
3739 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
3741 yylval.pval = savepv(PL_tokenbuf);
3746 /* Check for keywords */
3747 tmp = keyword(PL_tokenbuf, len);
3749 /* Is this a word before a => operator? */
3750 if (*d == '=' && d[1] == '>') {
3752 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
3753 yylval.opval->op_private = OPpCONST_BARE;
3754 if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
3755 SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
3759 if (tmp < 0) { /* second-class keyword? */
3760 GV *ogv = Nullgv; /* override (winner) */
3761 GV *hgv = Nullgv; /* hidden (loser) */
3762 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3764 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3767 if (GvIMPORTED_CV(gv))
3769 else if (! CvMETHOD(cv))
3773 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3774 (gv = *gvp) != (GV*)&PL_sv_undef &&
3775 GvCVu(gv) && GvIMPORTED_CV(gv))
3781 tmp = 0; /* overridden by import or by GLOBAL */
3784 && -tmp==KEY_lock /* XXX generalizable kludge */
3786 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3788 tmp = 0; /* any sub overrides "weak" keyword */
3790 else { /* no override */
3794 if (ckWARN(WARN_AMBIGUOUS) && hgv
3795 && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3796 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3797 "Ambiguous call resolved as CORE::%s(), %s",
3798 GvENAME(hgv), "qualify as such or use &");
3805 default: /* not a keyword */
3809 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3811 /* Get the rest if it looks like a package qualifier */
3813 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
3815 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3818 Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
3819 *s == '\'' ? "'" : "::");
3824 if (PL_expect == XOPERATOR) {
3825 if (PL_bufptr == PL_linestart) {
3826 CopLINE_dec(PL_curcop);
3827 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3828 CopLINE_inc(PL_curcop);
3831 no_op("Bareword",s);
3834 /* Look for a subroutine with this name in current package,
3835 unless name is "Foo::", in which case Foo is a bearword
3836 (and a package name). */
3839 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3841 if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3842 Perl_warner(aTHX_ WARN_BAREWORD,
3843 "Bareword \"%s\" refers to nonexistent package",
3846 PL_tokenbuf[len] = '\0';
3853 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3856 /* if we saw a global override before, get the right name */
3859 sv = newSVpvn("CORE::GLOBAL::",14);
3860 sv_catpv(sv,PL_tokenbuf);
3863 sv = newSVpv(PL_tokenbuf,0);
3865 /* Presume this is going to be a bareword of some sort. */
3868 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3869 yylval.opval->op_private = OPpCONST_BARE;
3871 /* And if "Foo::", then that's what it certainly is. */
3876 /* See if it's the indirect object for a list operator. */
3878 if (PL_oldoldbufptr &&
3879 PL_oldoldbufptr < PL_bufptr &&
3880 (PL_oldoldbufptr == PL_last_lop
3881 || PL_oldoldbufptr == PL_last_uni) &&
3882 /* NO SKIPSPACE BEFORE HERE! */
3883 (PL_expect == XREF ||
3884 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
3886 bool immediate_paren = *s == '(';
3888 /* (Now we can afford to cross potential line boundary.) */
3891 /* Two barewords in a row may indicate method call. */
3893 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp=intuit_method(s,gv)))
3896 /* If not a declared subroutine, it's an indirect object. */
3897 /* (But it's an indir obj regardless for sort.) */
3899 if ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
3900 ((!gv || !GvCVu(gv)) &&
3901 (PL_last_lop_op != OP_MAPSTART &&
3902 PL_last_lop_op != OP_GREPSTART))))
3904 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3909 PL_expect = XOPERATOR;
3912 /* Is this a word before a => operator? */
3913 if (*s == '=' && s[1] == '>' && !pkgname) {
3915 sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
3916 if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
3917 SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
3921 /* If followed by a paren, it's certainly a subroutine. */
3924 if (gv && GvCVu(gv)) {
3925 for (d = s + 1; SPACE_OR_TAB(*d); d++) ;
3926 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
3931 PL_nextval[PL_nexttoke].opval = yylval.opval;
3932 PL_expect = XOPERATOR;
3938 /* If followed by var or block, call it a method (unless sub) */
3940 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3941 PL_last_lop = PL_oldbufptr;
3942 PL_last_lop_op = OP_METHOD;
3946 /* If followed by a bareword, see if it looks like indir obj. */
3948 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp = intuit_method(s,gv)))
3951 /* Not a method, so call it a subroutine (if defined) */
3953 if (gv && GvCVu(gv)) {
3955 if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
3956 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3957 "Ambiguous use of -%s resolved as -&%s()",
3958 PL_tokenbuf, PL_tokenbuf);
3959 /* Check for a constant sub */
3961 if ((sv = cv_const_sv(cv))) {
3963 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3964 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3965 yylval.opval->op_private = 0;
3969 /* Resolve to GV now. */
3970 op_free(yylval.opval);
3971 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3972 yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
3973 PL_last_lop = PL_oldbufptr;
3974 PL_last_lop_op = OP_ENTERSUB;
3975 /* Is there a prototype? */
3978 char *proto = SvPV((SV*)cv, len);
3981 if (strEQ(proto, "$"))
3983 if (*proto == '&' && *s == '{') {
3984 sv_setpv(PL_subname,"__ANON__");
3988 PL_nextval[PL_nexttoke].opval = yylval.opval;
3994 /* Call it a bare word */
3996 if (PL_hints & HINT_STRICT_SUBS)
3997 yylval.opval->op_private |= OPpCONST_STRICT;
4000 if (ckWARN(WARN_RESERVED)) {
4001 if (lastchar != '-') {
4002 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
4003 if (!*d && strNE(PL_tokenbuf,"main"))
4004 Perl_warner(aTHX_ WARN_RESERVED, PL_warn_reserved,
4011 if (lastchar && strchr("*%&", lastchar) && ckWARN_d(WARN_AMBIGUOUS)) {
4012 Perl_warner(aTHX_ WARN_AMBIGUOUS,
4013 "Operator or semicolon missing before %c%s",
4014 lastchar, PL_tokenbuf);
4015 Perl_warner(aTHX_ WARN_AMBIGUOUS,
4016 "Ambiguous use of %c resolved as operator %c",
4017 lastchar, lastchar);
4023 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4024 newSVpv(CopFILE(PL_curcop),0));
4028 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4029 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
4032 case KEY___PACKAGE__:
4033 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4035 ? newSVsv(PL_curstname)
4044 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
4045 char *pname = "main";
4046 if (PL_tokenbuf[2] == 'D')
4047 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
4048 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
4051 GvIOp(gv) = newIO();
4052 IoIFP(GvIOp(gv)) = PL_rsfp;
4053 #if defined(HAS_FCNTL) && defined(F_SETFD)
4055 int fd = PerlIO_fileno(PL_rsfp);
4056 fcntl(fd,F_SETFD,fd >= 3);
4059 /* Mark this internal pseudo-handle as clean */
4060 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
4062 IoTYPE(GvIOp(gv)) = IoTYPE_PIPE;
4063 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
4064 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
4066 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
4067 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
4068 /* if the script was opened in binmode, we need to revert
4069 * it to text mode for compatibility; but only iff it has CRs
4070 * XXX this is a questionable hack at best. */
4071 if (PL_bufend-PL_bufptr > 2
4072 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
4075 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
4076 loc = PerlIO_tell(PL_rsfp);
4077 (void)PerlIO_seek(PL_rsfp, 0L, 0);
4080 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
4082 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
4083 #endif /* NETWARE */
4084 #ifdef PERLIO_IS_STDIO /* really? */
4085 # if defined(__BORLANDC__)
4086 /* XXX see note in do_binmode() */
4087 ((FILE*)PL_rsfp)->flags &= ~_F_BIN;
4091 PerlIO_seek(PL_rsfp, loc, 0);
4095 #ifdef PERLIO_LAYERS
4096 if (UTF && !IN_BYTES)
4097 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
4110 if (PL_expect == XSTATE) {
4117 if (*s == ':' && s[1] == ':') {
4120 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4121 if (!(tmp = keyword(PL_tokenbuf, len)))
4122 Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
4136 LOP(OP_ACCEPT,XTERM);
4142 LOP(OP_ATAN2,XTERM);
4148 LOP(OP_BINMODE,XTERM);
4151 LOP(OP_BLESS,XTERM);
4160 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
4177 if (!PL_cryptseen) {
4178 PL_cryptseen = TRUE;
4182 LOP(OP_CRYPT,XTERM);
4185 LOP(OP_CHMOD,XTERM);
4188 LOP(OP_CHOWN,XTERM);
4191 LOP(OP_CONNECT,XTERM);
4207 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4211 PL_hints |= HINT_BLOCK_SCOPE;
4221 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
4222 LOP(OP_DBMOPEN,XTERM);
4228 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4235 yylval.ival = CopLINE(PL_curcop);
4249 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
4250 UNIBRACK(OP_ENTEREVAL);
4265 case KEY_endhostent:
4271 case KEY_endservent:
4274 case KEY_endprotoent:
4285 yylval.ival = CopLINE(PL_curcop);
4287 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
4289 if ((PL_bufend - p) >= 3 &&
4290 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
4292 else if ((PL_bufend - p) >= 4 &&
4293 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
4296 if (isIDFIRST_lazy_if(p,UTF)) {
4297 p = scan_ident(p, PL_bufend,
4298 PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4302 Perl_croak(aTHX_ "Missing $ on loop variable");
4307 LOP(OP_FORMLINE,XTERM);
4313 LOP(OP_FCNTL,XTERM);
4319 LOP(OP_FLOCK,XTERM);
4328 LOP(OP_GREPSTART, XREF);
4331 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4346 case KEY_getpriority:
4347 LOP(OP_GETPRIORITY,XTERM);
4349 case KEY_getprotobyname:
4352 case KEY_getprotobynumber:
4353 LOP(OP_GPBYNUMBER,XTERM);
4355 case KEY_getprotoent:
4367 case KEY_getpeername:
4368 UNI(OP_GETPEERNAME);
4370 case KEY_gethostbyname:
4373 case KEY_gethostbyaddr:
4374 LOP(OP_GHBYADDR,XTERM);
4376 case KEY_gethostent:
4379 case KEY_getnetbyname:
4382 case KEY_getnetbyaddr:
4383 LOP(OP_GNBYADDR,XTERM);
4388 case KEY_getservbyname:
4389 LOP(OP_GSBYNAME,XTERM);
4391 case KEY_getservbyport:
4392 LOP(OP_GSBYPORT,XTERM);
4394 case KEY_getservent:
4397 case KEY_getsockname:
4398 UNI(OP_GETSOCKNAME);
4400 case KEY_getsockopt:
4401 LOP(OP_GSOCKOPT,XTERM);
4423 yylval.ival = CopLINE(PL_curcop);
4427 LOP(OP_INDEX,XTERM);
4433 LOP(OP_IOCTL,XTERM);
4445 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4477 LOP(OP_LISTEN,XTERM);
4486 s = scan_pat(s,OP_MATCH);
4487 TERM(sublex_start());
4490 LOP(OP_MAPSTART, XREF);
4493 LOP(OP_MKDIR,XTERM);
4496 LOP(OP_MSGCTL,XTERM);
4499 LOP(OP_MSGGET,XTERM);
4502 LOP(OP_MSGRCV,XTERM);
4505 LOP(OP_MSGSND,XTERM);
4511 if (isIDFIRST_lazy_if(s,UTF)) {
4512 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
4513 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
4515 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
4516 if (!PL_in_my_stash) {
4519 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
4527 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4534 if (PL_expect != XSTATE)
4535 yyerror("\"no\" not allowed in expression");
4536 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4537 s = force_version(s);
4542 if (*s == '(' || (s = skipspace(s), *s == '('))
4549 if (isIDFIRST_lazy_if(s,UTF)) {
4551 for (d = s; isALNUM_lazy_if(d,UTF); d++) ;
4553 if (strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE))
4554 Perl_warner(aTHX_ WARN_PRECEDENCE,
4555 "Precedence problem: open %.*s should be open(%.*s)",
4561 yylval.ival = OP_OR;
4571 LOP(OP_OPEN_DIR,XTERM);
4574 checkcomma(s,PL_tokenbuf,"filehandle");
4578 checkcomma(s,PL_tokenbuf,"filehandle");
4597 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4601 LOP(OP_PIPE_OP,XTERM);
4604 s = scan_str(s,FALSE,FALSE);
4606 missingterm((char*)0);
4607 yylval.ival = OP_CONST;
4608 TERM(sublex_start());
4614 s = scan_str(s,FALSE,FALSE);
4616 missingterm((char*)0);
4618 if (SvCUR(PL_lex_stuff)) {
4621 d = SvPV_force(PL_lex_stuff, len);
4624 for (; isSPACE(*d) && len; --len, ++d) ;
4627 if (!warned && ckWARN(WARN_QW)) {
4628 for (; !isSPACE(*d) && len; --len, ++d) {
4630 Perl_warner(aTHX_ WARN_QW,
4631 "Possible attempt to separate words with commas");
4634 else if (*d == '#') {
4635 Perl_warner(aTHX_ WARN_QW,
4636 "Possible attempt to put comments in qw() list");
4642 for (; !isSPACE(*d) && len; --len, ++d) ;
4644 sv = newSVpvn(b, d-b);
4645 if (DO_UTF8(PL_lex_stuff))
4647 words = append_elem(OP_LIST, words,
4648 newSVOP(OP_CONST, 0, tokeq(sv)));
4652 PL_nextval[PL_nexttoke].opval = words;
4657 SvREFCNT_dec(PL_lex_stuff);
4658 PL_lex_stuff = Nullsv;
4664 s = scan_str(s,FALSE,FALSE);
4666 missingterm((char*)0);
4667 yylval.ival = OP_STRINGIFY;
4668 if (SvIVX(PL_lex_stuff) == '\'')
4669 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
4670 TERM(sublex_start());
4673 s = scan_pat(s,OP_QR);
4674 TERM(sublex_start());
4677 s = scan_str(s,FALSE,FALSE);
4679 missingterm((char*)0);
4680 yylval.ival = OP_BACKTICK;
4682 TERM(sublex_start());
4689 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4690 s = force_version(s);
4693 *PL_tokenbuf = '\0';
4694 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4695 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
4696 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
4698 yyerror("<> should be quotes");
4706 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4710 LOP(OP_RENAME,XTERM);
4719 LOP(OP_RINDEX,XTERM);
4742 LOP(OP_REVERSE,XTERM);
4753 TERM(sublex_start());
4755 TOKEN(1); /* force error */
4764 LOP(OP_SELECT,XTERM);
4770 LOP(OP_SEMCTL,XTERM);
4773 LOP(OP_SEMGET,XTERM);
4776 LOP(OP_SEMOP,XTERM);
4782 LOP(OP_SETPGRP,XTERM);
4784 case KEY_setpriority:
4785 LOP(OP_SETPRIORITY,XTERM);
4787 case KEY_sethostent:
4793 case KEY_setservent:
4796 case KEY_setprotoent:
4806 LOP(OP_SEEKDIR,XTERM);
4808 case KEY_setsockopt:
4809 LOP(OP_SSOCKOPT,XTERM);
4815 LOP(OP_SHMCTL,XTERM);
4818 LOP(OP_SHMGET,XTERM);
4821 LOP(OP_SHMREAD,XTERM);
4824 LOP(OP_SHMWRITE,XTERM);
4827 LOP(OP_SHUTDOWN,XTERM);
4836 LOP(OP_SOCKET,XTERM);
4838 case KEY_socketpair:
4839 LOP(OP_SOCKPAIR,XTERM);
4842 checkcomma(s,PL_tokenbuf,"subroutine name");
4844 if (*s == ';' || *s == ')') /* probably a close */
4845 Perl_croak(aTHX_ "sort is now a reserved word");
4847 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4851 LOP(OP_SPLIT,XTERM);
4854 LOP(OP_SPRINTF,XTERM);
4857 LOP(OP_SPLICE,XTERM);
4872 LOP(OP_SUBSTR,XTERM);
4878 char tmpbuf[sizeof PL_tokenbuf];
4879 SSize_t tboffset = 0;
4880 expectation attrful;
4881 bool have_name, have_proto;
4886 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
4887 (*s == ':' && s[1] == ':'))
4890 attrful = XATTRBLOCK;
4891 /* remember buffer pos'n for later force_word */
4892 tboffset = s - PL_oldbufptr;
4893 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4894 if (strchr(tmpbuf, ':'))
4895 sv_setpv(PL_subname, tmpbuf);
4897 sv_setsv(PL_subname,PL_curstname);
4898 sv_catpvn(PL_subname,"::",2);
4899 sv_catpvn(PL_subname,tmpbuf,len);
4906 Perl_croak(aTHX_ "Missing name in \"my sub\"");
4907 PL_expect = XTERMBLOCK;
4908 attrful = XATTRTERM;
4909 sv_setpv(PL_subname,"?");
4913 if (key == KEY_format) {
4915 PL_lex_formbrack = PL_lex_brackets + 1;
4917 (void) force_word(PL_oldbufptr + tboffset, WORD,
4922 /* Look for a prototype */
4926 s = scan_str(s,FALSE,FALSE);
4928 Perl_croak(aTHX_ "Prototype not terminated");
4930 d = SvPVX(PL_lex_stuff);
4932 for (p = d; *p; ++p) {
4937 SvCUR(PL_lex_stuff) = tmp;
4945 if (*s == ':' && s[1] != ':')
4946 PL_expect = attrful;
4949 PL_nextval[PL_nexttoke].opval =
4950 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4951 PL_lex_stuff = Nullsv;
4955 sv_setpv(PL_subname,"__ANON__");
4958 (void) force_word(PL_oldbufptr + tboffset, WORD,
4967 LOP(OP_SYSTEM,XREF);
4970 LOP(OP_SYMLINK,XTERM);
4973 LOP(OP_SYSCALL,XTERM);
4976 LOP(OP_SYSOPEN,XTERM);
4979 LOP(OP_SYSSEEK,XTERM);
4982 LOP(OP_SYSREAD,XTERM);
4985 LOP(OP_SYSWRITE,XTERM);
4989 TERM(sublex_start());
5010 LOP(OP_TRUNCATE,XTERM);
5022 yylval.ival = CopLINE(PL_curcop);
5026 yylval.ival = CopLINE(PL_curcop);
5030 LOP(OP_UNLINK,XTERM);
5036 LOP(OP_UNPACK,XTERM);
5039 LOP(OP_UTIME,XTERM);
5045 LOP(OP_UNSHIFT,XTERM);
5048 if (PL_expect != XSTATE)
5049 yyerror("\"use\" not allowed in expression");
5051 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
5052 s = force_version(s);
5053 if (*s == ';' || (s = skipspace(s), *s == ';')) {
5054 PL_nextval[PL_nexttoke].opval = Nullop;
5059 s = force_word(s,WORD,FALSE,TRUE,FALSE);
5060 s = force_version(s);
5072 yylval.ival = CopLINE(PL_curcop);
5076 PL_hints |= HINT_BLOCK_SCOPE;
5083 LOP(OP_WAITPID,XTERM);
5091 static char ctl_l[2];
5093 if (ctl_l[0] == '\0')
5094 ctl_l[0] = toCTRL('L');
5095 gv_fetchpv(ctl_l,TRUE, SVt_PV);
5098 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
5103 if (PL_expect == XOPERATOR)
5109 yylval.ival = OP_XOR;
5114 TERM(sublex_start());
5119 #pragma segment Main
5123 S_pending_ident(pTHX)
5127 /* pit holds the identifier we read and pending_ident is reset */
5128 char pit = PL_pending_ident;
5129 PL_pending_ident = 0;
5131 DEBUG_T({ PerlIO_printf(Perl_debug_log,
5132 "### Tokener saw identifier '%s'\n", PL_tokenbuf); });
5134 /* if we're in a my(), we can't allow dynamics here.
5135 $foo'bar has already been turned into $foo::bar, so
5136 just check for colons.
5138 if it's a legal name, the OP is a PADANY.
5141 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
5142 if (strchr(PL_tokenbuf,':'))
5143 yyerror(Perl_form(aTHX_ "No package name allowed for "
5144 "variable %s in \"our\"",
5146 tmp = pad_allocmy(PL_tokenbuf);
5149 if (strchr(PL_tokenbuf,':'))
5150 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
5152 yylval.opval = newOP(OP_PADANY, 0);
5153 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
5159 build the ops for accesses to a my() variable.
5161 Deny my($a) or my($b) in a sort block, *if* $a or $b is
5162 then used in a comparison. This catches most, but not
5163 all cases. For instance, it catches
5164 sort { my($a); $a <=> $b }
5166 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
5167 (although why you'd do that is anyone's guess).
5170 if (!strchr(PL_tokenbuf,':')) {
5171 #ifdef USE_5005THREADS
5172 /* Check for single character per-thread SVs */
5173 if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
5174 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
5175 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
5177 yylval.opval = newOP(OP_THREADSV, 0);
5178 yylval.opval->op_targ = tmp;
5181 #endif /* USE_5005THREADS */
5182 if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
5183 SV *namesv = AvARRAY(PL_comppad_name)[tmp];
5184 /* might be an "our" variable" */
5185 if (SvFLAGS(namesv) & SVpad_OUR) {
5186 /* build ops for a bareword */
5187 SV *sym = newSVpv(HvNAME(GvSTASH(namesv)),0);
5188 sv_catpvn(sym, "::", 2);
5189 sv_catpv(sym, PL_tokenbuf+1);
5190 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
5191 yylval.opval->op_private = OPpCONST_ENTERED;
5192 gv_fetchpv(SvPVX(sym),
5194 ? (GV_ADDMULTI | GV_ADDINEVAL)
5197 ((PL_tokenbuf[0] == '$') ? SVt_PV
5198 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5203 /* if it's a sort block and they're naming $a or $b */
5204 if (PL_last_lop_op == OP_SORT &&
5205 PL_tokenbuf[0] == '$' &&
5206 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
5209 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
5210 d < PL_bufend && *d != '\n';
5213 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
5214 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
5220 yylval.opval = newOP(OP_PADANY, 0);
5221 yylval.opval->op_targ = tmp;
5227 Whine if they've said @foo in a doublequoted string,
5228 and @foo isn't a variable we can find in the symbol
5231 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
5232 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
5233 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
5234 && ckWARN(WARN_AMBIGUOUS))
5236 /* Downgraded from fatal to warning 20000522 mjd */
5237 Perl_warner(aTHX_ WARN_AMBIGUOUS,
5238 "Possible unintended interpolation of %s in string",
5243 /* build ops for a bareword */
5244 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
5245 yylval.opval->op_private = OPpCONST_ENTERED;
5246 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
5247 ((PL_tokenbuf[0] == '$') ? SVt_PV
5248 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5254 Perl_keyword(pTHX_ register char *d, I32 len)
5259 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
5260 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
5261 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
5262 if (strEQ(d,"__DATA__")) return KEY___DATA__;
5263 if (strEQ(d,"__END__")) return KEY___END__;
5267 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
5272 if (strEQ(d,"and")) return -KEY_and;
5273 if (strEQ(d,"abs")) return -KEY_abs;
5276 if (strEQ(d,"alarm")) return -KEY_alarm;
5277 if (strEQ(d,"atan2")) return -KEY_atan2;
5280 if (strEQ(d,"accept")) return -KEY_accept;
5285 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
5288 if (strEQ(d,"bless")) return -KEY_bless;
5289 if (strEQ(d,"bind")) return -KEY_bind;
5290 if (strEQ(d,"binmode")) return -KEY_binmode;
5293 if (strEQ(d,"CORE")) return -KEY_CORE;
5294 if (strEQ(d,"CHECK")) return KEY_CHECK;
5299 if (strEQ(d,"cmp")) return -KEY_cmp;
5300 if (strEQ(d,"chr")) return -KEY_chr;
5301 if (strEQ(d,"cos")) return -KEY_cos;
5304 if (strEQ(d,"chop")) return -KEY_chop;
5307 if (strEQ(d,"close")) return -KEY_close;
5308 if (strEQ(d,"chdir")) return -KEY_chdir;
5309 if (strEQ(d,"chomp")) return -KEY_chomp;
5310 if (strEQ(d,"chmod")) return -KEY_chmod;
5311 if (strEQ(d,"chown")) return -KEY_chown;
5312 if (strEQ(d,"crypt")) return -KEY_crypt;
5315 if (strEQ(d,"chroot")) return -KEY_chroot;
5316 if (strEQ(d,"caller")) return -KEY_caller;
5319 if (strEQ(d,"connect")) return -KEY_connect;
5322 if (strEQ(d,"closedir")) return -KEY_closedir;
5323 if (strEQ(d,"continue")) return -KEY_continue;
5328 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
5333 if (strEQ(d,"do")) return KEY_do;
5336 if (strEQ(d,"die")) return -KEY_die;
5339 if (strEQ(d,"dump")) return -KEY_dump;
5342 if (strEQ(d,"delete")) return KEY_delete;
5345 if (strEQ(d,"defined")) return KEY_defined;
5346 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
5349 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
5354 if (strEQ(d,"END")) return KEY_END;
5359 if (strEQ(d,"eq")) return -KEY_eq;
5362 if (strEQ(d,"eof")) return -KEY_eof;
5363 if (strEQ(d,"exp")) return -KEY_exp;
5366 if (strEQ(d,"else")) return KEY_else;
5367 if (strEQ(d,"exit")) return -KEY_exit;
5368 if (strEQ(d,"eval")) return KEY_eval;
5369 if (strEQ(d,"exec")) return -KEY_exec;
5370 if (strEQ(d,"each")) return -KEY_each;
5373 if (strEQ(d,"elsif")) return KEY_elsif;
5376 if (strEQ(d,"exists")) return KEY_exists;
5377 if (strEQ(d,"elseif")) Perl_warn(aTHX_ "elseif should be elsif");
5380 if (strEQ(d,"endgrent")) return -KEY_endgrent;
5381 if (strEQ(d,"endpwent")) return -KEY_endpwent;
5384 if (strEQ(d,"endnetent")) return -KEY_endnetent;
5387 if (strEQ(d,"endhostent")) return -KEY_endhostent;
5388 if (strEQ(d,"endservent")) return -KEY_endservent;
5391 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
5398 if (strEQ(d,"for")) return KEY_for;
5401 if (strEQ(d,"fork")) return -KEY_fork;
5404 if (strEQ(d,"fcntl")) return -KEY_fcntl;
5405 if (strEQ(d,"flock")) return -KEY_flock;
5408 if (strEQ(d,"format")) return KEY_format;
5409 if (strEQ(d,"fileno")) return -KEY_fileno;
5412 if (strEQ(d,"foreach")) return KEY_foreach;
5415 if (strEQ(d,"formline")) return -KEY_formline;
5420 if (strnEQ(d,"get",3)) {
5425 if (strEQ(d,"ppid")) return -KEY_getppid;
5426 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
5429 if (strEQ(d,"pwent")) return -KEY_getpwent;
5430 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
5431 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
5434 if (strEQ(d,"peername")) return -KEY_getpeername;
5435 if (strEQ(d,"protoent")) return -KEY_getprotoent;
5436 if (strEQ(d,"priority")) return -KEY_getpriority;
5439 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
5442 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
5446 else if (*d == 'h') {
5447 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
5448 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
5449 if (strEQ(d,"hostent")) return -KEY_gethostent;
5451 else if (*d == 'n') {
5452 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
5453 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
5454 if (strEQ(d,"netent")) return -KEY_getnetent;
5456 else if (*d == 's') {
5457 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
5458 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
5459 if (strEQ(d,"servent")) return -KEY_getservent;
5460 if (strEQ(d,"sockname")) return -KEY_getsockname;
5461 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
5463 else if (*d == 'g') {
5464 if (strEQ(d,"grent")) return -KEY_getgrent;
5465 if (strEQ(d,"grnam")) return -KEY_getgrnam;
5466 if (strEQ(d,"grgid")) return -KEY_getgrgid;
5468 else if (*d == 'l') {
5469 if (strEQ(d,"login")) return -KEY_getlogin;
5471 else if (strEQ(d,"c")) return -KEY_getc;
5476 if (strEQ(d,"gt")) return -KEY_gt;
5477 if (strEQ(d,"ge")) return -KEY_ge;
5480 if (strEQ(d,"grep")) return KEY_grep;
5481 if (strEQ(d,"goto")) return KEY_goto;
5482 if (strEQ(d,"glob")) return KEY_glob;
5485 if (strEQ(d,"gmtime")) return -KEY_gmtime;
5490 if (strEQ(d,"hex")) return -KEY_hex;
5493 if (strEQ(d,"INIT")) return KEY_INIT;
5498 if (strEQ(d,"if")) return KEY_if;
5501 if (strEQ(d,"int")) return -KEY_int;
5504 if (strEQ(d,"index")) return -KEY_index;
5505 if (strEQ(d,"ioctl")) return -KEY_ioctl;
5510 if (strEQ(d,"join")) return -KEY_join;
5514 if (strEQ(d,"keys")) return -KEY_keys;
5515 if (strEQ(d,"kill")) return -KEY_kill;
5521 if (strEQ(d,"lt")) return -KEY_lt;
5522 if (strEQ(d,"le")) return -KEY_le;
5523 if (strEQ(d,"lc")) return -KEY_lc;
5526 if (strEQ(d,"log")) return -KEY_log;
5529 if (strEQ(d,"last")) return KEY_last;
5530 if (strEQ(d,"link")) return -KEY_link;
5531 if (strEQ(d,"lock")) return -KEY_lock;
5534 if (strEQ(d,"local")) return KEY_local;
5535 if (strEQ(d,"lstat")) return -KEY_lstat;
5538 if (strEQ(d,"length")) return -KEY_length;
5539 if (strEQ(d,"listen")) return -KEY_listen;
5542 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
5545 if (strEQ(d,"localtime")) return -KEY_localtime;
5551 case 1: return KEY_m;
5553 if (strEQ(d,"my")) return KEY_my;
5556 if (strEQ(d,"map")) return KEY_map;
5559 if (strEQ(d,"mkdir")) return -KEY_mkdir;
5562 if (strEQ(d,"msgctl")) return -KEY_msgctl;
5563 if (strEQ(d,"msgget")) return -KEY_msgget;
5564 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
5565 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
5570 if (strEQ(d,"next")) return KEY_next;
5571 if (strEQ(d,"ne")) return -KEY_ne;
5572 if (strEQ(d,"not")) return -KEY_not;
5573 if (strEQ(d,"no")) return KEY_no;
5578 if (strEQ(d,"or")) return -KEY_or;
5581 if (strEQ(d,"ord")) return -KEY_ord;
5582 if (strEQ(d,"oct")) return -KEY_oct;
5583 if (strEQ(d,"our")) return KEY_our;
5586 if (strEQ(d,"open")) return -KEY_open;
5589 if (strEQ(d,"opendir")) return -KEY_opendir;
5596 if (strEQ(d,"pop")) return -KEY_pop;
5597 if (strEQ(d,"pos")) return KEY_pos;
5600 if (strEQ(d,"push")) return -KEY_push;
5601 if (strEQ(d,"pack")) return -KEY_pack;
5602 if (strEQ(d,"pipe")) return -KEY_pipe;
5605 if (strEQ(d,"print")) return KEY_print;
5608 if (strEQ(d,"printf")) return KEY_printf;
5611 if (strEQ(d,"package")) return KEY_package;
5614 if (strEQ(d,"prototype")) return KEY_prototype;
5619 if (strEQ(d,"q")) return KEY_q;
5620 if (strEQ(d,"qr")) return KEY_qr;
5621 if (strEQ(d,"qq")) return KEY_qq;
5622 if (strEQ(d,"qw")) return KEY_qw;
5623 if (strEQ(d,"qx")) return KEY_qx;
5625 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
5630 if (strEQ(d,"ref")) return -KEY_ref;
5633 if (strEQ(d,"read")) return -KEY_read;
5634 if (strEQ(d,"rand")) return -KEY_rand;
5635 if (strEQ(d,"recv")) return -KEY_recv;
5636 if (strEQ(d,"redo")) return KEY_redo;
5639 if (strEQ(d,"rmdir")) return -KEY_rmdir;
5640 if (strEQ(d,"reset")) return -KEY_reset;
5643 if (strEQ(d,"return")) return KEY_return;
5644 if (strEQ(d,"rename")) return -KEY_rename;
5645 if (strEQ(d,"rindex")) return -KEY_rindex;
5648 if (strEQ(d,"require")) return KEY_require;
5649 if (strEQ(d,"reverse")) return -KEY_reverse;
5650 if (strEQ(d,"readdir")) return -KEY_readdir;
5653 if (strEQ(d,"readlink")) return -KEY_readlink;
5654 if (strEQ(d,"readline")) return -KEY_readline;
5655 if (strEQ(d,"readpipe")) return -KEY_readpipe;
5658 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
5664 case 0: return KEY_s;
5666 if (strEQ(d,"scalar")) return KEY_scalar;
5671 if (strEQ(d,"seek")) return -KEY_seek;
5672 if (strEQ(d,"send")) return -KEY_send;
5675 if (strEQ(d,"semop")) return -KEY_semop;
5678 if (strEQ(d,"select")) return -KEY_select;
5679 if (strEQ(d,"semctl")) return -KEY_semctl;
5680 if (strEQ(d,"semget")) return -KEY_semget;
5683 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
5684 if (strEQ(d,"seekdir")) return -KEY_seekdir;
5687 if (strEQ(d,"setpwent")) return -KEY_setpwent;
5688 if (strEQ(d,"setgrent")) return -KEY_setgrent;
5691 if (strEQ(d,"setnetent")) return -KEY_setnetent;
5694 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
5695 if (strEQ(d,"sethostent")) return -KEY_sethostent;
5696 if (strEQ(d,"setservent")) return -KEY_setservent;
5699 if (strEQ(d,"setpriority")) return -KEY_setpriority;
5700 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
5707 if (strEQ(d,"shift")) return -KEY_shift;
5710 if (strEQ(d,"shmctl")) return -KEY_shmctl;
5711 if (strEQ(d,"shmget")) return -KEY_shmget;
5714 if (strEQ(d,"shmread")) return -KEY_shmread;
5717 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
5718 if (strEQ(d,"shutdown")) return -KEY_shutdown;
5723 if (strEQ(d,"sin")) return -KEY_sin;
5726 if (strEQ(d,"sleep")) return -KEY_sleep;
5729 if (strEQ(d,"sort")) return KEY_sort;
5730 if (strEQ(d,"socket")) return -KEY_socket;
5731 if (strEQ(d,"socketpair")) return -KEY_socketpair;
5734 if (strEQ(d,"split")) return KEY_split;
5735 if (strEQ(d,"sprintf")) return -KEY_sprintf;
5736 if (strEQ(d,"splice")) return -KEY_splice;
5739 if (strEQ(d,"sqrt")) return -KEY_sqrt;
5742 if (strEQ(d,"srand")) return -KEY_srand;
5745 if (strEQ(d,"stat")) return -KEY_stat;
5746 if (strEQ(d,"study")) return KEY_study;
5749 if (strEQ(d,"substr")) return -KEY_substr;
5750 if (strEQ(d,"sub")) return KEY_sub;
5755 if (strEQ(d,"system")) return -KEY_system;
5758 if (strEQ(d,"symlink")) return -KEY_symlink;
5759 if (strEQ(d,"syscall")) return -KEY_syscall;
5760 if (strEQ(d,"sysopen")) return -KEY_sysopen;
5761 if (strEQ(d,"sysread")) return -KEY_sysread;
5762 if (strEQ(d,"sysseek")) return -KEY_sysseek;
5765 if (strEQ(d,"syswrite")) return -KEY_syswrite;
5774 if (strEQ(d,"tr")) return KEY_tr;
5777 if (strEQ(d,"tie")) return KEY_tie;
5780 if (strEQ(d,"tell")) return -KEY_tell;
5781 if (strEQ(d,"tied")) return KEY_tied;
5782 if (strEQ(d,"time")) return -KEY_time;
5785 if (strEQ(d,"times")) return -KEY_times;
5788 if (strEQ(d,"telldir")) return -KEY_telldir;
5791 if (strEQ(d,"truncate")) return -KEY_truncate;
5798 if (strEQ(d,"uc")) return -KEY_uc;
5801 if (strEQ(d,"use")) return KEY_use;
5804 if (strEQ(d,"undef")) return KEY_undef;
5805 if (strEQ(d,"until")) return KEY_until;
5806 if (strEQ(d,"untie")) return KEY_untie;
5807 if (strEQ(d,"utime")) return -KEY_utime;
5808 if (strEQ(d,"umask")) return -KEY_umask;
5811 if (strEQ(d,"unless")) return KEY_unless;
5812 if (strEQ(d,"unpack")) return -KEY_unpack;
5813 if (strEQ(d,"unlink")) return -KEY_unlink;
5816 if (strEQ(d,"unshift")) return -KEY_unshift;
5817 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
5822 if (strEQ(d,"values")) return -KEY_values;
5823 if (strEQ(d,"vec")) return -KEY_vec;
5828 if (strEQ(d,"warn")) return -KEY_warn;
5829 if (strEQ(d,"wait")) return -KEY_wait;
5832 if (strEQ(d,"while")) return KEY_while;
5833 if (strEQ(d,"write")) return -KEY_write;
5836 if (strEQ(d,"waitpid")) return -KEY_waitpid;
5839 if (strEQ(d,"wantarray")) return -KEY_wantarray;
5844 if (len == 1) return -KEY_x;
5845 if (strEQ(d,"xor")) return -KEY_xor;
5848 if (len == 1) return KEY_y;
5857 S_checkcomma(pTHX_ register char *s, char *name, char *what)
5861 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
5862 if (ckWARN(WARN_SYNTAX)) {
5864 for (w = s+2; *w && level; w++) {
5871 for (; *w && isSPACE(*w); w++) ;
5872 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
5873 Perl_warner(aTHX_ WARN_SYNTAX,
5874 "%s (...) interpreted as function",name);
5877 while (s < PL_bufend && isSPACE(*s))
5881 while (s < PL_bufend && isSPACE(*s))
5883 if (isIDFIRST_lazy_if(s,UTF)) {
5885 while (isALNUM_lazy_if(s,UTF))
5887 while (s < PL_bufend && isSPACE(*s))
5892 kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
5896 Perl_croak(aTHX_ "No comma allowed after %s", what);
5901 /* Either returns sv, or mortalizes sv and returns a new SV*.
5902 Best used as sv=new_constant(..., sv, ...).
5903 If s, pv are NULL, calls subroutine with one argument,
5904 and type is used with error messages only. */
5907 S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv,
5911 HV *table = GvHV(PL_hintgv); /* ^H */
5915 const char *why1, *why2, *why3;
5917 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
5920 why2 = strEQ(key,"charnames")
5921 ? "(possibly a missing \"use charnames ...\")"
5923 msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
5924 (type ? type: "undef"), why2);
5926 /* This is convoluted and evil ("goto considered harmful")
5927 * but I do not understand the intricacies of all the different
5928 * failure modes of %^H in here. The goal here is to make
5929 * the most probable error message user-friendly. --jhi */
5934 msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
5935 (type ? type: "undef"), why1, why2, why3);
5937 yyerror(SvPVX(msg));
5941 cvp = hv_fetch(table, key, strlen(key), FALSE);
5942 if (!cvp || !SvOK(*cvp)) {
5945 why3 = "} is not defined";
5948 sv_2mortal(sv); /* Parent created it permanently */
5951 pv = sv_2mortal(newSVpvn(s, len));
5953 typesv = sv_2mortal(newSVpv(type, 0));
5955 typesv = &PL_sv_undef;
5957 PUSHSTACKi(PERLSI_OVERLOAD);
5969 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
5973 /* Check the eval first */
5974 if (!PL_in_eval && SvTRUE(ERRSV)) {
5976 sv_catpv(ERRSV, "Propagated");
5977 yyerror(SvPV(ERRSV, n_a)); /* Duplicates the message inside eval */
5979 res = SvREFCNT_inc(sv);
5983 (void)SvREFCNT_inc(res);
5992 why1 = "Call to &{$^H{";
5994 why3 = "}} did not return a defined value";
6003 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
6005 register char *d = dest;
6006 register char *e = d + destlen - 3; /* two-character token, ending NUL */
6009 Perl_croak(aTHX_ ident_too_long);
6010 if (isALNUM(*s)) /* UTF handled below */
6012 else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) {
6017 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
6021 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
6022 char *t = s + UTF8SKIP(s);
6023 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
6025 if (d + (t - s) > e)
6026 Perl_croak(aTHX_ ident_too_long);
6027 Copy(s, d, t - s, char);
6040 S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
6050 e = d + destlen - 3; /* two-character token, ending NUL */
6052 while (isDIGIT(*s)) {
6054 Perl_croak(aTHX_ ident_too_long);
6061 Perl_croak(aTHX_ ident_too_long);
6062 if (isALNUM(*s)) /* UTF handled below */
6064 else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
6069 else if (*s == ':' && s[1] == ':') {
6073 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
6074 char *t = s + UTF8SKIP(s);
6075 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
6077 if (d + (t - s) > e)
6078 Perl_croak(aTHX_ ident_too_long);
6079 Copy(s, d, t - s, char);
6090 if (PL_lex_state != LEX_NORMAL)
6091 PL_lex_state = LEX_INTERPENDMAYBE;
6094 if (*s == '$' && s[1] &&
6095 (isALNUM_lazy_if(s+1,UTF) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
6108 if (*d == '^' && *s && isCONTROLVAR(*s)) {
6113 if (isSPACE(s[-1])) {
6116 if (!SPACE_OR_TAB(ch)) {
6122 if (isIDFIRST_lazy_if(d,UTF)) {
6126 while ((e < send && isALNUM_lazy_if(e,UTF)) || *e == ':') {
6128 while (e < send && UTF8_IS_CONTINUED(*e) && is_utf8_mark((U8*)e))
6131 Copy(s, d, e - s, char);
6136 while ((isALNUM(*s) || *s == ':') && d < e)
6139 Perl_croak(aTHX_ ident_too_long);
6142 while (s < send && SPACE_OR_TAB(*s)) s++;
6143 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
6144 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
6145 const char *brack = *s == '[' ? "[...]" : "{...}";
6146 Perl_warner(aTHX_ WARN_AMBIGUOUS,
6147 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
6148 funny, dest, brack, funny, dest, brack);
6151 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
6155 /* Handle extended ${^Foo} variables
6156 * 1999-02-27 mjd-perl-patch@plover.com */
6157 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
6161 while (isALNUM(*s) && d < e) {
6165 Perl_croak(aTHX_ ident_too_long);
6170 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
6171 PL_lex_state = LEX_INTERPEND;
6174 if (PL_lex_state == LEX_NORMAL) {
6175 if (ckWARN(WARN_AMBIGUOUS) &&
6176 (keyword(dest, d - dest) || get_cv(dest, FALSE)))
6178 Perl_warner(aTHX_ WARN_AMBIGUOUS,
6179 "Ambiguous use of %c{%s} resolved to %c%s",
6180 funny, dest, funny, dest);
6185 s = bracket; /* let the parser handle it */
6189 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
6190 PL_lex_state = LEX_INTERPEND;
6195 Perl_pmflag(pTHX_ U16 *pmfl, int ch)
6200 *pmfl |= PMf_GLOBAL;
6202 *pmfl |= PMf_CONTINUE;
6206 *pmfl |= PMf_MULTILINE;
6208 *pmfl |= PMf_SINGLELINE;
6210 *pmfl |= PMf_EXTENDED;
6214 S_scan_pat(pTHX_ char *start, I32 type)
6219 s = scan_str(start,FALSE,FALSE);
6221 Perl_croak(aTHX_ "Search pattern not terminated");
6223 pm = (PMOP*)newPMOP(type, 0);
6224 if (PL_multi_open == '?')
6225 pm->op_pmflags |= PMf_ONCE;
6227 while (*s && strchr("iomsx", *s))
6228 pmflag(&pm->op_pmflags,*s++);
6231 while (*s && strchr("iogcmsx", *s))
6232 pmflag(&pm->op_pmflags,*s++);
6234 pm->op_pmpermflags = pm->op_pmflags;
6236 PL_lex_op = (OP*)pm;
6237 yylval.ival = OP_MATCH;
6242 S_scan_subst(pTHX_ char *start)
6249 yylval.ival = OP_NULL;
6251 s = scan_str(start,FALSE,FALSE);
6254 Perl_croak(aTHX_ "Substitution pattern not terminated");
6256 if (s[-1] == PL_multi_open)
6259 first_start = PL_multi_start;
6260 s = scan_str(s,FALSE,FALSE);
6263 SvREFCNT_dec(PL_lex_stuff);
6264 PL_lex_stuff = Nullsv;
6266 Perl_croak(aTHX_ "Substitution replacement not terminated");
6268 PL_multi_start = first_start; /* so whole substitution is taken together */
6270 pm = (PMOP*)newPMOP(OP_SUBST, 0);
6276 else if (strchr("iogcmsx", *s))
6277 pmflag(&pm->op_pmflags,*s++);
6284 PL_sublex_info.super_bufptr = s;
6285 PL_sublex_info.super_bufend = PL_bufend;
6287 pm->op_pmflags |= PMf_EVAL;
6288 repl = newSVpvn("",0);
6290 sv_catpv(repl, es ? "eval " : "do ");
6291 sv_catpvn(repl, "{ ", 2);
6292 sv_catsv(repl, PL_lex_repl);
6293 sv_catpvn(repl, " };", 2);
6295 SvREFCNT_dec(PL_lex_repl);
6299 pm->op_pmpermflags = pm->op_pmflags;
6300 PL_lex_op = (OP*)pm;
6301 yylval.ival = OP_SUBST;
6306 S_scan_trans(pTHX_ char *start)
6315 yylval.ival = OP_NULL;
6317 s = scan_str(start,FALSE,FALSE);
6319 Perl_croak(aTHX_ "Transliteration pattern not terminated");
6320 if (s[-1] == PL_multi_open)
6323 s = scan_str(s,FALSE,FALSE);
6326 SvREFCNT_dec(PL_lex_stuff);
6327 PL_lex_stuff = Nullsv;
6329 Perl_croak(aTHX_ "Transliteration replacement not terminated");
6332 complement = del = squash = 0;
6333 while (strchr("cds", *s)) {
6335 complement = OPpTRANS_COMPLEMENT;
6337 del = OPpTRANS_DELETE;
6339 squash = OPpTRANS_SQUASH;
6343 New(803, tbl, complement&&!del?258:256, short);
6344 o = newPVOP(OP_TRANS, 0, (char*)tbl);
6345 o->op_private = del|squash|complement|
6346 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
6347 (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0);
6350 yylval.ival = OP_TRANS;
6355 S_scan_heredoc(pTHX_ register char *s)
6358 I32 op_type = OP_SCALAR;
6365 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
6369 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
6372 for (peek = s; SPACE_OR_TAB(*peek); peek++) ;
6373 if (*peek && strchr("`'\"",*peek)) {
6376 s = delimcpy(d, e, s, PL_bufend, term, &len);
6386 if (!isALNUM_lazy_if(s,UTF))
6387 deprecate("bare << to mean <<\"\"");
6388 for (; isALNUM_lazy_if(s,UTF); s++) {
6393 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
6394 Perl_croak(aTHX_ "Delimiter for here document is too long");
6397 len = d - PL_tokenbuf;
6398 #ifndef PERL_STRICT_CR
6399 d = strchr(s, '\r');
6403 while (s < PL_bufend) {
6409 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
6418 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6423 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
6424 herewas = newSVpvn(s,PL_bufend-s);
6426 s--, herewas = newSVpvn(s,d-s);
6427 s += SvCUR(herewas);
6429 tmpstr = NEWSV(87,79);
6430 sv_upgrade(tmpstr, SVt_PVIV);
6435 else if (term == '`') {
6436 op_type = OP_BACKTICK;
6437 SvIVX(tmpstr) = '\\';
6441 PL_multi_start = CopLINE(PL_curcop);
6442 PL_multi_open = PL_multi_close = '<';
6443 term = *PL_tokenbuf;
6444 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
6445 char *bufptr = PL_sublex_info.super_bufptr;
6446 char *bufend = PL_sublex_info.super_bufend;
6447 char *olds = s - SvCUR(herewas);
6448 s = strchr(bufptr, '\n');
6452 while (s < bufend &&
6453 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6455 CopLINE_inc(PL_curcop);
6458 CopLINE_set(PL_curcop, PL_multi_start);
6459 missingterm(PL_tokenbuf);
6461 sv_setpvn(herewas,bufptr,d-bufptr+1);
6462 sv_setpvn(tmpstr,d+1,s-d);
6464 sv_catpvn(herewas,s,bufend-s);
6465 (void)strcpy(bufptr,SvPVX(herewas));
6472 while (s < PL_bufend &&
6473 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6475 CopLINE_inc(PL_curcop);
6477 if (s >= PL_bufend) {
6478 CopLINE_set(PL_curcop, PL_multi_start);
6479 missingterm(PL_tokenbuf);
6481 sv_setpvn(tmpstr,d+1,s-d);
6483 CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
6485 sv_catpvn(herewas,s,PL_bufend-s);
6486 sv_setsv(PL_linestr,herewas);
6487 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
6488 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6489 PL_last_lop = PL_last_uni = Nullch;
6492 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
6493 while (s >= PL_bufend) { /* multiple line string? */
6495 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6496 CopLINE_set(PL_curcop, PL_multi_start);
6497 missingterm(PL_tokenbuf);
6499 CopLINE_inc(PL_curcop);
6500 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6501 PL_last_lop = PL_last_uni = Nullch;
6502 #ifndef PERL_STRICT_CR
6503 if (PL_bufend - PL_linestart >= 2) {
6504 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
6505 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
6507 PL_bufend[-2] = '\n';
6509 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6511 else if (PL_bufend[-1] == '\r')
6512 PL_bufend[-1] = '\n';
6514 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
6515 PL_bufend[-1] = '\n';
6517 if (PERLDB_LINE && PL_curstash != PL_debstash) {
6518 SV *sv = NEWSV(88,0);
6520 sv_upgrade(sv, SVt_PVMG);
6521 sv_setsv(sv,PL_linestr);
6522 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop),sv);
6524 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
6527 sv_catsv(PL_linestr,herewas);
6528 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6532 sv_catsv(tmpstr,PL_linestr);
6537 PL_multi_end = CopLINE(PL_curcop);
6538 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
6539 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
6540 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
6542 SvREFCNT_dec(herewas);
6543 if (UTF && !IN_BYTES && is_utf8_string((U8*)SvPVX(tmpstr), SvCUR(tmpstr)))
6545 PL_lex_stuff = tmpstr;
6546 yylval.ival = op_type;
6551 takes: current position in input buffer
6552 returns: new position in input buffer
6553 side-effects: yylval and lex_op are set.
6558 <FH> read from filehandle
6559 <pkg::FH> read from package qualified filehandle
6560 <pkg'FH> read from package qualified filehandle
6561 <$fh> read from filehandle in $fh
6567 S_scan_inputsymbol(pTHX_ char *start)
6569 register char *s = start; /* current position in buffer */
6575 d = PL_tokenbuf; /* start of temp holding space */
6576 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
6577 end = strchr(s, '\n');
6580 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
6582 /* die if we didn't have space for the contents of the <>,
6583 or if it didn't end, or if we see a newline
6586 if (len >= sizeof PL_tokenbuf)
6587 Perl_croak(aTHX_ "Excessively long <> operator");
6589 Perl_croak(aTHX_ "Unterminated <> operator");
6594 Remember, only scalar variables are interpreted as filehandles by
6595 this code. Anything more complex (e.g., <$fh{$num}>) will be
6596 treated as a glob() call.
6597 This code makes use of the fact that except for the $ at the front,
6598 a scalar variable and a filehandle look the same.
6600 if (*d == '$' && d[1]) d++;
6602 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
6603 while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
6606 /* If we've tried to read what we allow filehandles to look like, and
6607 there's still text left, then it must be a glob() and not a getline.
6608 Use scan_str to pull out the stuff between the <> and treat it
6609 as nothing more than a string.
6612 if (d - PL_tokenbuf != len) {
6613 yylval.ival = OP_GLOB;
6615 s = scan_str(start,FALSE,FALSE);
6617 Perl_croak(aTHX_ "Glob not terminated");
6621 /* we're in a filehandle read situation */
6624 /* turn <> into <ARGV> */
6626 (void)strcpy(d,"ARGV");
6628 /* if <$fh>, create the ops to turn the variable into a
6634 /* try to find it in the pad for this block, otherwise find
6635 add symbol table ops
6637 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
6638 OP *o = newOP(OP_PADSV, 0);
6640 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, o);
6643 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
6644 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
6645 newUNOP(OP_RV2SV, 0,
6646 newGVOP(OP_GV, 0, gv)));
6648 PL_lex_op->op_flags |= OPf_SPECIAL;
6649 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
6650 yylval.ival = OP_NULL;
6653 /* If it's none of the above, it must be a literal filehandle
6654 (<Foo::BAR> or <FOO>) so build a simple readline OP */
6656 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
6657 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
6658 yylval.ival = OP_NULL;
6667 takes: start position in buffer
6668 keep_quoted preserve \ on the embedded delimiter(s)
6669 keep_delims preserve the delimiters around the string
6670 returns: position to continue reading from buffer
6671 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
6672 updates the read buffer.
6674 This subroutine pulls a string out of the input. It is called for:
6675 q single quotes q(literal text)
6676 ' single quotes 'literal text'
6677 qq double quotes qq(interpolate $here please)
6678 " double quotes "interpolate $here please"
6679 qx backticks qx(/bin/ls -l)
6680 ` backticks `/bin/ls -l`
6681 qw quote words @EXPORT_OK = qw( func() $spam )
6682 m// regexp match m/this/
6683 s/// regexp substitute s/this/that/
6684 tr/// string transliterate tr/this/that/
6685 y/// string transliterate y/this/that/
6686 ($*@) sub prototypes sub foo ($)
6687 (stuff) sub attr parameters sub foo : attr(stuff)
6688 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
6690 In most of these cases (all but <>, patterns and transliterate)
6691 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
6692 calls scan_str(). s/// makes yylex() call scan_subst() which calls
6693 scan_str(). tr/// and y/// make yylex() call scan_trans() which
6696 It skips whitespace before the string starts, and treats the first
6697 character as the delimiter. If the delimiter is one of ([{< then
6698 the corresponding "close" character )]}> is used as the closing
6699 delimiter. It allows quoting of delimiters, and if the string has
6700 balanced delimiters ([{<>}]) it allows nesting.
6702 On success, the SV with the resulting string is put into lex_stuff or,
6703 if that is already non-NULL, into lex_repl. The second case occurs only
6704 when parsing the RHS of the special constructs s/// and tr/// (y///).
6705 For convenience, the terminating delimiter character is stuffed into
6710 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
6712 SV *sv; /* scalar value: string */
6713 char *tmps; /* temp string, used for delimiter matching */
6714 register char *s = start; /* current position in the buffer */
6715 register char term; /* terminating character */
6716 register char *to; /* current position in the sv's data */
6717 I32 brackets = 1; /* bracket nesting level */
6718 bool has_utf8 = FALSE; /* is there any utf8 content? */
6720 /* skip space before the delimiter */
6724 /* mark where we are, in case we need to report errors */
6727 /* after skipping whitespace, the next character is the terminator */
6729 if (!UTF8_IS_INVARIANT((U8)term) && UTF)
6732 /* mark where we are */
6733 PL_multi_start = CopLINE(PL_curcop);
6734 PL_multi_open = term;
6736 /* find corresponding closing delimiter */
6737 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
6739 PL_multi_close = term;
6741 /* create a new SV to hold the contents. 87 is leak category, I'm
6742 assuming. 79 is the SV's initial length. What a random number. */
6744 sv_upgrade(sv, SVt_PVIV);
6746 (void)SvPOK_only(sv); /* validate pointer */
6748 /* move past delimiter and try to read a complete string */
6750 sv_catpvn(sv, s, 1);
6753 /* extend sv if need be */
6754 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
6755 /* set 'to' to the next character in the sv's string */
6756 to = SvPVX(sv)+SvCUR(sv);
6758 /* if open delimiter is the close delimiter read unbridle */
6759 if (PL_multi_open == PL_multi_close) {
6760 for (; s < PL_bufend; s++,to++) {
6761 /* embedded newlines increment the current line number */
6762 if (*s == '\n' && !PL_rsfp)
6763 CopLINE_inc(PL_curcop);
6764 /* handle quoted delimiters */
6765 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
6766 if (!keep_quoted && s[1] == term)
6768 /* any other quotes are simply copied straight through */
6772 /* terminate when run out of buffer (the for() condition), or
6773 have found the terminator */
6774 else if (*s == term)
6776 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
6782 /* if the terminator isn't the same as the start character (e.g.,
6783 matched brackets), we have to allow more in the quoting, and
6784 be prepared for nested brackets.
6787 /* read until we run out of string, or we find the terminator */
6788 for (; s < PL_bufend; s++,to++) {
6789 /* embedded newlines increment the line count */
6790 if (*s == '\n' && !PL_rsfp)
6791 CopLINE_inc(PL_curcop);
6792 /* backslashes can escape the open or closing characters */
6793 if (*s == '\\' && s+1 < PL_bufend) {
6795 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
6800 /* allow nested opens and closes */
6801 else if (*s == PL_multi_close && --brackets <= 0)
6803 else if (*s == PL_multi_open)
6805 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
6810 /* terminate the copied string and update the sv's end-of-string */
6812 SvCUR_set(sv, to - SvPVX(sv));
6815 * this next chunk reads more into the buffer if we're not done yet
6819 break; /* handle case where we are done yet :-) */
6821 #ifndef PERL_STRICT_CR
6822 if (to - SvPVX(sv) >= 2) {
6823 if ((to[-2] == '\r' && to[-1] == '\n') ||
6824 (to[-2] == '\n' && to[-1] == '\r'))
6828 SvCUR_set(sv, to - SvPVX(sv));
6830 else if (to[-1] == '\r')
6833 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
6837 /* if we're out of file, or a read fails, bail and reset the current
6838 line marker so we can report where the unterminated string began
6841 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6843 CopLINE_set(PL_curcop, PL_multi_start);
6846 /* we read a line, so increment our line counter */
6847 CopLINE_inc(PL_curcop);
6849 /* update debugger info */
6850 if (PERLDB_LINE && PL_curstash != PL_debstash) {
6851 SV *sv = NEWSV(88,0);
6853 sv_upgrade(sv, SVt_PVMG);
6854 sv_setsv(sv,PL_linestr);
6855 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop), sv);
6858 /* having changed the buffer, we must update PL_bufend */
6859 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6860 PL_last_lop = PL_last_uni = Nullch;
6863 /* at this point, we have successfully read the delimited string */
6866 sv_catpvn(sv, s, 1);
6869 PL_multi_end = CopLINE(PL_curcop);
6872 /* if we allocated too much space, give some back */
6873 if (SvCUR(sv) + 5 < SvLEN(sv)) {
6874 SvLEN_set(sv, SvCUR(sv) + 1);
6875 Renew(SvPVX(sv), SvLEN(sv), char);
6878 /* decide whether this is the first or second quoted string we've read
6891 takes: pointer to position in buffer
6892 returns: pointer to new position in buffer
6893 side-effects: builds ops for the constant in yylval.op
6895 Read a number in any of the formats that Perl accepts:
6897 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
6898 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
6901 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
6903 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
6906 If it reads a number without a decimal point or an exponent, it will
6907 try converting the number to an integer and see if it can do so
6908 without loss of precision.
6912 Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp)
6914 register char *s = start; /* current position in buffer */
6915 register char *d; /* destination in temp buffer */
6916 register char *e; /* end of temp buffer */
6917 NV nv; /* number read, as a double */
6918 SV *sv = Nullsv; /* place to put the converted number */
6919 bool floatit; /* boolean: int or float? */
6920 char *lastub = 0; /* position of last underbar */
6921 static char number_too_long[] = "Number too long";
6923 /* We use the first character to decide what type of number this is */
6927 Perl_croak(aTHX_ "panic: scan_num");
6929 /* if it starts with a 0, it could be an octal number, a decimal in
6930 0.13 disguise, or a hexadecimal number, or a binary number. */
6934 u holds the "number so far"
6935 shift the power of 2 of the base
6936 (hex == 4, octal == 3, binary == 1)
6937 overflowed was the number more than we can hold?
6939 Shift is used when we add a digit. It also serves as an "are
6940 we in octal/hex/binary?" indicator to disallow hex characters
6946 bool overflowed = FALSE;
6947 static NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
6948 static char* bases[5] = { "", "binary", "", "octal",
6950 static char* Bases[5] = { "", "Binary", "", "Octal",
6952 static char *maxima[5] = { "",
6953 "0b11111111111111111111111111111111",
6957 char *base, *Base, *max;
6963 } else if (s[1] == 'b') {
6967 /* check for a decimal in disguise */
6968 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
6970 /* so it must be octal */
6977 if (ckWARN(WARN_SYNTAX))
6978 Perl_warner(aTHX_ WARN_SYNTAX,
6979 "Misplaced _ in number");
6983 base = bases[shift];
6984 Base = Bases[shift];
6985 max = maxima[shift];
6987 /* read the rest of the number */
6989 /* x is used in the overflow test,
6990 b is the digit we're adding on. */
6995 /* if we don't mention it, we're done */
6999 /* _ are ignored -- but warned about if consecutive */
7001 if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
7002 Perl_warner(aTHX_ WARN_SYNTAX,
7003 "Misplaced _ in number");
7007 /* 8 and 9 are not octal */
7010 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
7014 case '2': case '3': case '4':
7015 case '5': case '6': case '7':
7017 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
7021 b = *s++ & 15; /* ASCII digit -> value of digit */
7025 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
7026 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
7027 /* make sure they said 0x */
7032 /* Prepare to put the digit we have onto the end
7033 of the number so far. We check for overflows.
7038 x = u << shift; /* make room for the digit */
7040 if ((x >> shift) != u
7041 && !(PL_hints & HINT_NEW_BINARY)) {
7044 if (ckWARN_d(WARN_OVERFLOW))
7045 Perl_warner(aTHX_ WARN_OVERFLOW,
7046 "Integer overflow in %s number",
7049 u = x | b; /* add the digit to the end */
7052 n *= nvshift[shift];
7053 /* If an NV has not enough bits in its
7054 * mantissa to represent an UV this summing of
7055 * small low-order numbers is a waste of time
7056 * (because the NV cannot preserve the
7057 * low-order bits anyway): we could just
7058 * remember when did we overflow and in the
7059 * end just multiply n by the right
7067 /* if we get here, we had success: make a scalar value from
7072 /* final misplaced underbar check */
7074 if (ckWARN(WARN_SYNTAX))
7075 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
7080 if (ckWARN(WARN_PORTABLE) && n > 4294967295.0)
7081 Perl_warner(aTHX_ WARN_PORTABLE,
7082 "%s number > %s non-portable",
7088 if (ckWARN(WARN_PORTABLE) && u > 0xffffffff)
7089 Perl_warner(aTHX_ WARN_PORTABLE,
7090 "%s number > %s non-portable",
7095 if (PL_hints & HINT_NEW_BINARY)
7096 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
7101 handle decimal numbers.
7102 we're also sent here when we read a 0 as the first digit
7104 case '1': case '2': case '3': case '4': case '5':
7105 case '6': case '7': case '8': case '9': case '.':
7108 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
7111 /* read next group of digits and _ and copy into d */
7112 while (isDIGIT(*s) || *s == '_') {
7113 /* skip underscores, checking for misplaced ones
7117 if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
7118 Perl_warner(aTHX_ WARN_SYNTAX,
7119 "Misplaced _ in number");
7123 /* check for end of fixed-length buffer */
7125 Perl_croak(aTHX_ number_too_long);
7126 /* if we're ok, copy the character */
7131 /* final misplaced underbar check */
7132 if (lastub && s == lastub + 1) {
7133 if (ckWARN(WARN_SYNTAX))
7134 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
7137 /* read a decimal portion if there is one. avoid
7138 3..5 being interpreted as the number 3. followed
7141 if (*s == '.' && s[1] != '.') {
7146 if (ckWARN(WARN_SYNTAX))
7147 Perl_warner(aTHX_ WARN_SYNTAX,
7148 "Misplaced _ in number");
7152 /* copy, ignoring underbars, until we run out of digits.
7154 for (; isDIGIT(*s) || *s == '_'; s++) {
7155 /* fixed length buffer check */
7157 Perl_croak(aTHX_ number_too_long);
7159 if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
7160 Perl_warner(aTHX_ WARN_SYNTAX,
7161 "Misplaced _ in number");
7167 /* fractional part ending in underbar? */
7169 if (ckWARN(WARN_SYNTAX))
7170 Perl_warner(aTHX_ WARN_SYNTAX,
7171 "Misplaced _ in number");
7173 if (*s == '.' && isDIGIT(s[1])) {
7174 /* oops, it's really a v-string, but without the "v" */
7180 /* read exponent part, if present */
7181 if (*s && strchr("eE",*s) && strchr("+-0123456789_", s[1])) {
7185 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
7186 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
7188 /* stray preinitial _ */
7190 if (ckWARN(WARN_SYNTAX))
7191 Perl_warner(aTHX_ WARN_SYNTAX,
7192 "Misplaced _ in number");
7196 /* allow positive or negative exponent */
7197 if (*s == '+' || *s == '-')
7200 /* stray initial _ */
7202 if (ckWARN(WARN_SYNTAX))
7203 Perl_warner(aTHX_ WARN_SYNTAX,
7204 "Misplaced _ in number");
7208 /* read digits of exponent */
7209 while (isDIGIT(*s) || *s == '_') {
7212 Perl_croak(aTHX_ number_too_long);
7216 if (ckWARN(WARN_SYNTAX) &&
7217 ((lastub && s == lastub + 1) ||
7218 (!isDIGIT(s[1]) && s[1] != '_')))
7219 Perl_warner(aTHX_ WARN_SYNTAX,
7220 "Misplaced _ in number");
7227 /* make an sv from the string */
7231 We try to do an integer conversion first if no characters
7232 indicating "float" have been found.
7237 int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
7239 if (flags == IS_NUMBER_IN_UV) {
7241 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
7244 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
7245 if (uv <= (UV) IV_MIN)
7246 sv_setiv(sv, -(IV)uv);
7253 /* terminate the string */
7255 nv = Atof(PL_tokenbuf);
7259 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
7260 (PL_hints & HINT_NEW_INTEGER) )
7261 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
7262 (floatit ? "float" : "integer"),
7266 /* if it starts with a v, it could be a v-string */
7272 while (isDIGIT(*pos) || *pos == '_')
7274 if (!isALPHA(*pos)) {
7276 U8 tmpbuf[UTF8_MAXLEN+1];
7278 s++; /* get past 'v' */
7281 sv_setpvn(sv, "", 0);
7284 if (*s == '0' && isDIGIT(s[1]))
7285 yyerror("Octal number in vector unsupported");
7288 /* this is atoi() that tolerates underscores */
7291 while (--end >= s) {
7296 rev += (*end - '0') * mult;
7298 if (orev > rev && ckWARN_d(WARN_OVERFLOW))
7299 Perl_warner(aTHX_ WARN_OVERFLOW,
7300 "Integer overflow in decimal number");
7303 /* Append native character for the rev point */
7304 tmpend = uvchr_to_utf8(tmpbuf, rev);
7305 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
7306 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
7308 if (*pos == '.' && isDIGIT(pos[1]))
7314 while (isDIGIT(*pos) || *pos == '_')
7324 /* make the op for the constant and return */
7327 lvalp->opval = newSVOP(OP_CONST, 0, sv);
7329 lvalp->opval = Nullop;
7335 S_scan_formline(pTHX_ register char *s)
7339 SV *stuff = newSVpvn("",0);
7340 bool needargs = FALSE;
7343 if (*s == '.' || *s == /*{*/'}') {
7345 #ifdef PERL_STRICT_CR
7346 for (t = s+1;SPACE_OR_TAB(*t); t++) ;
7348 for (t = s+1;SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
7350 if (*t == '\n' || t == PL_bufend)
7353 if (PL_in_eval && !PL_rsfp) {
7354 eol = strchr(s,'\n');
7359 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7361 for (t = s; t < eol; t++) {
7362 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
7364 goto enough; /* ~~ must be first line in formline */
7366 if (*t == '@' || *t == '^')
7370 sv_catpvn(stuff, s, eol-s);
7371 #ifndef PERL_STRICT_CR
7372 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
7373 char *end = SvPVX(stuff) + SvCUR(stuff);
7385 s = filter_gets(PL_linestr, PL_rsfp, 0);
7386 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
7387 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
7388 PL_last_lop = PL_last_uni = Nullch;
7391 yyerror("Format not terminated");
7401 PL_lex_state = LEX_NORMAL;
7402 PL_nextval[PL_nexttoke].ival = 0;
7406 PL_lex_state = LEX_FORMLINE;
7407 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
7409 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
7413 SvREFCNT_dec(stuff);
7414 PL_lex_formbrack = 0;
7425 PL_cshlen = strlen(PL_cshname);
7430 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
7432 I32 oldsavestack_ix = PL_savestack_ix;
7433 CV* outsidecv = PL_compcv;
7437 assert(SvTYPE(PL_compcv) == SVt_PVCV);
7439 SAVEI32(PL_subline);
7440 save_item(PL_subname);
7443 SAVESPTR(PL_comppad_name);
7444 SAVESPTR(PL_compcv);
7445 SAVEI32(PL_comppad_name_fill);
7446 SAVEI32(PL_min_intro_pending);
7447 SAVEI32(PL_max_intro_pending);
7448 SAVEI32(PL_pad_reset_pending);
7450 PL_compcv = (CV*)NEWSV(1104,0);
7451 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
7452 CvFLAGS(PL_compcv) |= flags;
7454 PL_comppad = newAV();
7455 av_push(PL_comppad, Nullsv);
7456 PL_curpad = AvARRAY(PL_comppad);
7457 PL_comppad_name = newAV();
7458 PL_comppad_name_fill = 0;
7459 PL_min_intro_pending = 0;
7461 PL_subline = CopLINE(PL_curcop);
7462 #ifdef USE_5005THREADS
7463 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
7464 PL_curpad[0] = (SV*)newAV();
7465 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
7466 #endif /* USE_5005THREADS */
7468 comppadlist = newAV();
7469 AvREAL_off(comppadlist);
7470 av_store(comppadlist, 0, (SV*)PL_comppad_name);
7471 av_store(comppadlist, 1, (SV*)PL_comppad);
7473 CvPADLIST(PL_compcv) = comppadlist;
7474 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
7475 #ifdef USE_5005THREADS
7476 CvOWNER(PL_compcv) = 0;
7477 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
7478 MUTEX_INIT(CvMUTEXP(PL_compcv));
7479 #endif /* USE_5005THREADS */
7481 return oldsavestack_ix;
7485 #pragma segment Perl_yylex
7488 Perl_yywarn(pTHX_ char *s)
7490 PL_in_eval |= EVAL_WARNONLY;
7492 PL_in_eval &= ~EVAL_WARNONLY;
7497 Perl_yyerror(pTHX_ char *s)
7500 char *context = NULL;
7504 if (!yychar || (yychar == ';' && !PL_rsfp))
7506 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
7507 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
7508 while (isSPACE(*PL_oldoldbufptr))
7510 context = PL_oldoldbufptr;
7511 contlen = PL_bufptr - PL_oldoldbufptr;
7513 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
7514 PL_oldbufptr != PL_bufptr) {
7515 while (isSPACE(*PL_oldbufptr))
7517 context = PL_oldbufptr;
7518 contlen = PL_bufptr - PL_oldbufptr;
7520 else if (yychar > 255)
7521 where = "next token ???";
7522 #ifdef USE_PURE_BISON
7523 /* GNU Bison sets the value -2 */
7524 else if (yychar == -2) {
7526 else if ((yychar & 127) == 127) {
7528 if (PL_lex_state == LEX_NORMAL ||
7529 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
7530 where = "at end of line";
7531 else if (PL_lex_inpat)
7532 where = "within pattern";
7534 where = "within string";
7537 SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
7539 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
7540 else if (isPRINT_LC(yychar))
7541 Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
7543 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
7544 where = SvPVX(where_sv);
7546 msg = sv_2mortal(newSVpv(s, 0));
7547 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
7548 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
7550 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
7552 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
7553 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
7554 Perl_sv_catpvf(aTHX_ msg,
7555 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
7556 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
7559 if (PL_in_eval & EVAL_WARNONLY)
7560 Perl_warn(aTHX_ "%"SVf, msg);
7563 if (PL_error_count >= 10) {
7564 if (PL_in_eval && SvCUR(ERRSV))
7565 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
7566 ERRSV, CopFILE(PL_curcop));
7568 Perl_croak(aTHX_ "%s has too many errors.\n",
7569 CopFILE(PL_curcop));
7572 PL_in_my_stash = Nullhv;
7576 #pragma segment Main
7580 S_swallow_bom(pTHX_ U8 *s)
7583 slen = SvCUR(PL_linestr);
7587 /* UTF-16 little-endian */
7588 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
7589 Perl_croak(aTHX_ "Unsupported script encoding");
7590 #ifndef PERL_NO_UTF16_FILTER
7591 DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-LE script encoding\n"));
7593 if (PL_bufend > (char*)s) {
7597 filter_add(utf16rev_textfilter, NULL);
7598 New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
7599 PL_bufend = (char*)utf16_to_utf8_reversed(s, news,
7600 PL_bufend - (char*)s - 1,
7602 Copy(news, s, newlen, U8);
7603 SvCUR_set(PL_linestr, newlen);
7604 PL_bufend = SvPVX(PL_linestr) + newlen;
7605 news[newlen++] = '\0';
7609 Perl_croak(aTHX_ "Unsupported script encoding");
7614 if (s[1] == 0xFF) { /* UTF-16 big-endian */
7615 #ifndef PERL_NO_UTF16_FILTER
7616 DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding\n"));
7618 if (PL_bufend > (char *)s) {
7622 filter_add(utf16_textfilter, NULL);
7623 New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
7624 PL_bufend = (char*)utf16_to_utf8(s, news,
7625 PL_bufend - (char*)s,
7627 Copy(news, s, newlen, U8);
7628 SvCUR_set(PL_linestr, newlen);
7629 PL_bufend = SvPVX(PL_linestr) + newlen;
7630 news[newlen++] = '\0';
7634 Perl_croak(aTHX_ "Unsupported script encoding");
7639 if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
7640 DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-8 script encoding\n"));
7645 if (slen > 3 && s[1] == 0 && /* UTF-32 big-endian */
7646 s[2] == 0xFE && s[3] == 0xFF)
7648 Perl_croak(aTHX_ "Unsupported script encoding");
7656 * Restore a source filter.
7660 restore_rsfp(pTHX_ void *f)
7662 PerlIO *fp = (PerlIO*)f;
7664 if (PL_rsfp == PerlIO_stdin())
7665 PerlIO_clearerr(PL_rsfp);
7666 else if (PL_rsfp && (PL_rsfp != fp))
7667 PerlIO_close(PL_rsfp);
7671 #ifndef PERL_NO_UTF16_FILTER
7673 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
7675 I32 count = FILTER_READ(idx+1, sv, maxlen);
7680 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
7681 if (!*SvPV_nolen(sv))
7682 /* Game over, but don't feed an odd-length string to utf16_to_utf8 */
7685 tend = utf16_to_utf8((U8*)SvPVX(sv), tmps, SvCUR(sv), &newlen);
7686 sv_usepvn(sv, (char*)tmps, tend - tmps);
7692 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
7694 I32 count = FILTER_READ(idx+1, sv, maxlen);
7699 if (!*SvPV_nolen(sv))
7700 /* Game over, but don't feed an odd-length string to utf16_to_utf8 */
7703 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
7704 tend = utf16_to_utf8_reversed((U8*)SvPVX(sv), tmps, SvCUR(sv), &newlen);
7705 sv_usepvn(sv, (char*)tmps, tend - tmps);