3 * Copyright (c) 1991-1999, 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);
32 #define XFAKEBRACK 128
35 #define UTF (PL_hints & HINT_UTF8)
37 * Note: we try to be careful never to call the isXXX_utf8() functions
38 * unless we're pretty sure we've seen the beginning of a UTF-8 character
39 * (that is, the two high bits are set). Otherwise we risk loading in the
40 * heavy-duty SWASHINIT and SWASHGET routines unnecessarily.
42 #define isIDFIRST_lazy(p) ((!UTF || (*((U8*)p) < 0xc0)) \
44 : isIDFIRST_utf8((U8*)p))
45 #define isALNUM_lazy(p) ((!UTF || (*((U8*)p) < 0xc0)) \
47 : isALNUM_utf8((U8*)p))
49 /* In variables name $^X, these are the legal values for X.
50 * 1999-02-27 mjd-perl-patch@plover.com */
51 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
53 /* 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
79 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
81 # include <unistd.h> /* Needed for execv() */
90 YYSTYPE* yylval_pointer = NULL;
91 int* yychar_pointer = NULL;
94 # define yylval (*yylval_pointer)
95 # define yychar (*yychar_pointer)
96 # define PERL_YYLEX_PARAM yylval_pointer,yychar_pointer
98 # define yylex() Perl_yylex(aTHX_ yylval_pointer, yychar_pointer)
101 #include "keywords.h"
103 /* CLINE is a macro that ensures PL_copline has a sane value */
108 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
111 * Convenience functions to return different tokens and prime the
112 * lexer for the next token. They all take an argument.
114 * TOKEN : generic token (used for '(', DOLSHARP, etc)
115 * OPERATOR : generic operator
116 * AOPERATOR : assignment operator
117 * PREBLOCK : beginning the block after an if, while, foreach, ...
118 * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
119 * PREREF : *EXPR where EXPR is not a simple identifier
120 * TERM : expression term
121 * LOOPX : loop exiting command (goto, last, dump, etc)
122 * FTST : file test operator
123 * FUN0 : zero-argument function
124 * FUN1 : not used, except for not, which isn't a UNIOP
125 * BOop : bitwise or or xor
127 * SHop : shift operator
128 * PWop : power operator
129 * PMop : pattern-matching operator
130 * Aop : addition-level operator
131 * Mop : multiplication-level operator
132 * Eop : equality-testing operator
133 * Rop : relational operator <= != gt
135 * Also see LOP and lop() below.
138 #define TOKEN(retval) return (PL_bufptr = s,(int)retval)
139 #define OPERATOR(retval) return (PL_expect = XTERM,PL_bufptr = s,(int)retval)
140 #define AOPERATOR(retval) return ao((PL_expect = XTERM,PL_bufptr = s,(int)retval))
141 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s,(int)retval)
142 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval)
143 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s,(int)retval)
144 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR,PL_bufptr = s,(int)retval)
145 #define LOOPX(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX)
146 #define FTST(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)UNIOP)
147 #define FUN0(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0)
148 #define FUN1(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1)
149 #define BOop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITOROP))
150 #define BAop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP))
151 #define SHop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP))
152 #define PWop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)POWOP))
153 #define PMop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP)
154 #define Aop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)ADDOP))
155 #define Mop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MULOP))
156 #define Eop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)EQOP)
157 #define Rop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)RELOP)
159 /* This bit of chicanery makes a unary function followed by
160 * a parenthesis into a function with one argument, highest precedence.
162 #define UNI(f) return(yylval.ival = f, \
165 PL_last_uni = PL_oldbufptr, \
166 PL_last_lop_op = f, \
167 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
169 #define UNIBRACK(f) return(yylval.ival = f, \
171 PL_last_uni = PL_oldbufptr, \
172 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
174 /* grandfather return to old style */
175 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
180 * This subroutine detects &&= and ||= and turns an ANDAND or OROR
181 * into an OP_ANDASSIGN or OP_ORASSIGN
185 S_ao(pTHX_ int toketype)
187 if (*PL_bufptr == '=') {
189 if (toketype == ANDAND)
190 yylval.ival = OP_ANDASSIGN;
191 else if (toketype == OROR)
192 yylval.ival = OP_ORASSIGN;
200 * When Perl expects an operator and finds something else, no_op
201 * prints the warning. It always prints "<something> found where
202 * operator expected. It prints "Missing semicolon on previous line?"
203 * if the surprise occurs at the start of the line. "do you need to
204 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
205 * where the compiler doesn't know if foo is a method call or a function.
206 * It prints "Missing operator before end of line" if there's nothing
207 * after the missing operator, or "... before <...>" if there is something
208 * after the missing operator.
212 S_no_op(pTHX_ char *what, char *s)
214 char *oldbp = PL_bufptr;
215 bool is_first = (PL_oldbufptr == PL_linestart);
223 yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
225 Perl_warn(aTHX_ "\t(Missing semicolon on previous line?)\n");
226 else if (PL_oldoldbufptr && isIDFIRST_lazy(PL_oldoldbufptr)) {
228 for (t = PL_oldoldbufptr; *t && (isALNUM_lazy(t) || *t == ':'); t++) ;
229 if (t < PL_bufptr && isSPACE(*t))
230 Perl_warn(aTHX_ "\t(Do you need to predeclare %.*s?)\n",
231 t - PL_oldoldbufptr, PL_oldoldbufptr);
234 Perl_warn(aTHX_ "\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
240 * Complain about missing quote/regexp/heredoc terminator.
241 * If it's called with (char *)NULL then it cauterizes the line buffer.
242 * If we're in a delimited string and the delimiter is a control
243 * character, it's reformatted into a two-char sequence like ^C.
248 S_missingterm(pTHX_ char *s)
253 char *nl = strrchr(s,'\n');
259 iscntrl(PL_multi_close)
261 PL_multi_close < 32 || PL_multi_close == 127
265 tmpbuf[1] = toCTRL(PL_multi_close);
271 *tmpbuf = PL_multi_close;
275 q = strchr(s,'"') ? '\'' : '"';
276 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
284 Perl_deprecate(pTHX_ char *s)
287 if (ckWARN(WARN_DEPRECATED))
288 Perl_warner(aTHX_ WARN_DEPRECATED, "Use of %s is deprecated", s);
293 * Deprecate a comma-less variable list.
299 deprecate("comma-less variable list");
303 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
304 * utf16-to-utf8-reversed.
310 S_win32_textfilter(pTHX_ int idx, SV *sv, int maxlen)
312 I32 count = FILTER_READ(idx+1, sv, maxlen);
313 if (count > 0 && !maxlen)
314 win32_strip_return(sv);
320 S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
322 I32 count = FILTER_READ(idx+1, sv, maxlen);
326 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
327 tend = utf16_to_utf8((U16*)SvPVX(sv), tmps, SvCUR(sv));
328 sv_usepvn(sv, (char*)tmps, tend - tmps);
335 S_utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
337 I32 count = FILTER_READ(idx+1, sv, maxlen);
341 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
342 tend = utf16_to_utf8_reversed((U16*)SvPVX(sv), tmps, SvCUR(sv));
343 sv_usepvn(sv, (char*)tmps, tend - tmps);
351 * Initialize variables. Uses the Perl save_stack to save its state (for
352 * recursive calls to the parser).
356 Perl_lex_start(pTHX_ SV *line)
362 SAVEI32(PL_lex_dojoin);
363 SAVEI32(PL_lex_brackets);
364 SAVEI32(PL_lex_casemods);
365 SAVEI32(PL_lex_starts);
366 SAVEI32(PL_lex_state);
367 SAVEVPTR(PL_lex_inpat);
368 SAVEI32(PL_lex_inwhat);
369 SAVECOPLINE(PL_curcop);
372 SAVEPPTR(PL_oldbufptr);
373 SAVEPPTR(PL_oldoldbufptr);
374 SAVEPPTR(PL_linestart);
375 SAVESPTR(PL_linestr);
376 SAVEPPTR(PL_lex_brackstack);
377 SAVEPPTR(PL_lex_casestack);
378 SAVEDESTRUCTOR_X(restore_rsfp, PL_rsfp);
379 SAVESPTR(PL_lex_stuff);
380 SAVEI32(PL_lex_defer);
381 SAVEI32(PL_sublex_info.sub_inwhat);
382 SAVESPTR(PL_lex_repl);
384 SAVEINT(PL_lex_expect);
386 PL_lex_state = LEX_NORMAL;
390 New(899, PL_lex_brackstack, 120, char);
391 New(899, PL_lex_casestack, 12, char);
392 SAVEFREEPV(PL_lex_brackstack);
393 SAVEFREEPV(PL_lex_casestack);
395 *PL_lex_casestack = '\0';
398 PL_lex_stuff = Nullsv;
399 PL_lex_repl = Nullsv;
402 PL_sublex_info.sub_inwhat = 0;
404 if (SvREADONLY(PL_linestr))
405 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
406 s = SvPV(PL_linestr, len);
407 if (len && s[len-1] != ';') {
408 if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
409 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
410 sv_catpvn(PL_linestr, "\n;", 2);
412 SvTEMP_off(PL_linestr);
413 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
414 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
416 PL_rs = newSVpvn("\n", 1);
422 * Finalizer for lexing operations. Must be called when the parser is
423 * done with the lexer.
429 PL_doextract = FALSE;
434 * This subroutine has nothing to do with tilting, whether at windmills
435 * or pinball tables. Its name is short for "increment line". It
436 * increments the current line number in CopLINE(PL_curcop) and checks
437 * to see whether the line starts with a comment of the form
438 * # line 500 "foo.pm"
439 * If so, it sets the current line number and file to the values in the comment.
443 S_incline(pTHX_ char *s)
451 CopLINE_inc(PL_curcop);
454 while (*s == ' ' || *s == '\t') s++;
455 if (strnEQ(s, "line ", 5)) {
464 while (*s == ' ' || *s == '\t')
466 if (*s == '"' && (t = strchr(s+1, '"')))
470 return; /* false alarm */
471 for (t = s; !isSPACE(*t); t++) ;
476 CopFILE_set(PL_curcop, s);
478 CopFILE_set(PL_curcop, PL_origfilename);
480 CopLINE_set(PL_curcop, atoi(n)-1);
485 * Called to gobble the appropriate amount and type of whitespace.
486 * Skips comments as well.
490 S_skipspace(pTHX_ register char *s)
493 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
494 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
500 SSize_t oldprevlen, oldoldprevlen;
501 SSize_t oldloplen, oldunilen;
502 while (s < PL_bufend && isSPACE(*s)) {
503 if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
508 if (s < PL_bufend && *s == '#') {
509 while (s < PL_bufend && *s != '\n')
513 if (PL_in_eval && !PL_rsfp) {
520 /* only continue to recharge the buffer if we're at the end
521 * of the buffer, we're not reading from a source filter, and
522 * we're in normal lexing mode
524 if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat ||
525 PL_lex_state == LEX_FORMLINE)
528 /* try to recharge the buffer */
529 if ((s = filter_gets(PL_linestr, PL_rsfp,
530 (prevlen = SvCUR(PL_linestr)))) == Nullch)
532 /* end of file. Add on the -p or -n magic */
533 if (PL_minus_n || PL_minus_p) {
534 sv_setpv(PL_linestr,PL_minus_p ?
535 ";}continue{print or die qq(-p destination: $!\\n)" :
537 sv_catpv(PL_linestr,";}");
538 PL_minus_n = PL_minus_p = 0;
541 sv_setpv(PL_linestr,";");
543 /* reset variables for next time we lex */
544 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
546 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
548 /* Close the filehandle. Could be from -P preprocessor,
549 * STDIN, or a regular file. If we were reading code from
550 * STDIN (because the commandline held no -e or filename)
551 * then we don't close it, we reset it so the code can
552 * read from STDIN too.
555 if (PL_preprocess && !PL_in_eval)
556 (void)PerlProc_pclose(PL_rsfp);
557 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
558 PerlIO_clearerr(PL_rsfp);
560 (void)PerlIO_close(PL_rsfp);
565 /* not at end of file, so we only read another line */
566 /* make corresponding updates to old pointers, for yyerror() */
567 oldprevlen = PL_oldbufptr - PL_bufend;
568 oldoldprevlen = PL_oldoldbufptr - PL_bufend;
570 oldunilen = PL_last_uni - PL_bufend;
572 oldloplen = PL_last_lop - PL_bufend;
573 PL_linestart = PL_bufptr = s + prevlen;
574 PL_bufend = s + SvCUR(PL_linestr);
576 PL_oldbufptr = s + oldprevlen;
577 PL_oldoldbufptr = s + oldoldprevlen;
579 PL_last_uni = s + oldunilen;
581 PL_last_lop = s + oldloplen;
584 /* debugger active and we're not compiling the debugger code,
585 * so store the line into the debugger's array of lines
587 if (PERLDB_LINE && PL_curstash != PL_debstash) {
588 SV *sv = NEWSV(85,0);
590 sv_upgrade(sv, SVt_PVMG);
591 sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
592 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
599 * Check the unary operators to ensure there's no ambiguity in how they're
600 * used. An ambiguous piece of code would be:
602 * This doesn't mean rand() + 5. Because rand() is a unary operator,
603 * the +5 is its argument.
613 if (PL_oldoldbufptr != PL_last_uni)
615 while (isSPACE(*PL_last_uni))
617 for (s = PL_last_uni; isALNUM_lazy(s) || *s == '-'; s++) ;
618 if ((t = strchr(s, '(')) && t < PL_bufptr)
620 if (ckWARN_d(WARN_AMBIGUOUS)){
623 Perl_warner(aTHX_ WARN_AMBIGUOUS,
624 "Warning: Use of \"%s\" without parens is ambiguous",
630 /* workaround to replace the UNI() macro with a function. Only the
631 * hints/uts.sh file mentions this. Other comments elsewhere in the
632 * source indicate Microport Unix might need it too.
638 #define UNI(f) return uni(f,s)
641 S_uni(pTHX_ I32 f, char *s)
646 PL_last_uni = PL_oldbufptr;
657 #endif /* CRIPPLED_CC */
660 * LOP : macro to build a list operator. Its behaviour has been replaced
661 * with a subroutine, S_lop() for which LOP is just another name.
664 #define LOP(f,x) return lop(f,x,s)
668 * Build a list operator (or something that might be one). The rules:
669 * - if we have a next token, then it's a list operator [why?]
670 * - if the next thing is an opening paren, then it's a function
671 * - else it's a list operator
675 S_lop(pTHX_ I32 f, expectation x, char *s)
682 PL_last_lop = PL_oldbufptr;
697 * When the lexer realizes it knows the next token (for instance,
698 * it is reordering tokens for the parser) then it can call S_force_next
699 * to know what token to return the next time the lexer is called. Caller
700 * will need to set PL_nextval[], and possibly PL_expect to ensure the lexer
701 * handles the token correctly.
705 S_force_next(pTHX_ I32 type)
707 PL_nexttype[PL_nexttoke] = type;
709 if (PL_lex_state != LEX_KNOWNEXT) {
710 PL_lex_defer = PL_lex_state;
711 PL_lex_expect = PL_expect;
712 PL_lex_state = LEX_KNOWNEXT;
718 * When the lexer knows the next thing is a word (for instance, it has
719 * just seen -> and it knows that the next char is a word char, then
720 * it calls S_force_word to stick the next word into the PL_next lookahead.
723 * char *start : buffer position (must be within PL_linestr)
724 * int token : PL_next will be this type of bare word (e.g., METHOD,WORD)
725 * int check_keyword : if true, Perl checks to make sure the word isn't
726 * a keyword (do this if the word is a label, e.g. goto FOO)
727 * int allow_pack : if true, : characters will also be allowed (require,
729 * int allow_initial_tick : used by the "sub" lexer only.
733 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
738 start = skipspace(start);
740 if (isIDFIRST_lazy(s) ||
741 (allow_pack && *s == ':') ||
742 (allow_initial_tick && *s == '\'') )
744 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
745 if (check_keyword && keyword(PL_tokenbuf, len))
747 if (token == METHOD) {
752 PL_expect = XOPERATOR;
755 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(PL_tokenbuf,0));
756 PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
764 * Called when the lexer wants $foo *foo &foo etc, but the program
765 * text only contains the "foo" portion. The first argument is a pointer
766 * to the "foo", and the second argument is the type symbol to prefix.
767 * Forces the next token to be a "WORD".
768 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
772 S_force_ident(pTHX_ register char *s, int kind)
775 OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
776 PL_nextval[PL_nexttoke].opval = o;
779 dTHR; /* just for in_eval */
780 o->op_private = OPpCONST_ENTERED;
781 /* XXX see note in pp_entereval() for why we forgo typo
782 warnings if the symbol must be introduced in an eval.
784 gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
785 kind == '$' ? SVt_PV :
786 kind == '@' ? SVt_PVAV :
787 kind == '%' ? SVt_PVHV :
796 * Forces the next token to be a version number.
800 S_force_version(pTHX_ char *s)
802 OP *version = Nullop;
806 /* default VERSION number -- GBARR */
811 for( d=s, c = 1; isDIGIT(*d) || *d == '_' || (*d == '.' && c--); d++);
812 if((*d == ';' || isSPACE(*d)) && *(skipspace(d)) != ',') {
814 /* real VERSION number -- GBARR */
815 version = yylval.opval;
819 /* NOTE: The parser sees the package name and the VERSION swapped */
820 PL_nextval[PL_nexttoke].opval = version;
828 * Tokenize a quoted string passed in as an SV. It finds the next
829 * chunk, up to end of string or a backslash. It may make a new
830 * SV containing that chunk (if HINT_NEW_STRING is on). It also
835 S_tokeq(pTHX_ SV *sv)
846 s = SvPV_force(sv, len);
850 while (s < send && *s != '\\')
855 if ( PL_hints & HINT_NEW_STRING )
856 pv = sv_2mortal(newSVpvn(SvPVX(pv), len));
859 if (s + 1 < send && (s[1] == '\\'))
860 s++; /* all that, just for this */
865 SvCUR_set(sv, d - SvPVX(sv));
867 if ( PL_hints & HINT_NEW_STRING )
868 return new_constant(NULL, 0, "q", sv, pv, "q");
873 * Now come three functions related to double-quote context,
874 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
875 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
876 * interact with PL_lex_state, and create fake ( ... ) argument lists
877 * to handle functions and concatenation.
878 * They assume that whoever calls them will be setting up a fake
879 * join call, because each subthing puts a ',' after it. This lets
882 * join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
884 * (I'm not sure whether the spurious commas at the end of lcfirst's
885 * arguments and join's arguments are created or not).
890 * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST).
892 * Pattern matching will set PL_lex_op to the pattern-matching op to
893 * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise).
895 * OP_CONST and OP_READLINE are easy--just make the new op and return.
897 * Everything else becomes a FUNC.
899 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
900 * had an OP_CONST or OP_READLINE). This just sets us up for a
901 * call to S_sublex_push().
907 register I32 op_type = yylval.ival;
909 if (op_type == OP_NULL) {
910 yylval.opval = PL_lex_op;
914 if (op_type == OP_CONST || op_type == OP_READLINE) {
915 SV *sv = tokeq(PL_lex_stuff);
917 if (SvTYPE(sv) == SVt_PVIV) {
918 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
924 nsv = newSVpvn(p, len);
928 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
929 PL_lex_stuff = Nullsv;
933 PL_sublex_info.super_state = PL_lex_state;
934 PL_sublex_info.sub_inwhat = op_type;
935 PL_sublex_info.sub_op = PL_lex_op;
936 PL_lex_state = LEX_INTERPPUSH;
940 yylval.opval = PL_lex_op;
950 * Create a new scope to save the lexing state. The scope will be
951 * ended in S_sublex_done. Returns a '(', starting the function arguments
952 * to the uc, lc, etc. found before.
953 * Sets PL_lex_state to LEX_INTERPCONCAT.
962 PL_lex_state = PL_sublex_info.super_state;
963 SAVEI32(PL_lex_dojoin);
964 SAVEI32(PL_lex_brackets);
965 SAVEI32(PL_lex_casemods);
966 SAVEI32(PL_lex_starts);
967 SAVEI32(PL_lex_state);
968 SAVEVPTR(PL_lex_inpat);
969 SAVEI32(PL_lex_inwhat);
970 SAVECOPLINE(PL_curcop);
972 SAVEPPTR(PL_oldbufptr);
973 SAVEPPTR(PL_oldoldbufptr);
974 SAVEPPTR(PL_linestart);
975 SAVESPTR(PL_linestr);
976 SAVEPPTR(PL_lex_brackstack);
977 SAVEPPTR(PL_lex_casestack);
979 PL_linestr = PL_lex_stuff;
980 PL_lex_stuff = Nullsv;
982 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
984 PL_bufend += SvCUR(PL_linestr);
985 SAVEFREESV(PL_linestr);
987 PL_lex_dojoin = FALSE;
989 New(899, PL_lex_brackstack, 120, char);
990 New(899, PL_lex_casestack, 12, char);
991 SAVEFREEPV(PL_lex_brackstack);
992 SAVEFREEPV(PL_lex_casestack);
994 *PL_lex_casestack = '\0';
996 PL_lex_state = LEX_INTERPCONCAT;
997 CopLINE_set(PL_curcop, PL_multi_start);
999 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1000 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1001 PL_lex_inpat = PL_sublex_info.sub_op;
1003 PL_lex_inpat = Nullop;
1010 * Restores lexer state after a S_sublex_push.
1016 if (!PL_lex_starts++) {
1017 PL_expect = XOPERATOR;
1018 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpvn("",0));
1022 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
1023 PL_lex_state = LEX_INTERPCASEMOD;
1027 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1028 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1029 PL_linestr = PL_lex_repl;
1031 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1032 PL_bufend += SvCUR(PL_linestr);
1033 SAVEFREESV(PL_linestr);
1034 PL_lex_dojoin = FALSE;
1035 PL_lex_brackets = 0;
1036 PL_lex_casemods = 0;
1037 *PL_lex_casestack = '\0';
1039 if (SvEVALED(PL_lex_repl)) {
1040 PL_lex_state = LEX_INTERPNORMAL;
1042 /* we don't clear PL_lex_repl here, so that we can check later
1043 whether this is an evalled subst; that means we rely on the
1044 logic to ensure sublex_done() is called again only via the
1045 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1048 PL_lex_state = LEX_INTERPCONCAT;
1049 PL_lex_repl = Nullsv;
1055 PL_bufend = SvPVX(PL_linestr);
1056 PL_bufend += SvCUR(PL_linestr);
1057 PL_expect = XOPERATOR;
1058 PL_sublex_info.sub_inwhat = 0;
1066 Extracts a pattern, double-quoted string, or transliteration. This
1069 It looks at lex_inwhat and PL_lex_inpat to find out whether it's
1070 processing a pattern (PL_lex_inpat is true), a transliteration
1071 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
1073 Returns a pointer to the character scanned up to. Iff this is
1074 advanced from the start pointer supplied (ie if anything was
1075 successfully parsed), will leave an OP for the substring scanned
1076 in yylval. Caller must intuit reason for not parsing further
1077 by looking at the next characters herself.
1081 double-quoted style: \r and \n
1082 regexp special ones: \D \s
1084 backrefs: \1 (deprecated in substitution replacements)
1085 case and quoting: \U \Q \E
1086 stops on @ and $, but not for $ as tail anchor
1088 In transliterations:
1089 characters are VERY literal, except for - not at the start or end
1090 of the string, which indicates a range. scan_const expands the
1091 range to the full set of intermediate characters.
1093 In double-quoted strings:
1095 double-quoted style: \r and \n
1097 backrefs: \1 (deprecated)
1098 case and quoting: \U \Q \E
1101 scan_const does *not* construct ops to handle interpolated strings.
1102 It stops processing as soon as it finds an embedded $ or @ variable
1103 and leaves it to the caller to work out what's going on.
1105 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
1107 $ in pattern could be $foo or could be tail anchor. Assumption:
1108 it's a tail anchor if $ is the last thing in the string, or if it's
1109 followed by one of ")| \n\t"
1111 \1 (backreferences) are turned into $1
1113 The structure of the code is
1114 while (there's a character to process) {
1115 handle transliteration ranges
1116 skip regexp comments
1117 skip # initiated comments in //x patterns
1118 check for embedded @foo
1119 check for embedded scalars
1121 leave intact backslashes from leave (below)
1122 deprecate \1 in strings and sub replacements
1123 handle string-changing backslashes \l \U \Q \E, etc.
1124 switch (what was escaped) {
1125 handle - in a transliteration (becomes a literal -)
1126 handle \132 octal characters
1127 handle 0x15 hex characters
1128 handle \cV (control V)
1129 handle printf backslashes (\f, \r, \n, etc)
1131 } (end if backslash)
1132 } (end while character to read)
1137 S_scan_const(pTHX_ char *start)
1139 register char *send = PL_bufend; /* end of the constant */
1140 SV *sv = NEWSV(93, send - start); /* sv for the constant */
1141 register char *s = start; /* start of the constant */
1142 register char *d = SvPVX(sv); /* destination for copies */
1143 bool dorange = FALSE; /* are we in a translit range? */
1145 I32 utf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op)
1146 ? (PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
1148 I32 thisutf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op)
1149 ? (PL_sublex_info.sub_op->op_private & (PL_lex_repl ?
1150 OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF))
1152 const char *leaveit = /* set of acceptably-backslashed characters */
1154 ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
1157 while (s < send || dorange) {
1158 /* get transliterations out of the way (they're most literal) */
1159 if (PL_lex_inwhat == OP_TRANS) {
1160 /* expand a range A-Z to the full set of characters. AIE! */
1162 I32 i; /* current expanded character */
1163 I32 min; /* first character in range */
1164 I32 max; /* last character in range */
1166 i = d - SvPVX(sv); /* remember current offset */
1167 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
1168 d = SvPVX(sv) + i; /* refresh d after realloc */
1169 d -= 2; /* eat the first char and the - */
1171 min = (U8)*d; /* first char in range */
1172 max = (U8)d[1]; /* last char in range */
1175 if ((isLOWER(min) && isLOWER(max)) ||
1176 (isUPPER(min) && isUPPER(max))) {
1178 for (i = min; i <= max; i++)
1182 for (i = min; i <= max; i++)
1189 for (i = min; i <= max; i++)
1192 /* mark the range as done, and continue */
1197 /* range begins (ignore - as first or last char) */
1198 else if (*s == '-' && s+1 < send && s != start) {
1200 *d++ = (char)0xff; /* use illegal utf8 byte--see pmtrans */
1209 /* if we get here, we're not doing a transliteration */
1211 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
1212 except for the last char, which will be done separately. */
1213 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
1215 while (s < send && *s != ')')
1217 } else if (s[2] == '{'
1218 || s[2] == 'p' && s[3] == '{') { /* This should march regcomp.c */
1220 char *regparse = s + (s[2] == '{' ? 3 : 4);
1223 while (count && (c = *regparse)) {
1224 if (c == '\\' && regparse[1])
1232 if (*regparse != ')') {
1233 regparse--; /* Leave one char for continuation. */
1234 yyerror("Sequence (?{...}) not terminated or not {}-balanced");
1236 while (s < regparse)
1241 /* likewise skip #-initiated comments in //x patterns */
1242 else if (*s == '#' && PL_lex_inpat &&
1243 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
1244 while (s+1 < send && *s != '\n')
1248 /* check for embedded arrays (@foo, @:foo, @'foo, @{foo}, @$foo) */
1249 else if (*s == '@' && s[1] && (isALNUM_lazy(s+1) || strchr(":'{$", s[1])))
1252 /* check for embedded scalars. only stop if we're sure it's a
1255 else if (*s == '$') {
1256 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
1258 if (s + 1 < send && !strchr("()| \n\t", s[1]))
1259 break; /* in regexp, $ might be tail anchor */
1262 /* (now in tr/// code again) */
1264 if (*s & 0x80 && thisutf) {
1265 dTHR; /* only for ckWARN */
1266 if (ckWARN(WARN_UTF8)) {
1267 (void)utf8_to_uv((U8*)s, &len); /* could cvt latin-1 to utf8 here... */
1277 if (*s == '\\' && s+1 < send) {
1280 /* some backslashes we leave behind */
1281 if (*leaveit && *s && strchr(leaveit, *s)) {
1287 /* deprecate \1 in strings and substitution replacements */
1288 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1289 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1291 dTHR; /* only for ckWARN */
1292 if (ckWARN(WARN_SYNTAX))
1293 Perl_warner(aTHX_ WARN_SYNTAX, "\\%c better written as $%c", *s, *s);
1298 /* string-change backslash escapes */
1299 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1304 /* if we get here, it's either a quoted -, or a digit */
1307 /* quoted - in transliterations */
1309 if (PL_lex_inwhat == OP_TRANS) {
1317 if (ckWARN(WARN_UNSAFE) && isALPHA(*s))
1318 Perl_warner(aTHX_ WARN_UNSAFE,
1319 "Unrecognized escape \\%c passed through",
1321 /* default action is to copy the quoted character */
1326 /* \132 indicates an octal constant */
1327 case '0': case '1': case '2': case '3':
1328 case '4': case '5': case '6': case '7':
1329 *d++ = (char)scan_oct(s, 3, &len);
1333 /* \x24 indicates a hex constant */
1337 char* e = strchr(s, '}');
1340 yyerror("Missing right brace on \\x{}");
1345 if (ckWARN(WARN_UTF8))
1346 Perl_warner(aTHX_ WARN_UTF8,
1347 "Use of \\x{} without utf8 declaration");
1349 /* note: utf always shorter than hex */
1350 d = (char*)uv_to_utf8((U8*)d,
1351 (UV)scan_hex(s + 1, e - s - 1, &len));
1355 UV uv = (UV)scan_hex(s, 2, &len);
1356 if (utf && PL_lex_inwhat == OP_TRANS &&
1357 utf != (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
1359 d = (char*)uv_to_utf8((U8*)d, uv); /* doing a CU or UC */
1362 if (uv >= 127 && UTF) {
1364 if (ckWARN(WARN_UTF8))
1365 Perl_warner(aTHX_ WARN_UTF8,
1366 "\\x%.*s will produce malformed UTF-8 character; use \\x{%.*s} for that",
1375 /* \N{latin small letter a} is a named character */
1379 char* e = strchr(s, '}');
1388 yyerror("Missing right brace on \\N{}");
1392 res = newSVpvn(s + 1, e - s - 1);
1393 res = new_constant( Nullch, 0, "charnames",
1394 res, Nullsv, "\\N{...}" );
1395 str = SvPV(res,len);
1396 if (len > e - s + 4) {
1397 char *odest = SvPVX(sv);
1399 SvGROW(sv, (SvCUR(sv) + len - (e - s + 4)));
1400 d = SvPVX(sv) + (d - odest);
1402 Copy(str, d, len, char);
1409 yyerror("Missing braces on \\N{}");
1412 /* \c is a control character */
1426 /* printf-style backslashes, formfeeds, newlines, etc */
1444 *d++ = '\047'; /* CP 1047 */
1447 *d++ = '\057'; /* CP 1047 */
1461 } /* end if (backslash) */
1464 } /* while loop to process each character */
1466 /* terminate the string and set up the sv */
1468 SvCUR_set(sv, d - SvPVX(sv));
1471 /* shrink the sv if we allocated more than we used */
1472 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1473 SvLEN_set(sv, SvCUR(sv) + 1);
1474 Renew(SvPVX(sv), SvLEN(sv), char);
1477 /* return the substring (via yylval) only if we parsed anything */
1478 if (s > PL_bufptr) {
1479 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1480 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1482 ( PL_lex_inwhat == OP_TRANS
1484 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1487 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1494 * Returns TRUE if there's more to the expression (e.g., a subscript),
1497 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
1499 * ->[ and ->{ return TRUE
1500 * { and [ outside a pattern are always subscripts, so return TRUE
1501 * if we're outside a pattern and it's not { or [, then return FALSE
1502 * if we're in a pattern and the first char is a {
1503 * {4,5} (any digits around the comma) returns FALSE
1504 * if we're in a pattern and the first char is a [
1506 * [SOMETHING] has a funky algorithm to decide whether it's a
1507 * character class or not. It has to deal with things like
1508 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
1509 * anything else returns TRUE
1512 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1515 S_intuit_more(pTHX_ register char *s)
1517 if (PL_lex_brackets)
1519 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1521 if (*s != '{' && *s != '[')
1526 /* In a pattern, so maybe we have {n,m}. */
1543 /* On the other hand, maybe we have a character class */
1546 if (*s == ']' || *s == '^')
1549 /* this is terrifying, and it works */
1550 int weight = 2; /* let's weigh the evidence */
1552 unsigned char un_char = 255, last_un_char;
1553 char *send = strchr(s,']');
1554 char tmpbuf[sizeof PL_tokenbuf * 4];
1556 if (!send) /* has to be an expression */
1559 Zero(seen,256,char);
1562 else if (isDIGIT(*s)) {
1564 if (isDIGIT(s[1]) && s[2] == ']')
1570 for (; s < send; s++) {
1571 last_un_char = un_char;
1572 un_char = (unsigned char)*s;
1577 weight -= seen[un_char] * 10;
1578 if (isALNUM_lazy(s+1)) {
1579 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1580 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1585 else if (*s == '$' && s[1] &&
1586 strchr("[#!%*<>()-=",s[1])) {
1587 if (/*{*/ strchr("])} =",s[2]))
1596 if (strchr("wds]",s[1]))
1598 else if (seen['\''] || seen['"'])
1600 else if (strchr("rnftbxcav",s[1]))
1602 else if (isDIGIT(s[1])) {
1604 while (s[1] && isDIGIT(s[1]))
1614 if (strchr("aA01! ",last_un_char))
1616 if (strchr("zZ79~",s[1]))
1618 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1619 weight -= 5; /* cope with negative subscript */
1622 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1623 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1628 if (keyword(tmpbuf, d - tmpbuf))
1631 if (un_char == last_un_char + 1)
1633 weight -= seen[un_char];
1638 if (weight >= 0) /* probably a character class */
1648 * Does all the checking to disambiguate
1650 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
1651 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
1653 * First argument is the stuff after the first token, e.g. "bar".
1655 * Not a method if bar is a filehandle.
1656 * Not a method if foo is a subroutine prototyped to take a filehandle.
1657 * Not a method if it's really "Foo $bar"
1658 * Method if it's "foo $bar"
1659 * Not a method if it's really "print foo $bar"
1660 * Method if it's really "foo package::" (interpreted as package->foo)
1661 * Not a method if bar is known to be a subroutne ("sub bar; foo bar")
1662 * Not a method if bar is a filehandle or package, but is quotd with
1667 S_intuit_method(pTHX_ char *start, GV *gv)
1669 char *s = start + (*start == '$');
1670 char tmpbuf[sizeof PL_tokenbuf];
1678 if ((cv = GvCVu(gv))) {
1679 char *proto = SvPVX(cv);
1689 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1690 /* start is the beginning of the possible filehandle/object,
1691 * and s is the end of it
1692 * tmpbuf is a copy of it
1695 if (*start == '$') {
1696 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1701 return *s == '(' ? FUNCMETH : METHOD;
1703 if (!keyword(tmpbuf, len)) {
1704 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1709 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1710 if (indirgv && GvCVu(indirgv))
1712 /* filehandle or package name makes it a method */
1713 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1715 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1716 return 0; /* no assumptions -- "=>" quotes bearword */
1718 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1719 newSVpvn(tmpbuf,len));
1720 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1724 return *s == '(' ? FUNCMETH : METHOD;
1732 * Return a string of Perl code to load the debugger. If PERL5DB
1733 * is set, it will return the contents of that, otherwise a
1734 * compile-time require of perl5db.pl.
1741 char *pdb = PerlEnv_getenv("PERL5DB");
1745 SETERRNO(0,SS$_NORMAL);
1746 return "BEGIN { require 'perl5db.pl' }";
1752 /* Encoded script support. filter_add() effectively inserts a
1753 * 'pre-processing' function into the current source input stream.
1754 * Note that the filter function only applies to the current source file
1755 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1757 * The datasv parameter (which may be NULL) can be used to pass
1758 * private data to this instance of the filter. The filter function
1759 * can recover the SV using the FILTER_DATA macro and use it to
1760 * store private buffers and state information.
1762 * The supplied datasv parameter is upgraded to a PVIO type
1763 * and the IoDIRP field is used to store the function pointer,
1764 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
1765 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1766 * private use must be set using malloc'd pointers.
1770 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
1775 if (!PL_rsfp_filters)
1776 PL_rsfp_filters = newAV();
1778 datasv = NEWSV(255,0);
1779 if (!SvUPGRADE(datasv, SVt_PVIO))
1780 Perl_die(aTHX_ "Can't upgrade filter_add data to SVt_PVIO");
1781 IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
1782 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
1783 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
1784 funcp, SvPV_nolen(datasv)));
1785 av_unshift(PL_rsfp_filters, 1);
1786 av_store(PL_rsfp_filters, 0, datasv) ;
1791 /* Delete most recently added instance of this filter function. */
1793 Perl_filter_del(pTHX_ filter_t funcp)
1796 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", funcp));
1797 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
1799 /* if filter is on top of stack (usual case) just pop it off */
1800 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
1801 if (IoDIRP(datasv) == (DIR*)funcp) {
1802 IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
1803 IoDIRP(datasv) = (DIR*)NULL;
1804 sv_free(av_pop(PL_rsfp_filters));
1808 /* we need to search for the correct entry and clear it */
1809 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
1813 /* Invoke the n'th filter function for the current rsfp. */
1815 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
1818 /* 0 = read one text line */
1823 if (!PL_rsfp_filters)
1825 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
1826 /* Provide a default input filter to make life easy. */
1827 /* Note that we append to the line. This is handy. */
1828 DEBUG_P(PerlIO_printf(Perl_debug_log,
1829 "filter_read %d: from rsfp\n", idx));
1833 int old_len = SvCUR(buf_sv) ;
1835 /* ensure buf_sv is large enough */
1836 SvGROW(buf_sv, old_len + maxlen) ;
1837 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1838 if (PerlIO_error(PL_rsfp))
1839 return -1; /* error */
1841 return 0 ; /* end of file */
1843 SvCUR_set(buf_sv, old_len + len) ;
1846 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
1847 if (PerlIO_error(PL_rsfp))
1848 return -1; /* error */
1850 return 0 ; /* end of file */
1853 return SvCUR(buf_sv);
1855 /* Skip this filter slot if filter has been deleted */
1856 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
1857 DEBUG_P(PerlIO_printf(Perl_debug_log,
1858 "filter_read %d: skipped (filter deleted)\n",
1860 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1862 /* Get function pointer hidden within datasv */
1863 funcp = (filter_t)IoDIRP(datasv);
1864 DEBUG_P(PerlIO_printf(Perl_debug_log,
1865 "filter_read %d: via function %p (%s)\n",
1866 idx, funcp, SvPV_nolen(datasv)));
1867 /* Call function. The function is expected to */
1868 /* call "FILTER_READ(idx+1, buf_sv)" first. */
1869 /* Return: <0:error, =0:eof, >0:not eof */
1870 return (*funcp)(aTHXo_ idx, buf_sv, maxlen);
1874 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
1877 if (!PL_rsfp_filters) {
1878 filter_add(win32_textfilter,NULL);
1881 if (PL_rsfp_filters) {
1884 SvCUR_set(sv, 0); /* start with empty line */
1885 if (FILTER_READ(0, sv, 0) > 0)
1886 return ( SvPVX(sv) ) ;
1891 return (sv_gets(sv, fp, append));
1896 static char* exp_name[] =
1897 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
1898 "ATTRTERM", "TERMBLOCK"
1905 Works out what to call the token just pulled out of the input
1906 stream. The yacc parser takes care of taking the ops we return and
1907 stitching them into a tree.
1913 if read an identifier
1914 if we're in a my declaration
1915 croak if they tried to say my($foo::bar)
1916 build the ops for a my() declaration
1917 if it's an access to a my() variable
1918 are we in a sort block?
1919 croak if my($a); $a <=> $b
1920 build ops for access to a my() variable
1921 if in a dq string, and they've said @foo and we can't find @foo
1923 build ops for a bareword
1924 if we already built the token before, use it.
1928 #ifdef USE_PURE_BISON
1929 Perl_yylex(pTHX_ YYSTYPE *lvalp, int *lcharp)
1942 #ifdef USE_PURE_BISON
1943 yylval_pointer = lvalp;
1944 yychar_pointer = lcharp;
1947 /* check if there's an identifier for us to look at */
1948 if (PL_pending_ident) {
1949 /* pit holds the identifier we read and pending_ident is reset */
1950 char pit = PL_pending_ident;
1951 PL_pending_ident = 0;
1953 /* if we're in a my(), we can't allow dynamics here.
1954 $foo'bar has already been turned into $foo::bar, so
1955 just check for colons.
1957 if it's a legal name, the OP is a PADANY.
1960 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
1961 tmp = pad_allocmy(PL_tokenbuf);
1964 if (strchr(PL_tokenbuf,':'))
1965 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
1967 yylval.opval = newOP(OP_PADANY, 0);
1968 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
1974 build the ops for accesses to a my() variable.
1976 Deny my($a) or my($b) in a sort block, *if* $a or $b is
1977 then used in a comparison. This catches most, but not
1978 all cases. For instance, it catches
1979 sort { my($a); $a <=> $b }
1981 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
1982 (although why you'd do that is anyone's guess).
1985 if (!strchr(PL_tokenbuf,':')) {
1987 /* Check for single character per-thread SVs */
1988 if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
1989 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
1990 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
1992 yylval.opval = newOP(OP_THREADSV, 0);
1993 yylval.opval->op_targ = tmp;
1996 #endif /* USE_THREADS */
1997 if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
1998 /* might be an "our" variable" */
1999 if (SvFLAGS(AvARRAY(PL_comppad_name)[tmp]) & SVpad_OUR) {
2000 /* build ops for a bareword */
2001 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
2002 yylval.opval->op_private = OPpCONST_ENTERED;
2003 gv_fetchpv(PL_tokenbuf+1,
2005 ? (GV_ADDMULTI | GV_ADDINEVAL | GV_ADDOUR)
2008 ((PL_tokenbuf[0] == '$') ? SVt_PV
2009 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
2014 /* if it's a sort block and they're naming $a or $b */
2015 if (PL_last_lop_op == OP_SORT &&
2016 PL_tokenbuf[0] == '$' &&
2017 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
2020 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
2021 d < PL_bufend && *d != '\n';
2024 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
2025 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
2031 yylval.opval = newOP(OP_PADANY, 0);
2032 yylval.opval->op_targ = tmp;
2038 Whine if they've said @foo in a doublequoted string,
2039 and @foo isn't a variable we can find in the symbol
2042 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
2043 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
2044 if (!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
2045 yyerror(Perl_form(aTHX_ "In string, %s now must be written as \\%s",
2046 PL_tokenbuf, PL_tokenbuf));
2049 /* build ops for a bareword */
2050 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
2051 yylval.opval->op_private = OPpCONST_ENTERED;
2052 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
2053 ((PL_tokenbuf[0] == '$') ? SVt_PV
2054 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
2059 /* no identifier pending identification */
2061 switch (PL_lex_state) {
2063 case LEX_NORMAL: /* Some compilers will produce faster */
2064 case LEX_INTERPNORMAL: /* code if we comment these out. */
2068 /* when we've already built the next token, just pull it out of the queue */
2071 yylval = PL_nextval[PL_nexttoke];
2073 PL_lex_state = PL_lex_defer;
2074 PL_expect = PL_lex_expect;
2075 PL_lex_defer = LEX_NORMAL;
2077 return(PL_nexttype[PL_nexttoke]);
2079 /* interpolated case modifiers like \L \U, including \Q and \E.
2080 when we get here, PL_bufptr is at the \
2082 case LEX_INTERPCASEMOD:
2084 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
2085 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
2087 /* handle \E or end of string */
2088 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
2092 if (PL_lex_casemods) {
2093 oldmod = PL_lex_casestack[--PL_lex_casemods];
2094 PL_lex_casestack[PL_lex_casemods] = '\0';
2096 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
2098 PL_lex_state = LEX_INTERPCONCAT;
2102 if (PL_bufptr != PL_bufend)
2104 PL_lex_state = LEX_INTERPCONCAT;
2109 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
2110 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
2111 if (strchr("LU", *s) &&
2112 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
2114 PL_lex_casestack[--PL_lex_casemods] = '\0';
2117 if (PL_lex_casemods > 10) {
2118 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
2119 if (newlb != PL_lex_casestack) {
2121 PL_lex_casestack = newlb;
2124 PL_lex_casestack[PL_lex_casemods++] = *s;
2125 PL_lex_casestack[PL_lex_casemods] = '\0';
2126 PL_lex_state = LEX_INTERPCONCAT;
2127 PL_nextval[PL_nexttoke].ival = 0;
2130 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
2132 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
2134 PL_nextval[PL_nexttoke].ival = OP_LC;
2136 PL_nextval[PL_nexttoke].ival = OP_UC;
2138 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
2140 Perl_croak(aTHX_ "panic: yylex");
2143 if (PL_lex_starts) {
2152 case LEX_INTERPPUSH:
2153 return sublex_push();
2155 case LEX_INTERPSTART:
2156 if (PL_bufptr == PL_bufend)
2157 return sublex_done();
2159 PL_lex_dojoin = (*PL_bufptr == '@');
2160 PL_lex_state = LEX_INTERPNORMAL;
2161 if (PL_lex_dojoin) {
2162 PL_nextval[PL_nexttoke].ival = 0;
2165 PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
2166 PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
2167 force_next(PRIVATEREF);
2169 force_ident("\"", '$');
2170 #endif /* USE_THREADS */
2171 PL_nextval[PL_nexttoke].ival = 0;
2173 PL_nextval[PL_nexttoke].ival = 0;
2175 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
2178 if (PL_lex_starts++) {
2184 case LEX_INTERPENDMAYBE:
2185 if (intuit_more(PL_bufptr)) {
2186 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
2192 if (PL_lex_dojoin) {
2193 PL_lex_dojoin = FALSE;
2194 PL_lex_state = LEX_INTERPCONCAT;
2197 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
2198 && SvEVALED(PL_lex_repl))
2200 if (PL_bufptr != PL_bufend)
2201 Perl_croak(aTHX_ "Bad evalled substitution pattern");
2202 PL_lex_repl = Nullsv;
2205 case LEX_INTERPCONCAT:
2207 if (PL_lex_brackets)
2208 Perl_croak(aTHX_ "panic: INTERPCONCAT");
2210 if (PL_bufptr == PL_bufend)
2211 return sublex_done();
2213 if (SvIVX(PL_linestr) == '\'') {
2214 SV *sv = newSVsv(PL_linestr);
2217 else if ( PL_hints & HINT_NEW_RE )
2218 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
2219 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2223 s = scan_const(PL_bufptr);
2225 PL_lex_state = LEX_INTERPCASEMOD;
2227 PL_lex_state = LEX_INTERPSTART;
2230 if (s != PL_bufptr) {
2231 PL_nextval[PL_nexttoke] = yylval;
2234 if (PL_lex_starts++)
2244 PL_lex_state = LEX_NORMAL;
2245 s = scan_formline(PL_bufptr);
2246 if (!PL_lex_formbrack)
2252 PL_oldoldbufptr = PL_oldbufptr;
2255 PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at %s\n",
2256 exp_name[PL_expect], s);
2262 if (isIDFIRST_lazy(s))
2264 Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
2267 goto fake_eof; /* emulate EOF on ^D or ^Z */
2272 if (PL_lex_brackets)
2273 yyerror("Missing right curly or square bracket");
2276 if (s++ < PL_bufend)
2277 goto retry; /* ignore stray nulls */
2280 if (!PL_in_eval && !PL_preambled) {
2281 PL_preambled = TRUE;
2282 sv_setpv(PL_linestr,incl_perldb());
2283 if (SvCUR(PL_linestr))
2284 sv_catpv(PL_linestr,";");
2286 while(AvFILLp(PL_preambleav) >= 0) {
2287 SV *tmpsv = av_shift(PL_preambleav);
2288 sv_catsv(PL_linestr, tmpsv);
2289 sv_catpv(PL_linestr, ";");
2292 sv_free((SV*)PL_preambleav);
2293 PL_preambleav = NULL;
2295 if (PL_minus_n || PL_minus_p) {
2296 sv_catpv(PL_linestr, "LINE: while (<>) {");
2298 sv_catpv(PL_linestr,"chomp;");
2300 GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
2302 GvIMPORTED_AV_on(gv);
2304 if (strchr("/'\"", *PL_splitstr)
2305 && strchr(PL_splitstr + 1, *PL_splitstr))
2306 Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s);", PL_splitstr);
2309 s = "'~#\200\1'"; /* surely one char is unused...*/
2310 while (s[1] && strchr(PL_splitstr, *s)) s++;
2312 Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s%c",
2313 "q" + (delim == '\''), delim);
2314 for (s = PL_splitstr; *s; s++) {
2316 sv_catpvn(PL_linestr, "\\", 1);
2317 sv_catpvn(PL_linestr, s, 1);
2319 Perl_sv_catpvf(aTHX_ PL_linestr, "%c);", delim);
2323 sv_catpv(PL_linestr,"@F=split(' ');");
2326 sv_catpv(PL_linestr, "\n");
2327 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2328 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2329 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2330 SV *sv = NEWSV(85,0);
2332 sv_upgrade(sv, SVt_PVMG);
2333 sv_setsv(sv,PL_linestr);
2334 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2339 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
2342 if (PL_preprocess && !PL_in_eval)
2343 (void)PerlProc_pclose(PL_rsfp);
2344 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2345 PerlIO_clearerr(PL_rsfp);
2347 (void)PerlIO_close(PL_rsfp);
2349 PL_doextract = FALSE;
2351 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2352 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
2353 sv_catpv(PL_linestr,";}");
2354 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2355 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2356 PL_minus_n = PL_minus_p = 0;
2359 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2360 sv_setpv(PL_linestr,"");
2361 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
2364 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
2365 PL_doextract = FALSE;
2367 /* Incest with pod. */
2368 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2369 sv_setpv(PL_linestr, "");
2370 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2371 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2372 PL_doextract = FALSE;
2376 } while (PL_doextract);
2377 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2378 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2379 SV *sv = NEWSV(85,0);
2381 sv_upgrade(sv, SVt_PVMG);
2382 sv_setsv(sv,PL_linestr);
2383 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2385 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2386 if (CopLINE(PL_curcop) == 1) {
2387 while (s < PL_bufend && isSPACE(*s))
2389 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2393 if (*s == '#' && *(s+1) == '!')
2395 #ifdef ALTERNATE_SHEBANG
2397 static char as[] = ALTERNATE_SHEBANG;
2398 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2399 d = s + (sizeof(as) - 1);
2401 #endif /* ALTERNATE_SHEBANG */
2410 while (*d && !isSPACE(*d))
2414 #ifdef ARG_ZERO_IS_SCRIPT
2415 if (ipathend > ipath) {
2417 * HP-UX (at least) sets argv[0] to the script name,
2418 * which makes $^X incorrect. And Digital UNIX and Linux,
2419 * at least, set argv[0] to the basename of the Perl
2420 * interpreter. So, having found "#!", we'll set it right.
2422 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
2423 assert(SvPOK(x) || SvGMAGICAL(x));
2424 if (sv_eq(x, CopFILESV(PL_curcop))) {
2425 sv_setpvn(x, ipath, ipathend - ipath);
2428 TAINT_NOT; /* $^X is always tainted, but that's OK */
2430 #endif /* ARG_ZERO_IS_SCRIPT */
2435 d = instr(s,"perl -");
2437 d = instr(s,"perl");
2439 /* avoid getting into infinite loops when shebang
2440 * line contains "Perl" rather than "perl" */
2442 for (d = ipathend-4; d >= ipath; --d) {
2443 if ((*d == 'p' || *d == 'P')
2444 && !ibcmp(d, "perl", 4))
2454 #ifdef ALTERNATE_SHEBANG
2456 * If the ALTERNATE_SHEBANG on this system starts with a
2457 * character that can be part of a Perl expression, then if
2458 * we see it but not "perl", we're probably looking at the
2459 * start of Perl code, not a request to hand off to some
2460 * other interpreter. Similarly, if "perl" is there, but
2461 * not in the first 'word' of the line, we assume the line
2462 * contains the start of the Perl program.
2464 if (d && *s != '#') {
2466 while (*c && !strchr("; \t\r\n\f\v#", *c))
2469 d = Nullch; /* "perl" not in first word; ignore */
2471 *s = '#'; /* Don't try to parse shebang line */
2473 #endif /* ALTERNATE_SHEBANG */
2478 !instr(s,"indir") &&
2479 instr(PL_origargv[0],"perl"))
2485 while (s < PL_bufend && isSPACE(*s))
2487 if (s < PL_bufend) {
2488 Newz(899,newargv,PL_origargc+3,char*);
2490 while (s < PL_bufend && !isSPACE(*s))
2493 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2496 newargv = PL_origargv;
2498 PerlProc_execv(ipath, newargv);
2499 Perl_croak(aTHX_ "Can't exec %s", ipath);
2502 U32 oldpdb = PL_perldb;
2503 bool oldn = PL_minus_n;
2504 bool oldp = PL_minus_p;
2506 while (*d && !isSPACE(*d)) d++;
2507 while (*d == ' ' || *d == '\t') d++;
2511 if (*d == 'M' || *d == 'm') {
2513 while (*d && !isSPACE(*d)) d++;
2514 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2517 d = moreswitches(d);
2519 if (PERLDB_LINE && !oldpdb ||
2520 ( PL_minus_n || PL_minus_p ) && !(oldn || oldp) )
2521 /* if we have already added "LINE: while (<>) {",
2522 we must not do it again */
2524 sv_setpv(PL_linestr, "");
2525 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2526 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2527 PL_preambled = FALSE;
2529 (void)gv_fetchfile(PL_origfilename);
2536 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2538 PL_lex_state = LEX_FORMLINE;
2543 #ifdef PERL_STRICT_CR
2544 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2546 "(Maybe you didn't strip carriage returns after a network transfer?)\n");
2548 case ' ': case '\t': case '\f': case 013:
2553 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2555 while (s < d && *s != '\n')
2560 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2562 PL_lex_state = LEX_FORMLINE;
2572 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2577 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2580 if (strnEQ(s,"=>",2)) {
2581 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2582 OPERATOR('-'); /* unary minus */
2584 PL_last_uni = PL_oldbufptr;
2585 PL_last_lop_op = OP_FTEREAD; /* good enough */
2587 case 'r': FTST(OP_FTEREAD);
2588 case 'w': FTST(OP_FTEWRITE);
2589 case 'x': FTST(OP_FTEEXEC);
2590 case 'o': FTST(OP_FTEOWNED);
2591 case 'R': FTST(OP_FTRREAD);
2592 case 'W': FTST(OP_FTRWRITE);
2593 case 'X': FTST(OP_FTREXEC);
2594 case 'O': FTST(OP_FTROWNED);
2595 case 'e': FTST(OP_FTIS);
2596 case 'z': FTST(OP_FTZERO);
2597 case 's': FTST(OP_FTSIZE);
2598 case 'f': FTST(OP_FTFILE);
2599 case 'd': FTST(OP_FTDIR);
2600 case 'l': FTST(OP_FTLINK);
2601 case 'p': FTST(OP_FTPIPE);
2602 case 'S': FTST(OP_FTSOCK);
2603 case 'u': FTST(OP_FTSUID);
2604 case 'g': FTST(OP_FTSGID);
2605 case 'k': FTST(OP_FTSVTX);
2606 case 'b': FTST(OP_FTBLK);
2607 case 'c': FTST(OP_FTCHR);
2608 case 't': FTST(OP_FTTTY);
2609 case 'T': FTST(OP_FTTEXT);
2610 case 'B': FTST(OP_FTBINARY);
2611 case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2612 case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2613 case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
2615 Perl_croak(aTHX_ "Unrecognized file test: -%c", (int)tmp);
2622 if (PL_expect == XOPERATOR)
2627 else if (*s == '>') {
2630 if (isIDFIRST_lazy(s)) {
2631 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2639 if (PL_expect == XOPERATOR)
2642 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2644 OPERATOR('-'); /* unary minus */
2651 if (PL_expect == XOPERATOR)
2656 if (PL_expect == XOPERATOR)
2659 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2665 if (PL_expect != XOPERATOR) {
2666 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2667 PL_expect = XOPERATOR;
2668 force_ident(PL_tokenbuf, '*');
2681 if (PL_expect == XOPERATOR) {
2685 PL_tokenbuf[0] = '%';
2686 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2687 if (!PL_tokenbuf[1]) {
2689 yyerror("Final % should be \\% or %name");
2692 PL_pending_ident = '%';
2711 switch (PL_expect) {
2714 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
2716 PL_bufptr = s; /* update in case we back off */
2722 PL_expect = XTERMBLOCK;
2726 while (isIDFIRST_lazy(s)) {
2727 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2729 d = scan_str(d,TRUE,TRUE);
2732 SvREFCNT_dec(PL_lex_stuff);
2733 PL_lex_stuff = Nullsv;
2735 /* MUST advance bufptr here to avoid bogus
2736 "at end of line" context messages from yyerror().
2738 PL_bufptr = s + len;
2739 yyerror("Unterminated attribute parameter in attribute list");
2742 return 0; /* EOF indicator */
2746 SV *sv = newSVpvn(s, len);
2747 sv_catsv(sv, PL_lex_stuff);
2748 attrs = append_elem(OP_LIST, attrs,
2749 newSVOP(OP_CONST, 0, sv));
2750 SvREFCNT_dec(PL_lex_stuff);
2751 PL_lex_stuff = Nullsv;
2754 attrs = append_elem(OP_LIST, attrs,
2755 newSVOP(OP_CONST, 0,
2762 tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}' for vi */
2763 if (*s != ';' && *s != tmp) {
2764 char q = ((*s == '\'') ? '"' : '\'');
2765 /* If here for an expression, and parsed no attrs, back off. */
2766 if (tmp == '=' && !attrs) {
2770 /* MUST advance bufptr here to avoid bogus "at end of line"
2771 context messages from yyerror().
2775 yyerror("Unterminated attribute list");
2777 yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list",
2784 PL_nextval[PL_nexttoke].opval = attrs;
2792 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
2793 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
2798 if (CopLINE(PL_curcop) < PL_copline)
2799 PL_copline = CopLINE(PL_curcop);
2810 if (PL_lex_brackets <= 0)
2811 yyerror("Unmatched right square bracket");
2814 if (PL_lex_state == LEX_INTERPNORMAL) {
2815 if (PL_lex_brackets == 0) {
2816 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
2817 PL_lex_state = LEX_INTERPEND;
2824 if (PL_lex_brackets > 100) {
2825 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
2826 if (newlb != PL_lex_brackstack) {
2828 PL_lex_brackstack = newlb;
2831 switch (PL_expect) {
2833 if (PL_lex_formbrack) {
2837 if (PL_oldoldbufptr == PL_last_lop)
2838 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2840 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2841 OPERATOR(HASHBRACK);
2843 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2846 PL_tokenbuf[0] = '\0';
2847 if (d < PL_bufend && *d == '-') {
2848 PL_tokenbuf[0] = '-';
2850 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2853 if (d < PL_bufend && isIDFIRST_lazy(d)) {
2854 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2856 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2859 char minus = (PL_tokenbuf[0] == '-');
2860 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2868 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
2873 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2878 if (PL_oldoldbufptr == PL_last_lop)
2879 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2881 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2884 OPERATOR(HASHBRACK);
2885 /* This hack serves to disambiguate a pair of curlies
2886 * as being a block or an anon hash. Normally, expectation
2887 * determines that, but in cases where we're not in a
2888 * position to expect anything in particular (like inside
2889 * eval"") we have to resolve the ambiguity. This code
2890 * covers the case where the first term in the curlies is a
2891 * quoted string. Most other cases need to be explicitly
2892 * disambiguated by prepending a `+' before the opening
2893 * curly in order to force resolution as an anon hash.
2895 * XXX should probably propagate the outer expectation
2896 * into eval"" to rely less on this hack, but that could
2897 * potentially break current behavior of eval"".
2901 if (*s == '\'' || *s == '"' || *s == '`') {
2902 /* common case: get past first string, handling escapes */
2903 for (t++; t < PL_bufend && *t != *s;)
2904 if (*t++ == '\\' && (*t == '\\' || *t == *s))
2908 else if (*s == 'q') {
2911 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
2912 && !isALNUM(*t)))) {
2914 char open, close, term;
2917 while (t < PL_bufend && isSPACE(*t))
2921 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
2925 for (t++; t < PL_bufend; t++) {
2926 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
2928 else if (*t == open)
2932 for (t++; t < PL_bufend; t++) {
2933 if (*t == '\\' && t+1 < PL_bufend)
2935 else if (*t == close && --brackets <= 0)
2937 else if (*t == open)
2943 else if (isIDFIRST_lazy(s)) {
2944 for (t++; t < PL_bufend && isALNUM_lazy(t); t++) ;
2946 while (t < PL_bufend && isSPACE(*t))
2948 /* if comma follows first term, call it an anon hash */
2949 /* XXX it could be a comma expression with loop modifiers */
2950 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
2951 || (*t == '=' && t[1] == '>')))
2952 OPERATOR(HASHBRACK);
2953 if (PL_expect == XREF)
2956 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
2962 yylval.ival = CopLINE(PL_curcop);
2963 if (isSPACE(*s) || *s == '#')
2964 PL_copline = NOLINE; /* invalidate current command line number */
2969 if (PL_lex_brackets <= 0)
2970 yyerror("Unmatched right curly bracket");
2972 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
2973 if (PL_lex_brackets < PL_lex_formbrack)
2974 PL_lex_formbrack = 0;
2975 if (PL_lex_state == LEX_INTERPNORMAL) {
2976 if (PL_lex_brackets == 0) {
2977 if (PL_expect & XFAKEBRACK) {
2978 PL_expect &= XENUMMASK;
2979 PL_lex_state = LEX_INTERPEND;
2981 return yylex(); /* ignore fake brackets */
2983 if (*s == '-' && s[1] == '>')
2984 PL_lex_state = LEX_INTERPENDMAYBE;
2985 else if (*s != '[' && *s != '{')
2986 PL_lex_state = LEX_INTERPEND;
2989 if (PL_expect & XFAKEBRACK) {
2990 PL_expect &= XENUMMASK;
2992 return yylex(); /* ignore fake brackets */
3002 if (PL_expect == XOPERATOR) {
3003 if (ckWARN(WARN_SEMICOLON) && isIDFIRST_lazy(s) && PL_bufptr == PL_linestart) {
3004 CopLINE_dec(PL_curcop);
3005 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3006 CopLINE_inc(PL_curcop);
3011 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3013 PL_expect = XOPERATOR;
3014 force_ident(PL_tokenbuf, '&');
3018 yylval.ival = (OPpENTERSUB_AMPER<<8);
3037 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
3038 Perl_warner(aTHX_ WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
3040 if (PL_expect == XSTATE && isALPHA(tmp) &&
3041 (s == PL_linestart+1 || s[-2] == '\n') )
3043 if (PL_in_eval && !PL_rsfp) {
3048 if (strnEQ(s,"=cut",4)) {
3062 PL_doextract = TRUE;
3065 if (PL_lex_brackets < PL_lex_formbrack) {
3067 #ifdef PERL_STRICT_CR
3068 for (t = s; *t == ' ' || *t == '\t'; t++) ;
3070 for (t = s; *t == ' ' || *t == '\t' || *t == '\r'; t++) ;
3072 if (*t == '\n' || *t == '#') {
3090 if (PL_expect != XOPERATOR) {
3091 if (s[1] != '<' && !strchr(s,'>'))
3094 s = scan_heredoc(s);
3096 s = scan_inputsymbol(s);
3097 TERM(sublex_start());
3102 SHop(OP_LEFT_SHIFT);
3116 SHop(OP_RIGHT_SHIFT);
3125 if (PL_expect == XOPERATOR) {
3126 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3129 return ','; /* grandfather non-comma-format format */
3133 if (s[1] == '#' && (isIDFIRST_lazy(s+2) || strchr("{$:+-", s[2]))) {
3134 PL_tokenbuf[0] = '@';
3135 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3136 sizeof PL_tokenbuf - 1, FALSE);
3137 if (PL_expect == XOPERATOR)
3138 no_op("Array length", s);
3139 if (!PL_tokenbuf[1])
3141 PL_expect = XOPERATOR;
3142 PL_pending_ident = '#';
3146 PL_tokenbuf[0] = '$';
3147 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3148 sizeof PL_tokenbuf - 1, FALSE);
3149 if (PL_expect == XOPERATOR)
3151 if (!PL_tokenbuf[1]) {
3153 yyerror("Final $ should be \\$ or $name");
3157 /* This kludge not intended to be bulletproof. */
3158 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
3159 yylval.opval = newSVOP(OP_CONST, 0,
3160 newSViv((IV)PL_compiling.cop_arybase));
3161 yylval.opval->op_private = OPpCONST_ARYBASE;
3167 if (PL_lex_state == LEX_NORMAL)
3170 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3173 PL_tokenbuf[0] = '@';
3174 if (ckWARN(WARN_SYNTAX)) {
3176 isSPACE(*t) || isALNUM_lazy(t) || *t == '$';
3179 PL_bufptr = skipspace(PL_bufptr);
3180 while (t < PL_bufend && *t != ']')
3182 Perl_warner(aTHX_ WARN_SYNTAX,
3183 "Multidimensional syntax %.*s not supported",
3184 (t - PL_bufptr) + 1, PL_bufptr);
3188 else if (*s == '{') {
3189 PL_tokenbuf[0] = '%';
3190 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
3191 (t = strchr(s, '}')) && (t = strchr(t, '=')))
3193 char tmpbuf[sizeof PL_tokenbuf];
3195 for (t++; isSPACE(*t); t++) ;
3196 if (isIDFIRST_lazy(t)) {
3197 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
3198 for (; isSPACE(*t); t++) ;
3199 if (*t == ';' && get_cv(tmpbuf, FALSE))
3200 Perl_warner(aTHX_ WARN_SYNTAX,
3201 "You need to quote \"%s\"", tmpbuf);
3207 PL_expect = XOPERATOR;
3208 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3209 bool islop = (PL_last_lop == PL_oldoldbufptr);
3210 if (!islop || PL_last_lop_op == OP_GREPSTART)
3211 PL_expect = XOPERATOR;
3212 else if (strchr("$@\"'`q", *s))
3213 PL_expect = XTERM; /* e.g. print $fh "foo" */
3214 else if (strchr("&*<%", *s) && isIDFIRST_lazy(s+1))
3215 PL_expect = XTERM; /* e.g. print $fh &sub */
3216 else if (isIDFIRST_lazy(s)) {
3217 char tmpbuf[sizeof PL_tokenbuf];
3218 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3219 if (tmp = keyword(tmpbuf, len)) {
3220 /* binary operators exclude handle interpretations */
3232 PL_expect = XTERM; /* e.g. print $fh length() */
3237 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
3238 if (gv && GvCVu(gv))
3239 PL_expect = XTERM; /* e.g. print $fh subr() */
3242 else if (isDIGIT(*s))
3243 PL_expect = XTERM; /* e.g. print $fh 3 */
3244 else if (*s == '.' && isDIGIT(s[1]))
3245 PL_expect = XTERM; /* e.g. print $fh .3 */
3246 else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
3247 PL_expect = XTERM; /* e.g. print $fh -1 */
3248 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3249 PL_expect = XTERM; /* print $fh <<"EOF" */
3251 PL_pending_ident = '$';
3255 if (PL_expect == XOPERATOR)
3257 PL_tokenbuf[0] = '@';
3258 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3259 if (!PL_tokenbuf[1]) {
3261 yyerror("Final @ should be \\@ or @name");
3264 if (PL_lex_state == LEX_NORMAL)
3266 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3268 PL_tokenbuf[0] = '%';
3270 /* Warn about @ where they meant $. */
3271 if (ckWARN(WARN_SYNTAX)) {
3272 if (*s == '[' || *s == '{') {
3274 while (*t && (isALNUM_lazy(t) || strchr(" \t$#+-'\"", *t)))
3276 if (*t == '}' || *t == ']') {
3278 PL_bufptr = skipspace(PL_bufptr);
3279 Perl_warner(aTHX_ WARN_SYNTAX,
3280 "Scalar value %.*s better written as $%.*s",
3281 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
3286 PL_pending_ident = '@';
3289 case '/': /* may either be division or pattern */
3290 case '?': /* may either be conditional or pattern */
3291 if (PL_expect != XOPERATOR) {
3292 /* Disable warning on "study /blah/" */
3293 if (PL_oldoldbufptr == PL_last_uni
3294 && (*PL_last_uni != 's' || s - PL_last_uni < 5
3295 || memNE(PL_last_uni, "study", 5) || isALNUM_lazy(PL_last_uni+5)))
3297 s = scan_pat(s,OP_MATCH);
3298 TERM(sublex_start());
3306 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3307 #ifdef PERL_STRICT_CR
3310 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3312 && (s == PL_linestart || s[-1] == '\n') )
3314 PL_lex_formbrack = 0;
3318 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
3324 yylval.ival = OPf_SPECIAL;
3330 if (PL_expect != XOPERATOR)
3335 case '0': case '1': case '2': case '3': case '4':
3336 case '5': case '6': case '7': case '8': case '9':
3338 if (PL_expect == XOPERATOR)
3343 s = scan_str(s,FALSE,FALSE);
3344 if (PL_expect == XOPERATOR) {
3345 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3348 return ','; /* grandfather non-comma-format format */
3354 missingterm((char*)0);
3355 yylval.ival = OP_CONST;
3356 TERM(sublex_start());
3359 s = scan_str(s,FALSE,FALSE);
3360 if (PL_expect == XOPERATOR) {
3361 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3364 return ','; /* grandfather non-comma-format format */
3370 missingterm((char*)0);
3371 yylval.ival = OP_CONST;
3372 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
3373 if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
3374 yylval.ival = OP_STRINGIFY;
3378 TERM(sublex_start());
3381 s = scan_str(s,FALSE,FALSE);
3382 if (PL_expect == XOPERATOR)
3383 no_op("Backticks",s);
3385 missingterm((char*)0);
3386 yylval.ival = OP_BACKTICK;
3388 TERM(sublex_start());
3392 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
3393 Perl_warner(aTHX_ WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
3395 if (PL_expect == XOPERATOR)
3396 no_op("Backslash",s);
3400 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
3440 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3442 /* Some keywords can be followed by any delimiter, including ':' */
3443 tmp = (len == 1 && strchr("msyq", PL_tokenbuf[0]) ||
3444 len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
3445 (PL_tokenbuf[0] == 'q' &&
3446 strchr("qwxr", PL_tokenbuf[1]))));
3448 /* x::* is just a word, unless x is "CORE" */
3449 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
3453 while (d < PL_bufend && isSPACE(*d))
3454 d++; /* no comments skipped here, or s### is misparsed */
3456 /* Is this a label? */
3457 if (!tmp && PL_expect == XSTATE
3458 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
3460 yylval.pval = savepv(PL_tokenbuf);
3465 /* Check for keywords */
3466 tmp = keyword(PL_tokenbuf, len);
3468 /* Is this a word before a => operator? */
3469 if (strnEQ(d,"=>",2)) {
3471 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
3472 yylval.opval->op_private = OPpCONST_BARE;
3476 if (tmp < 0) { /* second-class keyword? */
3477 GV *ogv = Nullgv; /* override (winner) */
3478 GV *hgv = Nullgv; /* hidden (loser) */
3479 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3481 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3484 if (GvIMPORTED_CV(gv))
3486 else if (! CvMETHOD(cv))
3490 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3491 (gv = *gvp) != (GV*)&PL_sv_undef &&
3492 GvCVu(gv) && GvIMPORTED_CV(gv))
3498 tmp = 0; /* overridden by import or by GLOBAL */
3501 && -tmp==KEY_lock /* XXX generalizable kludge */
3503 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3505 tmp = 0; /* any sub overrides "weak" keyword */
3507 else { /* no override */
3511 if (ckWARN(WARN_AMBIGUOUS) && hgv
3512 && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3513 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3514 "Ambiguous call resolved as CORE::%s(), %s",
3515 GvENAME(hgv), "qualify as such or use &");
3522 default: /* not a keyword */
3525 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3527 /* Get the rest if it looks like a package qualifier */
3529 if (*s == '\'' || *s == ':' && s[1] == ':') {
3531 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3534 Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
3535 *s == '\'' ? "'" : "::");
3539 if (PL_expect == XOPERATOR) {
3540 if (PL_bufptr == PL_linestart) {
3541 CopLINE_dec(PL_curcop);
3542 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3543 CopLINE_inc(PL_curcop);
3546 no_op("Bareword",s);
3549 /* Look for a subroutine with this name in current package,
3550 unless name is "Foo::", in which case Foo is a bearword
3551 (and a package name). */
3554 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3556 if (ckWARN(WARN_UNSAFE) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3557 Perl_warner(aTHX_ WARN_UNSAFE,
3558 "Bareword \"%s\" refers to nonexistent package",
3561 PL_tokenbuf[len] = '\0';
3568 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3571 /* if we saw a global override before, get the right name */
3574 sv = newSVpvn("CORE::GLOBAL::",14);
3575 sv_catpv(sv,PL_tokenbuf);
3578 sv = newSVpv(PL_tokenbuf,0);
3580 /* Presume this is going to be a bareword of some sort. */
3583 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3584 yylval.opval->op_private = OPpCONST_BARE;
3586 /* And if "Foo::", then that's what it certainly is. */
3591 /* See if it's the indirect object for a list operator. */
3593 if (PL_oldoldbufptr &&
3594 PL_oldoldbufptr < PL_bufptr &&
3595 (PL_oldoldbufptr == PL_last_lop
3596 || PL_oldoldbufptr == PL_last_uni) &&
3597 /* NO SKIPSPACE BEFORE HERE! */
3598 (PL_expect == XREF ||
3599 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
3601 bool immediate_paren = *s == '(';
3603 /* (Now we can afford to cross potential line boundary.) */
3606 /* Two barewords in a row may indicate method call. */
3608 if ((isIDFIRST_lazy(s) || *s == '$') && (tmp=intuit_method(s,gv)))
3611 /* If not a declared subroutine, it's an indirect object. */
3612 /* (But it's an indir obj regardless for sort.) */
3614 if ((PL_last_lop_op == OP_SORT ||
3615 (!immediate_paren && (!gv || !GvCVu(gv)))) &&
3616 (PL_last_lop_op != OP_MAPSTART &&
3617 PL_last_lop_op != OP_GREPSTART))
3619 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3624 /* If followed by a paren, it's certainly a subroutine. */
3626 PL_expect = XOPERATOR;
3630 if (gv && GvCVu(gv)) {
3631 for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
3632 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
3637 PL_nextval[PL_nexttoke].opval = yylval.opval;
3638 PL_expect = XOPERATOR;
3644 /* If followed by var or block, call it a method (unless sub) */
3646 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3647 PL_last_lop = PL_oldbufptr;
3648 PL_last_lop_op = OP_METHOD;
3652 /* If followed by a bareword, see if it looks like indir obj. */
3654 if ((isIDFIRST_lazy(s) || *s == '$') && (tmp = intuit_method(s,gv)))
3657 /* Not a method, so call it a subroutine (if defined) */
3659 if (gv && GvCVu(gv)) {
3661 if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
3662 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3663 "Ambiguous use of -%s resolved as -&%s()",
3664 PL_tokenbuf, PL_tokenbuf);
3665 /* Check for a constant sub */
3667 if ((sv = cv_const_sv(cv))) {
3669 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3670 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3671 yylval.opval->op_private = 0;
3675 /* Resolve to GV now. */
3676 op_free(yylval.opval);
3677 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3678 yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
3679 PL_last_lop = PL_oldbufptr;
3680 PL_last_lop_op = OP_ENTERSUB;
3681 /* Is there a prototype? */
3684 char *proto = SvPV((SV*)cv, len);
3687 if (strEQ(proto, "$"))
3689 if (*proto == '&' && *s == '{') {
3690 sv_setpv(PL_subname,"__ANON__");
3694 PL_nextval[PL_nexttoke].opval = yylval.opval;
3700 /* Call it a bare word */
3702 if (PL_hints & HINT_STRICT_SUBS)
3703 yylval.opval->op_private |= OPpCONST_STRICT;
3706 if (ckWARN(WARN_RESERVED)) {
3707 if (lastchar != '-') {
3708 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3710 Perl_warner(aTHX_ WARN_RESERVED, PL_warn_reserved,
3717 if (lastchar && strchr("*%&", lastchar) && ckWARN_d(WARN_AMBIGUOUS)) {
3718 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3719 "Operator or semicolon missing before %c%s",
3720 lastchar, PL_tokenbuf);
3721 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3722 "Ambiguous use of %c resolved as operator %c",
3723 lastchar, lastchar);
3729 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3730 newSVpv(CopFILE(PL_curcop),0));
3734 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3735 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
3738 case KEY___PACKAGE__:
3739 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3741 ? newSVsv(PL_curstname)
3750 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3751 char *pname = "main";
3752 if (PL_tokenbuf[2] == 'D')
3753 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3754 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
3757 GvIOp(gv) = newIO();
3758 IoIFP(GvIOp(gv)) = PL_rsfp;
3759 #if defined(HAS_FCNTL) && defined(F_SETFD)
3761 int fd = PerlIO_fileno(PL_rsfp);
3762 fcntl(fd,F_SETFD,fd >= 3);
3765 /* Mark this internal pseudo-handle as clean */
3766 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3768 IoTYPE(GvIOp(gv)) = '|';
3769 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
3770 IoTYPE(GvIOp(gv)) = '-';
3772 IoTYPE(GvIOp(gv)) = '<';
3784 if (PL_expect == XSTATE) {
3791 if (*s == ':' && s[1] == ':') {
3794 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3795 tmp = keyword(PL_tokenbuf, len);
3809 LOP(OP_ACCEPT,XTERM);
3815 LOP(OP_ATAN2,XTERM);
3824 LOP(OP_BLESS,XTERM);
3833 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
3850 if (!PL_cryptseen) {
3851 PL_cryptseen = TRUE;
3855 LOP(OP_CRYPT,XTERM);
3858 if (ckWARN(WARN_OCTAL)) {
3859 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
3860 if (*d != '0' && isDIGIT(*d))
3861 Perl_warner(aTHX_ WARN_OCTAL,
3862 "chmod: mode argument is missing initial 0");
3864 LOP(OP_CHMOD,XTERM);
3867 LOP(OP_CHOWN,XTERM);
3870 LOP(OP_CONNECT,XTERM);
3886 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3890 PL_hints |= HINT_BLOCK_SCOPE;
3900 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3901 LOP(OP_DBMOPEN,XTERM);
3907 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3914 yylval.ival = CopLINE(PL_curcop);
3928 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
3929 UNIBRACK(OP_ENTEREVAL);
3944 case KEY_endhostent:
3950 case KEY_endservent:
3953 case KEY_endprotoent:
3964 yylval.ival = CopLINE(PL_curcop);
3966 if (PL_expect == XSTATE && isIDFIRST_lazy(s)) {
3968 if ((PL_bufend - p) >= 3 &&
3969 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3971 else if ((PL_bufend - p) >= 4 &&
3972 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
3975 if (isIDFIRST_lazy(p)) {
3976 p = scan_ident(p, PL_bufend,
3977 PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3981 Perl_croak(aTHX_ "Missing $ on loop variable");
3986 LOP(OP_FORMLINE,XTERM);
3992 LOP(OP_FCNTL,XTERM);
3998 LOP(OP_FLOCK,XTERM);
4007 LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
4010 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4025 case KEY_getpriority:
4026 LOP(OP_GETPRIORITY,XTERM);
4028 case KEY_getprotobyname:
4031 case KEY_getprotobynumber:
4032 LOP(OP_GPBYNUMBER,XTERM);
4034 case KEY_getprotoent:
4046 case KEY_getpeername:
4047 UNI(OP_GETPEERNAME);
4049 case KEY_gethostbyname:
4052 case KEY_gethostbyaddr:
4053 LOP(OP_GHBYADDR,XTERM);
4055 case KEY_gethostent:
4058 case KEY_getnetbyname:
4061 case KEY_getnetbyaddr:
4062 LOP(OP_GNBYADDR,XTERM);
4067 case KEY_getservbyname:
4068 LOP(OP_GSBYNAME,XTERM);
4070 case KEY_getservbyport:
4071 LOP(OP_GSBYPORT,XTERM);
4073 case KEY_getservent:
4076 case KEY_getsockname:
4077 UNI(OP_GETSOCKNAME);
4079 case KEY_getsockopt:
4080 LOP(OP_GSOCKOPT,XTERM);
4102 yylval.ival = CopLINE(PL_curcop);
4106 LOP(OP_INDEX,XTERM);
4112 LOP(OP_IOCTL,XTERM);
4124 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4156 LOP(OP_LISTEN,XTERM);
4165 s = scan_pat(s,OP_MATCH);
4166 TERM(sublex_start());
4169 LOP(OP_MAPSTART, *s == '(' ? XTERM : XREF);
4172 LOP(OP_MKDIR,XTERM);
4175 LOP(OP_MSGCTL,XTERM);
4178 LOP(OP_MSGGET,XTERM);
4181 LOP(OP_MSGRCV,XTERM);
4184 LOP(OP_MSGSND,XTERM);
4190 if (isIDFIRST_lazy(s)) {
4191 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
4192 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
4194 PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
4195 if (!PL_in_my_stash) {
4198 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
4206 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4213 if (PL_expect != XSTATE)
4214 yyerror("\"no\" not allowed in expression");
4215 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4216 s = force_version(s);
4221 if (*s == '(' || (s = skipspace(s), *s == '('))
4228 if (isIDFIRST_lazy(s)) {
4230 for (d = s; isALNUM_lazy(d); d++) ;
4232 if (strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_AMBIGUOUS))
4233 Perl_warner(aTHX_ WARN_AMBIGUOUS,
4234 "Precedence problem: open %.*s should be open(%.*s)",
4240 yylval.ival = OP_OR;
4250 LOP(OP_OPEN_DIR,XTERM);
4253 checkcomma(s,PL_tokenbuf,"filehandle");
4257 checkcomma(s,PL_tokenbuf,"filehandle");
4276 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4280 LOP(OP_PIPE_OP,XTERM);
4283 s = scan_str(s,FALSE,FALSE);
4285 missingterm((char*)0);
4286 yylval.ival = OP_CONST;
4287 TERM(sublex_start());
4293 s = scan_str(s,FALSE,FALSE);
4295 missingterm((char*)0);
4297 if (SvCUR(PL_lex_stuff)) {
4300 d = SvPV_force(PL_lex_stuff, len);
4302 for (; isSPACE(*d) && len; --len, ++d) ;
4305 if (!warned && ckWARN(WARN_SYNTAX)) {
4306 for (; !isSPACE(*d) && len; --len, ++d) {
4308 Perl_warner(aTHX_ WARN_SYNTAX,
4309 "Possible attempt to separate words with commas");
4312 else if (*d == '#') {
4313 Perl_warner(aTHX_ WARN_SYNTAX,
4314 "Possible attempt to put comments in qw() list");
4320 for (; !isSPACE(*d) && len; --len, ++d) ;
4322 words = append_elem(OP_LIST, words,
4323 newSVOP(OP_CONST, 0, newSVpvn(b, d-b)));
4327 PL_nextval[PL_nexttoke].opval = words;
4332 SvREFCNT_dec(PL_lex_stuff);
4333 PL_lex_stuff = Nullsv;
4338 s = scan_str(s,FALSE,FALSE);
4340 missingterm((char*)0);
4341 yylval.ival = OP_STRINGIFY;
4342 if (SvIVX(PL_lex_stuff) == '\'')
4343 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
4344 TERM(sublex_start());
4347 s = scan_pat(s,OP_QR);
4348 TERM(sublex_start());
4351 s = scan_str(s,FALSE,FALSE);
4353 missingterm((char*)0);
4354 yylval.ival = OP_BACKTICK;
4356 TERM(sublex_start());
4362 *PL_tokenbuf = '\0';
4363 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4364 if (isIDFIRST_lazy(PL_tokenbuf))
4365 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
4367 yyerror("<> should be quotes");
4374 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4378 LOP(OP_RENAME,XTERM);
4387 LOP(OP_RINDEX,XTERM);
4410 LOP(OP_REVERSE,XTERM);
4421 TERM(sublex_start());
4423 TOKEN(1); /* force error */
4432 LOP(OP_SELECT,XTERM);
4438 LOP(OP_SEMCTL,XTERM);
4441 LOP(OP_SEMGET,XTERM);
4444 LOP(OP_SEMOP,XTERM);
4450 LOP(OP_SETPGRP,XTERM);
4452 case KEY_setpriority:
4453 LOP(OP_SETPRIORITY,XTERM);
4455 case KEY_sethostent:
4461 case KEY_setservent:
4464 case KEY_setprotoent:
4474 LOP(OP_SEEKDIR,XTERM);
4476 case KEY_setsockopt:
4477 LOP(OP_SSOCKOPT,XTERM);
4483 LOP(OP_SHMCTL,XTERM);
4486 LOP(OP_SHMGET,XTERM);
4489 LOP(OP_SHMREAD,XTERM);
4492 LOP(OP_SHMWRITE,XTERM);
4495 LOP(OP_SHUTDOWN,XTERM);
4504 LOP(OP_SOCKET,XTERM);
4506 case KEY_socketpair:
4507 LOP(OP_SOCKPAIR,XTERM);
4510 checkcomma(s,PL_tokenbuf,"subroutine name");
4512 if (*s == ';' || *s == ')') /* probably a close */
4513 Perl_croak(aTHX_ "sort is now a reserved word");
4515 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4519 LOP(OP_SPLIT,XTERM);
4522 LOP(OP_SPRINTF,XTERM);
4525 LOP(OP_SPLICE,XTERM);
4540 LOP(OP_SUBSTR,XTERM);
4546 char tmpbuf[sizeof PL_tokenbuf];
4548 expectation attrful;
4549 bool have_name, have_proto;
4554 if (isIDFIRST_lazy(s) || *s == '\'' ||
4555 (*s == ':' && s[1] == ':'))
4558 attrful = XATTRBLOCK;
4559 /* remember buffer pos'n for later force_word */
4560 tboffset = s - PL_oldbufptr;
4561 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4562 if (strchr(tmpbuf, ':'))
4563 sv_setpv(PL_subname, tmpbuf);
4565 sv_setsv(PL_subname,PL_curstname);
4566 sv_catpvn(PL_subname,"::",2);
4567 sv_catpvn(PL_subname,tmpbuf,len);
4574 Perl_croak(aTHX_ "Missing name in \"my sub\"");
4575 PL_expect = XTERMBLOCK;
4576 attrful = XATTRTERM;
4577 sv_setpv(PL_subname,"?");
4581 if (key == KEY_format) {
4583 PL_lex_formbrack = PL_lex_brackets + 1;
4585 (void) force_word(PL_oldbufptr + tboffset, WORD,
4590 /* Look for a prototype */
4594 s = scan_str(s,FALSE,FALSE);
4597 SvREFCNT_dec(PL_lex_stuff);
4598 PL_lex_stuff = Nullsv;
4599 Perl_croak(aTHX_ "Prototype not terminated");
4602 d = SvPVX(PL_lex_stuff);
4604 for (p = d; *p; ++p) {
4609 SvCUR(PL_lex_stuff) = tmp;
4617 if (*s == ':' && s[1] != ':')
4618 PL_expect = attrful;
4621 PL_nextval[PL_nexttoke].opval =
4622 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4623 PL_lex_stuff = Nullsv;
4627 sv_setpv(PL_subname,"__ANON__");
4630 (void) force_word(PL_oldbufptr + tboffset, WORD,
4639 LOP(OP_SYSTEM,XREF);
4642 LOP(OP_SYMLINK,XTERM);
4645 LOP(OP_SYSCALL,XTERM);
4648 LOP(OP_SYSOPEN,XTERM);
4651 LOP(OP_SYSSEEK,XTERM);
4654 LOP(OP_SYSREAD,XTERM);
4657 LOP(OP_SYSWRITE,XTERM);
4661 TERM(sublex_start());
4682 LOP(OP_TRUNCATE,XTERM);
4694 yylval.ival = CopLINE(PL_curcop);
4698 yylval.ival = CopLINE(PL_curcop);
4702 LOP(OP_UNLINK,XTERM);
4708 LOP(OP_UNPACK,XTERM);
4711 LOP(OP_UTIME,XTERM);
4714 if (ckWARN(WARN_OCTAL)) {
4715 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4716 if (*d != '0' && isDIGIT(*d))
4717 Perl_warner(aTHX_ WARN_OCTAL,
4718 "umask: argument is missing initial 0");
4723 LOP(OP_UNSHIFT,XTERM);
4726 if (PL_expect != XSTATE)
4727 yyerror("\"use\" not allowed in expression");
4730 s = force_version(s);
4731 if(*s == ';' || (s = skipspace(s), *s == ';')) {
4732 PL_nextval[PL_nexttoke].opval = Nullop;
4737 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4738 s = force_version(s);
4750 yylval.ival = CopLINE(PL_curcop);
4754 PL_hints |= HINT_BLOCK_SCOPE;
4761 LOP(OP_WAITPID,XTERM);
4769 static char ctl_l[2];
4771 if (ctl_l[0] == '\0')
4772 ctl_l[0] = toCTRL('L');
4773 gv_fetchpv(ctl_l,TRUE, SVt_PV);
4776 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
4781 if (PL_expect == XOPERATOR)
4787 yylval.ival = OP_XOR;
4792 TERM(sublex_start());
4798 Perl_keyword(pTHX_ register char *d, I32 len)
4803 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
4804 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
4805 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
4806 if (strEQ(d,"__DATA__")) return KEY___DATA__;
4807 if (strEQ(d,"__END__")) return KEY___END__;
4811 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
4816 if (strEQ(d,"and")) return -KEY_and;
4817 if (strEQ(d,"abs")) return -KEY_abs;
4820 if (strEQ(d,"alarm")) return -KEY_alarm;
4821 if (strEQ(d,"atan2")) return -KEY_atan2;
4824 if (strEQ(d,"accept")) return -KEY_accept;
4829 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
4832 if (strEQ(d,"bless")) return -KEY_bless;
4833 if (strEQ(d,"bind")) return -KEY_bind;
4834 if (strEQ(d,"binmode")) return -KEY_binmode;
4837 if (strEQ(d,"CORE")) return -KEY_CORE;
4842 if (strEQ(d,"cmp")) return -KEY_cmp;
4843 if (strEQ(d,"chr")) return -KEY_chr;
4844 if (strEQ(d,"cos")) return -KEY_cos;
4847 if (strEQ(d,"chop")) return KEY_chop;
4850 if (strEQ(d,"close")) return -KEY_close;
4851 if (strEQ(d,"chdir")) return -KEY_chdir;
4852 if (strEQ(d,"chomp")) return KEY_chomp;
4853 if (strEQ(d,"chmod")) return -KEY_chmod;
4854 if (strEQ(d,"chown")) return -KEY_chown;
4855 if (strEQ(d,"crypt")) return -KEY_crypt;
4858 if (strEQ(d,"chroot")) return -KEY_chroot;
4859 if (strEQ(d,"caller")) return -KEY_caller;
4862 if (strEQ(d,"connect")) return -KEY_connect;
4865 if (strEQ(d,"closedir")) return -KEY_closedir;
4866 if (strEQ(d,"continue")) return -KEY_continue;
4871 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
4876 if (strEQ(d,"do")) return KEY_do;
4879 if (strEQ(d,"die")) return -KEY_die;
4882 if (strEQ(d,"dump")) return -KEY_dump;
4885 if (strEQ(d,"delete")) return KEY_delete;
4888 if (strEQ(d,"defined")) return KEY_defined;
4889 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
4892 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
4897 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
4898 if (strEQ(d,"END")) return KEY_END;
4903 if (strEQ(d,"eq")) return -KEY_eq;
4906 if (strEQ(d,"eof")) return -KEY_eof;
4907 if (strEQ(d,"exp")) return -KEY_exp;
4910 if (strEQ(d,"else")) return KEY_else;
4911 if (strEQ(d,"exit")) return -KEY_exit;
4912 if (strEQ(d,"eval")) return KEY_eval;
4913 if (strEQ(d,"exec")) return -KEY_exec;
4914 if (strEQ(d,"each")) return KEY_each;
4917 if (strEQ(d,"elsif")) return KEY_elsif;
4920 if (strEQ(d,"exists")) return KEY_exists;
4921 if (strEQ(d,"elseif")) Perl_warn(aTHX_ "elseif should be elsif");
4924 if (strEQ(d,"endgrent")) return -KEY_endgrent;
4925 if (strEQ(d,"endpwent")) return -KEY_endpwent;
4928 if (strEQ(d,"endnetent")) return -KEY_endnetent;
4931 if (strEQ(d,"endhostent")) return -KEY_endhostent;
4932 if (strEQ(d,"endservent")) return -KEY_endservent;
4935 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
4942 if (strEQ(d,"for")) return KEY_for;
4945 if (strEQ(d,"fork")) return -KEY_fork;
4948 if (strEQ(d,"fcntl")) return -KEY_fcntl;
4949 if (strEQ(d,"flock")) return -KEY_flock;
4952 if (strEQ(d,"format")) return KEY_format;
4953 if (strEQ(d,"fileno")) return -KEY_fileno;
4956 if (strEQ(d,"foreach")) return KEY_foreach;
4959 if (strEQ(d,"formline")) return -KEY_formline;
4965 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
4966 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
4970 if (strnEQ(d,"get",3)) {
4975 if (strEQ(d,"ppid")) return -KEY_getppid;
4976 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
4979 if (strEQ(d,"pwent")) return -KEY_getpwent;
4980 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
4981 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
4984 if (strEQ(d,"peername")) return -KEY_getpeername;
4985 if (strEQ(d,"protoent")) return -KEY_getprotoent;
4986 if (strEQ(d,"priority")) return -KEY_getpriority;
4989 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
4992 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
4996 else if (*d == 'h') {
4997 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
4998 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
4999 if (strEQ(d,"hostent")) return -KEY_gethostent;
5001 else if (*d == 'n') {
5002 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
5003 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
5004 if (strEQ(d,"netent")) return -KEY_getnetent;
5006 else if (*d == 's') {
5007 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
5008 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
5009 if (strEQ(d,"servent")) return -KEY_getservent;
5010 if (strEQ(d,"sockname")) return -KEY_getsockname;
5011 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
5013 else if (*d == 'g') {
5014 if (strEQ(d,"grent")) return -KEY_getgrent;
5015 if (strEQ(d,"grnam")) return -KEY_getgrnam;
5016 if (strEQ(d,"grgid")) return -KEY_getgrgid;
5018 else if (*d == 'l') {
5019 if (strEQ(d,"login")) return -KEY_getlogin;
5021 else if (strEQ(d,"c")) return -KEY_getc;
5026 if (strEQ(d,"gt")) return -KEY_gt;
5027 if (strEQ(d,"ge")) return -KEY_ge;
5030 if (strEQ(d,"grep")) return KEY_grep;
5031 if (strEQ(d,"goto")) return KEY_goto;
5032 if (strEQ(d,"glob")) return KEY_glob;
5035 if (strEQ(d,"gmtime")) return -KEY_gmtime;
5040 if (strEQ(d,"hex")) return -KEY_hex;
5043 if (strEQ(d,"INIT")) return KEY_INIT;
5048 if (strEQ(d,"if")) return KEY_if;
5051 if (strEQ(d,"int")) return -KEY_int;
5054 if (strEQ(d,"index")) return -KEY_index;
5055 if (strEQ(d,"ioctl")) return -KEY_ioctl;
5060 if (strEQ(d,"join")) return -KEY_join;
5064 if (strEQ(d,"keys")) return KEY_keys;
5065 if (strEQ(d,"kill")) return -KEY_kill;
5070 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
5071 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
5077 if (strEQ(d,"lt")) return -KEY_lt;
5078 if (strEQ(d,"le")) return -KEY_le;
5079 if (strEQ(d,"lc")) return -KEY_lc;
5082 if (strEQ(d,"log")) return -KEY_log;
5085 if (strEQ(d,"last")) return KEY_last;
5086 if (strEQ(d,"link")) return -KEY_link;
5087 if (strEQ(d,"lock")) return -KEY_lock;
5090 if (strEQ(d,"local")) return KEY_local;
5091 if (strEQ(d,"lstat")) return -KEY_lstat;
5094 if (strEQ(d,"length")) return -KEY_length;
5095 if (strEQ(d,"listen")) return -KEY_listen;
5098 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
5101 if (strEQ(d,"localtime")) return -KEY_localtime;
5107 case 1: return KEY_m;
5109 if (strEQ(d,"my")) return KEY_my;
5112 if (strEQ(d,"map")) return KEY_map;
5115 if (strEQ(d,"mkdir")) return -KEY_mkdir;
5118 if (strEQ(d,"msgctl")) return -KEY_msgctl;
5119 if (strEQ(d,"msgget")) return -KEY_msgget;
5120 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
5121 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
5126 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
5129 if (strEQ(d,"next")) return KEY_next;
5130 if (strEQ(d,"ne")) return -KEY_ne;
5131 if (strEQ(d,"not")) return -KEY_not;
5132 if (strEQ(d,"no")) return KEY_no;
5137 if (strEQ(d,"or")) return -KEY_or;
5140 if (strEQ(d,"ord")) return -KEY_ord;
5141 if (strEQ(d,"oct")) return -KEY_oct;
5142 if (strEQ(d,"our")) return KEY_our;
5145 if (strEQ(d,"open")) return -KEY_open;
5148 if (strEQ(d,"opendir")) return -KEY_opendir;
5155 if (strEQ(d,"pop")) return KEY_pop;
5156 if (strEQ(d,"pos")) return KEY_pos;
5159 if (strEQ(d,"push")) return KEY_push;
5160 if (strEQ(d,"pack")) return -KEY_pack;
5161 if (strEQ(d,"pipe")) return -KEY_pipe;
5164 if (strEQ(d,"print")) return KEY_print;
5167 if (strEQ(d,"printf")) return KEY_printf;
5170 if (strEQ(d,"package")) return KEY_package;
5173 if (strEQ(d,"prototype")) return KEY_prototype;
5178 if (strEQ(d,"q")) return KEY_q;
5179 if (strEQ(d,"qr")) return KEY_qr;
5180 if (strEQ(d,"qq")) return KEY_qq;
5181 if (strEQ(d,"qw")) return KEY_qw;
5182 if (strEQ(d,"qx")) return KEY_qx;
5184 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
5189 if (strEQ(d,"ref")) return -KEY_ref;
5192 if (strEQ(d,"read")) return -KEY_read;
5193 if (strEQ(d,"rand")) return -KEY_rand;
5194 if (strEQ(d,"recv")) return -KEY_recv;
5195 if (strEQ(d,"redo")) return KEY_redo;
5198 if (strEQ(d,"rmdir")) return -KEY_rmdir;
5199 if (strEQ(d,"reset")) return -KEY_reset;
5202 if (strEQ(d,"return")) return KEY_return;
5203 if (strEQ(d,"rename")) return -KEY_rename;
5204 if (strEQ(d,"rindex")) return -KEY_rindex;
5207 if (strEQ(d,"require")) return -KEY_require;
5208 if (strEQ(d,"reverse")) return -KEY_reverse;
5209 if (strEQ(d,"readdir")) return -KEY_readdir;
5212 if (strEQ(d,"readlink")) return -KEY_readlink;
5213 if (strEQ(d,"readline")) return -KEY_readline;
5214 if (strEQ(d,"readpipe")) return -KEY_readpipe;
5217 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
5222 if (strEQ(d,"STOP")) return KEY_STOP;
5226 case 0: return KEY_s;
5228 if (strEQ(d,"scalar")) return KEY_scalar;
5233 if (strEQ(d,"seek")) return -KEY_seek;
5234 if (strEQ(d,"send")) return -KEY_send;
5237 if (strEQ(d,"semop")) return -KEY_semop;
5240 if (strEQ(d,"select")) return -KEY_select;
5241 if (strEQ(d,"semctl")) return -KEY_semctl;
5242 if (strEQ(d,"semget")) return -KEY_semget;
5245 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
5246 if (strEQ(d,"seekdir")) return -KEY_seekdir;
5249 if (strEQ(d,"setpwent")) return -KEY_setpwent;
5250 if (strEQ(d,"setgrent")) return -KEY_setgrent;
5253 if (strEQ(d,"setnetent")) return -KEY_setnetent;
5256 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
5257 if (strEQ(d,"sethostent")) return -KEY_sethostent;
5258 if (strEQ(d,"setservent")) return -KEY_setservent;
5261 if (strEQ(d,"setpriority")) return -KEY_setpriority;
5262 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
5269 if (strEQ(d,"shift")) return KEY_shift;
5272 if (strEQ(d,"shmctl")) return -KEY_shmctl;
5273 if (strEQ(d,"shmget")) return -KEY_shmget;
5276 if (strEQ(d,"shmread")) return -KEY_shmread;
5279 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
5280 if (strEQ(d,"shutdown")) return -KEY_shutdown;
5285 if (strEQ(d,"sin")) return -KEY_sin;
5288 if (strEQ(d,"sleep")) return -KEY_sleep;
5291 if (strEQ(d,"sort")) return KEY_sort;
5292 if (strEQ(d,"socket")) return -KEY_socket;
5293 if (strEQ(d,"socketpair")) return -KEY_socketpair;
5296 if (strEQ(d,"split")) return KEY_split;
5297 if (strEQ(d,"sprintf")) return -KEY_sprintf;
5298 if (strEQ(d,"splice")) return KEY_splice;
5301 if (strEQ(d,"sqrt")) return -KEY_sqrt;
5304 if (strEQ(d,"srand")) return -KEY_srand;
5307 if (strEQ(d,"stat")) return -KEY_stat;
5308 if (strEQ(d,"study")) return KEY_study;
5311 if (strEQ(d,"substr")) return -KEY_substr;
5312 if (strEQ(d,"sub")) return KEY_sub;
5317 if (strEQ(d,"system")) return -KEY_system;
5320 if (strEQ(d,"symlink")) return -KEY_symlink;
5321 if (strEQ(d,"syscall")) return -KEY_syscall;
5322 if (strEQ(d,"sysopen")) return -KEY_sysopen;
5323 if (strEQ(d,"sysread")) return -KEY_sysread;
5324 if (strEQ(d,"sysseek")) return -KEY_sysseek;
5327 if (strEQ(d,"syswrite")) return -KEY_syswrite;
5336 if (strEQ(d,"tr")) return KEY_tr;
5339 if (strEQ(d,"tie")) return KEY_tie;
5342 if (strEQ(d,"tell")) return -KEY_tell;
5343 if (strEQ(d,"tied")) return KEY_tied;
5344 if (strEQ(d,"time")) return -KEY_time;
5347 if (strEQ(d,"times")) return -KEY_times;
5350 if (strEQ(d,"telldir")) return -KEY_telldir;
5353 if (strEQ(d,"truncate")) return -KEY_truncate;
5360 if (strEQ(d,"uc")) return -KEY_uc;
5363 if (strEQ(d,"use")) return KEY_use;
5366 if (strEQ(d,"undef")) return KEY_undef;
5367 if (strEQ(d,"until")) return KEY_until;
5368 if (strEQ(d,"untie")) return KEY_untie;
5369 if (strEQ(d,"utime")) return -KEY_utime;
5370 if (strEQ(d,"umask")) return -KEY_umask;
5373 if (strEQ(d,"unless")) return KEY_unless;
5374 if (strEQ(d,"unpack")) return -KEY_unpack;
5375 if (strEQ(d,"unlink")) return -KEY_unlink;
5378 if (strEQ(d,"unshift")) return KEY_unshift;
5379 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
5384 if (strEQ(d,"values")) return -KEY_values;
5385 if (strEQ(d,"vec")) return -KEY_vec;
5390 if (strEQ(d,"warn")) return -KEY_warn;
5391 if (strEQ(d,"wait")) return -KEY_wait;
5394 if (strEQ(d,"while")) return KEY_while;
5395 if (strEQ(d,"write")) return -KEY_write;
5398 if (strEQ(d,"waitpid")) return -KEY_waitpid;
5401 if (strEQ(d,"wantarray")) return -KEY_wantarray;
5406 if (len == 1) return -KEY_x;
5407 if (strEQ(d,"xor")) return -KEY_xor;
5410 if (len == 1) return KEY_y;
5419 S_checkcomma(pTHX_ register char *s, char *name, char *what)
5423 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
5424 dTHR; /* only for ckWARN */
5425 if (ckWARN(WARN_SYNTAX)) {
5427 for (w = s+2; *w && level; w++) {
5434 for (; *w && isSPACE(*w); w++) ;
5435 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
5436 Perl_warner(aTHX_ WARN_SYNTAX,
5437 "%s (...) interpreted as function",name);
5440 while (s < PL_bufend && isSPACE(*s))
5444 while (s < PL_bufend && isSPACE(*s))
5446 if (isIDFIRST_lazy(s)) {
5448 while (isALNUM_lazy(s))
5450 while (s < PL_bufend && isSPACE(*s))
5455 kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
5459 Perl_croak(aTHX_ "No comma allowed after %s", what);
5464 /* Either returns sv, or mortalizes sv and returns a new SV*.
5465 Best used as sv=new_constant(..., sv, ...).
5466 If s, pv are NULL, calls subroutine with one argument,
5467 and type is used with error messages only. */
5470 S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv,
5474 HV *table = GvHV(PL_hintgv); /* ^H */
5478 const char *why, *why1, *why2;
5480 if (!(PL_hints & HINT_LOCALIZE_HH)) {
5483 why = "%^H is not localized";
5487 msg = Perl_newSVpvf(aTHX_ "constant(%s): %s%s%s",
5488 (type ? type: "undef"), why1, why2, why);
5489 yyerror(SvPVX(msg));
5494 why = "%^H is not defined";
5497 cvp = hv_fetch(table, key, strlen(key), FALSE);
5498 if (!cvp || !SvOK(*cvp)) {
5499 why = "} is not defined";
5504 sv_2mortal(sv); /* Parent created it permanently */
5507 pv = sv_2mortal(newSVpvn(s, len));
5509 typesv = sv_2mortal(newSVpv(type, 0));
5511 typesv = &PL_sv_undef;
5513 PUSHSTACKi(PERLSI_OVERLOAD);
5526 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
5530 /* Check the eval first */
5531 if (!PL_in_eval && SvTRUE(ERRSV))
5534 sv_catpv(ERRSV, "Propagated");
5535 yyerror(SvPV(ERRSV, n_a)); /* Duplicates the message inside eval */
5537 res = SvREFCNT_inc(sv);
5541 (void)SvREFCNT_inc(res);
5550 why = "}} did not return a defined value";
5551 why1 = "Call to &{$^H{";
5561 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
5563 register char *d = dest;
5564 register char *e = d + destlen - 3; /* two-character token, ending NUL */
5567 Perl_croak(aTHX_ ident_too_long);
5568 if (isALNUM(*s)) /* UTF handled below */
5570 else if (*s == '\'' && allow_package && isIDFIRST_lazy(s+1)) {
5575 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
5579 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5580 char *t = s + UTF8SKIP(s);
5581 while (*t & 0x80 && is_utf8_mark((U8*)t))
5583 if (d + (t - s) > e)
5584 Perl_croak(aTHX_ ident_too_long);
5585 Copy(s, d, t - s, char);
5598 S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
5608 e = d + destlen - 3; /* two-character token, ending NUL */
5610 while (isDIGIT(*s)) {
5612 Perl_croak(aTHX_ ident_too_long);
5619 Perl_croak(aTHX_ ident_too_long);
5620 if (isALNUM(*s)) /* UTF handled below */
5622 else if (*s == '\'' && isIDFIRST_lazy(s+1)) {
5627 else if (*s == ':' && s[1] == ':') {
5631 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5632 char *t = s + UTF8SKIP(s);
5633 while (*t & 0x80 && is_utf8_mark((U8*)t))
5635 if (d + (t - s) > e)
5636 Perl_croak(aTHX_ ident_too_long);
5637 Copy(s, d, t - s, char);
5648 if (PL_lex_state != LEX_NORMAL)
5649 PL_lex_state = LEX_INTERPENDMAYBE;
5652 if (*s == '$' && s[1] &&
5653 (isALNUM_lazy(s+1) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
5666 if (*d == '^' && *s && isCONTROLVAR(*s)) {
5671 if (isSPACE(s[-1])) {
5674 if (ch != ' ' && ch != '\t') {
5680 if (isIDFIRST_lazy(d)) {
5684 while (e < send && isALNUM_lazy(e) || *e == ':') {
5686 while (e < send && *e & 0x80 && is_utf8_mark((U8*)e))
5689 Copy(s, d, e - s, char);
5694 while ((isALNUM(*s) || *s == ':') && d < e)
5697 Perl_croak(aTHX_ ident_too_long);
5700 while (s < send && (*s == ' ' || *s == '\t')) s++;
5701 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
5702 dTHR; /* only for ckWARN */
5703 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
5704 const char *brack = *s == '[' ? "[...]" : "{...}";
5705 Perl_warner(aTHX_ WARN_AMBIGUOUS,
5706 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
5707 funny, dest, brack, funny, dest, brack);
5710 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR | XFAKEBRACK;
5714 /* Handle extended ${^Foo} variables
5715 * 1999-02-27 mjd-perl-patch@plover.com */
5716 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
5720 while (isALNUM(*s) && d < e) {
5724 Perl_croak(aTHX_ ident_too_long);
5729 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
5730 PL_lex_state = LEX_INTERPEND;
5733 if (PL_lex_state == LEX_NORMAL) {
5734 dTHR; /* only for ckWARN */
5735 if (ckWARN(WARN_AMBIGUOUS) &&
5736 (keyword(dest, d - dest) || get_cv(dest, FALSE)))
5738 Perl_warner(aTHX_ WARN_AMBIGUOUS,
5739 "Ambiguous use of %c{%s} resolved to %c%s",
5740 funny, dest, funny, dest);
5745 s = bracket; /* let the parser handle it */
5749 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
5750 PL_lex_state = LEX_INTERPEND;
5755 Perl_pmflag(pTHX_ U16 *pmfl, int ch)
5760 *pmfl |= PMf_GLOBAL;
5762 *pmfl |= PMf_CONTINUE;
5766 *pmfl |= PMf_MULTILINE;
5768 *pmfl |= PMf_SINGLELINE;
5770 *pmfl |= PMf_EXTENDED;
5774 S_scan_pat(pTHX_ char *start, I32 type)
5779 s = scan_str(start,FALSE,FALSE);
5782 SvREFCNT_dec(PL_lex_stuff);
5783 PL_lex_stuff = Nullsv;
5784 Perl_croak(aTHX_ "Search pattern not terminated");
5787 pm = (PMOP*)newPMOP(type, 0);
5788 if (PL_multi_open == '?')
5789 pm->op_pmflags |= PMf_ONCE;
5791 while (*s && strchr("iomsx", *s))
5792 pmflag(&pm->op_pmflags,*s++);
5795 while (*s && strchr("iogcmsx", *s))
5796 pmflag(&pm->op_pmflags,*s++);
5798 pm->op_pmpermflags = pm->op_pmflags;
5800 PL_lex_op = (OP*)pm;
5801 yylval.ival = OP_MATCH;
5806 S_scan_subst(pTHX_ char *start)
5813 yylval.ival = OP_NULL;
5815 s = scan_str(start,FALSE,FALSE);
5819 SvREFCNT_dec(PL_lex_stuff);
5820 PL_lex_stuff = Nullsv;
5821 Perl_croak(aTHX_ "Substitution pattern not terminated");
5824 if (s[-1] == PL_multi_open)
5827 first_start = PL_multi_start;
5828 s = scan_str(s,FALSE,FALSE);
5831 SvREFCNT_dec(PL_lex_stuff);
5832 PL_lex_stuff = Nullsv;
5834 SvREFCNT_dec(PL_lex_repl);
5835 PL_lex_repl = Nullsv;
5836 Perl_croak(aTHX_ "Substitution replacement not terminated");
5838 PL_multi_start = first_start; /* so whole substitution is taken together */
5840 pm = (PMOP*)newPMOP(OP_SUBST, 0);
5846 else if (strchr("iogcmsx", *s))
5847 pmflag(&pm->op_pmflags,*s++);
5854 PL_sublex_info.super_bufptr = s;
5855 PL_sublex_info.super_bufend = PL_bufend;
5857 pm->op_pmflags |= PMf_EVAL;
5858 repl = newSVpvn("",0);
5860 sv_catpv(repl, es ? "eval " : "do ");
5861 sv_catpvn(repl, "{ ", 2);
5862 sv_catsv(repl, PL_lex_repl);
5863 sv_catpvn(repl, " };", 2);
5865 SvREFCNT_dec(PL_lex_repl);
5869 pm->op_pmpermflags = pm->op_pmflags;
5870 PL_lex_op = (OP*)pm;
5871 yylval.ival = OP_SUBST;
5876 S_scan_trans(pTHX_ char *start)
5887 yylval.ival = OP_NULL;
5889 s = scan_str(start,FALSE,FALSE);
5892 SvREFCNT_dec(PL_lex_stuff);
5893 PL_lex_stuff = Nullsv;
5894 Perl_croak(aTHX_ "Transliteration pattern not terminated");
5896 if (s[-1] == PL_multi_open)
5899 s = scan_str(s,FALSE,FALSE);
5902 SvREFCNT_dec(PL_lex_stuff);
5903 PL_lex_stuff = Nullsv;
5905 SvREFCNT_dec(PL_lex_repl);
5906 PL_lex_repl = Nullsv;
5907 Perl_croak(aTHX_ "Transliteration replacement not terminated");
5911 o = newSVOP(OP_TRANS, 0, 0);
5912 utf8 = OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF;
5915 New(803,tbl,256,short);
5916 o = newPVOP(OP_TRANS, 0, (char*)tbl);
5920 complement = del = squash = 0;
5921 while (strchr("cdsCU", *s)) {
5923 complement = OPpTRANS_COMPLEMENT;
5925 del = OPpTRANS_DELETE;
5927 squash = OPpTRANS_SQUASH;
5932 utf8 &= ~OPpTRANS_FROM_UTF;
5934 utf8 |= OPpTRANS_FROM_UTF;
5938 utf8 &= ~OPpTRANS_TO_UTF;
5940 utf8 |= OPpTRANS_TO_UTF;
5943 Perl_croak(aTHX_ "Too many /C and /U options");
5948 o->op_private = del|squash|complement|utf8;
5951 yylval.ival = OP_TRANS;
5956 S_scan_heredoc(pTHX_ register char *s)
5960 I32 op_type = OP_SCALAR;
5967 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
5971 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
5974 for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5975 if (*peek && strchr("`'\"",*peek)) {
5978 s = delimcpy(d, e, s, PL_bufend, term, &len);
5988 if (!isALNUM_lazy(s))
5989 deprecate("bare << to mean <<\"\"");
5990 for (; isALNUM_lazy(s); s++) {
5995 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
5996 Perl_croak(aTHX_ "Delimiter for here document is too long");
5999 len = d - PL_tokenbuf;
6000 #ifndef PERL_STRICT_CR
6001 d = strchr(s, '\r');
6005 while (s < PL_bufend) {
6011 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
6020 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6025 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
6026 herewas = newSVpvn(s,PL_bufend-s);
6028 s--, herewas = newSVpvn(s,d-s);
6029 s += SvCUR(herewas);
6031 tmpstr = NEWSV(87,79);
6032 sv_upgrade(tmpstr, SVt_PVIV);
6037 else if (term == '`') {
6038 op_type = OP_BACKTICK;
6039 SvIVX(tmpstr) = '\\';
6043 PL_multi_start = CopLINE(PL_curcop);
6044 PL_multi_open = PL_multi_close = '<';
6045 term = *PL_tokenbuf;
6046 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
6047 char *bufptr = PL_sublex_info.super_bufptr;
6048 char *bufend = PL_sublex_info.super_bufend;
6049 char *olds = s - SvCUR(herewas);
6050 s = strchr(bufptr, '\n');
6054 while (s < bufend &&
6055 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6057 CopLINE_inc(PL_curcop);
6060 CopLINE_set(PL_curcop, PL_multi_start);
6061 missingterm(PL_tokenbuf);
6063 sv_setpvn(herewas,bufptr,d-bufptr+1);
6064 sv_setpvn(tmpstr,d+1,s-d);
6066 sv_catpvn(herewas,s,bufend-s);
6067 (void)strcpy(bufptr,SvPVX(herewas));
6074 while (s < PL_bufend &&
6075 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6077 CopLINE_inc(PL_curcop);
6079 if (s >= PL_bufend) {
6080 CopLINE_set(PL_curcop, PL_multi_start);
6081 missingterm(PL_tokenbuf);
6083 sv_setpvn(tmpstr,d+1,s-d);
6085 CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
6087 sv_catpvn(herewas,s,PL_bufend-s);
6088 sv_setsv(PL_linestr,herewas);
6089 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
6090 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6093 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
6094 while (s >= PL_bufend) { /* multiple line string? */
6096 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6097 CopLINE_set(PL_curcop, PL_multi_start);
6098 missingterm(PL_tokenbuf);
6100 CopLINE_inc(PL_curcop);
6101 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6102 #ifndef PERL_STRICT_CR
6103 if (PL_bufend - PL_linestart >= 2) {
6104 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
6105 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
6107 PL_bufend[-2] = '\n';
6109 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6111 else if (PL_bufend[-1] == '\r')
6112 PL_bufend[-1] = '\n';
6114 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
6115 PL_bufend[-1] = '\n';
6117 if (PERLDB_LINE && PL_curstash != PL_debstash) {
6118 SV *sv = NEWSV(88,0);
6120 sv_upgrade(sv, SVt_PVMG);
6121 sv_setsv(sv,PL_linestr);
6122 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop),sv);
6124 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
6127 sv_catsv(PL_linestr,herewas);
6128 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6132 sv_catsv(tmpstr,PL_linestr);
6137 PL_multi_end = CopLINE(PL_curcop);
6138 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
6139 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
6140 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
6142 SvREFCNT_dec(herewas);
6143 PL_lex_stuff = tmpstr;
6144 yylval.ival = op_type;
6149 takes: current position in input buffer
6150 returns: new position in input buffer
6151 side-effects: yylval and lex_op are set.
6156 <FH> read from filehandle
6157 <pkg::FH> read from package qualified filehandle
6158 <pkg'FH> read from package qualified filehandle
6159 <$fh> read from filehandle in $fh
6165 S_scan_inputsymbol(pTHX_ char *start)
6167 register char *s = start; /* current position in buffer */
6173 d = PL_tokenbuf; /* start of temp holding space */
6174 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
6175 end = strchr(s, '\n');
6178 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
6180 /* die if we didn't have space for the contents of the <>,
6181 or if it didn't end, or if we see a newline
6184 if (len >= sizeof PL_tokenbuf)
6185 Perl_croak(aTHX_ "Excessively long <> operator");
6187 Perl_croak(aTHX_ "Unterminated <> operator");
6192 Remember, only scalar variables are interpreted as filehandles by
6193 this code. Anything more complex (e.g., <$fh{$num}>) will be
6194 treated as a glob() call.
6195 This code makes use of the fact that except for the $ at the front,
6196 a scalar variable and a filehandle look the same.
6198 if (*d == '$' && d[1]) d++;
6200 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
6201 while (*d && (isALNUM_lazy(d) || *d == '\'' || *d == ':'))
6204 /* If we've tried to read what we allow filehandles to look like, and
6205 there's still text left, then it must be a glob() and not a getline.
6206 Use scan_str to pull out the stuff between the <> and treat it
6207 as nothing more than a string.
6210 if (d - PL_tokenbuf != len) {
6211 yylval.ival = OP_GLOB;
6213 s = scan_str(start,FALSE,FALSE);
6215 Perl_croak(aTHX_ "Glob not terminated");
6219 /* we're in a filehandle read situation */
6222 /* turn <> into <ARGV> */
6224 (void)strcpy(d,"ARGV");
6226 /* if <$fh>, create the ops to turn the variable into a
6232 /* try to find it in the pad for this block, otherwise find
6233 add symbol table ops
6235 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
6236 OP *o = newOP(OP_PADSV, 0);
6238 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, o);
6241 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
6242 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
6243 newUNOP(OP_RV2SV, 0,
6244 newGVOP(OP_GV, 0, gv)));
6246 PL_lex_op->op_flags |= OPf_SPECIAL;
6247 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
6248 yylval.ival = OP_NULL;
6251 /* If it's none of the above, it must be a literal filehandle
6252 (<Foo::BAR> or <FOO>) so build a simple readline OP */
6254 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
6255 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
6256 yylval.ival = OP_NULL;
6265 takes: start position in buffer
6266 keep_quoted preserve \ on the embedded delimiter(s)
6267 keep_delims preserve the delimiters around the string
6268 returns: position to continue reading from buffer
6269 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
6270 updates the read buffer.
6272 This subroutine pulls a string out of the input. It is called for:
6273 q single quotes q(literal text)
6274 ' single quotes 'literal text'
6275 qq double quotes qq(interpolate $here please)
6276 " double quotes "interpolate $here please"
6277 qx backticks qx(/bin/ls -l)
6278 ` backticks `/bin/ls -l`
6279 qw quote words @EXPORT_OK = qw( func() $spam )
6280 m// regexp match m/this/
6281 s/// regexp substitute s/this/that/
6282 tr/// string transliterate tr/this/that/
6283 y/// string transliterate y/this/that/
6284 ($*@) sub prototypes sub foo ($)
6285 (stuff) sub attr parameters sub foo : attr(stuff)
6286 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
6288 In most of these cases (all but <>, patterns and transliterate)
6289 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
6290 calls scan_str(). s/// makes yylex() call scan_subst() which calls
6291 scan_str(). tr/// and y/// make yylex() call scan_trans() which
6294 It skips whitespace before the string starts, and treats the first
6295 character as the delimiter. If the delimiter is one of ([{< then
6296 the corresponding "close" character )]}> is used as the closing
6297 delimiter. It allows quoting of delimiters, and if the string has
6298 balanced delimiters ([{<>}]) it allows nesting.
6300 The lexer always reads these strings into lex_stuff, except in the
6301 case of the operators which take *two* arguments (s/// and tr///)
6302 when it checks to see if lex_stuff is full (presumably with the 1st
6303 arg to s or tr) and if so puts the string into lex_repl.
6308 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
6311 SV *sv; /* scalar value: string */
6312 char *tmps; /* temp string, used for delimiter matching */
6313 register char *s = start; /* current position in the buffer */
6314 register char term; /* terminating character */
6315 register char *to; /* current position in the sv's data */
6316 I32 brackets = 1; /* bracket nesting level */
6318 /* skip space before the delimiter */
6322 /* mark where we are, in case we need to report errors */
6325 /* after skipping whitespace, the next character is the terminator */
6327 /* mark where we are */
6328 PL_multi_start = CopLINE(PL_curcop);
6329 PL_multi_open = term;
6331 /* find corresponding closing delimiter */
6332 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
6334 PL_multi_close = term;
6336 /* create a new SV to hold the contents. 87 is leak category, I'm
6337 assuming. 79 is the SV's initial length. What a random number. */
6339 sv_upgrade(sv, SVt_PVIV);
6341 (void)SvPOK_only(sv); /* validate pointer */
6343 /* move past delimiter and try to read a complete string */
6345 sv_catpvn(sv, s, 1);
6348 /* extend sv if need be */
6349 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
6350 /* set 'to' to the next character in the sv's string */
6351 to = SvPVX(sv)+SvCUR(sv);
6353 /* if open delimiter is the close delimiter read unbridle */
6354 if (PL_multi_open == PL_multi_close) {
6355 for (; s < PL_bufend; s++,to++) {
6356 /* embedded newlines increment the current line number */
6357 if (*s == '\n' && !PL_rsfp)
6358 CopLINE_inc(PL_curcop);
6359 /* handle quoted delimiters */
6360 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
6361 if (!keep_quoted && s[1] == term)
6363 /* any other quotes are simply copied straight through */
6367 /* terminate when run out of buffer (the for() condition), or
6368 have found the terminator */
6369 else if (*s == term)
6375 /* if the terminator isn't the same as the start character (e.g.,
6376 matched brackets), we have to allow more in the quoting, and
6377 be prepared for nested brackets.
6380 /* read until we run out of string, or we find the terminator */
6381 for (; s < PL_bufend; s++,to++) {
6382 /* embedded newlines increment the line count */
6383 if (*s == '\n' && !PL_rsfp)
6384 CopLINE_inc(PL_curcop);
6385 /* backslashes can escape the open or closing characters */
6386 if (*s == '\\' && s+1 < PL_bufend) {
6388 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
6393 /* allow nested opens and closes */
6394 else if (*s == PL_multi_close && --brackets <= 0)
6396 else if (*s == PL_multi_open)
6401 /* terminate the copied string and update the sv's end-of-string */
6403 SvCUR_set(sv, to - SvPVX(sv));
6406 * this next chunk reads more into the buffer if we're not done yet
6409 if (s < PL_bufend) break; /* handle case where we are done yet :-) */
6411 #ifndef PERL_STRICT_CR
6412 if (to - SvPVX(sv) >= 2) {
6413 if ((to[-2] == '\r' && to[-1] == '\n') ||
6414 (to[-2] == '\n' && to[-1] == '\r'))
6418 SvCUR_set(sv, to - SvPVX(sv));
6420 else if (to[-1] == '\r')
6423 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
6427 /* if we're out of file, or a read fails, bail and reset the current
6428 line marker so we can report where the unterminated string began
6431 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6433 CopLINE_set(PL_curcop, PL_multi_start);
6436 /* we read a line, so increment our line counter */
6437 CopLINE_inc(PL_curcop);
6439 /* update debugger info */
6440 if (PERLDB_LINE && PL_curstash != PL_debstash) {
6441 SV *sv = NEWSV(88,0);
6443 sv_upgrade(sv, SVt_PVMG);
6444 sv_setsv(sv,PL_linestr);
6445 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop), sv);
6448 /* having changed the buffer, we must update PL_bufend */
6449 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6452 /* at this point, we have successfully read the delimited string */
6455 sv_catpvn(sv, s, 1);
6456 PL_multi_end = CopLINE(PL_curcop);
6459 /* if we allocated too much space, give some back */
6460 if (SvCUR(sv) + 5 < SvLEN(sv)) {
6461 SvLEN_set(sv, SvCUR(sv) + 1);
6462 Renew(SvPVX(sv), SvLEN(sv), char);
6465 /* decide whether this is the first or second quoted string we've read
6478 takes: pointer to position in buffer
6479 returns: pointer to new position in buffer
6480 side-effects: builds ops for the constant in yylval.op
6482 Read a number in any of the formats that Perl accepts:
6484 0(x[0-7A-F]+)|([0-7]+)|(b[01])
6485 [\d_]+(\.[\d_]*)?[Ee](\d+)
6487 Underbars (_) are allowed in decimal numbers. If -w is on,
6488 underbars before a decimal point must be at three digit intervals.
6490 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
6493 If it reads a number without a decimal point or an exponent, it will
6494 try converting the number to an integer and see if it can do so
6495 without loss of precision.
6499 Perl_scan_num(pTHX_ char *start)
6501 register char *s = start; /* current position in buffer */
6502 register char *d; /* destination in temp buffer */
6503 register char *e; /* end of temp buffer */
6504 IV tryiv; /* used to see if it can be an IV */
6505 NV value; /* number read, as a double */
6506 SV *sv; /* place to put the converted number */
6507 bool floatit; /* boolean: int or float? */
6508 char *lastub = 0; /* position of last underbar */
6509 static char number_too_long[] = "Number too long";
6511 /* We use the first character to decide what type of number this is */
6515 Perl_croak(aTHX_ "panic: scan_num");
6517 /* if it starts with a 0, it could be an octal number, a decimal in
6518 0.13 disguise, or a hexadecimal number, or a binary number.
6523 u holds the "number so far"
6524 shift the power of 2 of the base
6525 (hex == 4, octal == 3, binary == 1)
6526 overflowed was the number more than we can hold?
6528 Shift is used when we add a digit. It also serves as an "are
6529 we in octal/hex/binary?" indicator to disallow hex characters
6536 bool overflowed = FALSE;
6537 static NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
6538 static char* bases[5] = { "", "binary", "", "octal",
6540 static char* Bases[5] = { "", "Binary", "", "Octal",
6542 static char *maxima[5] = { "",
6543 "0b11111111111111111111111111111111",
6547 char *base, *Base, *max;
6553 } else if (s[1] == 'b') {
6557 /* check for a decimal in disguise */
6558 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
6560 /* so it must be octal */
6564 base = bases[shift];
6565 Base = Bases[shift];
6566 max = maxima[shift];
6568 /* read the rest of the number */
6570 /* x is used in the overflow test,
6571 b is the digit we're adding on. */
6576 /* if we don't mention it, we're done */
6585 /* 8 and 9 are not octal */
6588 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
6592 case '2': case '3': case '4':
6593 case '5': case '6': case '7':
6595 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
6599 b = *s++ & 15; /* ASCII digit -> value of digit */
6603 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
6604 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
6605 /* make sure they said 0x */
6610 /* Prepare to put the digit we have onto the end
6611 of the number so far. We check for overflows.
6616 x = u << shift; /* make room for the digit */
6618 if ((x >> shift) != u
6619 && !(PL_hints & HINT_NEW_BINARY)) {
6623 if (ckWARN_d(WARN_OVERFLOW))
6624 Perl_warner(aTHX_ WARN_OVERFLOW,
6625 "Integer overflow in %s number",
6628 u = x | b; /* add the digit to the end */
6631 n *= nvshift[shift];
6632 /* If an NV has not enough bits in its
6633 * mantissa to represent an UV this summing of
6634 * small low-order numbers is a waste of time
6635 * (because the NV cannot preserve the
6636 * low-order bits anyway): we could just
6637 * remember when did we overflow and in the
6638 * end just multiply n by the right
6646 /* if we get here, we had success: make a scalar value from
6653 if (ckWARN(WARN_PORTABLE) && n > 4294967295.0)
6654 Perl_warner(aTHX_ WARN_PORTABLE,
6655 "%s number > %s non-portable",
6662 if (ckWARN(WARN_PORTABLE) && u > 0xffffffff)
6663 Perl_warner(aTHX_ WARN_PORTABLE,
6664 "%s number > %s non-portable",
6669 if (PL_hints & HINT_NEW_BINARY)
6670 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
6675 handle decimal numbers.
6676 we're also sent here when we read a 0 as the first digit
6678 case '1': case '2': case '3': case '4': case '5':
6679 case '6': case '7': case '8': case '9': case '.':
6682 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
6685 /* read next group of digits and _ and copy into d */
6686 while (isDIGIT(*s) || *s == '_') {
6687 /* skip underscores, checking for misplaced ones
6691 dTHR; /* only for ckWARN */
6692 if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
6693 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
6697 /* check for end of fixed-length buffer */
6699 Perl_croak(aTHX_ number_too_long);
6700 /* if we're ok, copy the character */
6705 /* final misplaced underbar check */
6706 if (lastub && s - lastub != 3) {
6708 if (ckWARN(WARN_SYNTAX))
6709 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
6712 /* read a decimal portion if there is one. avoid
6713 3..5 being interpreted as the number 3. followed
6716 if (*s == '.' && s[1] != '.') {
6720 /* copy, ignoring underbars, until we run out of
6721 digits. Note: no misplaced underbar checks!
6723 for (; isDIGIT(*s) || *s == '_'; s++) {
6724 /* fixed length buffer check */
6726 Perl_croak(aTHX_ number_too_long);
6732 /* read exponent part, if present */
6733 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
6737 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
6738 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
6740 /* allow positive or negative exponent */
6741 if (*s == '+' || *s == '-')
6744 /* read digits of exponent (no underbars :-) */
6745 while (isDIGIT(*s)) {
6747 Perl_croak(aTHX_ number_too_long);
6752 /* terminate the string */
6755 /* make an sv from the string */
6758 value = Atof(PL_tokenbuf);
6761 See if we can make do with an integer value without loss of
6762 precision. We use I_V to cast to an int, because some
6763 compilers have issues. Then we try casting it back and see
6764 if it was the same. We only do this if we know we
6765 specifically read an integer.
6767 Note: if floatit is true, then we don't need to do the
6771 if (!floatit && (NV)tryiv == value)
6772 sv_setiv(sv, tryiv);
6774 sv_setnv(sv, value);
6775 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
6776 (PL_hints & HINT_NEW_INTEGER) )
6777 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
6778 (floatit ? "float" : "integer"),
6783 /* make the op for the constant and return */
6785 yylval.opval = newSVOP(OP_CONST, 0, sv);
6791 S_scan_formline(pTHX_ register char *s)
6796 SV *stuff = newSVpvn("",0);
6797 bool needargs = FALSE;
6800 if (*s == '.' || *s == '}') {
6802 #ifdef PERL_STRICT_CR
6803 for (t = s+1;*t == ' ' || *t == '\t'; t++) ;
6805 for (t = s+1;*t == ' ' || *t == '\t' || *t == '\r'; t++) ;
6807 if (*t == '\n' || t == PL_bufend)
6810 if (PL_in_eval && !PL_rsfp) {
6811 eol = strchr(s,'\n');
6816 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6818 for (t = s; t < eol; t++) {
6819 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
6821 goto enough; /* ~~ must be first line in formline */
6823 if (*t == '@' || *t == '^')
6826 sv_catpvn(stuff, s, eol-s);
6830 s = filter_gets(PL_linestr, PL_rsfp, 0);
6831 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
6832 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
6835 yyerror("Format not terminated");
6845 PL_lex_state = LEX_NORMAL;
6846 PL_nextval[PL_nexttoke].ival = 0;
6850 PL_lex_state = LEX_FORMLINE;
6851 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
6853 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
6857 SvREFCNT_dec(stuff);
6858 PL_lex_formbrack = 0;
6869 PL_cshlen = strlen(PL_cshname);
6874 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
6877 I32 oldsavestack_ix = PL_savestack_ix;
6878 CV* outsidecv = PL_compcv;
6882 assert(SvTYPE(PL_compcv) == SVt_PVCV);
6884 SAVEI32(PL_subline);
6885 save_item(PL_subname);
6887 SAVEVPTR(PL_curpad);
6888 SAVESPTR(PL_comppad);
6889 SAVESPTR(PL_comppad_name);
6890 SAVESPTR(PL_compcv);
6891 SAVEI32(PL_comppad_name_fill);
6892 SAVEI32(PL_min_intro_pending);
6893 SAVEI32(PL_max_intro_pending);
6894 SAVEI32(PL_pad_reset_pending);
6896 PL_compcv = (CV*)NEWSV(1104,0);
6897 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
6898 CvFLAGS(PL_compcv) |= flags;
6900 PL_comppad = newAV();
6901 av_push(PL_comppad, Nullsv);
6902 PL_curpad = AvARRAY(PL_comppad);
6903 PL_comppad_name = newAV();
6904 PL_comppad_name_fill = 0;
6905 PL_min_intro_pending = 0;
6907 PL_subline = CopLINE(PL_curcop);
6909 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
6910 PL_curpad[0] = (SV*)newAV();
6911 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
6912 #endif /* USE_THREADS */
6914 comppadlist = newAV();
6915 AvREAL_off(comppadlist);
6916 av_store(comppadlist, 0, (SV*)PL_comppad_name);
6917 av_store(comppadlist, 1, (SV*)PL_comppad);
6919 CvPADLIST(PL_compcv) = comppadlist;
6920 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
6922 CvOWNER(PL_compcv) = 0;
6923 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
6924 MUTEX_INIT(CvMUTEXP(PL_compcv));
6925 #endif /* USE_THREADS */
6927 return oldsavestack_ix;
6931 Perl_yywarn(pTHX_ char *s)
6934 PL_in_eval |= EVAL_WARNONLY;
6936 PL_in_eval &= ~EVAL_WARNONLY;
6941 Perl_yyerror(pTHX_ char *s)
6945 char *context = NULL;
6949 if (!yychar || (yychar == ';' && !PL_rsfp))
6951 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
6952 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
6953 while (isSPACE(*PL_oldoldbufptr))
6955 context = PL_oldoldbufptr;
6956 contlen = PL_bufptr - PL_oldoldbufptr;
6958 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
6959 PL_oldbufptr != PL_bufptr) {
6960 while (isSPACE(*PL_oldbufptr))
6962 context = PL_oldbufptr;
6963 contlen = PL_bufptr - PL_oldbufptr;
6965 else if (yychar > 255)
6966 where = "next token ???";
6967 else if ((yychar & 127) == 127) {
6968 if (PL_lex_state == LEX_NORMAL ||
6969 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
6970 where = "at end of line";
6971 else if (PL_lex_inpat)
6972 where = "within pattern";
6974 where = "within string";
6977 SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
6979 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
6980 else if (isPRINT_LC(yychar))
6981 Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
6983 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
6984 where = SvPVX(where_sv);
6986 msg = sv_2mortal(newSVpv(s, 0));
6987 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
6988 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
6990 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
6992 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
6993 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
6994 Perl_sv_catpvf(aTHX_ msg,
6995 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
6996 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
6999 if (PL_in_eval & EVAL_WARNONLY)
7000 Perl_warn(aTHX_ "%_", msg);
7003 if (PL_error_count >= 10)
7004 Perl_croak(aTHX_ "%s has too many errors.\n", CopFILE(PL_curcop));
7006 PL_in_my_stash = Nullhv;
7017 * Restore a source filter.
7021 restore_rsfp(pTHXo_ void *f)
7023 PerlIO *fp = (PerlIO*)f;
7025 if (PL_rsfp == PerlIO_stdin())
7026 PerlIO_clearerr(PL_rsfp);
7027 else if (PL_rsfp && (PL_rsfp != fp))
7028 PerlIO_close(PL_rsfp);