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(pTHXo_ void *f);
31 #ifndef PERL_NO_UTF16_FILTER
32 static I32 utf16_textfilter(pTHXo_ int idx, SV *sv, int maxlen);
33 static I32 utf16rev_textfilter(pTHXo_ int idx, SV *sv, int maxlen);
36 #define XFAKEBRACK 128
39 /*#define UTF (SvUTF8(PL_linestr) && !(PL_hints & HINT_BYTE))*/
40 #define UTF (PL_hints & HINT_UTF8)
42 /* In variables name $^X, these are the legal values for X.
43 * 1999-02-27 mjd-perl-patch@plover.com */
44 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
46 /* On MacOS, respect nonbreaking spaces */
47 #ifdef MACOS_TRADITIONAL
48 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\312'||(c)=='\t')
50 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\t')
53 /* LEX_* are values for PL_lex_state, the state of the lexer.
54 * They are arranged oddly so that the guard on the switch statement
55 * can get by with a single comparison (if the compiler is smart enough).
58 /* #define LEX_NOTPARSING 11 is done in perl.h. */
61 #define LEX_INTERPNORMAL 9
62 #define LEX_INTERPCASEMOD 8
63 #define LEX_INTERPPUSH 7
64 #define LEX_INTERPSTART 6
65 #define LEX_INTERPEND 5
66 #define LEX_INTERPENDMAYBE 4
67 #define LEX_INTERPCONCAT 3
68 #define LEX_INTERPCONST 2
69 #define LEX_FORMLINE 1
70 #define LEX_KNOWNEXT 0
78 # define YYMAXLEVEL 100
80 YYSTYPE* yylval_pointer[YYMAXLEVEL];
81 int* yychar_pointer[YYMAXLEVEL];
85 # define yylval (*yylval_pointer[yyactlevel])
86 # define yychar (*yychar_pointer[yyactlevel])
87 # define PERL_YYLEX_PARAM yylval_pointer[yyactlevel],yychar_pointer[yyactlevel]
89 # define yylex() Perl_yylex_r(aTHX_ yylval_pointer[yyactlevel],yychar_pointer[yyactlevel])
94 /* CLINE is a macro that ensures PL_copline has a sane value */
99 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
102 * Convenience functions to return different tokens and prime the
103 * lexer for the next token. They all take an argument.
105 * TOKEN : generic token (used for '(', DOLSHARP, etc)
106 * OPERATOR : generic operator
107 * AOPERATOR : assignment operator
108 * PREBLOCK : beginning the block after an if, while, foreach, ...
109 * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
110 * PREREF : *EXPR where EXPR is not a simple identifier
111 * TERM : expression term
112 * LOOPX : loop exiting command (goto, last, dump, etc)
113 * FTST : file test operator
114 * FUN0 : zero-argument function
115 * FUN1 : not used, except for not, which isn't a UNIOP
116 * BOop : bitwise or or xor
118 * SHop : shift operator
119 * PWop : power operator
120 * PMop : pattern-matching operator
121 * Aop : addition-level operator
122 * Mop : multiplication-level operator
123 * Eop : equality-testing operator
124 * Rop : relational operator <= != gt
126 * Also see LOP and lop() below.
129 /* Note that REPORT() and REPORT2() will be expressions that supply
130 * their own trailing comma, not suitable for statements as such. */
131 #ifdef DEBUGGING /* Serve -DT. */
132 # define REPORT(x,retval) tokereport(x,s,(int)retval),
133 # define REPORT2(x,retval) tokereport(x,s, yylval.ival),
135 # define REPORT(x,retval)
136 # define REPORT2(x,retval)
139 #define TOKEN(retval) return (REPORT2("token",retval) PL_bufptr = s,(int)retval)
140 #define OPERATOR(retval) return (REPORT2("operator",retval) PL_expect = XTERM, PL_bufptr = s,(int)retval)
141 #define AOPERATOR(retval) return ao((REPORT2("aop",retval) PL_expect = XTERM, PL_bufptr = s,(int)retval))
142 #define PREBLOCK(retval) return (REPORT2("preblock",retval) PL_expect = XBLOCK,PL_bufptr = s,(int)retval)
143 #define PRETERMBLOCK(retval) return (REPORT2("pretermblock",retval) PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval)
144 #define PREREF(retval) return (REPORT2("preref",retval) PL_expect = XREF,PL_bufptr = s,(int)retval)
145 #define TERM(retval) return (CLINE, REPORT2("term",retval) PL_expect = XOPERATOR, PL_bufptr = s,(int)retval)
146 #define LOOPX(f) return(yylval.ival=f, REPORT("loopx",f) PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX)
147 #define FTST(f) return(yylval.ival=f, REPORT("ftst",f) PL_expect = XTERM,PL_bufptr = s,(int)UNIOP)
148 #define FUN0(f) return(yylval.ival = f, REPORT("fun0",f) PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0)
149 #define FUN1(f) return(yylval.ival = f, REPORT("fun1",f) PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1)
150 #define BOop(f) return ao((yylval.ival=f, REPORT("bitorop",f) PL_expect = XTERM,PL_bufptr = s,(int)BITOROP))
151 #define BAop(f) return ao((yylval.ival=f, REPORT("bitandop",f) PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP))
152 #define SHop(f) return ao((yylval.ival=f, REPORT("shiftop",f) PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP))
153 #define PWop(f) return ao((yylval.ival=f, REPORT("powop",f) PL_expect = XTERM,PL_bufptr = s,(int)POWOP))
154 #define PMop(f) return(yylval.ival=f, REPORT("matchop",f) PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP)
155 #define Aop(f) return ao((yylval.ival=f, REPORT("add",f) PL_expect = XTERM,PL_bufptr = s,(int)ADDOP))
156 #define Mop(f) return ao((yylval.ival=f, REPORT("mul",f) PL_expect = XTERM,PL_bufptr = s,(int)MULOP))
157 #define Eop(f) return(yylval.ival=f, REPORT("eq",f) PL_expect = XTERM,PL_bufptr = s,(int)EQOP)
158 #define Rop(f) return(yylval.ival=f, REPORT("rel",f) PL_expect = XTERM,PL_bufptr = s,(int)RELOP)
160 /* This bit of chicanery makes a unary function followed by
161 * a parenthesis into a function with one argument, highest precedence.
163 #define UNI(f) return(yylval.ival = f, \
167 PL_last_uni = PL_oldbufptr, \
168 PL_last_lop_op = f, \
169 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
171 #define UNIBRACK(f) return(yylval.ival = f, \
174 PL_last_uni = PL_oldbufptr, \
175 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
177 /* grandfather return to old style */
178 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
181 S_tokereport(pTHX_ char *thing, char* s, I32 rv)
185 report = newSVpv(thing, 0);
186 Perl_sv_catpvf(aTHX_ report, ":line %i:%i:", CopLINE(PL_curcop), rv);
188 if (s - PL_bufptr > 0)
189 sv_catpvn(report, PL_bufptr, s - PL_bufptr);
191 if (PL_oldbufptr && *PL_oldbufptr)
192 sv_catpv(report, PL_tokenbuf);
194 PerlIO_printf(Perl_debug_log, "### %s\n", SvPV_nolen(report));
201 * This subroutine detects &&= and ||= and turns an ANDAND or OROR
202 * into an OP_ANDASSIGN or OP_ORASSIGN
206 S_ao(pTHX_ int toketype)
208 if (*PL_bufptr == '=') {
210 if (toketype == ANDAND)
211 yylval.ival = OP_ANDASSIGN;
212 else if (toketype == OROR)
213 yylval.ival = OP_ORASSIGN;
221 * When Perl expects an operator and finds something else, no_op
222 * prints the warning. It always prints "<something> found where
223 * operator expected. It prints "Missing semicolon on previous line?"
224 * if the surprise occurs at the start of the line. "do you need to
225 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
226 * where the compiler doesn't know if foo is a method call or a function.
227 * It prints "Missing operator before end of line" if there's nothing
228 * after the missing operator, or "... before <...>" if there is something
229 * after the missing operator.
233 S_no_op(pTHX_ char *what, char *s)
235 char *oldbp = PL_bufptr;
236 bool is_first = (PL_oldbufptr == PL_linestart);
242 yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
244 Perl_warn(aTHX_ "\t(Missing semicolon on previous line?)\n");
245 else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
247 for (t = PL_oldoldbufptr; *t && (isALNUM_lazy_if(t,UTF) || *t == ':'); t++) ;
248 if (t < PL_bufptr && isSPACE(*t))
249 Perl_warn(aTHX_ "\t(Do you need to predeclare %.*s?)\n",
250 t - PL_oldoldbufptr, PL_oldoldbufptr);
254 Perl_warn(aTHX_ "\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
261 * Complain about missing quote/regexp/heredoc terminator.
262 * If it's called with (char *)NULL then it cauterizes the line buffer.
263 * If we're in a delimited string and the delimiter is a control
264 * character, it's reformatted into a two-char sequence like ^C.
269 S_missingterm(pTHX_ char *s)
274 char *nl = strrchr(s,'\n');
280 iscntrl(PL_multi_close)
282 PL_multi_close < 32 || PL_multi_close == 127
286 tmpbuf[1] = toCTRL(PL_multi_close);
292 *tmpbuf = PL_multi_close;
296 q = strchr(s,'"') ? '\'' : '"';
297 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
305 Perl_deprecate(pTHX_ char *s)
307 if (ckWARN(WARN_DEPRECATED))
308 Perl_warner(aTHX_ WARN_DEPRECATED, "Use of %s is deprecated", s);
313 * Deprecate a comma-less variable list.
319 deprecate("comma-less variable list");
323 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
324 * utf16-to-utf8-reversed.
327 #ifdef PERL_CR_FILTER
331 register char *s = SvPVX(sv);
332 register char *e = s + SvCUR(sv);
333 /* outer loop optimized to do nothing if there are no CR-LFs */
335 if (*s++ == '\r' && *s == '\n') {
336 /* hit a CR-LF, need to copy the rest */
337 register char *d = s - 1;
340 if (*s == '\r' && s[1] == '\n')
351 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
353 I32 count = FILTER_READ(idx+1, sv, maxlen);
354 if (count > 0 && !maxlen)
362 * Initialize variables. Uses the Perl save_stack to save its state (for
363 * recursive calls to the parser).
367 Perl_lex_start(pTHX_ SV *line)
372 SAVEI32(PL_lex_dojoin);
373 SAVEI32(PL_lex_brackets);
374 SAVEI32(PL_lex_casemods);
375 SAVEI32(PL_lex_starts);
376 SAVEI32(PL_lex_state);
377 SAVEVPTR(PL_lex_inpat);
378 SAVEI32(PL_lex_inwhat);
379 if (PL_lex_state == LEX_KNOWNEXT) {
380 I32 toke = PL_nexttoke;
381 while (--toke >= 0) {
382 SAVEI32(PL_nexttype[toke]);
383 SAVEVPTR(PL_nextval[toke]);
385 SAVEI32(PL_nexttoke);
387 SAVECOPLINE(PL_curcop);
390 SAVEPPTR(PL_oldbufptr);
391 SAVEPPTR(PL_oldoldbufptr);
392 SAVEPPTR(PL_last_lop);
393 SAVEPPTR(PL_last_uni);
394 SAVEPPTR(PL_linestart);
395 SAVESPTR(PL_linestr);
396 SAVEPPTR(PL_lex_brackstack);
397 SAVEPPTR(PL_lex_casestack);
398 SAVEDESTRUCTOR_X(restore_rsfp, PL_rsfp);
399 SAVESPTR(PL_lex_stuff);
400 SAVEI32(PL_lex_defer);
401 SAVEI32(PL_sublex_info.sub_inwhat);
402 SAVESPTR(PL_lex_repl);
404 SAVEINT(PL_lex_expect);
406 PL_lex_state = LEX_NORMAL;
410 New(899, PL_lex_brackstack, 120, char);
411 New(899, PL_lex_casestack, 12, char);
412 SAVEFREEPV(PL_lex_brackstack);
413 SAVEFREEPV(PL_lex_casestack);
415 *PL_lex_casestack = '\0';
418 PL_lex_stuff = Nullsv;
419 PL_lex_repl = Nullsv;
423 PL_sublex_info.sub_inwhat = 0;
425 if (SvREADONLY(PL_linestr))
426 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
427 s = SvPV(PL_linestr, len);
428 if (len && s[len-1] != ';') {
429 if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
430 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
431 sv_catpvn(PL_linestr, "\n;", 2);
433 SvTEMP_off(PL_linestr);
434 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
435 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
436 PL_last_lop = PL_last_uni = Nullch;
438 PL_rs = newSVpvn("\n", 1);
444 * Finalizer for lexing operations. Must be called when the parser is
445 * done with the lexer.
451 PL_doextract = FALSE;
456 * This subroutine has nothing to do with tilting, whether at windmills
457 * or pinball tables. Its name is short for "increment line". It
458 * increments the current line number in CopLINE(PL_curcop) and checks
459 * to see whether the line starts with a comment of the form
460 * # line 500 "foo.pm"
461 * If so, it sets the current line number and file to the values in the comment.
465 S_incline(pTHX_ char *s)
472 CopLINE_inc(PL_curcop);
475 while (SPACE_OR_TAB(*s)) s++;
476 if (strnEQ(s, "line", 4))
480 if (SPACE_OR_TAB(*s))
484 while (SPACE_OR_TAB(*s)) s++;
490 while (SPACE_OR_TAB(*s))
492 if (*s == '"' && (t = strchr(s+1, '"'))) {
497 for (t = s; !isSPACE(*t); t++) ;
500 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
502 if (*e != '\n' && *e != '\0')
503 return; /* false alarm */
509 Safefree(CopFILE(PL_curcop));
511 SvREFCNT_dec(CopFILEGV(PL_curcop));
513 CopFILE_set(PL_curcop, s);
516 CopLINE_set(PL_curcop, atoi(n)-1);
521 * Called to gobble the appropriate amount and type of whitespace.
522 * Skips comments as well.
526 S_skipspace(pTHX_ register char *s)
528 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
529 while (s < PL_bufend && SPACE_OR_TAB(*s))
535 SSize_t oldprevlen, oldoldprevlen;
536 SSize_t oldloplen, oldunilen;
537 while (s < PL_bufend && isSPACE(*s)) {
538 if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
543 if (s < PL_bufend && *s == '#') {
544 while (s < PL_bufend && *s != '\n')
548 if (PL_in_eval && !PL_rsfp) {
555 /* only continue to recharge the buffer if we're at the end
556 * of the buffer, we're not reading from a source filter, and
557 * we're in normal lexing mode
559 if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat ||
560 PL_lex_state == LEX_FORMLINE)
563 /* try to recharge the buffer */
564 if ((s = filter_gets(PL_linestr, PL_rsfp,
565 (prevlen = SvCUR(PL_linestr)))) == Nullch)
567 /* end of file. Add on the -p or -n magic */
568 if (PL_minus_n || PL_minus_p) {
569 sv_setpv(PL_linestr,PL_minus_p ?
570 ";}continue{print or die qq(-p destination: $!\\n)" :
572 sv_catpv(PL_linestr,";}");
573 PL_minus_n = PL_minus_p = 0;
576 sv_setpv(PL_linestr,";");
578 /* reset variables for next time we lex */
579 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
581 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
582 PL_last_lop = PL_last_uni = Nullch;
584 /* Close the filehandle. Could be from -P preprocessor,
585 * STDIN, or a regular file. If we were reading code from
586 * STDIN (because the commandline held no -e or filename)
587 * then we don't close it, we reset it so the code can
588 * read from STDIN too.
591 if (PL_preprocess && !PL_in_eval)
592 (void)PerlProc_pclose(PL_rsfp);
593 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
594 PerlIO_clearerr(PL_rsfp);
596 (void)PerlIO_close(PL_rsfp);
601 /* not at end of file, so we only read another line */
602 /* make corresponding updates to old pointers, for yyerror() */
603 oldprevlen = PL_oldbufptr - PL_bufend;
604 oldoldprevlen = PL_oldoldbufptr - PL_bufend;
606 oldunilen = PL_last_uni - PL_bufend;
608 oldloplen = PL_last_lop - PL_bufend;
609 PL_linestart = PL_bufptr = s + prevlen;
610 PL_bufend = s + SvCUR(PL_linestr);
612 PL_oldbufptr = s + oldprevlen;
613 PL_oldoldbufptr = s + oldoldprevlen;
615 PL_last_uni = s + oldunilen;
617 PL_last_lop = s + oldloplen;
620 /* debugger active and we're not compiling the debugger code,
621 * so store the line into the debugger's array of lines
623 if (PERLDB_LINE && PL_curstash != PL_debstash) {
624 SV *sv = NEWSV(85,0);
626 sv_upgrade(sv, SVt_PVMG);
627 sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
628 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
635 * Check the unary operators to ensure there's no ambiguity in how they're
636 * used. An ambiguous piece of code would be:
638 * This doesn't mean rand() + 5. Because rand() is a unary operator,
639 * the +5 is its argument.
648 if (PL_oldoldbufptr != PL_last_uni)
650 while (isSPACE(*PL_last_uni))
652 for (s = PL_last_uni; isALNUM_lazy_if(s,UTF) || *s == '-'; s++) ;
653 if ((t = strchr(s, '(')) && t < PL_bufptr)
655 if (ckWARN_d(WARN_AMBIGUOUS)){
658 Perl_warner(aTHX_ WARN_AMBIGUOUS,
659 "Warning: Use of \"%s\" without parens is ambiguous",
665 /* workaround to replace the UNI() macro with a function. Only the
666 * hints/uts.sh file mentions this. Other comments elsewhere in the
667 * source indicate Microport Unix might need it too.
673 #define UNI(f) return uni(f,s)
676 S_uni(pTHX_ I32 f, char *s)
681 PL_last_uni = PL_oldbufptr;
692 #endif /* CRIPPLED_CC */
695 * LOP : macro to build a list operator. Its behaviour has been replaced
696 * with a subroutine, S_lop() for which LOP is just another name.
699 #define LOP(f,x) return lop(f,x,s)
703 * Build a list operator (or something that might be one). The rules:
704 * - if we have a next token, then it's a list operator [why?]
705 * - if the next thing is an opening paren, then it's a function
706 * - else it's a list operator
710 S_lop(pTHX_ I32 f, int x, char *s)
717 PL_last_lop = PL_oldbufptr;
732 * When the lexer realizes it knows the next token (for instance,
733 * it is reordering tokens for the parser) then it can call S_force_next
734 * to know what token to return the next time the lexer is called. Caller
735 * will need to set PL_nextval[], and possibly PL_expect to ensure the lexer
736 * handles the token correctly.
740 S_force_next(pTHX_ I32 type)
742 PL_nexttype[PL_nexttoke] = type;
744 if (PL_lex_state != LEX_KNOWNEXT) {
745 PL_lex_defer = PL_lex_state;
746 PL_lex_expect = PL_expect;
747 PL_lex_state = LEX_KNOWNEXT;
753 * When the lexer knows the next thing is a word (for instance, it has
754 * just seen -> and it knows that the next char is a word char, then
755 * it calls S_force_word to stick the next word into the PL_next lookahead.
758 * char *start : buffer position (must be within PL_linestr)
759 * int token : PL_next will be this type of bare word (e.g., METHOD,WORD)
760 * int check_keyword : if true, Perl checks to make sure the word isn't
761 * a keyword (do this if the word is a label, e.g. goto FOO)
762 * int allow_pack : if true, : characters will also be allowed (require,
764 * int allow_initial_tick : used by the "sub" lexer only.
768 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
773 start = skipspace(start);
775 if (isIDFIRST_lazy_if(s,UTF) ||
776 (allow_pack && *s == ':') ||
777 (allow_initial_tick && *s == '\'') )
779 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
780 if (check_keyword && keyword(PL_tokenbuf, len))
782 if (token == METHOD) {
787 PL_expect = XOPERATOR;
790 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(PL_tokenbuf,0));
791 PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
799 * Called when the lexer wants $foo *foo &foo etc, but the program
800 * text only contains the "foo" portion. The first argument is a pointer
801 * to the "foo", and the second argument is the type symbol to prefix.
802 * Forces the next token to be a "WORD".
803 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
807 S_force_ident(pTHX_ register char *s, int kind)
810 OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
811 PL_nextval[PL_nexttoke].opval = o;
814 o->op_private = OPpCONST_ENTERED;
815 /* XXX see note in pp_entereval() for why we forgo typo
816 warnings if the symbol must be introduced in an eval.
818 gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
819 kind == '$' ? SVt_PV :
820 kind == '@' ? SVt_PVAV :
821 kind == '%' ? SVt_PVHV :
829 Perl_str_to_version(pTHX_ SV *sv)
834 char *start = SvPVx(sv,len);
835 bool utf = SvUTF8(sv) ? TRUE : FALSE;
836 char *end = start + len;
837 while (start < end) {
841 n = utf8_to_uv((U8*)start, len, &skip, 0);
846 retval += ((NV)n)/nshift;
855 * Forces the next token to be a version number.
859 S_force_version(pTHX_ char *s)
861 OP *version = Nullop;
870 for (; isDIGIT(*d) || *d == '_' || *d == '.'; d++);
871 if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
873 s = scan_num(s, &yylval);
874 version = yylval.opval;
875 ver = cSVOPx(version)->op_sv;
876 if (SvPOK(ver) && !SvNIOK(ver)) {
877 (void)SvUPGRADE(ver, SVt_PVNV);
878 SvNVX(ver) = str_to_version(ver);
879 SvNOK_on(ver); /* hint that it is a version */
884 /* NOTE: The parser sees the package name and the VERSION swapped */
885 PL_nextval[PL_nexttoke].opval = version;
893 * Tokenize a quoted string passed in as an SV. It finds the next
894 * chunk, up to end of string or a backslash. It may make a new
895 * SV containing that chunk (if HINT_NEW_STRING is on). It also
900 S_tokeq(pTHX_ SV *sv)
911 s = SvPV_force(sv, len);
912 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
915 while (s < send && *s != '\\')
920 if ( PL_hints & HINT_NEW_STRING )
921 pv = sv_2mortal(newSVpvn(SvPVX(pv), len));
924 if (s + 1 < send && (s[1] == '\\'))
925 s++; /* all that, just for this */
930 SvCUR_set(sv, d - SvPVX(sv));
932 if ( PL_hints & HINT_NEW_STRING )
933 return new_constant(NULL, 0, "q", sv, pv, "q");
938 * Now come three functions related to double-quote context,
939 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
940 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
941 * interact with PL_lex_state, and create fake ( ... ) argument lists
942 * to handle functions and concatenation.
943 * They assume that whoever calls them will be setting up a fake
944 * join call, because each subthing puts a ',' after it. This lets
947 * join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
949 * (I'm not sure whether the spurious commas at the end of lcfirst's
950 * arguments and join's arguments are created or not).
955 * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST).
957 * Pattern matching will set PL_lex_op to the pattern-matching op to
958 * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise).
960 * OP_CONST and OP_READLINE are easy--just make the new op and return.
962 * Everything else becomes a FUNC.
964 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
965 * had an OP_CONST or OP_READLINE). This just sets us up for a
966 * call to S_sublex_push().
972 register I32 op_type = yylval.ival;
974 if (op_type == OP_NULL) {
975 yylval.opval = PL_lex_op;
979 if (op_type == OP_CONST || op_type == OP_READLINE) {
980 SV *sv = tokeq(PL_lex_stuff);
982 if (SvTYPE(sv) == SVt_PVIV) {
983 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
989 nsv = newSVpvn(p, len);
995 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
996 PL_lex_stuff = Nullsv;
1000 PL_sublex_info.super_state = PL_lex_state;
1001 PL_sublex_info.sub_inwhat = op_type;
1002 PL_sublex_info.sub_op = PL_lex_op;
1003 PL_lex_state = LEX_INTERPPUSH;
1007 yylval.opval = PL_lex_op;
1017 * Create a new scope to save the lexing state. The scope will be
1018 * ended in S_sublex_done. Returns a '(', starting the function arguments
1019 * to the uc, lc, etc. found before.
1020 * Sets PL_lex_state to LEX_INTERPCONCAT.
1028 PL_lex_state = PL_sublex_info.super_state;
1029 SAVEI32(PL_lex_dojoin);
1030 SAVEI32(PL_lex_brackets);
1031 SAVEI32(PL_lex_casemods);
1032 SAVEI32(PL_lex_starts);
1033 SAVEI32(PL_lex_state);
1034 SAVEVPTR(PL_lex_inpat);
1035 SAVEI32(PL_lex_inwhat);
1036 SAVECOPLINE(PL_curcop);
1037 SAVEPPTR(PL_bufptr);
1038 SAVEPPTR(PL_oldbufptr);
1039 SAVEPPTR(PL_oldoldbufptr);
1040 SAVEPPTR(PL_last_lop);
1041 SAVEPPTR(PL_last_uni);
1042 SAVEPPTR(PL_linestart);
1043 SAVESPTR(PL_linestr);
1044 SAVEPPTR(PL_lex_brackstack);
1045 SAVEPPTR(PL_lex_casestack);
1047 PL_linestr = PL_lex_stuff;
1048 PL_lex_stuff = Nullsv;
1050 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
1051 = SvPVX(PL_linestr);
1052 PL_bufend += SvCUR(PL_linestr);
1053 PL_last_lop = PL_last_uni = Nullch;
1054 SAVEFREESV(PL_linestr);
1056 PL_lex_dojoin = FALSE;
1057 PL_lex_brackets = 0;
1058 New(899, PL_lex_brackstack, 120, char);
1059 New(899, PL_lex_casestack, 12, char);
1060 SAVEFREEPV(PL_lex_brackstack);
1061 SAVEFREEPV(PL_lex_casestack);
1062 PL_lex_casemods = 0;
1063 *PL_lex_casestack = '\0';
1065 PL_lex_state = LEX_INTERPCONCAT;
1066 CopLINE_set(PL_curcop, PL_multi_start);
1068 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1069 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1070 PL_lex_inpat = PL_sublex_info.sub_op;
1072 PL_lex_inpat = Nullop;
1079 * Restores lexer state after a S_sublex_push.
1085 if (!PL_lex_starts++) {
1086 SV *sv = newSVpvn("",0);
1087 if (SvUTF8(PL_linestr))
1089 PL_expect = XOPERATOR;
1090 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1094 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
1095 PL_lex_state = LEX_INTERPCASEMOD;
1099 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1100 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1101 PL_linestr = PL_lex_repl;
1103 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1104 PL_bufend += SvCUR(PL_linestr);
1105 PL_last_lop = PL_last_uni = Nullch;
1106 SAVEFREESV(PL_linestr);
1107 PL_lex_dojoin = FALSE;
1108 PL_lex_brackets = 0;
1109 PL_lex_casemods = 0;
1110 *PL_lex_casestack = '\0';
1112 if (SvEVALED(PL_lex_repl)) {
1113 PL_lex_state = LEX_INTERPNORMAL;
1115 /* we don't clear PL_lex_repl here, so that we can check later
1116 whether this is an evalled subst; that means we rely on the
1117 logic to ensure sublex_done() is called again only via the
1118 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1121 PL_lex_state = LEX_INTERPCONCAT;
1122 PL_lex_repl = Nullsv;
1128 PL_bufend = SvPVX(PL_linestr);
1129 PL_bufend += SvCUR(PL_linestr);
1130 PL_expect = XOPERATOR;
1131 PL_sublex_info.sub_inwhat = 0;
1139 Extracts a pattern, double-quoted string, or transliteration. This
1142 It looks at lex_inwhat and PL_lex_inpat to find out whether it's
1143 processing a pattern (PL_lex_inpat is true), a transliteration
1144 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
1146 Returns a pointer to the character scanned up to. Iff this is
1147 advanced from the start pointer supplied (ie if anything was
1148 successfully parsed), will leave an OP for the substring scanned
1149 in yylval. Caller must intuit reason for not parsing further
1150 by looking at the next characters herself.
1154 double-quoted style: \r and \n
1155 regexp special ones: \D \s
1157 backrefs: \1 (deprecated in substitution replacements)
1158 case and quoting: \U \Q \E
1159 stops on @ and $, but not for $ as tail anchor
1161 In transliterations:
1162 characters are VERY literal, except for - not at the start or end
1163 of the string, which indicates a range. scan_const expands the
1164 range to the full set of intermediate characters.
1166 In double-quoted strings:
1168 double-quoted style: \r and \n
1170 backrefs: \1 (deprecated)
1171 case and quoting: \U \Q \E
1174 scan_const does *not* construct ops to handle interpolated strings.
1175 It stops processing as soon as it finds an embedded $ or @ variable
1176 and leaves it to the caller to work out what's going on.
1178 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
1180 $ in pattern could be $foo or could be tail anchor. Assumption:
1181 it's a tail anchor if $ is the last thing in the string, or if it's
1182 followed by one of ")| \n\t"
1184 \1 (backreferences) are turned into $1
1186 The structure of the code is
1187 while (there's a character to process) {
1188 handle transliteration ranges
1189 skip regexp comments
1190 skip # initiated comments in //x patterns
1191 check for embedded @foo
1192 check for embedded scalars
1194 leave intact backslashes from leave (below)
1195 deprecate \1 in strings and sub replacements
1196 handle string-changing backslashes \l \U \Q \E, etc.
1197 switch (what was escaped) {
1198 handle - in a transliteration (becomes a literal -)
1199 handle \132 octal characters
1200 handle 0x15 hex characters
1201 handle \cV (control V)
1202 handle printf backslashes (\f, \r, \n, etc)
1204 } (end if backslash)
1205 } (end while character to read)
1210 S_scan_const(pTHX_ char *start)
1212 register char *send = PL_bufend; /* end of the constant */
1213 SV *sv = NEWSV(93, send - start); /* sv for the constant */
1214 register char *s = start; /* start of the constant */
1215 register char *d = SvPVX(sv); /* destination for copies */
1216 bool dorange = FALSE; /* are we in a translit range? */
1217 bool didrange = FALSE; /* did we just finish a range? */
1218 bool has_utf8 = (PL_linestr && SvUTF8(PL_linestr));
1219 /* the constant is UTF8 */
1222 I32 utf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op)
1223 ? (PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
1225 I32 this_utf8 = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op)
1226 ? (PL_sublex_info.sub_op->op_private & (PL_lex_repl ?
1227 OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF))
1229 const char *leaveit = /* set of acceptably-backslashed characters */
1231 ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
1234 while (s < send || dorange) {
1235 /* get transliterations out of the way (they're most literal) */
1236 if (PL_lex_inwhat == OP_TRANS) {
1237 /* expand a range A-Z to the full set of characters. AIE! */
1239 I32 i; /* current expanded character */
1240 I32 min; /* first character in range */
1241 I32 max; /* last character in range */
1244 char *c = (char*)utf8_hop((U8*)d, -1);
1249 /* mark the range as done, and continue */
1254 i = d - SvPVX(sv); /* remember current offset */
1255 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
1256 d = SvPVX(sv) + i; /* refresh d after realloc */
1257 d -= 2; /* eat the first char and the - */
1259 min = (U8)*d; /* first char in range */
1260 max = (U8)d[1]; /* last char in range */
1264 "Invalid [] range \"%c-%c\" in transliteration operator",
1265 (char)min, (char)max);
1269 if ((isLOWER(min) && isLOWER(max)) ||
1270 (isUPPER(min) && isUPPER(max))) {
1272 for (i = min; i <= max; i++)
1276 for (i = min; i <= max; i++)
1283 for (i = min; i <= max; i++)
1286 /* mark the range as done, and continue */
1292 /* range begins (ignore - as first or last char) */
1293 else if (*s == '-' && s+1 < send && s != start) {
1295 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
1298 *d++ = (char)0xff; /* use illegal utf8 byte--see pmtrans */
1310 /* if we get here, we're not doing a transliteration */
1312 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
1313 except for the last char, which will be done separately. */
1314 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
1316 while (s < send && *s != ')')
1319 else if (s[2] == '{' /* This should match regcomp.c */
1320 || ((s[2] == 'p' || s[2] == '?') && s[3] == '{'))
1323 char *regparse = s + (s[2] == '{' ? 3 : 4);
1326 while (count && (c = *regparse)) {
1327 if (c == '\\' && regparse[1])
1335 if (*regparse != ')') {
1336 regparse--; /* Leave one char for continuation. */
1337 yyerror("Sequence (?{...}) not terminated or not {}-balanced");
1339 while (s < regparse)
1344 /* likewise skip #-initiated comments in //x patterns */
1345 else if (*s == '#' && PL_lex_inpat &&
1346 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
1347 while (s+1 < send && *s != '\n')
1351 /* check for embedded arrays
1352 (@foo, @:foo, @'foo, @{foo}, @$foo, @+, @-)
1354 else if (*s == '@' && s[1]
1355 && (isALNUM_lazy_if(s+1,UTF) || strchr(":'{$+-", s[1])))
1358 /* check for embedded scalars. only stop if we're sure it's a
1361 else if (*s == '$') {
1362 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
1364 if (s + 1 < send && !strchr("()| \n\t", s[1]))
1365 break; /* in regexp, $ might be tail anchor */
1369 if (*s == '\\' && s+1 < send) {
1372 /* some backslashes we leave behind */
1373 if (*leaveit && *s && strchr(leaveit, *s)) {
1379 /* deprecate \1 in strings and substitution replacements */
1380 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1381 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1383 if (ckWARN(WARN_SYNTAX))
1384 Perl_warner(aTHX_ WARN_SYNTAX, "\\%c better written as $%c", *s, *s);
1389 /* string-change backslash escapes */
1390 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1395 /* if we get here, it's either a quoted -, or a digit */
1398 /* quoted - in transliterations */
1400 if (PL_lex_inwhat == OP_TRANS) {
1407 if (ckWARN(WARN_MISC) && isALNUM(*s))
1408 Perl_warner(aTHX_ WARN_MISC,
1409 "Unrecognized escape \\%c passed through",
1411 /* default action is to copy the quoted character */
1412 goto default_action;
1415 /* \132 indicates an octal constant */
1416 case '0': case '1': case '2': case '3':
1417 case '4': case '5': case '6': case '7':
1419 STRLEN len = 0; /* disallow underscores */
1420 uv = (UV)scan_oct(s, 3, &len);
1423 goto NUM_ESCAPE_INSERT;
1425 /* \x24 indicates a hex constant */
1429 char* e = strchr(s, '}');
1431 yyerror("Missing right brace on \\x{}");
1435 STRLEN len = 1; /* allow underscores */
1436 uv = (UV)scan_hex(s + 1, e - s - 1, &len);
1442 STRLEN len = 0; /* disallow underscores */
1443 uv = (UV)scan_hex(s, 2, &len);
1449 /* Insert oct or hex escaped character.
1450 * There will always enough room in sv since such
1451 * escapes will be longer than any UT-F8 sequence
1452 * they can end up as. */
1454 /* This spot is wrong for EBCDIC. Characters like
1455 * the lowercase letters and digits are >127 in EBCDIC,
1456 * so here they would need to be mapped to the Unicode
1457 * repertoire. --jhi */
1460 if (!has_utf8 && uv > 255) {
1461 /* Might need to recode whatever we have
1462 * accumulated so far if it contains any
1465 * (Can't we keep track of that and avoid
1466 * this rescan? --jhi)
1471 for (c = SvPVX(sv); c < d; c++) {
1472 if (UTF8_IS_CONTINUED(*c))
1476 char *old_pvx = SvPVX(sv);
1480 SvLEN(sv) + hicount + 1) +
1488 if (UTF8_IS_CONTINUED(*src)) {
1489 *dst-- = UTF8_EIGHT_BIT_LO(*src);
1490 *dst-- = UTF8_EIGHT_BIT_HI(*src--);
1499 if (has_utf8 || uv > 255) {
1500 d = (char*)uv_to_utf8((U8*)d, uv);
1502 if (PL_lex_inwhat == OP_TRANS &&
1503 PL_sublex_info.sub_op) {
1504 PL_sublex_info.sub_op->op_private |=
1505 (PL_lex_repl ? OPpTRANS_FROM_UTF
1519 /* \N{latin small letter a} is a named character */
1523 char* e = strchr(s, '}');
1529 yyerror("Missing right brace on \\N{}");
1533 res = newSVpvn(s + 1, e - s - 1);
1534 res = new_constant( Nullch, 0, "charnames",
1535 res, Nullsv, "\\N{...}" );
1537 sv_utf8_upgrade(res);
1538 str = SvPV(res,len);
1539 if (!has_utf8 && SvUTF8(res)) {
1540 char *ostart = SvPVX(sv);
1541 SvCUR_set(sv, d - ostart);
1544 sv_utf8_upgrade(sv);
1545 /* this just broke our allocation above... */
1546 SvGROW(sv, send - start);
1547 d = SvPVX(sv) + SvCUR(sv);
1550 if (len > e - s + 4) {
1551 char *odest = SvPVX(sv);
1553 SvGROW(sv, (SvLEN(sv) + len - (e - s + 4)));
1554 d = SvPVX(sv) + (d - odest);
1556 Copy(str, d, len, char);
1563 yyerror("Missing braces on \\N{}");
1566 /* \c is a control character */
1583 /* printf-style backslashes, formfeeds, newlines, etc */
1601 *d++ = '\047'; /* CP 1047 */
1604 *d++ = '\057'; /* CP 1047 */
1618 } /* end if (backslash) */
1621 if (UTF8_IS_CONTINUED(*s) && (this_utf8 || has_utf8)) {
1622 STRLEN len = (STRLEN) -1;
1625 uv = utf8_to_uv((U8*)s, send - s, &len, 0);
1627 if (len == (STRLEN)-1) {
1628 /* Illegal UTF8 (a high-bit byte), make it valid. */
1629 char *old_pvx = SvPVX(sv);
1630 /* need space for one extra char (NOTE: SvCUR() not set here) */
1631 d = SvGROW(sv, SvLEN(sv) + 1) + (d - old_pvx);
1632 d = (char*)uv_to_utf8((U8*)d, (U8)*s++);
1639 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1640 PL_sublex_info.sub_op->op_private |=
1641 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1648 } /* while loop to process each character */
1650 /* terminate the string and set up the sv */
1652 SvCUR_set(sv, d - SvPVX(sv));
1657 /* shrink the sv if we allocated more than we used */
1658 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1659 SvLEN_set(sv, SvCUR(sv) + 1);
1660 Renew(SvPVX(sv), SvLEN(sv), char);
1663 /* return the substring (via yylval) only if we parsed anything */
1664 if (s > PL_bufptr) {
1665 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1666 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1668 ( PL_lex_inwhat == OP_TRANS
1670 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1673 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1680 * Returns TRUE if there's more to the expression (e.g., a subscript),
1683 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
1685 * ->[ and ->{ return TRUE
1686 * { and [ outside a pattern are always subscripts, so return TRUE
1687 * if we're outside a pattern and it's not { or [, then return FALSE
1688 * if we're in a pattern and the first char is a {
1689 * {4,5} (any digits around the comma) returns FALSE
1690 * if we're in a pattern and the first char is a [
1692 * [SOMETHING] has a funky algorithm to decide whether it's a
1693 * character class or not. It has to deal with things like
1694 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
1695 * anything else returns TRUE
1698 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1701 S_intuit_more(pTHX_ register char *s)
1703 if (PL_lex_brackets)
1705 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1707 if (*s != '{' && *s != '[')
1712 /* In a pattern, so maybe we have {n,m}. */
1729 /* On the other hand, maybe we have a character class */
1732 if (*s == ']' || *s == '^')
1735 /* this is terrifying, and it works */
1736 int weight = 2; /* let's weigh the evidence */
1738 unsigned char un_char = 255, last_un_char;
1739 char *send = strchr(s,']');
1740 char tmpbuf[sizeof PL_tokenbuf * 4];
1742 if (!send) /* has to be an expression */
1745 Zero(seen,256,char);
1748 else if (isDIGIT(*s)) {
1750 if (isDIGIT(s[1]) && s[2] == ']')
1756 for (; s < send; s++) {
1757 last_un_char = un_char;
1758 un_char = (unsigned char)*s;
1763 weight -= seen[un_char] * 10;
1764 if (isALNUM_lazy_if(s+1,UTF)) {
1765 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1766 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1771 else if (*s == '$' && s[1] &&
1772 strchr("[#!%*<>()-=",s[1])) {
1773 if (/*{*/ strchr("])} =",s[2]))
1782 if (strchr("wds]",s[1]))
1784 else if (seen['\''] || seen['"'])
1786 else if (strchr("rnftbxcav",s[1]))
1788 else if (isDIGIT(s[1])) {
1790 while (s[1] && isDIGIT(s[1]))
1800 if (strchr("aA01! ",last_un_char))
1802 if (strchr("zZ79~",s[1]))
1804 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1805 weight -= 5; /* cope with negative subscript */
1808 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1809 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1814 if (keyword(tmpbuf, d - tmpbuf))
1817 if (un_char == last_un_char + 1)
1819 weight -= seen[un_char];
1824 if (weight >= 0) /* probably a character class */
1834 * Does all the checking to disambiguate
1836 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
1837 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
1839 * First argument is the stuff after the first token, e.g. "bar".
1841 * Not a method if bar is a filehandle.
1842 * Not a method if foo is a subroutine prototyped to take a filehandle.
1843 * Not a method if it's really "Foo $bar"
1844 * Method if it's "foo $bar"
1845 * Not a method if it's really "print foo $bar"
1846 * Method if it's really "foo package::" (interpreted as package->foo)
1847 * Not a method if bar is known to be a subroutne ("sub bar; foo bar")
1848 * Not a method if bar is a filehandle or package, but is quoted with
1853 S_intuit_method(pTHX_ char *start, GV *gv)
1855 char *s = start + (*start == '$');
1856 char tmpbuf[sizeof PL_tokenbuf];
1864 if ((cv = GvCVu(gv))) {
1865 char *proto = SvPVX(cv);
1875 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1876 /* start is the beginning of the possible filehandle/object,
1877 * and s is the end of it
1878 * tmpbuf is a copy of it
1881 if (*start == '$') {
1882 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1887 return *s == '(' ? FUNCMETH : METHOD;
1889 if (!keyword(tmpbuf, len)) {
1890 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1895 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1896 if (indirgv && GvCVu(indirgv))
1898 /* filehandle or package name makes it a method */
1899 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1901 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1902 return 0; /* no assumptions -- "=>" quotes bearword */
1904 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1905 newSVpvn(tmpbuf,len));
1906 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1910 return *s == '(' ? FUNCMETH : METHOD;
1918 * Return a string of Perl code to load the debugger. If PERL5DB
1919 * is set, it will return the contents of that, otherwise a
1920 * compile-time require of perl5db.pl.
1927 char *pdb = PerlEnv_getenv("PERL5DB");
1931 SETERRNO(0,SS$_NORMAL);
1932 return "BEGIN { require 'perl5db.pl' }";
1938 /* Encoded script support. filter_add() effectively inserts a
1939 * 'pre-processing' function into the current source input stream.
1940 * Note that the filter function only applies to the current source file
1941 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1943 * The datasv parameter (which may be NULL) can be used to pass
1944 * private data to this instance of the filter. The filter function
1945 * can recover the SV using the FILTER_DATA macro and use it to
1946 * store private buffers and state information.
1948 * The supplied datasv parameter is upgraded to a PVIO type
1949 * and the IoDIRP/IoANY field is used to store the function pointer,
1950 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
1951 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1952 * private use must be set using malloc'd pointers.
1956 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
1961 if (!PL_rsfp_filters)
1962 PL_rsfp_filters = newAV();
1964 datasv = NEWSV(255,0);
1965 if (!SvUPGRADE(datasv, SVt_PVIO))
1966 Perl_die(aTHX_ "Can't upgrade filter_add data to SVt_PVIO");
1967 IoANY(datasv) = (void *)funcp; /* stash funcp into spare field */
1968 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
1969 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
1970 funcp, SvPV_nolen(datasv)));
1971 av_unshift(PL_rsfp_filters, 1);
1972 av_store(PL_rsfp_filters, 0, datasv) ;
1977 /* Delete most recently added instance of this filter function. */
1979 Perl_filter_del(pTHX_ filter_t funcp)
1982 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", funcp));
1983 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
1985 /* if filter is on top of stack (usual case) just pop it off */
1986 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
1987 if (IoANY(datasv) == (void *)funcp) {
1988 IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
1989 IoANY(datasv) = (void *)NULL;
1990 sv_free(av_pop(PL_rsfp_filters));
1994 /* we need to search for the correct entry and clear it */
1995 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
1999 /* Invoke the n'th filter function for the current rsfp. */
2001 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
2004 /* 0 = read one text line */
2009 if (!PL_rsfp_filters)
2011 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
2012 /* Provide a default input filter to make life easy. */
2013 /* Note that we append to the line. This is handy. */
2014 DEBUG_P(PerlIO_printf(Perl_debug_log,
2015 "filter_read %d: from rsfp\n", idx));
2019 int old_len = SvCUR(buf_sv) ;
2021 /* ensure buf_sv is large enough */
2022 SvGROW(buf_sv, old_len + maxlen) ;
2023 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
2024 if (PerlIO_error(PL_rsfp))
2025 return -1; /* error */
2027 return 0 ; /* end of file */
2029 SvCUR_set(buf_sv, old_len + len) ;
2032 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
2033 if (PerlIO_error(PL_rsfp))
2034 return -1; /* error */
2036 return 0 ; /* end of file */
2039 return SvCUR(buf_sv);
2041 /* Skip this filter slot if filter has been deleted */
2042 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
2043 DEBUG_P(PerlIO_printf(Perl_debug_log,
2044 "filter_read %d: skipped (filter deleted)\n",
2046 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
2048 /* Get function pointer hidden within datasv */
2049 funcp = (filter_t)IoANY(datasv);
2050 DEBUG_P(PerlIO_printf(Perl_debug_log,
2051 "filter_read %d: via function %p (%s)\n",
2052 idx, funcp, SvPV_nolen(datasv)));
2053 /* Call function. The function is expected to */
2054 /* call "FILTER_READ(idx+1, buf_sv)" first. */
2055 /* Return: <0:error, =0:eof, >0:not eof */
2056 return (*funcp)(aTHXo_ idx, buf_sv, maxlen);
2060 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
2062 #ifdef PERL_CR_FILTER
2063 if (!PL_rsfp_filters) {
2064 filter_add(S_cr_textfilter,NULL);
2067 if (PL_rsfp_filters) {
2070 SvCUR_set(sv, 0); /* start with empty line */
2071 if (FILTER_READ(0, sv, 0) > 0)
2072 return ( SvPVX(sv) ) ;
2077 return (sv_gets(sv, fp, append));
2081 S_find_in_my_stash(pTHX_ char *pkgname, I32 len)
2085 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
2089 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
2090 (gv = gv_fetchpv(pkgname, FALSE, SVt_PVHV)))
2092 return GvHV(gv); /* Foo:: */
2095 /* use constant CLASS => 'MyClass' */
2096 if ((gv = gv_fetchpv(pkgname, FALSE, SVt_PVCV))) {
2098 if (GvCV(gv) && (sv = cv_const_sv(GvCV(gv)))) {
2099 pkgname = SvPV_nolen(sv);
2103 return gv_stashpv(pkgname, FALSE);
2107 static char* exp_name[] =
2108 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
2109 "ATTRTERM", "TERMBLOCK"
2116 Works out what to call the token just pulled out of the input
2117 stream. The yacc parser takes care of taking the ops we return and
2118 stitching them into a tree.
2124 if read an identifier
2125 if we're in a my declaration
2126 croak if they tried to say my($foo::bar)
2127 build the ops for a my() declaration
2128 if it's an access to a my() variable
2129 are we in a sort block?
2130 croak if my($a); $a <=> $b
2131 build ops for access to a my() variable
2132 if in a dq string, and they've said @foo and we can't find @foo
2134 build ops for a bareword
2135 if we already built the token before, use it.
2138 #ifdef USE_PURE_BISON
2140 Perl_yylex_r(pTHX_ YYSTYPE *lvalp, int *lcharp)
2145 yylval_pointer[yyactlevel] = lvalp;
2146 yychar_pointer[yyactlevel] = lcharp;
2147 if (yyactlevel >= YYMAXLEVEL)
2148 Perl_croak(aTHX_ "panic: YYMAXLEVEL");
2150 r = Perl_yylex(aTHX);
2160 #pragma segment Perl_yylex
2173 /* check if there's an identifier for us to look at */
2174 if (PL_pending_ident) {
2175 /* pit holds the identifier we read and pending_ident is reset */
2176 char pit = PL_pending_ident;
2177 PL_pending_ident = 0;
2179 DEBUG_T({ PerlIO_printf(Perl_debug_log,
2180 "### Tokener saw identifier '%s'\n", PL_tokenbuf); })
2182 /* if we're in a my(), we can't allow dynamics here.
2183 $foo'bar has already been turned into $foo::bar, so
2184 just check for colons.
2186 if it's a legal name, the OP is a PADANY.
2189 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
2190 if (strchr(PL_tokenbuf,':'))
2191 yyerror(Perl_form(aTHX_ "No package name allowed for "
2192 "variable %s in \"our\"",
2194 tmp = pad_allocmy(PL_tokenbuf);
2197 if (strchr(PL_tokenbuf,':'))
2198 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
2200 yylval.opval = newOP(OP_PADANY, 0);
2201 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
2207 build the ops for accesses to a my() variable.
2209 Deny my($a) or my($b) in a sort block, *if* $a or $b is
2210 then used in a comparison. This catches most, but not
2211 all cases. For instance, it catches
2212 sort { my($a); $a <=> $b }
2214 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
2215 (although why you'd do that is anyone's guess).
2218 if (!strchr(PL_tokenbuf,':')) {
2220 /* Check for single character per-thread SVs */
2221 if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
2222 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
2223 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
2225 yylval.opval = newOP(OP_THREADSV, 0);
2226 yylval.opval->op_targ = tmp;
2229 #endif /* USE_THREADS */
2230 if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
2231 SV *namesv = AvARRAY(PL_comppad_name)[tmp];
2232 /* might be an "our" variable" */
2233 if (SvFLAGS(namesv) & SVpad_OUR) {
2234 /* build ops for a bareword */
2235 SV *sym = newSVpv(HvNAME(GvSTASH(namesv)),0);
2236 sv_catpvn(sym, "::", 2);
2237 sv_catpv(sym, PL_tokenbuf+1);
2238 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
2239 yylval.opval->op_private = OPpCONST_ENTERED;
2240 gv_fetchpv(SvPVX(sym),
2242 ? (GV_ADDMULTI | GV_ADDINEVAL)
2245 ((PL_tokenbuf[0] == '$') ? SVt_PV
2246 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
2251 /* if it's a sort block and they're naming $a or $b */
2252 if (PL_last_lop_op == OP_SORT &&
2253 PL_tokenbuf[0] == '$' &&
2254 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
2257 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
2258 d < PL_bufend && *d != '\n';
2261 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
2262 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
2268 yylval.opval = newOP(OP_PADANY, 0);
2269 yylval.opval->op_targ = tmp;
2275 Whine if they've said @foo in a doublequoted string,
2276 and @foo isn't a variable we can find in the symbol
2279 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
2280 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
2281 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
2282 && ckWARN(WARN_AMBIGUOUS))
2284 /* Downgraded from fatal to warning 20000522 mjd */
2285 Perl_warner(aTHX_ WARN_AMBIGUOUS,
2286 "Possible unintended interpolation of %s in string",
2291 /* build ops for a bareword */
2292 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
2293 yylval.opval->op_private = OPpCONST_ENTERED;
2294 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
2295 ((PL_tokenbuf[0] == '$') ? SVt_PV
2296 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
2301 /* no identifier pending identification */
2303 switch (PL_lex_state) {
2305 case LEX_NORMAL: /* Some compilers will produce faster */
2306 case LEX_INTERPNORMAL: /* code if we comment these out. */
2310 /* when we've already built the next token, just pull it out of the queue */
2313 yylval = PL_nextval[PL_nexttoke];
2315 PL_lex_state = PL_lex_defer;
2316 PL_expect = PL_lex_expect;
2317 PL_lex_defer = LEX_NORMAL;
2319 DEBUG_T({ PerlIO_printf(Perl_debug_log,
2320 "### Next token after '%s' was known, type %"IVdf"\n", PL_bufptr,
2321 (IV)PL_nexttype[PL_nexttoke]); })
2323 return(PL_nexttype[PL_nexttoke]);
2325 /* interpolated case modifiers like \L \U, including \Q and \E.
2326 when we get here, PL_bufptr is at the \
2328 case LEX_INTERPCASEMOD:
2330 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
2331 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
2333 /* handle \E or end of string */
2334 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
2338 if (PL_lex_casemods) {
2339 oldmod = PL_lex_casestack[--PL_lex_casemods];
2340 PL_lex_casestack[PL_lex_casemods] = '\0';
2342 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
2344 PL_lex_state = LEX_INTERPCONCAT;
2348 if (PL_bufptr != PL_bufend)
2350 PL_lex_state = LEX_INTERPCONCAT;
2354 DEBUG_T({ PerlIO_printf(Perl_debug_log,
2355 "### Saw case modifier at '%s'\n", PL_bufptr); })
2357 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
2358 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
2359 if (strchr("LU", *s) &&
2360 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
2362 PL_lex_casestack[--PL_lex_casemods] = '\0';
2365 if (PL_lex_casemods > 10) {
2366 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
2367 if (newlb != PL_lex_casestack) {
2369 PL_lex_casestack = newlb;
2372 PL_lex_casestack[PL_lex_casemods++] = *s;
2373 PL_lex_casestack[PL_lex_casemods] = '\0';
2374 PL_lex_state = LEX_INTERPCONCAT;
2375 PL_nextval[PL_nexttoke].ival = 0;
2378 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
2380 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
2382 PL_nextval[PL_nexttoke].ival = OP_LC;
2384 PL_nextval[PL_nexttoke].ival = OP_UC;
2386 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
2388 Perl_croak(aTHX_ "panic: yylex");
2391 if (PL_lex_starts) {
2400 case LEX_INTERPPUSH:
2401 return sublex_push();
2403 case LEX_INTERPSTART:
2404 if (PL_bufptr == PL_bufend)
2405 return sublex_done();
2406 DEBUG_T({ PerlIO_printf(Perl_debug_log,
2407 "### Interpolated variable at '%s'\n", PL_bufptr); })
2409 PL_lex_dojoin = (*PL_bufptr == '@');
2410 PL_lex_state = LEX_INTERPNORMAL;
2411 if (PL_lex_dojoin) {
2412 PL_nextval[PL_nexttoke].ival = 0;
2415 PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
2416 PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
2417 force_next(PRIVATEREF);
2419 force_ident("\"", '$');
2420 #endif /* USE_THREADS */
2421 PL_nextval[PL_nexttoke].ival = 0;
2423 PL_nextval[PL_nexttoke].ival = 0;
2425 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
2428 if (PL_lex_starts++) {
2434 case LEX_INTERPENDMAYBE:
2435 if (intuit_more(PL_bufptr)) {
2436 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
2442 if (PL_lex_dojoin) {
2443 PL_lex_dojoin = FALSE;
2444 PL_lex_state = LEX_INTERPCONCAT;
2447 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
2448 && SvEVALED(PL_lex_repl))
2450 if (PL_bufptr != PL_bufend)
2451 Perl_croak(aTHX_ "Bad evalled substitution pattern");
2452 PL_lex_repl = Nullsv;
2455 case LEX_INTERPCONCAT:
2457 if (PL_lex_brackets)
2458 Perl_croak(aTHX_ "panic: INTERPCONCAT");
2460 if (PL_bufptr == PL_bufend)
2461 return sublex_done();
2463 if (SvIVX(PL_linestr) == '\'') {
2464 SV *sv = newSVsv(PL_linestr);
2467 else if ( PL_hints & HINT_NEW_RE )
2468 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
2469 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2473 s = scan_const(PL_bufptr);
2475 PL_lex_state = LEX_INTERPCASEMOD;
2477 PL_lex_state = LEX_INTERPSTART;
2480 if (s != PL_bufptr) {
2481 PL_nextval[PL_nexttoke] = yylval;
2484 if (PL_lex_starts++)
2494 PL_lex_state = LEX_NORMAL;
2495 s = scan_formline(PL_bufptr);
2496 if (!PL_lex_formbrack)
2502 PL_oldoldbufptr = PL_oldbufptr;
2505 PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at %s\n",
2506 exp_name[PL_expect], s);
2512 if (isIDFIRST_lazy_if(s,UTF))
2514 Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
2517 goto fake_eof; /* emulate EOF on ^D or ^Z */
2522 if (PL_lex_brackets)
2523 yyerror("Missing right curly or square bracket");
2524 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2525 "### Tokener got EOF\n");
2529 if (s++ < PL_bufend)
2530 goto retry; /* ignore stray nulls */
2533 if (!PL_in_eval && !PL_preambled) {
2534 PL_preambled = TRUE;
2535 sv_setpv(PL_linestr,incl_perldb());
2536 if (SvCUR(PL_linestr))
2537 sv_catpv(PL_linestr,";");
2539 while(AvFILLp(PL_preambleav) >= 0) {
2540 SV *tmpsv = av_shift(PL_preambleav);
2541 sv_catsv(PL_linestr, tmpsv);
2542 sv_catpv(PL_linestr, ";");
2545 sv_free((SV*)PL_preambleav);
2546 PL_preambleav = NULL;
2548 if (PL_minus_n || PL_minus_p) {
2549 sv_catpv(PL_linestr, "LINE: while (<>) {");
2551 sv_catpv(PL_linestr,"chomp;");
2553 GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
2555 GvIMPORTED_AV_on(gv);
2557 if (strchr("/'\"", *PL_splitstr)
2558 && strchr(PL_splitstr + 1, *PL_splitstr))
2559 Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s);", PL_splitstr);
2562 s = "'~#\200\1'"; /* surely one char is unused...*/
2563 while (s[1] && strchr(PL_splitstr, *s)) s++;
2565 Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s%c",
2566 "q" + (delim == '\''), delim);
2567 for (s = PL_splitstr; *s; s++) {
2569 sv_catpvn(PL_linestr, "\\", 1);
2570 sv_catpvn(PL_linestr, s, 1);
2572 Perl_sv_catpvf(aTHX_ PL_linestr, "%c);", delim);
2576 sv_catpv(PL_linestr,"@F=split(' ');");
2579 sv_catpv(PL_linestr, "\n");
2580 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2581 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2582 PL_last_lop = PL_last_uni = Nullch;
2583 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2584 SV *sv = NEWSV(85,0);
2586 sv_upgrade(sv, SVt_PVMG);
2587 sv_setsv(sv,PL_linestr);
2588 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2593 bof = PL_rsfp ? TRUE : FALSE;
2594 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
2597 if (PL_preprocess && !PL_in_eval)
2598 (void)PerlProc_pclose(PL_rsfp);
2599 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2600 PerlIO_clearerr(PL_rsfp);
2602 (void)PerlIO_close(PL_rsfp);
2604 PL_doextract = FALSE;
2606 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2607 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
2608 sv_catpv(PL_linestr,";}");
2609 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2610 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2611 PL_last_lop = PL_last_uni = Nullch;
2612 PL_minus_n = PL_minus_p = 0;
2615 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2616 PL_last_lop = PL_last_uni = Nullch;
2617 sv_setpv(PL_linestr,"");
2618 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
2620 /* if it looks like the start of a BOM, check if it in fact is */
2621 else if (bof && (!*s || *(U8*)s == 0xEF || *(U8*)s >= 0xFE)) {
2622 #ifdef PERLIO_IS_STDIO
2623 # ifdef __GNU_LIBRARY__
2624 # if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
2625 # define FTELL_FOR_PIPE_IS_BROKEN
2629 # if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
2630 # define FTELL_FOR_PIPE_IS_BROKEN
2635 #ifdef FTELL_FOR_PIPE_IS_BROKEN
2636 /* This loses the possibility to detect the bof
2637 * situation on perl -P when the libc5 is being used.
2638 * Workaround? Maybe attach some extra state to PL_rsfp?
2641 bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
2643 bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
2646 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2647 s = swallow_bom((U8*)s);
2651 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
2652 PL_doextract = FALSE;
2654 /* Incest with pod. */
2655 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2656 sv_setpv(PL_linestr, "");
2657 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2658 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2659 PL_last_lop = PL_last_uni = Nullch;
2660 PL_doextract = FALSE;
2664 } while (PL_doextract);
2665 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2666 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2667 SV *sv = NEWSV(85,0);
2669 sv_upgrade(sv, SVt_PVMG);
2670 sv_setsv(sv,PL_linestr);
2671 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2673 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2674 PL_last_lop = PL_last_uni = Nullch;
2675 if (CopLINE(PL_curcop) == 1) {
2676 while (s < PL_bufend && isSPACE(*s))
2678 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2682 if (*s == '#' && *(s+1) == '!')
2684 #ifdef ALTERNATE_SHEBANG
2686 static char as[] = ALTERNATE_SHEBANG;
2687 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2688 d = s + (sizeof(as) - 1);
2690 #endif /* ALTERNATE_SHEBANG */
2699 while (*d && !isSPACE(*d))
2703 #ifdef ARG_ZERO_IS_SCRIPT
2704 if (ipathend > ipath) {
2706 * HP-UX (at least) sets argv[0] to the script name,
2707 * which makes $^X incorrect. And Digital UNIX and Linux,
2708 * at least, set argv[0] to the basename of the Perl
2709 * interpreter. So, having found "#!", we'll set it right.
2711 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
2712 assert(SvPOK(x) || SvGMAGICAL(x));
2713 if (sv_eq(x, CopFILESV(PL_curcop))) {
2714 sv_setpvn(x, ipath, ipathend - ipath);
2717 TAINT_NOT; /* $^X is always tainted, but that's OK */
2719 #endif /* ARG_ZERO_IS_SCRIPT */
2724 d = instr(s,"perl -");
2726 d = instr(s,"perl");
2728 /* avoid getting into infinite loops when shebang
2729 * line contains "Perl" rather than "perl" */
2731 for (d = ipathend-4; d >= ipath; --d) {
2732 if ((*d == 'p' || *d == 'P')
2733 && !ibcmp(d, "perl", 4))
2743 #ifdef ALTERNATE_SHEBANG
2745 * If the ALTERNATE_SHEBANG on this system starts with a
2746 * character that can be part of a Perl expression, then if
2747 * we see it but not "perl", we're probably looking at the
2748 * start of Perl code, not a request to hand off to some
2749 * other interpreter. Similarly, if "perl" is there, but
2750 * not in the first 'word' of the line, we assume the line
2751 * contains the start of the Perl program.
2753 if (d && *s != '#') {
2755 while (*c && !strchr("; \t\r\n\f\v#", *c))
2758 d = Nullch; /* "perl" not in first word; ignore */
2760 *s = '#'; /* Don't try to parse shebang line */
2762 #endif /* ALTERNATE_SHEBANG */
2763 #ifndef MACOS_TRADITIONAL
2768 !instr(s,"indir") &&
2769 instr(PL_origargv[0],"perl"))
2775 while (s < PL_bufend && isSPACE(*s))
2777 if (s < PL_bufend) {
2778 Newz(899,newargv,PL_origargc+3,char*);
2780 while (s < PL_bufend && !isSPACE(*s))
2783 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2786 newargv = PL_origargv;
2788 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
2789 Perl_croak(aTHX_ "Can't exec %s", ipath);
2793 U32 oldpdb = PL_perldb;
2794 bool oldn = PL_minus_n;
2795 bool oldp = PL_minus_p;
2797 while (*d && !isSPACE(*d)) d++;
2798 while (SPACE_OR_TAB(*d)) d++;
2802 if (*d == 'M' || *d == 'm') {
2804 while (*d && !isSPACE(*d)) d++;
2805 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2808 d = moreswitches(d);
2810 if ((PERLDB_LINE && !oldpdb) ||
2811 ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
2812 /* if we have already added "LINE: while (<>) {",
2813 we must not do it again */
2815 sv_setpv(PL_linestr, "");
2816 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2817 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2818 PL_last_lop = PL_last_uni = Nullch;
2819 PL_preambled = FALSE;
2821 (void)gv_fetchfile(PL_origfilename);
2828 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2830 PL_lex_state = LEX_FORMLINE;
2835 #ifdef PERL_STRICT_CR
2836 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2838 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
2840 case ' ': case '\t': case '\f': case 013:
2841 #ifdef MACOS_TRADITIONAL
2848 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2849 if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
2850 /* handle eval qq[#line 1 "foo"\n ...] */
2851 CopLINE_dec(PL_curcop);
2855 while (s < d && *s != '\n')
2860 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2862 PL_lex_state = LEX_FORMLINE;
2872 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2879 while (s < PL_bufend && SPACE_OR_TAB(*s))
2882 if (strnEQ(s,"=>",2)) {
2883 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2884 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2885 "### Saw unary minus before =>, forcing word '%s'\n", s);
2887 OPERATOR('-'); /* unary minus */
2889 PL_last_uni = PL_oldbufptr;
2891 case 'r': ftst = OP_FTEREAD; break;
2892 case 'w': ftst = OP_FTEWRITE; break;
2893 case 'x': ftst = OP_FTEEXEC; break;
2894 case 'o': ftst = OP_FTEOWNED; break;
2895 case 'R': ftst = OP_FTRREAD; break;
2896 case 'W': ftst = OP_FTRWRITE; break;
2897 case 'X': ftst = OP_FTREXEC; break;
2898 case 'O': ftst = OP_FTROWNED; break;
2899 case 'e': ftst = OP_FTIS; break;
2900 case 'z': ftst = OP_FTZERO; break;
2901 case 's': ftst = OP_FTSIZE; break;
2902 case 'f': ftst = OP_FTFILE; break;
2903 case 'd': ftst = OP_FTDIR; break;
2904 case 'l': ftst = OP_FTLINK; break;
2905 case 'p': ftst = OP_FTPIPE; break;
2906 case 'S': ftst = OP_FTSOCK; break;
2907 case 'u': ftst = OP_FTSUID; break;
2908 case 'g': ftst = OP_FTSGID; break;
2909 case 'k': ftst = OP_FTSVTX; break;
2910 case 'b': ftst = OP_FTBLK; break;
2911 case 'c': ftst = OP_FTCHR; break;
2912 case 't': ftst = OP_FTTTY; break;
2913 case 'T': ftst = OP_FTTEXT; break;
2914 case 'B': ftst = OP_FTBINARY; break;
2915 case 'M': case 'A': case 'C':
2916 gv_fetchpv("\024",TRUE, SVt_PV);
2918 case 'M': ftst = OP_FTMTIME; break;
2919 case 'A': ftst = OP_FTATIME; break;
2920 case 'C': ftst = OP_FTCTIME; break;
2928 PL_last_lop_op = ftst;
2929 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2930 "### Saw file test %c\n", (int)ftst);
2935 /* Assume it was a minus followed by a one-letter named
2936 * subroutine call (or a -bareword), then. */
2937 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2938 "### %c looked like a file test but was not\n",
2947 if (PL_expect == XOPERATOR)
2952 else if (*s == '>') {
2955 if (isIDFIRST_lazy_if(s,UTF)) {
2956 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2964 if (PL_expect == XOPERATOR)
2967 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2969 OPERATOR('-'); /* unary minus */
2976 if (PL_expect == XOPERATOR)
2981 if (PL_expect == XOPERATOR)
2984 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2990 if (PL_expect != XOPERATOR) {
2991 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2992 PL_expect = XOPERATOR;
2993 force_ident(PL_tokenbuf, '*');
3006 if (PL_expect == XOPERATOR) {
3010 PL_tokenbuf[0] = '%';
3011 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
3012 if (!PL_tokenbuf[1]) {
3014 yyerror("Final % should be \\% or %name");
3017 PL_pending_ident = '%';
3036 switch (PL_expect) {
3039 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
3041 PL_bufptr = s; /* update in case we back off */
3047 PL_expect = XTERMBLOCK;
3051 while (isIDFIRST_lazy_if(s,UTF)) {
3052 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3053 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
3054 if (tmp < 0) tmp = -tmp;
3069 d = scan_str(d,TRUE,TRUE);
3071 /* MUST advance bufptr here to avoid bogus
3072 "at end of line" context messages from yyerror().
3074 PL_bufptr = s + len;
3075 yyerror("Unterminated attribute parameter in attribute list");
3078 return 0; /* EOF indicator */
3082 SV *sv = newSVpvn(s, len);
3083 sv_catsv(sv, PL_lex_stuff);
3084 attrs = append_elem(OP_LIST, attrs,
3085 newSVOP(OP_CONST, 0, sv));
3086 SvREFCNT_dec(PL_lex_stuff);
3087 PL_lex_stuff = Nullsv;
3090 if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len))
3091 CvLVALUE_on(PL_compcv);
3092 else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len))
3093 CvLOCKED_on(PL_compcv);
3094 else if (!PL_in_my && len == 6 && strnEQ(s, "method", len))
3095 CvMETHOD_on(PL_compcv);
3097 else if (PL_in_my == KEY_our && len == 6 && strnEQ(s, "shared", len))
3098 GvSHARED_on(cGVOPx_gv(yylval.opval));
3100 /* After we've set the flags, it could be argued that
3101 we don't need to do the attributes.pm-based setting
3102 process, and shouldn't bother appending recognized
3103 flags. To experiment with that, uncomment the
3104 following "else": */
3106 attrs = append_elem(OP_LIST, attrs,
3107 newSVOP(OP_CONST, 0,
3111 if (*s == ':' && s[1] != ':')
3114 break; /* require real whitespace or :'s */
3116 tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
3117 if (*s != ';' && *s != tmp && (tmp != '=' || *s != ')')) {
3118 char q = ((*s == '\'') ? '"' : '\'');
3119 /* If here for an expression, and parsed no attrs, back off. */
3120 if (tmp == '=' && !attrs) {
3124 /* MUST advance bufptr here to avoid bogus "at end of line"
3125 context messages from yyerror().
3129 yyerror("Unterminated attribute list");
3131 yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list",
3139 PL_nextval[PL_nexttoke].opval = attrs;
3147 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
3148 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
3164 if (PL_lex_brackets <= 0)
3165 yyerror("Unmatched right square bracket");
3168 if (PL_lex_state == LEX_INTERPNORMAL) {
3169 if (PL_lex_brackets == 0) {
3170 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
3171 PL_lex_state = LEX_INTERPEND;
3178 if (PL_lex_brackets > 100) {
3179 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
3180 if (newlb != PL_lex_brackstack) {
3182 PL_lex_brackstack = newlb;
3185 switch (PL_expect) {
3187 if (PL_lex_formbrack) {
3191 if (PL_oldoldbufptr == PL_last_lop)
3192 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3194 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3195 OPERATOR(HASHBRACK);
3197 while (s < PL_bufend && SPACE_OR_TAB(*s))
3200 PL_tokenbuf[0] = '\0';
3201 if (d < PL_bufend && *d == '-') {
3202 PL_tokenbuf[0] = '-';
3204 while (d < PL_bufend && SPACE_OR_TAB(*d))
3207 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
3208 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
3210 while (d < PL_bufend && SPACE_OR_TAB(*d))
3213 char minus = (PL_tokenbuf[0] == '-');
3214 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
3222 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
3227 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3232 if (PL_oldoldbufptr == PL_last_lop)
3233 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3235 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3238 OPERATOR(HASHBRACK);
3239 /* This hack serves to disambiguate a pair of curlies
3240 * as being a block or an anon hash. Normally, expectation
3241 * determines that, but in cases where we're not in a
3242 * position to expect anything in particular (like inside
3243 * eval"") we have to resolve the ambiguity. This code
3244 * covers the case where the first term in the curlies is a
3245 * quoted string. Most other cases need to be explicitly
3246 * disambiguated by prepending a `+' before the opening
3247 * curly in order to force resolution as an anon hash.
3249 * XXX should probably propagate the outer expectation
3250 * into eval"" to rely less on this hack, but that could
3251 * potentially break current behavior of eval"".
3255 if (*s == '\'' || *s == '"' || *s == '`') {
3256 /* common case: get past first string, handling escapes */
3257 for (t++; t < PL_bufend && *t != *s;)
3258 if (*t++ == '\\' && (*t == '\\' || *t == *s))
3262 else if (*s == 'q') {
3265 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
3269 char open, close, term;
3272 while (t < PL_bufend && isSPACE(*t))
3276 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
3280 for (t++; t < PL_bufend; t++) {
3281 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
3283 else if (*t == open)
3287 for (t++; t < PL_bufend; t++) {
3288 if (*t == '\\' && t+1 < PL_bufend)
3290 else if (*t == close && --brackets <= 0)
3292 else if (*t == open)
3298 else if (isALNUM_lazy_if(t,UTF)) {
3300 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3303 while (t < PL_bufend && isSPACE(*t))
3305 /* if comma follows first term, call it an anon hash */
3306 /* XXX it could be a comma expression with loop modifiers */
3307 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
3308 || (*t == '=' && t[1] == '>')))
3309 OPERATOR(HASHBRACK);
3310 if (PL_expect == XREF)
3313 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
3319 yylval.ival = CopLINE(PL_curcop);
3320 if (isSPACE(*s) || *s == '#')
3321 PL_copline = NOLINE; /* invalidate current command line number */
3326 if (PL_lex_brackets <= 0)
3327 yyerror("Unmatched right curly bracket");
3329 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
3330 if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
3331 PL_lex_formbrack = 0;
3332 if (PL_lex_state == LEX_INTERPNORMAL) {
3333 if (PL_lex_brackets == 0) {
3334 if (PL_expect & XFAKEBRACK) {
3335 PL_expect &= XENUMMASK;
3336 PL_lex_state = LEX_INTERPEND;
3338 return yylex(); /* ignore fake brackets */
3340 if (*s == '-' && s[1] == '>')
3341 PL_lex_state = LEX_INTERPENDMAYBE;
3342 else if (*s != '[' && *s != '{')
3343 PL_lex_state = LEX_INTERPEND;
3346 if (PL_expect & XFAKEBRACK) {
3347 PL_expect &= XENUMMASK;
3349 return yylex(); /* ignore fake brackets */
3359 if (PL_expect == XOPERATOR) {
3360 if (ckWARN(WARN_SEMICOLON)
3361 && isIDFIRST_lazy_if(s,UTF) && PL_bufptr == PL_linestart)
3363 CopLINE_dec(PL_curcop);
3364 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3365 CopLINE_inc(PL_curcop);
3370 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3372 PL_expect = XOPERATOR;
3373 force_ident(PL_tokenbuf, '&');
3377 yylval.ival = (OPpENTERSUB_AMPER<<8);
3396 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
3397 Perl_warner(aTHX_ WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
3399 if (PL_expect == XSTATE && isALPHA(tmp) &&
3400 (s == PL_linestart+1 || s[-2] == '\n') )
3402 if (PL_in_eval && !PL_rsfp) {
3407 if (strnEQ(s,"=cut",4)) {
3421 PL_doextract = TRUE;
3424 if (PL_lex_brackets < PL_lex_formbrack) {
3426 #ifdef PERL_STRICT_CR
3427 for (t = s; SPACE_OR_TAB(*t); t++) ;
3429 for (t = s; SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
3431 if (*t == '\n' || *t == '#') {
3449 if (PL_expect != XOPERATOR) {
3450 if (s[1] != '<' && !strchr(s,'>'))
3453 s = scan_heredoc(s);
3455 s = scan_inputsymbol(s);
3456 TERM(sublex_start());
3461 SHop(OP_LEFT_SHIFT);
3475 SHop(OP_RIGHT_SHIFT);
3484 if (PL_expect == XOPERATOR) {
3485 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3488 return ','; /* grandfather non-comma-format format */
3492 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
3493 PL_tokenbuf[0] = '@';
3494 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3495 sizeof PL_tokenbuf - 1, FALSE);
3496 if (PL_expect == XOPERATOR)
3497 no_op("Array length", s);
3498 if (!PL_tokenbuf[1])
3500 PL_expect = XOPERATOR;
3501 PL_pending_ident = '#';
3505 PL_tokenbuf[0] = '$';
3506 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3507 sizeof PL_tokenbuf - 1, FALSE);
3508 if (PL_expect == XOPERATOR)
3510 if (!PL_tokenbuf[1]) {
3512 yyerror("Final $ should be \\$ or $name");
3516 /* This kludge not intended to be bulletproof. */
3517 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
3518 yylval.opval = newSVOP(OP_CONST, 0,
3519 newSViv(PL_compiling.cop_arybase));
3520 yylval.opval->op_private = OPpCONST_ARYBASE;
3526 if (PL_lex_state == LEX_NORMAL)
3529 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3532 PL_tokenbuf[0] = '@';
3533 if (ckWARN(WARN_SYNTAX)) {
3535 isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$';
3538 PL_bufptr = skipspace(PL_bufptr);
3539 while (t < PL_bufend && *t != ']')
3541 Perl_warner(aTHX_ WARN_SYNTAX,
3542 "Multidimensional syntax %.*s not supported",
3543 (t - PL_bufptr) + 1, PL_bufptr);
3547 else if (*s == '{') {
3548 PL_tokenbuf[0] = '%';
3549 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
3550 (t = strchr(s, '}')) && (t = strchr(t, '=')))
3552 char tmpbuf[sizeof PL_tokenbuf];
3554 for (t++; isSPACE(*t); t++) ;
3555 if (isIDFIRST_lazy_if(t,UTF)) {
3556 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
3557 for (; isSPACE(*t); t++) ;
3558 if (*t == ';' && get_cv(tmpbuf, FALSE))
3559 Perl_warner(aTHX_ WARN_SYNTAX,
3560 "You need to quote \"%s\"", tmpbuf);
3566 PL_expect = XOPERATOR;
3567 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3568 bool islop = (PL_last_lop == PL_oldoldbufptr);
3569 if (!islop || PL_last_lop_op == OP_GREPSTART)
3570 PL_expect = XOPERATOR;
3571 else if (strchr("$@\"'`q", *s))
3572 PL_expect = XTERM; /* e.g. print $fh "foo" */
3573 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
3574 PL_expect = XTERM; /* e.g. print $fh &sub */
3575 else if (isIDFIRST_lazy_if(s,UTF)) {
3576 char tmpbuf[sizeof PL_tokenbuf];
3577 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3578 if ((tmp = keyword(tmpbuf, len))) {
3579 /* binary operators exclude handle interpretations */
3591 PL_expect = XTERM; /* e.g. print $fh length() */
3596 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
3597 if (gv && GvCVu(gv))
3598 PL_expect = XTERM; /* e.g. print $fh subr() */
3601 else if (isDIGIT(*s))
3602 PL_expect = XTERM; /* e.g. print $fh 3 */
3603 else if (*s == '.' && isDIGIT(s[1]))
3604 PL_expect = XTERM; /* e.g. print $fh .3 */
3605 else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
3606 PL_expect = XTERM; /* e.g. print $fh -1 */
3607 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3608 PL_expect = XTERM; /* print $fh <<"EOF" */
3610 PL_pending_ident = '$';
3614 if (PL_expect == XOPERATOR)
3616 PL_tokenbuf[0] = '@';
3617 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3618 if (!PL_tokenbuf[1]) {
3620 yyerror("Final @ should be \\@ or @name");
3623 if (PL_lex_state == LEX_NORMAL)
3625 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3627 PL_tokenbuf[0] = '%';
3629 /* Warn about @ where they meant $. */
3630 if (ckWARN(WARN_SYNTAX)) {
3631 if (*s == '[' || *s == '{') {
3633 while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
3635 if (*t == '}' || *t == ']') {
3637 PL_bufptr = skipspace(PL_bufptr);
3638 Perl_warner(aTHX_ WARN_SYNTAX,
3639 "Scalar value %.*s better written as $%.*s",
3640 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
3645 PL_pending_ident = '@';
3648 case '/': /* may either be division or pattern */
3649 case '?': /* may either be conditional or pattern */
3650 if (PL_expect != XOPERATOR) {
3651 /* Disable warning on "study /blah/" */
3652 if (PL_oldoldbufptr == PL_last_uni
3653 && (*PL_last_uni != 's' || s - PL_last_uni < 5
3654 || memNE(PL_last_uni, "study", 5)
3655 || isALNUM_lazy_if(PL_last_uni+5,UTF)))
3657 s = scan_pat(s,OP_MATCH);
3658 TERM(sublex_start());
3666 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3667 #ifdef PERL_STRICT_CR
3670 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3672 && (s == PL_linestart || s[-1] == '\n') )
3674 PL_lex_formbrack = 0;
3678 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
3684 yylval.ival = OPf_SPECIAL;
3690 if (PL_expect != XOPERATOR)
3695 case '0': case '1': case '2': case '3': case '4':
3696 case '5': case '6': case '7': case '8': case '9':
3697 s = scan_num(s, &yylval);
3698 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3699 "### Saw number in '%s'\n", s);
3701 if (PL_expect == XOPERATOR)
3706 s = scan_str(s,FALSE,FALSE);
3707 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3708 "### Saw string before '%s'\n", s);
3710 if (PL_expect == XOPERATOR) {
3711 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3714 return ','; /* grandfather non-comma-format format */
3720 missingterm((char*)0);
3721 yylval.ival = OP_CONST;
3722 TERM(sublex_start());
3725 s = scan_str(s,FALSE,FALSE);
3726 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3727 "### Saw string before '%s'\n", s);
3729 if (PL_expect == XOPERATOR) {
3730 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3733 return ','; /* grandfather non-comma-format format */
3739 missingterm((char*)0);
3740 yylval.ival = OP_CONST;
3741 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
3742 if (*d == '$' || *d == '@' || *d == '\\' || UTF8_IS_CONTINUED(*d)) {
3743 yylval.ival = OP_STRINGIFY;
3747 TERM(sublex_start());
3750 s = scan_str(s,FALSE,FALSE);
3751 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3752 "### Saw backtick string before '%s'\n", s);
3754 if (PL_expect == XOPERATOR)
3755 no_op("Backticks",s);
3757 missingterm((char*)0);
3758 yylval.ival = OP_BACKTICK;
3760 TERM(sublex_start());
3764 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
3765 Perl_warner(aTHX_ WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
3767 if (PL_expect == XOPERATOR)
3768 no_op("Backslash",s);
3772 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
3776 while (isDIGIT(*start) || *start == '_')
3778 if (*start == '.' && isDIGIT(start[1])) {
3779 s = scan_num(s, &yylval);
3782 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
3783 else if (!isALPHA(*start) && (PL_expect == XTERM || PL_expect == XREF)) {
3787 gv = gv_fetchpv(s, FALSE, SVt_PVCV);
3790 s = scan_num(s, &yylval);
3797 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
3836 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3838 /* Some keywords can be followed by any delimiter, including ':' */
3839 tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
3840 (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
3841 (PL_tokenbuf[0] == 'q' &&
3842 strchr("qwxr", PL_tokenbuf[1])))));
3844 /* x::* is just a word, unless x is "CORE" */
3845 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
3849 while (d < PL_bufend && isSPACE(*d))
3850 d++; /* no comments skipped here, or s### is misparsed */
3852 /* Is this a label? */
3853 if (!tmp && PL_expect == XSTATE
3854 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
3856 yylval.pval = savepv(PL_tokenbuf);
3861 /* Check for keywords */
3862 tmp = keyword(PL_tokenbuf, len);
3864 /* Is this a word before a => operator? */
3865 if (*d == '=' && d[1] == '>') {
3867 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
3868 yylval.opval->op_private = OPpCONST_BARE;
3869 if (UTF && !IN_BYTE && is_utf8_string((U8*)PL_tokenbuf, len))
3870 SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
3874 if (tmp < 0) { /* second-class keyword? */
3875 GV *ogv = Nullgv; /* override (winner) */
3876 GV *hgv = Nullgv; /* hidden (loser) */
3877 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3879 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3882 if (GvIMPORTED_CV(gv))
3884 else if (! CvMETHOD(cv))
3888 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3889 (gv = *gvp) != (GV*)&PL_sv_undef &&
3890 GvCVu(gv) && GvIMPORTED_CV(gv))
3896 tmp = 0; /* overridden by import or by GLOBAL */
3899 && -tmp==KEY_lock /* XXX generalizable kludge */
3901 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3903 tmp = 0; /* any sub overrides "weak" keyword */
3905 else { /* no override */
3909 if (ckWARN(WARN_AMBIGUOUS) && hgv
3910 && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3911 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3912 "Ambiguous call resolved as CORE::%s(), %s",
3913 GvENAME(hgv), "qualify as such or use &");
3920 default: /* not a keyword */
3923 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3925 /* Get the rest if it looks like a package qualifier */
3927 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
3929 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3932 Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
3933 *s == '\'' ? "'" : "::");
3937 if (PL_expect == XOPERATOR) {
3938 if (PL_bufptr == PL_linestart) {
3939 CopLINE_dec(PL_curcop);
3940 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3941 CopLINE_inc(PL_curcop);
3944 no_op("Bareword",s);
3947 /* Look for a subroutine with this name in current package,
3948 unless name is "Foo::", in which case Foo is a bearword
3949 (and a package name). */
3952 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3954 if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3955 Perl_warner(aTHX_ WARN_BAREWORD,
3956 "Bareword \"%s\" refers to nonexistent package",
3959 PL_tokenbuf[len] = '\0';
3966 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3969 /* if we saw a global override before, get the right name */
3972 sv = newSVpvn("CORE::GLOBAL::",14);
3973 sv_catpv(sv,PL_tokenbuf);
3976 sv = newSVpv(PL_tokenbuf,0);
3978 /* Presume this is going to be a bareword of some sort. */
3981 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3982 yylval.opval->op_private = OPpCONST_BARE;
3984 /* And if "Foo::", then that's what it certainly is. */
3989 /* See if it's the indirect object for a list operator. */
3991 if (PL_oldoldbufptr &&
3992 PL_oldoldbufptr < PL_bufptr &&
3993 (PL_oldoldbufptr == PL_last_lop
3994 || PL_oldoldbufptr == PL_last_uni) &&
3995 /* NO SKIPSPACE BEFORE HERE! */
3996 (PL_expect == XREF ||
3997 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
3999 bool immediate_paren = *s == '(';
4001 /* (Now we can afford to cross potential line boundary.) */
4004 /* Two barewords in a row may indicate method call. */
4006 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp=intuit_method(s,gv)))
4009 /* If not a declared subroutine, it's an indirect object. */
4010 /* (But it's an indir obj regardless for sort.) */
4012 if ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
4013 ((!gv || !GvCVu(gv)) &&
4014 (PL_last_lop_op != OP_MAPSTART &&
4015 PL_last_lop_op != OP_GREPSTART))))
4017 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
4023 PL_expect = XOPERATOR;
4026 /* Is this a word before a => operator? */
4027 if (*s == '=' && s[1] == '>') {
4029 sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
4030 if (UTF && !IN_BYTE && is_utf8_string((U8*)PL_tokenbuf, len))
4031 SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
4035 /* If followed by a paren, it's certainly a subroutine. */
4038 if (gv && GvCVu(gv)) {
4039 for (d = s + 1; SPACE_OR_TAB(*d); d++) ;
4040 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
4045 PL_nextval[PL_nexttoke].opval = yylval.opval;
4046 PL_expect = XOPERATOR;
4052 /* If followed by var or block, call it a method (unless sub) */
4054 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
4055 PL_last_lop = PL_oldbufptr;
4056 PL_last_lop_op = OP_METHOD;
4060 /* If followed by a bareword, see if it looks like indir obj. */
4062 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp = intuit_method(s,gv)))
4065 /* Not a method, so call it a subroutine (if defined) */
4067 if (gv && GvCVu(gv)) {
4069 if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
4070 Perl_warner(aTHX_ WARN_AMBIGUOUS,
4071 "Ambiguous use of -%s resolved as -&%s()",
4072 PL_tokenbuf, PL_tokenbuf);
4073 /* Check for a constant sub */
4075 if ((sv = cv_const_sv(cv))) {
4077 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
4078 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
4079 yylval.opval->op_private = 0;
4083 /* Resolve to GV now. */
4084 op_free(yylval.opval);
4085 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
4086 yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
4087 PL_last_lop = PL_oldbufptr;
4088 PL_last_lop_op = OP_ENTERSUB;
4089 /* Is there a prototype? */
4092 char *proto = SvPV((SV*)cv, len);
4095 if (strEQ(proto, "$"))
4097 if (*proto == '&' && *s == '{') {
4098 sv_setpv(PL_subname,"__ANON__");
4102 PL_nextval[PL_nexttoke].opval = yylval.opval;
4108 /* Call it a bare word */
4110 if (PL_hints & HINT_STRICT_SUBS)
4111 yylval.opval->op_private |= OPpCONST_STRICT;
4114 if (ckWARN(WARN_RESERVED)) {
4115 if (lastchar != '-') {
4116 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
4118 Perl_warner(aTHX_ WARN_RESERVED, PL_warn_reserved,
4125 if (lastchar && strchr("*%&", lastchar) && ckWARN_d(WARN_AMBIGUOUS)) {
4126 Perl_warner(aTHX_ WARN_AMBIGUOUS,
4127 "Operator or semicolon missing before %c%s",
4128 lastchar, PL_tokenbuf);
4129 Perl_warner(aTHX_ WARN_AMBIGUOUS,
4130 "Ambiguous use of %c resolved as operator %c",
4131 lastchar, lastchar);
4137 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4138 newSVpv(CopFILE(PL_curcop),0));
4142 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4143 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
4146 case KEY___PACKAGE__:
4147 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4149 ? newSVsv(PL_curstname)
4158 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
4159 char *pname = "main";
4160 if (PL_tokenbuf[2] == 'D')
4161 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
4162 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
4165 GvIOp(gv) = newIO();
4166 IoIFP(GvIOp(gv)) = PL_rsfp;
4167 #if defined(HAS_FCNTL) && defined(F_SETFD)
4169 int fd = PerlIO_fileno(PL_rsfp);
4170 fcntl(fd,F_SETFD,fd >= 3);
4173 /* Mark this internal pseudo-handle as clean */
4174 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
4176 IoTYPE(GvIOp(gv)) = IoTYPE_PIPE;
4177 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
4178 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
4180 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
4181 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
4182 /* if the script was opened in binmode, we need to revert
4183 * it to text mode for compatibility; but only iff it has CRs
4184 * XXX this is a questionable hack at best. */
4185 if (PL_bufend-PL_bufptr > 2
4186 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
4189 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
4190 loc = PerlIO_tell(PL_rsfp);
4191 (void)PerlIO_seek(PL_rsfp, 0L, 0);
4193 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
4195 PerlIO_seek(PL_rsfp, loc, 0);
4199 #ifdef PERLIO_LAYERS
4200 if (UTF && !IN_BYTE)
4201 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
4214 if (PL_expect == XSTATE) {
4221 if (*s == ':' && s[1] == ':') {
4224 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4225 if (!(tmp = keyword(PL_tokenbuf, len)))
4226 Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
4240 LOP(OP_ACCEPT,XTERM);
4246 LOP(OP_ATAN2,XTERM);
4252 LOP(OP_BINMODE,XTERM);
4255 LOP(OP_BLESS,XTERM);
4264 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
4281 if (!PL_cryptseen) {
4282 PL_cryptseen = TRUE;
4286 LOP(OP_CRYPT,XTERM);
4289 if (ckWARN(WARN_CHMOD)) {
4290 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4291 if (*d != '0' && isDIGIT(*d))
4292 Perl_warner(aTHX_ WARN_CHMOD,
4293 "chmod() mode argument is missing initial 0");
4295 LOP(OP_CHMOD,XTERM);
4298 LOP(OP_CHOWN,XTERM);
4301 LOP(OP_CONNECT,XTERM);
4317 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4321 PL_hints |= HINT_BLOCK_SCOPE;
4331 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
4332 LOP(OP_DBMOPEN,XTERM);
4338 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4345 yylval.ival = CopLINE(PL_curcop);
4359 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
4360 UNIBRACK(OP_ENTEREVAL);
4375 case KEY_endhostent:
4381 case KEY_endservent:
4384 case KEY_endprotoent:
4395 yylval.ival = CopLINE(PL_curcop);
4397 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
4399 if ((PL_bufend - p) >= 3 &&
4400 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
4402 else if ((PL_bufend - p) >= 4 &&
4403 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
4406 if (isIDFIRST_lazy_if(p,UTF)) {
4407 p = scan_ident(p, PL_bufend,
4408 PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4412 Perl_croak(aTHX_ "Missing $ on loop variable");
4417 LOP(OP_FORMLINE,XTERM);
4423 LOP(OP_FCNTL,XTERM);
4429 LOP(OP_FLOCK,XTERM);
4438 LOP(OP_GREPSTART, XREF);
4441 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4456 case KEY_getpriority:
4457 LOP(OP_GETPRIORITY,XTERM);
4459 case KEY_getprotobyname:
4462 case KEY_getprotobynumber:
4463 LOP(OP_GPBYNUMBER,XTERM);
4465 case KEY_getprotoent:
4477 case KEY_getpeername:
4478 UNI(OP_GETPEERNAME);
4480 case KEY_gethostbyname:
4483 case KEY_gethostbyaddr:
4484 LOP(OP_GHBYADDR,XTERM);
4486 case KEY_gethostent:
4489 case KEY_getnetbyname:
4492 case KEY_getnetbyaddr:
4493 LOP(OP_GNBYADDR,XTERM);
4498 case KEY_getservbyname:
4499 LOP(OP_GSBYNAME,XTERM);
4501 case KEY_getservbyport:
4502 LOP(OP_GSBYPORT,XTERM);
4504 case KEY_getservent:
4507 case KEY_getsockname:
4508 UNI(OP_GETSOCKNAME);
4510 case KEY_getsockopt:
4511 LOP(OP_GSOCKOPT,XTERM);
4533 yylval.ival = CopLINE(PL_curcop);
4537 LOP(OP_INDEX,XTERM);
4543 LOP(OP_IOCTL,XTERM);
4555 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4587 LOP(OP_LISTEN,XTERM);
4596 s = scan_pat(s,OP_MATCH);
4597 TERM(sublex_start());
4600 LOP(OP_MAPSTART, XREF);
4603 LOP(OP_MKDIR,XTERM);
4606 LOP(OP_MSGCTL,XTERM);
4609 LOP(OP_MSGGET,XTERM);
4612 LOP(OP_MSGRCV,XTERM);
4615 LOP(OP_MSGSND,XTERM);
4621 if (isIDFIRST_lazy_if(s,UTF)) {
4622 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
4623 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
4625 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
4626 if (!PL_in_my_stash) {
4629 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
4637 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4644 if (PL_expect != XSTATE)
4645 yyerror("\"no\" not allowed in expression");
4646 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4647 s = force_version(s);
4652 if (*s == '(' || (s = skipspace(s), *s == '('))
4659 if (isIDFIRST_lazy_if(s,UTF)) {
4661 for (d = s; isALNUM_lazy_if(d,UTF); d++) ;
4663 if (strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE))
4664 Perl_warner(aTHX_ WARN_PRECEDENCE,
4665 "Precedence problem: open %.*s should be open(%.*s)",
4671 yylval.ival = OP_OR;
4681 LOP(OP_OPEN_DIR,XTERM);
4684 checkcomma(s,PL_tokenbuf,"filehandle");
4688 checkcomma(s,PL_tokenbuf,"filehandle");
4707 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4711 LOP(OP_PIPE_OP,XTERM);
4714 s = scan_str(s,FALSE,FALSE);
4716 missingterm((char*)0);
4717 yylval.ival = OP_CONST;
4718 TERM(sublex_start());
4724 s = scan_str(s,FALSE,FALSE);
4726 missingterm((char*)0);
4728 if (SvCUR(PL_lex_stuff)) {
4731 d = SvPV_force(PL_lex_stuff, len);
4734 for (; isSPACE(*d) && len; --len, ++d) ;
4737 if (!warned && ckWARN(WARN_QW)) {
4738 for (; !isSPACE(*d) && len; --len, ++d) {
4740 Perl_warner(aTHX_ WARN_QW,
4741 "Possible attempt to separate words with commas");
4744 else if (*d == '#') {
4745 Perl_warner(aTHX_ WARN_QW,
4746 "Possible attempt to put comments in qw() list");
4752 for (; !isSPACE(*d) && len; --len, ++d) ;
4754 sv = newSVpvn(b, d-b);
4755 if (DO_UTF8(PL_lex_stuff))
4757 words = append_elem(OP_LIST, words,
4758 newSVOP(OP_CONST, 0, tokeq(sv)));
4762 PL_nextval[PL_nexttoke].opval = words;
4767 SvREFCNT_dec(PL_lex_stuff);
4768 PL_lex_stuff = Nullsv;
4774 s = scan_str(s,FALSE,FALSE);
4776 missingterm((char*)0);
4777 yylval.ival = OP_STRINGIFY;
4778 if (SvIVX(PL_lex_stuff) == '\'')
4779 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
4780 TERM(sublex_start());
4783 s = scan_pat(s,OP_QR);
4784 TERM(sublex_start());
4787 s = scan_str(s,FALSE,FALSE);
4789 missingterm((char*)0);
4790 yylval.ival = OP_BACKTICK;
4792 TERM(sublex_start());
4799 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4800 s = force_version(s);
4803 *PL_tokenbuf = '\0';
4804 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4805 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
4806 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
4808 yyerror("<> should be quotes");
4816 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4820 LOP(OP_RENAME,XTERM);
4829 LOP(OP_RINDEX,XTERM);
4852 LOP(OP_REVERSE,XTERM);
4863 TERM(sublex_start());
4865 TOKEN(1); /* force error */
4874 LOP(OP_SELECT,XTERM);
4880 LOP(OP_SEMCTL,XTERM);
4883 LOP(OP_SEMGET,XTERM);
4886 LOP(OP_SEMOP,XTERM);
4892 LOP(OP_SETPGRP,XTERM);
4894 case KEY_setpriority:
4895 LOP(OP_SETPRIORITY,XTERM);
4897 case KEY_sethostent:
4903 case KEY_setservent:
4906 case KEY_setprotoent:
4916 LOP(OP_SEEKDIR,XTERM);
4918 case KEY_setsockopt:
4919 LOP(OP_SSOCKOPT,XTERM);
4925 LOP(OP_SHMCTL,XTERM);
4928 LOP(OP_SHMGET,XTERM);
4931 LOP(OP_SHMREAD,XTERM);
4934 LOP(OP_SHMWRITE,XTERM);
4937 LOP(OP_SHUTDOWN,XTERM);
4946 LOP(OP_SOCKET,XTERM);
4948 case KEY_socketpair:
4949 LOP(OP_SOCKPAIR,XTERM);
4952 checkcomma(s,PL_tokenbuf,"subroutine name");
4954 if (*s == ';' || *s == ')') /* probably a close */
4955 Perl_croak(aTHX_ "sort is now a reserved word");
4957 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4961 LOP(OP_SPLIT,XTERM);
4964 LOP(OP_SPRINTF,XTERM);
4967 LOP(OP_SPLICE,XTERM);
4982 LOP(OP_SUBSTR,XTERM);
4988 char tmpbuf[sizeof PL_tokenbuf];
4990 expectation attrful;
4991 bool have_name, have_proto;
4996 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
4997 (*s == ':' && s[1] == ':'))
5000 attrful = XATTRBLOCK;
5001 /* remember buffer pos'n for later force_word */
5002 tboffset = s - PL_oldbufptr;
5003 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
5004 if (strchr(tmpbuf, ':'))
5005 sv_setpv(PL_subname, tmpbuf);
5007 sv_setsv(PL_subname,PL_curstname);
5008 sv_catpvn(PL_subname,"::",2);
5009 sv_catpvn(PL_subname,tmpbuf,len);
5016 Perl_croak(aTHX_ "Missing name in \"my sub\"");
5017 PL_expect = XTERMBLOCK;
5018 attrful = XATTRTERM;
5019 sv_setpv(PL_subname,"?");
5023 if (key == KEY_format) {
5025 PL_lex_formbrack = PL_lex_brackets + 1;
5027 (void) force_word(PL_oldbufptr + tboffset, WORD,
5032 /* Look for a prototype */
5036 s = scan_str(s,FALSE,FALSE);
5038 Perl_croak(aTHX_ "Prototype not terminated");
5040 d = SvPVX(PL_lex_stuff);
5042 for (p = d; *p; ++p) {
5047 SvCUR(PL_lex_stuff) = tmp;
5055 if (*s == ':' && s[1] != ':')
5056 PL_expect = attrful;
5059 PL_nextval[PL_nexttoke].opval =
5060 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
5061 PL_lex_stuff = Nullsv;
5065 sv_setpv(PL_subname,"__ANON__");
5068 (void) force_word(PL_oldbufptr + tboffset, WORD,
5077 LOP(OP_SYSTEM,XREF);
5080 LOP(OP_SYMLINK,XTERM);
5083 LOP(OP_SYSCALL,XTERM);
5086 LOP(OP_SYSOPEN,XTERM);
5089 LOP(OP_SYSSEEK,XTERM);
5092 LOP(OP_SYSREAD,XTERM);
5095 LOP(OP_SYSWRITE,XTERM);
5099 TERM(sublex_start());
5120 LOP(OP_TRUNCATE,XTERM);
5132 yylval.ival = CopLINE(PL_curcop);
5136 yylval.ival = CopLINE(PL_curcop);
5140 LOP(OP_UNLINK,XTERM);
5146 LOP(OP_UNPACK,XTERM);
5149 LOP(OP_UTIME,XTERM);
5152 if (ckWARN(WARN_UMASK)) {
5153 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
5154 if (*d != '0' && isDIGIT(*d))
5155 Perl_warner(aTHX_ WARN_UMASK,
5156 "umask: argument is missing initial 0");
5161 LOP(OP_UNSHIFT,XTERM);
5164 if (PL_expect != XSTATE)
5165 yyerror("\"use\" not allowed in expression");
5167 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
5168 s = force_version(s);
5169 if (*s == ';' || (s = skipspace(s), *s == ';')) {
5170 PL_nextval[PL_nexttoke].opval = Nullop;
5175 s = force_word(s,WORD,FALSE,TRUE,FALSE);
5176 s = force_version(s);
5188 yylval.ival = CopLINE(PL_curcop);
5192 PL_hints |= HINT_BLOCK_SCOPE;
5199 LOP(OP_WAITPID,XTERM);
5207 static char ctl_l[2];
5209 if (ctl_l[0] == '\0')
5210 ctl_l[0] = toCTRL('L');
5211 gv_fetchpv(ctl_l,TRUE, SVt_PV);
5214 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
5219 if (PL_expect == XOPERATOR)
5225 yylval.ival = OP_XOR;
5230 TERM(sublex_start());
5235 #pragma segment Main
5239 Perl_keyword(pTHX_ register char *d, I32 len)
5244 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
5245 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
5246 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
5247 if (strEQ(d,"__DATA__")) return KEY___DATA__;
5248 if (strEQ(d,"__END__")) return KEY___END__;
5252 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
5257 if (strEQ(d,"and")) return -KEY_and;
5258 if (strEQ(d,"abs")) return -KEY_abs;
5261 if (strEQ(d,"alarm")) return -KEY_alarm;
5262 if (strEQ(d,"atan2")) return -KEY_atan2;
5265 if (strEQ(d,"accept")) return -KEY_accept;
5270 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
5273 if (strEQ(d,"bless")) return -KEY_bless;
5274 if (strEQ(d,"bind")) return -KEY_bind;
5275 if (strEQ(d,"binmode")) return -KEY_binmode;
5278 if (strEQ(d,"CORE")) return -KEY_CORE;
5279 if (strEQ(d,"CHECK")) return KEY_CHECK;
5284 if (strEQ(d,"cmp")) return -KEY_cmp;
5285 if (strEQ(d,"chr")) return -KEY_chr;
5286 if (strEQ(d,"cos")) return -KEY_cos;
5289 if (strEQ(d,"chop")) return -KEY_chop;
5292 if (strEQ(d,"close")) return -KEY_close;
5293 if (strEQ(d,"chdir")) return -KEY_chdir;
5294 if (strEQ(d,"chomp")) return -KEY_chomp;
5295 if (strEQ(d,"chmod")) return -KEY_chmod;
5296 if (strEQ(d,"chown")) return -KEY_chown;
5297 if (strEQ(d,"crypt")) return -KEY_crypt;
5300 if (strEQ(d,"chroot")) return -KEY_chroot;
5301 if (strEQ(d,"caller")) return -KEY_caller;
5304 if (strEQ(d,"connect")) return -KEY_connect;
5307 if (strEQ(d,"closedir")) return -KEY_closedir;
5308 if (strEQ(d,"continue")) return -KEY_continue;
5313 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
5318 if (strEQ(d,"do")) return KEY_do;
5321 if (strEQ(d,"die")) return -KEY_die;
5324 if (strEQ(d,"dump")) return -KEY_dump;
5327 if (strEQ(d,"delete")) return KEY_delete;
5330 if (strEQ(d,"defined")) return KEY_defined;
5331 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
5334 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
5339 if (strEQ(d,"END")) return KEY_END;
5344 if (strEQ(d,"eq")) return -KEY_eq;
5347 if (strEQ(d,"eof")) return -KEY_eof;
5348 if (strEQ(d,"exp")) return -KEY_exp;
5351 if (strEQ(d,"else")) return KEY_else;
5352 if (strEQ(d,"exit")) return -KEY_exit;
5353 if (strEQ(d,"eval")) return KEY_eval;
5354 if (strEQ(d,"exec")) return -KEY_exec;
5355 if (strEQ(d,"each")) return -KEY_each;
5358 if (strEQ(d,"elsif")) return KEY_elsif;
5361 if (strEQ(d,"exists")) return KEY_exists;
5362 if (strEQ(d,"elseif")) Perl_warn(aTHX_ "elseif should be elsif");
5365 if (strEQ(d,"endgrent")) return -KEY_endgrent;
5366 if (strEQ(d,"endpwent")) return -KEY_endpwent;
5369 if (strEQ(d,"endnetent")) return -KEY_endnetent;
5372 if (strEQ(d,"endhostent")) return -KEY_endhostent;
5373 if (strEQ(d,"endservent")) return -KEY_endservent;
5376 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
5383 if (strEQ(d,"for")) return KEY_for;
5386 if (strEQ(d,"fork")) return -KEY_fork;
5389 if (strEQ(d,"fcntl")) return -KEY_fcntl;
5390 if (strEQ(d,"flock")) return -KEY_flock;
5393 if (strEQ(d,"format")) return KEY_format;
5394 if (strEQ(d,"fileno")) return -KEY_fileno;
5397 if (strEQ(d,"foreach")) return KEY_foreach;
5400 if (strEQ(d,"formline")) return -KEY_formline;
5405 if (strnEQ(d,"get",3)) {
5410 if (strEQ(d,"ppid")) return -KEY_getppid;
5411 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
5414 if (strEQ(d,"pwent")) return -KEY_getpwent;
5415 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
5416 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
5419 if (strEQ(d,"peername")) return -KEY_getpeername;
5420 if (strEQ(d,"protoent")) return -KEY_getprotoent;
5421 if (strEQ(d,"priority")) return -KEY_getpriority;
5424 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
5427 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
5431 else if (*d == 'h') {
5432 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
5433 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
5434 if (strEQ(d,"hostent")) return -KEY_gethostent;
5436 else if (*d == 'n') {
5437 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
5438 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
5439 if (strEQ(d,"netent")) return -KEY_getnetent;
5441 else if (*d == 's') {
5442 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
5443 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
5444 if (strEQ(d,"servent")) return -KEY_getservent;
5445 if (strEQ(d,"sockname")) return -KEY_getsockname;
5446 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
5448 else if (*d == 'g') {
5449 if (strEQ(d,"grent")) return -KEY_getgrent;
5450 if (strEQ(d,"grnam")) return -KEY_getgrnam;
5451 if (strEQ(d,"grgid")) return -KEY_getgrgid;
5453 else if (*d == 'l') {
5454 if (strEQ(d,"login")) return -KEY_getlogin;
5456 else if (strEQ(d,"c")) return -KEY_getc;
5461 if (strEQ(d,"gt")) return -KEY_gt;
5462 if (strEQ(d,"ge")) return -KEY_ge;
5465 if (strEQ(d,"grep")) return KEY_grep;
5466 if (strEQ(d,"goto")) return KEY_goto;
5467 if (strEQ(d,"glob")) return KEY_glob;
5470 if (strEQ(d,"gmtime")) return -KEY_gmtime;
5475 if (strEQ(d,"hex")) return -KEY_hex;
5478 if (strEQ(d,"INIT")) return KEY_INIT;
5483 if (strEQ(d,"if")) return KEY_if;
5486 if (strEQ(d,"int")) return -KEY_int;
5489 if (strEQ(d,"index")) return -KEY_index;
5490 if (strEQ(d,"ioctl")) return -KEY_ioctl;
5495 if (strEQ(d,"join")) return -KEY_join;
5499 if (strEQ(d,"keys")) return -KEY_keys;
5500 if (strEQ(d,"kill")) return -KEY_kill;
5506 if (strEQ(d,"lt")) return -KEY_lt;
5507 if (strEQ(d,"le")) return -KEY_le;
5508 if (strEQ(d,"lc")) return -KEY_lc;
5511 if (strEQ(d,"log")) return -KEY_log;
5514 if (strEQ(d,"last")) return KEY_last;
5515 if (strEQ(d,"link")) return -KEY_link;
5516 if (strEQ(d,"lock")) return -KEY_lock;
5519 if (strEQ(d,"local")) return KEY_local;
5520 if (strEQ(d,"lstat")) return -KEY_lstat;
5523 if (strEQ(d,"length")) return -KEY_length;
5524 if (strEQ(d,"listen")) return -KEY_listen;
5527 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
5530 if (strEQ(d,"localtime")) return -KEY_localtime;
5536 case 1: return KEY_m;
5538 if (strEQ(d,"my")) return KEY_my;
5541 if (strEQ(d,"map")) return KEY_map;
5544 if (strEQ(d,"mkdir")) return -KEY_mkdir;
5547 if (strEQ(d,"msgctl")) return -KEY_msgctl;
5548 if (strEQ(d,"msgget")) return -KEY_msgget;
5549 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
5550 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
5555 if (strEQ(d,"next")) return KEY_next;
5556 if (strEQ(d,"ne")) return -KEY_ne;
5557 if (strEQ(d,"not")) return -KEY_not;
5558 if (strEQ(d,"no")) return KEY_no;
5563 if (strEQ(d,"or")) return -KEY_or;
5566 if (strEQ(d,"ord")) return -KEY_ord;
5567 if (strEQ(d,"oct")) return -KEY_oct;
5568 if (strEQ(d,"our")) return KEY_our;
5571 if (strEQ(d,"open")) return -KEY_open;
5574 if (strEQ(d,"opendir")) return -KEY_opendir;
5581 if (strEQ(d,"pop")) return -KEY_pop;
5582 if (strEQ(d,"pos")) return KEY_pos;
5585 if (strEQ(d,"push")) return -KEY_push;
5586 if (strEQ(d,"pack")) return -KEY_pack;
5587 if (strEQ(d,"pipe")) return -KEY_pipe;
5590 if (strEQ(d,"print")) return KEY_print;
5593 if (strEQ(d,"printf")) return KEY_printf;
5596 if (strEQ(d,"package")) return KEY_package;
5599 if (strEQ(d,"prototype")) return KEY_prototype;
5604 if (strEQ(d,"q")) return KEY_q;
5605 if (strEQ(d,"qr")) return KEY_qr;
5606 if (strEQ(d,"qq")) return KEY_qq;
5607 if (strEQ(d,"qw")) return KEY_qw;
5608 if (strEQ(d,"qx")) return KEY_qx;
5610 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
5615 if (strEQ(d,"ref")) return -KEY_ref;
5618 if (strEQ(d,"read")) return -KEY_read;
5619 if (strEQ(d,"rand")) return -KEY_rand;
5620 if (strEQ(d,"recv")) return -KEY_recv;
5621 if (strEQ(d,"redo")) return KEY_redo;
5624 if (strEQ(d,"rmdir")) return -KEY_rmdir;
5625 if (strEQ(d,"reset")) return -KEY_reset;
5628 if (strEQ(d,"return")) return KEY_return;
5629 if (strEQ(d,"rename")) return -KEY_rename;
5630 if (strEQ(d,"rindex")) return -KEY_rindex;
5633 if (strEQ(d,"require")) return -KEY_require;
5634 if (strEQ(d,"reverse")) return -KEY_reverse;
5635 if (strEQ(d,"readdir")) return -KEY_readdir;
5638 if (strEQ(d,"readlink")) return -KEY_readlink;
5639 if (strEQ(d,"readline")) return -KEY_readline;
5640 if (strEQ(d,"readpipe")) return -KEY_readpipe;
5643 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
5649 case 0: return KEY_s;
5651 if (strEQ(d,"scalar")) return KEY_scalar;
5656 if (strEQ(d,"seek")) return -KEY_seek;
5657 if (strEQ(d,"send")) return -KEY_send;
5660 if (strEQ(d,"semop")) return -KEY_semop;
5663 if (strEQ(d,"select")) return -KEY_select;
5664 if (strEQ(d,"semctl")) return -KEY_semctl;
5665 if (strEQ(d,"semget")) return -KEY_semget;
5668 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
5669 if (strEQ(d,"seekdir")) return -KEY_seekdir;
5672 if (strEQ(d,"setpwent")) return -KEY_setpwent;
5673 if (strEQ(d,"setgrent")) return -KEY_setgrent;
5676 if (strEQ(d,"setnetent")) return -KEY_setnetent;
5679 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
5680 if (strEQ(d,"sethostent")) return -KEY_sethostent;
5681 if (strEQ(d,"setservent")) return -KEY_setservent;
5684 if (strEQ(d,"setpriority")) return -KEY_setpriority;
5685 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
5692 if (strEQ(d,"shift")) return -KEY_shift;
5695 if (strEQ(d,"shmctl")) return -KEY_shmctl;
5696 if (strEQ(d,"shmget")) return -KEY_shmget;
5699 if (strEQ(d,"shmread")) return -KEY_shmread;
5702 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
5703 if (strEQ(d,"shutdown")) return -KEY_shutdown;
5708 if (strEQ(d,"sin")) return -KEY_sin;
5711 if (strEQ(d,"sleep")) return -KEY_sleep;
5714 if (strEQ(d,"sort")) return KEY_sort;
5715 if (strEQ(d,"socket")) return -KEY_socket;
5716 if (strEQ(d,"socketpair")) return -KEY_socketpair;
5719 if (strEQ(d,"split")) return KEY_split;
5720 if (strEQ(d,"sprintf")) return -KEY_sprintf;
5721 if (strEQ(d,"splice")) return -KEY_splice;
5724 if (strEQ(d,"sqrt")) return -KEY_sqrt;
5727 if (strEQ(d,"srand")) return -KEY_srand;
5730 if (strEQ(d,"stat")) return -KEY_stat;
5731 if (strEQ(d,"study")) return KEY_study;
5734 if (strEQ(d,"substr")) return -KEY_substr;
5735 if (strEQ(d,"sub")) return KEY_sub;
5740 if (strEQ(d,"system")) return -KEY_system;
5743 if (strEQ(d,"symlink")) return -KEY_symlink;
5744 if (strEQ(d,"syscall")) return -KEY_syscall;
5745 if (strEQ(d,"sysopen")) return -KEY_sysopen;
5746 if (strEQ(d,"sysread")) return -KEY_sysread;
5747 if (strEQ(d,"sysseek")) return -KEY_sysseek;
5750 if (strEQ(d,"syswrite")) return -KEY_syswrite;
5759 if (strEQ(d,"tr")) return KEY_tr;
5762 if (strEQ(d,"tie")) return KEY_tie;
5765 if (strEQ(d,"tell")) return -KEY_tell;
5766 if (strEQ(d,"tied")) return KEY_tied;
5767 if (strEQ(d,"time")) return -KEY_time;
5770 if (strEQ(d,"times")) return -KEY_times;
5773 if (strEQ(d,"telldir")) return -KEY_telldir;
5776 if (strEQ(d,"truncate")) return -KEY_truncate;
5783 if (strEQ(d,"uc")) return -KEY_uc;
5786 if (strEQ(d,"use")) return KEY_use;
5789 if (strEQ(d,"undef")) return KEY_undef;
5790 if (strEQ(d,"until")) return KEY_until;
5791 if (strEQ(d,"untie")) return KEY_untie;
5792 if (strEQ(d,"utime")) return -KEY_utime;
5793 if (strEQ(d,"umask")) return -KEY_umask;
5796 if (strEQ(d,"unless")) return KEY_unless;
5797 if (strEQ(d,"unpack")) return -KEY_unpack;
5798 if (strEQ(d,"unlink")) return -KEY_unlink;
5801 if (strEQ(d,"unshift")) return -KEY_unshift;
5802 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
5807 if (strEQ(d,"values")) return -KEY_values;
5808 if (strEQ(d,"vec")) return -KEY_vec;
5813 if (strEQ(d,"warn")) return -KEY_warn;
5814 if (strEQ(d,"wait")) return -KEY_wait;
5817 if (strEQ(d,"while")) return KEY_while;
5818 if (strEQ(d,"write")) return -KEY_write;
5821 if (strEQ(d,"waitpid")) return -KEY_waitpid;
5824 if (strEQ(d,"wantarray")) return -KEY_wantarray;
5829 if (len == 1) return -KEY_x;
5830 if (strEQ(d,"xor")) return -KEY_xor;
5833 if (len == 1) return KEY_y;
5842 S_checkcomma(pTHX_ register char *s, char *name, char *what)
5846 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
5847 if (ckWARN(WARN_SYNTAX)) {
5849 for (w = s+2; *w && level; w++) {
5856 for (; *w && isSPACE(*w); w++) ;
5857 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
5858 Perl_warner(aTHX_ WARN_SYNTAX,
5859 "%s (...) interpreted as function",name);
5862 while (s < PL_bufend && isSPACE(*s))
5866 while (s < PL_bufend && isSPACE(*s))
5868 if (isIDFIRST_lazy_if(s,UTF)) {
5870 while (isALNUM_lazy_if(s,UTF))
5872 while (s < PL_bufend && isSPACE(*s))
5877 kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
5881 Perl_croak(aTHX_ "No comma allowed after %s", what);
5886 /* Either returns sv, or mortalizes sv and returns a new SV*.
5887 Best used as sv=new_constant(..., sv, ...).
5888 If s, pv are NULL, calls subroutine with one argument,
5889 and type is used with error messages only. */
5892 S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv,
5896 HV *table = GvHV(PL_hintgv); /* ^H */
5900 const char *why1, *why2, *why3;
5902 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
5905 why2 = strEQ(key,"charnames")
5906 ? "(possibly a missing \"use charnames ...\")"
5908 msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
5909 (type ? type: "undef"), why2);
5911 /* This is convoluted and evil ("goto considered harmful")
5912 * but I do not understand the intricacies of all the different
5913 * failure modes of %^H in here. The goal here is to make
5914 * the most probable error message user-friendly. --jhi */
5919 msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
5920 (type ? type: "undef"), why1, why2, why3);
5922 yyerror(SvPVX(msg));
5926 cvp = hv_fetch(table, key, strlen(key), FALSE);
5927 if (!cvp || !SvOK(*cvp)) {
5930 why3 = "} is not defined";
5933 sv_2mortal(sv); /* Parent created it permanently */
5936 pv = sv_2mortal(newSVpvn(s, len));
5938 typesv = sv_2mortal(newSVpv(type, 0));
5940 typesv = &PL_sv_undef;
5942 PUSHSTACKi(PERLSI_OVERLOAD);
5954 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
5958 /* Check the eval first */
5959 if (!PL_in_eval && SvTRUE(ERRSV)) {
5961 sv_catpv(ERRSV, "Propagated");
5962 yyerror(SvPV(ERRSV, n_a)); /* Duplicates the message inside eval */
5964 res = SvREFCNT_inc(sv);
5968 (void)SvREFCNT_inc(res);
5977 why1 = "Call to &{$^H{";
5979 why3 = "}} did not return a defined value";
5988 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
5990 register char *d = dest;
5991 register char *e = d + destlen - 3; /* two-character token, ending NUL */
5994 Perl_croak(aTHX_ ident_too_long);
5995 if (isALNUM(*s)) /* UTF handled below */
5997 else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) {
6002 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
6006 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
6007 char *t = s + UTF8SKIP(s);
6008 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
6010 if (d + (t - s) > e)
6011 Perl_croak(aTHX_ ident_too_long);
6012 Copy(s, d, t - s, char);
6025 S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
6035 e = d + destlen - 3; /* two-character token, ending NUL */
6037 while (isDIGIT(*s)) {
6039 Perl_croak(aTHX_ ident_too_long);
6046 Perl_croak(aTHX_ ident_too_long);
6047 if (isALNUM(*s)) /* UTF handled below */
6049 else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
6054 else if (*s == ':' && s[1] == ':') {
6058 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
6059 char *t = s + UTF8SKIP(s);
6060 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
6062 if (d + (t - s) > e)
6063 Perl_croak(aTHX_ ident_too_long);
6064 Copy(s, d, t - s, char);
6075 if (PL_lex_state != LEX_NORMAL)
6076 PL_lex_state = LEX_INTERPENDMAYBE;
6079 if (*s == '$' && s[1] &&
6080 (isALNUM_lazy_if(s+1,UTF) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
6093 if (*d == '^' && *s && isCONTROLVAR(*s)) {
6098 if (isSPACE(s[-1])) {
6101 if (!SPACE_OR_TAB(ch)) {
6107 if (isIDFIRST_lazy_if(d,UTF)) {
6111 while ((e < send && isALNUM_lazy_if(e,UTF)) || *e == ':') {
6113 while (e < send && UTF8_IS_CONTINUED(*e) && is_utf8_mark((U8*)e))
6116 Copy(s, d, e - s, char);
6121 while ((isALNUM(*s) || *s == ':') && d < e)
6124 Perl_croak(aTHX_ ident_too_long);
6127 while (s < send && SPACE_OR_TAB(*s)) s++;
6128 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
6129 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
6130 const char *brack = *s == '[' ? "[...]" : "{...}";
6131 Perl_warner(aTHX_ WARN_AMBIGUOUS,
6132 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
6133 funny, dest, brack, funny, dest, brack);
6136 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
6140 /* Handle extended ${^Foo} variables
6141 * 1999-02-27 mjd-perl-patch@plover.com */
6142 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
6146 while (isALNUM(*s) && d < e) {
6150 Perl_croak(aTHX_ ident_too_long);
6155 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
6156 PL_lex_state = LEX_INTERPEND;
6159 if (PL_lex_state == LEX_NORMAL) {
6160 if (ckWARN(WARN_AMBIGUOUS) &&
6161 (keyword(dest, d - dest) || get_cv(dest, FALSE)))
6163 Perl_warner(aTHX_ WARN_AMBIGUOUS,
6164 "Ambiguous use of %c{%s} resolved to %c%s",
6165 funny, dest, funny, dest);
6170 s = bracket; /* let the parser handle it */
6174 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
6175 PL_lex_state = LEX_INTERPEND;
6180 Perl_pmflag(pTHX_ U16 *pmfl, int ch)
6185 *pmfl |= PMf_GLOBAL;
6187 *pmfl |= PMf_CONTINUE;
6191 *pmfl |= PMf_MULTILINE;
6193 *pmfl |= PMf_SINGLELINE;
6195 *pmfl |= PMf_EXTENDED;
6199 S_scan_pat(pTHX_ char *start, I32 type)
6204 s = scan_str(start,FALSE,FALSE);
6206 Perl_croak(aTHX_ "Search pattern not terminated");
6208 pm = (PMOP*)newPMOP(type, 0);
6209 if (PL_multi_open == '?')
6210 pm->op_pmflags |= PMf_ONCE;
6212 while (*s && strchr("iomsx", *s))
6213 pmflag(&pm->op_pmflags,*s++);
6216 while (*s && strchr("iogcmsx", *s))
6217 pmflag(&pm->op_pmflags,*s++);
6219 pm->op_pmpermflags = pm->op_pmflags;
6221 PL_lex_op = (OP*)pm;
6222 yylval.ival = OP_MATCH;
6227 S_scan_subst(pTHX_ char *start)
6234 yylval.ival = OP_NULL;
6236 s = scan_str(start,FALSE,FALSE);
6239 Perl_croak(aTHX_ "Substitution pattern not terminated");
6241 if (s[-1] == PL_multi_open)
6244 first_start = PL_multi_start;
6245 s = scan_str(s,FALSE,FALSE);
6248 SvREFCNT_dec(PL_lex_stuff);
6249 PL_lex_stuff = Nullsv;
6251 Perl_croak(aTHX_ "Substitution replacement not terminated");
6253 PL_multi_start = first_start; /* so whole substitution is taken together */
6255 pm = (PMOP*)newPMOP(OP_SUBST, 0);
6261 else if (strchr("iogcmsx", *s))
6262 pmflag(&pm->op_pmflags,*s++);
6269 PL_sublex_info.super_bufptr = s;
6270 PL_sublex_info.super_bufend = PL_bufend;
6272 pm->op_pmflags |= PMf_EVAL;
6273 repl = newSVpvn("",0);
6275 sv_catpv(repl, es ? "eval " : "do ");
6276 sv_catpvn(repl, "{ ", 2);
6277 sv_catsv(repl, PL_lex_repl);
6278 sv_catpvn(repl, " };", 2);
6280 SvREFCNT_dec(PL_lex_repl);
6284 pm->op_pmpermflags = pm->op_pmflags;
6285 PL_lex_op = (OP*)pm;
6286 yylval.ival = OP_SUBST;
6291 S_scan_trans(pTHX_ char *start)
6300 yylval.ival = OP_NULL;
6302 s = scan_str(start,FALSE,FALSE);
6304 Perl_croak(aTHX_ "Transliteration pattern not terminated");
6305 if (s[-1] == PL_multi_open)
6308 s = scan_str(s,FALSE,FALSE);
6311 SvREFCNT_dec(PL_lex_stuff);
6312 PL_lex_stuff = Nullsv;
6314 Perl_croak(aTHX_ "Transliteration replacement not terminated");
6317 complement = del = squash = 0;
6318 while (strchr("cds", *s)) {
6320 complement = OPpTRANS_COMPLEMENT;
6322 del = OPpTRANS_DELETE;
6324 squash = OPpTRANS_SQUASH;
6328 New(803, tbl, complement&&!del?258:256, short);
6329 o = newPVOP(OP_TRANS, 0, (char*)tbl);
6330 o->op_private = del|squash|complement|
6331 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
6332 (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0);
6335 yylval.ival = OP_TRANS;
6340 S_scan_heredoc(pTHX_ register char *s)
6343 I32 op_type = OP_SCALAR;
6350 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
6354 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
6357 for (peek = s; SPACE_OR_TAB(*peek); peek++) ;
6358 if (*peek && strchr("`'\"",*peek)) {
6361 s = delimcpy(d, e, s, PL_bufend, term, &len);
6371 if (!isALNUM_lazy_if(s,UTF))
6372 deprecate("bare << to mean <<\"\"");
6373 for (; isALNUM_lazy_if(s,UTF); s++) {
6378 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
6379 Perl_croak(aTHX_ "Delimiter for here document is too long");
6382 len = d - PL_tokenbuf;
6383 #ifndef PERL_STRICT_CR
6384 d = strchr(s, '\r');
6388 while (s < PL_bufend) {
6394 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
6403 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6408 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
6409 herewas = newSVpvn(s,PL_bufend-s);
6411 s--, herewas = newSVpvn(s,d-s);
6412 s += SvCUR(herewas);
6414 tmpstr = NEWSV(87,79);
6415 sv_upgrade(tmpstr, SVt_PVIV);
6420 else if (term == '`') {
6421 op_type = OP_BACKTICK;
6422 SvIVX(tmpstr) = '\\';
6426 PL_multi_start = CopLINE(PL_curcop);
6427 PL_multi_open = PL_multi_close = '<';
6428 term = *PL_tokenbuf;
6429 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
6430 char *bufptr = PL_sublex_info.super_bufptr;
6431 char *bufend = PL_sublex_info.super_bufend;
6432 char *olds = s - SvCUR(herewas);
6433 s = strchr(bufptr, '\n');
6437 while (s < bufend &&
6438 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6440 CopLINE_inc(PL_curcop);
6443 CopLINE_set(PL_curcop, PL_multi_start);
6444 missingterm(PL_tokenbuf);
6446 sv_setpvn(herewas,bufptr,d-bufptr+1);
6447 sv_setpvn(tmpstr,d+1,s-d);
6449 sv_catpvn(herewas,s,bufend-s);
6450 (void)strcpy(bufptr,SvPVX(herewas));
6457 while (s < PL_bufend &&
6458 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6460 CopLINE_inc(PL_curcop);
6462 if (s >= PL_bufend) {
6463 CopLINE_set(PL_curcop, PL_multi_start);
6464 missingterm(PL_tokenbuf);
6466 sv_setpvn(tmpstr,d+1,s-d);
6468 CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
6470 sv_catpvn(herewas,s,PL_bufend-s);
6471 sv_setsv(PL_linestr,herewas);
6472 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
6473 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6474 PL_last_lop = PL_last_uni = Nullch;
6477 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
6478 while (s >= PL_bufend) { /* multiple line string? */
6480 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6481 CopLINE_set(PL_curcop, PL_multi_start);
6482 missingterm(PL_tokenbuf);
6484 CopLINE_inc(PL_curcop);
6485 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6486 PL_last_lop = PL_last_uni = Nullch;
6487 #ifndef PERL_STRICT_CR
6488 if (PL_bufend - PL_linestart >= 2) {
6489 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
6490 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
6492 PL_bufend[-2] = '\n';
6494 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6496 else if (PL_bufend[-1] == '\r')
6497 PL_bufend[-1] = '\n';
6499 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
6500 PL_bufend[-1] = '\n';
6502 if (PERLDB_LINE && PL_curstash != PL_debstash) {
6503 SV *sv = NEWSV(88,0);
6505 sv_upgrade(sv, SVt_PVMG);
6506 sv_setsv(sv,PL_linestr);
6507 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop),sv);
6509 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
6512 sv_catsv(PL_linestr,herewas);
6513 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6517 sv_catsv(tmpstr,PL_linestr);
6522 PL_multi_end = CopLINE(PL_curcop);
6523 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
6524 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
6525 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
6527 SvREFCNT_dec(herewas);
6528 if (UTF && !IN_BYTE && is_utf8_string((U8*)SvPVX(tmpstr), SvCUR(tmpstr)))
6530 PL_lex_stuff = tmpstr;
6531 yylval.ival = op_type;
6536 takes: current position in input buffer
6537 returns: new position in input buffer
6538 side-effects: yylval and lex_op are set.
6543 <FH> read from filehandle
6544 <pkg::FH> read from package qualified filehandle
6545 <pkg'FH> read from package qualified filehandle
6546 <$fh> read from filehandle in $fh
6552 S_scan_inputsymbol(pTHX_ char *start)
6554 register char *s = start; /* current position in buffer */
6560 d = PL_tokenbuf; /* start of temp holding space */
6561 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
6562 end = strchr(s, '\n');
6565 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
6567 /* die if we didn't have space for the contents of the <>,
6568 or if it didn't end, or if we see a newline
6571 if (len >= sizeof PL_tokenbuf)
6572 Perl_croak(aTHX_ "Excessively long <> operator");
6574 Perl_croak(aTHX_ "Unterminated <> operator");
6579 Remember, only scalar variables are interpreted as filehandles by
6580 this code. Anything more complex (e.g., <$fh{$num}>) will be
6581 treated as a glob() call.
6582 This code makes use of the fact that except for the $ at the front,
6583 a scalar variable and a filehandle look the same.
6585 if (*d == '$' && d[1]) d++;
6587 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
6588 while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
6591 /* If we've tried to read what we allow filehandles to look like, and
6592 there's still text left, then it must be a glob() and not a getline.
6593 Use scan_str to pull out the stuff between the <> and treat it
6594 as nothing more than a string.
6597 if (d - PL_tokenbuf != len) {
6598 yylval.ival = OP_GLOB;
6600 s = scan_str(start,FALSE,FALSE);
6602 Perl_croak(aTHX_ "Glob not terminated");
6606 /* we're in a filehandle read situation */
6609 /* turn <> into <ARGV> */
6611 (void)strcpy(d,"ARGV");
6613 /* if <$fh>, create the ops to turn the variable into a
6619 /* try to find it in the pad for this block, otherwise find
6620 add symbol table ops
6622 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
6623 OP *o = newOP(OP_PADSV, 0);
6625 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, o);
6628 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
6629 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
6630 newUNOP(OP_RV2SV, 0,
6631 newGVOP(OP_GV, 0, gv)));
6633 PL_lex_op->op_flags |= OPf_SPECIAL;
6634 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
6635 yylval.ival = OP_NULL;
6638 /* If it's none of the above, it must be a literal filehandle
6639 (<Foo::BAR> or <FOO>) so build a simple readline OP */
6641 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
6642 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
6643 yylval.ival = OP_NULL;
6652 takes: start position in buffer
6653 keep_quoted preserve \ on the embedded delimiter(s)
6654 keep_delims preserve the delimiters around the string
6655 returns: position to continue reading from buffer
6656 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
6657 updates the read buffer.
6659 This subroutine pulls a string out of the input. It is called for:
6660 q single quotes q(literal text)
6661 ' single quotes 'literal text'
6662 qq double quotes qq(interpolate $here please)
6663 " double quotes "interpolate $here please"
6664 qx backticks qx(/bin/ls -l)
6665 ` backticks `/bin/ls -l`
6666 qw quote words @EXPORT_OK = qw( func() $spam )
6667 m// regexp match m/this/
6668 s/// regexp substitute s/this/that/
6669 tr/// string transliterate tr/this/that/
6670 y/// string transliterate y/this/that/
6671 ($*@) sub prototypes sub foo ($)
6672 (stuff) sub attr parameters sub foo : attr(stuff)
6673 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
6675 In most of these cases (all but <>, patterns and transliterate)
6676 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
6677 calls scan_str(). s/// makes yylex() call scan_subst() which calls
6678 scan_str(). tr/// and y/// make yylex() call scan_trans() which
6681 It skips whitespace before the string starts, and treats the first
6682 character as the delimiter. If the delimiter is one of ([{< then
6683 the corresponding "close" character )]}> is used as the closing
6684 delimiter. It allows quoting of delimiters, and if the string has
6685 balanced delimiters ([{<>}]) it allows nesting.
6687 On success, the SV with the resulting string is put into lex_stuff or,
6688 if that is already non-NULL, into lex_repl. The second case occurs only
6689 when parsing the RHS of the special constructs s/// and tr/// (y///).
6690 For convenience, the terminating delimiter character is stuffed into
6695 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
6697 SV *sv; /* scalar value: string */
6698 char *tmps; /* temp string, used for delimiter matching */
6699 register char *s = start; /* current position in the buffer */
6700 register char term; /* terminating character */
6701 register char *to; /* current position in the sv's data */
6702 I32 brackets = 1; /* bracket nesting level */
6703 bool has_utf8 = FALSE; /* is there any utf8 content? */
6705 /* skip space before the delimiter */
6709 /* mark where we are, in case we need to report errors */
6712 /* after skipping whitespace, the next character is the terminator */
6714 if (UTF8_IS_CONTINUED(term) && UTF)
6717 /* mark where we are */
6718 PL_multi_start = CopLINE(PL_curcop);
6719 PL_multi_open = term;
6721 /* find corresponding closing delimiter */
6722 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
6724 PL_multi_close = term;
6726 /* create a new SV to hold the contents. 87 is leak category, I'm
6727 assuming. 79 is the SV's initial length. What a random number. */
6729 sv_upgrade(sv, SVt_PVIV);
6731 (void)SvPOK_only(sv); /* validate pointer */
6733 /* move past delimiter and try to read a complete string */
6735 sv_catpvn(sv, s, 1);
6738 /* extend sv if need be */
6739 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
6740 /* set 'to' to the next character in the sv's string */
6741 to = SvPVX(sv)+SvCUR(sv);
6743 /* if open delimiter is the close delimiter read unbridle */
6744 if (PL_multi_open == PL_multi_close) {
6745 for (; s < PL_bufend; s++,to++) {
6746 /* embedded newlines increment the current line number */
6747 if (*s == '\n' && !PL_rsfp)
6748 CopLINE_inc(PL_curcop);
6749 /* handle quoted delimiters */
6750 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
6751 if (!keep_quoted && s[1] == term)
6753 /* any other quotes are simply copied straight through */
6757 /* terminate when run out of buffer (the for() condition), or
6758 have found the terminator */
6759 else if (*s == term)
6761 else if (!has_utf8 && UTF8_IS_CONTINUED(*s) && UTF)
6767 /* if the terminator isn't the same as the start character (e.g.,
6768 matched brackets), we have to allow more in the quoting, and
6769 be prepared for nested brackets.
6772 /* read until we run out of string, or we find the terminator */
6773 for (; s < PL_bufend; s++,to++) {
6774 /* embedded newlines increment the line count */
6775 if (*s == '\n' && !PL_rsfp)
6776 CopLINE_inc(PL_curcop);
6777 /* backslashes can escape the open or closing characters */
6778 if (*s == '\\' && s+1 < PL_bufend) {
6780 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
6785 /* allow nested opens and closes */
6786 else if (*s == PL_multi_close && --brackets <= 0)
6788 else if (*s == PL_multi_open)
6790 else if (!has_utf8 && UTF8_IS_CONTINUED(*s) && UTF)
6795 /* terminate the copied string and update the sv's end-of-string */
6797 SvCUR_set(sv, to - SvPVX(sv));
6800 * this next chunk reads more into the buffer if we're not done yet
6804 break; /* handle case where we are done yet :-) */
6806 #ifndef PERL_STRICT_CR
6807 if (to - SvPVX(sv) >= 2) {
6808 if ((to[-2] == '\r' && to[-1] == '\n') ||
6809 (to[-2] == '\n' && to[-1] == '\r'))
6813 SvCUR_set(sv, to - SvPVX(sv));
6815 else if (to[-1] == '\r')
6818 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
6822 /* if we're out of file, or a read fails, bail and reset the current
6823 line marker so we can report where the unterminated string began
6826 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6828 CopLINE_set(PL_curcop, PL_multi_start);
6831 /* we read a line, so increment our line counter */
6832 CopLINE_inc(PL_curcop);
6834 /* update debugger info */
6835 if (PERLDB_LINE && PL_curstash != PL_debstash) {
6836 SV *sv = NEWSV(88,0);
6838 sv_upgrade(sv, SVt_PVMG);
6839 sv_setsv(sv,PL_linestr);
6840 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop), sv);
6843 /* having changed the buffer, we must update PL_bufend */
6844 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6845 PL_last_lop = PL_last_uni = Nullch;
6848 /* at this point, we have successfully read the delimited string */
6851 sv_catpvn(sv, s, 1);
6854 PL_multi_end = CopLINE(PL_curcop);
6857 /* if we allocated too much space, give some back */
6858 if (SvCUR(sv) + 5 < SvLEN(sv)) {
6859 SvLEN_set(sv, SvCUR(sv) + 1);
6860 Renew(SvPVX(sv), SvLEN(sv), char);
6863 /* decide whether this is the first or second quoted string we've read
6876 takes: pointer to position in buffer
6877 returns: pointer to new position in buffer
6878 side-effects: builds ops for the constant in yylval.op
6880 Read a number in any of the formats that Perl accepts:
6882 0(x[0-7A-F]+)|([0-7]+)|(b[01])
6883 [\d_]+(\.[\d_]*)?[Ee](\d+)
6885 Underbars (_) are allowed in decimal numbers. If -w is on,
6886 underbars before a decimal point must be at three digit intervals.
6888 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
6891 If it reads a number without a decimal point or an exponent, it will
6892 try converting the number to an integer and see if it can do so
6893 without loss of precision.
6897 Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp)
6899 register char *s = start; /* current position in buffer */
6900 register char *d; /* destination in temp buffer */
6901 register char *e; /* end of temp buffer */
6902 NV nv; /* number read, as a double */
6903 SV *sv = Nullsv; /* place to put the converted number */
6904 bool floatit; /* boolean: int or float? */
6905 char *lastub = 0; /* position of last underbar */
6906 static char number_too_long[] = "Number too long";
6908 /* We use the first character to decide what type of number this is */
6912 Perl_croak(aTHX_ "panic: scan_num");
6914 /* if it starts with a 0, it could be an octal number, a decimal in
6915 0.13 disguise, or a hexadecimal number, or a binary number. */
6919 u holds the "number so far"
6920 shift the power of 2 of the base
6921 (hex == 4, octal == 3, binary == 1)
6922 overflowed was the number more than we can hold?
6924 Shift is used when we add a digit. It also serves as an "are
6925 we in octal/hex/binary?" indicator to disallow hex characters
6931 bool overflowed = FALSE;
6932 static NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
6933 static char* bases[5] = { "", "binary", "", "octal",
6935 static char* Bases[5] = { "", "Binary", "", "Octal",
6937 static char *maxima[5] = { "",
6938 "0b11111111111111111111111111111111",
6942 char *base, *Base, *max;
6948 } else if (s[1] == 'b') {
6952 /* check for a decimal in disguise */
6953 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
6955 /* so it must be octal */
6959 base = bases[shift];
6960 Base = Bases[shift];
6961 max = maxima[shift];
6963 /* read the rest of the number */
6965 /* x is used in the overflow test,
6966 b is the digit we're adding on. */
6971 /* if we don't mention it, we're done */
6980 /* 8 and 9 are not octal */
6983 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
6987 case '2': case '3': case '4':
6988 case '5': case '6': case '7':
6990 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
6994 b = *s++ & 15; /* ASCII digit -> value of digit */
6998 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
6999 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
7000 /* make sure they said 0x */
7005 /* Prepare to put the digit we have onto the end
7006 of the number so far. We check for overflows.
7011 x = u << shift; /* make room for the digit */
7013 if ((x >> shift) != u
7014 && !(PL_hints & HINT_NEW_BINARY)) {
7017 if (ckWARN_d(WARN_OVERFLOW))
7018 Perl_warner(aTHX_ WARN_OVERFLOW,
7019 "Integer overflow in %s number",
7022 u = x | b; /* add the digit to the end */
7025 n *= nvshift[shift];
7026 /* If an NV has not enough bits in its
7027 * mantissa to represent an UV this summing of
7028 * small low-order numbers is a waste of time
7029 * (because the NV cannot preserve the
7030 * low-order bits anyway): we could just
7031 * remember when did we overflow and in the
7032 * end just multiply n by the right
7040 /* if we get here, we had success: make a scalar value from
7046 if (ckWARN(WARN_PORTABLE) && n > 4294967295.0)
7047 Perl_warner(aTHX_ WARN_PORTABLE,
7048 "%s number > %s non-portable",
7054 if (ckWARN(WARN_PORTABLE) && u > 0xffffffff)
7055 Perl_warner(aTHX_ WARN_PORTABLE,
7056 "%s number > %s non-portable",
7061 if (PL_hints & HINT_NEW_BINARY)
7062 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
7067 handle decimal numbers.
7068 we're also sent here when we read a 0 as the first digit
7070 case '1': case '2': case '3': case '4': case '5':
7071 case '6': case '7': case '8': case '9': case '.':
7074 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
7077 /* read next group of digits and _ and copy into d */
7078 while (isDIGIT(*s) || *s == '_') {
7079 /* skip underscores, checking for misplaced ones
7083 if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
7084 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
7088 /* check for end of fixed-length buffer */
7090 Perl_croak(aTHX_ number_too_long);
7091 /* if we're ok, copy the character */
7096 /* final misplaced underbar check */
7097 if (lastub && s - lastub != 3) {
7098 if (ckWARN(WARN_SYNTAX))
7099 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
7102 /* read a decimal portion if there is one. avoid
7103 3..5 being interpreted as the number 3. followed
7106 if (*s == '.' && s[1] != '.') {
7110 /* copy, ignoring underbars, until we run out of
7111 digits. Note: no misplaced underbar checks!
7113 for (; isDIGIT(*s) || *s == '_'; s++) {
7114 /* fixed length buffer check */
7116 Perl_croak(aTHX_ number_too_long);
7120 if (*s == '.' && isDIGIT(s[1])) {
7121 /* oops, it's really a v-string, but without the "v" */
7127 /* read exponent part, if present */
7128 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
7132 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
7133 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
7135 /* allow positive or negative exponent */
7136 if (*s == '+' || *s == '-')
7139 /* read digits of exponent (no underbars :-) */
7140 while (isDIGIT(*s)) {
7142 Perl_croak(aTHX_ number_too_long);
7147 /* terminate the string */
7150 /* make an sv from the string */
7153 #if defined(Strtol) && defined(Strtoul)
7156 strtol/strtoll sets errno to ERANGE if the number is too big
7157 for an integer. We try to do an integer conversion first
7158 if no characters indicating "float" have been found.
7165 if (*PL_tokenbuf == '-')
7166 iv = Strtol(PL_tokenbuf, (char**)NULL, 10);
7168 uv = Strtoul(PL_tokenbuf, (char**)NULL, 10);
7170 floatit = TRUE; /* Probably just too large. */
7171 else if (*PL_tokenbuf == '-')
7173 else if (uv <= IV_MAX)
7174 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
7179 nv = Atof(PL_tokenbuf);
7184 No working strtou?ll?.
7186 Unfortunately atol() doesn't do range checks (returning
7187 LONG_MIN/LONG_MAX, and setting errno to ERANGE on overflows)
7188 everywhere [1], so we cannot use use atol() (or atoll()).
7189 If we could, they would be used, as Atol(), very much like
7190 Strtol() and Strtoul() are used above.
7192 [1] XXX Configure test needed to check for atol()
7193 (and atoll()) overflow behaviour XXX
7197 We need to do this the hard way. */
7199 nv = Atof(PL_tokenbuf);
7201 /* See if we can make do with an integer value without loss of
7202 precision. We use U_V to cast to a UV, because some
7203 compilers have issues. Then we try casting it back and see
7204 if it was the same [1]. We only do this if we know we
7205 specifically read an integer. If floatit is true, then we
7206 don't need to do the conversion at all.
7208 [1] Note that this is lossy if our NVs cannot preserve our
7209 UVs. There are metaconfig defines NV_PRESERVES_UV (a boolean)
7210 and NV_PRESERVES_UV_BITS (a number), but in general we really
7211 do hope all such potentially lossy platforms have strtou?ll?
7212 to do a lossless IV/UV conversion.
7214 Maybe could do some tricks with DBL_DIG, LDBL_DIG and
7215 DBL_MANT_DIG and LDBL_MANT_DIG (these are already available
7216 as NV_DIG and NV_MANT_DIG)?
7222 if (!floatit && (NV)uv == nv) {
7224 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
7232 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
7233 (PL_hints & HINT_NEW_INTEGER) )
7234 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
7235 (floatit ? "float" : "integer"),
7239 /* if it starts with a v, it could be a v-string */
7245 while (isDIGIT(*pos) || *pos == '_')
7247 if (!isALPHA(*pos)) {
7249 U8 tmpbuf[UTF8_MAXLEN+1];
7251 s++; /* get past 'v' */
7254 sv_setpvn(sv, "", 0);
7257 if (*s == '0' && isDIGIT(s[1]))
7258 yyerror("Octal number in vector unsupported");
7261 /* this is atoi() that tolerates underscores */
7264 while (--end >= s) {
7269 rev += (*end - '0') * mult;
7271 if (orev > rev && ckWARN_d(WARN_OVERFLOW))
7272 Perl_warner(aTHX_ WARN_OVERFLOW,
7273 "Integer overflow in decimal number");
7276 tmpend = uv_to_utf8(tmpbuf, rev);
7279 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
7280 if (*pos == '.' && isDIGIT(pos[1]))
7286 while (isDIGIT(*pos) || *pos == '_')
7295 sv_utf8_downgrade(sv, TRUE);
7302 /* make the op for the constant and return */
7305 lvalp->opval = newSVOP(OP_CONST, 0, sv);
7307 lvalp->opval = Nullop;
7313 S_scan_formline(pTHX_ register char *s)
7317 SV *stuff = newSVpvn("",0);
7318 bool needargs = FALSE;
7321 if (*s == '.' || *s == /*{*/'}') {
7323 #ifdef PERL_STRICT_CR
7324 for (t = s+1;SPACE_OR_TAB(*t); t++) ;
7326 for (t = s+1;SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
7328 if (*t == '\n' || t == PL_bufend)
7331 if (PL_in_eval && !PL_rsfp) {
7332 eol = strchr(s,'\n');
7337 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7339 for (t = s; t < eol; t++) {
7340 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
7342 goto enough; /* ~~ must be first line in formline */
7344 if (*t == '@' || *t == '^')
7347 sv_catpvn(stuff, s, eol-s);
7348 #ifndef PERL_STRICT_CR
7349 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
7350 char *end = SvPVX(stuff) + SvCUR(stuff);
7359 s = filter_gets(PL_linestr, PL_rsfp, 0);
7360 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
7361 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
7362 PL_last_lop = PL_last_uni = Nullch;
7365 yyerror("Format not terminated");
7375 PL_lex_state = LEX_NORMAL;
7376 PL_nextval[PL_nexttoke].ival = 0;
7380 PL_lex_state = LEX_FORMLINE;
7381 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
7383 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
7387 SvREFCNT_dec(stuff);
7388 PL_lex_formbrack = 0;
7399 PL_cshlen = strlen(PL_cshname);
7404 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
7406 I32 oldsavestack_ix = PL_savestack_ix;
7407 CV* outsidecv = PL_compcv;
7411 assert(SvTYPE(PL_compcv) == SVt_PVCV);
7413 SAVEI32(PL_subline);
7414 save_item(PL_subname);
7417 SAVESPTR(PL_comppad_name);
7418 SAVESPTR(PL_compcv);
7419 SAVEI32(PL_comppad_name_fill);
7420 SAVEI32(PL_min_intro_pending);
7421 SAVEI32(PL_max_intro_pending);
7422 SAVEI32(PL_pad_reset_pending);
7424 PL_compcv = (CV*)NEWSV(1104,0);
7425 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
7426 CvFLAGS(PL_compcv) |= flags;
7428 PL_comppad = newAV();
7429 av_push(PL_comppad, Nullsv);
7430 PL_curpad = AvARRAY(PL_comppad);
7431 PL_comppad_name = newAV();
7432 PL_comppad_name_fill = 0;
7433 PL_min_intro_pending = 0;
7435 PL_subline = CopLINE(PL_curcop);
7437 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
7438 PL_curpad[0] = (SV*)newAV();
7439 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
7440 #endif /* USE_THREADS */
7442 comppadlist = newAV();
7443 AvREAL_off(comppadlist);
7444 av_store(comppadlist, 0, (SV*)PL_comppad_name);
7445 av_store(comppadlist, 1, (SV*)PL_comppad);
7447 CvPADLIST(PL_compcv) = comppadlist;
7448 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
7450 CvOWNER(PL_compcv) = 0;
7451 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
7452 MUTEX_INIT(CvMUTEXP(PL_compcv));
7453 #endif /* USE_THREADS */
7455 return oldsavestack_ix;
7459 #pragma segment Perl_yylex
7462 Perl_yywarn(pTHX_ char *s)
7464 PL_in_eval |= EVAL_WARNONLY;
7466 PL_in_eval &= ~EVAL_WARNONLY;
7471 Perl_yyerror(pTHX_ char *s)
7474 char *context = NULL;
7478 if (!yychar || (yychar == ';' && !PL_rsfp))
7480 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
7481 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
7482 while (isSPACE(*PL_oldoldbufptr))
7484 context = PL_oldoldbufptr;
7485 contlen = PL_bufptr - PL_oldoldbufptr;
7487 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
7488 PL_oldbufptr != PL_bufptr) {
7489 while (isSPACE(*PL_oldbufptr))
7491 context = PL_oldbufptr;
7492 contlen = PL_bufptr - PL_oldbufptr;
7494 else if (yychar > 255)
7495 where = "next token ???";
7496 #ifdef USE_PURE_BISON
7497 /* GNU Bison sets the value -2 */
7498 else if (yychar == -2) {
7500 else if ((yychar & 127) == 127) {
7502 if (PL_lex_state == LEX_NORMAL ||
7503 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
7504 where = "at end of line";
7505 else if (PL_lex_inpat)
7506 where = "within pattern";
7508 where = "within string";
7511 SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
7513 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
7514 else if (isPRINT_LC(yychar))
7515 Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
7517 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
7518 where = SvPVX(where_sv);
7520 msg = sv_2mortal(newSVpv(s, 0));
7521 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
7522 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
7524 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
7526 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
7527 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
7528 Perl_sv_catpvf(aTHX_ msg,
7529 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
7530 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
7533 if (PL_in_eval & EVAL_WARNONLY)
7534 Perl_warn(aTHX_ "%"SVf, msg);
7537 if (PL_error_count >= 10) {
7538 if (PL_in_eval && SvCUR(ERRSV))
7539 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
7540 ERRSV, CopFILE(PL_curcop));
7542 Perl_croak(aTHX_ "%s has too many errors.\n",
7543 CopFILE(PL_curcop));
7546 PL_in_my_stash = Nullhv;
7550 #pragma segment Main
7554 S_swallow_bom(pTHX_ U8 *s)
7557 slen = SvCUR(PL_linestr);
7561 /* UTF-16 little-endian */
7562 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
7563 Perl_croak(aTHX_ "Unsupported script encoding");
7564 #ifndef PERL_NO_UTF16_FILTER
7565 DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-LE script encoding\n"));
7567 if (PL_bufend > (char*)s) {
7571 filter_add(utf16rev_textfilter, NULL);
7572 New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
7573 PL_bufend = (char*)utf16_to_utf8_reversed(s, news,
7574 PL_bufend - (char*)s - 1,
7576 Copy(news, s, newlen, U8);
7577 SvCUR_set(PL_linestr, newlen);
7578 PL_bufend = SvPVX(PL_linestr) + newlen;
7579 news[newlen++] = '\0';
7583 Perl_croak(aTHX_ "Unsupported script encoding");
7588 if (s[1] == 0xFF) { /* UTF-16 big-endian */
7589 #ifndef PERL_NO_UTF16_FILTER
7590 DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding\n"));
7592 if (PL_bufend > (char *)s) {
7596 filter_add(utf16_textfilter, NULL);
7597 New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
7598 PL_bufend = (char*)utf16_to_utf8(s, news,
7599 PL_bufend - (char*)s,
7601 Copy(news, s, newlen, U8);
7602 SvCUR_set(PL_linestr, newlen);
7603 PL_bufend = SvPVX(PL_linestr) + newlen;
7604 news[newlen++] = '\0';
7608 Perl_croak(aTHX_ "Unsupported script encoding");
7613 if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
7614 DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-8 script encoding\n"));
7619 if (slen > 3 && s[1] == 0 && /* UTF-32 big-endian */
7620 s[2] == 0xFE && s[3] == 0xFF)
7622 Perl_croak(aTHX_ "Unsupported script encoding");
7634 * Restore a source filter.
7638 restore_rsfp(pTHXo_ void *f)
7640 PerlIO *fp = (PerlIO*)f;
7642 if (PL_rsfp == PerlIO_stdin())
7643 PerlIO_clearerr(PL_rsfp);
7644 else if (PL_rsfp && (PL_rsfp != fp))
7645 PerlIO_close(PL_rsfp);
7649 #ifndef PERL_NO_UTF16_FILTER
7651 utf16_textfilter(pTHXo_ int idx, SV *sv, int maxlen)
7653 I32 count = FILTER_READ(idx+1, sv, maxlen);
7658 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
7659 if (!*SvPV_nolen(sv))
7660 /* Game over, but don't feed an odd-length string to utf16_to_utf8 */
7663 tend = utf16_to_utf8((U8*)SvPVX(sv), tmps, SvCUR(sv), &newlen);
7664 sv_usepvn(sv, (char*)tmps, tend - tmps);
7670 utf16rev_textfilter(pTHXo_ int idx, SV *sv, int maxlen)
7672 I32 count = FILTER_READ(idx+1, sv, maxlen);
7677 if (!*SvPV_nolen(sv))
7678 /* Game over, but don't feed an odd-length string to utf16_to_utf8 */
7681 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
7682 tend = utf16_to_utf8_reversed((U8*)SvPVX(sv), tmps, SvCUR(sv), &newlen);
7683 sv_usepvn(sv, (char*)tmps, tend - tmps);