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 if (s[1] == 'U' && s[2] == '+') { /* \N{U+HHHH} */
1534 STRLEN alen = e - s - 3;
1536 UV uv = (UV)scan_hex(s + 3, alen, &blen);
1539 res = newSVpvn(s, (uv >> 8) + 1); /* filler */
1540 str = (char *)uv_to_utf8((U8*)SvPVX(res), uv);
1541 SvCUR_set(res, str - SvPVX(res));
1547 yyerror("Illegal hexadecimal code on \\N{U+...}");
1553 res = newSVpvn(s + 1, e - s - 1);
1554 res = new_constant( Nullch, 0, "charnames",
1555 res, Nullsv, "\\N{...}" );
1558 sv_utf8_upgrade(res);
1559 str = SvPV(res,len);
1560 if (!has_utf8 && SvUTF8(res)) {
1561 char *ostart = SvPVX(sv);
1562 SvCUR_set(sv, d - ostart);
1565 sv_utf8_upgrade(sv);
1566 /* this just broke our allocation above... */
1567 SvGROW(sv, send - start);
1568 d = SvPVX(sv) + SvCUR(sv);
1571 if (len > e - s + 4) {
1572 char *odest = SvPVX(sv);
1574 SvGROW(sv, (SvLEN(sv) + len - (e - s + 4)));
1575 d = SvPVX(sv) + (d - odest);
1577 Copy(str, d, len, char);
1584 yyerror("Missing braces on \\N{}");
1587 /* \c is a control character */
1604 /* printf-style backslashes, formfeeds, newlines, etc */
1622 *d++ = '\047'; /* CP 1047 */
1625 *d++ = '\057'; /* CP 1047 */
1639 } /* end if (backslash) */
1642 if (UTF8_IS_CONTINUED(*s) && (this_utf8 || has_utf8)) {
1643 STRLEN len = (STRLEN) -1;
1646 uv = utf8_to_uv((U8*)s, send - s, &len, 0);
1648 if (len == (STRLEN)-1) {
1649 /* Illegal UTF8 (a high-bit byte), make it valid. */
1650 char *old_pvx = SvPVX(sv);
1651 /* need space for one extra char (NOTE: SvCUR() not set here) */
1652 d = SvGROW(sv, SvLEN(sv) + 1) + (d - old_pvx);
1653 d = (char*)uv_to_utf8((U8*)d, (U8)*s++);
1660 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1661 PL_sublex_info.sub_op->op_private |=
1662 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1669 } /* while loop to process each character */
1671 /* terminate the string and set up the sv */
1673 SvCUR_set(sv, d - SvPVX(sv));
1678 /* shrink the sv if we allocated more than we used */
1679 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1680 SvLEN_set(sv, SvCUR(sv) + 1);
1681 Renew(SvPVX(sv), SvLEN(sv), char);
1684 /* return the substring (via yylval) only if we parsed anything */
1685 if (s > PL_bufptr) {
1686 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1687 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1689 ( PL_lex_inwhat == OP_TRANS
1691 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1694 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1701 * Returns TRUE if there's more to the expression (e.g., a subscript),
1704 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
1706 * ->[ and ->{ return TRUE
1707 * { and [ outside a pattern are always subscripts, so return TRUE
1708 * if we're outside a pattern and it's not { or [, then return FALSE
1709 * if we're in a pattern and the first char is a {
1710 * {4,5} (any digits around the comma) returns FALSE
1711 * if we're in a pattern and the first char is a [
1713 * [SOMETHING] has a funky algorithm to decide whether it's a
1714 * character class or not. It has to deal with things like
1715 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
1716 * anything else returns TRUE
1719 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1722 S_intuit_more(pTHX_ register char *s)
1724 if (PL_lex_brackets)
1726 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1728 if (*s != '{' && *s != '[')
1733 /* In a pattern, so maybe we have {n,m}. */
1750 /* On the other hand, maybe we have a character class */
1753 if (*s == ']' || *s == '^')
1756 /* this is terrifying, and it works */
1757 int weight = 2; /* let's weigh the evidence */
1759 unsigned char un_char = 255, last_un_char;
1760 char *send = strchr(s,']');
1761 char tmpbuf[sizeof PL_tokenbuf * 4];
1763 if (!send) /* has to be an expression */
1766 Zero(seen,256,char);
1769 else if (isDIGIT(*s)) {
1771 if (isDIGIT(s[1]) && s[2] == ']')
1777 for (; s < send; s++) {
1778 last_un_char = un_char;
1779 un_char = (unsigned char)*s;
1784 weight -= seen[un_char] * 10;
1785 if (isALNUM_lazy_if(s+1,UTF)) {
1786 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1787 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1792 else if (*s == '$' && s[1] &&
1793 strchr("[#!%*<>()-=",s[1])) {
1794 if (/*{*/ strchr("])} =",s[2]))
1803 if (strchr("wds]",s[1]))
1805 else if (seen['\''] || seen['"'])
1807 else if (strchr("rnftbxcav",s[1]))
1809 else if (isDIGIT(s[1])) {
1811 while (s[1] && isDIGIT(s[1]))
1821 if (strchr("aA01! ",last_un_char))
1823 if (strchr("zZ79~",s[1]))
1825 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1826 weight -= 5; /* cope with negative subscript */
1829 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1830 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1835 if (keyword(tmpbuf, d - tmpbuf))
1838 if (un_char == last_un_char + 1)
1840 weight -= seen[un_char];
1845 if (weight >= 0) /* probably a character class */
1855 * Does all the checking to disambiguate
1857 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
1858 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
1860 * First argument is the stuff after the first token, e.g. "bar".
1862 * Not a method if bar is a filehandle.
1863 * Not a method if foo is a subroutine prototyped to take a filehandle.
1864 * Not a method if it's really "Foo $bar"
1865 * Method if it's "foo $bar"
1866 * Not a method if it's really "print foo $bar"
1867 * Method if it's really "foo package::" (interpreted as package->foo)
1868 * Not a method if bar is known to be a subroutne ("sub bar; foo bar")
1869 * Not a method if bar is a filehandle or package, but is quoted with
1874 S_intuit_method(pTHX_ char *start, GV *gv)
1876 char *s = start + (*start == '$');
1877 char tmpbuf[sizeof PL_tokenbuf];
1885 if ((cv = GvCVu(gv))) {
1886 char *proto = SvPVX(cv);
1896 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1897 /* start is the beginning of the possible filehandle/object,
1898 * and s is the end of it
1899 * tmpbuf is a copy of it
1902 if (*start == '$') {
1903 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1908 return *s == '(' ? FUNCMETH : METHOD;
1910 if (!keyword(tmpbuf, len)) {
1911 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1916 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1917 if (indirgv && GvCVu(indirgv))
1919 /* filehandle or package name makes it a method */
1920 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1922 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1923 return 0; /* no assumptions -- "=>" quotes bearword */
1925 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1926 newSVpvn(tmpbuf,len));
1927 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1931 return *s == '(' ? FUNCMETH : METHOD;
1939 * Return a string of Perl code to load the debugger. If PERL5DB
1940 * is set, it will return the contents of that, otherwise a
1941 * compile-time require of perl5db.pl.
1948 char *pdb = PerlEnv_getenv("PERL5DB");
1952 SETERRNO(0,SS$_NORMAL);
1953 return "BEGIN { require 'perl5db.pl' }";
1959 /* Encoded script support. filter_add() effectively inserts a
1960 * 'pre-processing' function into the current source input stream.
1961 * Note that the filter function only applies to the current source file
1962 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1964 * The datasv parameter (which may be NULL) can be used to pass
1965 * private data to this instance of the filter. The filter function
1966 * can recover the SV using the FILTER_DATA macro and use it to
1967 * store private buffers and state information.
1969 * The supplied datasv parameter is upgraded to a PVIO type
1970 * and the IoDIRP/IoANY field is used to store the function pointer,
1971 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
1972 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1973 * private use must be set using malloc'd pointers.
1977 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
1982 if (!PL_rsfp_filters)
1983 PL_rsfp_filters = newAV();
1985 datasv = NEWSV(255,0);
1986 if (!SvUPGRADE(datasv, SVt_PVIO))
1987 Perl_die(aTHX_ "Can't upgrade filter_add data to SVt_PVIO");
1988 IoANY(datasv) = (void *)funcp; /* stash funcp into spare field */
1989 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
1990 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
1991 funcp, SvPV_nolen(datasv)));
1992 av_unshift(PL_rsfp_filters, 1);
1993 av_store(PL_rsfp_filters, 0, datasv) ;
1998 /* Delete most recently added instance of this filter function. */
2000 Perl_filter_del(pTHX_ filter_t funcp)
2003 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", funcp));
2004 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
2006 /* if filter is on top of stack (usual case) just pop it off */
2007 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
2008 if (IoANY(datasv) == (void *)funcp) {
2009 IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
2010 IoANY(datasv) = (void *)NULL;
2011 sv_free(av_pop(PL_rsfp_filters));
2015 /* we need to search for the correct entry and clear it */
2016 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
2020 /* Invoke the n'th filter function for the current rsfp. */
2022 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
2025 /* 0 = read one text line */
2030 if (!PL_rsfp_filters)
2032 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
2033 /* Provide a default input filter to make life easy. */
2034 /* Note that we append to the line. This is handy. */
2035 DEBUG_P(PerlIO_printf(Perl_debug_log,
2036 "filter_read %d: from rsfp\n", idx));
2040 int old_len = SvCUR(buf_sv) ;
2042 /* ensure buf_sv is large enough */
2043 SvGROW(buf_sv, old_len + maxlen) ;
2044 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
2045 if (PerlIO_error(PL_rsfp))
2046 return -1; /* error */
2048 return 0 ; /* end of file */
2050 SvCUR_set(buf_sv, old_len + len) ;
2053 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
2054 if (PerlIO_error(PL_rsfp))
2055 return -1; /* error */
2057 return 0 ; /* end of file */
2060 return SvCUR(buf_sv);
2062 /* Skip this filter slot if filter has been deleted */
2063 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
2064 DEBUG_P(PerlIO_printf(Perl_debug_log,
2065 "filter_read %d: skipped (filter deleted)\n",
2067 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
2069 /* Get function pointer hidden within datasv */
2070 funcp = (filter_t)IoANY(datasv);
2071 DEBUG_P(PerlIO_printf(Perl_debug_log,
2072 "filter_read %d: via function %p (%s)\n",
2073 idx, funcp, SvPV_nolen(datasv)));
2074 /* Call function. The function is expected to */
2075 /* call "FILTER_READ(idx+1, buf_sv)" first. */
2076 /* Return: <0:error, =0:eof, >0:not eof */
2077 return (*funcp)(aTHXo_ idx, buf_sv, maxlen);
2081 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
2083 #ifdef PERL_CR_FILTER
2084 if (!PL_rsfp_filters) {
2085 filter_add(S_cr_textfilter,NULL);
2088 if (PL_rsfp_filters) {
2091 SvCUR_set(sv, 0); /* start with empty line */
2092 if (FILTER_READ(0, sv, 0) > 0)
2093 return ( SvPVX(sv) ) ;
2098 return (sv_gets(sv, fp, append));
2102 S_find_in_my_stash(pTHX_ char *pkgname, I32 len)
2106 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
2110 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
2111 (gv = gv_fetchpv(pkgname, FALSE, SVt_PVHV)))
2113 return GvHV(gv); /* Foo:: */
2116 /* use constant CLASS => 'MyClass' */
2117 if ((gv = gv_fetchpv(pkgname, FALSE, SVt_PVCV))) {
2119 if (GvCV(gv) && (sv = cv_const_sv(GvCV(gv)))) {
2120 pkgname = SvPV_nolen(sv);
2124 return gv_stashpv(pkgname, FALSE);
2128 static char* exp_name[] =
2129 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
2130 "ATTRTERM", "TERMBLOCK"
2137 Works out what to call the token just pulled out of the input
2138 stream. The yacc parser takes care of taking the ops we return and
2139 stitching them into a tree.
2145 if read an identifier
2146 if we're in a my declaration
2147 croak if they tried to say my($foo::bar)
2148 build the ops for a my() declaration
2149 if it's an access to a my() variable
2150 are we in a sort block?
2151 croak if my($a); $a <=> $b
2152 build ops for access to a my() variable
2153 if in a dq string, and they've said @foo and we can't find @foo
2155 build ops for a bareword
2156 if we already built the token before, use it.
2159 #ifdef USE_PURE_BISON
2161 Perl_yylex_r(pTHX_ YYSTYPE *lvalp, int *lcharp)
2166 yylval_pointer[yyactlevel] = lvalp;
2167 yychar_pointer[yyactlevel] = lcharp;
2168 if (yyactlevel >= YYMAXLEVEL)
2169 Perl_croak(aTHX_ "panic: YYMAXLEVEL");
2171 r = Perl_yylex(aTHX);
2181 #pragma segment Perl_yylex
2194 /* check if there's an identifier for us to look at */
2195 if (PL_pending_ident) {
2196 /* pit holds the identifier we read and pending_ident is reset */
2197 char pit = PL_pending_ident;
2198 PL_pending_ident = 0;
2200 DEBUG_T({ PerlIO_printf(Perl_debug_log,
2201 "### Tokener saw identifier '%s'\n", PL_tokenbuf); })
2203 /* if we're in a my(), we can't allow dynamics here.
2204 $foo'bar has already been turned into $foo::bar, so
2205 just check for colons.
2207 if it's a legal name, the OP is a PADANY.
2210 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
2211 if (strchr(PL_tokenbuf,':'))
2212 yyerror(Perl_form(aTHX_ "No package name allowed for "
2213 "variable %s in \"our\"",
2215 tmp = pad_allocmy(PL_tokenbuf);
2218 if (strchr(PL_tokenbuf,':'))
2219 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
2221 yylval.opval = newOP(OP_PADANY, 0);
2222 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
2228 build the ops for accesses to a my() variable.
2230 Deny my($a) or my($b) in a sort block, *if* $a or $b is
2231 then used in a comparison. This catches most, but not
2232 all cases. For instance, it catches
2233 sort { my($a); $a <=> $b }
2235 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
2236 (although why you'd do that is anyone's guess).
2239 if (!strchr(PL_tokenbuf,':')) {
2241 /* Check for single character per-thread SVs */
2242 if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
2243 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
2244 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
2246 yylval.opval = newOP(OP_THREADSV, 0);
2247 yylval.opval->op_targ = tmp;
2250 #endif /* USE_THREADS */
2251 if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
2252 SV *namesv = AvARRAY(PL_comppad_name)[tmp];
2253 /* might be an "our" variable" */
2254 if (SvFLAGS(namesv) & SVpad_OUR) {
2255 /* build ops for a bareword */
2256 SV *sym = newSVpv(HvNAME(GvSTASH(namesv)),0);
2257 sv_catpvn(sym, "::", 2);
2258 sv_catpv(sym, PL_tokenbuf+1);
2259 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
2260 yylval.opval->op_private = OPpCONST_ENTERED;
2261 gv_fetchpv(SvPVX(sym),
2263 ? (GV_ADDMULTI | GV_ADDINEVAL)
2266 ((PL_tokenbuf[0] == '$') ? SVt_PV
2267 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
2272 /* if it's a sort block and they're naming $a or $b */
2273 if (PL_last_lop_op == OP_SORT &&
2274 PL_tokenbuf[0] == '$' &&
2275 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
2278 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
2279 d < PL_bufend && *d != '\n';
2282 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
2283 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
2289 yylval.opval = newOP(OP_PADANY, 0);
2290 yylval.opval->op_targ = tmp;
2296 Whine if they've said @foo in a doublequoted string,
2297 and @foo isn't a variable we can find in the symbol
2300 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
2301 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
2302 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
2303 && ckWARN(WARN_AMBIGUOUS))
2305 /* Downgraded from fatal to warning 20000522 mjd */
2306 Perl_warner(aTHX_ WARN_AMBIGUOUS,
2307 "Possible unintended interpolation of %s in string",
2312 /* build ops for a bareword */
2313 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
2314 yylval.opval->op_private = OPpCONST_ENTERED;
2315 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
2316 ((PL_tokenbuf[0] == '$') ? SVt_PV
2317 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
2322 /* no identifier pending identification */
2324 switch (PL_lex_state) {
2326 case LEX_NORMAL: /* Some compilers will produce faster */
2327 case LEX_INTERPNORMAL: /* code if we comment these out. */
2331 /* when we've already built the next token, just pull it out of the queue */
2334 yylval = PL_nextval[PL_nexttoke];
2336 PL_lex_state = PL_lex_defer;
2337 PL_expect = PL_lex_expect;
2338 PL_lex_defer = LEX_NORMAL;
2340 DEBUG_T({ PerlIO_printf(Perl_debug_log,
2341 "### Next token after '%s' was known, type %"IVdf"\n", PL_bufptr,
2342 (IV)PL_nexttype[PL_nexttoke]); })
2344 return(PL_nexttype[PL_nexttoke]);
2346 /* interpolated case modifiers like \L \U, including \Q and \E.
2347 when we get here, PL_bufptr is at the \
2349 case LEX_INTERPCASEMOD:
2351 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
2352 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
2354 /* handle \E or end of string */
2355 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
2359 if (PL_lex_casemods) {
2360 oldmod = PL_lex_casestack[--PL_lex_casemods];
2361 PL_lex_casestack[PL_lex_casemods] = '\0';
2363 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
2365 PL_lex_state = LEX_INTERPCONCAT;
2369 if (PL_bufptr != PL_bufend)
2371 PL_lex_state = LEX_INTERPCONCAT;
2375 DEBUG_T({ PerlIO_printf(Perl_debug_log,
2376 "### Saw case modifier at '%s'\n", PL_bufptr); })
2378 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
2379 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
2380 if (strchr("LU", *s) &&
2381 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
2383 PL_lex_casestack[--PL_lex_casemods] = '\0';
2386 if (PL_lex_casemods > 10) {
2387 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
2388 if (newlb != PL_lex_casestack) {
2390 PL_lex_casestack = newlb;
2393 PL_lex_casestack[PL_lex_casemods++] = *s;
2394 PL_lex_casestack[PL_lex_casemods] = '\0';
2395 PL_lex_state = LEX_INTERPCONCAT;
2396 PL_nextval[PL_nexttoke].ival = 0;
2399 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
2401 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
2403 PL_nextval[PL_nexttoke].ival = OP_LC;
2405 PL_nextval[PL_nexttoke].ival = OP_UC;
2407 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
2409 Perl_croak(aTHX_ "panic: yylex");
2412 if (PL_lex_starts) {
2421 case LEX_INTERPPUSH:
2422 return sublex_push();
2424 case LEX_INTERPSTART:
2425 if (PL_bufptr == PL_bufend)
2426 return sublex_done();
2427 DEBUG_T({ PerlIO_printf(Perl_debug_log,
2428 "### Interpolated variable at '%s'\n", PL_bufptr); })
2430 PL_lex_dojoin = (*PL_bufptr == '@');
2431 PL_lex_state = LEX_INTERPNORMAL;
2432 if (PL_lex_dojoin) {
2433 PL_nextval[PL_nexttoke].ival = 0;
2436 PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
2437 PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
2438 force_next(PRIVATEREF);
2440 force_ident("\"", '$');
2441 #endif /* USE_THREADS */
2442 PL_nextval[PL_nexttoke].ival = 0;
2444 PL_nextval[PL_nexttoke].ival = 0;
2446 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
2449 if (PL_lex_starts++) {
2455 case LEX_INTERPENDMAYBE:
2456 if (intuit_more(PL_bufptr)) {
2457 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
2463 if (PL_lex_dojoin) {
2464 PL_lex_dojoin = FALSE;
2465 PL_lex_state = LEX_INTERPCONCAT;
2468 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
2469 && SvEVALED(PL_lex_repl))
2471 if (PL_bufptr != PL_bufend)
2472 Perl_croak(aTHX_ "Bad evalled substitution pattern");
2473 PL_lex_repl = Nullsv;
2476 case LEX_INTERPCONCAT:
2478 if (PL_lex_brackets)
2479 Perl_croak(aTHX_ "panic: INTERPCONCAT");
2481 if (PL_bufptr == PL_bufend)
2482 return sublex_done();
2484 if (SvIVX(PL_linestr) == '\'') {
2485 SV *sv = newSVsv(PL_linestr);
2488 else if ( PL_hints & HINT_NEW_RE )
2489 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
2490 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2494 s = scan_const(PL_bufptr);
2496 PL_lex_state = LEX_INTERPCASEMOD;
2498 PL_lex_state = LEX_INTERPSTART;
2501 if (s != PL_bufptr) {
2502 PL_nextval[PL_nexttoke] = yylval;
2505 if (PL_lex_starts++)
2515 PL_lex_state = LEX_NORMAL;
2516 s = scan_formline(PL_bufptr);
2517 if (!PL_lex_formbrack)
2523 PL_oldoldbufptr = PL_oldbufptr;
2526 PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at %s\n",
2527 exp_name[PL_expect], s);
2533 if (isIDFIRST_lazy_if(s,UTF))
2535 Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
2538 goto fake_eof; /* emulate EOF on ^D or ^Z */
2543 if (PL_lex_brackets)
2544 yyerror("Missing right curly or square bracket");
2545 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2546 "### Tokener got EOF\n");
2550 if (s++ < PL_bufend)
2551 goto retry; /* ignore stray nulls */
2554 if (!PL_in_eval && !PL_preambled) {
2555 PL_preambled = TRUE;
2556 sv_setpv(PL_linestr,incl_perldb());
2557 if (SvCUR(PL_linestr))
2558 sv_catpv(PL_linestr,";");
2560 while(AvFILLp(PL_preambleav) >= 0) {
2561 SV *tmpsv = av_shift(PL_preambleav);
2562 sv_catsv(PL_linestr, tmpsv);
2563 sv_catpv(PL_linestr, ";");
2566 sv_free((SV*)PL_preambleav);
2567 PL_preambleav = NULL;
2569 if (PL_minus_n || PL_minus_p) {
2570 sv_catpv(PL_linestr, "LINE: while (<>) {");
2572 sv_catpv(PL_linestr,"chomp;");
2574 GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
2576 GvIMPORTED_AV_on(gv);
2578 if (strchr("/'\"", *PL_splitstr)
2579 && strchr(PL_splitstr + 1, *PL_splitstr))
2580 Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s);", PL_splitstr);
2583 s = "'~#\200\1'"; /* surely one char is unused...*/
2584 while (s[1] && strchr(PL_splitstr, *s)) s++;
2586 Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s%c",
2587 "q" + (delim == '\''), delim);
2588 for (s = PL_splitstr; *s; s++) {
2590 sv_catpvn(PL_linestr, "\\", 1);
2591 sv_catpvn(PL_linestr, s, 1);
2593 Perl_sv_catpvf(aTHX_ PL_linestr, "%c);", delim);
2597 sv_catpv(PL_linestr,"@F=split(' ');");
2600 sv_catpv(PL_linestr, "\n");
2601 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2602 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2603 PL_last_lop = PL_last_uni = Nullch;
2604 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2605 SV *sv = NEWSV(85,0);
2607 sv_upgrade(sv, SVt_PVMG);
2608 sv_setsv(sv,PL_linestr);
2609 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2614 bof = PL_rsfp ? TRUE : FALSE;
2615 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
2618 if (PL_preprocess && !PL_in_eval)
2619 (void)PerlProc_pclose(PL_rsfp);
2620 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2621 PerlIO_clearerr(PL_rsfp);
2623 (void)PerlIO_close(PL_rsfp);
2625 PL_doextract = FALSE;
2627 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2628 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
2629 sv_catpv(PL_linestr,";}");
2630 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2631 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2632 PL_last_lop = PL_last_uni = Nullch;
2633 PL_minus_n = PL_minus_p = 0;
2636 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2637 PL_last_lop = PL_last_uni = Nullch;
2638 sv_setpv(PL_linestr,"");
2639 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
2641 /* if it looks like the start of a BOM, check if it in fact is */
2642 else if (bof && (!*s || *(U8*)s == 0xEF || *(U8*)s >= 0xFE)) {
2643 #ifdef PERLIO_IS_STDIO
2644 # ifdef __GNU_LIBRARY__
2645 # if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
2646 # define FTELL_FOR_PIPE_IS_BROKEN
2650 # if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
2651 # define FTELL_FOR_PIPE_IS_BROKEN
2656 #ifdef FTELL_FOR_PIPE_IS_BROKEN
2657 /* This loses the possibility to detect the bof
2658 * situation on perl -P when the libc5 is being used.
2659 * Workaround? Maybe attach some extra state to PL_rsfp?
2662 bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
2664 bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
2667 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2668 s = swallow_bom((U8*)s);
2672 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
2673 PL_doextract = FALSE;
2675 /* Incest with pod. */
2676 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2677 sv_setpv(PL_linestr, "");
2678 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2679 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2680 PL_last_lop = PL_last_uni = Nullch;
2681 PL_doextract = FALSE;
2685 } while (PL_doextract);
2686 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2687 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2688 SV *sv = NEWSV(85,0);
2690 sv_upgrade(sv, SVt_PVMG);
2691 sv_setsv(sv,PL_linestr);
2692 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2694 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2695 PL_last_lop = PL_last_uni = Nullch;
2696 if (CopLINE(PL_curcop) == 1) {
2697 while (s < PL_bufend && isSPACE(*s))
2699 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2703 if (*s == '#' && *(s+1) == '!')
2705 #ifdef ALTERNATE_SHEBANG
2707 static char as[] = ALTERNATE_SHEBANG;
2708 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2709 d = s + (sizeof(as) - 1);
2711 #endif /* ALTERNATE_SHEBANG */
2720 while (*d && !isSPACE(*d))
2724 #ifdef ARG_ZERO_IS_SCRIPT
2725 if (ipathend > ipath) {
2727 * HP-UX (at least) sets argv[0] to the script name,
2728 * which makes $^X incorrect. And Digital UNIX and Linux,
2729 * at least, set argv[0] to the basename of the Perl
2730 * interpreter. So, having found "#!", we'll set it right.
2732 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
2733 assert(SvPOK(x) || SvGMAGICAL(x));
2734 if (sv_eq(x, CopFILESV(PL_curcop))) {
2735 sv_setpvn(x, ipath, ipathend - ipath);
2738 TAINT_NOT; /* $^X is always tainted, but that's OK */
2740 #endif /* ARG_ZERO_IS_SCRIPT */
2745 d = instr(s,"perl -");
2747 d = instr(s,"perl");
2749 /* avoid getting into infinite loops when shebang
2750 * line contains "Perl" rather than "perl" */
2752 for (d = ipathend-4; d >= ipath; --d) {
2753 if ((*d == 'p' || *d == 'P')
2754 && !ibcmp(d, "perl", 4))
2764 #ifdef ALTERNATE_SHEBANG
2766 * If the ALTERNATE_SHEBANG on this system starts with a
2767 * character that can be part of a Perl expression, then if
2768 * we see it but not "perl", we're probably looking at the
2769 * start of Perl code, not a request to hand off to some
2770 * other interpreter. Similarly, if "perl" is there, but
2771 * not in the first 'word' of the line, we assume the line
2772 * contains the start of the Perl program.
2774 if (d && *s != '#') {
2776 while (*c && !strchr("; \t\r\n\f\v#", *c))
2779 d = Nullch; /* "perl" not in first word; ignore */
2781 *s = '#'; /* Don't try to parse shebang line */
2783 #endif /* ALTERNATE_SHEBANG */
2784 #ifndef MACOS_TRADITIONAL
2789 !instr(s,"indir") &&
2790 instr(PL_origargv[0],"perl"))
2796 while (s < PL_bufend && isSPACE(*s))
2798 if (s < PL_bufend) {
2799 Newz(899,newargv,PL_origargc+3,char*);
2801 while (s < PL_bufend && !isSPACE(*s))
2804 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2807 newargv = PL_origargv;
2809 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
2810 Perl_croak(aTHX_ "Can't exec %s", ipath);
2814 U32 oldpdb = PL_perldb;
2815 bool oldn = PL_minus_n;
2816 bool oldp = PL_minus_p;
2818 while (*d && !isSPACE(*d)) d++;
2819 while (SPACE_OR_TAB(*d)) d++;
2823 if (*d == 'M' || *d == 'm') {
2825 while (*d && !isSPACE(*d)) d++;
2826 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2829 d = moreswitches(d);
2831 if ((PERLDB_LINE && !oldpdb) ||
2832 ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
2833 /* if we have already added "LINE: while (<>) {",
2834 we must not do it again */
2836 sv_setpv(PL_linestr, "");
2837 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2838 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2839 PL_last_lop = PL_last_uni = Nullch;
2840 PL_preambled = FALSE;
2842 (void)gv_fetchfile(PL_origfilename);
2849 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2851 PL_lex_state = LEX_FORMLINE;
2856 #ifdef PERL_STRICT_CR
2857 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2859 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
2861 case ' ': case '\t': case '\f': case 013:
2862 #ifdef MACOS_TRADITIONAL
2869 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2870 if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
2871 /* handle eval qq[#line 1 "foo"\n ...] */
2872 CopLINE_dec(PL_curcop);
2876 while (s < d && *s != '\n')
2881 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2883 PL_lex_state = LEX_FORMLINE;
2893 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2900 while (s < PL_bufend && SPACE_OR_TAB(*s))
2903 if (strnEQ(s,"=>",2)) {
2904 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2905 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2906 "### Saw unary minus before =>, forcing word '%s'\n", s);
2908 OPERATOR('-'); /* unary minus */
2910 PL_last_uni = PL_oldbufptr;
2912 case 'r': ftst = OP_FTEREAD; break;
2913 case 'w': ftst = OP_FTEWRITE; break;
2914 case 'x': ftst = OP_FTEEXEC; break;
2915 case 'o': ftst = OP_FTEOWNED; break;
2916 case 'R': ftst = OP_FTRREAD; break;
2917 case 'W': ftst = OP_FTRWRITE; break;
2918 case 'X': ftst = OP_FTREXEC; break;
2919 case 'O': ftst = OP_FTROWNED; break;
2920 case 'e': ftst = OP_FTIS; break;
2921 case 'z': ftst = OP_FTZERO; break;
2922 case 's': ftst = OP_FTSIZE; break;
2923 case 'f': ftst = OP_FTFILE; break;
2924 case 'd': ftst = OP_FTDIR; break;
2925 case 'l': ftst = OP_FTLINK; break;
2926 case 'p': ftst = OP_FTPIPE; break;
2927 case 'S': ftst = OP_FTSOCK; break;
2928 case 'u': ftst = OP_FTSUID; break;
2929 case 'g': ftst = OP_FTSGID; break;
2930 case 'k': ftst = OP_FTSVTX; break;
2931 case 'b': ftst = OP_FTBLK; break;
2932 case 'c': ftst = OP_FTCHR; break;
2933 case 't': ftst = OP_FTTTY; break;
2934 case 'T': ftst = OP_FTTEXT; break;
2935 case 'B': ftst = OP_FTBINARY; break;
2936 case 'M': case 'A': case 'C':
2937 gv_fetchpv("\024",TRUE, SVt_PV);
2939 case 'M': ftst = OP_FTMTIME; break;
2940 case 'A': ftst = OP_FTATIME; break;
2941 case 'C': ftst = OP_FTCTIME; break;
2949 PL_last_lop_op = ftst;
2950 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2951 "### Saw file test %c\n", (int)ftst);
2956 /* Assume it was a minus followed by a one-letter named
2957 * subroutine call (or a -bareword), then. */
2958 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2959 "### %c looked like a file test but was not\n",
2968 if (PL_expect == XOPERATOR)
2973 else if (*s == '>') {
2976 if (isIDFIRST_lazy_if(s,UTF)) {
2977 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2985 if (PL_expect == XOPERATOR)
2988 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2990 OPERATOR('-'); /* unary minus */
2997 if (PL_expect == XOPERATOR)
3002 if (PL_expect == XOPERATOR)
3005 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
3011 if (PL_expect != XOPERATOR) {
3012 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3013 PL_expect = XOPERATOR;
3014 force_ident(PL_tokenbuf, '*');
3027 if (PL_expect == XOPERATOR) {
3031 PL_tokenbuf[0] = '%';
3032 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
3033 if (!PL_tokenbuf[1]) {
3035 yyerror("Final % should be \\% or %name");
3038 PL_pending_ident = '%';
3057 switch (PL_expect) {
3060 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
3062 PL_bufptr = s; /* update in case we back off */
3068 PL_expect = XTERMBLOCK;
3072 while (isIDFIRST_lazy_if(s,UTF)) {
3073 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3074 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
3075 if (tmp < 0) tmp = -tmp;
3090 d = scan_str(d,TRUE,TRUE);
3092 /* MUST advance bufptr here to avoid bogus
3093 "at end of line" context messages from yyerror().
3095 PL_bufptr = s + len;
3096 yyerror("Unterminated attribute parameter in attribute list");
3099 return 0; /* EOF indicator */
3103 SV *sv = newSVpvn(s, len);
3104 sv_catsv(sv, PL_lex_stuff);
3105 attrs = append_elem(OP_LIST, attrs,
3106 newSVOP(OP_CONST, 0, sv));
3107 SvREFCNT_dec(PL_lex_stuff);
3108 PL_lex_stuff = Nullsv;
3111 if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len))
3112 CvLVALUE_on(PL_compcv);
3113 else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len))
3114 CvLOCKED_on(PL_compcv);
3115 else if (!PL_in_my && len == 6 && strnEQ(s, "method", len))
3116 CvMETHOD_on(PL_compcv);
3118 else if (PL_in_my == KEY_our && len == 6 && strnEQ(s, "shared", len))
3119 GvSHARED_on(cGVOPx_gv(yylval.opval));
3121 /* After we've set the flags, it could be argued that
3122 we don't need to do the attributes.pm-based setting
3123 process, and shouldn't bother appending recognized
3124 flags. To experiment with that, uncomment the
3125 following "else": */
3127 attrs = append_elem(OP_LIST, attrs,
3128 newSVOP(OP_CONST, 0,
3132 if (*s == ':' && s[1] != ':')
3135 break; /* require real whitespace or :'s */
3137 tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
3138 if (*s != ';' && *s != tmp && (tmp != '=' || *s != ')')) {
3139 char q = ((*s == '\'') ? '"' : '\'');
3140 /* If here for an expression, and parsed no attrs, back off. */
3141 if (tmp == '=' && !attrs) {
3145 /* MUST advance bufptr here to avoid bogus "at end of line"
3146 context messages from yyerror().
3150 yyerror("Unterminated attribute list");
3152 yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list",
3160 PL_nextval[PL_nexttoke].opval = attrs;
3168 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
3169 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
3185 if (PL_lex_brackets <= 0)
3186 yyerror("Unmatched right square bracket");
3189 if (PL_lex_state == LEX_INTERPNORMAL) {
3190 if (PL_lex_brackets == 0) {
3191 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
3192 PL_lex_state = LEX_INTERPEND;
3199 if (PL_lex_brackets > 100) {
3200 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
3201 if (newlb != PL_lex_brackstack) {
3203 PL_lex_brackstack = newlb;
3206 switch (PL_expect) {
3208 if (PL_lex_formbrack) {
3212 if (PL_oldoldbufptr == PL_last_lop)
3213 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3215 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3216 OPERATOR(HASHBRACK);
3218 while (s < PL_bufend && SPACE_OR_TAB(*s))
3221 PL_tokenbuf[0] = '\0';
3222 if (d < PL_bufend && *d == '-') {
3223 PL_tokenbuf[0] = '-';
3225 while (d < PL_bufend && SPACE_OR_TAB(*d))
3228 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
3229 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
3231 while (d < PL_bufend && SPACE_OR_TAB(*d))
3234 char minus = (PL_tokenbuf[0] == '-');
3235 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
3243 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
3248 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3253 if (PL_oldoldbufptr == PL_last_lop)
3254 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3256 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3259 OPERATOR(HASHBRACK);
3260 /* This hack serves to disambiguate a pair of curlies
3261 * as being a block or an anon hash. Normally, expectation
3262 * determines that, but in cases where we're not in a
3263 * position to expect anything in particular (like inside
3264 * eval"") we have to resolve the ambiguity. This code
3265 * covers the case where the first term in the curlies is a
3266 * quoted string. Most other cases need to be explicitly
3267 * disambiguated by prepending a `+' before the opening
3268 * curly in order to force resolution as an anon hash.
3270 * XXX should probably propagate the outer expectation
3271 * into eval"" to rely less on this hack, but that could
3272 * potentially break current behavior of eval"".
3276 if (*s == '\'' || *s == '"' || *s == '`') {
3277 /* common case: get past first string, handling escapes */
3278 for (t++; t < PL_bufend && *t != *s;)
3279 if (*t++ == '\\' && (*t == '\\' || *t == *s))
3283 else if (*s == 'q') {
3286 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
3290 char open, close, term;
3293 while (t < PL_bufend && isSPACE(*t))
3297 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
3301 for (t++; t < PL_bufend; t++) {
3302 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
3304 else if (*t == open)
3308 for (t++; t < PL_bufend; t++) {
3309 if (*t == '\\' && t+1 < PL_bufend)
3311 else if (*t == close && --brackets <= 0)
3313 else if (*t == open)
3319 else if (isALNUM_lazy_if(t,UTF)) {
3321 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3324 while (t < PL_bufend && isSPACE(*t))
3326 /* if comma follows first term, call it an anon hash */
3327 /* XXX it could be a comma expression with loop modifiers */
3328 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
3329 || (*t == '=' && t[1] == '>')))
3330 OPERATOR(HASHBRACK);
3331 if (PL_expect == XREF)
3334 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
3340 yylval.ival = CopLINE(PL_curcop);
3341 if (isSPACE(*s) || *s == '#')
3342 PL_copline = NOLINE; /* invalidate current command line number */
3347 if (PL_lex_brackets <= 0)
3348 yyerror("Unmatched right curly bracket");
3350 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
3351 if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
3352 PL_lex_formbrack = 0;
3353 if (PL_lex_state == LEX_INTERPNORMAL) {
3354 if (PL_lex_brackets == 0) {
3355 if (PL_expect & XFAKEBRACK) {
3356 PL_expect &= XENUMMASK;
3357 PL_lex_state = LEX_INTERPEND;
3359 return yylex(); /* ignore fake brackets */
3361 if (*s == '-' && s[1] == '>')
3362 PL_lex_state = LEX_INTERPENDMAYBE;
3363 else if (*s != '[' && *s != '{')
3364 PL_lex_state = LEX_INTERPEND;
3367 if (PL_expect & XFAKEBRACK) {
3368 PL_expect &= XENUMMASK;
3370 return yylex(); /* ignore fake brackets */
3380 if (PL_expect == XOPERATOR) {
3381 if (ckWARN(WARN_SEMICOLON)
3382 && isIDFIRST_lazy_if(s,UTF) && PL_bufptr == PL_linestart)
3384 CopLINE_dec(PL_curcop);
3385 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3386 CopLINE_inc(PL_curcop);
3391 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3393 PL_expect = XOPERATOR;
3394 force_ident(PL_tokenbuf, '&');
3398 yylval.ival = (OPpENTERSUB_AMPER<<8);
3417 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
3418 Perl_warner(aTHX_ WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
3420 if (PL_expect == XSTATE && isALPHA(tmp) &&
3421 (s == PL_linestart+1 || s[-2] == '\n') )
3423 if (PL_in_eval && !PL_rsfp) {
3428 if (strnEQ(s,"=cut",4)) {
3442 PL_doextract = TRUE;
3445 if (PL_lex_brackets < PL_lex_formbrack) {
3447 #ifdef PERL_STRICT_CR
3448 for (t = s; SPACE_OR_TAB(*t); t++) ;
3450 for (t = s; SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
3452 if (*t == '\n' || *t == '#') {
3470 if (PL_expect != XOPERATOR) {
3471 if (s[1] != '<' && !strchr(s,'>'))
3474 s = scan_heredoc(s);
3476 s = scan_inputsymbol(s);
3477 TERM(sublex_start());
3482 SHop(OP_LEFT_SHIFT);
3496 SHop(OP_RIGHT_SHIFT);
3505 if (PL_expect == XOPERATOR) {
3506 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3509 return ','; /* grandfather non-comma-format format */
3513 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
3514 PL_tokenbuf[0] = '@';
3515 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3516 sizeof PL_tokenbuf - 1, FALSE);
3517 if (PL_expect == XOPERATOR)
3518 no_op("Array length", s);
3519 if (!PL_tokenbuf[1])
3521 PL_expect = XOPERATOR;
3522 PL_pending_ident = '#';
3526 PL_tokenbuf[0] = '$';
3527 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3528 sizeof PL_tokenbuf - 1, FALSE);
3529 if (PL_expect == XOPERATOR)
3531 if (!PL_tokenbuf[1]) {
3533 yyerror("Final $ should be \\$ or $name");
3537 /* This kludge not intended to be bulletproof. */
3538 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
3539 yylval.opval = newSVOP(OP_CONST, 0,
3540 newSViv(PL_compiling.cop_arybase));
3541 yylval.opval->op_private = OPpCONST_ARYBASE;
3547 if (PL_lex_state == LEX_NORMAL)
3550 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3553 PL_tokenbuf[0] = '@';
3554 if (ckWARN(WARN_SYNTAX)) {
3556 isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$';
3559 PL_bufptr = skipspace(PL_bufptr);
3560 while (t < PL_bufend && *t != ']')
3562 Perl_warner(aTHX_ WARN_SYNTAX,
3563 "Multidimensional syntax %.*s not supported",
3564 (t - PL_bufptr) + 1, PL_bufptr);
3568 else if (*s == '{') {
3569 PL_tokenbuf[0] = '%';
3570 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
3571 (t = strchr(s, '}')) && (t = strchr(t, '=')))
3573 char tmpbuf[sizeof PL_tokenbuf];
3575 for (t++; isSPACE(*t); t++) ;
3576 if (isIDFIRST_lazy_if(t,UTF)) {
3577 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
3578 for (; isSPACE(*t); t++) ;
3579 if (*t == ';' && get_cv(tmpbuf, FALSE))
3580 Perl_warner(aTHX_ WARN_SYNTAX,
3581 "You need to quote \"%s\"", tmpbuf);
3587 PL_expect = XOPERATOR;
3588 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3589 bool islop = (PL_last_lop == PL_oldoldbufptr);
3590 if (!islop || PL_last_lop_op == OP_GREPSTART)
3591 PL_expect = XOPERATOR;
3592 else if (strchr("$@\"'`q", *s))
3593 PL_expect = XTERM; /* e.g. print $fh "foo" */
3594 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
3595 PL_expect = XTERM; /* e.g. print $fh &sub */
3596 else if (isIDFIRST_lazy_if(s,UTF)) {
3597 char tmpbuf[sizeof PL_tokenbuf];
3598 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3599 if ((tmp = keyword(tmpbuf, len))) {
3600 /* binary operators exclude handle interpretations */
3612 PL_expect = XTERM; /* e.g. print $fh length() */
3617 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
3618 if (gv && GvCVu(gv))
3619 PL_expect = XTERM; /* e.g. print $fh subr() */
3622 else if (isDIGIT(*s))
3623 PL_expect = XTERM; /* e.g. print $fh 3 */
3624 else if (*s == '.' && isDIGIT(s[1]))
3625 PL_expect = XTERM; /* e.g. print $fh .3 */
3626 else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
3627 PL_expect = XTERM; /* e.g. print $fh -1 */
3628 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3629 PL_expect = XTERM; /* print $fh <<"EOF" */
3631 PL_pending_ident = '$';
3635 if (PL_expect == XOPERATOR)
3637 PL_tokenbuf[0] = '@';
3638 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3639 if (!PL_tokenbuf[1]) {
3641 yyerror("Final @ should be \\@ or @name");
3644 if (PL_lex_state == LEX_NORMAL)
3646 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3648 PL_tokenbuf[0] = '%';
3650 /* Warn about @ where they meant $. */
3651 if (ckWARN(WARN_SYNTAX)) {
3652 if (*s == '[' || *s == '{') {
3654 while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
3656 if (*t == '}' || *t == ']') {
3658 PL_bufptr = skipspace(PL_bufptr);
3659 Perl_warner(aTHX_ WARN_SYNTAX,
3660 "Scalar value %.*s better written as $%.*s",
3661 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
3666 PL_pending_ident = '@';
3669 case '/': /* may either be division or pattern */
3670 case '?': /* may either be conditional or pattern */
3671 if (PL_expect != XOPERATOR) {
3672 /* Disable warning on "study /blah/" */
3673 if (PL_oldoldbufptr == PL_last_uni
3674 && (*PL_last_uni != 's' || s - PL_last_uni < 5
3675 || memNE(PL_last_uni, "study", 5)
3676 || isALNUM_lazy_if(PL_last_uni+5,UTF)))
3678 s = scan_pat(s,OP_MATCH);
3679 TERM(sublex_start());
3687 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3688 #ifdef PERL_STRICT_CR
3691 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3693 && (s == PL_linestart || s[-1] == '\n') )
3695 PL_lex_formbrack = 0;
3699 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
3705 yylval.ival = OPf_SPECIAL;
3711 if (PL_expect != XOPERATOR)
3716 case '0': case '1': case '2': case '3': case '4':
3717 case '5': case '6': case '7': case '8': case '9':
3718 s = scan_num(s, &yylval);
3719 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3720 "### Saw number in '%s'\n", s);
3722 if (PL_expect == XOPERATOR)
3727 s = scan_str(s,FALSE,FALSE);
3728 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3729 "### Saw string before '%s'\n", s);
3731 if (PL_expect == XOPERATOR) {
3732 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3735 return ','; /* grandfather non-comma-format format */
3741 missingterm((char*)0);
3742 yylval.ival = OP_CONST;
3743 TERM(sublex_start());
3746 s = scan_str(s,FALSE,FALSE);
3747 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3748 "### Saw string before '%s'\n", s);
3750 if (PL_expect == XOPERATOR) {
3751 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3754 return ','; /* grandfather non-comma-format format */
3760 missingterm((char*)0);
3761 yylval.ival = OP_CONST;
3762 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
3763 if (*d == '$' || *d == '@' || *d == '\\' || UTF8_IS_CONTINUED(*d)) {
3764 yylval.ival = OP_STRINGIFY;
3768 TERM(sublex_start());
3771 s = scan_str(s,FALSE,FALSE);
3772 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3773 "### Saw backtick string before '%s'\n", s);
3775 if (PL_expect == XOPERATOR)
3776 no_op("Backticks",s);
3778 missingterm((char*)0);
3779 yylval.ival = OP_BACKTICK;
3781 TERM(sublex_start());
3785 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
3786 Perl_warner(aTHX_ WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
3788 if (PL_expect == XOPERATOR)
3789 no_op("Backslash",s);
3793 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
3797 while (isDIGIT(*start) || *start == '_')
3799 if (*start == '.' && isDIGIT(start[1])) {
3800 s = scan_num(s, &yylval);
3803 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
3804 else if (!isALPHA(*start) && (PL_expect == XTERM || PL_expect == XREF)) {
3808 gv = gv_fetchpv(s, FALSE, SVt_PVCV);
3811 s = scan_num(s, &yylval);
3818 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
3857 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3859 /* Some keywords can be followed by any delimiter, including ':' */
3860 tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
3861 (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
3862 (PL_tokenbuf[0] == 'q' &&
3863 strchr("qwxr", PL_tokenbuf[1])))));
3865 /* x::* is just a word, unless x is "CORE" */
3866 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
3870 while (d < PL_bufend && isSPACE(*d))
3871 d++; /* no comments skipped here, or s### is misparsed */
3873 /* Is this a label? */
3874 if (!tmp && PL_expect == XSTATE
3875 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
3877 yylval.pval = savepv(PL_tokenbuf);
3882 /* Check for keywords */
3883 tmp = keyword(PL_tokenbuf, len);
3885 /* Is this a word before a => operator? */
3886 if (*d == '=' && d[1] == '>') {
3888 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
3889 yylval.opval->op_private = OPpCONST_BARE;
3890 if (UTF && !IN_BYTE && is_utf8_string((U8*)PL_tokenbuf, len))
3891 SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
3895 if (tmp < 0) { /* second-class keyword? */
3896 GV *ogv = Nullgv; /* override (winner) */
3897 GV *hgv = Nullgv; /* hidden (loser) */
3898 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3900 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3903 if (GvIMPORTED_CV(gv))
3905 else if (! CvMETHOD(cv))
3909 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3910 (gv = *gvp) != (GV*)&PL_sv_undef &&
3911 GvCVu(gv) && GvIMPORTED_CV(gv))
3917 tmp = 0; /* overridden by import or by GLOBAL */
3920 && -tmp==KEY_lock /* XXX generalizable kludge */
3922 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3924 tmp = 0; /* any sub overrides "weak" keyword */
3926 else { /* no override */
3930 if (ckWARN(WARN_AMBIGUOUS) && hgv
3931 && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3932 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3933 "Ambiguous call resolved as CORE::%s(), %s",
3934 GvENAME(hgv), "qualify as such or use &");
3941 default: /* not a keyword */
3944 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3946 /* Get the rest if it looks like a package qualifier */
3948 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
3950 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3953 Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
3954 *s == '\'' ? "'" : "::");
3958 if (PL_expect == XOPERATOR) {
3959 if (PL_bufptr == PL_linestart) {
3960 CopLINE_dec(PL_curcop);
3961 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3962 CopLINE_inc(PL_curcop);
3965 no_op("Bareword",s);
3968 /* Look for a subroutine with this name in current package,
3969 unless name is "Foo::", in which case Foo is a bearword
3970 (and a package name). */
3973 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3975 if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3976 Perl_warner(aTHX_ WARN_BAREWORD,
3977 "Bareword \"%s\" refers to nonexistent package",
3980 PL_tokenbuf[len] = '\0';
3987 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3990 /* if we saw a global override before, get the right name */
3993 sv = newSVpvn("CORE::GLOBAL::",14);
3994 sv_catpv(sv,PL_tokenbuf);
3997 sv = newSVpv(PL_tokenbuf,0);
3999 /* Presume this is going to be a bareword of some sort. */
4002 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
4003 yylval.opval->op_private = OPpCONST_BARE;
4005 /* And if "Foo::", then that's what it certainly is. */
4010 /* See if it's the indirect object for a list operator. */
4012 if (PL_oldoldbufptr &&
4013 PL_oldoldbufptr < PL_bufptr &&
4014 (PL_oldoldbufptr == PL_last_lop
4015 || PL_oldoldbufptr == PL_last_uni) &&
4016 /* NO SKIPSPACE BEFORE HERE! */
4017 (PL_expect == XREF ||
4018 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
4020 bool immediate_paren = *s == '(';
4022 /* (Now we can afford to cross potential line boundary.) */
4025 /* Two barewords in a row may indicate method call. */
4027 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp=intuit_method(s,gv)))
4030 /* If not a declared subroutine, it's an indirect object. */
4031 /* (But it's an indir obj regardless for sort.) */
4033 if ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
4034 ((!gv || !GvCVu(gv)) &&
4035 (PL_last_lop_op != OP_MAPSTART &&
4036 PL_last_lop_op != OP_GREPSTART))))
4038 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
4044 PL_expect = XOPERATOR;
4047 /* Is this a word before a => operator? */
4048 if (*s == '=' && s[1] == '>') {
4050 sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
4051 if (UTF && !IN_BYTE && is_utf8_string((U8*)PL_tokenbuf, len))
4052 SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
4056 /* If followed by a paren, it's certainly a subroutine. */
4059 if (gv && GvCVu(gv)) {
4060 for (d = s + 1; SPACE_OR_TAB(*d); d++) ;
4061 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
4066 PL_nextval[PL_nexttoke].opval = yylval.opval;
4067 PL_expect = XOPERATOR;
4073 /* If followed by var or block, call it a method (unless sub) */
4075 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
4076 PL_last_lop = PL_oldbufptr;
4077 PL_last_lop_op = OP_METHOD;
4081 /* If followed by a bareword, see if it looks like indir obj. */
4083 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp = intuit_method(s,gv)))
4086 /* Not a method, so call it a subroutine (if defined) */
4088 if (gv && GvCVu(gv)) {
4090 if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
4091 Perl_warner(aTHX_ WARN_AMBIGUOUS,
4092 "Ambiguous use of -%s resolved as -&%s()",
4093 PL_tokenbuf, PL_tokenbuf);
4094 /* Check for a constant sub */
4096 if ((sv = cv_const_sv(cv))) {
4098 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
4099 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
4100 yylval.opval->op_private = 0;
4104 /* Resolve to GV now. */
4105 op_free(yylval.opval);
4106 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
4107 yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
4108 PL_last_lop = PL_oldbufptr;
4109 PL_last_lop_op = OP_ENTERSUB;
4110 /* Is there a prototype? */
4113 char *proto = SvPV((SV*)cv, len);
4116 if (strEQ(proto, "$"))
4118 if (*proto == '&' && *s == '{') {
4119 sv_setpv(PL_subname,"__ANON__");
4123 PL_nextval[PL_nexttoke].opval = yylval.opval;
4129 /* Call it a bare word */
4131 if (PL_hints & HINT_STRICT_SUBS)
4132 yylval.opval->op_private |= OPpCONST_STRICT;
4135 if (ckWARN(WARN_RESERVED)) {
4136 if (lastchar != '-') {
4137 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
4139 Perl_warner(aTHX_ WARN_RESERVED, PL_warn_reserved,
4146 if (lastchar && strchr("*%&", lastchar) && ckWARN_d(WARN_AMBIGUOUS)) {
4147 Perl_warner(aTHX_ WARN_AMBIGUOUS,
4148 "Operator or semicolon missing before %c%s",
4149 lastchar, PL_tokenbuf);
4150 Perl_warner(aTHX_ WARN_AMBIGUOUS,
4151 "Ambiguous use of %c resolved as operator %c",
4152 lastchar, lastchar);
4158 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4159 newSVpv(CopFILE(PL_curcop),0));
4163 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4164 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
4167 case KEY___PACKAGE__:
4168 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4170 ? newSVsv(PL_curstname)
4179 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
4180 char *pname = "main";
4181 if (PL_tokenbuf[2] == 'D')
4182 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
4183 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
4186 GvIOp(gv) = newIO();
4187 IoIFP(GvIOp(gv)) = PL_rsfp;
4188 #if defined(HAS_FCNTL) && defined(F_SETFD)
4190 int fd = PerlIO_fileno(PL_rsfp);
4191 fcntl(fd,F_SETFD,fd >= 3);
4194 /* Mark this internal pseudo-handle as clean */
4195 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
4197 IoTYPE(GvIOp(gv)) = IoTYPE_PIPE;
4198 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
4199 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
4201 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
4202 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
4203 /* if the script was opened in binmode, we need to revert
4204 * it to text mode for compatibility; but only iff it has CRs
4205 * XXX this is a questionable hack at best. */
4206 if (PL_bufend-PL_bufptr > 2
4207 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
4210 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
4211 loc = PerlIO_tell(PL_rsfp);
4212 (void)PerlIO_seek(PL_rsfp, 0L, 0);
4214 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
4216 PerlIO_seek(PL_rsfp, loc, 0);
4220 #ifdef PERLIO_LAYERS
4221 if (UTF && !IN_BYTE)
4222 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
4235 if (PL_expect == XSTATE) {
4242 if (*s == ':' && s[1] == ':') {
4245 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4246 if (!(tmp = keyword(PL_tokenbuf, len)))
4247 Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
4261 LOP(OP_ACCEPT,XTERM);
4267 LOP(OP_ATAN2,XTERM);
4273 LOP(OP_BINMODE,XTERM);
4276 LOP(OP_BLESS,XTERM);
4285 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
4302 if (!PL_cryptseen) {
4303 PL_cryptseen = TRUE;
4307 LOP(OP_CRYPT,XTERM);
4310 if (ckWARN(WARN_CHMOD)) {
4311 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4312 if (*d != '0' && isDIGIT(*d))
4313 Perl_warner(aTHX_ WARN_CHMOD,
4314 "chmod() mode argument is missing initial 0");
4316 LOP(OP_CHMOD,XTERM);
4319 LOP(OP_CHOWN,XTERM);
4322 LOP(OP_CONNECT,XTERM);
4338 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4342 PL_hints |= HINT_BLOCK_SCOPE;
4352 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
4353 LOP(OP_DBMOPEN,XTERM);
4359 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4366 yylval.ival = CopLINE(PL_curcop);
4380 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
4381 UNIBRACK(OP_ENTEREVAL);
4396 case KEY_endhostent:
4402 case KEY_endservent:
4405 case KEY_endprotoent:
4416 yylval.ival = CopLINE(PL_curcop);
4418 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
4420 if ((PL_bufend - p) >= 3 &&
4421 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
4423 else if ((PL_bufend - p) >= 4 &&
4424 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
4427 if (isIDFIRST_lazy_if(p,UTF)) {
4428 p = scan_ident(p, PL_bufend,
4429 PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4433 Perl_croak(aTHX_ "Missing $ on loop variable");
4438 LOP(OP_FORMLINE,XTERM);
4444 LOP(OP_FCNTL,XTERM);
4450 LOP(OP_FLOCK,XTERM);
4459 LOP(OP_GREPSTART, XREF);
4462 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4477 case KEY_getpriority:
4478 LOP(OP_GETPRIORITY,XTERM);
4480 case KEY_getprotobyname:
4483 case KEY_getprotobynumber:
4484 LOP(OP_GPBYNUMBER,XTERM);
4486 case KEY_getprotoent:
4498 case KEY_getpeername:
4499 UNI(OP_GETPEERNAME);
4501 case KEY_gethostbyname:
4504 case KEY_gethostbyaddr:
4505 LOP(OP_GHBYADDR,XTERM);
4507 case KEY_gethostent:
4510 case KEY_getnetbyname:
4513 case KEY_getnetbyaddr:
4514 LOP(OP_GNBYADDR,XTERM);
4519 case KEY_getservbyname:
4520 LOP(OP_GSBYNAME,XTERM);
4522 case KEY_getservbyport:
4523 LOP(OP_GSBYPORT,XTERM);
4525 case KEY_getservent:
4528 case KEY_getsockname:
4529 UNI(OP_GETSOCKNAME);
4531 case KEY_getsockopt:
4532 LOP(OP_GSOCKOPT,XTERM);
4554 yylval.ival = CopLINE(PL_curcop);
4558 LOP(OP_INDEX,XTERM);
4564 LOP(OP_IOCTL,XTERM);
4576 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4608 LOP(OP_LISTEN,XTERM);
4617 s = scan_pat(s,OP_MATCH);
4618 TERM(sublex_start());
4621 LOP(OP_MAPSTART, XREF);
4624 LOP(OP_MKDIR,XTERM);
4627 LOP(OP_MSGCTL,XTERM);
4630 LOP(OP_MSGGET,XTERM);
4633 LOP(OP_MSGRCV,XTERM);
4636 LOP(OP_MSGSND,XTERM);
4642 if (isIDFIRST_lazy_if(s,UTF)) {
4643 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
4644 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
4646 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
4647 if (!PL_in_my_stash) {
4650 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
4658 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4665 if (PL_expect != XSTATE)
4666 yyerror("\"no\" not allowed in expression");
4667 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4668 s = force_version(s);
4673 if (*s == '(' || (s = skipspace(s), *s == '('))
4680 if (isIDFIRST_lazy_if(s,UTF)) {
4682 for (d = s; isALNUM_lazy_if(d,UTF); d++) ;
4684 if (strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE))
4685 Perl_warner(aTHX_ WARN_PRECEDENCE,
4686 "Precedence problem: open %.*s should be open(%.*s)",
4692 yylval.ival = OP_OR;
4702 LOP(OP_OPEN_DIR,XTERM);
4705 checkcomma(s,PL_tokenbuf,"filehandle");
4709 checkcomma(s,PL_tokenbuf,"filehandle");
4728 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4732 LOP(OP_PIPE_OP,XTERM);
4735 s = scan_str(s,FALSE,FALSE);
4737 missingterm((char*)0);
4738 yylval.ival = OP_CONST;
4739 TERM(sublex_start());
4745 s = scan_str(s,FALSE,FALSE);
4747 missingterm((char*)0);
4749 if (SvCUR(PL_lex_stuff)) {
4752 d = SvPV_force(PL_lex_stuff, len);
4755 for (; isSPACE(*d) && len; --len, ++d) ;
4758 if (!warned && ckWARN(WARN_QW)) {
4759 for (; !isSPACE(*d) && len; --len, ++d) {
4761 Perl_warner(aTHX_ WARN_QW,
4762 "Possible attempt to separate words with commas");
4765 else if (*d == '#') {
4766 Perl_warner(aTHX_ WARN_QW,
4767 "Possible attempt to put comments in qw() list");
4773 for (; !isSPACE(*d) && len; --len, ++d) ;
4775 sv = newSVpvn(b, d-b);
4776 if (DO_UTF8(PL_lex_stuff))
4778 words = append_elem(OP_LIST, words,
4779 newSVOP(OP_CONST, 0, tokeq(sv)));
4783 PL_nextval[PL_nexttoke].opval = words;
4788 SvREFCNT_dec(PL_lex_stuff);
4789 PL_lex_stuff = Nullsv;
4795 s = scan_str(s,FALSE,FALSE);
4797 missingterm((char*)0);
4798 yylval.ival = OP_STRINGIFY;
4799 if (SvIVX(PL_lex_stuff) == '\'')
4800 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
4801 TERM(sublex_start());
4804 s = scan_pat(s,OP_QR);
4805 TERM(sublex_start());
4808 s = scan_str(s,FALSE,FALSE);
4810 missingterm((char*)0);
4811 yylval.ival = OP_BACKTICK;
4813 TERM(sublex_start());
4820 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4821 s = force_version(s);
4824 *PL_tokenbuf = '\0';
4825 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4826 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
4827 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
4829 yyerror("<> should be quotes");
4837 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4841 LOP(OP_RENAME,XTERM);
4850 LOP(OP_RINDEX,XTERM);
4873 LOP(OP_REVERSE,XTERM);
4884 TERM(sublex_start());
4886 TOKEN(1); /* force error */
4895 LOP(OP_SELECT,XTERM);
4901 LOP(OP_SEMCTL,XTERM);
4904 LOP(OP_SEMGET,XTERM);
4907 LOP(OP_SEMOP,XTERM);
4913 LOP(OP_SETPGRP,XTERM);
4915 case KEY_setpriority:
4916 LOP(OP_SETPRIORITY,XTERM);
4918 case KEY_sethostent:
4924 case KEY_setservent:
4927 case KEY_setprotoent:
4937 LOP(OP_SEEKDIR,XTERM);
4939 case KEY_setsockopt:
4940 LOP(OP_SSOCKOPT,XTERM);
4946 LOP(OP_SHMCTL,XTERM);
4949 LOP(OP_SHMGET,XTERM);
4952 LOP(OP_SHMREAD,XTERM);
4955 LOP(OP_SHMWRITE,XTERM);
4958 LOP(OP_SHUTDOWN,XTERM);
4967 LOP(OP_SOCKET,XTERM);
4969 case KEY_socketpair:
4970 LOP(OP_SOCKPAIR,XTERM);
4973 checkcomma(s,PL_tokenbuf,"subroutine name");
4975 if (*s == ';' || *s == ')') /* probably a close */
4976 Perl_croak(aTHX_ "sort is now a reserved word");
4978 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4982 LOP(OP_SPLIT,XTERM);
4985 LOP(OP_SPRINTF,XTERM);
4988 LOP(OP_SPLICE,XTERM);
5003 LOP(OP_SUBSTR,XTERM);
5009 char tmpbuf[sizeof PL_tokenbuf];
5011 expectation attrful;
5012 bool have_name, have_proto;
5017 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
5018 (*s == ':' && s[1] == ':'))
5021 attrful = XATTRBLOCK;
5022 /* remember buffer pos'n for later force_word */
5023 tboffset = s - PL_oldbufptr;
5024 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
5025 if (strchr(tmpbuf, ':'))
5026 sv_setpv(PL_subname, tmpbuf);
5028 sv_setsv(PL_subname,PL_curstname);
5029 sv_catpvn(PL_subname,"::",2);
5030 sv_catpvn(PL_subname,tmpbuf,len);
5037 Perl_croak(aTHX_ "Missing name in \"my sub\"");
5038 PL_expect = XTERMBLOCK;
5039 attrful = XATTRTERM;
5040 sv_setpv(PL_subname,"?");
5044 if (key == KEY_format) {
5046 PL_lex_formbrack = PL_lex_brackets + 1;
5048 (void) force_word(PL_oldbufptr + tboffset, WORD,
5053 /* Look for a prototype */
5057 s = scan_str(s,FALSE,FALSE);
5059 Perl_croak(aTHX_ "Prototype not terminated");
5061 d = SvPVX(PL_lex_stuff);
5063 for (p = d; *p; ++p) {
5068 SvCUR(PL_lex_stuff) = tmp;
5076 if (*s == ':' && s[1] != ':')
5077 PL_expect = attrful;
5080 PL_nextval[PL_nexttoke].opval =
5081 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
5082 PL_lex_stuff = Nullsv;
5086 sv_setpv(PL_subname,"__ANON__");
5089 (void) force_word(PL_oldbufptr + tboffset, WORD,
5098 LOP(OP_SYSTEM,XREF);
5101 LOP(OP_SYMLINK,XTERM);
5104 LOP(OP_SYSCALL,XTERM);
5107 LOP(OP_SYSOPEN,XTERM);
5110 LOP(OP_SYSSEEK,XTERM);
5113 LOP(OP_SYSREAD,XTERM);
5116 LOP(OP_SYSWRITE,XTERM);
5120 TERM(sublex_start());
5141 LOP(OP_TRUNCATE,XTERM);
5153 yylval.ival = CopLINE(PL_curcop);
5157 yylval.ival = CopLINE(PL_curcop);
5161 LOP(OP_UNLINK,XTERM);
5167 LOP(OP_UNPACK,XTERM);
5170 LOP(OP_UTIME,XTERM);
5173 if (ckWARN(WARN_UMASK)) {
5174 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
5175 if (*d != '0' && isDIGIT(*d))
5176 Perl_warner(aTHX_ WARN_UMASK,
5177 "umask: argument is missing initial 0");
5182 LOP(OP_UNSHIFT,XTERM);
5185 if (PL_expect != XSTATE)
5186 yyerror("\"use\" not allowed in expression");
5188 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
5189 s = force_version(s);
5190 if (*s == ';' || (s = skipspace(s), *s == ';')) {
5191 PL_nextval[PL_nexttoke].opval = Nullop;
5196 s = force_word(s,WORD,FALSE,TRUE,FALSE);
5197 s = force_version(s);
5209 yylval.ival = CopLINE(PL_curcop);
5213 PL_hints |= HINT_BLOCK_SCOPE;
5220 LOP(OP_WAITPID,XTERM);
5228 static char ctl_l[2];
5230 if (ctl_l[0] == '\0')
5231 ctl_l[0] = toCTRL('L');
5232 gv_fetchpv(ctl_l,TRUE, SVt_PV);
5235 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
5240 if (PL_expect == XOPERATOR)
5246 yylval.ival = OP_XOR;
5251 TERM(sublex_start());
5256 #pragma segment Main
5260 Perl_keyword(pTHX_ register char *d, I32 len)
5265 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
5266 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
5267 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
5268 if (strEQ(d,"__DATA__")) return KEY___DATA__;
5269 if (strEQ(d,"__END__")) return KEY___END__;
5273 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
5278 if (strEQ(d,"and")) return -KEY_and;
5279 if (strEQ(d,"abs")) return -KEY_abs;
5282 if (strEQ(d,"alarm")) return -KEY_alarm;
5283 if (strEQ(d,"atan2")) return -KEY_atan2;
5286 if (strEQ(d,"accept")) return -KEY_accept;
5291 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
5294 if (strEQ(d,"bless")) return -KEY_bless;
5295 if (strEQ(d,"bind")) return -KEY_bind;
5296 if (strEQ(d,"binmode")) return -KEY_binmode;
5299 if (strEQ(d,"CORE")) return -KEY_CORE;
5300 if (strEQ(d,"CHECK")) return KEY_CHECK;
5305 if (strEQ(d,"cmp")) return -KEY_cmp;
5306 if (strEQ(d,"chr")) return -KEY_chr;
5307 if (strEQ(d,"cos")) return -KEY_cos;
5310 if (strEQ(d,"chop")) return -KEY_chop;
5313 if (strEQ(d,"close")) return -KEY_close;
5314 if (strEQ(d,"chdir")) return -KEY_chdir;
5315 if (strEQ(d,"chomp")) return -KEY_chomp;
5316 if (strEQ(d,"chmod")) return -KEY_chmod;
5317 if (strEQ(d,"chown")) return -KEY_chown;
5318 if (strEQ(d,"crypt")) return -KEY_crypt;
5321 if (strEQ(d,"chroot")) return -KEY_chroot;
5322 if (strEQ(d,"caller")) return -KEY_caller;
5325 if (strEQ(d,"connect")) return -KEY_connect;
5328 if (strEQ(d,"closedir")) return -KEY_closedir;
5329 if (strEQ(d,"continue")) return -KEY_continue;
5334 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
5339 if (strEQ(d,"do")) return KEY_do;
5342 if (strEQ(d,"die")) return -KEY_die;
5345 if (strEQ(d,"dump")) return -KEY_dump;
5348 if (strEQ(d,"delete")) return KEY_delete;
5351 if (strEQ(d,"defined")) return KEY_defined;
5352 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
5355 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
5360 if (strEQ(d,"END")) return KEY_END;
5365 if (strEQ(d,"eq")) return -KEY_eq;
5368 if (strEQ(d,"eof")) return -KEY_eof;
5369 if (strEQ(d,"exp")) return -KEY_exp;
5372 if (strEQ(d,"else")) return KEY_else;
5373 if (strEQ(d,"exit")) return -KEY_exit;
5374 if (strEQ(d,"eval")) return KEY_eval;
5375 if (strEQ(d,"exec")) return -KEY_exec;
5376 if (strEQ(d,"each")) return -KEY_each;
5379 if (strEQ(d,"elsif")) return KEY_elsif;
5382 if (strEQ(d,"exists")) return KEY_exists;
5383 if (strEQ(d,"elseif")) Perl_warn(aTHX_ "elseif should be elsif");
5386 if (strEQ(d,"endgrent")) return -KEY_endgrent;
5387 if (strEQ(d,"endpwent")) return -KEY_endpwent;
5390 if (strEQ(d,"endnetent")) return -KEY_endnetent;
5393 if (strEQ(d,"endhostent")) return -KEY_endhostent;
5394 if (strEQ(d,"endservent")) return -KEY_endservent;
5397 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
5404 if (strEQ(d,"for")) return KEY_for;
5407 if (strEQ(d,"fork")) return -KEY_fork;
5410 if (strEQ(d,"fcntl")) return -KEY_fcntl;
5411 if (strEQ(d,"flock")) return -KEY_flock;
5414 if (strEQ(d,"format")) return KEY_format;
5415 if (strEQ(d,"fileno")) return -KEY_fileno;
5418 if (strEQ(d,"foreach")) return KEY_foreach;
5421 if (strEQ(d,"formline")) return -KEY_formline;
5426 if (strnEQ(d,"get",3)) {
5431 if (strEQ(d,"ppid")) return -KEY_getppid;
5432 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
5435 if (strEQ(d,"pwent")) return -KEY_getpwent;
5436 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
5437 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
5440 if (strEQ(d,"peername")) return -KEY_getpeername;
5441 if (strEQ(d,"protoent")) return -KEY_getprotoent;
5442 if (strEQ(d,"priority")) return -KEY_getpriority;
5445 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
5448 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
5452 else if (*d == 'h') {
5453 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
5454 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
5455 if (strEQ(d,"hostent")) return -KEY_gethostent;
5457 else if (*d == 'n') {
5458 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
5459 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
5460 if (strEQ(d,"netent")) return -KEY_getnetent;
5462 else if (*d == 's') {
5463 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
5464 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
5465 if (strEQ(d,"servent")) return -KEY_getservent;
5466 if (strEQ(d,"sockname")) return -KEY_getsockname;
5467 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
5469 else if (*d == 'g') {
5470 if (strEQ(d,"grent")) return -KEY_getgrent;
5471 if (strEQ(d,"grnam")) return -KEY_getgrnam;
5472 if (strEQ(d,"grgid")) return -KEY_getgrgid;
5474 else if (*d == 'l') {
5475 if (strEQ(d,"login")) return -KEY_getlogin;
5477 else if (strEQ(d,"c")) return -KEY_getc;
5482 if (strEQ(d,"gt")) return -KEY_gt;
5483 if (strEQ(d,"ge")) return -KEY_ge;
5486 if (strEQ(d,"grep")) return KEY_grep;
5487 if (strEQ(d,"goto")) return KEY_goto;
5488 if (strEQ(d,"glob")) return KEY_glob;
5491 if (strEQ(d,"gmtime")) return -KEY_gmtime;
5496 if (strEQ(d,"hex")) return -KEY_hex;
5499 if (strEQ(d,"INIT")) return KEY_INIT;
5504 if (strEQ(d,"if")) return KEY_if;
5507 if (strEQ(d,"int")) return -KEY_int;
5510 if (strEQ(d,"index")) return -KEY_index;
5511 if (strEQ(d,"ioctl")) return -KEY_ioctl;
5516 if (strEQ(d,"join")) return -KEY_join;
5520 if (strEQ(d,"keys")) return -KEY_keys;
5521 if (strEQ(d,"kill")) return -KEY_kill;
5527 if (strEQ(d,"lt")) return -KEY_lt;
5528 if (strEQ(d,"le")) return -KEY_le;
5529 if (strEQ(d,"lc")) return -KEY_lc;
5532 if (strEQ(d,"log")) return -KEY_log;
5535 if (strEQ(d,"last")) return KEY_last;
5536 if (strEQ(d,"link")) return -KEY_link;
5537 if (strEQ(d,"lock")) return -KEY_lock;
5540 if (strEQ(d,"local")) return KEY_local;
5541 if (strEQ(d,"lstat")) return -KEY_lstat;
5544 if (strEQ(d,"length")) return -KEY_length;
5545 if (strEQ(d,"listen")) return -KEY_listen;
5548 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
5551 if (strEQ(d,"localtime")) return -KEY_localtime;
5557 case 1: return KEY_m;
5559 if (strEQ(d,"my")) return KEY_my;
5562 if (strEQ(d,"map")) return KEY_map;
5565 if (strEQ(d,"mkdir")) return -KEY_mkdir;
5568 if (strEQ(d,"msgctl")) return -KEY_msgctl;
5569 if (strEQ(d,"msgget")) return -KEY_msgget;
5570 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
5571 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
5576 if (strEQ(d,"next")) return KEY_next;
5577 if (strEQ(d,"ne")) return -KEY_ne;
5578 if (strEQ(d,"not")) return -KEY_not;
5579 if (strEQ(d,"no")) return KEY_no;
5584 if (strEQ(d,"or")) return -KEY_or;
5587 if (strEQ(d,"ord")) return -KEY_ord;
5588 if (strEQ(d,"oct")) return -KEY_oct;
5589 if (strEQ(d,"our")) return KEY_our;
5592 if (strEQ(d,"open")) return -KEY_open;
5595 if (strEQ(d,"opendir")) return -KEY_opendir;
5602 if (strEQ(d,"pop")) return -KEY_pop;
5603 if (strEQ(d,"pos")) return KEY_pos;
5606 if (strEQ(d,"push")) return -KEY_push;
5607 if (strEQ(d,"pack")) return -KEY_pack;
5608 if (strEQ(d,"pipe")) return -KEY_pipe;
5611 if (strEQ(d,"print")) return KEY_print;
5614 if (strEQ(d,"printf")) return KEY_printf;
5617 if (strEQ(d,"package")) return KEY_package;
5620 if (strEQ(d,"prototype")) return KEY_prototype;
5625 if (strEQ(d,"q")) return KEY_q;
5626 if (strEQ(d,"qr")) return KEY_qr;
5627 if (strEQ(d,"qq")) return KEY_qq;
5628 if (strEQ(d,"qw")) return KEY_qw;
5629 if (strEQ(d,"qx")) return KEY_qx;
5631 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
5636 if (strEQ(d,"ref")) return -KEY_ref;
5639 if (strEQ(d,"read")) return -KEY_read;
5640 if (strEQ(d,"rand")) return -KEY_rand;
5641 if (strEQ(d,"recv")) return -KEY_recv;
5642 if (strEQ(d,"redo")) return KEY_redo;
5645 if (strEQ(d,"rmdir")) return -KEY_rmdir;
5646 if (strEQ(d,"reset")) return -KEY_reset;
5649 if (strEQ(d,"return")) return KEY_return;
5650 if (strEQ(d,"rename")) return -KEY_rename;
5651 if (strEQ(d,"rindex")) return -KEY_rindex;
5654 if (strEQ(d,"require")) return -KEY_require;
5655 if (strEQ(d,"reverse")) return -KEY_reverse;
5656 if (strEQ(d,"readdir")) return -KEY_readdir;
5659 if (strEQ(d,"readlink")) return -KEY_readlink;
5660 if (strEQ(d,"readline")) return -KEY_readline;
5661 if (strEQ(d,"readpipe")) return -KEY_readpipe;
5664 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
5670 case 0: return KEY_s;
5672 if (strEQ(d,"scalar")) return KEY_scalar;
5677 if (strEQ(d,"seek")) return -KEY_seek;
5678 if (strEQ(d,"send")) return -KEY_send;
5681 if (strEQ(d,"semop")) return -KEY_semop;
5684 if (strEQ(d,"select")) return -KEY_select;
5685 if (strEQ(d,"semctl")) return -KEY_semctl;
5686 if (strEQ(d,"semget")) return -KEY_semget;
5689 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
5690 if (strEQ(d,"seekdir")) return -KEY_seekdir;
5693 if (strEQ(d,"setpwent")) return -KEY_setpwent;
5694 if (strEQ(d,"setgrent")) return -KEY_setgrent;
5697 if (strEQ(d,"setnetent")) return -KEY_setnetent;
5700 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
5701 if (strEQ(d,"sethostent")) return -KEY_sethostent;
5702 if (strEQ(d,"setservent")) return -KEY_setservent;
5705 if (strEQ(d,"setpriority")) return -KEY_setpriority;
5706 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
5713 if (strEQ(d,"shift")) return -KEY_shift;
5716 if (strEQ(d,"shmctl")) return -KEY_shmctl;
5717 if (strEQ(d,"shmget")) return -KEY_shmget;
5720 if (strEQ(d,"shmread")) return -KEY_shmread;
5723 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
5724 if (strEQ(d,"shutdown")) return -KEY_shutdown;
5729 if (strEQ(d,"sin")) return -KEY_sin;
5732 if (strEQ(d,"sleep")) return -KEY_sleep;
5735 if (strEQ(d,"sort")) return KEY_sort;
5736 if (strEQ(d,"socket")) return -KEY_socket;
5737 if (strEQ(d,"socketpair")) return -KEY_socketpair;
5740 if (strEQ(d,"split")) return KEY_split;
5741 if (strEQ(d,"sprintf")) return -KEY_sprintf;
5742 if (strEQ(d,"splice")) return -KEY_splice;
5745 if (strEQ(d,"sqrt")) return -KEY_sqrt;
5748 if (strEQ(d,"srand")) return -KEY_srand;
5751 if (strEQ(d,"stat")) return -KEY_stat;
5752 if (strEQ(d,"study")) return KEY_study;
5755 if (strEQ(d,"substr")) return -KEY_substr;
5756 if (strEQ(d,"sub")) return KEY_sub;
5761 if (strEQ(d,"system")) return -KEY_system;
5764 if (strEQ(d,"symlink")) return -KEY_symlink;
5765 if (strEQ(d,"syscall")) return -KEY_syscall;
5766 if (strEQ(d,"sysopen")) return -KEY_sysopen;
5767 if (strEQ(d,"sysread")) return -KEY_sysread;
5768 if (strEQ(d,"sysseek")) return -KEY_sysseek;
5771 if (strEQ(d,"syswrite")) return -KEY_syswrite;
5780 if (strEQ(d,"tr")) return KEY_tr;
5783 if (strEQ(d,"tie")) return KEY_tie;
5786 if (strEQ(d,"tell")) return -KEY_tell;
5787 if (strEQ(d,"tied")) return KEY_tied;
5788 if (strEQ(d,"time")) return -KEY_time;
5791 if (strEQ(d,"times")) return -KEY_times;
5794 if (strEQ(d,"telldir")) return -KEY_telldir;
5797 if (strEQ(d,"truncate")) return -KEY_truncate;
5804 if (strEQ(d,"uc")) return -KEY_uc;
5807 if (strEQ(d,"use")) return KEY_use;
5810 if (strEQ(d,"undef")) return KEY_undef;
5811 if (strEQ(d,"until")) return KEY_until;
5812 if (strEQ(d,"untie")) return KEY_untie;
5813 if (strEQ(d,"utime")) return -KEY_utime;
5814 if (strEQ(d,"umask")) return -KEY_umask;
5817 if (strEQ(d,"unless")) return KEY_unless;
5818 if (strEQ(d,"unpack")) return -KEY_unpack;
5819 if (strEQ(d,"unlink")) return -KEY_unlink;
5822 if (strEQ(d,"unshift")) return -KEY_unshift;
5823 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
5828 if (strEQ(d,"values")) return -KEY_values;
5829 if (strEQ(d,"vec")) return -KEY_vec;
5834 if (strEQ(d,"warn")) return -KEY_warn;
5835 if (strEQ(d,"wait")) return -KEY_wait;
5838 if (strEQ(d,"while")) return KEY_while;
5839 if (strEQ(d,"write")) return -KEY_write;
5842 if (strEQ(d,"waitpid")) return -KEY_waitpid;
5845 if (strEQ(d,"wantarray")) return -KEY_wantarray;
5850 if (len == 1) return -KEY_x;
5851 if (strEQ(d,"xor")) return -KEY_xor;
5854 if (len == 1) return KEY_y;
5863 S_checkcomma(pTHX_ register char *s, char *name, char *what)
5867 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
5868 if (ckWARN(WARN_SYNTAX)) {
5870 for (w = s+2; *w && level; w++) {
5877 for (; *w && isSPACE(*w); w++) ;
5878 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
5879 Perl_warner(aTHX_ WARN_SYNTAX,
5880 "%s (...) interpreted as function",name);
5883 while (s < PL_bufend && isSPACE(*s))
5887 while (s < PL_bufend && isSPACE(*s))
5889 if (isIDFIRST_lazy_if(s,UTF)) {
5891 while (isALNUM_lazy_if(s,UTF))
5893 while (s < PL_bufend && isSPACE(*s))
5898 kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
5902 Perl_croak(aTHX_ "No comma allowed after %s", what);
5907 /* Either returns sv, or mortalizes sv and returns a new SV*.
5908 Best used as sv=new_constant(..., sv, ...).
5909 If s, pv are NULL, calls subroutine with one argument,
5910 and type is used with error messages only. */
5913 S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv,
5917 HV *table = GvHV(PL_hintgv); /* ^H */
5921 const char *why1, *why2, *why3;
5923 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
5926 why2 = strEQ(key,"charnames")
5927 ? "(possibly a missing \"use charnames ...\")"
5929 msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
5930 (type ? type: "undef"), why2);
5932 /* This is convoluted and evil ("goto considered harmful")
5933 * but I do not understand the intricacies of all the different
5934 * failure modes of %^H in here. The goal here is to make
5935 * the most probable error message user-friendly. --jhi */
5940 msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
5941 (type ? type: "undef"), why1, why2, why3);
5943 yyerror(SvPVX(msg));
5947 cvp = hv_fetch(table, key, strlen(key), FALSE);
5948 if (!cvp || !SvOK(*cvp)) {
5951 why3 = "} is not defined";
5954 sv_2mortal(sv); /* Parent created it permanently */
5957 pv = sv_2mortal(newSVpvn(s, len));
5959 typesv = sv_2mortal(newSVpv(type, 0));
5961 typesv = &PL_sv_undef;
5963 PUSHSTACKi(PERLSI_OVERLOAD);
5975 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
5979 /* Check the eval first */
5980 if (!PL_in_eval && SvTRUE(ERRSV)) {
5982 sv_catpv(ERRSV, "Propagated");
5983 yyerror(SvPV(ERRSV, n_a)); /* Duplicates the message inside eval */
5985 res = SvREFCNT_inc(sv);
5989 (void)SvREFCNT_inc(res);
5998 why1 = "Call to &{$^H{";
6000 why3 = "}} did not return a defined value";
6009 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
6011 register char *d = dest;
6012 register char *e = d + destlen - 3; /* two-character token, ending NUL */
6015 Perl_croak(aTHX_ ident_too_long);
6016 if (isALNUM(*s)) /* UTF handled below */
6018 else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) {
6023 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
6027 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
6028 char *t = s + UTF8SKIP(s);
6029 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
6031 if (d + (t - s) > e)
6032 Perl_croak(aTHX_ ident_too_long);
6033 Copy(s, d, t - s, char);
6046 S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
6056 e = d + destlen - 3; /* two-character token, ending NUL */
6058 while (isDIGIT(*s)) {
6060 Perl_croak(aTHX_ ident_too_long);
6067 Perl_croak(aTHX_ ident_too_long);
6068 if (isALNUM(*s)) /* UTF handled below */
6070 else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
6075 else if (*s == ':' && s[1] == ':') {
6079 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
6080 char *t = s + UTF8SKIP(s);
6081 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
6083 if (d + (t - s) > e)
6084 Perl_croak(aTHX_ ident_too_long);
6085 Copy(s, d, t - s, char);
6096 if (PL_lex_state != LEX_NORMAL)
6097 PL_lex_state = LEX_INTERPENDMAYBE;
6100 if (*s == '$' && s[1] &&
6101 (isALNUM_lazy_if(s+1,UTF) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
6114 if (*d == '^' && *s && isCONTROLVAR(*s)) {
6119 if (isSPACE(s[-1])) {
6122 if (!SPACE_OR_TAB(ch)) {
6128 if (isIDFIRST_lazy_if(d,UTF)) {
6132 while ((e < send && isALNUM_lazy_if(e,UTF)) || *e == ':') {
6134 while (e < send && UTF8_IS_CONTINUED(*e) && is_utf8_mark((U8*)e))
6137 Copy(s, d, e - s, char);
6142 while ((isALNUM(*s) || *s == ':') && d < e)
6145 Perl_croak(aTHX_ ident_too_long);
6148 while (s < send && SPACE_OR_TAB(*s)) s++;
6149 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
6150 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
6151 const char *brack = *s == '[' ? "[...]" : "{...}";
6152 Perl_warner(aTHX_ WARN_AMBIGUOUS,
6153 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
6154 funny, dest, brack, funny, dest, brack);
6157 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
6161 /* Handle extended ${^Foo} variables
6162 * 1999-02-27 mjd-perl-patch@plover.com */
6163 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
6167 while (isALNUM(*s) && d < e) {
6171 Perl_croak(aTHX_ ident_too_long);
6176 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
6177 PL_lex_state = LEX_INTERPEND;
6180 if (PL_lex_state == LEX_NORMAL) {
6181 if (ckWARN(WARN_AMBIGUOUS) &&
6182 (keyword(dest, d - dest) || get_cv(dest, FALSE)))
6184 Perl_warner(aTHX_ WARN_AMBIGUOUS,
6185 "Ambiguous use of %c{%s} resolved to %c%s",
6186 funny, dest, funny, dest);
6191 s = bracket; /* let the parser handle it */
6195 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
6196 PL_lex_state = LEX_INTERPEND;
6201 Perl_pmflag(pTHX_ U16 *pmfl, int ch)
6206 *pmfl |= PMf_GLOBAL;
6208 *pmfl |= PMf_CONTINUE;
6212 *pmfl |= PMf_MULTILINE;
6214 *pmfl |= PMf_SINGLELINE;
6216 *pmfl |= PMf_EXTENDED;
6220 S_scan_pat(pTHX_ char *start, I32 type)
6225 s = scan_str(start,FALSE,FALSE);
6227 Perl_croak(aTHX_ "Search pattern not terminated");
6229 pm = (PMOP*)newPMOP(type, 0);
6230 if (PL_multi_open == '?')
6231 pm->op_pmflags |= PMf_ONCE;
6233 while (*s && strchr("iomsx", *s))
6234 pmflag(&pm->op_pmflags,*s++);
6237 while (*s && strchr("iogcmsx", *s))
6238 pmflag(&pm->op_pmflags,*s++);
6240 pm->op_pmpermflags = pm->op_pmflags;
6242 PL_lex_op = (OP*)pm;
6243 yylval.ival = OP_MATCH;
6248 S_scan_subst(pTHX_ char *start)
6255 yylval.ival = OP_NULL;
6257 s = scan_str(start,FALSE,FALSE);
6260 Perl_croak(aTHX_ "Substitution pattern not terminated");
6262 if (s[-1] == PL_multi_open)
6265 first_start = PL_multi_start;
6266 s = scan_str(s,FALSE,FALSE);
6269 SvREFCNT_dec(PL_lex_stuff);
6270 PL_lex_stuff = Nullsv;
6272 Perl_croak(aTHX_ "Substitution replacement not terminated");
6274 PL_multi_start = first_start; /* so whole substitution is taken together */
6276 pm = (PMOP*)newPMOP(OP_SUBST, 0);
6282 else if (strchr("iogcmsx", *s))
6283 pmflag(&pm->op_pmflags,*s++);
6290 PL_sublex_info.super_bufptr = s;
6291 PL_sublex_info.super_bufend = PL_bufend;
6293 pm->op_pmflags |= PMf_EVAL;
6294 repl = newSVpvn("",0);
6296 sv_catpv(repl, es ? "eval " : "do ");
6297 sv_catpvn(repl, "{ ", 2);
6298 sv_catsv(repl, PL_lex_repl);
6299 sv_catpvn(repl, " };", 2);
6301 SvREFCNT_dec(PL_lex_repl);
6305 pm->op_pmpermflags = pm->op_pmflags;
6306 PL_lex_op = (OP*)pm;
6307 yylval.ival = OP_SUBST;
6312 S_scan_trans(pTHX_ char *start)
6321 yylval.ival = OP_NULL;
6323 s = scan_str(start,FALSE,FALSE);
6325 Perl_croak(aTHX_ "Transliteration pattern not terminated");
6326 if (s[-1] == PL_multi_open)
6329 s = scan_str(s,FALSE,FALSE);
6332 SvREFCNT_dec(PL_lex_stuff);
6333 PL_lex_stuff = Nullsv;
6335 Perl_croak(aTHX_ "Transliteration replacement not terminated");
6338 complement = del = squash = 0;
6339 while (strchr("cds", *s)) {
6341 complement = OPpTRANS_COMPLEMENT;
6343 del = OPpTRANS_DELETE;
6345 squash = OPpTRANS_SQUASH;
6349 New(803, tbl, complement&&!del?258:256, short);
6350 o = newPVOP(OP_TRANS, 0, (char*)tbl);
6351 o->op_private = del|squash|complement|
6352 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
6353 (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0);
6356 yylval.ival = OP_TRANS;
6361 S_scan_heredoc(pTHX_ register char *s)
6364 I32 op_type = OP_SCALAR;
6371 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
6375 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
6378 for (peek = s; SPACE_OR_TAB(*peek); peek++) ;
6379 if (*peek && strchr("`'\"",*peek)) {
6382 s = delimcpy(d, e, s, PL_bufend, term, &len);
6392 if (!isALNUM_lazy_if(s,UTF))
6393 deprecate("bare << to mean <<\"\"");
6394 for (; isALNUM_lazy_if(s,UTF); s++) {
6399 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
6400 Perl_croak(aTHX_ "Delimiter for here document is too long");
6403 len = d - PL_tokenbuf;
6404 #ifndef PERL_STRICT_CR
6405 d = strchr(s, '\r');
6409 while (s < PL_bufend) {
6415 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
6424 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6429 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
6430 herewas = newSVpvn(s,PL_bufend-s);
6432 s--, herewas = newSVpvn(s,d-s);
6433 s += SvCUR(herewas);
6435 tmpstr = NEWSV(87,79);
6436 sv_upgrade(tmpstr, SVt_PVIV);
6441 else if (term == '`') {
6442 op_type = OP_BACKTICK;
6443 SvIVX(tmpstr) = '\\';
6447 PL_multi_start = CopLINE(PL_curcop);
6448 PL_multi_open = PL_multi_close = '<';
6449 term = *PL_tokenbuf;
6450 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
6451 char *bufptr = PL_sublex_info.super_bufptr;
6452 char *bufend = PL_sublex_info.super_bufend;
6453 char *olds = s - SvCUR(herewas);
6454 s = strchr(bufptr, '\n');
6458 while (s < bufend &&
6459 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6461 CopLINE_inc(PL_curcop);
6464 CopLINE_set(PL_curcop, PL_multi_start);
6465 missingterm(PL_tokenbuf);
6467 sv_setpvn(herewas,bufptr,d-bufptr+1);
6468 sv_setpvn(tmpstr,d+1,s-d);
6470 sv_catpvn(herewas,s,bufend-s);
6471 (void)strcpy(bufptr,SvPVX(herewas));
6478 while (s < PL_bufend &&
6479 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6481 CopLINE_inc(PL_curcop);
6483 if (s >= PL_bufend) {
6484 CopLINE_set(PL_curcop, PL_multi_start);
6485 missingterm(PL_tokenbuf);
6487 sv_setpvn(tmpstr,d+1,s-d);
6489 CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
6491 sv_catpvn(herewas,s,PL_bufend-s);
6492 sv_setsv(PL_linestr,herewas);
6493 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
6494 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6495 PL_last_lop = PL_last_uni = Nullch;
6498 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
6499 while (s >= PL_bufend) { /* multiple line string? */
6501 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6502 CopLINE_set(PL_curcop, PL_multi_start);
6503 missingterm(PL_tokenbuf);
6505 CopLINE_inc(PL_curcop);
6506 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6507 PL_last_lop = PL_last_uni = Nullch;
6508 #ifndef PERL_STRICT_CR
6509 if (PL_bufend - PL_linestart >= 2) {
6510 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
6511 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
6513 PL_bufend[-2] = '\n';
6515 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6517 else if (PL_bufend[-1] == '\r')
6518 PL_bufend[-1] = '\n';
6520 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
6521 PL_bufend[-1] = '\n';
6523 if (PERLDB_LINE && PL_curstash != PL_debstash) {
6524 SV *sv = NEWSV(88,0);
6526 sv_upgrade(sv, SVt_PVMG);
6527 sv_setsv(sv,PL_linestr);
6528 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop),sv);
6530 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
6533 sv_catsv(PL_linestr,herewas);
6534 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6538 sv_catsv(tmpstr,PL_linestr);
6543 PL_multi_end = CopLINE(PL_curcop);
6544 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
6545 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
6546 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
6548 SvREFCNT_dec(herewas);
6549 if (UTF && !IN_BYTE && is_utf8_string((U8*)SvPVX(tmpstr), SvCUR(tmpstr)))
6551 PL_lex_stuff = tmpstr;
6552 yylval.ival = op_type;
6557 takes: current position in input buffer
6558 returns: new position in input buffer
6559 side-effects: yylval and lex_op are set.
6564 <FH> read from filehandle
6565 <pkg::FH> read from package qualified filehandle
6566 <pkg'FH> read from package qualified filehandle
6567 <$fh> read from filehandle in $fh
6573 S_scan_inputsymbol(pTHX_ char *start)
6575 register char *s = start; /* current position in buffer */
6581 d = PL_tokenbuf; /* start of temp holding space */
6582 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
6583 end = strchr(s, '\n');
6586 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
6588 /* die if we didn't have space for the contents of the <>,
6589 or if it didn't end, or if we see a newline
6592 if (len >= sizeof PL_tokenbuf)
6593 Perl_croak(aTHX_ "Excessively long <> operator");
6595 Perl_croak(aTHX_ "Unterminated <> operator");
6600 Remember, only scalar variables are interpreted as filehandles by
6601 this code. Anything more complex (e.g., <$fh{$num}>) will be
6602 treated as a glob() call.
6603 This code makes use of the fact that except for the $ at the front,
6604 a scalar variable and a filehandle look the same.
6606 if (*d == '$' && d[1]) d++;
6608 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
6609 while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
6612 /* If we've tried to read what we allow filehandles to look like, and
6613 there's still text left, then it must be a glob() and not a getline.
6614 Use scan_str to pull out the stuff between the <> and treat it
6615 as nothing more than a string.
6618 if (d - PL_tokenbuf != len) {
6619 yylval.ival = OP_GLOB;
6621 s = scan_str(start,FALSE,FALSE);
6623 Perl_croak(aTHX_ "Glob not terminated");
6627 /* we're in a filehandle read situation */
6630 /* turn <> into <ARGV> */
6632 (void)strcpy(d,"ARGV");
6634 /* if <$fh>, create the ops to turn the variable into a
6640 /* try to find it in the pad for this block, otherwise find
6641 add symbol table ops
6643 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
6644 OP *o = newOP(OP_PADSV, 0);
6646 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, o);
6649 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
6650 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
6651 newUNOP(OP_RV2SV, 0,
6652 newGVOP(OP_GV, 0, gv)));
6654 PL_lex_op->op_flags |= OPf_SPECIAL;
6655 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
6656 yylval.ival = OP_NULL;
6659 /* If it's none of the above, it must be a literal filehandle
6660 (<Foo::BAR> or <FOO>) so build a simple readline OP */
6662 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
6663 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
6664 yylval.ival = OP_NULL;
6673 takes: start position in buffer
6674 keep_quoted preserve \ on the embedded delimiter(s)
6675 keep_delims preserve the delimiters around the string
6676 returns: position to continue reading from buffer
6677 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
6678 updates the read buffer.
6680 This subroutine pulls a string out of the input. It is called for:
6681 q single quotes q(literal text)
6682 ' single quotes 'literal text'
6683 qq double quotes qq(interpolate $here please)
6684 " double quotes "interpolate $here please"
6685 qx backticks qx(/bin/ls -l)
6686 ` backticks `/bin/ls -l`
6687 qw quote words @EXPORT_OK = qw( func() $spam )
6688 m// regexp match m/this/
6689 s/// regexp substitute s/this/that/
6690 tr/// string transliterate tr/this/that/
6691 y/// string transliterate y/this/that/
6692 ($*@) sub prototypes sub foo ($)
6693 (stuff) sub attr parameters sub foo : attr(stuff)
6694 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
6696 In most of these cases (all but <>, patterns and transliterate)
6697 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
6698 calls scan_str(). s/// makes yylex() call scan_subst() which calls
6699 scan_str(). tr/// and y/// make yylex() call scan_trans() which
6702 It skips whitespace before the string starts, and treats the first
6703 character as the delimiter. If the delimiter is one of ([{< then
6704 the corresponding "close" character )]}> is used as the closing
6705 delimiter. It allows quoting of delimiters, and if the string has
6706 balanced delimiters ([{<>}]) it allows nesting.
6708 On success, the SV with the resulting string is put into lex_stuff or,
6709 if that is already non-NULL, into lex_repl. The second case occurs only
6710 when parsing the RHS of the special constructs s/// and tr/// (y///).
6711 For convenience, the terminating delimiter character is stuffed into
6716 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
6718 SV *sv; /* scalar value: string */
6719 char *tmps; /* temp string, used for delimiter matching */
6720 register char *s = start; /* current position in the buffer */
6721 register char term; /* terminating character */
6722 register char *to; /* current position in the sv's data */
6723 I32 brackets = 1; /* bracket nesting level */
6724 bool has_utf8 = FALSE; /* is there any utf8 content? */
6726 /* skip space before the delimiter */
6730 /* mark where we are, in case we need to report errors */
6733 /* after skipping whitespace, the next character is the terminator */
6735 if (UTF8_IS_CONTINUED(term) && UTF)
6738 /* mark where we are */
6739 PL_multi_start = CopLINE(PL_curcop);
6740 PL_multi_open = term;
6742 /* find corresponding closing delimiter */
6743 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
6745 PL_multi_close = term;
6747 /* create a new SV to hold the contents. 87 is leak category, I'm
6748 assuming. 79 is the SV's initial length. What a random number. */
6750 sv_upgrade(sv, SVt_PVIV);
6752 (void)SvPOK_only(sv); /* validate pointer */
6754 /* move past delimiter and try to read a complete string */
6756 sv_catpvn(sv, s, 1);
6759 /* extend sv if need be */
6760 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
6761 /* set 'to' to the next character in the sv's string */
6762 to = SvPVX(sv)+SvCUR(sv);
6764 /* if open delimiter is the close delimiter read unbridle */
6765 if (PL_multi_open == PL_multi_close) {
6766 for (; s < PL_bufend; s++,to++) {
6767 /* embedded newlines increment the current line number */
6768 if (*s == '\n' && !PL_rsfp)
6769 CopLINE_inc(PL_curcop);
6770 /* handle quoted delimiters */
6771 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
6772 if (!keep_quoted && s[1] == term)
6774 /* any other quotes are simply copied straight through */
6778 /* terminate when run out of buffer (the for() condition), or
6779 have found the terminator */
6780 else if (*s == term)
6782 else if (!has_utf8 && UTF8_IS_CONTINUED(*s) && UTF)
6788 /* if the terminator isn't the same as the start character (e.g.,
6789 matched brackets), we have to allow more in the quoting, and
6790 be prepared for nested brackets.
6793 /* read until we run out of string, or we find the terminator */
6794 for (; s < PL_bufend; s++,to++) {
6795 /* embedded newlines increment the line count */
6796 if (*s == '\n' && !PL_rsfp)
6797 CopLINE_inc(PL_curcop);
6798 /* backslashes can escape the open or closing characters */
6799 if (*s == '\\' && s+1 < PL_bufend) {
6801 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
6806 /* allow nested opens and closes */
6807 else if (*s == PL_multi_close && --brackets <= 0)
6809 else if (*s == PL_multi_open)
6811 else if (!has_utf8 && UTF8_IS_CONTINUED(*s) && UTF)
6816 /* terminate the copied string and update the sv's end-of-string */
6818 SvCUR_set(sv, to - SvPVX(sv));
6821 * this next chunk reads more into the buffer if we're not done yet
6825 break; /* handle case where we are done yet :-) */
6827 #ifndef PERL_STRICT_CR
6828 if (to - SvPVX(sv) >= 2) {
6829 if ((to[-2] == '\r' && to[-1] == '\n') ||
6830 (to[-2] == '\n' && to[-1] == '\r'))
6834 SvCUR_set(sv, to - SvPVX(sv));
6836 else if (to[-1] == '\r')
6839 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
6843 /* if we're out of file, or a read fails, bail and reset the current
6844 line marker so we can report where the unterminated string began
6847 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6849 CopLINE_set(PL_curcop, PL_multi_start);
6852 /* we read a line, so increment our line counter */
6853 CopLINE_inc(PL_curcop);
6855 /* update debugger info */
6856 if (PERLDB_LINE && PL_curstash != PL_debstash) {
6857 SV *sv = NEWSV(88,0);
6859 sv_upgrade(sv, SVt_PVMG);
6860 sv_setsv(sv,PL_linestr);
6861 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop), sv);
6864 /* having changed the buffer, we must update PL_bufend */
6865 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6866 PL_last_lop = PL_last_uni = Nullch;
6869 /* at this point, we have successfully read the delimited string */
6872 sv_catpvn(sv, s, 1);
6875 PL_multi_end = CopLINE(PL_curcop);
6878 /* if we allocated too much space, give some back */
6879 if (SvCUR(sv) + 5 < SvLEN(sv)) {
6880 SvLEN_set(sv, SvCUR(sv) + 1);
6881 Renew(SvPVX(sv), SvLEN(sv), char);
6884 /* decide whether this is the first or second quoted string we've read
6897 takes: pointer to position in buffer
6898 returns: pointer to new position in buffer
6899 side-effects: builds ops for the constant in yylval.op
6901 Read a number in any of the formats that Perl accepts:
6903 0(x[0-7A-F]+)|([0-7]+)|(b[01])
6904 [\d_]+(\.[\d_]*)?[Ee](\d+)
6906 Underbars (_) are allowed in decimal numbers. If -w is on,
6907 underbars before a decimal point must be at three digit intervals.
6909 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
6912 If it reads a number without a decimal point or an exponent, it will
6913 try converting the number to an integer and see if it can do so
6914 without loss of precision.
6918 Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp)
6920 register char *s = start; /* current position in buffer */
6921 register char *d; /* destination in temp buffer */
6922 register char *e; /* end of temp buffer */
6923 NV nv; /* number read, as a double */
6924 SV *sv = Nullsv; /* place to put the converted number */
6925 bool floatit; /* boolean: int or float? */
6926 char *lastub = 0; /* position of last underbar */
6927 static char number_too_long[] = "Number too long";
6929 /* We use the first character to decide what type of number this is */
6933 Perl_croak(aTHX_ "panic: scan_num");
6935 /* if it starts with a 0, it could be an octal number, a decimal in
6936 0.13 disguise, or a hexadecimal number, or a binary number. */
6940 u holds the "number so far"
6941 shift the power of 2 of the base
6942 (hex == 4, octal == 3, binary == 1)
6943 overflowed was the number more than we can hold?
6945 Shift is used when we add a digit. It also serves as an "are
6946 we in octal/hex/binary?" indicator to disallow hex characters
6952 bool overflowed = FALSE;
6953 static NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
6954 static char* bases[5] = { "", "binary", "", "octal",
6956 static char* Bases[5] = { "", "Binary", "", "Octal",
6958 static char *maxima[5] = { "",
6959 "0b11111111111111111111111111111111",
6963 char *base, *Base, *max;
6969 } else if (s[1] == 'b') {
6973 /* check for a decimal in disguise */
6974 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
6976 /* so it must be octal */
6980 base = bases[shift];
6981 Base = Bases[shift];
6982 max = maxima[shift];
6984 /* read the rest of the number */
6986 /* x is used in the overflow test,
6987 b is the digit we're adding on. */
6992 /* if we don't mention it, we're done */
7001 /* 8 and 9 are not octal */
7004 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
7008 case '2': case '3': case '4':
7009 case '5': case '6': case '7':
7011 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
7015 b = *s++ & 15; /* ASCII digit -> value of digit */
7019 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
7020 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
7021 /* make sure they said 0x */
7026 /* Prepare to put the digit we have onto the end
7027 of the number so far. We check for overflows.
7032 x = u << shift; /* make room for the digit */
7034 if ((x >> shift) != u
7035 && !(PL_hints & HINT_NEW_BINARY)) {
7038 if (ckWARN_d(WARN_OVERFLOW))
7039 Perl_warner(aTHX_ WARN_OVERFLOW,
7040 "Integer overflow in %s number",
7043 u = x | b; /* add the digit to the end */
7046 n *= nvshift[shift];
7047 /* If an NV has not enough bits in its
7048 * mantissa to represent an UV this summing of
7049 * small low-order numbers is a waste of time
7050 * (because the NV cannot preserve the
7051 * low-order bits anyway): we could just
7052 * remember when did we overflow and in the
7053 * end just multiply n by the right
7061 /* if we get here, we had success: make a scalar value from
7067 if (ckWARN(WARN_PORTABLE) && n > 4294967295.0)
7068 Perl_warner(aTHX_ WARN_PORTABLE,
7069 "%s number > %s non-portable",
7075 if (ckWARN(WARN_PORTABLE) && u > 0xffffffff)
7076 Perl_warner(aTHX_ WARN_PORTABLE,
7077 "%s number > %s non-portable",
7082 if (PL_hints & HINT_NEW_BINARY)
7083 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
7088 handle decimal numbers.
7089 we're also sent here when we read a 0 as the first digit
7091 case '1': case '2': case '3': case '4': case '5':
7092 case '6': case '7': case '8': case '9': case '.':
7095 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
7098 /* read next group of digits and _ and copy into d */
7099 while (isDIGIT(*s) || *s == '_') {
7100 /* skip underscores, checking for misplaced ones
7104 if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
7105 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
7109 /* check for end of fixed-length buffer */
7111 Perl_croak(aTHX_ number_too_long);
7112 /* if we're ok, copy the character */
7117 /* final misplaced underbar check */
7118 if (lastub && s - lastub != 3) {
7119 if (ckWARN(WARN_SYNTAX))
7120 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
7123 /* read a decimal portion if there is one. avoid
7124 3..5 being interpreted as the number 3. followed
7127 if (*s == '.' && s[1] != '.') {
7131 /* copy, ignoring underbars, until we run out of
7132 digits. Note: no misplaced underbar checks!
7134 for (; isDIGIT(*s) || *s == '_'; s++) {
7135 /* fixed length buffer check */
7137 Perl_croak(aTHX_ number_too_long);
7141 if (*s == '.' && isDIGIT(s[1])) {
7142 /* oops, it's really a v-string, but without the "v" */
7148 /* read exponent part, if present */
7149 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
7153 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
7154 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
7156 /* allow positive or negative exponent */
7157 if (*s == '+' || *s == '-')
7160 /* read digits of exponent (no underbars :-) */
7161 while (isDIGIT(*s)) {
7163 Perl_croak(aTHX_ number_too_long);
7168 /* terminate the string */
7171 /* make an sv from the string */
7174 #if defined(Strtol) && defined(Strtoul)
7177 strtol/strtoll sets errno to ERANGE if the number is too big
7178 for an integer. We try to do an integer conversion first
7179 if no characters indicating "float" have been found.
7186 if (*PL_tokenbuf == '-')
7187 iv = Strtol(PL_tokenbuf, (char**)NULL, 10);
7189 uv = Strtoul(PL_tokenbuf, (char**)NULL, 10);
7191 floatit = TRUE; /* Probably just too large. */
7192 else if (*PL_tokenbuf == '-')
7194 else if (uv <= IV_MAX)
7195 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
7200 nv = Atof(PL_tokenbuf);
7205 No working strtou?ll?.
7207 Unfortunately atol() doesn't do range checks (returning
7208 LONG_MIN/LONG_MAX, and setting errno to ERANGE on overflows)
7209 everywhere [1], so we cannot use use atol() (or atoll()).
7210 If we could, they would be used, as Atol(), very much like
7211 Strtol() and Strtoul() are used above.
7213 [1] XXX Configure test needed to check for atol()
7214 (and atoll()) overflow behaviour XXX
7218 We need to do this the hard way. */
7220 nv = Atof(PL_tokenbuf);
7222 /* See if we can make do with an integer value without loss of
7223 precision. We use U_V to cast to a UV, because some
7224 compilers have issues. Then we try casting it back and see
7225 if it was the same [1]. We only do this if we know we
7226 specifically read an integer. If floatit is true, then we
7227 don't need to do the conversion at all.
7229 [1] Note that this is lossy if our NVs cannot preserve our
7230 UVs. There are metaconfig defines NV_PRESERVES_UV (a boolean)
7231 and NV_PRESERVES_UV_BITS (a number), but in general we really
7232 do hope all such potentially lossy platforms have strtou?ll?
7233 to do a lossless IV/UV conversion.
7235 Maybe could do some tricks with DBL_DIG, LDBL_DIG and
7236 DBL_MANT_DIG and LDBL_MANT_DIG (these are already available
7237 as NV_DIG and NV_MANT_DIG)?
7243 if (!floatit && (NV)uv == nv) {
7245 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
7253 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
7254 (PL_hints & HINT_NEW_INTEGER) )
7255 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
7256 (floatit ? "float" : "integer"),
7260 /* if it starts with a v, it could be a v-string */
7266 while (isDIGIT(*pos) || *pos == '_')
7268 if (!isALPHA(*pos)) {
7270 U8 tmpbuf[UTF8_MAXLEN+1];
7272 s++; /* get past 'v' */
7275 sv_setpvn(sv, "", 0);
7278 if (*s == '0' && isDIGIT(s[1]))
7279 yyerror("Octal number in vector unsupported");
7282 /* this is atoi() that tolerates underscores */
7285 while (--end >= s) {
7290 rev += (*end - '0') * mult;
7292 if (orev > rev && ckWARN_d(WARN_OVERFLOW))
7293 Perl_warner(aTHX_ WARN_OVERFLOW,
7294 "Integer overflow in decimal number");
7297 tmpend = uv_to_utf8(tmpbuf, rev);
7300 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
7301 if (*pos == '.' && isDIGIT(pos[1]))
7307 while (isDIGIT(*pos) || *pos == '_')
7316 sv_utf8_downgrade(sv, TRUE);
7323 /* make the op for the constant and return */
7326 lvalp->opval = newSVOP(OP_CONST, 0, sv);
7328 lvalp->opval = Nullop;
7334 S_scan_formline(pTHX_ register char *s)
7338 SV *stuff = newSVpvn("",0);
7339 bool needargs = FALSE;
7342 if (*s == '.' || *s == /*{*/'}') {
7344 #ifdef PERL_STRICT_CR
7345 for (t = s+1;SPACE_OR_TAB(*t); t++) ;
7347 for (t = s+1;SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
7349 if (*t == '\n' || t == PL_bufend)
7352 if (PL_in_eval && !PL_rsfp) {
7353 eol = strchr(s,'\n');
7358 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7360 for (t = s; t < eol; t++) {
7361 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
7363 goto enough; /* ~~ must be first line in formline */
7365 if (*t == '@' || *t == '^')
7368 sv_catpvn(stuff, s, eol-s);
7369 #ifndef PERL_STRICT_CR
7370 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
7371 char *end = SvPVX(stuff) + SvCUR(stuff);
7380 s = filter_gets(PL_linestr, PL_rsfp, 0);
7381 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
7382 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
7383 PL_last_lop = PL_last_uni = Nullch;
7386 yyerror("Format not terminated");
7396 PL_lex_state = LEX_NORMAL;
7397 PL_nextval[PL_nexttoke].ival = 0;
7401 PL_lex_state = LEX_FORMLINE;
7402 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
7404 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
7408 SvREFCNT_dec(stuff);
7409 PL_lex_formbrack = 0;
7420 PL_cshlen = strlen(PL_cshname);
7425 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
7427 I32 oldsavestack_ix = PL_savestack_ix;
7428 CV* outsidecv = PL_compcv;
7432 assert(SvTYPE(PL_compcv) == SVt_PVCV);
7434 SAVEI32(PL_subline);
7435 save_item(PL_subname);
7438 SAVESPTR(PL_comppad_name);
7439 SAVESPTR(PL_compcv);
7440 SAVEI32(PL_comppad_name_fill);
7441 SAVEI32(PL_min_intro_pending);
7442 SAVEI32(PL_max_intro_pending);
7443 SAVEI32(PL_pad_reset_pending);
7445 PL_compcv = (CV*)NEWSV(1104,0);
7446 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
7447 CvFLAGS(PL_compcv) |= flags;
7449 PL_comppad = newAV();
7450 av_push(PL_comppad, Nullsv);
7451 PL_curpad = AvARRAY(PL_comppad);
7452 PL_comppad_name = newAV();
7453 PL_comppad_name_fill = 0;
7454 PL_min_intro_pending = 0;
7456 PL_subline = CopLINE(PL_curcop);
7458 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
7459 PL_curpad[0] = (SV*)newAV();
7460 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
7461 #endif /* USE_THREADS */
7463 comppadlist = newAV();
7464 AvREAL_off(comppadlist);
7465 av_store(comppadlist, 0, (SV*)PL_comppad_name);
7466 av_store(comppadlist, 1, (SV*)PL_comppad);
7468 CvPADLIST(PL_compcv) = comppadlist;
7469 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
7471 CvOWNER(PL_compcv) = 0;
7472 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
7473 MUTEX_INIT(CvMUTEXP(PL_compcv));
7474 #endif /* USE_THREADS */
7476 return oldsavestack_ix;
7480 #pragma segment Perl_yylex
7483 Perl_yywarn(pTHX_ char *s)
7485 PL_in_eval |= EVAL_WARNONLY;
7487 PL_in_eval &= ~EVAL_WARNONLY;
7492 Perl_yyerror(pTHX_ char *s)
7495 char *context = NULL;
7499 if (!yychar || (yychar == ';' && !PL_rsfp))
7501 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
7502 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
7503 while (isSPACE(*PL_oldoldbufptr))
7505 context = PL_oldoldbufptr;
7506 contlen = PL_bufptr - PL_oldoldbufptr;
7508 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
7509 PL_oldbufptr != PL_bufptr) {
7510 while (isSPACE(*PL_oldbufptr))
7512 context = PL_oldbufptr;
7513 contlen = PL_bufptr - PL_oldbufptr;
7515 else if (yychar > 255)
7516 where = "next token ???";
7517 #ifdef USE_PURE_BISON
7518 /* GNU Bison sets the value -2 */
7519 else if (yychar == -2) {
7521 else if ((yychar & 127) == 127) {
7523 if (PL_lex_state == LEX_NORMAL ||
7524 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
7525 where = "at end of line";
7526 else if (PL_lex_inpat)
7527 where = "within pattern";
7529 where = "within string";
7532 SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
7534 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
7535 else if (isPRINT_LC(yychar))
7536 Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
7538 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
7539 where = SvPVX(where_sv);
7541 msg = sv_2mortal(newSVpv(s, 0));
7542 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
7543 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
7545 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
7547 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
7548 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
7549 Perl_sv_catpvf(aTHX_ msg,
7550 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
7551 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
7554 if (PL_in_eval & EVAL_WARNONLY)
7555 Perl_warn(aTHX_ "%"SVf, msg);
7558 if (PL_error_count >= 10) {
7559 if (PL_in_eval && SvCUR(ERRSV))
7560 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
7561 ERRSV, CopFILE(PL_curcop));
7563 Perl_croak(aTHX_ "%s has too many errors.\n",
7564 CopFILE(PL_curcop));
7567 PL_in_my_stash = Nullhv;
7571 #pragma segment Main
7575 S_swallow_bom(pTHX_ U8 *s)
7578 slen = SvCUR(PL_linestr);
7582 /* UTF-16 little-endian */
7583 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
7584 Perl_croak(aTHX_ "Unsupported script encoding");
7585 #ifndef PERL_NO_UTF16_FILTER
7586 DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-LE script encoding\n"));
7588 if (PL_bufend > (char*)s) {
7592 filter_add(utf16rev_textfilter, NULL);
7593 New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
7594 PL_bufend = (char*)utf16_to_utf8_reversed(s, news,
7595 PL_bufend - (char*)s - 1,
7597 Copy(news, s, newlen, U8);
7598 SvCUR_set(PL_linestr, newlen);
7599 PL_bufend = SvPVX(PL_linestr) + newlen;
7600 news[newlen++] = '\0';
7604 Perl_croak(aTHX_ "Unsupported script encoding");
7609 if (s[1] == 0xFF) { /* UTF-16 big-endian */
7610 #ifndef PERL_NO_UTF16_FILTER
7611 DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding\n"));
7613 if (PL_bufend > (char *)s) {
7617 filter_add(utf16_textfilter, NULL);
7618 New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
7619 PL_bufend = (char*)utf16_to_utf8(s, news,
7620 PL_bufend - (char*)s,
7622 Copy(news, s, newlen, U8);
7623 SvCUR_set(PL_linestr, newlen);
7624 PL_bufend = SvPVX(PL_linestr) + newlen;
7625 news[newlen++] = '\0';
7629 Perl_croak(aTHX_ "Unsupported script encoding");
7634 if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
7635 DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-8 script encoding\n"));
7640 if (slen > 3 && s[1] == 0 && /* UTF-32 big-endian */
7641 s[2] == 0xFE && s[3] == 0xFF)
7643 Perl_croak(aTHX_ "Unsupported script encoding");
7655 * Restore a source filter.
7659 restore_rsfp(pTHXo_ void *f)
7661 PerlIO *fp = (PerlIO*)f;
7663 if (PL_rsfp == PerlIO_stdin())
7664 PerlIO_clearerr(PL_rsfp);
7665 else if (PL_rsfp && (PL_rsfp != fp))
7666 PerlIO_close(PL_rsfp);
7670 #ifndef PERL_NO_UTF16_FILTER
7672 utf16_textfilter(pTHXo_ int idx, SV *sv, int maxlen)
7674 I32 count = FILTER_READ(idx+1, sv, maxlen);
7679 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
7680 if (!*SvPV_nolen(sv))
7681 /* Game over, but don't feed an odd-length string to utf16_to_utf8 */
7684 tend = utf16_to_utf8((U8*)SvPVX(sv), tmps, SvCUR(sv), &newlen);
7685 sv_usepvn(sv, (char*)tmps, tend - tmps);
7691 utf16rev_textfilter(pTHXo_ int idx, SV *sv, int maxlen)
7693 I32 count = FILTER_READ(idx+1, sv, maxlen);
7698 if (!*SvPV_nolen(sv))
7699 /* Game over, but don't feed an odd-length string to utf16_to_utf8 */
7702 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
7703 tend = utf16_to_utf8_reversed((U8*)SvPVX(sv), tmps, SvCUR(sv), &newlen);
7704 sv_usepvn(sv, (char*)tmps, tend - tmps);