3 * Copyright (c) 1991-2002, 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";
29 static char c_without_g[] = "Use of /c modifier is meaningless without /g";
31 static void restore_rsfp(pTHX_ void *f);
32 #ifndef PERL_NO_UTF16_FILTER
33 static I32 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen);
34 static I32 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen);
37 #define XFAKEBRACK 128
40 #ifdef USE_UTF8_SCRIPTS
41 # define UTF (!IN_BYTES)
43 # ifdef EBCDIC /* For now 'use utf8' does not affect tokenizer on EBCDIC */
44 # define UTF (PL_linestr && DO_UTF8(PL_linestr))
46 # define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || (PL_hints & HINT_UTF8))
50 /* In variables named $^X, these are the legal values for X.
51 * 1999-02-27 mjd-perl-patch@plover.com */
52 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
54 /* On MacOS, respect nonbreaking spaces */
55 #ifdef MACOS_TRADITIONAL
56 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\312'||(c)=='\t')
58 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\t')
61 /* LEX_* are values for PL_lex_state, the state of the lexer.
62 * They are arranged oddly so that the guard on the switch statement
63 * can get by with a single comparison (if the compiler is smart enough).
66 /* #define LEX_NOTPARSING 11 is done in perl.h. */
69 #define LEX_INTERPNORMAL 9
70 #define LEX_INTERPCASEMOD 8
71 #define LEX_INTERPPUSH 7
72 #define LEX_INTERPSTART 6
73 #define LEX_INTERPEND 5
74 #define LEX_INTERPENDMAYBE 4
75 #define LEX_INTERPCONCAT 3
76 #define LEX_INTERPCONST 2
77 #define LEX_FORMLINE 1
78 #define LEX_KNOWNEXT 0
86 # define YYMAXLEVEL 100
88 YYSTYPE* yylval_pointer[YYMAXLEVEL];
89 int* yychar_pointer[YYMAXLEVEL];
93 # define yylval (*yylval_pointer[yyactlevel])
94 # define yychar (*yychar_pointer[yyactlevel])
95 # define PERL_YYLEX_PARAM yylval_pointer[yyactlevel],yychar_pointer[yyactlevel]
97 # define yylex() Perl_yylex_r(aTHX_ yylval_pointer[yyactlevel],yychar_pointer[yyactlevel])
100 #include "keywords.h"
102 /* CLINE is a macro that ensures PL_copline has a sane value */
107 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
110 * Convenience functions to return different tokens and prime the
111 * lexer for the next token. They all take an argument.
113 * TOKEN : generic token (used for '(', DOLSHARP, etc)
114 * OPERATOR : generic operator
115 * AOPERATOR : assignment operator
116 * PREBLOCK : beginning the block after an if, while, foreach, ...
117 * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
118 * PREREF : *EXPR where EXPR is not a simple identifier
119 * TERM : expression term
120 * LOOPX : loop exiting command (goto, last, dump, etc)
121 * FTST : file test operator
122 * FUN0 : zero-argument function
123 * FUN1 : not used, except for not, which isn't a UNIOP
124 * BOop : bitwise or or xor
126 * SHop : shift operator
127 * PWop : power operator
128 * PMop : pattern-matching operator
129 * Aop : addition-level operator
130 * Mop : multiplication-level operator
131 * Eop : equality-testing operator
132 * Rop : relational operator <= != gt
134 * Also see LOP and lop() below.
137 /* Note that REPORT() and REPORT2() will be expressions that supply
138 * their own trailing comma, not suitable for statements as such. */
139 #ifdef DEBUGGING /* Serve -DT. */
140 # define REPORT(x,retval) tokereport(x,s,(int)retval),
141 # define REPORT2(x,retval) tokereport(x,s, yylval.ival),
143 # define REPORT(x,retval)
144 # define REPORT2(x,retval)
147 #define TOKEN(retval) return (REPORT2("token",retval) PL_bufptr = s,(int)retval)
148 #define OPERATOR(retval) return (REPORT2("operator",retval) PL_expect = XTERM, PL_bufptr = s,(int)retval)
149 #define AOPERATOR(retval) return ao((REPORT2("aop",retval) PL_expect = XTERM, PL_bufptr = s,(int)retval))
150 #define PREBLOCK(retval) return (REPORT2("preblock",retval) PL_expect = XBLOCK,PL_bufptr = s,(int)retval)
151 #define PRETERMBLOCK(retval) return (REPORT2("pretermblock",retval) PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval)
152 #define PREREF(retval) return (REPORT2("preref",retval) PL_expect = XREF,PL_bufptr = s,(int)retval)
153 #define TERM(retval) return (CLINE, REPORT2("term",retval) PL_expect = XOPERATOR, PL_bufptr = s,(int)retval)
154 #define LOOPX(f) return(yylval.ival=f, REPORT("loopx",f) PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX)
155 #define FTST(f) return(yylval.ival=f, REPORT("ftst",f) PL_expect = XTERM,PL_bufptr = s,(int)UNIOP)
156 #define FUN0(f) return(yylval.ival = f, REPORT("fun0",f) PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0)
157 #define FUN1(f) return(yylval.ival = f, REPORT("fun1",f) PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1)
158 #define BOop(f) return ao((yylval.ival=f, REPORT("bitorop",f) PL_expect = XTERM,PL_bufptr = s,(int)BITOROP))
159 #define BAop(f) return ao((yylval.ival=f, REPORT("bitandop",f) PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP))
160 #define SHop(f) return ao((yylval.ival=f, REPORT("shiftop",f) PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP))
161 #define PWop(f) return ao((yylval.ival=f, REPORT("powop",f) PL_expect = XTERM,PL_bufptr = s,(int)POWOP))
162 #define PMop(f) return(yylval.ival=f, REPORT("matchop",f) PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP)
163 #define Aop(f) return ao((yylval.ival=f, REPORT("add",f) PL_expect = XTERM,PL_bufptr = s,(int)ADDOP))
164 #define Mop(f) return ao((yylval.ival=f, REPORT("mul",f) PL_expect = XTERM,PL_bufptr = s,(int)MULOP))
165 #define Eop(f) return(yylval.ival=f, REPORT("eq",f) PL_expect = XTERM,PL_bufptr = s,(int)EQOP)
166 #define Rop(f) return(yylval.ival=f, REPORT("rel",f) PL_expect = XTERM,PL_bufptr = s,(int)RELOP)
168 /* This bit of chicanery makes a unary function followed by
169 * a parenthesis into a function with one argument, highest precedence.
171 #define UNI(f) return(yylval.ival = f, \
175 PL_last_uni = PL_oldbufptr, \
176 PL_last_lop_op = f, \
177 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
179 #define UNIBRACK(f) return(yylval.ival = f, \
182 PL_last_uni = PL_oldbufptr, \
183 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
185 /* grandfather return to old style */
186 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
191 S_tokereport(pTHX_ char *thing, char* s, I32 rv)
194 SV* report = newSVpv(thing, 0);
195 Perl_sv_catpvf(aTHX_ report, ":line %d:%"IVdf":", CopLINE(PL_curcop),
198 if (s - PL_bufptr > 0)
199 sv_catpvn(report, PL_bufptr, s - PL_bufptr);
201 if (PL_oldbufptr && *PL_oldbufptr)
202 sv_catpv(report, PL_tokenbuf);
204 PerlIO_printf(Perl_debug_log, "### %s\n", SvPV_nolen(report));
213 * This subroutine detects &&= and ||= and turns an ANDAND or OROR
214 * into an OP_ANDASSIGN or OP_ORASSIGN
218 S_ao(pTHX_ int toketype)
220 if (*PL_bufptr == '=') {
222 if (toketype == ANDAND)
223 yylval.ival = OP_ANDASSIGN;
224 else if (toketype == OROR)
225 yylval.ival = OP_ORASSIGN;
233 * When Perl expects an operator and finds something else, no_op
234 * prints the warning. It always prints "<something> found where
235 * operator expected. It prints "Missing semicolon on previous line?"
236 * if the surprise occurs at the start of the line. "do you need to
237 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
238 * where the compiler doesn't know if foo is a method call or a function.
239 * It prints "Missing operator before end of line" if there's nothing
240 * after the missing operator, or "... before <...>" if there is something
241 * after the missing operator.
245 S_no_op(pTHX_ char *what, char *s)
247 char *oldbp = PL_bufptr;
248 bool is_first = (PL_oldbufptr == PL_linestart);
254 yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
256 Perl_warn(aTHX_ "\t(Missing semicolon on previous line?)\n");
257 else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
259 for (t = PL_oldoldbufptr; *t && (isALNUM_lazy_if(t,UTF) || *t == ':'); t++) ;
260 if (t < PL_bufptr && isSPACE(*t))
261 Perl_warn(aTHX_ "\t(Do you need to predeclare %.*s?)\n",
262 t - PL_oldoldbufptr, PL_oldoldbufptr);
266 Perl_warn(aTHX_ "\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
273 * Complain about missing quote/regexp/heredoc terminator.
274 * If it's called with (char *)NULL then it cauterizes the line buffer.
275 * If we're in a delimited string and the delimiter is a control
276 * character, it's reformatted into a two-char sequence like ^C.
281 S_missingterm(pTHX_ char *s)
286 char *nl = strrchr(s,'\n');
292 iscntrl(PL_multi_close)
294 PL_multi_close < 32 || PL_multi_close == 127
298 tmpbuf[1] = toCTRL(PL_multi_close);
304 *tmpbuf = PL_multi_close;
308 q = strchr(s,'"') ? '\'' : '"';
309 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
317 Perl_deprecate(pTHX_ char *s)
319 if (ckWARN(WARN_DEPRECATED))
320 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "Use of %s is deprecated", s);
324 Perl_deprecate_old(pTHX_ char *s)
326 /* This function should NOT be called for any new deprecated warnings */
327 /* Use Perl_deprecate instead */
329 /* It is here to maintain backward compatibility with the pre-5.8 */
330 /* warnings category hierarchy. The "deprecated" category used to */
331 /* live under the "syntax" category. It is now a top-level category */
332 /* in its own right. */
334 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
335 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
336 "Use of %s is deprecated", s);
341 * Deprecate a comma-less variable list.
347 deprecate_old("comma-less variable list");
351 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
352 * utf16-to-utf8-reversed.
355 #ifdef PERL_CR_FILTER
359 register char *s = SvPVX(sv);
360 register char *e = s + SvCUR(sv);
361 /* outer loop optimized to do nothing if there are no CR-LFs */
363 if (*s++ == '\r' && *s == '\n') {
364 /* hit a CR-LF, need to copy the rest */
365 register char *d = s - 1;
368 if (*s == '\r' && s[1] == '\n')
379 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
381 I32 count = FILTER_READ(idx+1, sv, maxlen);
382 if (count > 0 && !maxlen)
390 * Initialize variables. Uses the Perl save_stack to save its state (for
391 * recursive calls to the parser).
395 Perl_lex_start(pTHX_ SV *line)
400 SAVEI32(PL_lex_dojoin);
401 SAVEI32(PL_lex_brackets);
402 SAVEI32(PL_lex_casemods);
403 SAVEI32(PL_lex_starts);
404 SAVEI32(PL_lex_state);
405 SAVEVPTR(PL_lex_inpat);
406 SAVEI32(PL_lex_inwhat);
407 if (PL_lex_state == LEX_KNOWNEXT) {
408 I32 toke = PL_nexttoke;
409 while (--toke >= 0) {
410 SAVEI32(PL_nexttype[toke]);
411 SAVEVPTR(PL_nextval[toke]);
413 SAVEI32(PL_nexttoke);
415 SAVECOPLINE(PL_curcop);
418 SAVEPPTR(PL_oldbufptr);
419 SAVEPPTR(PL_oldoldbufptr);
420 SAVEPPTR(PL_last_lop);
421 SAVEPPTR(PL_last_uni);
422 SAVEPPTR(PL_linestart);
423 SAVESPTR(PL_linestr);
424 SAVEPPTR(PL_lex_brackstack);
425 SAVEPPTR(PL_lex_casestack);
426 SAVEDESTRUCTOR_X(restore_rsfp, PL_rsfp);
427 SAVESPTR(PL_lex_stuff);
428 SAVEI32(PL_lex_defer);
429 SAVEI32(PL_sublex_info.sub_inwhat);
430 SAVESPTR(PL_lex_repl);
432 SAVEINT(PL_lex_expect);
434 PL_lex_state = LEX_NORMAL;
438 New(899, PL_lex_brackstack, 120, char);
439 New(899, PL_lex_casestack, 12, char);
440 SAVEFREEPV(PL_lex_brackstack);
441 SAVEFREEPV(PL_lex_casestack);
443 *PL_lex_casestack = '\0';
446 PL_lex_stuff = Nullsv;
447 PL_lex_repl = Nullsv;
451 PL_sublex_info.sub_inwhat = 0;
453 if (SvREADONLY(PL_linestr))
454 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
455 s = SvPV(PL_linestr, len);
456 if (len && s[len-1] != ';') {
457 if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
458 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
459 sv_catpvn(PL_linestr, "\n;", 2);
461 SvTEMP_off(PL_linestr);
462 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
463 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
464 PL_last_lop = PL_last_uni = Nullch;
470 * Finalizer for lexing operations. Must be called when the parser is
471 * done with the lexer.
477 PL_doextract = FALSE;
482 * This subroutine has nothing to do with tilting, whether at windmills
483 * or pinball tables. Its name is short for "increment line". It
484 * increments the current line number in CopLINE(PL_curcop) and checks
485 * to see whether the line starts with a comment of the form
486 * # line 500 "foo.pm"
487 * If so, it sets the current line number and file to the values in the comment.
491 S_incline(pTHX_ char *s)
498 CopLINE_inc(PL_curcop);
501 while (SPACE_OR_TAB(*s)) s++;
502 if (strnEQ(s, "line", 4))
506 if (SPACE_OR_TAB(*s))
510 while (SPACE_OR_TAB(*s)) s++;
516 while (SPACE_OR_TAB(*s))
518 if (*s == '"' && (t = strchr(s+1, '"'))) {
523 for (t = s; !isSPACE(*t); t++) ;
526 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
528 if (*e != '\n' && *e != '\0')
529 return; /* false alarm */
534 CopFILE_free(PL_curcop);
535 CopFILE_set(PL_curcop, s);
538 CopLINE_set(PL_curcop, atoi(n)-1);
543 * Called to gobble the appropriate amount and type of whitespace.
544 * Skips comments as well.
548 S_skipspace(pTHX_ register char *s)
550 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
551 while (s < PL_bufend && SPACE_OR_TAB(*s))
557 SSize_t oldprevlen, oldoldprevlen;
558 SSize_t oldloplen = 0, oldunilen = 0;
559 while (s < PL_bufend && isSPACE(*s)) {
560 if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
565 if (s < PL_bufend && *s == '#') {
566 while (s < PL_bufend && *s != '\n')
570 if (PL_in_eval && !PL_rsfp) {
577 /* only continue to recharge the buffer if we're at the end
578 * of the buffer, we're not reading from a source filter, and
579 * we're in normal lexing mode
581 if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat ||
582 PL_lex_state == LEX_FORMLINE)
585 /* try to recharge the buffer */
586 if ((s = filter_gets(PL_linestr, PL_rsfp,
587 (prevlen = SvCUR(PL_linestr)))) == Nullch)
589 /* end of file. Add on the -p or -n magic */
590 if (PL_minus_n || PL_minus_p) {
591 sv_setpv(PL_linestr,PL_minus_p ?
592 ";}continue{print or die qq(-p destination: $!\\n)" :
594 sv_catpv(PL_linestr,";}");
595 PL_minus_n = PL_minus_p = 0;
598 sv_setpv(PL_linestr,";");
600 /* reset variables for next time we lex */
601 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
603 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
604 PL_last_lop = PL_last_uni = Nullch;
606 /* Close the filehandle. Could be from -P preprocessor,
607 * STDIN, or a regular file. If we were reading code from
608 * STDIN (because the commandline held no -e or filename)
609 * then we don't close it, we reset it so the code can
610 * read from STDIN too.
613 if (PL_preprocess && !PL_in_eval)
614 (void)PerlProc_pclose(PL_rsfp);
615 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
616 PerlIO_clearerr(PL_rsfp);
618 (void)PerlIO_close(PL_rsfp);
623 /* not at end of file, so we only read another line */
624 /* make corresponding updates to old pointers, for yyerror() */
625 oldprevlen = PL_oldbufptr - PL_bufend;
626 oldoldprevlen = PL_oldoldbufptr - PL_bufend;
628 oldunilen = PL_last_uni - PL_bufend;
630 oldloplen = PL_last_lop - PL_bufend;
631 PL_linestart = PL_bufptr = s + prevlen;
632 PL_bufend = s + SvCUR(PL_linestr);
634 PL_oldbufptr = s + oldprevlen;
635 PL_oldoldbufptr = s + oldoldprevlen;
637 PL_last_uni = s + oldunilen;
639 PL_last_lop = s + oldloplen;
642 /* debugger active and we're not compiling the debugger code,
643 * so store the line into the debugger's array of lines
645 if (PERLDB_LINE && PL_curstash != PL_debstash) {
646 SV *sv = NEWSV(85,0);
648 sv_upgrade(sv, SVt_PVMG);
649 sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
652 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
659 * Check the unary operators to ensure there's no ambiguity in how they're
660 * used. An ambiguous piece of code would be:
662 * This doesn't mean rand() + 5. Because rand() is a unary operator,
663 * the +5 is its argument.
672 if (PL_oldoldbufptr != PL_last_uni)
674 while (isSPACE(*PL_last_uni))
676 for (s = PL_last_uni; isALNUM_lazy_if(s,UTF) || *s == '-'; s++) ;
677 if ((t = strchr(s, '(')) && t < PL_bufptr)
679 if (ckWARN_d(WARN_AMBIGUOUS)){
682 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
683 "Warning: Use of \"%s\" without parens is ambiguous",
690 * LOP : macro to build a list operator. Its behaviour has been replaced
691 * with a subroutine, S_lop() for which LOP is just another name.
694 #define LOP(f,x) return lop(f,x,s)
698 * Build a list operator (or something that might be one). The rules:
699 * - if we have a next token, then it's a list operator [why?]
700 * - if the next thing is an opening paren, then it's a function
701 * - else it's a list operator
705 S_lop(pTHX_ I32 f, int x, char *s)
712 PL_last_lop = PL_oldbufptr;
727 * When the lexer realizes it knows the next token (for instance,
728 * it is reordering tokens for the parser) then it can call S_force_next
729 * to know what token to return the next time the lexer is called. Caller
730 * will need to set PL_nextval[], and possibly PL_expect to ensure the lexer
731 * handles the token correctly.
735 S_force_next(pTHX_ I32 type)
737 PL_nexttype[PL_nexttoke] = type;
739 if (PL_lex_state != LEX_KNOWNEXT) {
740 PL_lex_defer = PL_lex_state;
741 PL_lex_expect = PL_expect;
742 PL_lex_state = LEX_KNOWNEXT;
748 * When the lexer knows the next thing is a word (for instance, it has
749 * just seen -> and it knows that the next char is a word char, then
750 * it calls S_force_word to stick the next word into the PL_next lookahead.
753 * char *start : buffer position (must be within PL_linestr)
754 * int token : PL_next will be this type of bare word (e.g., METHOD,WORD)
755 * int check_keyword : if true, Perl checks to make sure the word isn't
756 * a keyword (do this if the word is a label, e.g. goto FOO)
757 * int allow_pack : if true, : characters will also be allowed (require,
759 * int allow_initial_tick : used by the "sub" lexer only.
763 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
768 start = skipspace(start);
770 if (isIDFIRST_lazy_if(s,UTF) ||
771 (allow_pack && *s == ':') ||
772 (allow_initial_tick && *s == '\'') )
774 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
775 if (check_keyword && keyword(PL_tokenbuf, len))
777 if (token == METHOD) {
782 PL_expect = XOPERATOR;
785 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(PL_tokenbuf,0));
786 PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
794 * Called when the lexer wants $foo *foo &foo etc, but the program
795 * text only contains the "foo" portion. The first argument is a pointer
796 * to the "foo", and the second argument is the type symbol to prefix.
797 * Forces the next token to be a "WORD".
798 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
802 S_force_ident(pTHX_ register char *s, int kind)
805 OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
806 PL_nextval[PL_nexttoke].opval = o;
809 o->op_private = OPpCONST_ENTERED;
810 /* XXX see note in pp_entereval() for why we forgo typo
811 warnings if the symbol must be introduced in an eval.
813 gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
814 kind == '$' ? SVt_PV :
815 kind == '@' ? SVt_PVAV :
816 kind == '%' ? SVt_PVHV :
824 Perl_str_to_version(pTHX_ SV *sv)
829 char *start = SvPVx(sv,len);
830 bool utf = SvUTF8(sv) ? TRUE : FALSE;
831 char *end = start + len;
832 while (start < end) {
836 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
841 retval += ((NV)n)/nshift;
850 * Forces the next token to be a version number.
851 * If the next token appears to be an invalid version number, (e.g. "v2b"),
852 * and if "guessing" is TRUE, then no new token is created (and the caller
853 * must use an alternative parsing method).
857 S_force_version(pTHX_ char *s, int guessing)
859 OP *version = Nullop;
868 while (isDIGIT(*d) || *d == '_' || *d == '.')
870 if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
872 s = scan_num(s, &yylval);
873 version = yylval.opval;
874 ver = cSVOPx(version)->op_sv;
875 if (SvPOK(ver) && !SvNIOK(ver)) {
876 (void)SvUPGRADE(ver, SVt_PVNV);
877 SvNVX(ver) = str_to_version(ver);
878 SvNOK_on(ver); /* hint that it is a version */
885 /* NOTE: The parser sees the package name and the VERSION swapped */
886 PL_nextval[PL_nexttoke].opval = version;
894 * Tokenize a quoted string passed in as an SV. It finds the next
895 * chunk, up to end of string or a backslash. It may make a new
896 * SV containing that chunk (if HINT_NEW_STRING is on). It also
901 S_tokeq(pTHX_ SV *sv)
912 s = SvPV_force(sv, len);
913 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
916 while (s < send && *s != '\\')
921 if ( PL_hints & HINT_NEW_STRING ) {
922 pv = sv_2mortal(newSVpvn(SvPVX(pv), len));
928 if (s + 1 < send && (s[1] == '\\'))
929 s++; /* all that, just for this */
934 SvCUR_set(sv, d - SvPVX(sv));
936 if ( PL_hints & HINT_NEW_STRING )
937 return new_constant(NULL, 0, "q", sv, pv, "q");
942 * Now come three functions related to double-quote context,
943 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
944 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
945 * interact with PL_lex_state, and create fake ( ... ) argument lists
946 * to handle functions and concatenation.
947 * They assume that whoever calls them will be setting up a fake
948 * join call, because each subthing puts a ',' after it. This lets
951 * join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
953 * (I'm not sure whether the spurious commas at the end of lcfirst's
954 * arguments and join's arguments are created or not).
959 * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST).
961 * Pattern matching will set PL_lex_op to the pattern-matching op to
962 * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise).
964 * OP_CONST and OP_READLINE are easy--just make the new op and return.
966 * Everything else becomes a FUNC.
968 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
969 * had an OP_CONST or OP_READLINE). This just sets us up for a
970 * call to S_sublex_push().
976 register I32 op_type = yylval.ival;
978 if (op_type == OP_NULL) {
979 yylval.opval = PL_lex_op;
983 if (op_type == OP_CONST || op_type == OP_READLINE) {
984 SV *sv = tokeq(PL_lex_stuff);
986 if (SvTYPE(sv) == SVt_PVIV) {
987 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
993 nsv = newSVpvn(p, len);
999 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
1000 PL_lex_stuff = Nullsv;
1004 PL_sublex_info.super_state = PL_lex_state;
1005 PL_sublex_info.sub_inwhat = op_type;
1006 PL_sublex_info.sub_op = PL_lex_op;
1007 PL_lex_state = LEX_INTERPPUSH;
1011 yylval.opval = PL_lex_op;
1021 * Create a new scope to save the lexing state. The scope will be
1022 * ended in S_sublex_done. Returns a '(', starting the function arguments
1023 * to the uc, lc, etc. found before.
1024 * Sets PL_lex_state to LEX_INTERPCONCAT.
1032 PL_lex_state = PL_sublex_info.super_state;
1033 SAVEI32(PL_lex_dojoin);
1034 SAVEI32(PL_lex_brackets);
1035 SAVEI32(PL_lex_casemods);
1036 SAVEI32(PL_lex_starts);
1037 SAVEI32(PL_lex_state);
1038 SAVEVPTR(PL_lex_inpat);
1039 SAVEI32(PL_lex_inwhat);
1040 SAVECOPLINE(PL_curcop);
1041 SAVEPPTR(PL_bufptr);
1042 SAVEPPTR(PL_bufend);
1043 SAVEPPTR(PL_oldbufptr);
1044 SAVEPPTR(PL_oldoldbufptr);
1045 SAVEPPTR(PL_last_lop);
1046 SAVEPPTR(PL_last_uni);
1047 SAVEPPTR(PL_linestart);
1048 SAVESPTR(PL_linestr);
1049 SAVEPPTR(PL_lex_brackstack);
1050 SAVEPPTR(PL_lex_casestack);
1052 PL_linestr = PL_lex_stuff;
1053 PL_lex_stuff = Nullsv;
1055 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
1056 = SvPVX(PL_linestr);
1057 PL_bufend += SvCUR(PL_linestr);
1058 PL_last_lop = PL_last_uni = Nullch;
1059 SAVEFREESV(PL_linestr);
1061 PL_lex_dojoin = FALSE;
1062 PL_lex_brackets = 0;
1063 New(899, PL_lex_brackstack, 120, char);
1064 New(899, PL_lex_casestack, 12, char);
1065 SAVEFREEPV(PL_lex_brackstack);
1066 SAVEFREEPV(PL_lex_casestack);
1067 PL_lex_casemods = 0;
1068 *PL_lex_casestack = '\0';
1070 PL_lex_state = LEX_INTERPCONCAT;
1071 CopLINE_set(PL_curcop, PL_multi_start);
1073 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1074 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1075 PL_lex_inpat = PL_sublex_info.sub_op;
1077 PL_lex_inpat = Nullop;
1084 * Restores lexer state after a S_sublex_push.
1090 if (!PL_lex_starts++) {
1091 SV *sv = newSVpvn("",0);
1092 if (SvUTF8(PL_linestr))
1094 PL_expect = XOPERATOR;
1095 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1099 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
1100 PL_lex_state = LEX_INTERPCASEMOD;
1104 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1105 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1106 PL_linestr = PL_lex_repl;
1108 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1109 PL_bufend += SvCUR(PL_linestr);
1110 PL_last_lop = PL_last_uni = Nullch;
1111 SAVEFREESV(PL_linestr);
1112 PL_lex_dojoin = FALSE;
1113 PL_lex_brackets = 0;
1114 PL_lex_casemods = 0;
1115 *PL_lex_casestack = '\0';
1117 if (SvEVALED(PL_lex_repl)) {
1118 PL_lex_state = LEX_INTERPNORMAL;
1120 /* we don't clear PL_lex_repl here, so that we can check later
1121 whether this is an evalled subst; that means we rely on the
1122 logic to ensure sublex_done() is called again only via the
1123 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1126 PL_lex_state = LEX_INTERPCONCAT;
1127 PL_lex_repl = Nullsv;
1133 PL_bufend = SvPVX(PL_linestr);
1134 PL_bufend += SvCUR(PL_linestr);
1135 PL_expect = XOPERATOR;
1136 PL_sublex_info.sub_inwhat = 0;
1144 Extracts a pattern, double-quoted string, or transliteration. This
1147 It looks at lex_inwhat and PL_lex_inpat to find out whether it's
1148 processing a pattern (PL_lex_inpat is true), a transliteration
1149 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
1151 Returns a pointer to the character scanned up to. Iff this is
1152 advanced from the start pointer supplied (ie if anything was
1153 successfully parsed), will leave an OP for the substring scanned
1154 in yylval. Caller must intuit reason for not parsing further
1155 by looking at the next characters herself.
1159 double-quoted style: \r and \n
1160 regexp special ones: \D \s
1162 backrefs: \1 (deprecated in substitution replacements)
1163 case and quoting: \U \Q \E
1164 stops on @ and $, but not for $ as tail anchor
1166 In transliterations:
1167 characters are VERY literal, except for - not at the start or end
1168 of the string, which indicates a range. scan_const expands the
1169 range to the full set of intermediate characters.
1171 In double-quoted strings:
1173 double-quoted style: \r and \n
1175 backrefs: \1 (deprecated)
1176 case and quoting: \U \Q \E
1179 scan_const does *not* construct ops to handle interpolated strings.
1180 It stops processing as soon as it finds an embedded $ or @ variable
1181 and leaves it to the caller to work out what's going on.
1183 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
1185 $ in pattern could be $foo or could be tail anchor. Assumption:
1186 it's a tail anchor if $ is the last thing in the string, or if it's
1187 followed by one of ")| \n\t"
1189 \1 (backreferences) are turned into $1
1191 The structure of the code is
1192 while (there's a character to process) {
1193 handle transliteration ranges
1194 skip regexp comments
1195 skip # initiated comments in //x patterns
1196 check for embedded @foo
1197 check for embedded scalars
1199 leave intact backslashes from leave (below)
1200 deprecate \1 in strings and sub replacements
1201 handle string-changing backslashes \l \U \Q \E, etc.
1202 switch (what was escaped) {
1203 handle - in a transliteration (becomes a literal -)
1204 handle \132 octal characters
1205 handle 0x15 hex characters
1206 handle \cV (control V)
1207 handle printf backslashes (\f, \r, \n, etc)
1209 } (end if backslash)
1210 } (end while character to read)
1215 S_scan_const(pTHX_ char *start)
1217 register char *send = PL_bufend; /* end of the constant */
1218 SV *sv = NEWSV(93, send - start); /* sv for the constant */
1219 register char *s = start; /* start of the constant */
1220 register char *d = SvPVX(sv); /* destination for copies */
1221 bool dorange = FALSE; /* are we in a translit range? */
1222 bool didrange = FALSE; /* did we just finish a range? */
1223 I32 has_utf8 = FALSE; /* Output constant is UTF8 */
1224 I32 this_utf8 = UTF; /* The source string is assumed to be UTF8 */
1227 const char *leaveit = /* set of acceptably-backslashed characters */
1229 ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
1232 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1233 /* If we are doing a trans and we know we want UTF8 set expectation */
1234 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
1235 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1239 while (s < send || dorange) {
1240 /* get transliterations out of the way (they're most literal) */
1241 if (PL_lex_inwhat == OP_TRANS) {
1242 /* expand a range A-Z to the full set of characters. AIE! */
1244 I32 i; /* current expanded character */
1245 I32 min; /* first character in range */
1246 I32 max; /* last character in range */
1249 char *c = (char*)utf8_hop((U8*)d, -1);
1253 *c = (char)UTF_TO_NATIVE(0xff);
1254 /* mark the range as done, and continue */
1260 i = d - SvPVX(sv); /* remember current offset */
1261 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
1262 d = SvPVX(sv) + i; /* refresh d after realloc */
1263 d -= 2; /* eat the first char and the - */
1265 min = (U8)*d; /* first char in range */
1266 max = (U8)d[1]; /* last char in range */
1270 "Invalid [] range \"%c-%c\" in transliteration operator",
1271 (char)min, (char)max);
1275 if ((isLOWER(min) && isLOWER(max)) ||
1276 (isUPPER(min) && isUPPER(max))) {
1278 for (i = min; i <= max; i++)
1280 *d++ = NATIVE_TO_NEED(has_utf8,i);
1282 for (i = min; i <= max; i++)
1284 *d++ = NATIVE_TO_NEED(has_utf8,i);
1289 for (i = min; i <= max; i++)
1292 /* mark the range as done, and continue */
1298 /* range begins (ignore - as first or last char) */
1299 else if (*s == '-' && s+1 < send && s != start) {
1301 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
1304 *d++ = (char)UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */
1316 /* if we get here, we're not doing a transliteration */
1318 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
1319 except for the last char, which will be done separately. */
1320 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
1322 while (s < send && *s != ')')
1323 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1325 else if (s[2] == '{' /* This should match regcomp.c */
1326 || ((s[2] == 'p' || s[2] == '?') && s[3] == '{'))
1329 char *regparse = s + (s[2] == '{' ? 3 : 4);
1332 while (count && (c = *regparse)) {
1333 if (c == '\\' && regparse[1])
1341 if (*regparse != ')') {
1342 regparse--; /* Leave one char for continuation. */
1343 yyerror("Sequence (?{...}) not terminated or not {}-balanced");
1345 while (s < regparse)
1346 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1350 /* likewise skip #-initiated comments in //x patterns */
1351 else if (*s == '#' && PL_lex_inpat &&
1352 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
1353 while (s+1 < send && *s != '\n')
1354 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1357 /* check for embedded arrays
1358 (@foo, @:foo, @'foo, @{foo}, @$foo, @+, @-)
1360 else if (*s == '@' && s[1]
1361 && (isALNUM_lazy_if(s+1,UTF) || strchr(":'{$+-", s[1])))
1364 /* check for embedded scalars. only stop if we're sure it's a
1367 else if (*s == '$') {
1368 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
1370 if (s + 1 < send && !strchr("()| \r\n\t", s[1]))
1371 break; /* in regexp, $ might be tail anchor */
1374 /* End of else if chain - OP_TRANS rejoin rest */
1377 if (*s == '\\' && s+1 < send) {
1380 /* some backslashes we leave behind */
1381 if (*leaveit && *s && strchr(leaveit, *s)) {
1382 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
1383 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1387 /* deprecate \1 in strings and substitution replacements */
1388 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1389 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1391 if (ckWARN(WARN_SYNTAX))
1392 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
1397 /* string-change backslash escapes */
1398 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1403 /* if we get here, it's either a quoted -, or a digit */
1406 /* quoted - in transliterations */
1408 if (PL_lex_inwhat == OP_TRANS) {
1415 if (ckWARN(WARN_MISC) &&
1418 Perl_warner(aTHX_ packWARN(WARN_MISC),
1419 "Unrecognized escape \\%c passed through",
1421 /* default action is to copy the quoted character */
1422 goto default_action;
1425 /* \132 indicates an octal constant */
1426 case '0': case '1': case '2': case '3':
1427 case '4': case '5': case '6': case '7':
1431 uv = grok_oct(s, &len, &flags, NULL);
1434 goto NUM_ESCAPE_INSERT;
1436 /* \x24 indicates a hex constant */
1440 char* e = strchr(s, '}');
1441 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
1442 PERL_SCAN_DISALLOW_PREFIX;
1447 yyerror("Missing right brace on \\x{}");
1451 uv = grok_hex(s, &len, &flags, NULL);
1457 I32 flags = PERL_SCAN_DISALLOW_PREFIX;
1458 uv = grok_hex(s, &len, &flags, NULL);
1464 /* Insert oct or hex escaped character.
1465 * There will always enough room in sv since such
1466 * escapes will be longer than any UTF-8 sequence
1467 * they can end up as. */
1469 /* We need to map to chars to ASCII before doing the tests
1472 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(uv))) {
1473 if (!has_utf8 && uv > 255) {
1474 /* Might need to recode whatever we have
1475 * accumulated so far if it contains any
1478 * (Can't we keep track of that and avoid
1479 * this rescan? --jhi)
1483 for (c = (U8 *) SvPVX(sv); c < (U8 *)d; c++) {
1484 if (!NATIVE_IS_INVARIANT(*c)) {
1489 STRLEN offset = d - SvPVX(sv);
1491 d = SvGROW(sv, SvLEN(sv) + hicount + 1) + offset;
1495 while (src >= (U8 *)SvPVX(sv)) {
1496 if (!NATIVE_IS_INVARIANT(*src)) {
1497 U8 ch = NATIVE_TO_ASCII(*src);
1498 *dst-- = UTF8_EIGHT_BIT_LO(ch);
1499 *dst-- = UTF8_EIGHT_BIT_HI(ch);
1509 if (has_utf8 || uv > 255) {
1510 d = (char*)uvchr_to_utf8((U8*)d, uv);
1512 if (PL_lex_inwhat == OP_TRANS &&
1513 PL_sublex_info.sub_op) {
1514 PL_sublex_info.sub_op->op_private |=
1515 (PL_lex_repl ? OPpTRANS_FROM_UTF
1528 /* \N{LATIN SMALL LETTER A} is a named character */
1532 char* e = strchr(s, '}');
1538 yyerror("Missing right brace on \\N{}");
1542 res = newSVpvn(s + 1, e - s - 1);
1543 res = new_constant( Nullch, 0, "charnames",
1544 res, Nullsv, "\\N{...}" );
1546 sv_utf8_upgrade(res);
1547 str = SvPV(res,len);
1548 #ifdef EBCDIC_NEVER_MIND
1549 /* charnames uses pack U and that has been
1550 * recently changed to do the below uni->native
1551 * mapping, so this would be redundant (and wrong,
1552 * the code point would be doubly converted).
1553 * But leave this in just in case the pack U change
1554 * gets revoked, but the semantics is still
1555 * desireable for charnames. --jhi */
1557 UV uv = utf8_to_uvchr((U8*)str, 0);
1560 U8 tmpbuf[UTF8_MAXLEN+1], *d;
1562 d = uvchr_to_utf8(tmpbuf, UNI_TO_NATIVE(uv));
1563 sv_setpvn(res, (char *)tmpbuf, d - tmpbuf);
1564 str = SvPV(res, len);
1568 if (!has_utf8 && SvUTF8(res)) {
1569 char *ostart = SvPVX(sv);
1570 SvCUR_set(sv, d - ostart);
1573 sv_utf8_upgrade(sv);
1574 /* this just broke our allocation above... */
1575 SvGROW(sv, send - start);
1576 d = SvPVX(sv) + SvCUR(sv);
1579 if (len > e - s + 4) { /* I _guess_ 4 is \N{} --jhi */
1580 char *odest = SvPVX(sv);
1582 SvGROW(sv, (SvLEN(sv) + len - (e - s + 4)));
1583 d = SvPVX(sv) + (d - odest);
1585 Copy(str, d, len, char);
1592 yyerror("Missing braces on \\N{}");
1595 /* \c is a control character */
1604 *d++ = NATIVE_TO_NEED(has_utf8,toCTRL(c));
1608 /* printf-style backslashes, formfeeds, newlines, etc */
1610 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
1613 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
1616 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
1619 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
1622 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
1625 *d++ = ASCII_TO_NEED(has_utf8,'\033');
1628 *d++ = ASCII_TO_NEED(has_utf8,'\007');
1634 } /* end if (backslash) */
1637 /* If we started with encoded form, or already know we want it
1638 and then encode the next character */
1639 if ((has_utf8 || this_utf8) && !NATIVE_IS_INVARIANT((U8)(*s))) {
1641 UV uv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
1642 STRLEN need = UNISKIP(NATIVE_TO_UNI(uv));
1645 /* encoded value larger than old, need extra space (NOTE: SvCUR() not set here) */
1646 STRLEN off = d - SvPVX(sv);
1647 d = SvGROW(sv, SvLEN(sv) + (need-len)) + off;
1649 d = (char*)uvchr_to_utf8((U8*)d, uv);
1653 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1655 } /* while loop to process each character */
1657 /* terminate the string and set up the sv */
1659 SvCUR_set(sv, d - SvPVX(sv));
1660 if (SvCUR(sv) >= SvLEN(sv))
1661 Perl_croak(aTHX_ "panic: constant overflowed allocated space");
1664 if (PL_encoding && !has_utf8) {
1665 sv_recode_to_utf8(sv, PL_encoding);
1670 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1671 PL_sublex_info.sub_op->op_private |=
1672 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1676 /* shrink the sv if we allocated more than we used */
1677 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1678 SvLEN_set(sv, SvCUR(sv) + 1);
1679 Renew(SvPVX(sv), SvLEN(sv), char);
1682 /* return the substring (via yylval) only if we parsed anything */
1683 if (s > PL_bufptr) {
1684 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1685 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1687 ( PL_lex_inwhat == OP_TRANS
1689 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1692 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1699 * Returns TRUE if there's more to the expression (e.g., a subscript),
1702 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
1704 * ->[ and ->{ return TRUE
1705 * { and [ outside a pattern are always subscripts, so return TRUE
1706 * if we're outside a pattern and it's not { or [, then return FALSE
1707 * if we're in a pattern and the first char is a {
1708 * {4,5} (any digits around the comma) returns FALSE
1709 * if we're in a pattern and the first char is a [
1711 * [SOMETHING] has a funky algorithm to decide whether it's a
1712 * character class or not. It has to deal with things like
1713 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
1714 * anything else returns TRUE
1717 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1720 S_intuit_more(pTHX_ register char *s)
1722 if (PL_lex_brackets)
1724 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1726 if (*s != '{' && *s != '[')
1731 /* In a pattern, so maybe we have {n,m}. */
1748 /* On the other hand, maybe we have a character class */
1751 if (*s == ']' || *s == '^')
1754 /* this is terrifying, and it works */
1755 int weight = 2; /* let's weigh the evidence */
1757 unsigned char un_char = 255, last_un_char;
1758 char *send = strchr(s,']');
1759 char tmpbuf[sizeof PL_tokenbuf * 4];
1761 if (!send) /* has to be an expression */
1764 Zero(seen,256,char);
1767 else if (isDIGIT(*s)) {
1769 if (isDIGIT(s[1]) && s[2] == ']')
1775 for (; s < send; s++) {
1776 last_un_char = un_char;
1777 un_char = (unsigned char)*s;
1782 weight -= seen[un_char] * 10;
1783 if (isALNUM_lazy_if(s+1,UTF)) {
1784 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1785 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1790 else if (*s == '$' && s[1] &&
1791 strchr("[#!%*<>()-=",s[1])) {
1792 if (/*{*/ strchr("])} =",s[2]))
1801 if (strchr("wds]",s[1]))
1803 else if (seen['\''] || seen['"'])
1805 else if (strchr("rnftbxcav",s[1]))
1807 else if (isDIGIT(s[1])) {
1809 while (s[1] && isDIGIT(s[1]))
1819 if (strchr("aA01! ",last_un_char))
1821 if (strchr("zZ79~",s[1]))
1823 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1824 weight -= 5; /* cope with negative subscript */
1827 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1828 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1833 if (keyword(tmpbuf, d - tmpbuf))
1836 if (un_char == last_un_char + 1)
1838 weight -= seen[un_char];
1843 if (weight >= 0) /* probably a character class */
1853 * Does all the checking to disambiguate
1855 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
1856 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
1858 * First argument is the stuff after the first token, e.g. "bar".
1860 * Not a method if bar is a filehandle.
1861 * Not a method if foo is a subroutine prototyped to take a filehandle.
1862 * Not a method if it's really "Foo $bar"
1863 * Method if it's "foo $bar"
1864 * Not a method if it's really "print foo $bar"
1865 * Method if it's really "foo package::" (interpreted as package->foo)
1866 * Not a method if bar is known to be a subroutne ("sub bar; foo bar")
1867 * Not a method if bar is a filehandle or package, but is quoted with
1872 S_intuit_method(pTHX_ char *start, GV *gv)
1874 char *s = start + (*start == '$');
1875 char tmpbuf[sizeof PL_tokenbuf];
1883 if ((cv = GvCVu(gv))) {
1884 char *proto = SvPVX(cv);
1894 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1895 /* start is the beginning of the possible filehandle/object,
1896 * and s is the end of it
1897 * tmpbuf is a copy of it
1900 if (*start == '$') {
1901 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1906 return *s == '(' ? FUNCMETH : METHOD;
1908 if (!keyword(tmpbuf, len)) {
1909 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1914 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1915 if (indirgv && GvCVu(indirgv))
1917 /* filehandle or package name makes it a method */
1918 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1920 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1921 return 0; /* no assumptions -- "=>" quotes bearword */
1923 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1924 newSVpvn(tmpbuf,len));
1925 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1929 return *s == '(' ? FUNCMETH : METHOD;
1937 * Return a string of Perl code to load the debugger. If PERL5DB
1938 * is set, it will return the contents of that, otherwise a
1939 * compile-time require of perl5db.pl.
1946 char *pdb = PerlEnv_getenv("PERL5DB");
1950 SETERRNO(0,SS$_NORMAL);
1951 return "BEGIN { require 'perl5db.pl' }";
1957 /* Encoded script support. filter_add() effectively inserts a
1958 * 'pre-processing' function into the current source input stream.
1959 * Note that the filter function only applies to the current source file
1960 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1962 * The datasv parameter (which may be NULL) can be used to pass
1963 * private data to this instance of the filter. The filter function
1964 * can recover the SV using the FILTER_DATA macro and use it to
1965 * store private buffers and state information.
1967 * The supplied datasv parameter is upgraded to a PVIO type
1968 * and the IoDIRP/IoANY field is used to store the function pointer,
1969 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
1970 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1971 * private use must be set using malloc'd pointers.
1975 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
1980 if (!PL_rsfp_filters)
1981 PL_rsfp_filters = newAV();
1983 datasv = NEWSV(255,0);
1984 if (!SvUPGRADE(datasv, SVt_PVIO))
1985 Perl_die(aTHX_ "Can't upgrade filter_add data to SVt_PVIO");
1986 IoANY(datasv) = (void *)funcp; /* stash funcp into spare field */
1987 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
1988 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
1989 (void*)funcp, SvPV_nolen(datasv)));
1990 av_unshift(PL_rsfp_filters, 1);
1991 av_store(PL_rsfp_filters, 0, datasv) ;
1996 /* Delete most recently added instance of this filter function. */
1998 Perl_filter_del(pTHX_ filter_t funcp)
2001 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", (void*)funcp));
2002 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
2004 /* if filter is on top of stack (usual case) just pop it off */
2005 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
2006 if (IoANY(datasv) == (void *)funcp) {
2007 IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
2008 IoANY(datasv) = (void *)NULL;
2009 sv_free(av_pop(PL_rsfp_filters));
2013 /* we need to search for the correct entry and clear it */
2014 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
2018 /* Invoke the n'th filter function for the current rsfp. */
2020 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
2023 /* 0 = read one text line */
2028 if (!PL_rsfp_filters)
2030 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
2031 /* Provide a default input filter to make life easy. */
2032 /* Note that we append to the line. This is handy. */
2033 DEBUG_P(PerlIO_printf(Perl_debug_log,
2034 "filter_read %d: from rsfp\n", idx));
2038 int old_len = SvCUR(buf_sv) ;
2040 /* ensure buf_sv is large enough */
2041 SvGROW(buf_sv, old_len + maxlen) ;
2042 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
2043 if (PerlIO_error(PL_rsfp))
2044 return -1; /* error */
2046 return 0 ; /* end of file */
2048 SvCUR_set(buf_sv, old_len + len) ;
2051 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
2052 if (PerlIO_error(PL_rsfp))
2053 return -1; /* error */
2055 return 0 ; /* end of file */
2058 return SvCUR(buf_sv);
2060 /* Skip this filter slot if filter has been deleted */
2061 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
2062 DEBUG_P(PerlIO_printf(Perl_debug_log,
2063 "filter_read %d: skipped (filter deleted)\n",
2065 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
2067 /* Get function pointer hidden within datasv */
2068 funcp = (filter_t)IoANY(datasv);
2069 DEBUG_P(PerlIO_printf(Perl_debug_log,
2070 "filter_read %d: via function %p (%s)\n",
2071 idx, (void*)funcp, SvPV_nolen(datasv)));
2072 /* Call function. The function is expected to */
2073 /* call "FILTER_READ(idx+1, buf_sv)" first. */
2074 /* Return: <0:error, =0:eof, >0:not eof */
2075 return (*funcp)(aTHX_ idx, buf_sv, maxlen);
2079 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
2081 #ifdef PERL_CR_FILTER
2082 if (!PL_rsfp_filters) {
2083 filter_add(S_cr_textfilter,NULL);
2086 if (PL_rsfp_filters) {
2089 SvCUR_set(sv, 0); /* start with empty line */
2090 if (FILTER_READ(0, sv, 0) > 0)
2091 return ( SvPVX(sv) ) ;
2096 return (sv_gets(sv, fp, append));
2100 S_find_in_my_stash(pTHX_ char *pkgname, I32 len)
2104 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
2108 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
2109 (gv = gv_fetchpv(pkgname, FALSE, SVt_PVHV)))
2111 return GvHV(gv); /* Foo:: */
2114 /* use constant CLASS => 'MyClass' */
2115 if ((gv = gv_fetchpv(pkgname, FALSE, SVt_PVCV))) {
2117 if (GvCV(gv) && (sv = cv_const_sv(GvCV(gv)))) {
2118 pkgname = SvPV_nolen(sv);
2122 return gv_stashpv(pkgname, FALSE);
2126 static char* exp_name[] =
2127 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
2128 "ATTRTERM", "TERMBLOCK"
2135 Works out what to call the token just pulled out of the input
2136 stream. The yacc parser takes care of taking the ops we return and
2137 stitching them into a tree.
2143 if read an identifier
2144 if we're in a my declaration
2145 croak if they tried to say my($foo::bar)
2146 build the ops for a my() declaration
2147 if it's an access to a my() variable
2148 are we in a sort block?
2149 croak if my($a); $a <=> $b
2150 build ops for access to a my() variable
2151 if in a dq string, and they've said @foo and we can't find @foo
2153 build ops for a bareword
2154 if we already built the token before, use it.
2157 #ifdef USE_PURE_BISON
2159 Perl_yylex_r(pTHX_ YYSTYPE *lvalp, int *lcharp)
2164 yylval_pointer[yyactlevel] = lvalp;
2165 yychar_pointer[yyactlevel] = lcharp;
2166 if (yyactlevel >= YYMAXLEVEL)
2167 Perl_croak(aTHX_ "panic: YYMAXLEVEL");
2169 r = Perl_yylex(aTHX);
2179 #pragma segment Perl_yylex
2192 /* check if there's an identifier for us to look at */
2193 if (PL_pending_ident)
2194 return S_pending_ident(aTHX);
2196 /* no identifier pending identification */
2198 switch (PL_lex_state) {
2200 case LEX_NORMAL: /* Some compilers will produce faster */
2201 case LEX_INTERPNORMAL: /* code if we comment these out. */
2205 /* when we've already built the next token, just pull it out of the queue */
2208 yylval = PL_nextval[PL_nexttoke];
2210 PL_lex_state = PL_lex_defer;
2211 PL_expect = PL_lex_expect;
2212 PL_lex_defer = LEX_NORMAL;
2214 DEBUG_T({ PerlIO_printf(Perl_debug_log,
2215 "### Next token after '%s' was known, type %"IVdf"\n", PL_bufptr,
2216 (IV)PL_nexttype[PL_nexttoke]); });
2218 return(PL_nexttype[PL_nexttoke]);
2220 /* interpolated case modifiers like \L \U, including \Q and \E.
2221 when we get here, PL_bufptr is at the \
2223 case LEX_INTERPCASEMOD:
2225 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
2226 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
2228 /* handle \E or end of string */
2229 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
2233 if (PL_lex_casemods) {
2234 oldmod = PL_lex_casestack[--PL_lex_casemods];
2235 PL_lex_casestack[PL_lex_casemods] = '\0';
2237 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
2239 PL_lex_state = LEX_INTERPCONCAT;
2243 if (PL_bufptr != PL_bufend)
2245 PL_lex_state = LEX_INTERPCONCAT;
2249 DEBUG_T({ PerlIO_printf(Perl_debug_log,
2250 "### Saw case modifier at '%s'\n", PL_bufptr); });
2252 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
2253 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
2254 if (strchr("LU", *s) &&
2255 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
2257 PL_lex_casestack[--PL_lex_casemods] = '\0';
2260 if (PL_lex_casemods > 10) {
2261 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
2262 if (newlb != PL_lex_casestack) {
2264 PL_lex_casestack = newlb;
2267 PL_lex_casestack[PL_lex_casemods++] = *s;
2268 PL_lex_casestack[PL_lex_casemods] = '\0';
2269 PL_lex_state = LEX_INTERPCONCAT;
2270 PL_nextval[PL_nexttoke].ival = 0;
2273 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
2275 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
2277 PL_nextval[PL_nexttoke].ival = OP_LC;
2279 PL_nextval[PL_nexttoke].ival = OP_UC;
2281 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
2283 Perl_croak(aTHX_ "panic: yylex");
2286 if (PL_lex_starts) {
2295 case LEX_INTERPPUSH:
2296 return sublex_push();
2298 case LEX_INTERPSTART:
2299 if (PL_bufptr == PL_bufend)
2300 return sublex_done();
2301 DEBUG_T({ PerlIO_printf(Perl_debug_log,
2302 "### Interpolated variable at '%s'\n", PL_bufptr); });
2304 PL_lex_dojoin = (*PL_bufptr == '@');
2305 PL_lex_state = LEX_INTERPNORMAL;
2306 if (PL_lex_dojoin) {
2307 PL_nextval[PL_nexttoke].ival = 0;
2309 #ifdef USE_5005THREADS
2310 PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
2311 PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
2312 force_next(PRIVATEREF);
2314 force_ident("\"", '$');
2315 #endif /* USE_5005THREADS */
2316 PL_nextval[PL_nexttoke].ival = 0;
2318 PL_nextval[PL_nexttoke].ival = 0;
2320 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
2323 if (PL_lex_starts++) {
2329 case LEX_INTERPENDMAYBE:
2330 if (intuit_more(PL_bufptr)) {
2331 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
2337 if (PL_lex_dojoin) {
2338 PL_lex_dojoin = FALSE;
2339 PL_lex_state = LEX_INTERPCONCAT;
2342 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
2343 && SvEVALED(PL_lex_repl))
2345 if (PL_bufptr != PL_bufend)
2346 Perl_croak(aTHX_ "Bad evalled substitution pattern");
2347 PL_lex_repl = Nullsv;
2350 case LEX_INTERPCONCAT:
2352 if (PL_lex_brackets)
2353 Perl_croak(aTHX_ "panic: INTERPCONCAT");
2355 if (PL_bufptr == PL_bufend)
2356 return sublex_done();
2358 if (SvIVX(PL_linestr) == '\'') {
2359 SV *sv = newSVsv(PL_linestr);
2362 else if ( PL_hints & HINT_NEW_RE )
2363 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
2364 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2368 s = scan_const(PL_bufptr);
2370 PL_lex_state = LEX_INTERPCASEMOD;
2372 PL_lex_state = LEX_INTERPSTART;
2375 if (s != PL_bufptr) {
2376 PL_nextval[PL_nexttoke] = yylval;
2379 if (PL_lex_starts++)
2389 PL_lex_state = LEX_NORMAL;
2390 s = scan_formline(PL_bufptr);
2391 if (!PL_lex_formbrack)
2397 PL_oldoldbufptr = PL_oldbufptr;
2400 PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at %s\n",
2401 exp_name[PL_expect], s);
2407 if (isIDFIRST_lazy_if(s,UTF))
2409 Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
2412 goto fake_eof; /* emulate EOF on ^D or ^Z */
2417 if (PL_lex_brackets)
2418 yyerror("Missing right curly or square bracket");
2419 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2420 "### Tokener got EOF\n");
2424 if (s++ < PL_bufend)
2425 goto retry; /* ignore stray nulls */
2428 if (!PL_in_eval && !PL_preambled) {
2429 PL_preambled = TRUE;
2430 sv_setpv(PL_linestr,incl_perldb());
2431 if (SvCUR(PL_linestr))
2432 sv_catpv(PL_linestr,";");
2434 while(AvFILLp(PL_preambleav) >= 0) {
2435 SV *tmpsv = av_shift(PL_preambleav);
2436 sv_catsv(PL_linestr, tmpsv);
2437 sv_catpv(PL_linestr, ";");
2440 sv_free((SV*)PL_preambleav);
2441 PL_preambleav = NULL;
2443 if (PL_minus_n || PL_minus_p) {
2444 sv_catpv(PL_linestr, "LINE: while (<>) {");
2446 sv_catpv(PL_linestr,"chomp;");
2449 if (strchr("/'\"", *PL_splitstr)
2450 && strchr(PL_splitstr + 1, *PL_splitstr))
2451 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
2454 s = "'~#\200\1'"; /* surely one char is unused...*/
2455 while (s[1] && strchr(PL_splitstr, *s)) s++;
2457 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s%c",
2458 "q" + (delim == '\''), delim);
2459 for (s = PL_splitstr; *s; s++) {
2461 sv_catpvn(PL_linestr, "\\", 1);
2462 sv_catpvn(PL_linestr, s, 1);
2464 Perl_sv_catpvf(aTHX_ PL_linestr, "%c);", delim);
2468 sv_catpv(PL_linestr,"our @F=split(' ');");
2471 sv_catpv(PL_linestr, "\n");
2472 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2473 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2474 PL_last_lop = PL_last_uni = Nullch;
2475 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2476 SV *sv = NEWSV(85,0);
2478 sv_upgrade(sv, SVt_PVMG);
2479 sv_setsv(sv,PL_linestr);
2482 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2487 bof = PL_rsfp ? TRUE : FALSE;
2488 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
2491 if (PL_preprocess && !PL_in_eval)
2492 (void)PerlProc_pclose(PL_rsfp);
2493 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2494 PerlIO_clearerr(PL_rsfp);
2496 (void)PerlIO_close(PL_rsfp);
2498 PL_doextract = FALSE;
2500 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2501 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
2502 sv_catpv(PL_linestr,";}");
2503 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2504 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2505 PL_last_lop = PL_last_uni = Nullch;
2506 PL_minus_n = PL_minus_p = 0;
2509 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2510 PL_last_lop = PL_last_uni = Nullch;
2511 sv_setpv(PL_linestr,"");
2512 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
2514 /* if it looks like the start of a BOM, check if it in fact is */
2515 else if (bof && (!*s || *(U8*)s == 0xEF || *(U8*)s >= 0xFE)) {
2516 #ifdef PERLIO_IS_STDIO
2517 # ifdef __GNU_LIBRARY__
2518 # if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
2519 # define FTELL_FOR_PIPE_IS_BROKEN
2523 # if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
2524 # define FTELL_FOR_PIPE_IS_BROKEN
2529 #ifdef FTELL_FOR_PIPE_IS_BROKEN
2530 /* This loses the possibility to detect the bof
2531 * situation on perl -P when the libc5 is being used.
2532 * Workaround? Maybe attach some extra state to PL_rsfp?
2535 bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
2537 bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
2540 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2541 s = swallow_bom((U8*)s);
2545 /* Incest with pod. */
2546 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2547 sv_setpv(PL_linestr, "");
2548 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2549 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2550 PL_last_lop = PL_last_uni = Nullch;
2551 PL_doextract = FALSE;
2555 } while (PL_doextract);
2556 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2557 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2558 SV *sv = NEWSV(85,0);
2560 sv_upgrade(sv, SVt_PVMG);
2561 sv_setsv(sv,PL_linestr);
2564 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2566 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2567 PL_last_lop = PL_last_uni = Nullch;
2568 if (CopLINE(PL_curcop) == 1) {
2569 while (s < PL_bufend && isSPACE(*s))
2571 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2575 if (*s == '#' && *(s+1) == '!')
2577 #ifdef ALTERNATE_SHEBANG
2579 static char as[] = ALTERNATE_SHEBANG;
2580 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2581 d = s + (sizeof(as) - 1);
2583 #endif /* ALTERNATE_SHEBANG */
2592 while (*d && !isSPACE(*d))
2596 #ifdef ARG_ZERO_IS_SCRIPT
2597 if (ipathend > ipath) {
2599 * HP-UX (at least) sets argv[0] to the script name,
2600 * which makes $^X incorrect. And Digital UNIX and Linux,
2601 * at least, set argv[0] to the basename of the Perl
2602 * interpreter. So, having found "#!", we'll set it right.
2604 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV)); /* $^X */
2605 assert(SvPOK(x) || SvGMAGICAL(x));
2606 if (sv_eq(x, CopFILESV(PL_curcop))) {
2607 sv_setpvn(x, ipath, ipathend - ipath);
2610 TAINT_NOT; /* $^X is always tainted, but that's OK */
2612 #endif /* ARG_ZERO_IS_SCRIPT */
2617 d = instr(s,"perl -");
2619 d = instr(s,"perl");
2621 /* avoid getting into infinite loops when shebang
2622 * line contains "Perl" rather than "perl" */
2624 for (d = ipathend-4; d >= ipath; --d) {
2625 if ((*d == 'p' || *d == 'P')
2626 && !ibcmp(d, "perl", 4))
2636 #ifdef ALTERNATE_SHEBANG
2638 * If the ALTERNATE_SHEBANG on this system starts with a
2639 * character that can be part of a Perl expression, then if
2640 * we see it but not "perl", we're probably looking at the
2641 * start of Perl code, not a request to hand off to some
2642 * other interpreter. Similarly, if "perl" is there, but
2643 * not in the first 'word' of the line, we assume the line
2644 * contains the start of the Perl program.
2646 if (d && *s != '#') {
2648 while (*c && !strchr("; \t\r\n\f\v#", *c))
2651 d = Nullch; /* "perl" not in first word; ignore */
2653 *s = '#'; /* Don't try to parse shebang line */
2655 #endif /* ALTERNATE_SHEBANG */
2656 #ifndef MACOS_TRADITIONAL
2661 !instr(s,"indir") &&
2662 instr(PL_origargv[0],"perl"))
2668 while (s < PL_bufend && isSPACE(*s))
2670 if (s < PL_bufend) {
2671 Newz(899,newargv,PL_origargc+3,char*);
2673 while (s < PL_bufend && !isSPACE(*s))
2676 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2679 newargv = PL_origargv;
2681 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
2682 Perl_croak(aTHX_ "Can't exec %s", ipath);
2686 U32 oldpdb = PL_perldb;
2687 bool oldn = PL_minus_n;
2688 bool oldp = PL_minus_p;
2690 while (*d && !isSPACE(*d)) d++;
2691 while (SPACE_OR_TAB(*d)) d++;
2694 bool switches_done = PL_doswitches;
2696 if (*d == 'M' || *d == 'm') {
2698 while (*d && !isSPACE(*d)) d++;
2699 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2702 d = moreswitches(d);
2704 if ((PERLDB_LINE && !oldpdb) ||
2705 ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
2706 /* if we have already added "LINE: while (<>) {",
2707 we must not do it again */
2709 sv_setpv(PL_linestr, "");
2710 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2711 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2712 PL_last_lop = PL_last_uni = Nullch;
2713 PL_preambled = FALSE;
2715 (void)gv_fetchfile(PL_origfilename);
2718 if (PL_doswitches && !switches_done) {
2719 int argc = PL_origargc;
2720 char **argv = PL_origargv;
2723 } while (argc && argv[0][0] == '-' && argv[0][1]);
2724 init_argv_symbols(argc,argv);
2730 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2732 PL_lex_state = LEX_FORMLINE;
2737 #ifdef PERL_STRICT_CR
2738 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2740 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
2742 case ' ': case '\t': case '\f': case 013:
2743 #ifdef MACOS_TRADITIONAL
2750 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2751 if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
2752 /* handle eval qq[#line 1 "foo"\n ...] */
2753 CopLINE_dec(PL_curcop);
2757 while (s < d && *s != '\n')
2761 else if (s > d) /* Found by Ilya: feed random input to Perl. */
2762 Perl_croak(aTHX_ "panic: input overflow");
2764 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2766 PL_lex_state = LEX_FORMLINE;
2776 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2783 while (s < PL_bufend && SPACE_OR_TAB(*s))
2786 if (strnEQ(s,"=>",2)) {
2787 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2788 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2789 "### Saw unary minus before =>, forcing word '%s'\n", s);
2791 OPERATOR('-'); /* unary minus */
2793 PL_last_uni = PL_oldbufptr;
2795 case 'r': ftst = OP_FTEREAD; break;
2796 case 'w': ftst = OP_FTEWRITE; break;
2797 case 'x': ftst = OP_FTEEXEC; break;
2798 case 'o': ftst = OP_FTEOWNED; break;
2799 case 'R': ftst = OP_FTRREAD; break;
2800 case 'W': ftst = OP_FTRWRITE; break;
2801 case 'X': ftst = OP_FTREXEC; break;
2802 case 'O': ftst = OP_FTROWNED; break;
2803 case 'e': ftst = OP_FTIS; break;
2804 case 'z': ftst = OP_FTZERO; break;
2805 case 's': ftst = OP_FTSIZE; break;
2806 case 'f': ftst = OP_FTFILE; break;
2807 case 'd': ftst = OP_FTDIR; break;
2808 case 'l': ftst = OP_FTLINK; break;
2809 case 'p': ftst = OP_FTPIPE; break;
2810 case 'S': ftst = OP_FTSOCK; break;
2811 case 'u': ftst = OP_FTSUID; break;
2812 case 'g': ftst = OP_FTSGID; break;
2813 case 'k': ftst = OP_FTSVTX; break;
2814 case 'b': ftst = OP_FTBLK; break;
2815 case 'c': ftst = OP_FTCHR; break;
2816 case 't': ftst = OP_FTTTY; break;
2817 case 'T': ftst = OP_FTTEXT; break;
2818 case 'B': ftst = OP_FTBINARY; break;
2819 case 'M': case 'A': case 'C':
2820 gv_fetchpv("\024",TRUE, SVt_PV);
2822 case 'M': ftst = OP_FTMTIME; break;
2823 case 'A': ftst = OP_FTATIME; break;
2824 case 'C': ftst = OP_FTCTIME; break;
2832 PL_last_lop_op = ftst;
2833 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2834 "### Saw file test %c\n", (int)ftst);
2839 /* Assume it was a minus followed by a one-letter named
2840 * subroutine call (or a -bareword), then. */
2841 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2842 "### %c looked like a file test but was not\n",
2851 if (PL_expect == XOPERATOR)
2856 else if (*s == '>') {
2859 if (isIDFIRST_lazy_if(s,UTF)) {
2860 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2868 if (PL_expect == XOPERATOR)
2871 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2873 OPERATOR('-'); /* unary minus */
2880 if (PL_expect == XOPERATOR)
2885 if (PL_expect == XOPERATOR)
2888 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2894 if (PL_expect != XOPERATOR) {
2895 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2896 PL_expect = XOPERATOR;
2897 force_ident(PL_tokenbuf, '*');
2910 if (PL_expect == XOPERATOR) {
2914 PL_tokenbuf[0] = '%';
2915 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2916 if (!PL_tokenbuf[1]) {
2918 yyerror("Final % should be \\% or %name");
2921 PL_pending_ident = '%';
2940 switch (PL_expect) {
2943 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
2945 PL_bufptr = s; /* update in case we back off */
2951 PL_expect = XTERMBLOCK;
2955 while (isIDFIRST_lazy_if(s,UTF)) {
2956 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2957 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
2958 if (tmp < 0) tmp = -tmp;
2973 d = scan_str(d,TRUE,TRUE);
2975 /* MUST advance bufptr here to avoid bogus
2976 "at end of line" context messages from yyerror().
2978 PL_bufptr = s + len;
2979 yyerror("Unterminated attribute parameter in attribute list");
2982 return 0; /* EOF indicator */
2986 SV *sv = newSVpvn(s, len);
2987 sv_catsv(sv, PL_lex_stuff);
2988 attrs = append_elem(OP_LIST, attrs,
2989 newSVOP(OP_CONST, 0, sv));
2990 SvREFCNT_dec(PL_lex_stuff);
2991 PL_lex_stuff = Nullsv;
2994 /* NOTE: any CV attrs applied here need to be part of
2995 the CVf_BUILTIN_ATTRS define in cv.h! */
2996 if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len))
2997 CvLVALUE_on(PL_compcv);
2998 else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len))
2999 CvLOCKED_on(PL_compcv);
3000 else if (!PL_in_my && len == 6 && strnEQ(s, "method", len))
3001 CvMETHOD_on(PL_compcv);
3003 else if (PL_in_my == KEY_our && len == 6 &&
3004 strnEQ(s, "unique", len))
3005 GvUNIQUE_on(cGVOPx_gv(yylval.opval));
3007 /* After we've set the flags, it could be argued that
3008 we don't need to do the attributes.pm-based setting
3009 process, and shouldn't bother appending recognized
3010 flags. To experiment with that, uncomment the
3011 following "else". (Note that's already been
3012 uncommented. That keeps the above-applied built-in
3013 attributes from being intercepted (and possibly
3014 rejected) by a package's attribute routines, but is
3015 justified by the performance win for the common case
3016 of applying only built-in attributes.) */
3018 attrs = append_elem(OP_LIST, attrs,
3019 newSVOP(OP_CONST, 0,
3023 if (*s == ':' && s[1] != ':')
3026 break; /* require real whitespace or :'s */
3028 tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
3029 if (*s != ';' && *s != tmp && (tmp != '=' || *s != ')')) {
3030 char q = ((*s == '\'') ? '"' : '\'');
3031 /* If here for an expression, and parsed no attrs, back off. */
3032 if (tmp == '=' && !attrs) {
3036 /* MUST advance bufptr here to avoid bogus "at end of line"
3037 context messages from yyerror().
3041 yyerror("Unterminated attribute list");
3043 yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list",
3051 PL_nextval[PL_nexttoke].opval = attrs;
3059 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
3060 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
3076 if (PL_lex_brackets <= 0)
3077 yyerror("Unmatched right square bracket");
3080 if (PL_lex_state == LEX_INTERPNORMAL) {
3081 if (PL_lex_brackets == 0) {
3082 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
3083 PL_lex_state = LEX_INTERPEND;
3090 if (PL_lex_brackets > 100) {
3091 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
3092 if (newlb != PL_lex_brackstack) {
3094 PL_lex_brackstack = newlb;
3097 switch (PL_expect) {
3099 if (PL_lex_formbrack) {
3103 if (PL_oldoldbufptr == PL_last_lop)
3104 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3106 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3107 OPERATOR(HASHBRACK);
3109 while (s < PL_bufend && SPACE_OR_TAB(*s))
3112 PL_tokenbuf[0] = '\0';
3113 if (d < PL_bufend && *d == '-') {
3114 PL_tokenbuf[0] = '-';
3116 while (d < PL_bufend && SPACE_OR_TAB(*d))
3119 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
3120 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
3122 while (d < PL_bufend && SPACE_OR_TAB(*d))
3125 char minus = (PL_tokenbuf[0] == '-');
3126 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
3134 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
3139 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3144 if (PL_oldoldbufptr == PL_last_lop)
3145 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3147 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3150 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
3152 /* This hack is to get the ${} in the message. */
3154 yyerror("syntax error");
3157 OPERATOR(HASHBRACK);
3159 /* This hack serves to disambiguate a pair of curlies
3160 * as being a block or an anon hash. Normally, expectation
3161 * determines that, but in cases where we're not in a
3162 * position to expect anything in particular (like inside
3163 * eval"") we have to resolve the ambiguity. This code
3164 * covers the case where the first term in the curlies is a
3165 * quoted string. Most other cases need to be explicitly
3166 * disambiguated by prepending a `+' before the opening
3167 * curly in order to force resolution as an anon hash.
3169 * XXX should probably propagate the outer expectation
3170 * into eval"" to rely less on this hack, but that could
3171 * potentially break current behavior of eval"".
3175 if (*s == '\'' || *s == '"' || *s == '`') {
3176 /* common case: get past first string, handling escapes */
3177 for (t++; t < PL_bufend && *t != *s;)
3178 if (*t++ == '\\' && (*t == '\\' || *t == *s))
3182 else if (*s == 'q') {
3185 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
3189 char open, close, term;
3192 while (t < PL_bufend && isSPACE(*t))
3196 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
3200 for (t++; t < PL_bufend; t++) {
3201 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
3203 else if (*t == open)
3207 for (t++; t < PL_bufend; t++) {
3208 if (*t == '\\' && t+1 < PL_bufend)
3210 else if (*t == close && --brackets <= 0)
3212 else if (*t == open)
3218 else if (isALNUM_lazy_if(t,UTF)) {
3220 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3223 while (t < PL_bufend && isSPACE(*t))
3225 /* if comma follows first term, call it an anon hash */
3226 /* XXX it could be a comma expression with loop modifiers */
3227 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
3228 || (*t == '=' && t[1] == '>')))
3229 OPERATOR(HASHBRACK);
3230 if (PL_expect == XREF)
3233 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
3239 yylval.ival = CopLINE(PL_curcop);
3240 if (isSPACE(*s) || *s == '#')
3241 PL_copline = NOLINE; /* invalidate current command line number */
3246 if (PL_lex_brackets <= 0)
3247 yyerror("Unmatched right curly bracket");
3249 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
3250 if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
3251 PL_lex_formbrack = 0;
3252 if (PL_lex_state == LEX_INTERPNORMAL) {
3253 if (PL_lex_brackets == 0) {
3254 if (PL_expect & XFAKEBRACK) {
3255 PL_expect &= XENUMMASK;
3256 PL_lex_state = LEX_INTERPEND;
3258 return yylex(); /* ignore fake brackets */
3260 if (*s == '-' && s[1] == '>')
3261 PL_lex_state = LEX_INTERPENDMAYBE;
3262 else if (*s != '[' && *s != '{')
3263 PL_lex_state = LEX_INTERPEND;
3266 if (PL_expect & XFAKEBRACK) {
3267 PL_expect &= XENUMMASK;
3269 return yylex(); /* ignore fake brackets */
3279 if (PL_expect == XOPERATOR) {
3280 if (ckWARN(WARN_SEMICOLON)
3281 && isIDFIRST_lazy_if(s,UTF) && PL_bufptr == PL_linestart)
3283 CopLINE_dec(PL_curcop);
3284 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
3285 CopLINE_inc(PL_curcop);
3290 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3292 PL_expect = XOPERATOR;
3293 force_ident(PL_tokenbuf, '&');
3297 yylval.ival = (OPpENTERSUB_AMPER<<8);
3316 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
3317 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Reversed %c= operator",(int)tmp);
3319 if (PL_expect == XSTATE && isALPHA(tmp) &&
3320 (s == PL_linestart+1 || s[-2] == '\n') )
3322 if (PL_in_eval && !PL_rsfp) {
3327 if (strnEQ(s,"=cut",4)) {
3341 PL_doextract = TRUE;
3344 if (PL_lex_brackets < PL_lex_formbrack) {
3346 #ifdef PERL_STRICT_CR
3347 for (t = s; SPACE_OR_TAB(*t); t++) ;
3349 for (t = s; SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
3351 if (*t == '\n' || *t == '#') {
3369 if (PL_expect != XOPERATOR) {
3370 if (s[1] != '<' && !strchr(s,'>'))
3373 s = scan_heredoc(s);
3375 s = scan_inputsymbol(s);
3376 TERM(sublex_start());
3381 SHop(OP_LEFT_SHIFT);
3395 SHop(OP_RIGHT_SHIFT);
3404 if (PL_expect == XOPERATOR) {
3405 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3408 return ','; /* grandfather non-comma-format format */
3412 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
3413 PL_tokenbuf[0] = '@';
3414 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3415 sizeof PL_tokenbuf - 1, FALSE);
3416 if (PL_expect == XOPERATOR)
3417 no_op("Array length", s);
3418 if (!PL_tokenbuf[1])
3420 PL_expect = XOPERATOR;
3421 PL_pending_ident = '#';
3425 PL_tokenbuf[0] = '$';
3426 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3427 sizeof PL_tokenbuf - 1, FALSE);
3428 if (PL_expect == XOPERATOR)
3430 if (!PL_tokenbuf[1]) {
3432 yyerror("Final $ should be \\$ or $name");
3436 /* This kludge not intended to be bulletproof. */
3437 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
3438 yylval.opval = newSVOP(OP_CONST, 0,
3439 newSViv(PL_compiling.cop_arybase));
3440 yylval.opval->op_private = OPpCONST_ARYBASE;
3446 if (PL_lex_state == LEX_NORMAL)
3449 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3452 PL_tokenbuf[0] = '@';
3453 if (ckWARN(WARN_SYNTAX)) {
3455 isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$';
3458 PL_bufptr = skipspace(PL_bufptr);
3459 while (t < PL_bufend && *t != ']')
3461 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3462 "Multidimensional syntax %.*s not supported",
3463 (t - PL_bufptr) + 1, PL_bufptr);
3467 else if (*s == '{') {
3468 PL_tokenbuf[0] = '%';
3469 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
3470 (t = strchr(s, '}')) && (t = strchr(t, '=')))
3472 char tmpbuf[sizeof PL_tokenbuf];
3474 for (t++; isSPACE(*t); t++) ;
3475 if (isIDFIRST_lazy_if(t,UTF)) {
3476 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
3477 for (; isSPACE(*t); t++) ;
3478 if (*t == ';' && get_cv(tmpbuf, FALSE))
3479 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3480 "You need to quote \"%s\"", tmpbuf);
3486 PL_expect = XOPERATOR;
3487 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3488 bool islop = (PL_last_lop == PL_oldoldbufptr);
3489 if (!islop || PL_last_lop_op == OP_GREPSTART)
3490 PL_expect = XOPERATOR;
3491 else if (strchr("$@\"'`q", *s))
3492 PL_expect = XTERM; /* e.g. print $fh "foo" */
3493 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
3494 PL_expect = XTERM; /* e.g. print $fh &sub */
3495 else if (isIDFIRST_lazy_if(s,UTF)) {
3496 char tmpbuf[sizeof PL_tokenbuf];
3497 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3498 if ((tmp = keyword(tmpbuf, len))) {
3499 /* binary operators exclude handle interpretations */
3511 PL_expect = XTERM; /* e.g. print $fh length() */
3516 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
3517 if (gv && GvCVu(gv))
3518 PL_expect = XTERM; /* e.g. print $fh subr() */
3521 else if (isDIGIT(*s))
3522 PL_expect = XTERM; /* e.g. print $fh 3 */
3523 else if (*s == '.' && isDIGIT(s[1]))
3524 PL_expect = XTERM; /* e.g. print $fh .3 */
3525 else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
3526 PL_expect = XTERM; /* e.g. print $fh -1 */
3527 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3528 PL_expect = XTERM; /* print $fh <<"EOF" */
3530 PL_pending_ident = '$';
3534 if (PL_expect == XOPERATOR)
3536 PL_tokenbuf[0] = '@';
3537 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3538 if (!PL_tokenbuf[1]) {
3540 yyerror("Final @ should be \\@ or @name");
3543 if (PL_lex_state == LEX_NORMAL)
3545 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3547 PL_tokenbuf[0] = '%';
3549 /* Warn about @ where they meant $. */
3550 if (ckWARN(WARN_SYNTAX)) {
3551 if (*s == '[' || *s == '{') {
3553 while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
3555 if (*t == '}' || *t == ']') {
3557 PL_bufptr = skipspace(PL_bufptr);
3558 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3559 "Scalar value %.*s better written as $%.*s",
3560 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
3565 PL_pending_ident = '@';
3568 case '/': /* may either be division or pattern */
3569 case '?': /* may either be conditional or pattern */
3570 if (PL_expect != XOPERATOR) {
3571 /* Disable warning on "study /blah/" */
3572 if (PL_oldoldbufptr == PL_last_uni
3573 && (*PL_last_uni != 's' || s - PL_last_uni < 5
3574 || memNE(PL_last_uni, "study", 5)
3575 || isALNUM_lazy_if(PL_last_uni+5,UTF)))
3577 s = scan_pat(s,OP_MATCH);
3578 TERM(sublex_start());
3586 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3587 #ifdef PERL_STRICT_CR
3590 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3592 && (s == PL_linestart || s[-1] == '\n') )
3594 PL_lex_formbrack = 0;
3598 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
3604 yylval.ival = OPf_SPECIAL;
3610 if (PL_expect != XOPERATOR)
3615 case '0': case '1': case '2': case '3': case '4':
3616 case '5': case '6': case '7': case '8': case '9':
3617 s = scan_num(s, &yylval);
3618 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3619 "### Saw number in '%s'\n", s);
3621 if (PL_expect == XOPERATOR)
3626 s = scan_str(s,FALSE,FALSE);
3627 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3628 "### Saw string before '%s'\n", s);
3630 if (PL_expect == XOPERATOR) {
3631 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3634 return ','; /* grandfather non-comma-format format */
3640 missingterm((char*)0);
3641 yylval.ival = OP_CONST;
3642 TERM(sublex_start());
3645 s = scan_str(s,FALSE,FALSE);
3646 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3647 "### Saw string before '%s'\n", s);
3649 if (PL_expect == XOPERATOR) {
3650 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3653 return ','; /* grandfather non-comma-format format */
3659 missingterm((char*)0);
3660 yylval.ival = OP_CONST;
3661 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
3662 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
3663 yylval.ival = OP_STRINGIFY;
3667 TERM(sublex_start());
3670 s = scan_str(s,FALSE,FALSE);
3671 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3672 "### Saw backtick string before '%s'\n", s);
3674 if (PL_expect == XOPERATOR)
3675 no_op("Backticks",s);
3677 missingterm((char*)0);
3678 yylval.ival = OP_BACKTICK;
3680 TERM(sublex_start());
3684 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
3685 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
3687 if (PL_expect == XOPERATOR)
3688 no_op("Backslash",s);
3692 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
3696 while (isDIGIT(*start) || *start == '_')
3698 if (*start == '.' && isDIGIT(start[1])) {
3699 s = scan_num(s, &yylval);
3702 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
3703 else if (!isALPHA(*start) && (PL_expect == XTERM || PL_expect == XREF || PL_expect == XSTATE)) {
3707 gv = gv_fetchpv(s, FALSE, SVt_PVCV);
3710 s = scan_num(s, &yylval);
3717 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
3756 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3758 /* Some keywords can be followed by any delimiter, including ':' */
3759 tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
3760 (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
3761 (PL_tokenbuf[0] == 'q' &&
3762 strchr("qwxr", PL_tokenbuf[1])))));
3764 /* x::* is just a word, unless x is "CORE" */
3765 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
3769 while (d < PL_bufend && isSPACE(*d))
3770 d++; /* no comments skipped here, or s### is misparsed */
3772 /* Is this a label? */
3773 if (!tmp && PL_expect == XSTATE
3774 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
3776 yylval.pval = savepv(PL_tokenbuf);
3781 /* Check for keywords */
3782 tmp = keyword(PL_tokenbuf, len);
3784 /* Is this a word before a => operator? */
3785 if (*d == '=' && d[1] == '>') {
3787 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
3788 yylval.opval->op_private = OPpCONST_BARE;
3789 if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
3790 SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
3794 if (tmp < 0) { /* second-class keyword? */
3795 GV *ogv = Nullgv; /* override (winner) */
3796 GV *hgv = Nullgv; /* hidden (loser) */
3797 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3799 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3802 if (GvIMPORTED_CV(gv))
3804 else if (! CvMETHOD(cv))
3808 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3809 (gv = *gvp) != (GV*)&PL_sv_undef &&
3810 GvCVu(gv) && GvIMPORTED_CV(gv))
3816 tmp = 0; /* overridden by import or by GLOBAL */
3819 && -tmp==KEY_lock /* XXX generalizable kludge */
3821 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3823 tmp = 0; /* any sub overrides "weak" keyword */
3825 else { /* no override */
3827 if (tmp == KEY_dump && ckWARN(WARN_MISC)) {
3828 Perl_warner(aTHX_ packWARN(WARN_MISC),
3829 "dump() better written as CORE::dump()");
3833 if (ckWARN(WARN_AMBIGUOUS) && hgv
3834 && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3835 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
3836 "Ambiguous call resolved as CORE::%s(), %s",
3837 GvENAME(hgv), "qualify as such or use &");
3844 default: /* not a keyword */
3848 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3850 /* Get the rest if it looks like a package qualifier */
3852 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
3854 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3857 Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
3858 *s == '\'' ? "'" : "::");
3863 if (PL_expect == XOPERATOR) {
3864 if (PL_bufptr == PL_linestart) {
3865 CopLINE_dec(PL_curcop);
3866 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
3867 CopLINE_inc(PL_curcop);
3870 no_op("Bareword",s);
3873 /* Look for a subroutine with this name in current package,
3874 unless name is "Foo::", in which case Foo is a bearword
3875 (and a package name). */
3878 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3880 if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3881 Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
3882 "Bareword \"%s\" refers to nonexistent package",
3885 PL_tokenbuf[len] = '\0';
3892 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3895 /* if we saw a global override before, get the right name */
3898 sv = newSVpvn("CORE::GLOBAL::",14);
3899 sv_catpv(sv,PL_tokenbuf);
3902 sv = newSVpv(PL_tokenbuf,0);
3904 /* Presume this is going to be a bareword of some sort. */
3907 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3908 yylval.opval->op_private = OPpCONST_BARE;
3910 /* And if "Foo::", then that's what it certainly is. */
3915 /* See if it's the indirect object for a list operator. */
3917 if (PL_oldoldbufptr &&
3918 PL_oldoldbufptr < PL_bufptr &&
3919 (PL_oldoldbufptr == PL_last_lop
3920 || PL_oldoldbufptr == PL_last_uni) &&
3921 /* NO SKIPSPACE BEFORE HERE! */
3922 (PL_expect == XREF ||
3923 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
3925 bool immediate_paren = *s == '(';
3927 /* (Now we can afford to cross potential line boundary.) */
3930 /* Two barewords in a row may indicate method call. */
3932 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp=intuit_method(s,gv)))
3935 /* If not a declared subroutine, it's an indirect object. */
3936 /* (But it's an indir obj regardless for sort.) */
3938 if ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
3939 ((!gv || !GvCVu(gv)) &&
3940 (PL_last_lop_op != OP_MAPSTART &&
3941 PL_last_lop_op != OP_GREPSTART))))
3943 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3948 PL_expect = XOPERATOR;
3951 /* Is this a word before a => operator? */
3952 if (*s == '=' && s[1] == '>' && !pkgname) {
3954 sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
3955 if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
3956 SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
3960 /* If followed by a paren, it's certainly a subroutine. */
3963 if (gv && GvCVu(gv)) {
3964 for (d = s + 1; SPACE_OR_TAB(*d); d++) ;
3965 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
3970 PL_nextval[PL_nexttoke].opval = yylval.opval;
3971 PL_expect = XOPERATOR;
3977 /* If followed by var or block, call it a method (unless sub) */
3979 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3980 PL_last_lop = PL_oldbufptr;
3981 PL_last_lop_op = OP_METHOD;
3985 /* If followed by a bareword, see if it looks like indir obj. */
3987 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp = intuit_method(s,gv)))
3990 /* Not a method, so call it a subroutine (if defined) */
3992 if (gv && GvCVu(gv)) {
3994 if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
3995 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
3996 "Ambiguous use of -%s resolved as -&%s()",
3997 PL_tokenbuf, PL_tokenbuf);
3998 /* Check for a constant sub */
4000 if ((sv = cv_const_sv(cv))) {
4002 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
4003 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
4004 yylval.opval->op_private = 0;
4008 /* Resolve to GV now. */
4009 op_free(yylval.opval);
4010 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
4011 yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
4012 PL_last_lop = PL_oldbufptr;
4013 PL_last_lop_op = OP_ENTERSUB;
4014 /* Is there a prototype? */
4017 char *proto = SvPV((SV*)cv, len);
4020 if (strEQ(proto, "$"))
4022 if (*proto == '&' && *s == '{') {
4023 sv_setpv(PL_subname, PL_curstash ?
4024 "__ANON__" : "__ANON__::__ANON__");
4028 PL_nextval[PL_nexttoke].opval = yylval.opval;
4034 /* Call it a bare word */
4036 if (PL_hints & HINT_STRICT_SUBS)
4037 yylval.opval->op_private |= OPpCONST_STRICT;
4040 if (ckWARN(WARN_RESERVED)) {
4041 if (lastchar != '-') {
4042 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
4043 if (!*d && strNE(PL_tokenbuf,"main"))
4044 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
4051 if (lastchar && strchr("*%&", lastchar) && ckWARN_d(WARN_AMBIGUOUS)) {
4052 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4053 "Operator or semicolon missing before %c%s",
4054 lastchar, PL_tokenbuf);
4055 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4056 "Ambiguous use of %c resolved as operator %c",
4057 lastchar, lastchar);
4063 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4064 newSVpv(CopFILE(PL_curcop),0));
4068 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4069 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
4072 case KEY___PACKAGE__:
4073 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4075 ? newSVsv(PL_curstname)
4084 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
4085 char *pname = "main";
4086 if (PL_tokenbuf[2] == 'D')
4087 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
4088 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
4091 GvIOp(gv) = newIO();
4092 IoIFP(GvIOp(gv)) = PL_rsfp;
4093 #if defined(HAS_FCNTL) && defined(F_SETFD)
4095 int fd = PerlIO_fileno(PL_rsfp);
4096 fcntl(fd,F_SETFD,fd >= 3);
4099 /* Mark this internal pseudo-handle as clean */
4100 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
4102 IoTYPE(GvIOp(gv)) = IoTYPE_PIPE;
4103 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
4104 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
4106 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
4107 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
4108 /* if the script was opened in binmode, we need to revert
4109 * it to text mode for compatibility; but only iff it has CRs
4110 * XXX this is a questionable hack at best. */
4111 if (PL_bufend-PL_bufptr > 2
4112 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
4115 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
4116 loc = PerlIO_tell(PL_rsfp);
4117 (void)PerlIO_seek(PL_rsfp, 0L, 0);
4120 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
4122 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
4123 #endif /* NETWARE */
4124 #ifdef PERLIO_IS_STDIO /* really? */
4125 # if defined(__BORLANDC__)
4126 /* XXX see note in do_binmode() */
4127 ((FILE*)PL_rsfp)->flags &= ~_F_BIN;
4131 PerlIO_seek(PL_rsfp, loc, 0);
4135 #ifdef PERLIO_LAYERS
4136 if (UTF && !IN_BYTES)
4137 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
4150 if (PL_expect == XSTATE) {
4157 if (*s == ':' && s[1] == ':') {
4160 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4161 if (!(tmp = keyword(PL_tokenbuf, len)))
4162 Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
4176 LOP(OP_ACCEPT,XTERM);
4182 LOP(OP_ATAN2,XTERM);
4188 LOP(OP_BINMODE,XTERM);
4191 LOP(OP_BLESS,XTERM);
4200 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
4217 if (!PL_cryptseen) {
4218 PL_cryptseen = TRUE;
4222 LOP(OP_CRYPT,XTERM);
4225 LOP(OP_CHMOD,XTERM);
4228 LOP(OP_CHOWN,XTERM);
4231 LOP(OP_CONNECT,XTERM);
4247 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4251 PL_hints |= HINT_BLOCK_SCOPE;
4261 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
4262 LOP(OP_DBMOPEN,XTERM);
4268 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4275 yylval.ival = CopLINE(PL_curcop);
4289 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
4290 UNIBRACK(OP_ENTEREVAL);
4305 case KEY_endhostent:
4311 case KEY_endservent:
4314 case KEY_endprotoent:
4325 yylval.ival = CopLINE(PL_curcop);
4327 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
4329 if ((PL_bufend - p) >= 3 &&
4330 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
4332 else if ((PL_bufend - p) >= 4 &&
4333 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
4336 if (isIDFIRST_lazy_if(p,UTF)) {
4337 p = scan_ident(p, PL_bufend,
4338 PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4342 Perl_croak(aTHX_ "Missing $ on loop variable");
4347 LOP(OP_FORMLINE,XTERM);
4353 LOP(OP_FCNTL,XTERM);
4359 LOP(OP_FLOCK,XTERM);
4368 LOP(OP_GREPSTART, XREF);
4371 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4386 case KEY_getpriority:
4387 LOP(OP_GETPRIORITY,XTERM);
4389 case KEY_getprotobyname:
4392 case KEY_getprotobynumber:
4393 LOP(OP_GPBYNUMBER,XTERM);
4395 case KEY_getprotoent:
4407 case KEY_getpeername:
4408 UNI(OP_GETPEERNAME);
4410 case KEY_gethostbyname:
4413 case KEY_gethostbyaddr:
4414 LOP(OP_GHBYADDR,XTERM);
4416 case KEY_gethostent:
4419 case KEY_getnetbyname:
4422 case KEY_getnetbyaddr:
4423 LOP(OP_GNBYADDR,XTERM);
4428 case KEY_getservbyname:
4429 LOP(OP_GSBYNAME,XTERM);
4431 case KEY_getservbyport:
4432 LOP(OP_GSBYPORT,XTERM);
4434 case KEY_getservent:
4437 case KEY_getsockname:
4438 UNI(OP_GETSOCKNAME);
4440 case KEY_getsockopt:
4441 LOP(OP_GSOCKOPT,XTERM);
4463 yylval.ival = CopLINE(PL_curcop);
4467 LOP(OP_INDEX,XTERM);
4473 LOP(OP_IOCTL,XTERM);
4485 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4517 LOP(OP_LISTEN,XTERM);
4526 s = scan_pat(s,OP_MATCH);
4527 TERM(sublex_start());
4530 LOP(OP_MAPSTART, XREF);
4533 LOP(OP_MKDIR,XTERM);
4536 LOP(OP_MSGCTL,XTERM);
4539 LOP(OP_MSGGET,XTERM);
4542 LOP(OP_MSGRCV,XTERM);
4545 LOP(OP_MSGSND,XTERM);
4551 if (isIDFIRST_lazy_if(s,UTF)) {
4552 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
4553 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
4555 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
4556 if (!PL_in_my_stash) {
4559 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
4567 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4574 if (PL_expect != XSTATE)
4575 yyerror("\"no\" not allowed in expression");
4576 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4577 s = force_version(s, FALSE);
4582 if (*s == '(' || (s = skipspace(s), *s == '('))
4589 if (isIDFIRST_lazy_if(s,UTF)) {
4591 for (d = s; isALNUM_lazy_if(d,UTF); d++) ;
4593 if (strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE))
4594 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4595 "Precedence problem: open %.*s should be open(%.*s)",
4601 yylval.ival = OP_OR;
4611 LOP(OP_OPEN_DIR,XTERM);
4614 checkcomma(s,PL_tokenbuf,"filehandle");
4618 checkcomma(s,PL_tokenbuf,"filehandle");
4637 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4641 LOP(OP_PIPE_OP,XTERM);
4644 s = scan_str(s,FALSE,FALSE);
4646 missingterm((char*)0);
4647 yylval.ival = OP_CONST;
4648 TERM(sublex_start());
4654 s = scan_str(s,FALSE,FALSE);
4656 missingterm((char*)0);
4658 if (SvCUR(PL_lex_stuff)) {
4661 d = SvPV_force(PL_lex_stuff, len);
4664 for (; isSPACE(*d) && len; --len, ++d) ;
4667 if (!warned && ckWARN(WARN_QW)) {
4668 for (; !isSPACE(*d) && len; --len, ++d) {
4670 Perl_warner(aTHX_ packWARN(WARN_QW),
4671 "Possible attempt to separate words with commas");
4674 else if (*d == '#') {
4675 Perl_warner(aTHX_ packWARN(WARN_QW),
4676 "Possible attempt to put comments in qw() list");
4682 for (; !isSPACE(*d) && len; --len, ++d) ;
4684 sv = newSVpvn(b, d-b);
4685 if (DO_UTF8(PL_lex_stuff))
4687 words = append_elem(OP_LIST, words,
4688 newSVOP(OP_CONST, 0, tokeq(sv)));
4692 PL_nextval[PL_nexttoke].opval = words;
4697 SvREFCNT_dec(PL_lex_stuff);
4698 PL_lex_stuff = Nullsv;
4704 s = scan_str(s,FALSE,FALSE);
4706 missingterm((char*)0);
4707 yylval.ival = OP_STRINGIFY;
4708 if (SvIVX(PL_lex_stuff) == '\'')
4709 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
4710 TERM(sublex_start());
4713 s = scan_pat(s,OP_QR);
4714 TERM(sublex_start());
4717 s = scan_str(s,FALSE,FALSE);
4719 missingterm((char*)0);
4720 yylval.ival = OP_BACKTICK;
4722 TERM(sublex_start());
4730 s = force_version(s, FALSE);
4732 else if (*s != 'v' || !isDIGIT(s[1])
4733 || (s = force_version(s, TRUE), *s == 'v'))
4735 *PL_tokenbuf = '\0';
4736 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4737 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
4738 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
4740 yyerror("<> should be quotes");
4748 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4752 LOP(OP_RENAME,XTERM);
4761 LOP(OP_RINDEX,XTERM);
4784 LOP(OP_REVERSE,XTERM);
4795 TERM(sublex_start());
4797 TOKEN(1); /* force error */
4806 LOP(OP_SELECT,XTERM);
4812 LOP(OP_SEMCTL,XTERM);
4815 LOP(OP_SEMGET,XTERM);
4818 LOP(OP_SEMOP,XTERM);
4824 LOP(OP_SETPGRP,XTERM);
4826 case KEY_setpriority:
4827 LOP(OP_SETPRIORITY,XTERM);
4829 case KEY_sethostent:
4835 case KEY_setservent:
4838 case KEY_setprotoent:
4848 LOP(OP_SEEKDIR,XTERM);
4850 case KEY_setsockopt:
4851 LOP(OP_SSOCKOPT,XTERM);
4857 LOP(OP_SHMCTL,XTERM);
4860 LOP(OP_SHMGET,XTERM);
4863 LOP(OP_SHMREAD,XTERM);
4866 LOP(OP_SHMWRITE,XTERM);
4869 LOP(OP_SHUTDOWN,XTERM);
4878 LOP(OP_SOCKET,XTERM);
4880 case KEY_socketpair:
4881 LOP(OP_SOCKPAIR,XTERM);
4884 checkcomma(s,PL_tokenbuf,"subroutine name");
4886 if (*s == ';' || *s == ')') /* probably a close */
4887 Perl_croak(aTHX_ "sort is now a reserved word");
4889 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4893 LOP(OP_SPLIT,XTERM);
4896 LOP(OP_SPRINTF,XTERM);
4899 LOP(OP_SPLICE,XTERM);
4914 LOP(OP_SUBSTR,XTERM);
4920 char tmpbuf[sizeof PL_tokenbuf];
4921 SSize_t tboffset = 0;
4922 expectation attrful;
4923 bool have_name, have_proto, bad_proto;
4928 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
4929 (*s == ':' && s[1] == ':'))
4932 attrful = XATTRBLOCK;
4933 /* remember buffer pos'n for later force_word */
4934 tboffset = s - PL_oldbufptr;
4935 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4936 if (strchr(tmpbuf, ':'))
4937 sv_setpv(PL_subname, tmpbuf);
4939 sv_setsv(PL_subname,PL_curstname);
4940 sv_catpvn(PL_subname,"::",2);
4941 sv_catpvn(PL_subname,tmpbuf,len);
4948 Perl_croak(aTHX_ "Missing name in \"my sub\"");
4949 PL_expect = XTERMBLOCK;
4950 attrful = XATTRTERM;
4951 sv_setpv(PL_subname,"?");
4955 if (key == KEY_format) {
4957 PL_lex_formbrack = PL_lex_brackets + 1;
4959 (void) force_word(PL_oldbufptr + tboffset, WORD,
4964 /* Look for a prototype */
4968 s = scan_str(s,FALSE,FALSE);
4970 Perl_croak(aTHX_ "Prototype not terminated");
4971 /* strip spaces and check for bad characters */
4972 d = SvPVX(PL_lex_stuff);
4975 for (p = d; *p; ++p) {
4978 if (!strchr("$@%*;[]&\\", *p))
4983 if (bad_proto && ckWARN(WARN_SYNTAX))
4984 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4985 "Illegal character in prototype for %s : %s",
4986 SvPVX(PL_subname), d);
4987 SvCUR(PL_lex_stuff) = tmp;
4995 if (*s == ':' && s[1] != ':')
4996 PL_expect = attrful;
4999 PL_nextval[PL_nexttoke].opval =
5000 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
5001 PL_lex_stuff = Nullsv;
5005 sv_setpv(PL_subname,
5006 PL_curstash ? "__ANON__" : "__ANON__::__ANON__");
5009 (void) force_word(PL_oldbufptr + tboffset, WORD,
5018 LOP(OP_SYSTEM,XREF);
5021 LOP(OP_SYMLINK,XTERM);
5024 LOP(OP_SYSCALL,XTERM);
5027 LOP(OP_SYSOPEN,XTERM);
5030 LOP(OP_SYSSEEK,XTERM);
5033 LOP(OP_SYSREAD,XTERM);
5036 LOP(OP_SYSWRITE,XTERM);
5040 TERM(sublex_start());
5061 LOP(OP_TRUNCATE,XTERM);
5073 yylval.ival = CopLINE(PL_curcop);
5077 yylval.ival = CopLINE(PL_curcop);
5081 LOP(OP_UNLINK,XTERM);
5087 LOP(OP_UNPACK,XTERM);
5090 LOP(OP_UTIME,XTERM);
5096 LOP(OP_UNSHIFT,XTERM);
5099 if (PL_expect != XSTATE)
5100 yyerror("\"use\" not allowed in expression");
5102 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
5103 s = force_version(s, TRUE);
5104 if (*s == ';' || (s = skipspace(s), *s == ';')) {
5105 PL_nextval[PL_nexttoke].opval = Nullop;
5108 else if (*s == 'v') {
5109 s = force_word(s,WORD,FALSE,TRUE,FALSE);
5110 s = force_version(s, FALSE);
5114 s = force_word(s,WORD,FALSE,TRUE,FALSE);
5115 s = force_version(s, FALSE);
5127 yylval.ival = CopLINE(PL_curcop);
5131 PL_hints |= HINT_BLOCK_SCOPE;
5138 LOP(OP_WAITPID,XTERM);
5147 ctl_l[0] = toCTRL('L');
5149 gv_fetchpv(ctl_l,TRUE, SVt_PV);
5152 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
5157 if (PL_expect == XOPERATOR)
5163 yylval.ival = OP_XOR;
5168 TERM(sublex_start());
5173 #pragma segment Main
5177 S_pending_ident(pTHX)
5181 /* pit holds the identifier we read and pending_ident is reset */
5182 char pit = PL_pending_ident;
5183 PL_pending_ident = 0;
5185 DEBUG_T({ PerlIO_printf(Perl_debug_log,
5186 "### Tokener saw identifier '%s'\n", PL_tokenbuf); });
5188 /* if we're in a my(), we can't allow dynamics here.
5189 $foo'bar has already been turned into $foo::bar, so
5190 just check for colons.
5192 if it's a legal name, the OP is a PADANY.
5195 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
5196 if (strchr(PL_tokenbuf,':'))
5197 yyerror(Perl_form(aTHX_ "No package name allowed for "
5198 "variable %s in \"our\"",
5200 tmp = pad_allocmy(PL_tokenbuf);
5203 if (strchr(PL_tokenbuf,':'))
5204 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
5206 yylval.opval = newOP(OP_PADANY, 0);
5207 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
5213 build the ops for accesses to a my() variable.
5215 Deny my($a) or my($b) in a sort block, *if* $a or $b is
5216 then used in a comparison. This catches most, but not
5217 all cases. For instance, it catches
5218 sort { my($a); $a <=> $b }
5220 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
5221 (although why you'd do that is anyone's guess).
5224 if (!strchr(PL_tokenbuf,':')) {
5225 #ifdef USE_5005THREADS
5226 /* Check for single character per-thread SVs */
5227 if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
5228 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
5229 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
5231 yylval.opval = newOP(OP_THREADSV, 0);
5232 yylval.opval->op_targ = tmp;
5235 #endif /* USE_5005THREADS */
5236 if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
5237 SV *namesv = AvARRAY(PL_comppad_name)[tmp];
5238 /* might be an "our" variable" */
5239 if (SvFLAGS(namesv) & SVpad_OUR) {
5240 /* build ops for a bareword */
5241 SV *sym = newSVpv(HvNAME(GvSTASH(namesv)),0);
5242 sv_catpvn(sym, "::", 2);
5243 sv_catpv(sym, PL_tokenbuf+1);
5244 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
5245 yylval.opval->op_private = OPpCONST_ENTERED;
5246 gv_fetchpv(SvPVX(sym),
5248 ? (GV_ADDMULTI | GV_ADDINEVAL)
5251 ((PL_tokenbuf[0] == '$') ? SVt_PV
5252 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5257 /* if it's a sort block and they're naming $a or $b */
5258 if (PL_last_lop_op == OP_SORT &&
5259 PL_tokenbuf[0] == '$' &&
5260 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
5263 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
5264 d < PL_bufend && *d != '\n';
5267 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
5268 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
5274 yylval.opval = newOP(OP_PADANY, 0);
5275 yylval.opval->op_targ = tmp;
5281 Whine if they've said @foo in a doublequoted string,
5282 and @foo isn't a variable we can find in the symbol
5285 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
5286 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
5287 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
5288 && ckWARN(WARN_AMBIGUOUS))
5290 /* Downgraded from fatal to warning 20000522 mjd */
5291 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5292 "Possible unintended interpolation of %s in string",
5297 /* build ops for a bareword */
5298 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
5299 yylval.opval->op_private = OPpCONST_ENTERED;
5300 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
5301 ((PL_tokenbuf[0] == '$') ? SVt_PV
5302 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5308 Perl_keyword(pTHX_ register char *d, I32 len)
5313 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
5314 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
5315 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
5316 if (strEQ(d,"__DATA__")) return KEY___DATA__;
5317 if (strEQ(d,"__END__")) return KEY___END__;
5321 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
5326 if (strEQ(d,"and")) return -KEY_and;
5327 if (strEQ(d,"abs")) return -KEY_abs;
5330 if (strEQ(d,"alarm")) return -KEY_alarm;
5331 if (strEQ(d,"atan2")) return -KEY_atan2;
5334 if (strEQ(d,"accept")) return -KEY_accept;
5339 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
5342 if (strEQ(d,"bless")) return -KEY_bless;
5343 if (strEQ(d,"bind")) return -KEY_bind;
5344 if (strEQ(d,"binmode")) return -KEY_binmode;
5347 if (strEQ(d,"CORE")) return -KEY_CORE;
5348 if (strEQ(d,"CHECK")) return KEY_CHECK;
5353 if (strEQ(d,"cmp")) return -KEY_cmp;
5354 if (strEQ(d,"chr")) return -KEY_chr;
5355 if (strEQ(d,"cos")) return -KEY_cos;
5358 if (strEQ(d,"chop")) return -KEY_chop;
5361 if (strEQ(d,"close")) return -KEY_close;
5362 if (strEQ(d,"chdir")) return -KEY_chdir;
5363 if (strEQ(d,"chomp")) return -KEY_chomp;
5364 if (strEQ(d,"chmod")) return -KEY_chmod;
5365 if (strEQ(d,"chown")) return -KEY_chown;
5366 if (strEQ(d,"crypt")) return -KEY_crypt;
5369 if (strEQ(d,"chroot")) return -KEY_chroot;
5370 if (strEQ(d,"caller")) return -KEY_caller;
5373 if (strEQ(d,"connect")) return -KEY_connect;
5376 if (strEQ(d,"closedir")) return -KEY_closedir;
5377 if (strEQ(d,"continue")) return -KEY_continue;
5382 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
5387 if (strEQ(d,"do")) return KEY_do;
5390 if (strEQ(d,"die")) return -KEY_die;
5393 if (strEQ(d,"dump")) return -KEY_dump;
5396 if (strEQ(d,"delete")) return KEY_delete;
5399 if (strEQ(d,"defined")) return KEY_defined;
5400 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
5403 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
5408 if (strEQ(d,"END")) return KEY_END;
5413 if (strEQ(d,"eq")) return -KEY_eq;
5416 if (strEQ(d,"eof")) return -KEY_eof;
5417 if (strEQ(d,"exp")) return -KEY_exp;
5420 if (strEQ(d,"else")) return KEY_else;
5421 if (strEQ(d,"exit")) return -KEY_exit;
5422 if (strEQ(d,"eval")) return KEY_eval;
5423 if (strEQ(d,"exec")) return -KEY_exec;
5424 if (strEQ(d,"each")) return -KEY_each;
5427 if (strEQ(d,"elsif")) return KEY_elsif;
5430 if (strEQ(d,"exists")) return KEY_exists;
5431 if (strEQ(d,"elseif")) Perl_warn(aTHX_ "elseif should be elsif");
5434 if (strEQ(d,"endgrent")) return -KEY_endgrent;
5435 if (strEQ(d,"endpwent")) return -KEY_endpwent;
5438 if (strEQ(d,"endnetent")) return -KEY_endnetent;
5441 if (strEQ(d,"endhostent")) return -KEY_endhostent;
5442 if (strEQ(d,"endservent")) return -KEY_endservent;
5445 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
5452 if (strEQ(d,"for")) return KEY_for;
5455 if (strEQ(d,"fork")) return -KEY_fork;
5458 if (strEQ(d,"fcntl")) return -KEY_fcntl;
5459 if (strEQ(d,"flock")) return -KEY_flock;
5462 if (strEQ(d,"format")) return KEY_format;
5463 if (strEQ(d,"fileno")) return -KEY_fileno;
5466 if (strEQ(d,"foreach")) return KEY_foreach;
5469 if (strEQ(d,"formline")) return -KEY_formline;
5474 if (strnEQ(d,"get",3)) {
5479 if (strEQ(d,"ppid")) return -KEY_getppid;
5480 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
5483 if (strEQ(d,"pwent")) return -KEY_getpwent;
5484 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
5485 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
5488 if (strEQ(d,"peername")) return -KEY_getpeername;
5489 if (strEQ(d,"protoent")) return -KEY_getprotoent;
5490 if (strEQ(d,"priority")) return -KEY_getpriority;
5493 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
5496 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
5500 else if (*d == 'h') {
5501 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
5502 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
5503 if (strEQ(d,"hostent")) return -KEY_gethostent;
5505 else if (*d == 'n') {
5506 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
5507 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
5508 if (strEQ(d,"netent")) return -KEY_getnetent;
5510 else if (*d == 's') {
5511 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
5512 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
5513 if (strEQ(d,"servent")) return -KEY_getservent;
5514 if (strEQ(d,"sockname")) return -KEY_getsockname;
5515 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
5517 else if (*d == 'g') {
5518 if (strEQ(d,"grent")) return -KEY_getgrent;
5519 if (strEQ(d,"grnam")) return -KEY_getgrnam;
5520 if (strEQ(d,"grgid")) return -KEY_getgrgid;
5522 else if (*d == 'l') {
5523 if (strEQ(d,"login")) return -KEY_getlogin;
5525 else if (strEQ(d,"c")) return -KEY_getc;
5530 if (strEQ(d,"gt")) return -KEY_gt;
5531 if (strEQ(d,"ge")) return -KEY_ge;
5534 if (strEQ(d,"grep")) return KEY_grep;
5535 if (strEQ(d,"goto")) return KEY_goto;
5536 if (strEQ(d,"glob")) return KEY_glob;
5539 if (strEQ(d,"gmtime")) return -KEY_gmtime;
5544 if (strEQ(d,"hex")) return -KEY_hex;
5547 if (strEQ(d,"INIT")) return KEY_INIT;
5552 if (strEQ(d,"if")) return KEY_if;
5555 if (strEQ(d,"int")) return -KEY_int;
5558 if (strEQ(d,"index")) return -KEY_index;
5559 if (strEQ(d,"ioctl")) return -KEY_ioctl;
5564 if (strEQ(d,"join")) return -KEY_join;
5568 if (strEQ(d,"keys")) return -KEY_keys;
5569 if (strEQ(d,"kill")) return -KEY_kill;
5575 if (strEQ(d,"lt")) return -KEY_lt;
5576 if (strEQ(d,"le")) return -KEY_le;
5577 if (strEQ(d,"lc")) return -KEY_lc;
5580 if (strEQ(d,"log")) return -KEY_log;
5583 if (strEQ(d,"last")) return KEY_last;
5584 if (strEQ(d,"link")) return -KEY_link;
5585 if (strEQ(d,"lock")) return -KEY_lock;
5588 if (strEQ(d,"local")) return KEY_local;
5589 if (strEQ(d,"lstat")) return -KEY_lstat;
5592 if (strEQ(d,"length")) return -KEY_length;
5593 if (strEQ(d,"listen")) return -KEY_listen;
5596 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
5599 if (strEQ(d,"localtime")) return -KEY_localtime;
5605 case 1: return KEY_m;
5607 if (strEQ(d,"my")) return KEY_my;
5610 if (strEQ(d,"map")) return KEY_map;
5613 if (strEQ(d,"mkdir")) return -KEY_mkdir;
5616 if (strEQ(d,"msgctl")) return -KEY_msgctl;
5617 if (strEQ(d,"msgget")) return -KEY_msgget;
5618 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
5619 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
5624 if (strEQ(d,"next")) return KEY_next;
5625 if (strEQ(d,"ne")) return -KEY_ne;
5626 if (strEQ(d,"not")) return -KEY_not;
5627 if (strEQ(d,"no")) return KEY_no;
5632 if (strEQ(d,"or")) return -KEY_or;
5635 if (strEQ(d,"ord")) return -KEY_ord;
5636 if (strEQ(d,"oct")) return -KEY_oct;
5637 if (strEQ(d,"our")) return KEY_our;
5640 if (strEQ(d,"open")) return -KEY_open;
5643 if (strEQ(d,"opendir")) return -KEY_opendir;
5650 if (strEQ(d,"pop")) return -KEY_pop;
5651 if (strEQ(d,"pos")) return KEY_pos;
5654 if (strEQ(d,"push")) return -KEY_push;
5655 if (strEQ(d,"pack")) return -KEY_pack;
5656 if (strEQ(d,"pipe")) return -KEY_pipe;
5659 if (strEQ(d,"print")) return KEY_print;
5662 if (strEQ(d,"printf")) return KEY_printf;
5665 if (strEQ(d,"package")) return KEY_package;
5668 if (strEQ(d,"prototype")) return KEY_prototype;
5673 if (strEQ(d,"q")) return KEY_q;
5674 if (strEQ(d,"qr")) return KEY_qr;
5675 if (strEQ(d,"qq")) return KEY_qq;
5676 if (strEQ(d,"qw")) return KEY_qw;
5677 if (strEQ(d,"qx")) return KEY_qx;
5679 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
5684 if (strEQ(d,"ref")) return -KEY_ref;
5687 if (strEQ(d,"read")) return -KEY_read;
5688 if (strEQ(d,"rand")) return -KEY_rand;
5689 if (strEQ(d,"recv")) return -KEY_recv;
5690 if (strEQ(d,"redo")) return KEY_redo;
5693 if (strEQ(d,"rmdir")) return -KEY_rmdir;
5694 if (strEQ(d,"reset")) return -KEY_reset;
5697 if (strEQ(d,"return")) return KEY_return;
5698 if (strEQ(d,"rename")) return -KEY_rename;
5699 if (strEQ(d,"rindex")) return -KEY_rindex;
5702 if (strEQ(d,"require")) return KEY_require;
5703 if (strEQ(d,"reverse")) return -KEY_reverse;
5704 if (strEQ(d,"readdir")) return -KEY_readdir;
5707 if (strEQ(d,"readlink")) return -KEY_readlink;
5708 if (strEQ(d,"readline")) return -KEY_readline;
5709 if (strEQ(d,"readpipe")) return -KEY_readpipe;
5712 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
5718 case 0: return KEY_s;
5720 if (strEQ(d,"scalar")) return KEY_scalar;
5725 if (strEQ(d,"seek")) return -KEY_seek;
5726 if (strEQ(d,"send")) return -KEY_send;
5729 if (strEQ(d,"semop")) return -KEY_semop;
5732 if (strEQ(d,"select")) return -KEY_select;
5733 if (strEQ(d,"semctl")) return -KEY_semctl;
5734 if (strEQ(d,"semget")) return -KEY_semget;
5737 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
5738 if (strEQ(d,"seekdir")) return -KEY_seekdir;
5741 if (strEQ(d,"setpwent")) return -KEY_setpwent;
5742 if (strEQ(d,"setgrent")) return -KEY_setgrent;
5745 if (strEQ(d,"setnetent")) return -KEY_setnetent;
5748 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
5749 if (strEQ(d,"sethostent")) return -KEY_sethostent;
5750 if (strEQ(d,"setservent")) return -KEY_setservent;
5753 if (strEQ(d,"setpriority")) return -KEY_setpriority;
5754 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
5761 if (strEQ(d,"shift")) return -KEY_shift;
5764 if (strEQ(d,"shmctl")) return -KEY_shmctl;
5765 if (strEQ(d,"shmget")) return -KEY_shmget;
5768 if (strEQ(d,"shmread")) return -KEY_shmread;
5771 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
5772 if (strEQ(d,"shutdown")) return -KEY_shutdown;
5777 if (strEQ(d,"sin")) return -KEY_sin;
5780 if (strEQ(d,"sleep")) return -KEY_sleep;
5783 if (strEQ(d,"sort")) return KEY_sort;
5784 if (strEQ(d,"socket")) return -KEY_socket;
5785 if (strEQ(d,"socketpair")) return -KEY_socketpair;
5788 if (strEQ(d,"split")) return KEY_split;
5789 if (strEQ(d,"sprintf")) return -KEY_sprintf;
5790 if (strEQ(d,"splice")) return -KEY_splice;
5793 if (strEQ(d,"sqrt")) return -KEY_sqrt;
5796 if (strEQ(d,"srand")) return -KEY_srand;
5799 if (strEQ(d,"stat")) return -KEY_stat;
5800 if (strEQ(d,"study")) return KEY_study;
5803 if (strEQ(d,"substr")) return -KEY_substr;
5804 if (strEQ(d,"sub")) return KEY_sub;
5809 if (strEQ(d,"system")) return -KEY_system;
5812 if (strEQ(d,"symlink")) return -KEY_symlink;
5813 if (strEQ(d,"syscall")) return -KEY_syscall;
5814 if (strEQ(d,"sysopen")) return -KEY_sysopen;
5815 if (strEQ(d,"sysread")) return -KEY_sysread;
5816 if (strEQ(d,"sysseek")) return -KEY_sysseek;
5819 if (strEQ(d,"syswrite")) return -KEY_syswrite;
5828 if (strEQ(d,"tr")) return KEY_tr;
5831 if (strEQ(d,"tie")) return KEY_tie;
5834 if (strEQ(d,"tell")) return -KEY_tell;
5835 if (strEQ(d,"tied")) return KEY_tied;
5836 if (strEQ(d,"time")) return -KEY_time;
5839 if (strEQ(d,"times")) return -KEY_times;
5842 if (strEQ(d,"telldir")) return -KEY_telldir;
5845 if (strEQ(d,"truncate")) return -KEY_truncate;
5852 if (strEQ(d,"uc")) return -KEY_uc;
5855 if (strEQ(d,"use")) return KEY_use;
5858 if (strEQ(d,"undef")) return KEY_undef;
5859 if (strEQ(d,"until")) return KEY_until;
5860 if (strEQ(d,"untie")) return KEY_untie;
5861 if (strEQ(d,"utime")) return -KEY_utime;
5862 if (strEQ(d,"umask")) return -KEY_umask;
5865 if (strEQ(d,"unless")) return KEY_unless;
5866 if (strEQ(d,"unpack")) return -KEY_unpack;
5867 if (strEQ(d,"unlink")) return -KEY_unlink;
5870 if (strEQ(d,"unshift")) return -KEY_unshift;
5871 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
5876 if (strEQ(d,"values")) return -KEY_values;
5877 if (strEQ(d,"vec")) return -KEY_vec;
5882 if (strEQ(d,"warn")) return -KEY_warn;
5883 if (strEQ(d,"wait")) return -KEY_wait;
5886 if (strEQ(d,"while")) return KEY_while;
5887 if (strEQ(d,"write")) return -KEY_write;
5890 if (strEQ(d,"waitpid")) return -KEY_waitpid;
5893 if (strEQ(d,"wantarray")) return -KEY_wantarray;
5898 if (len == 1) return -KEY_x;
5899 if (strEQ(d,"xor")) return -KEY_xor;
5902 if (len == 1) return KEY_y;
5911 S_checkcomma(pTHX_ register char *s, char *name, char *what)
5915 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
5916 if (ckWARN(WARN_SYNTAX)) {
5918 for (w = s+2; *w && level; w++) {
5925 for (; *w && isSPACE(*w); w++) ;
5926 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
5927 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5928 "%s (...) interpreted as function",name);
5931 while (s < PL_bufend && isSPACE(*s))
5935 while (s < PL_bufend && isSPACE(*s))
5937 if (isIDFIRST_lazy_if(s,UTF)) {
5939 while (isALNUM_lazy_if(s,UTF))
5941 while (s < PL_bufend && isSPACE(*s))
5946 kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
5950 Perl_croak(aTHX_ "No comma allowed after %s", what);
5955 /* Either returns sv, or mortalizes sv and returns a new SV*.
5956 Best used as sv=new_constant(..., sv, ...).
5957 If s, pv are NULL, calls subroutine with one argument,
5958 and type is used with error messages only. */
5961 S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv,
5965 HV *table = GvHV(PL_hintgv); /* ^H */
5969 const char *why1, *why2, *why3;
5971 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
5974 why2 = strEQ(key,"charnames")
5975 ? "(possibly a missing \"use charnames ...\")"
5977 msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
5978 (type ? type: "undef"), why2);
5980 /* This is convoluted and evil ("goto considered harmful")
5981 * but I do not understand the intricacies of all the different
5982 * failure modes of %^H in here. The goal here is to make
5983 * the most probable error message user-friendly. --jhi */
5988 msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
5989 (type ? type: "undef"), why1, why2, why3);
5991 yyerror(SvPVX(msg));
5995 cvp = hv_fetch(table, key, strlen(key), FALSE);
5996 if (!cvp || !SvOK(*cvp)) {
5999 why3 = "} is not defined";
6002 sv_2mortal(sv); /* Parent created it permanently */
6005 pv = sv_2mortal(newSVpvn(s, len));
6007 typesv = sv_2mortal(newSVpv(type, 0));
6009 typesv = &PL_sv_undef;
6011 PUSHSTACKi(PERLSI_OVERLOAD);
6023 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
6027 /* Check the eval first */
6028 if (!PL_in_eval && SvTRUE(ERRSV)) {
6030 sv_catpv(ERRSV, "Propagated");
6031 yyerror(SvPV(ERRSV, n_a)); /* Duplicates the message inside eval */
6033 res = SvREFCNT_inc(sv);
6037 (void)SvREFCNT_inc(res);
6046 why1 = "Call to &{$^H{";
6048 why3 = "}} did not return a defined value";
6057 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
6059 register char *d = dest;
6060 register char *e = d + destlen - 3; /* two-character token, ending NUL */
6063 Perl_croak(aTHX_ ident_too_long);
6064 if (isALNUM(*s)) /* UTF handled below */
6066 else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) {
6071 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
6075 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
6076 char *t = s + UTF8SKIP(s);
6077 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
6079 if (d + (t - s) > e)
6080 Perl_croak(aTHX_ ident_too_long);
6081 Copy(s, d, t - s, char);
6094 S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
6104 e = d + destlen - 3; /* two-character token, ending NUL */
6106 while (isDIGIT(*s)) {
6108 Perl_croak(aTHX_ ident_too_long);
6115 Perl_croak(aTHX_ ident_too_long);
6116 if (isALNUM(*s)) /* UTF handled below */
6118 else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
6123 else if (*s == ':' && s[1] == ':') {
6127 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
6128 char *t = s + UTF8SKIP(s);
6129 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
6131 if (d + (t - s) > e)
6132 Perl_croak(aTHX_ ident_too_long);
6133 Copy(s, d, t - s, char);
6144 if (PL_lex_state != LEX_NORMAL)
6145 PL_lex_state = LEX_INTERPENDMAYBE;
6148 if (*s == '$' && s[1] &&
6149 (isALNUM_lazy_if(s+1,UTF) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
6162 if (*d == '^' && *s && isCONTROLVAR(*s)) {
6167 if (isSPACE(s[-1])) {
6170 if (!SPACE_OR_TAB(ch)) {
6176 if (isIDFIRST_lazy_if(d,UTF)) {
6180 while ((e < send && isALNUM_lazy_if(e,UTF)) || *e == ':') {
6182 while (e < send && UTF8_IS_CONTINUED(*e) && is_utf8_mark((U8*)e))
6185 Copy(s, d, e - s, char);
6190 while ((isALNUM(*s) || *s == ':') && d < e)
6193 Perl_croak(aTHX_ ident_too_long);
6196 while (s < send && SPACE_OR_TAB(*s)) s++;
6197 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
6198 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
6199 const char *brack = *s == '[' ? "[...]" : "{...}";
6200 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
6201 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
6202 funny, dest, brack, funny, dest, brack);
6205 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
6209 /* Handle extended ${^Foo} variables
6210 * 1999-02-27 mjd-perl-patch@plover.com */
6211 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
6215 while (isALNUM(*s) && d < e) {
6219 Perl_croak(aTHX_ ident_too_long);
6224 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
6225 PL_lex_state = LEX_INTERPEND;
6228 if (PL_lex_state == LEX_NORMAL) {
6229 if (ckWARN(WARN_AMBIGUOUS) &&
6230 (keyword(dest, d - dest) || get_cv(dest, FALSE)))
6232 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
6233 "Ambiguous use of %c{%s} resolved to %c%s",
6234 funny, dest, funny, dest);
6239 s = bracket; /* let the parser handle it */
6243 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
6244 PL_lex_state = LEX_INTERPEND;
6249 Perl_pmflag(pTHX_ U16 *pmfl, int ch)
6254 *pmfl |= PMf_GLOBAL;
6256 *pmfl |= PMf_CONTINUE;
6260 *pmfl |= PMf_MULTILINE;
6262 *pmfl |= PMf_SINGLELINE;
6264 *pmfl |= PMf_EXTENDED;
6268 S_scan_pat(pTHX_ char *start, I32 type)
6273 s = scan_str(start,FALSE,FALSE);
6275 Perl_croak(aTHX_ "Search pattern not terminated");
6277 pm = (PMOP*)newPMOP(type, 0);
6278 if (PL_multi_open == '?')
6279 pm->op_pmflags |= PMf_ONCE;
6281 while (*s && strchr("iomsx", *s))
6282 pmflag(&pm->op_pmflags,*s++);
6285 while (*s && strchr("iogcmsx", *s))
6286 pmflag(&pm->op_pmflags,*s++);
6288 /* issue a warning if /c is specified,but /g is not */
6289 if (ckWARN(WARN_REGEXP) &&
6290 (pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL))
6292 Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_without_g);
6295 pm->op_pmpermflags = pm->op_pmflags;
6297 PL_lex_op = (OP*)pm;
6298 yylval.ival = OP_MATCH;
6303 S_scan_subst(pTHX_ char *start)
6310 yylval.ival = OP_NULL;
6312 s = scan_str(start,FALSE,FALSE);
6315 Perl_croak(aTHX_ "Substitution pattern not terminated");
6317 if (s[-1] == PL_multi_open)
6320 first_start = PL_multi_start;
6321 s = scan_str(s,FALSE,FALSE);
6324 SvREFCNT_dec(PL_lex_stuff);
6325 PL_lex_stuff = Nullsv;
6327 Perl_croak(aTHX_ "Substitution replacement not terminated");
6329 PL_multi_start = first_start; /* so whole substitution is taken together */
6331 pm = (PMOP*)newPMOP(OP_SUBST, 0);
6337 else if (strchr("iogcmsx", *s))
6338 pmflag(&pm->op_pmflags,*s++);
6343 /* issue a warning if /c is specified,but /g is not */
6344 if (ckWARN(WARN_REGEXP) &&
6345 (pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL))
6347 Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_without_g);
6352 PL_sublex_info.super_bufptr = s;
6353 PL_sublex_info.super_bufend = PL_bufend;
6355 pm->op_pmflags |= PMf_EVAL;
6356 repl = newSVpvn("",0);
6358 sv_catpv(repl, es ? "eval " : "do ");
6359 sv_catpvn(repl, "{ ", 2);
6360 sv_catsv(repl, PL_lex_repl);
6361 sv_catpvn(repl, " };", 2);
6363 SvREFCNT_dec(PL_lex_repl);
6367 pm->op_pmpermflags = pm->op_pmflags;
6368 PL_lex_op = (OP*)pm;
6369 yylval.ival = OP_SUBST;
6374 S_scan_trans(pTHX_ char *start)
6383 yylval.ival = OP_NULL;
6385 s = scan_str(start,FALSE,FALSE);
6387 Perl_croak(aTHX_ "Transliteration pattern not terminated");
6388 if (s[-1] == PL_multi_open)
6391 s = scan_str(s,FALSE,FALSE);
6394 SvREFCNT_dec(PL_lex_stuff);
6395 PL_lex_stuff = Nullsv;
6397 Perl_croak(aTHX_ "Transliteration replacement not terminated");
6400 complement = del = squash = 0;
6401 while (strchr("cds", *s)) {
6403 complement = OPpTRANS_COMPLEMENT;
6405 del = OPpTRANS_DELETE;
6407 squash = OPpTRANS_SQUASH;
6411 New(803, tbl, complement&&!del?258:256, short);
6412 o = newPVOP(OP_TRANS, 0, (char*)tbl);
6413 o->op_private = del|squash|complement|
6414 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
6415 (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0);
6418 yylval.ival = OP_TRANS;
6423 S_scan_heredoc(pTHX_ register char *s)
6426 I32 op_type = OP_SCALAR;
6433 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
6437 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
6440 for (peek = s; SPACE_OR_TAB(*peek); peek++) ;
6441 if (*peek && strchr("`'\"",*peek)) {
6444 s = delimcpy(d, e, s, PL_bufend, term, &len);
6454 if (!isALNUM_lazy_if(s,UTF))
6455 deprecate_old("bare << to mean <<\"\"");
6456 for (; isALNUM_lazy_if(s,UTF); s++) {
6461 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
6462 Perl_croak(aTHX_ "Delimiter for here document is too long");
6465 len = d - PL_tokenbuf;
6466 #ifndef PERL_STRICT_CR
6467 d = strchr(s, '\r');
6471 while (s < PL_bufend) {
6477 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
6486 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6491 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
6492 herewas = newSVpvn(s,PL_bufend-s);
6494 s--, herewas = newSVpvn(s,d-s);
6495 s += SvCUR(herewas);
6497 tmpstr = NEWSV(87,79);
6498 sv_upgrade(tmpstr, SVt_PVIV);
6503 else if (term == '`') {
6504 op_type = OP_BACKTICK;
6505 SvIVX(tmpstr) = '\\';
6509 PL_multi_start = CopLINE(PL_curcop);
6510 PL_multi_open = PL_multi_close = '<';
6511 term = *PL_tokenbuf;
6512 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
6513 char *bufptr = PL_sublex_info.super_bufptr;
6514 char *bufend = PL_sublex_info.super_bufend;
6515 char *olds = s - SvCUR(herewas);
6516 s = strchr(bufptr, '\n');
6520 while (s < bufend &&
6521 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6523 CopLINE_inc(PL_curcop);
6526 CopLINE_set(PL_curcop, PL_multi_start);
6527 missingterm(PL_tokenbuf);
6529 sv_setpvn(herewas,bufptr,d-bufptr+1);
6530 sv_setpvn(tmpstr,d+1,s-d);
6532 sv_catpvn(herewas,s,bufend-s);
6533 (void)strcpy(bufptr,SvPVX(herewas));
6540 while (s < PL_bufend &&
6541 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6543 CopLINE_inc(PL_curcop);
6545 if (s >= PL_bufend) {
6546 CopLINE_set(PL_curcop, PL_multi_start);
6547 missingterm(PL_tokenbuf);
6549 sv_setpvn(tmpstr,d+1,s-d);
6551 CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
6553 sv_catpvn(herewas,s,PL_bufend-s);
6554 sv_setsv(PL_linestr,herewas);
6555 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
6556 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6557 PL_last_lop = PL_last_uni = Nullch;
6560 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
6561 while (s >= PL_bufend) { /* multiple line string? */
6563 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6564 CopLINE_set(PL_curcop, PL_multi_start);
6565 missingterm(PL_tokenbuf);
6567 CopLINE_inc(PL_curcop);
6568 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6569 PL_last_lop = PL_last_uni = Nullch;
6570 #ifndef PERL_STRICT_CR
6571 if (PL_bufend - PL_linestart >= 2) {
6572 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
6573 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
6575 PL_bufend[-2] = '\n';
6577 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6579 else if (PL_bufend[-1] == '\r')
6580 PL_bufend[-1] = '\n';
6582 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
6583 PL_bufend[-1] = '\n';
6585 if (PERLDB_LINE && PL_curstash != PL_debstash) {
6586 SV *sv = NEWSV(88,0);
6588 sv_upgrade(sv, SVt_PVMG);
6589 sv_setsv(sv,PL_linestr);
6592 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop),sv);
6594 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
6597 sv_catsv(PL_linestr,herewas);
6598 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6602 sv_catsv(tmpstr,PL_linestr);
6607 PL_multi_end = CopLINE(PL_curcop);
6608 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
6609 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
6610 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
6612 SvREFCNT_dec(herewas);
6613 if (UTF && !IN_BYTES && is_utf8_string((U8*)SvPVX(tmpstr), SvCUR(tmpstr)))
6615 PL_lex_stuff = tmpstr;
6616 yylval.ival = op_type;
6621 takes: current position in input buffer
6622 returns: new position in input buffer
6623 side-effects: yylval and lex_op are set.
6628 <FH> read from filehandle
6629 <pkg::FH> read from package qualified filehandle
6630 <pkg'FH> read from package qualified filehandle
6631 <$fh> read from filehandle in $fh
6637 S_scan_inputsymbol(pTHX_ char *start)
6639 register char *s = start; /* current position in buffer */
6645 d = PL_tokenbuf; /* start of temp holding space */
6646 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
6647 end = strchr(s, '\n');
6650 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
6652 /* die if we didn't have space for the contents of the <>,
6653 or if it didn't end, or if we see a newline
6656 if (len >= sizeof PL_tokenbuf)
6657 Perl_croak(aTHX_ "Excessively long <> operator");
6659 Perl_croak(aTHX_ "Unterminated <> operator");
6664 Remember, only scalar variables are interpreted as filehandles by
6665 this code. Anything more complex (e.g., <$fh{$num}>) will be
6666 treated as a glob() call.
6667 This code makes use of the fact that except for the $ at the front,
6668 a scalar variable and a filehandle look the same.
6670 if (*d == '$' && d[1]) d++;
6672 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
6673 while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
6676 /* If we've tried to read what we allow filehandles to look like, and
6677 there's still text left, then it must be a glob() and not a getline.
6678 Use scan_str to pull out the stuff between the <> and treat it
6679 as nothing more than a string.
6682 if (d - PL_tokenbuf != len) {
6683 yylval.ival = OP_GLOB;
6685 s = scan_str(start,FALSE,FALSE);
6687 Perl_croak(aTHX_ "Glob not terminated");
6691 bool readline_overriden = FALSE;
6692 GV *gv_readline = Nullgv;
6694 /* we're in a filehandle read situation */
6697 /* turn <> into <ARGV> */
6699 (void)strcpy(d,"ARGV");
6701 /* Check whether readline() is overriden */
6702 if (((gv_readline = gv_fetchpv("readline", FALSE, SVt_PVCV))
6703 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
6705 ((gvp = (GV**)hv_fetch(PL_globalstash, "readline", 8, FALSE))
6706 && (gv_readline = *gvp) != (GV*)&PL_sv_undef
6707 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
6708 readline_overriden = TRUE;
6710 /* if <$fh>, create the ops to turn the variable into a
6716 /* try to find it in the pad for this block, otherwise find
6717 add symbol table ops
6719 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
6720 SV *namesv = AvARRAY(PL_comppad_name)[tmp];
6721 if (SvFLAGS(namesv) & SVpad_OUR) {
6722 SV *sym = sv_2mortal(newSVpv(HvNAME(GvSTASH(namesv)),0));
6723 sv_catpvn(sym, "::", 2);
6729 OP *o = newOP(OP_PADSV, 0);
6731 PL_lex_op = readline_overriden
6732 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
6733 append_elem(OP_LIST, o,
6734 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
6735 : (OP*)newUNOP(OP_READLINE, 0, o);
6744 ? (GV_ADDMULTI | GV_ADDINEVAL)
6747 PL_lex_op = readline_overriden
6748 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
6749 append_elem(OP_LIST,
6750 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
6751 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
6752 : (OP*)newUNOP(OP_READLINE, 0,
6753 newUNOP(OP_RV2SV, 0,
6754 newGVOP(OP_GV, 0, gv)));
6756 if (!readline_overriden)
6757 PL_lex_op->op_flags |= OPf_SPECIAL;
6758 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
6759 yylval.ival = OP_NULL;
6762 /* If it's none of the above, it must be a literal filehandle
6763 (<Foo::BAR> or <FOO>) so build a simple readline OP */
6765 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
6766 PL_lex_op = readline_overriden
6767 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
6768 append_elem(OP_LIST,
6769 newGVOP(OP_GV, 0, gv),
6770 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
6771 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
6772 yylval.ival = OP_NULL;
6781 takes: start position in buffer
6782 keep_quoted preserve \ on the embedded delimiter(s)
6783 keep_delims preserve the delimiters around the string
6784 returns: position to continue reading from buffer
6785 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
6786 updates the read buffer.
6788 This subroutine pulls a string out of the input. It is called for:
6789 q single quotes q(literal text)
6790 ' single quotes 'literal text'
6791 qq double quotes qq(interpolate $here please)
6792 " double quotes "interpolate $here please"
6793 qx backticks qx(/bin/ls -l)
6794 ` backticks `/bin/ls -l`
6795 qw quote words @EXPORT_OK = qw( func() $spam )
6796 m// regexp match m/this/
6797 s/// regexp substitute s/this/that/
6798 tr/// string transliterate tr/this/that/
6799 y/// string transliterate y/this/that/
6800 ($*@) sub prototypes sub foo ($)
6801 (stuff) sub attr parameters sub foo : attr(stuff)
6802 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
6804 In most of these cases (all but <>, patterns and transliterate)
6805 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
6806 calls scan_str(). s/// makes yylex() call scan_subst() which calls
6807 scan_str(). tr/// and y/// make yylex() call scan_trans() which
6810 It skips whitespace before the string starts, and treats the first
6811 character as the delimiter. If the delimiter is one of ([{< then
6812 the corresponding "close" character )]}> is used as the closing
6813 delimiter. It allows quoting of delimiters, and if the string has
6814 balanced delimiters ([{<>}]) it allows nesting.
6816 On success, the SV with the resulting string is put into lex_stuff or,
6817 if that is already non-NULL, into lex_repl. The second case occurs only
6818 when parsing the RHS of the special constructs s/// and tr/// (y///).
6819 For convenience, the terminating delimiter character is stuffed into
6824 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
6826 SV *sv; /* scalar value: string */
6827 char *tmps; /* temp string, used for delimiter matching */
6828 register char *s = start; /* current position in the buffer */
6829 register char term; /* terminating character */
6830 register char *to; /* current position in the sv's data */
6831 I32 brackets = 1; /* bracket nesting level */
6832 bool has_utf8 = FALSE; /* is there any utf8 content? */
6834 /* skip space before the delimiter */
6838 /* mark where we are, in case we need to report errors */
6841 /* after skipping whitespace, the next character is the terminator */
6843 if (!UTF8_IS_INVARIANT((U8)term) && UTF)
6846 /* mark where we are */
6847 PL_multi_start = CopLINE(PL_curcop);
6848 PL_multi_open = term;
6850 /* find corresponding closing delimiter */
6851 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
6853 PL_multi_close = term;
6855 /* create a new SV to hold the contents. 87 is leak category, I'm
6856 assuming. 79 is the SV's initial length. What a random number. */
6858 sv_upgrade(sv, SVt_PVIV);
6860 (void)SvPOK_only(sv); /* validate pointer */
6862 /* move past delimiter and try to read a complete string */
6864 sv_catpvn(sv, s, 1);
6867 /* extend sv if need be */
6868 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
6869 /* set 'to' to the next character in the sv's string */
6870 to = SvPVX(sv)+SvCUR(sv);
6872 /* if open delimiter is the close delimiter read unbridle */
6873 if (PL_multi_open == PL_multi_close) {
6874 for (; s < PL_bufend; s++,to++) {
6875 /* embedded newlines increment the current line number */
6876 if (*s == '\n' && !PL_rsfp)
6877 CopLINE_inc(PL_curcop);
6878 /* handle quoted delimiters */
6879 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
6880 if (!keep_quoted && s[1] == term)
6882 /* any other quotes are simply copied straight through */
6886 /* terminate when run out of buffer (the for() condition), or
6887 have found the terminator */
6888 else if (*s == term)
6890 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
6896 /* if the terminator isn't the same as the start character (e.g.,
6897 matched brackets), we have to allow more in the quoting, and
6898 be prepared for nested brackets.
6901 /* read until we run out of string, or we find the terminator */
6902 for (; s < PL_bufend; s++,to++) {
6903 /* embedded newlines increment the line count */
6904 if (*s == '\n' && !PL_rsfp)
6905 CopLINE_inc(PL_curcop);
6906 /* backslashes can escape the open or closing characters */
6907 if (*s == '\\' && s+1 < PL_bufend) {
6909 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
6914 /* allow nested opens and closes */
6915 else if (*s == PL_multi_close && --brackets <= 0)
6917 else if (*s == PL_multi_open)
6919 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
6924 /* terminate the copied string and update the sv's end-of-string */
6926 SvCUR_set(sv, to - SvPVX(sv));
6929 * this next chunk reads more into the buffer if we're not done yet
6933 break; /* handle case where we are done yet :-) */
6935 #ifndef PERL_STRICT_CR
6936 if (to - SvPVX(sv) >= 2) {
6937 if ((to[-2] == '\r' && to[-1] == '\n') ||
6938 (to[-2] == '\n' && to[-1] == '\r'))
6942 SvCUR_set(sv, to - SvPVX(sv));
6944 else if (to[-1] == '\r')
6947 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
6951 /* if we're out of file, or a read fails, bail and reset the current
6952 line marker so we can report where the unterminated string began
6955 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6957 CopLINE_set(PL_curcop, PL_multi_start);
6960 /* we read a line, so increment our line counter */
6961 CopLINE_inc(PL_curcop);
6963 /* update debugger info */
6964 if (PERLDB_LINE && PL_curstash != PL_debstash) {
6965 SV *sv = NEWSV(88,0);
6967 sv_upgrade(sv, SVt_PVMG);
6968 sv_setsv(sv,PL_linestr);
6971 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop), sv);
6974 /* having changed the buffer, we must update PL_bufend */
6975 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6976 PL_last_lop = PL_last_uni = Nullch;
6979 /* at this point, we have successfully read the delimited string */
6982 sv_catpvn(sv, s, 1);
6985 PL_multi_end = CopLINE(PL_curcop);
6988 /* if we allocated too much space, give some back */
6989 if (SvCUR(sv) + 5 < SvLEN(sv)) {
6990 SvLEN_set(sv, SvCUR(sv) + 1);
6991 Renew(SvPVX(sv), SvLEN(sv), char);
6994 /* decide whether this is the first or second quoted string we've read
7007 takes: pointer to position in buffer
7008 returns: pointer to new position in buffer
7009 side-effects: builds ops for the constant in yylval.op
7011 Read a number in any of the formats that Perl accepts:
7013 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
7014 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
7017 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
7019 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
7022 If it reads a number without a decimal point or an exponent, it will
7023 try converting the number to an integer and see if it can do so
7024 without loss of precision.
7028 Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp)
7030 register char *s = start; /* current position in buffer */
7031 register char *d; /* destination in temp buffer */
7032 register char *e; /* end of temp buffer */
7033 NV nv; /* number read, as a double */
7034 SV *sv = Nullsv; /* place to put the converted number */
7035 bool floatit; /* boolean: int or float? */
7036 char *lastub = 0; /* position of last underbar */
7037 static char number_too_long[] = "Number too long";
7039 /* We use the first character to decide what type of number this is */
7043 Perl_croak(aTHX_ "panic: scan_num");
7045 /* if it starts with a 0, it could be an octal number, a decimal in
7046 0.13 disguise, or a hexadecimal number, or a binary number. */
7050 u holds the "number so far"
7051 shift the power of 2 of the base
7052 (hex == 4, octal == 3, binary == 1)
7053 overflowed was the number more than we can hold?
7055 Shift is used when we add a digit. It also serves as an "are
7056 we in octal/hex/binary?" indicator to disallow hex characters
7062 bool overflowed = FALSE;
7063 static NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
7064 static char* bases[5] = { "", "binary", "", "octal",
7066 static char* Bases[5] = { "", "Binary", "", "Octal",
7068 static char *maxima[5] = { "",
7069 "0b11111111111111111111111111111111",
7073 char *base, *Base, *max;
7079 } else if (s[1] == 'b') {
7083 /* check for a decimal in disguise */
7084 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
7086 /* so it must be octal */
7093 if (ckWARN(WARN_SYNTAX))
7094 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7095 "Misplaced _ in number");
7099 base = bases[shift];
7100 Base = Bases[shift];
7101 max = maxima[shift];
7103 /* read the rest of the number */
7105 /* x is used in the overflow test,
7106 b is the digit we're adding on. */
7111 /* if we don't mention it, we're done */
7115 /* _ are ignored -- but warned about if consecutive */
7117 if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
7118 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7119 "Misplaced _ in number");
7123 /* 8 and 9 are not octal */
7126 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
7130 case '2': case '3': case '4':
7131 case '5': case '6': case '7':
7133 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
7137 b = *s++ & 15; /* ASCII digit -> value of digit */
7141 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
7142 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
7143 /* make sure they said 0x */
7148 /* Prepare to put the digit we have onto the end
7149 of the number so far. We check for overflows.
7154 x = u << shift; /* make room for the digit */
7156 if ((x >> shift) != u
7157 && !(PL_hints & HINT_NEW_BINARY)) {
7160 if (ckWARN_d(WARN_OVERFLOW))
7161 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
7162 "Integer overflow in %s number",
7165 u = x | b; /* add the digit to the end */
7168 n *= nvshift[shift];
7169 /* If an NV has not enough bits in its
7170 * mantissa to represent an UV this summing of
7171 * small low-order numbers is a waste of time
7172 * (because the NV cannot preserve the
7173 * low-order bits anyway): we could just
7174 * remember when did we overflow and in the
7175 * end just multiply n by the right
7183 /* if we get here, we had success: make a scalar value from
7188 /* final misplaced underbar check */
7190 if (ckWARN(WARN_SYNTAX))
7191 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
7196 if (ckWARN(WARN_PORTABLE) && n > 4294967295.0)
7197 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
7198 "%s number > %s non-portable",
7204 if (ckWARN(WARN_PORTABLE) && u > 0xffffffff)
7205 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
7206 "%s number > %s non-portable",
7211 if (PL_hints & HINT_NEW_BINARY)
7212 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
7217 handle decimal numbers.
7218 we're also sent here when we read a 0 as the first digit
7220 case '1': case '2': case '3': case '4': case '5':
7221 case '6': case '7': case '8': case '9': case '.':
7224 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
7227 /* read next group of digits and _ and copy into d */
7228 while (isDIGIT(*s) || *s == '_') {
7229 /* skip underscores, checking for misplaced ones
7233 if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
7234 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7235 "Misplaced _ in number");
7239 /* check for end of fixed-length buffer */
7241 Perl_croak(aTHX_ number_too_long);
7242 /* if we're ok, copy the character */
7247 /* final misplaced underbar check */
7248 if (lastub && s == lastub + 1) {
7249 if (ckWARN(WARN_SYNTAX))
7250 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
7253 /* read a decimal portion if there is one. avoid
7254 3..5 being interpreted as the number 3. followed
7257 if (*s == '.' && s[1] != '.') {
7262 if (ckWARN(WARN_SYNTAX))
7263 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7264 "Misplaced _ in number");
7268 /* copy, ignoring underbars, until we run out of digits.
7270 for (; isDIGIT(*s) || *s == '_'; s++) {
7271 /* fixed length buffer check */
7273 Perl_croak(aTHX_ number_too_long);
7275 if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
7276 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7277 "Misplaced _ in number");
7283 /* fractional part ending in underbar? */
7285 if (ckWARN(WARN_SYNTAX))
7286 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7287 "Misplaced _ in number");
7289 if (*s == '.' && isDIGIT(s[1])) {
7290 /* oops, it's really a v-string, but without the "v" */
7296 /* read exponent part, if present */
7297 if (*s && strchr("eE",*s) && strchr("+-0123456789_", s[1])) {
7301 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
7302 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
7304 /* stray preinitial _ */
7306 if (ckWARN(WARN_SYNTAX))
7307 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7308 "Misplaced _ in number");
7312 /* allow positive or negative exponent */
7313 if (*s == '+' || *s == '-')
7316 /* stray initial _ */
7318 if (ckWARN(WARN_SYNTAX))
7319 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7320 "Misplaced _ in number");
7324 /* read digits of exponent */
7325 while (isDIGIT(*s) || *s == '_') {
7328 Perl_croak(aTHX_ number_too_long);
7332 if (ckWARN(WARN_SYNTAX) &&
7333 ((lastub && s == lastub + 1) ||
7334 (!isDIGIT(s[1]) && s[1] != '_')))
7335 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7336 "Misplaced _ in number");
7343 /* make an sv from the string */
7347 We try to do an integer conversion first if no characters
7348 indicating "float" have been found.
7353 int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
7355 if (flags == IS_NUMBER_IN_UV) {
7357 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
7360 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
7361 if (uv <= (UV) IV_MIN)
7362 sv_setiv(sv, -(IV)uv);
7369 /* terminate the string */
7371 nv = Atof(PL_tokenbuf);
7375 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
7376 (PL_hints & HINT_NEW_INTEGER) )
7377 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
7378 (floatit ? "float" : "integer"),
7382 /* if it starts with a v, it could be a v-string */
7385 sv = NEWSV(92,5); /* preallocate storage space */
7386 s = new_vstring(s,sv);
7390 /* make the op for the constant and return */
7393 lvalp->opval = newSVOP(OP_CONST, 0, sv);
7395 lvalp->opval = Nullop;
7401 S_scan_formline(pTHX_ register char *s)
7405 SV *stuff = newSVpvn("",0);
7406 bool needargs = FALSE;
7409 if (*s == '.' || *s == /*{*/'}') {
7411 #ifdef PERL_STRICT_CR
7412 for (t = s+1;SPACE_OR_TAB(*t); t++) ;
7414 for (t = s+1;SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
7416 if (*t == '\n' || t == PL_bufend)
7419 if (PL_in_eval && !PL_rsfp) {
7420 eol = strchr(s,'\n');
7425 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7427 for (t = s; t < eol; t++) {
7428 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
7430 goto enough; /* ~~ must be first line in formline */
7432 if (*t == '@' || *t == '^')
7436 sv_catpvn(stuff, s, eol-s);
7437 #ifndef PERL_STRICT_CR
7438 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
7439 char *end = SvPVX(stuff) + SvCUR(stuff);
7451 s = filter_gets(PL_linestr, PL_rsfp, 0);
7452 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
7453 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
7454 PL_last_lop = PL_last_uni = Nullch;
7457 yyerror("Format not terminated");
7467 PL_lex_state = LEX_NORMAL;
7468 PL_nextval[PL_nexttoke].ival = 0;
7472 PL_lex_state = LEX_FORMLINE;
7473 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
7475 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
7479 SvREFCNT_dec(stuff);
7480 PL_lex_formbrack = 0;
7491 PL_cshlen = strlen(PL_cshname);
7496 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
7498 I32 oldsavestack_ix = PL_savestack_ix;
7499 CV* outsidecv = PL_compcv;
7503 assert(SvTYPE(PL_compcv) == SVt_PVCV);
7505 SAVEI32(PL_subline);
7506 save_item(PL_subname);
7509 SAVESPTR(PL_comppad_name);
7510 SAVESPTR(PL_compcv);
7511 SAVEI32(PL_comppad_name_fill);
7512 SAVEI32(PL_min_intro_pending);
7513 SAVEI32(PL_max_intro_pending);
7514 SAVEI32(PL_pad_reset_pending);
7516 PL_compcv = (CV*)NEWSV(1104,0);
7517 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
7518 CvFLAGS(PL_compcv) |= flags;
7520 PL_comppad = newAV();
7521 av_push(PL_comppad, Nullsv);
7522 PL_curpad = AvARRAY(PL_comppad);
7523 PL_comppad_name = newAV();
7524 PL_comppad_name_fill = 0;
7525 PL_min_intro_pending = 0;
7527 PL_subline = CopLINE(PL_curcop);
7528 #ifdef USE_5005THREADS
7529 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
7530 PL_curpad[0] = (SV*)newAV();
7531 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
7532 #endif /* USE_5005THREADS */
7534 comppadlist = newAV();
7535 AvREAL_off(comppadlist);
7536 av_store(comppadlist, 0, (SV*)PL_comppad_name);
7537 av_store(comppadlist, 1, (SV*)PL_comppad);
7539 CvPADLIST(PL_compcv) = comppadlist;
7540 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
7541 #ifdef USE_5005THREADS
7542 CvOWNER(PL_compcv) = 0;
7543 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
7544 MUTEX_INIT(CvMUTEXP(PL_compcv));
7545 #endif /* USE_5005THREADS */
7547 return oldsavestack_ix;
7551 #pragma segment Perl_yylex
7554 Perl_yywarn(pTHX_ char *s)
7556 PL_in_eval |= EVAL_WARNONLY;
7558 PL_in_eval &= ~EVAL_WARNONLY;
7563 Perl_yyerror(pTHX_ char *s)
7566 char *context = NULL;
7570 if (!yychar || (yychar == ';' && !PL_rsfp))
7572 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
7573 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
7574 while (isSPACE(*PL_oldoldbufptr))
7576 context = PL_oldoldbufptr;
7577 contlen = PL_bufptr - PL_oldoldbufptr;
7579 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
7580 PL_oldbufptr != PL_bufptr) {
7581 while (isSPACE(*PL_oldbufptr))
7583 context = PL_oldbufptr;
7584 contlen = PL_bufptr - PL_oldbufptr;
7586 else if (yychar > 255)
7587 where = "next token ???";
7588 #ifdef USE_PURE_BISON
7589 /* GNU Bison sets the value -2 */
7590 else if (yychar == -2) {
7592 else if ((yychar & 127) == 127) {
7594 if (PL_lex_state == LEX_NORMAL ||
7595 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
7596 where = "at end of line";
7597 else if (PL_lex_inpat)
7598 where = "within pattern";
7600 where = "within string";
7603 SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
7605 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
7606 else if (isPRINT_LC(yychar))
7607 Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
7609 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
7610 where = SvPVX(where_sv);
7612 msg = sv_2mortal(newSVpv(s, 0));
7613 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
7614 OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
7616 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
7618 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
7619 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
7620 Perl_sv_catpvf(aTHX_ msg,
7621 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
7622 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
7625 if (PL_in_eval & EVAL_WARNONLY)
7626 Perl_warn(aTHX_ "%"SVf, msg);
7629 if (PL_error_count >= 10) {
7630 if (PL_in_eval && SvCUR(ERRSV))
7631 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
7632 ERRSV, OutCopFILE(PL_curcop));
7634 Perl_croak(aTHX_ "%s has too many errors.\n",
7635 OutCopFILE(PL_curcop));
7638 PL_in_my_stash = Nullhv;
7642 #pragma segment Main
7646 S_swallow_bom(pTHX_ U8 *s)
7649 slen = SvCUR(PL_linestr);
7653 /* UTF-16 little-endian */
7654 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
7655 Perl_croak(aTHX_ "Unsupported script encoding");
7656 #ifndef PERL_NO_UTF16_FILTER
7657 DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-LE script encoding\n"));
7659 if (PL_bufend > (char*)s) {
7663 filter_add(utf16rev_textfilter, NULL);
7664 New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
7665 PL_bufend = (char*)utf16_to_utf8_reversed(s, news,
7666 PL_bufend - (char*)s - 1,
7668 Copy(news, s, newlen, U8);
7669 SvCUR_set(PL_linestr, newlen);
7670 PL_bufend = SvPVX(PL_linestr) + newlen;
7671 news[newlen++] = '\0';
7675 Perl_croak(aTHX_ "Unsupported script encoding");
7680 if (s[1] == 0xFF) { /* UTF-16 big-endian */
7681 #ifndef PERL_NO_UTF16_FILTER
7682 DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding\n"));
7684 if (PL_bufend > (char *)s) {
7688 filter_add(utf16_textfilter, NULL);
7689 New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
7690 PL_bufend = (char*)utf16_to_utf8(s, news,
7691 PL_bufend - (char*)s,
7693 Copy(news, s, newlen, U8);
7694 SvCUR_set(PL_linestr, newlen);
7695 PL_bufend = SvPVX(PL_linestr) + newlen;
7696 news[newlen++] = '\0';
7700 Perl_croak(aTHX_ "Unsupported script encoding");
7705 if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
7706 DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-8 script encoding\n"));
7711 if (slen > 3 && s[1] == 0 && /* UTF-32 big-endian */
7712 s[2] == 0xFE && s[3] == 0xFF)
7714 Perl_croak(aTHX_ "Unsupported script encoding");
7722 * Restore a source filter.
7726 restore_rsfp(pTHX_ void *f)
7728 PerlIO *fp = (PerlIO*)f;
7730 if (PL_rsfp == PerlIO_stdin())
7731 PerlIO_clearerr(PL_rsfp);
7732 else if (PL_rsfp && (PL_rsfp != fp))
7733 PerlIO_close(PL_rsfp);
7737 #ifndef PERL_NO_UTF16_FILTER
7739 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
7741 I32 count = FILTER_READ(idx+1, sv, maxlen);
7746 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
7747 if (!*SvPV_nolen(sv))
7748 /* Game over, but don't feed an odd-length string to utf16_to_utf8 */
7751 tend = utf16_to_utf8((U8*)SvPVX(sv), tmps, SvCUR(sv), &newlen);
7752 sv_usepvn(sv, (char*)tmps, tend - tmps);
7758 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
7760 I32 count = FILTER_READ(idx+1, sv, maxlen);
7765 if (!*SvPV_nolen(sv))
7766 /* Game over, but don't feed an odd-length string to utf16_to_utf8 */
7769 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
7770 tend = utf16_to_utf8_reversed((U8*)SvPVX(sv), tmps, SvCUR(sv), &newlen);
7771 sv_usepvn(sv, (char*)tmps, tend - tmps);