3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "It all comes from here, the stench and the peril." --Frodo
16 * This file is the lexer for Perl. It's closely linked to the
19 * The main routine is yylex(), which returns the next token.
23 #define PERL_IN_TOKE_C
26 #define yychar PL_yychar
27 #define yylval PL_yylval
29 static char ident_too_long[] = "Identifier too long";
30 static char c_without_g[] = "Use of /c modifier is meaningless without /g";
31 static char c_in_subst[] = "Use of /c modifier is meaningless in s///";
33 static void restore_rsfp(pTHX_ void *f);
34 #ifndef PERL_NO_UTF16_FILTER
35 static I32 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen);
36 static I32 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen);
39 #define XFAKEBRACK 128
42 #ifdef USE_UTF8_SCRIPTS
43 # define UTF (!IN_BYTES)
45 # define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || (PL_hints & HINT_UTF8))
48 /* In variables named $^X, these are the legal values for X.
49 * 1999-02-27 mjd-perl-patch@plover.com */
50 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
52 /* On MacOS, respect nonbreaking spaces */
53 #ifdef MACOS_TRADITIONAL
54 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\312'||(c)=='\t')
56 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\t')
59 /* LEX_* are values for PL_lex_state, the state of the lexer.
60 * They are arranged oddly so that the guard on the switch statement
61 * can get by with a single comparison (if the compiler is smart enough).
64 /* #define LEX_NOTPARSING 11 is done in perl.h. */
67 #define LEX_INTERPNORMAL 9
68 #define LEX_INTERPCASEMOD 8
69 #define LEX_INTERPPUSH 7
70 #define LEX_INTERPSTART 6
71 #define LEX_INTERPEND 5
72 #define LEX_INTERPENDMAYBE 4
73 #define LEX_INTERPCONCAT 3
74 #define LEX_INTERPCONST 2
75 #define LEX_FORMLINE 1
76 #define LEX_KNOWNEXT 0
84 # define YYMAXLEVEL 100
86 YYSTYPE* yylval_pointer[YYMAXLEVEL];
87 int* yychar_pointer[YYMAXLEVEL];
91 # define yylval (*yylval_pointer[yyactlevel])
92 # define yychar (*yychar_pointer[yyactlevel])
93 # define PERL_YYLEX_PARAM yylval_pointer[yyactlevel],yychar_pointer[yyactlevel]
95 # define yylex() Perl_yylex_r(aTHX_ yylval_pointer[yyactlevel],yychar_pointer[yyactlevel])
100 /* CLINE is a macro that ensures PL_copline has a sane value */
105 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
108 * Convenience functions to return different tokens and prime the
109 * lexer for the next token. They all take an argument.
111 * TOKEN : generic token (used for '(', DOLSHARP, etc)
112 * OPERATOR : generic operator
113 * AOPERATOR : assignment operator
114 * PREBLOCK : beginning the block after an if, while, foreach, ...
115 * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
116 * PREREF : *EXPR where EXPR is not a simple identifier
117 * TERM : expression term
118 * LOOPX : loop exiting command (goto, last, dump, etc)
119 * FTST : file test operator
120 * FUN0 : zero-argument function
121 * FUN1 : not used, except for not, which isn't a UNIOP
122 * BOop : bitwise or or xor
124 * SHop : shift operator
125 * PWop : power operator
126 * PMop : pattern-matching operator
127 * Aop : addition-level operator
128 * Mop : multiplication-level operator
129 * Eop : equality-testing operator
130 * Rop : relational operator <= != gt
132 * Also see LOP and lop() below.
135 /* Note that REPORT() and REPORT2() will be expressions that supply
136 * their own trailing comma, not suitable for statements as such. */
137 #ifdef DEBUGGING /* Serve -DT. */
138 # define REPORT(x,retval) tokereport(x,s,(int)retval),
139 # define REPORT2(x,retval) tokereport(x,s, yylval.ival),
141 # define REPORT(x,retval)
142 # define REPORT2(x,retval)
145 #define TOKEN(retval) return (REPORT2("token",retval) PL_bufptr = s,(int)retval)
146 #define OPERATOR(retval) return (REPORT2("operator",retval) PL_expect = XTERM, PL_bufptr = s,(int)retval)
147 #define AOPERATOR(retval) return ao((REPORT2("aop",retval) PL_expect = XTERM, PL_bufptr = s,(int)retval))
148 #define PREBLOCK(retval) return (REPORT2("preblock",retval) PL_expect = XBLOCK,PL_bufptr = s,(int)retval)
149 #define PRETERMBLOCK(retval) return (REPORT2("pretermblock",retval) PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval)
150 #define PREREF(retval) return (REPORT2("preref",retval) PL_expect = XREF,PL_bufptr = s,(int)retval)
151 #define TERM(retval) return (CLINE, REPORT2("term",retval) PL_expect = XOPERATOR, PL_bufptr = s,(int)retval)
152 #define LOOPX(f) return(yylval.ival=f, REPORT("loopx",f) PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX)
153 #define FTST(f) return(yylval.ival=f, REPORT("ftst",f) PL_expect = XTERMORDORDOR,PL_bufptr = s,(int)UNIOP)
154 #define FUN0(f) return(yylval.ival = f, REPORT("fun0",f) PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0)
155 #define FUN1(f) return(yylval.ival = f, REPORT("fun1",f) PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1)
156 #define BOop(f) return ao((yylval.ival=f, REPORT("bitorop",f) PL_expect = XTERM,PL_bufptr = s,(int)BITOROP))
157 #define BAop(f) return ao((yylval.ival=f, REPORT("bitandop",f) PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP))
158 #define SHop(f) return ao((yylval.ival=f, REPORT("shiftop",f) PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP))
159 #define PWop(f) return ao((yylval.ival=f, REPORT("powop",f) PL_expect = XTERM,PL_bufptr = s,(int)POWOP))
160 #define PMop(f) return(yylval.ival=f, REPORT("matchop",f) PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP)
161 #define Aop(f) return ao((yylval.ival=f, REPORT("add",f) PL_expect = XTERM,PL_bufptr = s,(int)ADDOP))
162 #define Mop(f) return ao((yylval.ival=f, REPORT("mul",f) PL_expect = XTERM,PL_bufptr = s,(int)MULOP))
163 #define Eop(f) return(yylval.ival=f, REPORT("eq",f) PL_expect = XTERM,PL_bufptr = s,(int)EQOP)
164 #define Rop(f) return(yylval.ival=f, REPORT("rel",f) PL_expect = XTERM,PL_bufptr = s,(int)RELOP)
166 /* This bit of chicanery makes a unary function followed by
167 * a parenthesis into a function with one argument, highest precedence.
168 * The UNIDOR macro is for unary functions that can be followed by the //
169 * operator (such as C<shift // 0>).
171 #define UNI2(f,x) 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) )
178 #define UNI(f) UNI2(f,XTERM)
179 #define UNIDOR(f) UNI2(f,XTERMORDORDOR)
181 #define UNIBRACK(f) return(yylval.ival = f, \
184 PL_last_uni = PL_oldbufptr, \
185 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
187 /* grandfather return to old style */
188 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
193 S_tokereport(pTHX_ char *thing, char* s, I32 rv)
196 SV* report = newSVpv(thing, 0);
197 Perl_sv_catpvf(aTHX_ report, ":line %d:%"IVdf":", CopLINE(PL_curcop),
200 if (s - PL_bufptr > 0)
201 sv_catpvn(report, PL_bufptr, s - PL_bufptr);
203 if (PL_oldbufptr && *PL_oldbufptr)
204 sv_catpv(report, PL_tokenbuf);
206 PerlIO_printf(Perl_debug_log, "### %s\n", SvPV_nolen(report));
215 * This subroutine detects &&=, ||=, and //= and turns an ANDAND, OROR or DORDOR
216 * into an OP_ANDASSIGN, OP_ORASSIGN, or OP_DORASSIGN
220 S_ao(pTHX_ int toketype)
222 if (*PL_bufptr == '=') {
224 if (toketype == ANDAND)
225 yylval.ival = OP_ANDASSIGN;
226 else if (toketype == OROR)
227 yylval.ival = OP_ORASSIGN;
228 else if (toketype == DORDOR)
229 yylval.ival = OP_DORASSIGN;
237 * When Perl expects an operator and finds something else, no_op
238 * prints the warning. It always prints "<something> found where
239 * operator expected. It prints "Missing semicolon on previous line?"
240 * if the surprise occurs at the start of the line. "do you need to
241 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
242 * where the compiler doesn't know if foo is a method call or a function.
243 * It prints "Missing operator before end of line" if there's nothing
244 * after the missing operator, or "... before <...>" if there is something
245 * after the missing operator.
249 S_no_op(pTHX_ char *what, char *s)
251 char *oldbp = PL_bufptr;
252 bool is_first = (PL_oldbufptr == PL_linestart);
258 yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
260 Perl_warn(aTHX_ "\t(Missing semicolon on previous line?)\n");
261 else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
263 for (t = PL_oldoldbufptr; *t && (isALNUM_lazy_if(t,UTF) || *t == ':'); t++) ;
264 if (t < PL_bufptr && isSPACE(*t))
265 Perl_warn(aTHX_ "\t(Do you need to predeclare %.*s?)\n",
266 t - PL_oldoldbufptr, PL_oldoldbufptr);
270 Perl_warn(aTHX_ "\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
277 * Complain about missing quote/regexp/heredoc terminator.
278 * If it's called with (char *)NULL then it cauterizes the line buffer.
279 * If we're in a delimited string and the delimiter is a control
280 * character, it's reformatted into a two-char sequence like ^C.
285 S_missingterm(pTHX_ char *s)
290 char *nl = strrchr(s,'\n');
296 iscntrl(PL_multi_close)
298 PL_multi_close < 32 || PL_multi_close == 127
302 tmpbuf[1] = toCTRL(PL_multi_close);
308 *tmpbuf = (char)PL_multi_close;
312 q = strchr(s,'"') ? '\'' : '"';
313 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
321 Perl_deprecate(pTHX_ char *s)
323 if (ckWARN(WARN_DEPRECATED))
324 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "Use of %s is deprecated", s);
328 Perl_deprecate_old(pTHX_ char *s)
330 /* This function should NOT be called for any new deprecated warnings */
331 /* Use Perl_deprecate instead */
333 /* It is here to maintain backward compatibility with the pre-5.8 */
334 /* warnings category hierarchy. The "deprecated" category used to */
335 /* live under the "syntax" category. It is now a top-level category */
336 /* in its own right. */
338 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
339 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
340 "Use of %s is deprecated", s);
345 * Deprecate a comma-less variable list.
351 deprecate_old("comma-less variable list");
355 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
356 * utf16-to-utf8-reversed.
359 #ifdef PERL_CR_FILTER
363 register char *s = SvPVX(sv);
364 register char *e = s + SvCUR(sv);
365 /* outer loop optimized to do nothing if there are no CR-LFs */
367 if (*s++ == '\r' && *s == '\n') {
368 /* hit a CR-LF, need to copy the rest */
369 register char *d = s - 1;
372 if (*s == '\r' && s[1] == '\n')
383 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
385 I32 count = FILTER_READ(idx+1, sv, maxlen);
386 if (count > 0 && !maxlen)
394 * Initialize variables. Uses the Perl save_stack to save its state (for
395 * recursive calls to the parser).
399 Perl_lex_start(pTHX_ SV *line)
404 SAVEI32(PL_lex_dojoin);
405 SAVEI32(PL_lex_brackets);
406 SAVEI32(PL_lex_casemods);
407 SAVEI32(PL_lex_starts);
408 SAVEI32(PL_lex_state);
409 SAVEVPTR(PL_lex_inpat);
410 SAVEI32(PL_lex_inwhat);
411 if (PL_lex_state == LEX_KNOWNEXT) {
412 I32 toke = PL_nexttoke;
413 while (--toke >= 0) {
414 SAVEI32(PL_nexttype[toke]);
415 SAVEVPTR(PL_nextval[toke]);
417 SAVEI32(PL_nexttoke);
419 SAVECOPLINE(PL_curcop);
422 SAVEPPTR(PL_oldbufptr);
423 SAVEPPTR(PL_oldoldbufptr);
424 SAVEPPTR(PL_last_lop);
425 SAVEPPTR(PL_last_uni);
426 SAVEPPTR(PL_linestart);
427 SAVESPTR(PL_linestr);
428 SAVEGENERICPV(PL_lex_brackstack);
429 SAVEGENERICPV(PL_lex_casestack);
430 SAVEDESTRUCTOR_X(restore_rsfp, PL_rsfp);
431 SAVESPTR(PL_lex_stuff);
432 SAVEI32(PL_lex_defer);
433 SAVEI32(PL_sublex_info.sub_inwhat);
434 SAVESPTR(PL_lex_repl);
436 SAVEINT(PL_lex_expect);
438 PL_lex_state = LEX_NORMAL;
442 New(899, PL_lex_brackstack, 120, char);
443 New(899, PL_lex_casestack, 12, char);
445 *PL_lex_casestack = '\0';
448 PL_lex_stuff = Nullsv;
449 PL_lex_repl = Nullsv;
453 PL_sublex_info.sub_inwhat = 0;
455 if (SvREADONLY(PL_linestr))
456 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
457 s = SvPV(PL_linestr, len);
458 if (!len || s[len-1] != ';') {
459 if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
460 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
461 sv_catpvn(PL_linestr, "\n;", 2);
463 SvTEMP_off(PL_linestr);
464 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
465 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
466 PL_last_lop = PL_last_uni = Nullch;
472 * Finalizer for lexing operations. Must be called when the parser is
473 * done with the lexer.
479 PL_doextract = FALSE;
484 * This subroutine has nothing to do with tilting, whether at windmills
485 * or pinball tables. Its name is short for "increment line". It
486 * increments the current line number in CopLINE(PL_curcop) and checks
487 * to see whether the line starts with a comment of the form
488 * # line 500 "foo.pm"
489 * If so, it sets the current line number and file to the values in the comment.
493 S_incline(pTHX_ char *s)
500 CopLINE_inc(PL_curcop);
503 while (SPACE_OR_TAB(*s)) s++;
504 if (strnEQ(s, "line", 4))
508 if (SPACE_OR_TAB(*s))
512 while (SPACE_OR_TAB(*s)) s++;
518 while (SPACE_OR_TAB(*s))
520 if (*s == '"' && (t = strchr(s+1, '"'))) {
525 for (t = s; !isSPACE(*t); t++) ;
528 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
530 if (*e != '\n' && *e != '\0')
531 return; /* false alarm */
536 CopFILE_free(PL_curcop);
537 CopFILE_set(PL_curcop, s);
540 CopLINE_set(PL_curcop, atoi(n)-1);
545 * Called to gobble the appropriate amount and type of whitespace.
546 * Skips comments as well.
550 S_skipspace(pTHX_ register char *s)
552 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
553 while (s < PL_bufend && SPACE_OR_TAB(*s))
559 SSize_t oldprevlen, oldoldprevlen;
560 SSize_t oldloplen = 0, oldunilen = 0;
561 while (s < PL_bufend && isSPACE(*s)) {
562 if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
567 if (s < PL_bufend && *s == '#') {
568 while (s < PL_bufend && *s != '\n')
572 if (PL_in_eval && !PL_rsfp) {
579 /* only continue to recharge the buffer if we're at the end
580 * of the buffer, we're not reading from a source filter, and
581 * we're in normal lexing mode
583 if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat ||
584 PL_lex_state == LEX_FORMLINE)
587 /* try to recharge the buffer */
588 if ((s = filter_gets(PL_linestr, PL_rsfp,
589 (prevlen = SvCUR(PL_linestr)))) == Nullch)
591 /* end of file. Add on the -p or -n magic */
592 if (PL_minus_n || PL_minus_p) {
593 sv_setpv(PL_linestr,PL_minus_p ?
594 ";}continue{print or die qq(-p destination: $!\\n)" :
596 sv_catpv(PL_linestr,";}");
597 PL_minus_n = PL_minus_p = 0;
600 sv_setpv(PL_linestr,";");
602 /* reset variables for next time we lex */
603 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
605 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
606 PL_last_lop = PL_last_uni = Nullch;
608 /* Close the filehandle. Could be from -P preprocessor,
609 * STDIN, or a regular file. If we were reading code from
610 * STDIN (because the commandline held no -e or filename)
611 * then we don't close it, we reset it so the code can
612 * read from STDIN too.
615 if (PL_preprocess && !PL_in_eval)
616 (void)PerlProc_pclose(PL_rsfp);
617 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
618 PerlIO_clearerr(PL_rsfp);
620 (void)PerlIO_close(PL_rsfp);
625 /* not at end of file, so we only read another line */
626 /* make corresponding updates to old pointers, for yyerror() */
627 oldprevlen = PL_oldbufptr - PL_bufend;
628 oldoldprevlen = PL_oldoldbufptr - PL_bufend;
630 oldunilen = PL_last_uni - PL_bufend;
632 oldloplen = PL_last_lop - PL_bufend;
633 PL_linestart = PL_bufptr = s + prevlen;
634 PL_bufend = s + SvCUR(PL_linestr);
636 PL_oldbufptr = s + oldprevlen;
637 PL_oldoldbufptr = s + oldoldprevlen;
639 PL_last_uni = s + oldunilen;
641 PL_last_lop = s + oldloplen;
644 /* debugger active and we're not compiling the debugger code,
645 * so store the line into the debugger's array of lines
647 if (PERLDB_LINE && PL_curstash != PL_debstash) {
648 SV *sv = NEWSV(85,0);
650 sv_upgrade(sv, SVt_PVMG);
651 sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
654 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
661 * Check the unary operators to ensure there's no ambiguity in how they're
662 * used. An ambiguous piece of code would be:
664 * This doesn't mean rand() + 5. Because rand() is a unary operator,
665 * the +5 is its argument.
674 if (PL_oldoldbufptr != PL_last_uni)
676 while (isSPACE(*PL_last_uni))
678 for (s = PL_last_uni; isALNUM_lazy_if(s,UTF) || *s == '-'; s++) ;
679 if ((t = strchr(s, '(')) && t < PL_bufptr)
681 if (ckWARN_d(WARN_AMBIGUOUS)){
684 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
685 "Warning: Use of \"%s\" without parens is ambiguous",
692 * LOP : macro to build a list operator. Its behaviour has been replaced
693 * with a subroutine, S_lop() for which LOP is just another name.
696 #define LOP(f,x) return lop(f,x,s)
700 * Build a list operator (or something that might be one). The rules:
701 * - if we have a next token, then it's a list operator [why?]
702 * - if the next thing is an opening paren, then it's a function
703 * - else it's a list operator
707 S_lop(pTHX_ I32 f, int x, char *s)
714 PL_last_lop = PL_oldbufptr;
715 PL_last_lop_op = (OPCODE)f;
729 * When the lexer realizes it knows the next token (for instance,
730 * it is reordering tokens for the parser) then it can call S_force_next
731 * to know what token to return the next time the lexer is called. Caller
732 * will need to set PL_nextval[], and possibly PL_expect to ensure the lexer
733 * handles the token correctly.
737 S_force_next(pTHX_ I32 type)
739 PL_nexttype[PL_nexttoke] = type;
741 if (PL_lex_state != LEX_KNOWNEXT) {
742 PL_lex_defer = PL_lex_state;
743 PL_lex_expect = PL_expect;
744 PL_lex_state = LEX_KNOWNEXT;
750 * When the lexer knows the next thing is a word (for instance, it has
751 * just seen -> and it knows that the next char is a word char, then
752 * it calls S_force_word to stick the next word into the PL_next lookahead.
755 * char *start : buffer position (must be within PL_linestr)
756 * int token : PL_next will be this type of bare word (e.g., METHOD,WORD)
757 * int check_keyword : if true, Perl checks to make sure the word isn't
758 * a keyword (do this if the word is a label, e.g. goto FOO)
759 * int allow_pack : if true, : characters will also be allowed (require,
761 * int allow_initial_tick : used by the "sub" lexer only.
765 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
770 start = skipspace(start);
772 if (isIDFIRST_lazy_if(s,UTF) ||
773 (allow_pack && *s == ':') ||
774 (allow_initial_tick && *s == '\'') )
776 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
777 if (check_keyword && keyword(PL_tokenbuf, len))
779 if (token == METHOD) {
784 PL_expect = XOPERATOR;
787 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(PL_tokenbuf,0));
788 PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
796 * Called when the lexer wants $foo *foo &foo etc, but the program
797 * text only contains the "foo" portion. The first argument is a pointer
798 * to the "foo", and the second argument is the type symbol to prefix.
799 * Forces the next token to be a "WORD".
800 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
804 S_force_ident(pTHX_ register char *s, int kind)
807 OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
808 PL_nextval[PL_nexttoke].opval = o;
811 o->op_private = OPpCONST_ENTERED;
812 /* XXX see note in pp_entereval() for why we forgo typo
813 warnings if the symbol must be introduced in an eval.
815 gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
816 kind == '$' ? SVt_PV :
817 kind == '@' ? SVt_PVAV :
818 kind == '%' ? SVt_PVHV :
826 Perl_str_to_version(pTHX_ SV *sv)
831 char *start = SvPVx(sv,len);
832 bool utf = SvUTF8(sv) ? TRUE : FALSE;
833 char *end = start + len;
834 while (start < end) {
838 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
843 retval += ((NV)n)/nshift;
852 * Forces the next token to be a version number.
853 * If the next token appears to be an invalid version number, (e.g. "v2b"),
854 * and if "guessing" is TRUE, then no new token is created (and the caller
855 * must use an alternative parsing method).
859 S_force_version(pTHX_ char *s, int guessing)
861 OP *version = Nullop;
870 while (isDIGIT(*d) || *d == '_' || *d == '.')
872 if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
874 s = scan_num(s, &yylval);
875 version = yylval.opval;
876 ver = cSVOPx(version)->op_sv;
877 if (SvPOK(ver) && !SvNIOK(ver)) {
878 (void)SvUPGRADE(ver, SVt_PVNV);
879 SvNVX(ver) = str_to_version(ver);
880 SvNOK_on(ver); /* hint that it is a version */
887 /* NOTE: The parser sees the package name and the VERSION swapped */
888 PL_nextval[PL_nexttoke].opval = version;
896 * Tokenize a quoted string passed in as an SV. It finds the next
897 * chunk, up to end of string or a backslash. It may make a new
898 * SV containing that chunk (if HINT_NEW_STRING is on). It also
903 S_tokeq(pTHX_ SV *sv)
914 s = SvPV_force(sv, len);
915 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
918 while (s < send && *s != '\\')
923 if ( PL_hints & HINT_NEW_STRING ) {
924 pv = sv_2mortal(newSVpvn(SvPVX(pv), len));
930 if (s + 1 < send && (s[1] == '\\'))
931 s++; /* all that, just for this */
936 SvCUR_set(sv, d - SvPVX(sv));
938 if ( PL_hints & HINT_NEW_STRING )
939 return new_constant(NULL, 0, "q", sv, pv, "q");
944 * Now come three functions related to double-quote context,
945 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
946 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
947 * interact with PL_lex_state, and create fake ( ... ) argument lists
948 * to handle functions and concatenation.
949 * They assume that whoever calls them will be setting up a fake
950 * join call, because each subthing puts a ',' after it. This lets
953 * join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
955 * (I'm not sure whether the spurious commas at the end of lcfirst's
956 * arguments and join's arguments are created or not).
961 * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST).
963 * Pattern matching will set PL_lex_op to the pattern-matching op to
964 * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise).
966 * OP_CONST and OP_READLINE are easy--just make the new op and return.
968 * Everything else becomes a FUNC.
970 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
971 * had an OP_CONST or OP_READLINE). This just sets us up for a
972 * call to S_sublex_push().
978 register I32 op_type = yylval.ival;
980 if (op_type == OP_NULL) {
981 yylval.opval = PL_lex_op;
985 if (op_type == OP_CONST || op_type == OP_READLINE) {
986 SV *sv = tokeq(PL_lex_stuff);
988 if (SvTYPE(sv) == SVt_PVIV) {
989 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
995 nsv = newSVpvn(p, len);
1001 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
1002 PL_lex_stuff = Nullsv;
1003 /* Allow <FH> // "foo" */
1004 if (op_type == OP_READLINE)
1005 PL_expect = XTERMORDORDOR;
1009 PL_sublex_info.super_state = PL_lex_state;
1010 PL_sublex_info.sub_inwhat = op_type;
1011 PL_sublex_info.sub_op = PL_lex_op;
1012 PL_lex_state = LEX_INTERPPUSH;
1016 yylval.opval = PL_lex_op;
1026 * Create a new scope to save the lexing state. The scope will be
1027 * ended in S_sublex_done. Returns a '(', starting the function arguments
1028 * to the uc, lc, etc. found before.
1029 * Sets PL_lex_state to LEX_INTERPCONCAT.
1037 PL_lex_state = PL_sublex_info.super_state;
1038 SAVEI32(PL_lex_dojoin);
1039 SAVEI32(PL_lex_brackets);
1040 SAVEI32(PL_lex_casemods);
1041 SAVEI32(PL_lex_starts);
1042 SAVEI32(PL_lex_state);
1043 SAVEVPTR(PL_lex_inpat);
1044 SAVEI32(PL_lex_inwhat);
1045 SAVECOPLINE(PL_curcop);
1046 SAVEPPTR(PL_bufptr);
1047 SAVEPPTR(PL_bufend);
1048 SAVEPPTR(PL_oldbufptr);
1049 SAVEPPTR(PL_oldoldbufptr);
1050 SAVEPPTR(PL_last_lop);
1051 SAVEPPTR(PL_last_uni);
1052 SAVEPPTR(PL_linestart);
1053 SAVESPTR(PL_linestr);
1054 SAVEGENERICPV(PL_lex_brackstack);
1055 SAVEGENERICPV(PL_lex_casestack);
1057 PL_linestr = PL_lex_stuff;
1058 PL_lex_stuff = Nullsv;
1060 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
1061 = SvPVX(PL_linestr);
1062 PL_bufend += SvCUR(PL_linestr);
1063 PL_last_lop = PL_last_uni = Nullch;
1064 SAVEFREESV(PL_linestr);
1066 PL_lex_dojoin = FALSE;
1067 PL_lex_brackets = 0;
1068 New(899, PL_lex_brackstack, 120, char);
1069 New(899, PL_lex_casestack, 12, char);
1070 PL_lex_casemods = 0;
1071 *PL_lex_casestack = '\0';
1073 PL_lex_state = LEX_INTERPCONCAT;
1074 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
1076 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1077 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1078 PL_lex_inpat = PL_sublex_info.sub_op;
1080 PL_lex_inpat = Nullop;
1087 * Restores lexer state after a S_sublex_push.
1093 if (!PL_lex_starts++) {
1094 SV *sv = newSVpvn("",0);
1095 if (SvUTF8(PL_linestr))
1097 PL_expect = XOPERATOR;
1098 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1102 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
1103 PL_lex_state = LEX_INTERPCASEMOD;
1107 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1108 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1109 PL_linestr = PL_lex_repl;
1111 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1112 PL_bufend += SvCUR(PL_linestr);
1113 PL_last_lop = PL_last_uni = Nullch;
1114 SAVEFREESV(PL_linestr);
1115 PL_lex_dojoin = FALSE;
1116 PL_lex_brackets = 0;
1117 PL_lex_casemods = 0;
1118 *PL_lex_casestack = '\0';
1120 if (SvEVALED(PL_lex_repl)) {
1121 PL_lex_state = LEX_INTERPNORMAL;
1123 /* we don't clear PL_lex_repl here, so that we can check later
1124 whether this is an evalled subst; that means we rely on the
1125 logic to ensure sublex_done() is called again only via the
1126 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1129 PL_lex_state = LEX_INTERPCONCAT;
1130 PL_lex_repl = Nullsv;
1136 PL_bufend = SvPVX(PL_linestr);
1137 PL_bufend += SvCUR(PL_linestr);
1138 PL_expect = XOPERATOR;
1139 PL_sublex_info.sub_inwhat = 0;
1147 Extracts a pattern, double-quoted string, or transliteration. This
1150 It looks at lex_inwhat and PL_lex_inpat to find out whether it's
1151 processing a pattern (PL_lex_inpat is true), a transliteration
1152 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
1154 Returns a pointer to the character scanned up to. Iff this is
1155 advanced from the start pointer supplied (ie if anything was
1156 successfully parsed), will leave an OP for the substring scanned
1157 in yylval. Caller must intuit reason for not parsing further
1158 by looking at the next characters herself.
1162 double-quoted style: \r and \n
1163 regexp special ones: \D \s
1165 backrefs: \1 (deprecated in substitution replacements)
1166 case and quoting: \U \Q \E
1167 stops on @ and $, but not for $ as tail anchor
1169 In transliterations:
1170 characters are VERY literal, except for - not at the start or end
1171 of the string, which indicates a range. scan_const expands the
1172 range to the full set of intermediate characters.
1174 In double-quoted strings:
1176 double-quoted style: \r and \n
1178 backrefs: \1 (deprecated)
1179 case and quoting: \U \Q \E
1182 scan_const does *not* construct ops to handle interpolated strings.
1183 It stops processing as soon as it finds an embedded $ or @ variable
1184 and leaves it to the caller to work out what's going on.
1186 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @::foo.
1188 $ in pattern could be $foo or could be tail anchor. Assumption:
1189 it's a tail anchor if $ is the last thing in the string, or if it's
1190 followed by one of ")| \n\t"
1192 \1 (backreferences) are turned into $1
1194 The structure of the code is
1195 while (there's a character to process) {
1196 handle transliteration ranges
1197 skip regexp comments
1198 skip # initiated comments in //x patterns
1199 check for embedded @foo
1200 check for embedded scalars
1202 leave intact backslashes from leave (below)
1203 deprecate \1 in strings and sub replacements
1204 handle string-changing backslashes \l \U \Q \E, etc.
1205 switch (what was escaped) {
1206 handle - in a transliteration (becomes a literal -)
1207 handle \132 octal characters
1208 handle 0x15 hex characters
1209 handle \cV (control V)
1210 handle printf backslashes (\f, \r, \n, etc)
1212 } (end if backslash)
1213 } (end while character to read)
1218 S_scan_const(pTHX_ char *start)
1220 register char *send = PL_bufend; /* end of the constant */
1221 SV *sv = NEWSV(93, send - start); /* sv for the constant */
1222 register char *s = start; /* start of the constant */
1223 register char *d = SvPVX(sv); /* destination for copies */
1224 bool dorange = FALSE; /* are we in a translit range? */
1225 bool didrange = FALSE; /* did we just finish a range? */
1226 I32 has_utf8 = FALSE; /* Output constant is UTF8 */
1227 I32 this_utf8 = UTF; /* The source string is assumed to be UTF8 */
1230 const char *leaveit = /* set of acceptably-backslashed characters */
1232 ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
1235 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1236 /* If we are doing a trans and we know we want UTF8 set expectation */
1237 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
1238 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1242 while (s < send || dorange) {
1243 /* get transliterations out of the way (they're most literal) */
1244 if (PL_lex_inwhat == OP_TRANS) {
1245 /* expand a range A-Z to the full set of characters. AIE! */
1247 I32 i; /* current expanded character */
1248 I32 min; /* first character in range */
1249 I32 max; /* last character in range */
1252 char *c = (char*)utf8_hop((U8*)d, -1);
1256 *c = (char)UTF_TO_NATIVE(0xff);
1257 /* mark the range as done, and continue */
1263 i = d - SvPVX(sv); /* remember current offset */
1264 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
1265 d = SvPVX(sv) + i; /* refresh d after realloc */
1266 d -= 2; /* eat the first char and the - */
1268 min = (U8)*d; /* first char in range */
1269 max = (U8)d[1]; /* last char in range */
1273 "Invalid range \"%c-%c\" in transliteration operator",
1274 (char)min, (char)max);
1278 if ((isLOWER(min) && isLOWER(max)) ||
1279 (isUPPER(min) && isUPPER(max))) {
1281 for (i = min; i <= max; i++)
1283 *d++ = NATIVE_TO_NEED(has_utf8,i);
1285 for (i = min; i <= max; i++)
1287 *d++ = NATIVE_TO_NEED(has_utf8,i);
1292 for (i = min; i <= max; i++)
1295 /* mark the range as done, and continue */
1301 /* range begins (ignore - as first or last char) */
1302 else if (*s == '-' && s+1 < send && s != start) {
1304 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
1307 *d++ = (char)UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */
1319 /* if we get here, we're not doing a transliteration */
1321 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
1322 except for the last char, which will be done separately. */
1323 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
1325 while (s < send && *s != ')')
1326 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1328 else if (s[2] == '{' /* This should match regcomp.c */
1329 || ((s[2] == 'p' || s[2] == '?') && s[3] == '{'))
1332 char *regparse = s + (s[2] == '{' ? 3 : 4);
1335 while (count && (c = *regparse)) {
1336 if (c == '\\' && regparse[1])
1344 if (*regparse != ')') {
1345 regparse--; /* Leave one char for continuation. */
1346 yyerror("Sequence (?{...}) not terminated or not {}-balanced");
1348 while (s < regparse)
1349 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1353 /* likewise skip #-initiated comments in //x patterns */
1354 else if (*s == '#' && PL_lex_inpat &&
1355 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
1356 while (s+1 < send && *s != '\n')
1357 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1360 /* check for embedded arrays
1361 (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
1363 else if (*s == '@' && s[1]
1364 && (isALNUM_lazy_if(s+1,UTF) || strchr(":'{$+-", s[1])))
1367 /* check for embedded scalars. only stop if we're sure it's a
1370 else if (*s == '$') {
1371 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
1373 if (s + 1 < send && !strchr("()| \r\n\t", s[1]))
1374 break; /* in regexp, $ might be tail anchor */
1377 /* End of else if chain - OP_TRANS rejoin rest */
1380 if (*s == '\\' && s+1 < send) {
1383 /* some backslashes we leave behind */
1384 if (*leaveit && *s && strchr(leaveit, *s)) {
1385 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
1386 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1390 /* deprecate \1 in strings and substitution replacements */
1391 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1392 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1394 if (ckWARN(WARN_SYNTAX))
1395 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
1400 /* string-change backslash escapes */
1401 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1406 /* if we get here, it's either a quoted -, or a digit */
1409 /* quoted - in transliterations */
1411 if (PL_lex_inwhat == OP_TRANS) {
1418 if (ckWARN(WARN_MISC) &&
1421 Perl_warner(aTHX_ packWARN(WARN_MISC),
1422 "Unrecognized escape \\%c passed through",
1424 /* default action is to copy the quoted character */
1425 goto default_action;
1428 /* \132 indicates an octal constant */
1429 case '0': case '1': case '2': case '3':
1430 case '4': case '5': case '6': case '7':
1434 uv = grok_oct(s, &len, &flags, NULL);
1437 goto NUM_ESCAPE_INSERT;
1439 /* \x24 indicates a hex constant */
1443 char* e = strchr(s, '}');
1444 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
1445 PERL_SCAN_DISALLOW_PREFIX;
1450 yyerror("Missing right brace on \\x{}");
1454 uv = grok_hex(s, &len, &flags, NULL);
1460 I32 flags = PERL_SCAN_DISALLOW_PREFIX;
1461 uv = grok_hex(s, &len, &flags, NULL);
1467 /* Insert oct or hex escaped character.
1468 * There will always enough room in sv since such
1469 * escapes will be longer than any UTF-8 sequence
1470 * they can end up as. */
1472 /* We need to map to chars to ASCII before doing the tests
1475 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(uv))) {
1476 if (!has_utf8 && uv > 255) {
1477 /* Might need to recode whatever we have
1478 * accumulated so far if it contains any
1481 * (Can't we keep track of that and avoid
1482 * this rescan? --jhi)
1486 for (c = (U8 *) SvPVX(sv); c < (U8 *)d; c++) {
1487 if (!NATIVE_IS_INVARIANT(*c)) {
1492 STRLEN offset = d - SvPVX(sv);
1494 d = SvGROW(sv, SvLEN(sv) + hicount + 1) + offset;
1498 while (src >= (U8 *)SvPVX(sv)) {
1499 if (!NATIVE_IS_INVARIANT(*src)) {
1500 U8 ch = NATIVE_TO_ASCII(*src);
1501 *dst-- = (U8)UTF8_EIGHT_BIT_LO(ch);
1502 *dst-- = (U8)UTF8_EIGHT_BIT_HI(ch);
1512 if (has_utf8 || uv > 255) {
1513 d = (char*)uvchr_to_utf8((U8*)d, uv);
1515 if (PL_lex_inwhat == OP_TRANS &&
1516 PL_sublex_info.sub_op) {
1517 PL_sublex_info.sub_op->op_private |=
1518 (PL_lex_repl ? OPpTRANS_FROM_UTF
1531 /* \N{LATIN SMALL LETTER A} is a named character */
1535 char* e = strchr(s, '}');
1541 yyerror("Missing right brace on \\N{}");
1545 if (e > s + 2 && s[1] == 'U' && s[2] == '+') {
1547 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
1548 PERL_SCAN_DISALLOW_PREFIX;
1551 uv = grok_hex(s, &len, &flags, NULL);
1553 goto NUM_ESCAPE_INSERT;
1555 res = newSVpvn(s + 1, e - s - 1);
1556 res = new_constant( Nullch, 0, "charnames",
1557 res, Nullsv, "\\N{...}" );
1559 sv_utf8_upgrade(res);
1560 str = SvPV(res,len);
1561 #ifdef EBCDIC_NEVER_MIND
1562 /* charnames uses pack U and that has been
1563 * recently changed to do the below uni->native
1564 * mapping, so this would be redundant (and wrong,
1565 * the code point would be doubly converted).
1566 * But leave this in just in case the pack U change
1567 * gets revoked, but the semantics is still
1568 * desireable for charnames. --jhi */
1570 UV uv = utf8_to_uvchr((U8*)str, 0);
1573 U8 tmpbuf[UTF8_MAXLEN+1], *d;
1575 d = uvchr_to_utf8(tmpbuf, UNI_TO_NATIVE(uv));
1576 sv_setpvn(res, (char *)tmpbuf, d - tmpbuf);
1577 str = SvPV(res, len);
1581 if (!has_utf8 && SvUTF8(res)) {
1582 char *ostart = SvPVX(sv);
1583 SvCUR_set(sv, d - ostart);
1586 sv_utf8_upgrade(sv);
1587 /* this just broke our allocation above... */
1588 SvGROW(sv, (STRLEN)(send - start));
1589 d = SvPVX(sv) + SvCUR(sv);
1592 if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
1593 char *odest = SvPVX(sv);
1595 SvGROW(sv, (SvLEN(sv) + len - (e - s + 4)));
1596 d = SvPVX(sv) + (d - odest);
1598 Copy(str, d, len, char);
1605 yyerror("Missing braces on \\N{}");
1608 /* \c is a control character */
1617 *d++ = NATIVE_TO_NEED(has_utf8,toCTRL(c));
1620 yyerror("Missing control char name in \\c");
1624 /* printf-style backslashes, formfeeds, newlines, etc */
1626 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
1629 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
1632 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
1635 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
1638 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
1641 *d++ = ASCII_TO_NEED(has_utf8,'\033');
1644 *d++ = ASCII_TO_NEED(has_utf8,'\007');
1650 } /* end if (backslash) */
1653 /* If we started with encoded form, or already know we want it
1654 and then encode the next character */
1655 if ((has_utf8 || this_utf8) && !NATIVE_IS_INVARIANT((U8)(*s))) {
1657 UV uv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
1658 STRLEN need = UNISKIP(NATIVE_TO_UNI(uv));
1661 /* encoded value larger than old, need extra space (NOTE: SvCUR() not set here) */
1662 STRLEN off = d - SvPVX(sv);
1663 d = SvGROW(sv, SvLEN(sv) + (need-len)) + off;
1665 d = (char*)uvchr_to_utf8((U8*)d, uv);
1669 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1671 } /* while loop to process each character */
1673 /* terminate the string and set up the sv */
1675 SvCUR_set(sv, d - SvPVX(sv));
1676 if (SvCUR(sv) >= SvLEN(sv))
1677 Perl_croak(aTHX_ "panic: constant overflowed allocated space");
1680 if (PL_encoding && !has_utf8) {
1681 sv_recode_to_utf8(sv, PL_encoding);
1687 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1688 PL_sublex_info.sub_op->op_private |=
1689 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1693 /* shrink the sv if we allocated more than we used */
1694 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1695 SvLEN_set(sv, SvCUR(sv) + 1);
1696 Renew(SvPVX(sv), SvLEN(sv), char);
1699 /* return the substring (via yylval) only if we parsed anything */
1700 if (s > PL_bufptr) {
1701 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1702 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1704 ( PL_lex_inwhat == OP_TRANS
1706 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1709 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1716 * Returns TRUE if there's more to the expression (e.g., a subscript),
1719 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
1721 * ->[ and ->{ return TRUE
1722 * { and [ outside a pattern are always subscripts, so return TRUE
1723 * if we're outside a pattern and it's not { or [, then return FALSE
1724 * if we're in a pattern and the first char is a {
1725 * {4,5} (any digits around the comma) returns FALSE
1726 * if we're in a pattern and the first char is a [
1728 * [SOMETHING] has a funky algorithm to decide whether it's a
1729 * character class or not. It has to deal with things like
1730 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
1731 * anything else returns TRUE
1734 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1737 S_intuit_more(pTHX_ register char *s)
1739 if (PL_lex_brackets)
1741 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1743 if (*s != '{' && *s != '[')
1748 /* In a pattern, so maybe we have {n,m}. */
1765 /* On the other hand, maybe we have a character class */
1768 if (*s == ']' || *s == '^')
1771 /* this is terrifying, and it works */
1772 int weight = 2; /* let's weigh the evidence */
1774 unsigned char un_char = 255, last_un_char;
1775 char *send = strchr(s,']');
1776 char tmpbuf[sizeof PL_tokenbuf * 4];
1778 if (!send) /* has to be an expression */
1781 Zero(seen,256,char);
1784 else if (isDIGIT(*s)) {
1786 if (isDIGIT(s[1]) && s[2] == ']')
1792 for (; s < send; s++) {
1793 last_un_char = un_char;
1794 un_char = (unsigned char)*s;
1799 weight -= seen[un_char] * 10;
1800 if (isALNUM_lazy_if(s+1,UTF)) {
1801 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1802 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1807 else if (*s == '$' && s[1] &&
1808 strchr("[#!%*<>()-=",s[1])) {
1809 if (/*{*/ strchr("])} =",s[2]))
1818 if (strchr("wds]",s[1]))
1820 else if (seen['\''] || seen['"'])
1822 else if (strchr("rnftbxcav",s[1]))
1824 else if (isDIGIT(s[1])) {
1826 while (s[1] && isDIGIT(s[1]))
1836 if (strchr("aA01! ",last_un_char))
1838 if (strchr("zZ79~",s[1]))
1840 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1841 weight -= 5; /* cope with negative subscript */
1844 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1845 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1850 if (keyword(tmpbuf, d - tmpbuf))
1853 if (un_char == last_un_char + 1)
1855 weight -= seen[un_char];
1860 if (weight >= 0) /* probably a character class */
1870 * Does all the checking to disambiguate
1872 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
1873 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
1875 * First argument is the stuff after the first token, e.g. "bar".
1877 * Not a method if bar is a filehandle.
1878 * Not a method if foo is a subroutine prototyped to take a filehandle.
1879 * Not a method if it's really "Foo $bar"
1880 * Method if it's "foo $bar"
1881 * Not a method if it's really "print foo $bar"
1882 * Method if it's really "foo package::" (interpreted as package->foo)
1883 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
1884 * Not a method if bar is a filehandle or package, but is quoted with
1889 S_intuit_method(pTHX_ char *start, GV *gv)
1891 char *s = start + (*start == '$');
1892 char tmpbuf[sizeof PL_tokenbuf];
1900 if ((cv = GvCVu(gv))) {
1901 char *proto = SvPVX(cv);
1911 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1912 /* start is the beginning of the possible filehandle/object,
1913 * and s is the end of it
1914 * tmpbuf is a copy of it
1917 if (*start == '$') {
1918 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1923 return *s == '(' ? FUNCMETH : METHOD;
1925 if (!keyword(tmpbuf, len)) {
1926 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1931 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1932 if (indirgv && GvCVu(indirgv))
1934 /* filehandle or package name makes it a method */
1935 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1937 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1938 return 0; /* no assumptions -- "=>" quotes bearword */
1940 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1941 newSVpvn(tmpbuf,len));
1942 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1946 return *s == '(' ? FUNCMETH : METHOD;
1954 * Return a string of Perl code to load the debugger. If PERL5DB
1955 * is set, it will return the contents of that, otherwise a
1956 * compile-time require of perl5db.pl.
1963 char *pdb = PerlEnv_getenv("PERL5DB");
1967 SETERRNO(0,SS_NORMAL);
1968 return "BEGIN { require 'perl5db.pl' }";
1974 /* Encoded script support. filter_add() effectively inserts a
1975 * 'pre-processing' function into the current source input stream.
1976 * Note that the filter function only applies to the current source file
1977 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1979 * The datasv parameter (which may be NULL) can be used to pass
1980 * private data to this instance of the filter. The filter function
1981 * can recover the SV using the FILTER_DATA macro and use it to
1982 * store private buffers and state information.
1984 * The supplied datasv parameter is upgraded to a PVIO type
1985 * and the IoDIRP/IoANY field is used to store the function pointer,
1986 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
1987 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1988 * private use must be set using malloc'd pointers.
1992 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
1997 if (!PL_rsfp_filters)
1998 PL_rsfp_filters = newAV();
2000 datasv = NEWSV(255,0);
2001 if (!SvUPGRADE(datasv, SVt_PVIO))
2002 Perl_die(aTHX_ "Can't upgrade filter_add data to SVt_PVIO");
2003 IoANY(datasv) = (void *)funcp; /* stash funcp into spare field */
2004 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
2005 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
2006 (void*)funcp, SvPV_nolen(datasv)));
2007 av_unshift(PL_rsfp_filters, 1);
2008 av_store(PL_rsfp_filters, 0, datasv) ;
2013 /* Delete most recently added instance of this filter function. */
2015 Perl_filter_del(pTHX_ filter_t funcp)
2018 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", (void*)funcp));
2019 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
2021 /* if filter is on top of stack (usual case) just pop it off */
2022 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
2023 if (IoANY(datasv) == (void *)funcp) {
2024 IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
2025 IoANY(datasv) = (void *)NULL;
2026 sv_free(av_pop(PL_rsfp_filters));
2030 /* we need to search for the correct entry and clear it */
2031 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
2035 /* Invoke the n'th filter function for the current rsfp. */
2037 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
2040 /* 0 = read one text line */
2045 if (!PL_rsfp_filters)
2047 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
2048 /* Provide a default input filter to make life easy. */
2049 /* Note that we append to the line. This is handy. */
2050 DEBUG_P(PerlIO_printf(Perl_debug_log,
2051 "filter_read %d: from rsfp\n", idx));
2055 int old_len = SvCUR(buf_sv) ;
2057 /* ensure buf_sv is large enough */
2058 SvGROW(buf_sv, (STRLEN)(old_len + maxlen)) ;
2059 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
2060 if (PerlIO_error(PL_rsfp))
2061 return -1; /* error */
2063 return 0 ; /* end of file */
2065 SvCUR_set(buf_sv, old_len + len) ;
2068 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
2069 if (PerlIO_error(PL_rsfp))
2070 return -1; /* error */
2072 return 0 ; /* end of file */
2075 return SvCUR(buf_sv);
2077 /* Skip this filter slot if filter has been deleted */
2078 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
2079 DEBUG_P(PerlIO_printf(Perl_debug_log,
2080 "filter_read %d: skipped (filter deleted)\n",
2082 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
2084 /* Get function pointer hidden within datasv */
2085 funcp = (filter_t)IoANY(datasv);
2086 DEBUG_P(PerlIO_printf(Perl_debug_log,
2087 "filter_read %d: via function %p (%s)\n",
2088 idx, (void*)funcp, SvPV_nolen(datasv)));
2089 /* Call function. The function is expected to */
2090 /* call "FILTER_READ(idx+1, buf_sv)" first. */
2091 /* Return: <0:error, =0:eof, >0:not eof */
2092 return (*funcp)(aTHX_ idx, buf_sv, maxlen);
2096 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
2098 #ifdef PERL_CR_FILTER
2099 if (!PL_rsfp_filters) {
2100 filter_add(S_cr_textfilter,NULL);
2103 if (PL_rsfp_filters) {
2106 SvCUR_set(sv, 0); /* start with empty line */
2107 if (FILTER_READ(0, sv, 0) > 0)
2108 return ( SvPVX(sv) ) ;
2113 return (sv_gets(sv, fp, append));
2117 S_find_in_my_stash(pTHX_ char *pkgname, I32 len)
2121 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
2125 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
2126 (gv = gv_fetchpv(pkgname, FALSE, SVt_PVHV)))
2128 return GvHV(gv); /* Foo:: */
2131 /* use constant CLASS => 'MyClass' */
2132 if ((gv = gv_fetchpv(pkgname, FALSE, SVt_PVCV))) {
2134 if (GvCV(gv) && (sv = cv_const_sv(GvCV(gv)))) {
2135 pkgname = SvPV_nolen(sv);
2139 return gv_stashpv(pkgname, FALSE);
2143 static char* exp_name[] =
2144 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
2145 "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
2152 Works out what to call the token just pulled out of the input
2153 stream. The yacc parser takes care of taking the ops we return and
2154 stitching them into a tree.
2160 if read an identifier
2161 if we're in a my declaration
2162 croak if they tried to say my($foo::bar)
2163 build the ops for a my() declaration
2164 if it's an access to a my() variable
2165 are we in a sort block?
2166 croak if my($a); $a <=> $b
2167 build ops for access to a my() variable
2168 if in a dq string, and they've said @foo and we can't find @foo
2170 build ops for a bareword
2171 if we already built the token before, use it.
2174 #ifdef USE_PURE_BISON
2176 Perl_yylex_r(pTHX_ YYSTYPE *lvalp, int *lcharp)
2181 yylval_pointer[yyactlevel] = lvalp;
2182 yychar_pointer[yyactlevel] = lcharp;
2183 if (yyactlevel >= YYMAXLEVEL)
2184 Perl_croak(aTHX_ "panic: YYMAXLEVEL");
2186 r = Perl_yylex(aTHX);
2196 #pragma segment Perl_yylex
2208 I32 orig_keyword = 0;
2210 /* check if there's an identifier for us to look at */
2211 if (PL_pending_ident)
2212 return S_pending_ident(aTHX);
2214 /* no identifier pending identification */
2216 switch (PL_lex_state) {
2218 case LEX_NORMAL: /* Some compilers will produce faster */
2219 case LEX_INTERPNORMAL: /* code if we comment these out. */
2223 /* when we've already built the next token, just pull it out of the queue */
2226 yylval = PL_nextval[PL_nexttoke];
2228 PL_lex_state = PL_lex_defer;
2229 PL_expect = PL_lex_expect;
2230 PL_lex_defer = LEX_NORMAL;
2232 DEBUG_T({ PerlIO_printf(Perl_debug_log,
2233 "### Next token after '%s' was known, type %"IVdf"\n", PL_bufptr,
2234 (IV)PL_nexttype[PL_nexttoke]); });
2236 return(PL_nexttype[PL_nexttoke]);
2238 /* interpolated case modifiers like \L \U, including \Q and \E.
2239 when we get here, PL_bufptr is at the \
2241 case LEX_INTERPCASEMOD:
2243 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
2244 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
2246 /* handle \E or end of string */
2247 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
2251 if (PL_lex_casemods) {
2252 oldmod = PL_lex_casestack[--PL_lex_casemods];
2253 PL_lex_casestack[PL_lex_casemods] = '\0';
2255 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
2257 PL_lex_state = LEX_INTERPCONCAT;
2261 if (PL_bufptr != PL_bufend)
2263 PL_lex_state = LEX_INTERPCONCAT;
2267 DEBUG_T({ PerlIO_printf(Perl_debug_log,
2268 "### Saw case modifier at '%s'\n", PL_bufptr); });
2270 if (s[1] == '\\' && s[2] == 'E') {
2272 PL_lex_state = LEX_INTERPCONCAT;
2276 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
2277 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
2278 if (strchr("LU", *s) &&
2279 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) {
2280 PL_lex_casestack[--PL_lex_casemods] = '\0';
2283 if (PL_lex_casemods > 10)
2284 Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
2285 PL_lex_casestack[PL_lex_casemods++] = *s;
2286 PL_lex_casestack[PL_lex_casemods] = '\0';
2287 PL_lex_state = LEX_INTERPCONCAT;
2288 PL_nextval[PL_nexttoke].ival = 0;
2291 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
2293 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
2295 PL_nextval[PL_nexttoke].ival = OP_LC;
2297 PL_nextval[PL_nexttoke].ival = OP_UC;
2299 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
2301 Perl_croak(aTHX_ "panic: yylex");
2305 if (PL_lex_starts) {
2314 case LEX_INTERPPUSH:
2315 return sublex_push();
2317 case LEX_INTERPSTART:
2318 if (PL_bufptr == PL_bufend)
2319 return sublex_done();
2320 DEBUG_T({ PerlIO_printf(Perl_debug_log,
2321 "### Interpolated variable at '%s'\n", PL_bufptr); });
2323 PL_lex_dojoin = (*PL_bufptr == '@');
2324 PL_lex_state = LEX_INTERPNORMAL;
2325 if (PL_lex_dojoin) {
2326 PL_nextval[PL_nexttoke].ival = 0;
2328 force_ident("\"", '$');
2329 PL_nextval[PL_nexttoke].ival = 0;
2331 PL_nextval[PL_nexttoke].ival = 0;
2333 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
2336 if (PL_lex_starts++) {
2342 case LEX_INTERPENDMAYBE:
2343 if (intuit_more(PL_bufptr)) {
2344 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
2350 if (PL_lex_dojoin) {
2351 PL_lex_dojoin = FALSE;
2352 PL_lex_state = LEX_INTERPCONCAT;
2355 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
2356 && SvEVALED(PL_lex_repl))
2358 if (PL_bufptr != PL_bufend)
2359 Perl_croak(aTHX_ "Bad evalled substitution pattern");
2360 PL_lex_repl = Nullsv;
2363 case LEX_INTERPCONCAT:
2365 if (PL_lex_brackets)
2366 Perl_croak(aTHX_ "panic: INTERPCONCAT");
2368 if (PL_bufptr == PL_bufend)
2369 return sublex_done();
2371 if (SvIVX(PL_linestr) == '\'') {
2372 SV *sv = newSVsv(PL_linestr);
2375 else if ( PL_hints & HINT_NEW_RE )
2376 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
2377 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2381 s = scan_const(PL_bufptr);
2383 PL_lex_state = LEX_INTERPCASEMOD;
2385 PL_lex_state = LEX_INTERPSTART;
2388 if (s != PL_bufptr) {
2389 PL_nextval[PL_nexttoke] = yylval;
2392 if (PL_lex_starts++)
2402 PL_lex_state = LEX_NORMAL;
2403 s = scan_formline(PL_bufptr);
2404 if (!PL_lex_formbrack)
2410 PL_oldoldbufptr = PL_oldbufptr;
2413 PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at %s\n",
2414 exp_name[PL_expect], s);
2420 if (isIDFIRST_lazy_if(s,UTF))
2422 Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
2425 goto fake_eof; /* emulate EOF on ^D or ^Z */
2430 if (PL_lex_brackets)
2431 yyerror("Missing right curly or square bracket");
2432 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2433 "### Tokener got EOF\n");
2437 if (s++ < PL_bufend)
2438 goto retry; /* ignore stray nulls */
2441 if (!PL_in_eval && !PL_preambled) {
2442 PL_preambled = TRUE;
2443 sv_setpv(PL_linestr,incl_perldb());
2444 if (SvCUR(PL_linestr))
2445 sv_catpv(PL_linestr,";");
2447 while(AvFILLp(PL_preambleav) >= 0) {
2448 SV *tmpsv = av_shift(PL_preambleav);
2449 sv_catsv(PL_linestr, tmpsv);
2450 sv_catpv(PL_linestr, ";");
2453 sv_free((SV*)PL_preambleav);
2454 PL_preambleav = NULL;
2456 if (PL_minus_n || PL_minus_p) {
2457 sv_catpv(PL_linestr, "LINE: while (<>) {");
2459 sv_catpv(PL_linestr,"chomp;");
2462 if (strchr("/'\"", *PL_splitstr)
2463 && strchr(PL_splitstr + 1, *PL_splitstr))
2464 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
2467 s = "'~#\200\1'"; /* surely one char is unused...*/
2468 while (s[1] && strchr(PL_splitstr, *s)) s++;
2470 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s%c",
2471 "q" + (delim == '\''), delim);
2472 for (s = PL_splitstr; *s; s++) {
2474 sv_catpvn(PL_linestr, "\\", 1);
2475 sv_catpvn(PL_linestr, s, 1);
2477 Perl_sv_catpvf(aTHX_ PL_linestr, "%c);", delim);
2481 sv_catpv(PL_linestr,"our @F=split(' ');");
2484 sv_catpv(PL_linestr, "\n");
2485 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2486 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2487 PL_last_lop = PL_last_uni = Nullch;
2488 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2489 SV *sv = NEWSV(85,0);
2491 sv_upgrade(sv, SVt_PVMG);
2492 sv_setsv(sv,PL_linestr);
2495 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2500 bof = PL_rsfp ? TRUE : FALSE;
2501 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
2504 if (PL_preprocess && !PL_in_eval)
2505 (void)PerlProc_pclose(PL_rsfp);
2506 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2507 PerlIO_clearerr(PL_rsfp);
2509 (void)PerlIO_close(PL_rsfp);
2511 PL_doextract = FALSE;
2513 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2514 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
2515 sv_catpv(PL_linestr,";}");
2516 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2517 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2518 PL_last_lop = PL_last_uni = Nullch;
2519 PL_minus_n = PL_minus_p = 0;
2522 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2523 PL_last_lop = PL_last_uni = Nullch;
2524 sv_setpv(PL_linestr,"");
2525 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
2527 /* if it looks like the start of a BOM, check if it in fact is */
2528 else if (bof && (!*s || *(U8*)s == 0xEF || *(U8*)s >= 0xFE)) {
2529 #ifdef PERLIO_IS_STDIO
2530 # ifdef __GNU_LIBRARY__
2531 # if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
2532 # define FTELL_FOR_PIPE_IS_BROKEN
2536 # if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
2537 # define FTELL_FOR_PIPE_IS_BROKEN
2542 #ifdef FTELL_FOR_PIPE_IS_BROKEN
2543 /* This loses the possibility to detect the bof
2544 * situation on perl -P when the libc5 is being used.
2545 * Workaround? Maybe attach some extra state to PL_rsfp?
2548 bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
2550 bof = PerlIO_tell(PL_rsfp) == (Off_t)SvCUR(PL_linestr);
2553 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2554 s = swallow_bom((U8*)s);
2558 /* Incest with pod. */
2559 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2560 sv_setpv(PL_linestr, "");
2561 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2562 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2563 PL_last_lop = PL_last_uni = Nullch;
2564 PL_doextract = FALSE;
2568 } while (PL_doextract);
2569 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2570 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2571 SV *sv = NEWSV(85,0);
2573 sv_upgrade(sv, SVt_PVMG);
2574 sv_setsv(sv,PL_linestr);
2577 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2579 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2580 PL_last_lop = PL_last_uni = Nullch;
2581 if (CopLINE(PL_curcop) == 1) {
2582 while (s < PL_bufend && isSPACE(*s))
2584 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2588 if (*s == '#' && *(s+1) == '!')
2590 #ifdef ALTERNATE_SHEBANG
2592 static char as[] = ALTERNATE_SHEBANG;
2593 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2594 d = s + (sizeof(as) - 1);
2596 #endif /* ALTERNATE_SHEBANG */
2605 while (*d && !isSPACE(*d))
2609 #ifdef ARG_ZERO_IS_SCRIPT
2610 if (ipathend > ipath) {
2612 * HP-UX (at least) sets argv[0] to the script name,
2613 * which makes $^X incorrect. And Digital UNIX and Linux,
2614 * at least, set argv[0] to the basename of the Perl
2615 * interpreter. So, having found "#!", we'll set it right.
2617 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV)); /* $^X */
2618 assert(SvPOK(x) || SvGMAGICAL(x));
2619 if (sv_eq(x, CopFILESV(PL_curcop))) {
2620 sv_setpvn(x, ipath, ipathend - ipath);
2626 char *bstart = SvPV(CopFILESV(PL_curcop),blen);
2627 char *lstart = SvPV(x,llen);
2629 bstart += blen - llen;
2630 if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
2631 sv_setpvn(x, ipath, ipathend - ipath);
2636 TAINT_NOT; /* $^X is always tainted, but that's OK */
2638 #endif /* ARG_ZERO_IS_SCRIPT */
2643 d = instr(s,"perl -");
2645 d = instr(s,"perl");
2647 /* avoid getting into infinite loops when shebang
2648 * line contains "Perl" rather than "perl" */
2650 for (d = ipathend-4; d >= ipath; --d) {
2651 if ((*d == 'p' || *d == 'P')
2652 && !ibcmp(d, "perl", 4))
2662 #ifdef ALTERNATE_SHEBANG
2664 * If the ALTERNATE_SHEBANG on this system starts with a
2665 * character that can be part of a Perl expression, then if
2666 * we see it but not "perl", we're probably looking at the
2667 * start of Perl code, not a request to hand off to some
2668 * other interpreter. Similarly, if "perl" is there, but
2669 * not in the first 'word' of the line, we assume the line
2670 * contains the start of the Perl program.
2672 if (d && *s != '#') {
2674 while (*c && !strchr("; \t\r\n\f\v#", *c))
2677 d = Nullch; /* "perl" not in first word; ignore */
2679 *s = '#'; /* Don't try to parse shebang line */
2681 #endif /* ALTERNATE_SHEBANG */
2682 #ifndef MACOS_TRADITIONAL
2687 !instr(s,"indir") &&
2688 instr(PL_origargv[0],"perl"))
2694 while (s < PL_bufend && isSPACE(*s))
2696 if (s < PL_bufend) {
2697 Newz(899,newargv,PL_origargc+3,char*);
2699 while (s < PL_bufend && !isSPACE(*s))
2702 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2705 newargv = PL_origargv;
2707 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
2708 Perl_croak(aTHX_ "Can't exec %s", ipath);
2712 U32 oldpdb = PL_perldb;
2713 bool oldn = PL_minus_n;
2714 bool oldp = PL_minus_p;
2716 while (*d && !isSPACE(*d)) d++;
2717 while (SPACE_OR_TAB(*d)) d++;
2720 bool switches_done = PL_doswitches;
2722 if (*d == 'M' || *d == 'm') {
2724 while (*d && !isSPACE(*d)) d++;
2725 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2728 d = moreswitches(d);
2730 if ((PERLDB_LINE && !oldpdb) ||
2731 ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
2732 /* if we have already added "LINE: while (<>) {",
2733 we must not do it again */
2735 sv_setpv(PL_linestr, "");
2736 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2737 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2738 PL_last_lop = PL_last_uni = Nullch;
2739 PL_preambled = FALSE;
2741 (void)gv_fetchfile(PL_origfilename);
2744 if (PL_doswitches && !switches_done) {
2745 int argc = PL_origargc;
2746 char **argv = PL_origargv;
2749 } while (argc && argv[0][0] == '-' && argv[0][1]);
2750 init_argv_symbols(argc,argv);
2756 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2758 PL_lex_state = LEX_FORMLINE;
2763 #ifdef PERL_STRICT_CR
2764 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2766 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
2768 case ' ': case '\t': case '\f': case 013:
2769 #ifdef MACOS_TRADITIONAL
2776 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2777 if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
2778 /* handle eval qq[#line 1 "foo"\n ...] */
2779 CopLINE_dec(PL_curcop);
2783 while (s < d && *s != '\n')
2787 else if (s > d) /* Found by Ilya: feed random input to Perl. */
2788 Perl_croak(aTHX_ "panic: input overflow");
2790 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2792 PL_lex_state = LEX_FORMLINE;
2802 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2809 while (s < PL_bufend && SPACE_OR_TAB(*s))
2812 if (strnEQ(s,"=>",2)) {
2813 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2814 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2815 "### Saw unary minus before =>, forcing word '%s'\n", s);
2817 OPERATOR('-'); /* unary minus */
2819 PL_last_uni = PL_oldbufptr;
2821 case 'r': ftst = OP_FTEREAD; break;
2822 case 'w': ftst = OP_FTEWRITE; break;
2823 case 'x': ftst = OP_FTEEXEC; break;
2824 case 'o': ftst = OP_FTEOWNED; break;
2825 case 'R': ftst = OP_FTRREAD; break;
2826 case 'W': ftst = OP_FTRWRITE; break;
2827 case 'X': ftst = OP_FTREXEC; break;
2828 case 'O': ftst = OP_FTROWNED; break;
2829 case 'e': ftst = OP_FTIS; break;
2830 case 'z': ftst = OP_FTZERO; break;
2831 case 's': ftst = OP_FTSIZE; break;
2832 case 'f': ftst = OP_FTFILE; break;
2833 case 'd': ftst = OP_FTDIR; break;
2834 case 'l': ftst = OP_FTLINK; break;
2835 case 'p': ftst = OP_FTPIPE; break;
2836 case 'S': ftst = OP_FTSOCK; break;
2837 case 'u': ftst = OP_FTSUID; break;
2838 case 'g': ftst = OP_FTSGID; break;
2839 case 'k': ftst = OP_FTSVTX; break;
2840 case 'b': ftst = OP_FTBLK; break;
2841 case 'c': ftst = OP_FTCHR; break;
2842 case 't': ftst = OP_FTTTY; break;
2843 case 'T': ftst = OP_FTTEXT; break;
2844 case 'B': ftst = OP_FTBINARY; break;
2845 case 'M': case 'A': case 'C':
2846 gv_fetchpv("\024",TRUE, SVt_PV);
2848 case 'M': ftst = OP_FTMTIME; break;
2849 case 'A': ftst = OP_FTATIME; break;
2850 case 'C': ftst = OP_FTCTIME; break;
2858 PL_last_lop_op = (OPCODE)ftst;
2859 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2860 "### Saw file test %c\n", (int)ftst);
2865 /* Assume it was a minus followed by a one-letter named
2866 * subroutine call (or a -bareword), then. */
2867 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2868 "### %c looked like a file test but was not\n",
2877 if (PL_expect == XOPERATOR)
2882 else if (*s == '>') {
2885 if (isIDFIRST_lazy_if(s,UTF)) {
2886 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2894 if (PL_expect == XOPERATOR)
2897 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2899 OPERATOR('-'); /* unary minus */
2906 if (PL_expect == XOPERATOR)
2911 if (PL_expect == XOPERATOR)
2914 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2920 if (PL_expect != XOPERATOR) {
2921 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2922 PL_expect = XOPERATOR;
2923 force_ident(PL_tokenbuf, '*');
2936 if (PL_expect == XOPERATOR) {
2940 PL_tokenbuf[0] = '%';
2941 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2942 if (!PL_tokenbuf[1]) {
2945 PL_pending_ident = '%';
2964 switch (PL_expect) {
2967 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
2969 PL_bufptr = s; /* update in case we back off */
2975 PL_expect = XTERMBLOCK;
2979 while (isIDFIRST_lazy_if(s,UTF)) {
2980 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2981 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
2982 if (tmp < 0) tmp = -tmp;
2998 d = scan_str(d,TRUE,TRUE);
3000 /* MUST advance bufptr here to avoid bogus
3001 "at end of line" context messages from yyerror().
3003 PL_bufptr = s + len;
3004 yyerror("Unterminated attribute parameter in attribute list");
3007 return 0; /* EOF indicator */
3011 SV *sv = newSVpvn(s, len);
3012 sv_catsv(sv, PL_lex_stuff);
3013 attrs = append_elem(OP_LIST, attrs,
3014 newSVOP(OP_CONST, 0, sv));
3015 SvREFCNT_dec(PL_lex_stuff);
3016 PL_lex_stuff = Nullsv;
3019 /* NOTE: any CV attrs applied here need to be part of
3020 the CVf_BUILTIN_ATTRS define in cv.h! */
3021 if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len))
3022 CvLVALUE_on(PL_compcv);
3023 else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len))
3024 CvLOCKED_on(PL_compcv);
3025 else if (!PL_in_my && len == 6 && strnEQ(s, "method", len))
3026 CvMETHOD_on(PL_compcv);
3027 else if (!PL_in_my && len == 9 && strnEQ(s, "assertion", len))
3028 CvASSERTION_on(PL_compcv);
3030 else if (PL_in_my == KEY_our && len == 6 &&
3031 strnEQ(s, "unique", len))
3032 GvUNIQUE_on(cGVOPx_gv(yylval.opval));
3034 /* After we've set the flags, it could be argued that
3035 we don't need to do the attributes.pm-based setting
3036 process, and shouldn't bother appending recognized
3037 flags. To experiment with that, uncomment the
3038 following "else". (Note that's already been
3039 uncommented. That keeps the above-applied built-in
3040 attributes from being intercepted (and possibly
3041 rejected) by a package's attribute routines, but is
3042 justified by the performance win for the common case
3043 of applying only built-in attributes.) */
3045 attrs = append_elem(OP_LIST, attrs,
3046 newSVOP(OP_CONST, 0,
3050 if (*s == ':' && s[1] != ':')
3053 break; /* require real whitespace or :'s */
3055 tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
3056 if (*s != ';' && *s != '}' && *s != tmp && (tmp != '=' || *s != ')')) {
3057 char q = ((*s == '\'') ? '"' : '\'');
3058 /* If here for an expression, and parsed no attrs, back off. */
3059 if (tmp == '=' && !attrs) {
3063 /* MUST advance bufptr here to avoid bogus "at end of line"
3064 context messages from yyerror().
3068 yyerror("Unterminated attribute list");
3070 yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list",
3078 PL_nextval[PL_nexttoke].opval = attrs;
3086 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
3087 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
3104 if (PL_lex_brackets <= 0)
3105 yyerror("Unmatched right square bracket");
3108 if (PL_lex_state == LEX_INTERPNORMAL) {
3109 if (PL_lex_brackets == 0) {
3110 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
3111 PL_lex_state = LEX_INTERPEND;
3118 if (PL_lex_brackets > 100) {
3119 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
3121 switch (PL_expect) {
3123 if (PL_lex_formbrack) {
3127 if (PL_oldoldbufptr == PL_last_lop)
3128 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3130 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3131 OPERATOR(HASHBRACK);
3133 while (s < PL_bufend && SPACE_OR_TAB(*s))
3136 PL_tokenbuf[0] = '\0';
3137 if (d < PL_bufend && *d == '-') {
3138 PL_tokenbuf[0] = '-';
3140 while (d < PL_bufend && SPACE_OR_TAB(*d))
3143 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
3144 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
3146 while (d < PL_bufend && SPACE_OR_TAB(*d))
3149 char minus = (PL_tokenbuf[0] == '-');
3150 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
3158 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
3163 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3168 if (PL_oldoldbufptr == PL_last_lop)
3169 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3171 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3174 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
3176 /* This hack is to get the ${} in the message. */
3178 yyerror("syntax error");
3181 OPERATOR(HASHBRACK);
3183 /* This hack serves to disambiguate a pair of curlies
3184 * as being a block or an anon hash. Normally, expectation
3185 * determines that, but in cases where we're not in a
3186 * position to expect anything in particular (like inside
3187 * eval"") we have to resolve the ambiguity. This code
3188 * covers the case where the first term in the curlies is a
3189 * quoted string. Most other cases need to be explicitly
3190 * disambiguated by prepending a `+' before the opening
3191 * curly in order to force resolution as an anon hash.
3193 * XXX should probably propagate the outer expectation
3194 * into eval"" to rely less on this hack, but that could
3195 * potentially break current behavior of eval"".
3199 if (*s == '\'' || *s == '"' || *s == '`') {
3200 /* common case: get past first string, handling escapes */
3201 for (t++; t < PL_bufend && *t != *s;)
3202 if (*t++ == '\\' && (*t == '\\' || *t == *s))
3206 else if (*s == 'q') {
3209 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
3212 /* skip q//-like construct */
3214 char open, close, term;
3217 while (t < PL_bufend && isSPACE(*t))
3219 /* check for q => */
3220 if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
3221 OPERATOR(HASHBRACK);
3225 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
3229 for (t++; t < PL_bufend; t++) {
3230 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
3232 else if (*t == open)
3236 for (t++; t < PL_bufend; t++) {
3237 if (*t == '\\' && t+1 < PL_bufend)
3239 else if (*t == close && --brackets <= 0)
3241 else if (*t == open)
3248 /* skip plain q word */
3249 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3252 else if (isALNUM_lazy_if(t,UTF)) {
3254 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3257 while (t < PL_bufend && isSPACE(*t))
3259 /* if comma follows first term, call it an anon hash */
3260 /* XXX it could be a comma expression with loop modifiers */
3261 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
3262 || (*t == '=' && t[1] == '>')))
3263 OPERATOR(HASHBRACK);
3264 if (PL_expect == XREF)
3267 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
3273 yylval.ival = CopLINE(PL_curcop);
3274 if (isSPACE(*s) || *s == '#')
3275 PL_copline = NOLINE; /* invalidate current command line number */
3280 if (PL_lex_brackets <= 0)
3281 yyerror("Unmatched right curly bracket");
3283 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
3284 if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
3285 PL_lex_formbrack = 0;
3286 if (PL_lex_state == LEX_INTERPNORMAL) {
3287 if (PL_lex_brackets == 0) {
3288 if (PL_expect & XFAKEBRACK) {
3289 PL_expect &= XENUMMASK;
3290 PL_lex_state = LEX_INTERPEND;
3292 return yylex(); /* ignore fake brackets */
3294 if (*s == '-' && s[1] == '>')
3295 PL_lex_state = LEX_INTERPENDMAYBE;
3296 else if (*s != '[' && *s != '{')
3297 PL_lex_state = LEX_INTERPEND;
3300 if (PL_expect & XFAKEBRACK) {
3301 PL_expect &= XENUMMASK;
3303 return yylex(); /* ignore fake brackets */
3313 if (PL_expect == XOPERATOR) {
3314 if (ckWARN(WARN_SEMICOLON)
3315 && isIDFIRST_lazy_if(s,UTF) && PL_bufptr == PL_linestart)
3317 CopLINE_dec(PL_curcop);
3318 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
3319 CopLINE_inc(PL_curcop);
3324 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3326 PL_expect = XOPERATOR;
3327 force_ident(PL_tokenbuf, '&');
3331 yylval.ival = (OPpENTERSUB_AMPER<<8);
3350 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
3351 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Reversed %c= operator",(int)tmp);
3353 if (PL_expect == XSTATE && isALPHA(tmp) &&
3354 (s == PL_linestart+1 || s[-2] == '\n') )
3356 if (PL_in_eval && !PL_rsfp) {
3361 if (strnEQ(s,"=cut",4)) {
3375 PL_doextract = TRUE;
3378 if (PL_lex_brackets < PL_lex_formbrack) {
3380 #ifdef PERL_STRICT_CR
3381 for (t = s; SPACE_OR_TAB(*t); t++) ;
3383 for (t = s; SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
3385 if (*t == '\n' || *t == '#') {
3403 if (PL_expect != XOPERATOR) {
3404 if (s[1] != '<' && !strchr(s,'>'))
3407 s = scan_heredoc(s);
3409 s = scan_inputsymbol(s);
3410 TERM(sublex_start());
3415 SHop(OP_LEFT_SHIFT);
3429 SHop(OP_RIGHT_SHIFT);
3438 if (PL_expect == XOPERATOR) {
3439 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3442 return ','; /* grandfather non-comma-format format */
3446 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
3447 PL_tokenbuf[0] = '@';
3448 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3449 sizeof PL_tokenbuf - 1, FALSE);
3450 if (PL_expect == XOPERATOR)
3451 no_op("Array length", s);
3452 if (!PL_tokenbuf[1])
3454 PL_expect = XOPERATOR;
3455 PL_pending_ident = '#';
3459 PL_tokenbuf[0] = '$';
3460 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3461 sizeof PL_tokenbuf - 1, FALSE);
3462 if (PL_expect == XOPERATOR)
3464 if (!PL_tokenbuf[1]) {
3466 yyerror("Final $ should be \\$ or $name");
3470 /* This kludge not intended to be bulletproof. */
3471 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
3472 yylval.opval = newSVOP(OP_CONST, 0,
3473 newSViv(PL_compiling.cop_arybase));
3474 yylval.opval->op_private = OPpCONST_ARYBASE;
3480 if (PL_lex_state == LEX_NORMAL)
3483 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3486 PL_tokenbuf[0] = '@';
3487 if (ckWARN(WARN_SYNTAX)) {
3489 isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$';
3492 PL_bufptr = skipspace(PL_bufptr);
3493 while (t < PL_bufend && *t != ']')
3495 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3496 "Multidimensional syntax %.*s not supported",
3497 (t - PL_bufptr) + 1, PL_bufptr);
3501 else if (*s == '{') {
3502 PL_tokenbuf[0] = '%';
3503 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
3504 (t = strchr(s, '}')) && (t = strchr(t, '=')))
3506 char tmpbuf[sizeof PL_tokenbuf];
3508 for (t++; isSPACE(*t); t++) ;
3509 if (isIDFIRST_lazy_if(t,UTF)) {
3510 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
3511 for (; isSPACE(*t); t++) ;
3512 if (*t == ';' && get_cv(tmpbuf, FALSE))
3513 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3514 "You need to quote \"%s\"", tmpbuf);
3520 PL_expect = XOPERATOR;
3521 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3522 bool islop = (PL_last_lop == PL_oldoldbufptr);
3523 if (!islop || PL_last_lop_op == OP_GREPSTART)
3524 PL_expect = XOPERATOR;
3525 else if (strchr("$@\"'`q", *s))
3526 PL_expect = XTERM; /* e.g. print $fh "foo" */
3527 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
3528 PL_expect = XTERM; /* e.g. print $fh &sub */
3529 else if (isIDFIRST_lazy_if(s,UTF)) {
3530 char tmpbuf[sizeof PL_tokenbuf];
3531 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3532 if ((tmp = keyword(tmpbuf, len))) {
3533 /* binary operators exclude handle interpretations */
3545 PL_expect = XTERM; /* e.g. print $fh length() */
3550 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
3551 if (gv && GvCVu(gv))
3552 PL_expect = XTERM; /* e.g. print $fh subr() */
3555 else if (isDIGIT(*s))
3556 PL_expect = XTERM; /* e.g. print $fh 3 */
3557 else if (*s == '.' && isDIGIT(s[1]))
3558 PL_expect = XTERM; /* e.g. print $fh .3 */
3559 else if (strchr("?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
3560 PL_expect = XTERM; /* e.g. print $fh -1 */
3561 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '=' && s[1] != '/')
3562 PL_expect = XTERM; /* e.g. print $fh /.../
3563 XXX except DORDOR operator */
3564 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3565 PL_expect = XTERM; /* print $fh <<"EOF" */
3567 PL_pending_ident = '$';
3571 if (PL_expect == XOPERATOR)
3573 PL_tokenbuf[0] = '@';
3574 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3575 if (!PL_tokenbuf[1]) {
3578 if (PL_lex_state == LEX_NORMAL)
3580 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3582 PL_tokenbuf[0] = '%';
3584 /* Warn about @ where they meant $. */
3585 if (ckWARN(WARN_SYNTAX)) {
3586 if (*s == '[' || *s == '{') {
3588 while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
3590 if (*t == '}' || *t == ']') {
3592 PL_bufptr = skipspace(PL_bufptr);
3593 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3594 "Scalar value %.*s better written as $%.*s",
3595 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
3600 PL_pending_ident = '@';
3603 case '/': /* may be division, defined-or, or pattern */
3604 if (PL_expect == XTERMORDORDOR && s[1] == '/') {
3608 case '?': /* may either be conditional or pattern */
3609 if(PL_expect == XOPERATOR) {
3617 /* A // operator. */
3627 /* Disable warning on "study /blah/" */
3628 if (PL_oldoldbufptr == PL_last_uni
3629 && (*PL_last_uni != 's' || s - PL_last_uni < 5
3630 || memNE(PL_last_uni, "study", 5)
3631 || isALNUM_lazy_if(PL_last_uni+5,UTF)
3634 s = scan_pat(s,OP_MATCH);
3635 TERM(sublex_start());
3639 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3640 #ifdef PERL_STRICT_CR
3643 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3645 && (s == PL_linestart || s[-1] == '\n') )
3647 PL_lex_formbrack = 0;
3651 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
3657 yylval.ival = OPf_SPECIAL;
3663 if (PL_expect != XOPERATOR)
3668 case '0': case '1': case '2': case '3': case '4':
3669 case '5': case '6': case '7': case '8': case '9':
3670 s = scan_num(s, &yylval);
3671 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3672 "### Saw number in '%s'\n", s);
3674 if (PL_expect == XOPERATOR)
3679 s = scan_str(s,FALSE,FALSE);
3680 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3681 "### Saw string before '%s'\n", s);
3683 if (PL_expect == XOPERATOR) {
3684 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3687 return ','; /* grandfather non-comma-format format */
3693 missingterm((char*)0);
3694 yylval.ival = OP_CONST;
3695 TERM(sublex_start());
3698 s = scan_str(s,FALSE,FALSE);
3699 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3700 "### Saw string before '%s'\n", s);
3702 if (PL_expect == XOPERATOR) {
3703 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3706 return ','; /* grandfather non-comma-format format */
3712 missingterm((char*)0);
3713 yylval.ival = OP_CONST;
3714 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
3715 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
3716 yylval.ival = OP_STRINGIFY;
3720 TERM(sublex_start());
3723 s = scan_str(s,FALSE,FALSE);
3724 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3725 "### Saw backtick string before '%s'\n", s);
3727 if (PL_expect == XOPERATOR)
3728 no_op("Backticks",s);
3730 missingterm((char*)0);
3731 yylval.ival = OP_BACKTICK;
3733 TERM(sublex_start());
3737 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
3738 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
3740 if (PL_expect == XOPERATOR)
3741 no_op("Backslash",s);
3745 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
3749 while (isDIGIT(*start) || *start == '_')
3751 if (*start == '.' && isDIGIT(start[1])) {
3752 s = scan_num(s, &yylval);
3755 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
3756 else if (!isALPHA(*start) && (PL_expect == XTERM
3757 || PL_expect == XREF || PL_expect == XSTATE
3758 || PL_expect == XTERMORDORDOR)) {
3762 gv = gv_fetchpv(s, FALSE, SVt_PVCV);
3765 s = scan_num(s, &yylval);
3772 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
3812 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3814 /* Some keywords can be followed by any delimiter, including ':' */
3815 tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
3816 (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
3817 (PL_tokenbuf[0] == 'q' &&
3818 strchr("qwxr", PL_tokenbuf[1])))));
3820 /* x::* is just a word, unless x is "CORE" */
3821 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
3825 while (d < PL_bufend && isSPACE(*d))
3826 d++; /* no comments skipped here, or s### is misparsed */
3828 /* Is this a label? */
3829 if (!tmp && PL_expect == XSTATE
3830 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
3832 yylval.pval = savepv(PL_tokenbuf);
3837 /* Check for keywords */
3838 tmp = keyword(PL_tokenbuf, len);
3840 /* Is this a word before a => operator? */
3841 if (*d == '=' && d[1] == '>') {
3843 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
3844 yylval.opval->op_private = OPpCONST_BARE;
3845 if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
3846 SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
3850 if (tmp < 0) { /* second-class keyword? */
3851 GV *ogv = Nullgv; /* override (winner) */
3852 GV *hgv = Nullgv; /* hidden (loser) */
3853 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3855 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3858 if (GvIMPORTED_CV(gv))
3860 else if (! CvMETHOD(cv))
3864 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3865 (gv = *gvp) != (GV*)&PL_sv_undef &&
3866 GvCVu(gv) && GvIMPORTED_CV(gv))
3873 tmp = 0; /* overridden by import or by GLOBAL */
3876 && -tmp==KEY_lock /* XXX generalizable kludge */
3878 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3880 tmp = 0; /* any sub overrides "weak" keyword */
3882 else { /* no override */
3884 if (tmp == KEY_dump && ckWARN(WARN_MISC)) {
3885 Perl_warner(aTHX_ packWARN(WARN_MISC),
3886 "dump() better written as CORE::dump()");
3890 if (ckWARN(WARN_AMBIGUOUS) && hgv
3891 && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3892 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
3893 "Ambiguous call resolved as CORE::%s(), %s",
3894 GvENAME(hgv), "qualify as such or use &");
3901 default: /* not a keyword */
3905 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3907 /* Get the rest if it looks like a package qualifier */
3909 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
3911 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3914 Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
3915 *s == '\'' ? "'" : "::");
3920 if (PL_expect == XOPERATOR) {
3921 if (PL_bufptr == PL_linestart) {
3922 CopLINE_dec(PL_curcop);
3923 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
3924 CopLINE_inc(PL_curcop);
3927 no_op("Bareword",s);
3930 /* Look for a subroutine with this name in current package,
3931 unless name is "Foo::", in which case Foo is a bearword
3932 (and a package name). */
3935 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3937 if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3938 Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
3939 "Bareword \"%s\" refers to nonexistent package",
3942 PL_tokenbuf[len] = '\0';
3949 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3952 /* if we saw a global override before, get the right name */
3955 sv = newSVpvn("CORE::GLOBAL::",14);
3956 sv_catpv(sv,PL_tokenbuf);
3959 sv = newSVpv(PL_tokenbuf,0);
3961 /* Presume this is going to be a bareword of some sort. */
3964 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3965 yylval.opval->op_private = OPpCONST_BARE;
3966 /* UTF-8 package name? */
3967 if (UTF && !IN_BYTES &&
3968 is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
3971 /* And if "Foo::", then that's what it certainly is. */
3976 /* See if it's the indirect object for a list operator. */
3978 if (PL_oldoldbufptr &&
3979 PL_oldoldbufptr < PL_bufptr &&
3980 (PL_oldoldbufptr == PL_last_lop
3981 || PL_oldoldbufptr == PL_last_uni) &&
3982 /* NO SKIPSPACE BEFORE HERE! */
3983 (PL_expect == XREF ||
3984 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
3986 bool immediate_paren = *s == '(';
3988 /* (Now we can afford to cross potential line boundary.) */
3991 /* Two barewords in a row may indicate method call. */
3993 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp=intuit_method(s,gv)))
3996 /* If not a declared subroutine, it's an indirect object. */
3997 /* (But it's an indir obj regardless for sort.) */
3999 if ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
4000 ((!gv || !GvCVu(gv)) &&
4001 (PL_last_lop_op != OP_MAPSTART &&
4002 PL_last_lop_op != OP_GREPSTART))))
4004 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
4009 PL_expect = XOPERATOR;
4012 /* Is this a word before a => operator? */
4013 if (*s == '=' && s[1] == '>' && !pkgname) {
4015 sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
4016 if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
4017 SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
4021 /* If followed by a paren, it's certainly a subroutine. */
4024 if (gv && GvCVu(gv)) {
4025 for (d = s + 1; SPACE_OR_TAB(*d); d++) ;
4026 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
4031 PL_nextval[PL_nexttoke].opval = yylval.opval;
4032 PL_expect = XOPERATOR;
4038 /* If followed by var or block, call it a method (unless sub) */
4040 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
4041 PL_last_lop = PL_oldbufptr;
4042 PL_last_lop_op = OP_METHOD;
4046 /* If followed by a bareword, see if it looks like indir obj. */
4049 && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
4050 && (tmp = intuit_method(s,gv)))
4053 /* Not a method, so call it a subroutine (if defined) */
4055 if (gv && GvCVu(gv)) {
4057 if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
4058 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4059 "Ambiguous use of -%s resolved as -&%s()",
4060 PL_tokenbuf, PL_tokenbuf);
4061 /* Check for a constant sub */
4063 if ((sv = cv_const_sv(cv))) {
4065 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
4066 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
4067 yylval.opval->op_private = 0;
4071 /* Resolve to GV now. */
4072 op_free(yylval.opval);
4073 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
4074 yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
4075 PL_last_lop = PL_oldbufptr;
4076 PL_last_lop_op = OP_ENTERSUB;
4077 /* Is there a prototype? */
4080 char *proto = SvPV((SV*)cv, len);
4083 if (strEQ(proto, "$"))
4085 while (*proto == ';')
4087 if (*proto == '&' && *s == '{') {
4088 sv_setpv(PL_subname, PL_curstash ?
4089 "__ANON__" : "__ANON__::__ANON__");
4093 PL_nextval[PL_nexttoke].opval = yylval.opval;
4099 /* Call it a bare word */
4101 if (PL_hints & HINT_STRICT_SUBS)
4102 yylval.opval->op_private |= OPpCONST_STRICT;
4105 if (ckWARN(WARN_RESERVED)) {
4106 if (lastchar != '-') {
4107 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
4108 if (!*d && !gv_stashpv(PL_tokenbuf,FALSE))
4109 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
4116 if (lastchar && strchr("*%&", lastchar) && ckWARN_d(WARN_AMBIGUOUS)) {
4117 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4118 "Operator or semicolon missing before %c%s",
4119 lastchar, PL_tokenbuf);
4120 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4121 "Ambiguous use of %c resolved as operator %c",
4122 lastchar, lastchar);
4128 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4129 newSVpv(CopFILE(PL_curcop),0));
4133 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4134 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
4137 case KEY___PACKAGE__:
4138 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4140 ? newSVsv(PL_curstname)
4149 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
4150 char *pname = "main";
4151 if (PL_tokenbuf[2] == 'D')
4152 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
4153 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
4156 GvIOp(gv) = newIO();
4157 IoIFP(GvIOp(gv)) = PL_rsfp;
4158 #if defined(HAS_FCNTL) && defined(F_SETFD)
4160 int fd = PerlIO_fileno(PL_rsfp);
4161 fcntl(fd,F_SETFD,fd >= 3);
4164 /* Mark this internal pseudo-handle as clean */
4165 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
4167 IoTYPE(GvIOp(gv)) = IoTYPE_PIPE;
4168 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
4169 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
4171 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
4172 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
4173 /* if the script was opened in binmode, we need to revert
4174 * it to text mode for compatibility; but only iff it has CRs
4175 * XXX this is a questionable hack at best. */
4176 if (PL_bufend-PL_bufptr > 2
4177 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
4180 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
4181 loc = PerlIO_tell(PL_rsfp);
4182 (void)PerlIO_seek(PL_rsfp, 0L, 0);
4185 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
4187 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
4188 #endif /* NETWARE */
4189 #ifdef PERLIO_IS_STDIO /* really? */
4190 # if defined(__BORLANDC__)
4191 /* XXX see note in do_binmode() */
4192 ((FILE*)PL_rsfp)->flags &= ~_F_BIN;
4196 PerlIO_seek(PL_rsfp, loc, 0);
4200 #ifdef PERLIO_LAYERS
4203 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
4204 else if (PL_encoding) {
4211 XPUSHs(PL_encoding);
4213 call_method("name", G_SCALAR);
4217 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
4218 Perl_form(aTHX_ ":encoding(%"SVf")",
4236 if (PL_expect == XSTATE) {
4243 if (*s == ':' && s[1] == ':') {
4246 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4247 if (!(tmp = keyword(PL_tokenbuf, len)))
4248 Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
4262 LOP(OP_ACCEPT,XTERM);
4268 LOP(OP_ATAN2,XTERM);
4274 LOP(OP_BINMODE,XTERM);
4277 LOP(OP_BLESS,XTERM);
4286 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
4303 if (!PL_cryptseen) {
4304 PL_cryptseen = TRUE;
4308 LOP(OP_CRYPT,XTERM);
4311 LOP(OP_CHMOD,XTERM);
4314 LOP(OP_CHOWN,XTERM);
4317 LOP(OP_CONNECT,XTERM);
4333 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4337 PL_hints |= HINT_BLOCK_SCOPE;
4347 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
4348 LOP(OP_DBMOPEN,XTERM);
4354 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4361 yylval.ival = CopLINE(PL_curcop);
4375 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
4376 UNIBRACK(OP_ENTEREVAL);
4394 case KEY_endhostent:
4400 case KEY_endservent:
4403 case KEY_endprotoent:
4414 yylval.ival = CopLINE(PL_curcop);
4416 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
4418 if ((PL_bufend - p) >= 3 &&
4419 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
4421 else if ((PL_bufend - p) >= 4 &&
4422 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
4425 if (isIDFIRST_lazy_if(p,UTF)) {
4426 p = scan_ident(p, PL_bufend,
4427 PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4431 Perl_croak(aTHX_ "Missing $ on loop variable");
4436 LOP(OP_FORMLINE,XTERM);
4442 LOP(OP_FCNTL,XTERM);
4448 LOP(OP_FLOCK,XTERM);
4457 LOP(OP_GREPSTART, XREF);
4460 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4475 case KEY_getpriority:
4476 LOP(OP_GETPRIORITY,XTERM);
4478 case KEY_getprotobyname:
4481 case KEY_getprotobynumber:
4482 LOP(OP_GPBYNUMBER,XTERM);
4484 case KEY_getprotoent:
4496 case KEY_getpeername:
4497 UNI(OP_GETPEERNAME);
4499 case KEY_gethostbyname:
4502 case KEY_gethostbyaddr:
4503 LOP(OP_GHBYADDR,XTERM);
4505 case KEY_gethostent:
4508 case KEY_getnetbyname:
4511 case KEY_getnetbyaddr:
4512 LOP(OP_GNBYADDR,XTERM);
4517 case KEY_getservbyname:
4518 LOP(OP_GSBYNAME,XTERM);
4520 case KEY_getservbyport:
4521 LOP(OP_GSBYPORT,XTERM);
4523 case KEY_getservent:
4526 case KEY_getsockname:
4527 UNI(OP_GETSOCKNAME);
4529 case KEY_getsockopt:
4530 LOP(OP_GSOCKOPT,XTERM);
4552 yylval.ival = CopLINE(PL_curcop);
4556 LOP(OP_INDEX,XTERM);
4562 LOP(OP_IOCTL,XTERM);
4574 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4606 LOP(OP_LISTEN,XTERM);
4615 s = scan_pat(s,OP_MATCH);
4616 TERM(sublex_start());
4619 LOP(OP_MAPSTART, XREF);
4622 LOP(OP_MKDIR,XTERM);
4625 LOP(OP_MSGCTL,XTERM);
4628 LOP(OP_MSGGET,XTERM);
4631 LOP(OP_MSGRCV,XTERM);
4634 LOP(OP_MSGSND,XTERM);
4640 if (isIDFIRST_lazy_if(s,UTF)) {
4641 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
4642 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
4644 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
4645 if (!PL_in_my_stash) {
4648 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
4656 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4663 if (PL_expect != XSTATE)
4664 yyerror("\"no\" not allowed in expression");
4665 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4666 s = force_version(s, FALSE);
4671 if (*s == '(' || (s = skipspace(s), *s == '('))
4678 if (isIDFIRST_lazy_if(s,UTF)) {
4680 for (d = s; isALNUM_lazy_if(d,UTF); d++) ;
4682 if (strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
4684 && !(t[0] == '=' && t[1] == '>')
4686 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4687 "Precedence problem: open %.*s should be open(%.*s)",
4688 d - s, s, d - s, s);
4694 yylval.ival = OP_OR;
4704 LOP(OP_OPEN_DIR,XTERM);
4707 checkcomma(s,PL_tokenbuf,"filehandle");
4711 checkcomma(s,PL_tokenbuf,"filehandle");
4730 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4734 LOP(OP_PIPE_OP,XTERM);
4737 s = scan_str(s,FALSE,FALSE);
4739 missingterm((char*)0);
4740 yylval.ival = OP_CONST;
4741 TERM(sublex_start());
4747 s = scan_str(s,FALSE,FALSE);
4749 missingterm((char*)0);
4751 if (SvCUR(PL_lex_stuff)) {
4754 d = SvPV_force(PL_lex_stuff, len);
4757 for (; isSPACE(*d) && len; --len, ++d) ;
4760 if (!warned && ckWARN(WARN_QW)) {
4761 for (; !isSPACE(*d) && len; --len, ++d) {
4763 Perl_warner(aTHX_ packWARN(WARN_QW),
4764 "Possible attempt to separate words with commas");
4767 else if (*d == '#') {
4768 Perl_warner(aTHX_ packWARN(WARN_QW),
4769 "Possible attempt to put comments in qw() list");
4775 for (; !isSPACE(*d) && len; --len, ++d) ;
4777 sv = newSVpvn(b, d-b);
4778 if (DO_UTF8(PL_lex_stuff))
4780 words = append_elem(OP_LIST, words,
4781 newSVOP(OP_CONST, 0, tokeq(sv)));
4785 PL_nextval[PL_nexttoke].opval = words;
4790 SvREFCNT_dec(PL_lex_stuff);
4791 PL_lex_stuff = Nullsv;
4797 s = scan_str(s,FALSE,FALSE);
4799 missingterm((char*)0);
4800 yylval.ival = OP_STRINGIFY;
4801 if (SvIVX(PL_lex_stuff) == '\'')
4802 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
4803 TERM(sublex_start());
4806 s = scan_pat(s,OP_QR);
4807 TERM(sublex_start());
4810 s = scan_str(s,FALSE,FALSE);
4812 missingterm((char*)0);
4813 yylval.ival = OP_BACKTICK;
4815 TERM(sublex_start());
4823 s = force_version(s, FALSE);
4825 else if (*s != 'v' || !isDIGIT(s[1])
4826 || (s = force_version(s, TRUE), *s == 'v'))
4828 *PL_tokenbuf = '\0';
4829 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4830 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
4831 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
4833 yyerror("<> should be quotes");
4841 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4845 LOP(OP_RENAME,XTERM);
4854 LOP(OP_RINDEX,XTERM);
4864 UNIDOR(OP_READLINE);
4877 LOP(OP_REVERSE,XTERM);
4880 UNIDOR(OP_READLINK);
4888 TERM(sublex_start());
4890 TOKEN(1); /* force error */
4899 LOP(OP_SELECT,XTERM);
4905 LOP(OP_SEMCTL,XTERM);
4908 LOP(OP_SEMGET,XTERM);
4911 LOP(OP_SEMOP,XTERM);
4917 LOP(OP_SETPGRP,XTERM);
4919 case KEY_setpriority:
4920 LOP(OP_SETPRIORITY,XTERM);
4922 case KEY_sethostent:
4928 case KEY_setservent:
4931 case KEY_setprotoent:
4941 LOP(OP_SEEKDIR,XTERM);
4943 case KEY_setsockopt:
4944 LOP(OP_SSOCKOPT,XTERM);
4950 LOP(OP_SHMCTL,XTERM);
4953 LOP(OP_SHMGET,XTERM);
4956 LOP(OP_SHMREAD,XTERM);
4959 LOP(OP_SHMWRITE,XTERM);
4962 LOP(OP_SHUTDOWN,XTERM);
4971 LOP(OP_SOCKET,XTERM);
4973 case KEY_socketpair:
4974 LOP(OP_SOCKPAIR,XTERM);
4977 checkcomma(s,PL_tokenbuf,"subroutine name");
4979 if (*s == ';' || *s == ')') /* probably a close */
4980 Perl_croak(aTHX_ "sort is now a reserved word");
4982 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4986 LOP(OP_SPLIT,XTERM);
4989 LOP(OP_SPRINTF,XTERM);
4992 LOP(OP_SPLICE,XTERM);
5007 LOP(OP_SUBSTR,XTERM);
5013 char tmpbuf[sizeof PL_tokenbuf];
5014 SSize_t tboffset = 0;
5015 expectation attrful;
5016 bool have_name, have_proto, bad_proto;
5021 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
5022 (*s == ':' && s[1] == ':'))
5025 attrful = XATTRBLOCK;
5026 /* remember buffer pos'n for later force_word */
5027 tboffset = s - PL_oldbufptr;
5028 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
5029 if (strchr(tmpbuf, ':'))
5030 sv_setpv(PL_subname, tmpbuf);
5032 sv_setsv(PL_subname,PL_curstname);
5033 sv_catpvn(PL_subname,"::",2);
5034 sv_catpvn(PL_subname,tmpbuf,len);
5041 Perl_croak(aTHX_ "Missing name in \"my sub\"");
5042 PL_expect = XTERMBLOCK;
5043 attrful = XATTRTERM;
5044 sv_setpv(PL_subname,"?");
5048 if (key == KEY_format) {
5050 PL_lex_formbrack = PL_lex_brackets + 1;
5052 (void) force_word(PL_oldbufptr + tboffset, WORD,
5057 /* Look for a prototype */
5061 s = scan_str(s,FALSE,FALSE);
5063 Perl_croak(aTHX_ "Prototype not terminated");
5064 /* strip spaces and check for bad characters */
5065 d = SvPVX(PL_lex_stuff);
5068 for (p = d; *p; ++p) {
5071 if (!strchr("$@%*;[]&\\", *p))
5076 if (bad_proto && ckWARN(WARN_SYNTAX))
5077 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5078 "Illegal character in prototype for %"SVf" : %s",
5080 SvCUR(PL_lex_stuff) = tmp;
5088 if (*s == ':' && s[1] != ':')
5089 PL_expect = attrful;
5090 else if (!have_name && *s != '{' && key == KEY_sub)
5091 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
5094 PL_nextval[PL_nexttoke].opval =
5095 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
5096 PL_lex_stuff = Nullsv;
5100 sv_setpv(PL_subname,
5101 PL_curstash ? "__ANON__" : "__ANON__::__ANON__");
5104 (void) force_word(PL_oldbufptr + tboffset, WORD,
5113 LOP(OP_SYSTEM,XREF);
5116 LOP(OP_SYMLINK,XTERM);
5119 LOP(OP_SYSCALL,XTERM);
5122 LOP(OP_SYSOPEN,XTERM);
5125 LOP(OP_SYSSEEK,XTERM);
5128 LOP(OP_SYSREAD,XTERM);
5131 LOP(OP_SYSWRITE,XTERM);
5135 TERM(sublex_start());
5156 LOP(OP_TRUNCATE,XTERM);
5168 yylval.ival = CopLINE(PL_curcop);
5172 yylval.ival = CopLINE(PL_curcop);
5176 LOP(OP_UNLINK,XTERM);
5182 LOP(OP_UNPACK,XTERM);
5185 LOP(OP_UTIME,XTERM);
5191 LOP(OP_UNSHIFT,XTERM);
5194 if (PL_expect != XSTATE)
5195 yyerror("\"use\" not allowed in expression");
5197 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
5198 s = force_version(s, TRUE);
5199 if (*s == ';' || (s = skipspace(s), *s == ';')) {
5200 PL_nextval[PL_nexttoke].opval = Nullop;
5203 else if (*s == 'v') {
5204 s = force_word(s,WORD,FALSE,TRUE,FALSE);
5205 s = force_version(s, FALSE);
5209 s = force_word(s,WORD,FALSE,TRUE,FALSE);
5210 s = force_version(s, FALSE);
5222 yylval.ival = CopLINE(PL_curcop);
5226 PL_hints |= HINT_BLOCK_SCOPE;
5233 LOP(OP_WAITPID,XTERM);
5242 ctl_l[0] = toCTRL('L');
5244 gv_fetchpv(ctl_l,TRUE, SVt_PV);
5247 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
5252 if (PL_expect == XOPERATOR)
5258 yylval.ival = OP_XOR;
5263 TERM(sublex_start());
5268 #pragma segment Main
5272 S_pending_ident(pTHX)
5275 register I32 tmp = 0;
5276 /* pit holds the identifier we read and pending_ident is reset */
5277 char pit = PL_pending_ident;
5278 PL_pending_ident = 0;
5280 DEBUG_T({ PerlIO_printf(Perl_debug_log,
5281 "### Tokener saw identifier '%s'\n", PL_tokenbuf); });
5283 /* if we're in a my(), we can't allow dynamics here.
5284 $foo'bar has already been turned into $foo::bar, so
5285 just check for colons.
5287 if it's a legal name, the OP is a PADANY.
5290 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
5291 if (strchr(PL_tokenbuf,':'))
5292 yyerror(Perl_form(aTHX_ "No package name allowed for "
5293 "variable %s in \"our\"",
5295 tmp = allocmy(PL_tokenbuf);
5298 if (strchr(PL_tokenbuf,':'))
5299 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
5301 yylval.opval = newOP(OP_PADANY, 0);
5302 yylval.opval->op_targ = allocmy(PL_tokenbuf);
5308 build the ops for accesses to a my() variable.
5310 Deny my($a) or my($b) in a sort block, *if* $a or $b is
5311 then used in a comparison. This catches most, but not
5312 all cases. For instance, it catches
5313 sort { my($a); $a <=> $b }
5315 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
5316 (although why you'd do that is anyone's guess).
5319 if (!strchr(PL_tokenbuf,':')) {
5321 tmp = pad_findmy(PL_tokenbuf);
5322 if (tmp != NOT_IN_PAD) {
5323 /* might be an "our" variable" */
5324 if (PAD_COMPNAME_FLAGS(tmp) & SVpad_OUR) {
5325 /* build ops for a bareword */
5326 SV *sym = newSVpv(HvNAME(PAD_COMPNAME_OURSTASH(tmp)), 0);
5327 sv_catpvn(sym, "::", 2);
5328 sv_catpv(sym, PL_tokenbuf+1);
5329 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
5330 yylval.opval->op_private = OPpCONST_ENTERED;
5331 gv_fetchpv(SvPVX(sym),
5333 ? (GV_ADDMULTI | GV_ADDINEVAL)
5336 ((PL_tokenbuf[0] == '$') ? SVt_PV
5337 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5342 /* if it's a sort block and they're naming $a or $b */
5343 if (PL_last_lop_op == OP_SORT &&
5344 PL_tokenbuf[0] == '$' &&
5345 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
5348 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
5349 d < PL_bufend && *d != '\n';
5352 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
5353 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
5359 yylval.opval = newOP(OP_PADANY, 0);
5360 yylval.opval->op_targ = tmp;
5366 Whine if they've said @foo in a doublequoted string,
5367 and @foo isn't a variable we can find in the symbol
5370 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
5371 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
5372 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
5373 && ckWARN(WARN_AMBIGUOUS))
5375 /* Downgraded from fatal to warning 20000522 mjd */
5376 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5377 "Possible unintended interpolation of %s in string",
5382 /* build ops for a bareword */
5383 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
5384 yylval.opval->op_private = OPpCONST_ENTERED;
5385 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
5386 ((PL_tokenbuf[0] == '$') ? SVt_PV
5387 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5393 Perl_keyword(pTHX_ register char *d, I32 len)
5398 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
5399 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
5400 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
5401 if (strEQ(d,"__DATA__")) return KEY___DATA__;
5402 if (strEQ(d,"__END__")) return KEY___END__;
5406 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
5411 if (strEQ(d,"and")) return -KEY_and;
5412 if (strEQ(d,"abs")) return -KEY_abs;
5415 if (strEQ(d,"alarm")) return -KEY_alarm;
5416 if (strEQ(d,"atan2")) return -KEY_atan2;
5419 if (strEQ(d,"accept")) return -KEY_accept;
5424 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
5427 if (strEQ(d,"bless")) return -KEY_bless;
5428 if (strEQ(d,"bind")) return -KEY_bind;
5429 if (strEQ(d,"binmode")) return -KEY_binmode;
5432 if (strEQ(d,"CORE")) return -KEY_CORE;
5433 if (strEQ(d,"CHECK")) return KEY_CHECK;
5438 if (strEQ(d,"cmp")) return -KEY_cmp;
5439 if (strEQ(d,"chr")) return -KEY_chr;
5440 if (strEQ(d,"cos")) return -KEY_cos;
5443 if (strEQ(d,"chop")) return -KEY_chop;
5446 if (strEQ(d,"close")) return -KEY_close;
5447 if (strEQ(d,"chdir")) return -KEY_chdir;
5448 if (strEQ(d,"chomp")) return -KEY_chomp;
5449 if (strEQ(d,"chmod")) return -KEY_chmod;
5450 if (strEQ(d,"chown")) return -KEY_chown;
5451 if (strEQ(d,"crypt")) return -KEY_crypt;
5454 if (strEQ(d,"chroot")) return -KEY_chroot;
5455 if (strEQ(d,"caller")) return -KEY_caller;
5458 if (strEQ(d,"connect")) return -KEY_connect;
5461 if (strEQ(d,"closedir")) return -KEY_closedir;
5462 if (strEQ(d,"continue")) return -KEY_continue;
5467 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
5472 if (strEQ(d,"do")) return KEY_do;
5475 if (strEQ(d,"die")) return -KEY_die;
5478 if (strEQ(d,"dump")) return -KEY_dump;
5481 if (strEQ(d,"delete")) return KEY_delete;
5484 if (strEQ(d,"defined")) return KEY_defined;
5485 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
5488 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
5493 if (strEQ(d,"END")) return KEY_END;
5498 if (strEQ(d,"eq")) return -KEY_eq;
5501 if (strEQ(d,"eof")) return -KEY_eof;
5502 if (strEQ(d,"err")) return -KEY_err;
5503 if (strEQ(d,"exp")) return -KEY_exp;
5506 if (strEQ(d,"else")) return KEY_else;
5507 if (strEQ(d,"exit")) return -KEY_exit;
5508 if (strEQ(d,"eval")) return KEY_eval;
5509 if (strEQ(d,"exec")) return -KEY_exec;
5510 if (strEQ(d,"each")) return -KEY_each;
5513 if (strEQ(d,"elsif")) return KEY_elsif;
5516 if (strEQ(d,"exists")) return KEY_exists;
5517 if (strEQ(d,"elseif")) Perl_warn(aTHX_ "elseif should be elsif");
5520 if (strEQ(d,"endgrent")) return -KEY_endgrent;
5521 if (strEQ(d,"endpwent")) return -KEY_endpwent;
5524 if (strEQ(d,"endnetent")) return -KEY_endnetent;
5527 if (strEQ(d,"endhostent")) return -KEY_endhostent;
5528 if (strEQ(d,"endservent")) return -KEY_endservent;
5531 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
5538 if (strEQ(d,"for")) return KEY_for;
5541 if (strEQ(d,"fork")) return -KEY_fork;
5544 if (strEQ(d,"fcntl")) return -KEY_fcntl;
5545 if (strEQ(d,"flock")) return -KEY_flock;
5548 if (strEQ(d,"format")) return KEY_format;
5549 if (strEQ(d,"fileno")) return -KEY_fileno;
5552 if (strEQ(d,"foreach")) return KEY_foreach;
5555 if (strEQ(d,"formline")) return -KEY_formline;
5560 if (strnEQ(d,"get",3)) {
5565 if (strEQ(d,"ppid")) return -KEY_getppid;
5566 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
5569 if (strEQ(d,"pwent")) return -KEY_getpwent;
5570 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
5571 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
5574 if (strEQ(d,"peername")) return -KEY_getpeername;
5575 if (strEQ(d,"protoent")) return -KEY_getprotoent;
5576 if (strEQ(d,"priority")) return -KEY_getpriority;
5579 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
5582 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
5586 else if (*d == 'h') {
5587 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
5588 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
5589 if (strEQ(d,"hostent")) return -KEY_gethostent;
5591 else if (*d == 'n') {
5592 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
5593 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
5594 if (strEQ(d,"netent")) return -KEY_getnetent;
5596 else if (*d == 's') {
5597 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
5598 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
5599 if (strEQ(d,"servent")) return -KEY_getservent;
5600 if (strEQ(d,"sockname")) return -KEY_getsockname;
5601 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
5603 else if (*d == 'g') {
5604 if (strEQ(d,"grent")) return -KEY_getgrent;
5605 if (strEQ(d,"grnam")) return -KEY_getgrnam;
5606 if (strEQ(d,"grgid")) return -KEY_getgrgid;
5608 else if (*d == 'l') {
5609 if (strEQ(d,"login")) return -KEY_getlogin;
5611 else if (strEQ(d,"c")) return -KEY_getc;
5616 if (strEQ(d,"gt")) return -KEY_gt;
5617 if (strEQ(d,"ge")) return -KEY_ge;
5620 if (strEQ(d,"grep")) return KEY_grep;
5621 if (strEQ(d,"goto")) return KEY_goto;
5622 if (strEQ(d,"glob")) return KEY_glob;
5625 if (strEQ(d,"gmtime")) return -KEY_gmtime;
5630 if (strEQ(d,"hex")) return -KEY_hex;
5633 if (strEQ(d,"INIT")) return KEY_INIT;
5638 if (strEQ(d,"if")) return KEY_if;
5641 if (strEQ(d,"int")) return -KEY_int;
5644 if (strEQ(d,"index")) return -KEY_index;
5645 if (strEQ(d,"ioctl")) return -KEY_ioctl;
5650 if (strEQ(d,"join")) return -KEY_join;
5654 if (strEQ(d,"keys")) return -KEY_keys;
5655 if (strEQ(d,"kill")) return -KEY_kill;
5661 if (strEQ(d,"lt")) return -KEY_lt;
5662 if (strEQ(d,"le")) return -KEY_le;
5663 if (strEQ(d,"lc")) return -KEY_lc;
5666 if (strEQ(d,"log")) return -KEY_log;
5669 if (strEQ(d,"last")) return KEY_last;
5670 if (strEQ(d,"link")) return -KEY_link;
5671 if (strEQ(d,"lock")) return -KEY_lock;
5674 if (strEQ(d,"local")) return KEY_local;
5675 if (strEQ(d,"lstat")) return -KEY_lstat;
5678 if (strEQ(d,"length")) return -KEY_length;
5679 if (strEQ(d,"listen")) return -KEY_listen;
5682 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
5685 if (strEQ(d,"localtime")) return -KEY_localtime;
5691 case 1: return KEY_m;
5693 if (strEQ(d,"my")) return KEY_my;
5696 if (strEQ(d,"map")) return KEY_map;
5699 if (strEQ(d,"mkdir")) return -KEY_mkdir;
5702 if (strEQ(d,"msgctl")) return -KEY_msgctl;
5703 if (strEQ(d,"msgget")) return -KEY_msgget;
5704 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
5705 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
5710 if (strEQ(d,"next")) return KEY_next;
5711 if (strEQ(d,"ne")) return -KEY_ne;
5712 if (strEQ(d,"not")) return -KEY_not;
5713 if (strEQ(d,"no")) return KEY_no;
5718 if (strEQ(d,"or")) return -KEY_or;
5721 if (strEQ(d,"ord")) return -KEY_ord;
5722 if (strEQ(d,"oct")) return -KEY_oct;
5723 if (strEQ(d,"our")) return KEY_our;
5726 if (strEQ(d,"open")) return -KEY_open;
5729 if (strEQ(d,"opendir")) return -KEY_opendir;
5736 if (strEQ(d,"pop")) return -KEY_pop;
5737 if (strEQ(d,"pos")) return KEY_pos;
5740 if (strEQ(d,"push")) return -KEY_push;
5741 if (strEQ(d,"pack")) return -KEY_pack;
5742 if (strEQ(d,"pipe")) return -KEY_pipe;
5745 if (strEQ(d,"print")) return KEY_print;
5748 if (strEQ(d,"printf")) return KEY_printf;
5751 if (strEQ(d,"package")) return KEY_package;
5754 if (strEQ(d,"prototype")) return KEY_prototype;
5759 if (strEQ(d,"q")) return KEY_q;
5760 if (strEQ(d,"qr")) return KEY_qr;
5761 if (strEQ(d,"qq")) return KEY_qq;
5762 if (strEQ(d,"qw")) return KEY_qw;
5763 if (strEQ(d,"qx")) return KEY_qx;
5765 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
5770 if (strEQ(d,"ref")) return -KEY_ref;
5773 if (strEQ(d,"read")) return -KEY_read;
5774 if (strEQ(d,"rand")) return -KEY_rand;
5775 if (strEQ(d,"recv")) return -KEY_recv;
5776 if (strEQ(d,"redo")) return KEY_redo;
5779 if (strEQ(d,"rmdir")) return -KEY_rmdir;
5780 if (strEQ(d,"reset")) return -KEY_reset;
5783 if (strEQ(d,"return")) return KEY_return;
5784 if (strEQ(d,"rename")) return -KEY_rename;
5785 if (strEQ(d,"rindex")) return -KEY_rindex;
5788 if (strEQ(d,"require")) return KEY_require;
5789 if (strEQ(d,"reverse")) return -KEY_reverse;
5790 if (strEQ(d,"readdir")) return -KEY_readdir;
5793 if (strEQ(d,"readlink")) return -KEY_readlink;
5794 if (strEQ(d,"readline")) return -KEY_readline;
5795 if (strEQ(d,"readpipe")) return -KEY_readpipe;
5798 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
5804 case 0: return KEY_s;
5806 if (strEQ(d,"scalar")) return KEY_scalar;
5811 if (strEQ(d,"seek")) return -KEY_seek;
5812 if (strEQ(d,"send")) return -KEY_send;
5815 if (strEQ(d,"semop")) return -KEY_semop;
5818 if (strEQ(d,"select")) return -KEY_select;
5819 if (strEQ(d,"semctl")) return -KEY_semctl;
5820 if (strEQ(d,"semget")) return -KEY_semget;
5823 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
5824 if (strEQ(d,"seekdir")) return -KEY_seekdir;
5827 if (strEQ(d,"setpwent")) return -KEY_setpwent;
5828 if (strEQ(d,"setgrent")) return -KEY_setgrent;
5831 if (strEQ(d,"setnetent")) return -KEY_setnetent;
5834 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
5835 if (strEQ(d,"sethostent")) return -KEY_sethostent;
5836 if (strEQ(d,"setservent")) return -KEY_setservent;
5839 if (strEQ(d,"setpriority")) return -KEY_setpriority;
5840 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
5847 if (strEQ(d,"shift")) return -KEY_shift;
5850 if (strEQ(d,"shmctl")) return -KEY_shmctl;
5851 if (strEQ(d,"shmget")) return -KEY_shmget;
5854 if (strEQ(d,"shmread")) return -KEY_shmread;
5857 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
5858 if (strEQ(d,"shutdown")) return -KEY_shutdown;
5863 if (strEQ(d,"sin")) return -KEY_sin;
5866 if (strEQ(d,"sleep")) return -KEY_sleep;
5869 if (strEQ(d,"sort")) return KEY_sort;
5870 if (strEQ(d,"socket")) return -KEY_socket;
5871 if (strEQ(d,"socketpair")) return -KEY_socketpair;
5874 if (strEQ(d,"split")) return KEY_split;
5875 if (strEQ(d,"sprintf")) return -KEY_sprintf;
5876 if (strEQ(d,"splice")) return -KEY_splice;
5879 if (strEQ(d,"sqrt")) return -KEY_sqrt;
5882 if (strEQ(d,"srand")) return -KEY_srand;
5885 if (strEQ(d,"stat")) return -KEY_stat;
5886 if (strEQ(d,"study")) return KEY_study;
5889 if (strEQ(d,"substr")) return -KEY_substr;
5890 if (strEQ(d,"sub")) return KEY_sub;
5895 if (strEQ(d,"system")) return -KEY_system;
5898 if (strEQ(d,"symlink")) return -KEY_symlink;
5899 if (strEQ(d,"syscall")) return -KEY_syscall;
5900 if (strEQ(d,"sysopen")) return -KEY_sysopen;
5901 if (strEQ(d,"sysread")) return -KEY_sysread;
5902 if (strEQ(d,"sysseek")) return -KEY_sysseek;
5905 if (strEQ(d,"syswrite")) return -KEY_syswrite;
5914 if (strEQ(d,"tr")) return KEY_tr;
5917 if (strEQ(d,"tie")) return KEY_tie;
5920 if (strEQ(d,"tell")) return -KEY_tell;
5921 if (strEQ(d,"tied")) return KEY_tied;
5922 if (strEQ(d,"time")) return -KEY_time;
5925 if (strEQ(d,"times")) return -KEY_times;
5928 if (strEQ(d,"telldir")) return -KEY_telldir;
5931 if (strEQ(d,"truncate")) return -KEY_truncate;
5938 if (strEQ(d,"uc")) return -KEY_uc;
5941 if (strEQ(d,"use")) return KEY_use;
5944 if (strEQ(d,"undef")) return KEY_undef;
5945 if (strEQ(d,"until")) return KEY_until;
5946 if (strEQ(d,"untie")) return KEY_untie;
5947 if (strEQ(d,"utime")) return -KEY_utime;
5948 if (strEQ(d,"umask")) return -KEY_umask;
5951 if (strEQ(d,"unless")) return KEY_unless;
5952 if (strEQ(d,"unpack")) return -KEY_unpack;
5953 if (strEQ(d,"unlink")) return -KEY_unlink;
5956 if (strEQ(d,"unshift")) return -KEY_unshift;
5957 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
5962 if (strEQ(d,"values")) return -KEY_values;
5963 if (strEQ(d,"vec")) return -KEY_vec;
5968 if (strEQ(d,"warn")) return -KEY_warn;
5969 if (strEQ(d,"wait")) return -KEY_wait;
5972 if (strEQ(d,"while")) return KEY_while;
5973 if (strEQ(d,"write")) return -KEY_write;
5976 if (strEQ(d,"waitpid")) return -KEY_waitpid;
5979 if (strEQ(d,"wantarray")) return -KEY_wantarray;
5984 if (len == 1) return -KEY_x;
5985 if (strEQ(d,"xor")) return -KEY_xor;
5988 if (len == 1) return KEY_y;
5997 S_checkcomma(pTHX_ register char *s, char *name, char *what)
6001 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
6002 if (ckWARN(WARN_SYNTAX)) {
6004 for (w = s+2; *w && level; w++) {
6011 for (; *w && isSPACE(*w); w++) ;
6012 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
6013 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6014 "%s (...) interpreted as function",name);
6017 while (s < PL_bufend && isSPACE(*s))
6021 while (s < PL_bufend && isSPACE(*s))
6023 if (isIDFIRST_lazy_if(s,UTF)) {
6025 while (isALNUM_lazy_if(s,UTF))
6027 while (s < PL_bufend && isSPACE(*s))
6032 kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
6036 Perl_croak(aTHX_ "No comma allowed after %s", what);
6041 /* Either returns sv, or mortalizes sv and returns a new SV*.
6042 Best used as sv=new_constant(..., sv, ...).
6043 If s, pv are NULL, calls subroutine with one argument,
6044 and type is used with error messages only. */
6047 S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv,
6051 HV *table = GvHV(PL_hintgv); /* ^H */
6055 const char *why1, *why2, *why3;
6057 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
6060 why2 = strEQ(key,"charnames")
6061 ? "(possibly a missing \"use charnames ...\")"
6063 msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
6064 (type ? type: "undef"), why2);
6066 /* This is convoluted and evil ("goto considered harmful")
6067 * but I do not understand the intricacies of all the different
6068 * failure modes of %^H in here. The goal here is to make
6069 * the most probable error message user-friendly. --jhi */
6074 msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
6075 (type ? type: "undef"), why1, why2, why3);
6077 yyerror(SvPVX(msg));
6081 cvp = hv_fetch(table, key, strlen(key), FALSE);
6082 if (!cvp || !SvOK(*cvp)) {
6085 why3 = "} is not defined";
6088 sv_2mortal(sv); /* Parent created it permanently */
6091 pv = sv_2mortal(newSVpvn(s, len));
6093 typesv = sv_2mortal(newSVpv(type, 0));
6095 typesv = &PL_sv_undef;
6097 PUSHSTACKi(PERLSI_OVERLOAD);
6109 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
6113 /* Check the eval first */
6114 if (!PL_in_eval && SvTRUE(ERRSV)) {
6116 sv_catpv(ERRSV, "Propagated");
6117 yyerror(SvPV(ERRSV, n_a)); /* Duplicates the message inside eval */
6119 res = SvREFCNT_inc(sv);
6123 (void)SvREFCNT_inc(res);
6132 why1 = "Call to &{$^H{";
6134 why3 = "}} did not return a defined value";
6143 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
6145 register char *d = dest;
6146 register char *e = d + destlen - 3; /* two-character token, ending NUL */
6149 Perl_croak(aTHX_ ident_too_long);
6150 if (isALNUM(*s)) /* UTF handled below */
6152 else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) {
6157 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
6161 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
6162 char *t = s + UTF8SKIP(s);
6163 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
6165 if (d + (t - s) > e)
6166 Perl_croak(aTHX_ ident_too_long);
6167 Copy(s, d, t - s, char);
6180 S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
6190 e = d + destlen - 3; /* two-character token, ending NUL */
6192 while (isDIGIT(*s)) {
6194 Perl_croak(aTHX_ ident_too_long);
6201 Perl_croak(aTHX_ ident_too_long);
6202 if (isALNUM(*s)) /* UTF handled below */
6204 else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
6209 else if (*s == ':' && s[1] == ':') {
6213 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
6214 char *t = s + UTF8SKIP(s);
6215 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
6217 if (d + (t - s) > e)
6218 Perl_croak(aTHX_ ident_too_long);
6219 Copy(s, d, t - s, char);
6230 if (PL_lex_state != LEX_NORMAL)
6231 PL_lex_state = LEX_INTERPENDMAYBE;
6234 if (*s == '$' && s[1] &&
6235 (isALNUM_lazy_if(s+1,UTF) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
6248 if (*d == '^' && *s && isCONTROLVAR(*s)) {
6253 if (isSPACE(s[-1])) {
6256 if (!SPACE_OR_TAB(ch)) {
6262 if (isIDFIRST_lazy_if(d,UTF)) {
6266 while ((e < send && isALNUM_lazy_if(e,UTF)) || *e == ':') {
6268 while (e < send && UTF8_IS_CONTINUED(*e) && is_utf8_mark((U8*)e))
6271 Copy(s, d, e - s, char);
6276 while ((isALNUM(*s) || *s == ':') && d < e)
6279 Perl_croak(aTHX_ ident_too_long);
6282 while (s < send && SPACE_OR_TAB(*s)) s++;
6283 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
6284 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
6285 const char *brack = *s == '[' ? "[...]" : "{...}";
6286 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
6287 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
6288 funny, dest, brack, funny, dest, brack);
6291 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
6295 /* Handle extended ${^Foo} variables
6296 * 1999-02-27 mjd-perl-patch@plover.com */
6297 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
6301 while (isALNUM(*s) && d < e) {
6305 Perl_croak(aTHX_ ident_too_long);
6310 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
6311 PL_lex_state = LEX_INTERPEND;
6316 if (PL_lex_state == LEX_NORMAL) {
6317 if (ckWARN(WARN_AMBIGUOUS) &&
6318 (keyword(dest, d - dest) || get_cv(dest, FALSE)))
6320 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
6321 "Ambiguous use of %c{%s} resolved to %c%s",
6322 funny, dest, funny, dest);
6327 s = bracket; /* let the parser handle it */
6331 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
6332 PL_lex_state = LEX_INTERPEND;
6337 Perl_pmflag(pTHX_ U32* pmfl, int ch)
6342 *pmfl |= PMf_GLOBAL;
6344 *pmfl |= PMf_CONTINUE;
6348 *pmfl |= PMf_MULTILINE;
6350 *pmfl |= PMf_SINGLELINE;
6352 *pmfl |= PMf_EXTENDED;
6356 S_scan_pat(pTHX_ char *start, I32 type)
6361 s = scan_str(start,FALSE,FALSE);
6363 Perl_croak(aTHX_ "Search pattern not terminated");
6365 pm = (PMOP*)newPMOP(type, 0);
6366 if (PL_multi_open == '?')
6367 pm->op_pmflags |= PMf_ONCE;
6369 while (*s && strchr("iomsx", *s))
6370 pmflag(&pm->op_pmflags,*s++);
6373 while (*s && strchr("iogcmsx", *s))
6374 pmflag(&pm->op_pmflags,*s++);
6376 /* issue a warning if /c is specified,but /g is not */
6377 if (ckWARN(WARN_REGEXP) &&
6378 (pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL))
6380 Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_without_g);
6383 pm->op_pmpermflags = pm->op_pmflags;
6385 PL_lex_op = (OP*)pm;
6386 yylval.ival = OP_MATCH;
6391 S_scan_subst(pTHX_ char *start)
6398 yylval.ival = OP_NULL;
6400 s = scan_str(start,FALSE,FALSE);
6403 Perl_croak(aTHX_ "Substitution pattern not terminated");
6405 if (s[-1] == PL_multi_open)
6408 first_start = PL_multi_start;
6409 s = scan_str(s,FALSE,FALSE);
6412 SvREFCNT_dec(PL_lex_stuff);
6413 PL_lex_stuff = Nullsv;
6415 Perl_croak(aTHX_ "Substitution replacement not terminated");
6417 PL_multi_start = first_start; /* so whole substitution is taken together */
6419 pm = (PMOP*)newPMOP(OP_SUBST, 0);
6425 else if (strchr("iogcmsx", *s))
6426 pmflag(&pm->op_pmflags,*s++);
6431 /* /c is not meaningful with s/// */
6432 if (ckWARN(WARN_REGEXP) && (pm->op_pmflags & PMf_CONTINUE))
6434 Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_in_subst);
6439 PL_sublex_info.super_bufptr = s;
6440 PL_sublex_info.super_bufend = PL_bufend;
6442 pm->op_pmflags |= PMf_EVAL;
6443 repl = newSVpvn("",0);
6445 sv_catpv(repl, es ? "eval " : "do ");
6446 sv_catpvn(repl, "{ ", 2);
6447 sv_catsv(repl, PL_lex_repl);
6448 sv_catpvn(repl, " };", 2);
6450 SvREFCNT_dec(PL_lex_repl);
6454 pm->op_pmpermflags = pm->op_pmflags;
6455 PL_lex_op = (OP*)pm;
6456 yylval.ival = OP_SUBST;
6461 S_scan_trans(pTHX_ char *start)
6470 yylval.ival = OP_NULL;
6472 s = scan_str(start,FALSE,FALSE);
6474 Perl_croak(aTHX_ "Transliteration pattern not terminated");
6475 if (s[-1] == PL_multi_open)
6478 s = scan_str(s,FALSE,FALSE);
6481 SvREFCNT_dec(PL_lex_stuff);
6482 PL_lex_stuff = Nullsv;
6484 Perl_croak(aTHX_ "Transliteration replacement not terminated");
6487 complement = del = squash = 0;
6488 while (strchr("cds", *s)) {
6490 complement = OPpTRANS_COMPLEMENT;
6492 del = OPpTRANS_DELETE;
6494 squash = OPpTRANS_SQUASH;
6498 New(803, tbl, complement&&!del?258:256, short);
6499 o = newPVOP(OP_TRANS, 0, (char*)tbl);
6500 o->op_private = del|squash|complement|
6501 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
6502 (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0);
6505 yylval.ival = OP_TRANS;
6510 S_scan_heredoc(pTHX_ register char *s)
6513 I32 op_type = OP_SCALAR;
6520 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
6524 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
6527 for (peek = s; SPACE_OR_TAB(*peek); peek++) ;
6528 if (*peek && strchr("`'\"",*peek)) {
6531 s = delimcpy(d, e, s, PL_bufend, term, &len);
6541 if (!isALNUM_lazy_if(s,UTF))
6542 deprecate_old("bare << to mean <<\"\"");
6543 for (; isALNUM_lazy_if(s,UTF); s++) {
6548 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
6549 Perl_croak(aTHX_ "Delimiter for here document is too long");
6552 len = d - PL_tokenbuf;
6553 #ifndef PERL_STRICT_CR
6554 d = strchr(s, '\r');
6558 while (s < PL_bufend) {
6564 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
6573 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6578 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
6579 herewas = newSVpvn(s,PL_bufend-s);
6581 s--, herewas = newSVpvn(s,d-s);
6582 s += SvCUR(herewas);
6584 tmpstr = NEWSV(87,79);
6585 sv_upgrade(tmpstr, SVt_PVIV);
6590 else if (term == '`') {
6591 op_type = OP_BACKTICK;
6592 SvIVX(tmpstr) = '\\';
6596 PL_multi_start = CopLINE(PL_curcop);
6597 PL_multi_open = PL_multi_close = '<';
6598 term = *PL_tokenbuf;
6599 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
6600 char *bufptr = PL_sublex_info.super_bufptr;
6601 char *bufend = PL_sublex_info.super_bufend;
6602 char *olds = s - SvCUR(herewas);
6603 s = strchr(bufptr, '\n');
6607 while (s < bufend &&
6608 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6610 CopLINE_inc(PL_curcop);
6613 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
6614 missingterm(PL_tokenbuf);
6616 sv_setpvn(herewas,bufptr,d-bufptr+1);
6617 sv_setpvn(tmpstr,d+1,s-d);
6619 sv_catpvn(herewas,s,bufend-s);
6620 (void)strcpy(bufptr,SvPVX(herewas));
6627 while (s < PL_bufend &&
6628 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6630 CopLINE_inc(PL_curcop);
6632 if (s >= PL_bufend) {
6633 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
6634 missingterm(PL_tokenbuf);
6636 sv_setpvn(tmpstr,d+1,s-d);
6638 CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
6640 sv_catpvn(herewas,s,PL_bufend-s);
6641 sv_setsv(PL_linestr,herewas);
6642 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
6643 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6644 PL_last_lop = PL_last_uni = Nullch;
6647 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
6648 while (s >= PL_bufend) { /* multiple line string? */
6650 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6651 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
6652 missingterm(PL_tokenbuf);
6654 CopLINE_inc(PL_curcop);
6655 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6656 PL_last_lop = PL_last_uni = Nullch;
6657 #ifndef PERL_STRICT_CR
6658 if (PL_bufend - PL_linestart >= 2) {
6659 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
6660 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
6662 PL_bufend[-2] = '\n';
6664 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6666 else if (PL_bufend[-1] == '\r')
6667 PL_bufend[-1] = '\n';
6669 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
6670 PL_bufend[-1] = '\n';
6672 if (PERLDB_LINE && PL_curstash != PL_debstash) {
6673 SV *sv = NEWSV(88,0);
6675 sv_upgrade(sv, SVt_PVMG);
6676 sv_setsv(sv,PL_linestr);
6679 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop),sv);
6681 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
6684 sv_catsv(PL_linestr,herewas);
6685 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6689 sv_catsv(tmpstr,PL_linestr);
6694 PL_multi_end = CopLINE(PL_curcop);
6695 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
6696 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
6697 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
6699 SvREFCNT_dec(herewas);
6701 if (UTF && is_utf8_string((U8*)SvPVX(tmpstr), SvCUR(tmpstr)))
6703 else if (PL_encoding)
6704 sv_recode_to_utf8(tmpstr, PL_encoding);
6706 PL_lex_stuff = tmpstr;
6707 yylval.ival = op_type;
6712 takes: current position in input buffer
6713 returns: new position in input buffer
6714 side-effects: yylval and lex_op are set.
6719 <FH> read from filehandle
6720 <pkg::FH> read from package qualified filehandle
6721 <pkg'FH> read from package qualified filehandle
6722 <$fh> read from filehandle in $fh
6728 S_scan_inputsymbol(pTHX_ char *start)
6730 register char *s = start; /* current position in buffer */
6736 d = PL_tokenbuf; /* start of temp holding space */
6737 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
6738 end = strchr(s, '\n');
6741 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
6743 /* die if we didn't have space for the contents of the <>,
6744 or if it didn't end, or if we see a newline
6747 if (len >= sizeof PL_tokenbuf)
6748 Perl_croak(aTHX_ "Excessively long <> operator");
6750 Perl_croak(aTHX_ "Unterminated <> operator");
6755 Remember, only scalar variables are interpreted as filehandles by
6756 this code. Anything more complex (e.g., <$fh{$num}>) will be
6757 treated as a glob() call.
6758 This code makes use of the fact that except for the $ at the front,
6759 a scalar variable and a filehandle look the same.
6761 if (*d == '$' && d[1]) d++;
6763 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
6764 while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
6767 /* If we've tried to read what we allow filehandles to look like, and
6768 there's still text left, then it must be a glob() and not a getline.
6769 Use scan_str to pull out the stuff between the <> and treat it
6770 as nothing more than a string.
6773 if (d - PL_tokenbuf != len) {
6774 yylval.ival = OP_GLOB;
6776 s = scan_str(start,FALSE,FALSE);
6778 Perl_croak(aTHX_ "Glob not terminated");
6782 bool readline_overriden = FALSE;
6783 GV *gv_readline = Nullgv;
6785 /* we're in a filehandle read situation */
6788 /* turn <> into <ARGV> */
6790 (void)strcpy(d,"ARGV");
6792 /* Check whether readline() is overriden */
6793 if (((gv_readline = gv_fetchpv("readline", FALSE, SVt_PVCV))
6794 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
6796 ((gvp = (GV**)hv_fetch(PL_globalstash, "readline", 8, FALSE))
6797 && (gv_readline = *gvp) != (GV*)&PL_sv_undef
6798 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
6799 readline_overriden = TRUE;
6801 /* if <$fh>, create the ops to turn the variable into a
6807 /* try to find it in the pad for this block, otherwise find
6808 add symbol table ops
6810 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
6811 if (PAD_COMPNAME_FLAGS(tmp) & SVpad_OUR) {
6812 SV *sym = sv_2mortal(
6813 newSVpv(HvNAME(PAD_COMPNAME_OURSTASH(tmp)),0));
6814 sv_catpvn(sym, "::", 2);
6820 OP *o = newOP(OP_PADSV, 0);
6822 PL_lex_op = readline_overriden
6823 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
6824 append_elem(OP_LIST, o,
6825 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
6826 : (OP*)newUNOP(OP_READLINE, 0, o);
6835 ? (GV_ADDMULTI | GV_ADDINEVAL)
6838 PL_lex_op = readline_overriden
6839 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
6840 append_elem(OP_LIST,
6841 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
6842 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
6843 : (OP*)newUNOP(OP_READLINE, 0,
6844 newUNOP(OP_RV2SV, 0,
6845 newGVOP(OP_GV, 0, gv)));
6847 if (!readline_overriden)
6848 PL_lex_op->op_flags |= OPf_SPECIAL;
6849 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
6850 yylval.ival = OP_NULL;
6853 /* If it's none of the above, it must be a literal filehandle
6854 (<Foo::BAR> or <FOO>) so build a simple readline OP */
6856 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
6857 PL_lex_op = readline_overriden
6858 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
6859 append_elem(OP_LIST,
6860 newGVOP(OP_GV, 0, gv),
6861 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
6862 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
6863 yylval.ival = OP_NULL;
6872 takes: start position in buffer
6873 keep_quoted preserve \ on the embedded delimiter(s)
6874 keep_delims preserve the delimiters around the string
6875 returns: position to continue reading from buffer
6876 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
6877 updates the read buffer.
6879 This subroutine pulls a string out of the input. It is called for:
6880 q single quotes q(literal text)
6881 ' single quotes 'literal text'
6882 qq double quotes qq(interpolate $here please)
6883 " double quotes "interpolate $here please"
6884 qx backticks qx(/bin/ls -l)
6885 ` backticks `/bin/ls -l`
6886 qw quote words @EXPORT_OK = qw( func() $spam )
6887 m// regexp match m/this/
6888 s/// regexp substitute s/this/that/
6889 tr/// string transliterate tr/this/that/
6890 y/// string transliterate y/this/that/
6891 ($*@) sub prototypes sub foo ($)
6892 (stuff) sub attr parameters sub foo : attr(stuff)
6893 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
6895 In most of these cases (all but <>, patterns and transliterate)
6896 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
6897 calls scan_str(). s/// makes yylex() call scan_subst() which calls
6898 scan_str(). tr/// and y/// make yylex() call scan_trans() which
6901 It skips whitespace before the string starts, and treats the first
6902 character as the delimiter. If the delimiter is one of ([{< then
6903 the corresponding "close" character )]}> is used as the closing
6904 delimiter. It allows quoting of delimiters, and if the string has
6905 balanced delimiters ([{<>}]) it allows nesting.
6907 On success, the SV with the resulting string is put into lex_stuff or,
6908 if that is already non-NULL, into lex_repl. The second case occurs only
6909 when parsing the RHS of the special constructs s/// and tr/// (y///).
6910 For convenience, the terminating delimiter character is stuffed into
6915 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
6917 SV *sv; /* scalar value: string */
6918 char *tmps; /* temp string, used for delimiter matching */
6919 register char *s = start; /* current position in the buffer */
6920 register char term; /* terminating character */
6921 register char *to; /* current position in the sv's data */
6922 I32 brackets = 1; /* bracket nesting level */
6923 bool has_utf8 = FALSE; /* is there any utf8 content? */
6924 I32 termcode; /* terminating char. code */
6925 U8 termstr[UTF8_MAXLEN]; /* terminating string */
6926 STRLEN termlen; /* length of terminating string */
6927 char *last = NULL; /* last position for nesting bracket */
6929 /* skip space before the delimiter */
6933 /* mark where we are, in case we need to report errors */
6936 /* after skipping whitespace, the next character is the terminator */
6939 termcode = termstr[0] = term;
6943 termcode = utf8_to_uvchr((U8*)s, &termlen);
6944 Copy(s, termstr, termlen, U8);
6945 if (!UTF8_IS_INVARIANT(term))
6949 /* mark where we are */
6950 PL_multi_start = CopLINE(PL_curcop);
6951 PL_multi_open = term;
6953 /* find corresponding closing delimiter */
6954 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
6955 termcode = termstr[0] = term = tmps[5];
6957 PL_multi_close = term;
6959 /* create a new SV to hold the contents. 87 is leak category, I'm
6960 assuming. 79 is the SV's initial length. What a random number. */
6962 sv_upgrade(sv, SVt_PVIV);
6963 SvIVX(sv) = termcode;
6964 (void)SvPOK_only(sv); /* validate pointer */
6966 /* move past delimiter and try to read a complete string */
6968 sv_catpvn(sv, s, termlen);
6971 if (PL_encoding && !UTF) {
6975 int offset = s - SvPVX(PL_linestr);
6976 bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
6977 &offset, (char*)termstr, termlen);
6978 char *ns = SvPVX(PL_linestr) + offset;
6979 char *svlast = SvEND(sv) - 1;
6981 for (; s < ns; s++) {
6982 if (*s == '\n' && !PL_rsfp)
6983 CopLINE_inc(PL_curcop);
6986 goto read_more_line;
6988 /* handle quoted delimiters */
6989 if (*(svlast-1) == '\\') {
6991 for (t = svlast-2; t >= SvPVX(sv) && *t == '\\';)
6993 if ((svlast-1 - t) % 2) {
6997 SvCUR_set(sv, SvCUR(sv) - 1);
7002 if (PL_multi_open == PL_multi_close) {
7009 for (w = t = last; t < svlast; w++, t++) {
7010 /* At here, all closes are "was quoted" one,
7011 so we don't check PL_multi_close. */
7013 if (!keep_quoted && *(t+1) == PL_multi_open)
7018 else if (*t == PL_multi_open)
7026 SvCUR_set(sv, w - SvPVX(sv));
7029 if (--brackets <= 0)
7035 SvCUR_set(sv, SvCUR(sv) - 1);
7041 /* extend sv if need be */
7042 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
7043 /* set 'to' to the next character in the sv's string */
7044 to = SvPVX(sv)+SvCUR(sv);
7046 /* if open delimiter is the close delimiter read unbridle */
7047 if (PL_multi_open == PL_multi_close) {
7048 for (; s < PL_bufend; s++,to++) {
7049 /* embedded newlines increment the current line number */
7050 if (*s == '\n' && !PL_rsfp)
7051 CopLINE_inc(PL_curcop);
7052 /* handle quoted delimiters */
7053 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
7054 if (!keep_quoted && s[1] == term)
7056 /* any other quotes are simply copied straight through */
7060 /* terminate when run out of buffer (the for() condition), or
7061 have found the terminator */
7062 else if (*s == term) {
7065 if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
7068 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
7074 /* if the terminator isn't the same as the start character (e.g.,
7075 matched brackets), we have to allow more in the quoting, and
7076 be prepared for nested brackets.
7079 /* read until we run out of string, or we find the terminator */
7080 for (; s < PL_bufend; s++,to++) {
7081 /* embedded newlines increment the line count */
7082 if (*s == '\n' && !PL_rsfp)
7083 CopLINE_inc(PL_curcop);
7084 /* backslashes can escape the open or closing characters */
7085 if (*s == '\\' && s+1 < PL_bufend) {
7087 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
7092 /* allow nested opens and closes */
7093 else if (*s == PL_multi_close && --brackets <= 0)
7095 else if (*s == PL_multi_open)
7097 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
7102 /* terminate the copied string and update the sv's end-of-string */
7104 SvCUR_set(sv, to - SvPVX(sv));
7107 * this next chunk reads more into the buffer if we're not done yet
7111 break; /* handle case where we are done yet :-) */
7113 #ifndef PERL_STRICT_CR
7114 if (to - SvPVX(sv) >= 2) {
7115 if ((to[-2] == '\r' && to[-1] == '\n') ||
7116 (to[-2] == '\n' && to[-1] == '\r'))
7120 SvCUR_set(sv, to - SvPVX(sv));
7122 else if (to[-1] == '\r')
7125 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
7130 /* if we're out of file, or a read fails, bail and reset the current
7131 line marker so we can report where the unterminated string began
7134 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
7136 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
7139 /* we read a line, so increment our line counter */
7140 CopLINE_inc(PL_curcop);
7142 /* update debugger info */
7143 if (PERLDB_LINE && PL_curstash != PL_debstash) {
7144 SV *sv = NEWSV(88,0);
7146 sv_upgrade(sv, SVt_PVMG);
7147 sv_setsv(sv,PL_linestr);
7150 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop), sv);
7153 /* having changed the buffer, we must update PL_bufend */
7154 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7155 PL_last_lop = PL_last_uni = Nullch;
7158 /* at this point, we have successfully read the delimited string */
7160 if (!PL_encoding || UTF) {
7162 sv_catpvn(sv, s, termlen);
7165 if (has_utf8 || PL_encoding)
7168 PL_multi_end = CopLINE(PL_curcop);
7170 /* if we allocated too much space, give some back */
7171 if (SvCUR(sv) + 5 < SvLEN(sv)) {
7172 SvLEN_set(sv, SvCUR(sv) + 1);
7173 Renew(SvPVX(sv), SvLEN(sv), char);
7176 /* decide whether this is the first or second quoted string we've read
7189 takes: pointer to position in buffer
7190 returns: pointer to new position in buffer
7191 side-effects: builds ops for the constant in yylval.op
7193 Read a number in any of the formats that Perl accepts:
7195 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
7196 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
7199 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
7201 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
7204 If it reads a number without a decimal point or an exponent, it will
7205 try converting the number to an integer and see if it can do so
7206 without loss of precision.
7210 Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp)
7212 register char *s = start; /* current position in buffer */
7213 register char *d; /* destination in temp buffer */
7214 register char *e; /* end of temp buffer */
7215 NV nv; /* number read, as a double */
7216 SV *sv = Nullsv; /* place to put the converted number */
7217 bool floatit; /* boolean: int or float? */
7218 char *lastub = 0; /* position of last underbar */
7219 static char number_too_long[] = "Number too long";
7221 /* We use the first character to decide what type of number this is */
7225 Perl_croak(aTHX_ "panic: scan_num");
7227 /* if it starts with a 0, it could be an octal number, a decimal in
7228 0.13 disguise, or a hexadecimal number, or a binary number. */
7232 u holds the "number so far"
7233 shift the power of 2 of the base
7234 (hex == 4, octal == 3, binary == 1)
7235 overflowed was the number more than we can hold?
7237 Shift is used when we add a digit. It also serves as an "are
7238 we in octal/hex/binary?" indicator to disallow hex characters
7244 bool overflowed = FALSE;
7245 static NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
7246 static char* bases[5] = { "", "binary", "", "octal",
7248 static char* Bases[5] = { "", "Binary", "", "Octal",
7250 static char *maxima[5] = { "",
7251 "0b11111111111111111111111111111111",
7255 char *base, *Base, *max;
7261 } else if (s[1] == 'b') {
7265 /* check for a decimal in disguise */
7266 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
7268 /* so it must be octal */
7275 if (ckWARN(WARN_SYNTAX))
7276 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7277 "Misplaced _ in number");
7281 base = bases[shift];
7282 Base = Bases[shift];
7283 max = maxima[shift];
7285 /* read the rest of the number */
7287 /* x is used in the overflow test,
7288 b is the digit we're adding on. */
7293 /* if we don't mention it, we're done */
7297 /* _ are ignored -- but warned about if consecutive */
7299 if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
7300 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7301 "Misplaced _ in number");
7305 /* 8 and 9 are not octal */
7308 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
7312 case '2': case '3': case '4':
7313 case '5': case '6': case '7':
7315 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
7319 b = *s++ & 15; /* ASCII digit -> value of digit */
7323 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
7324 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
7325 /* make sure they said 0x */
7330 /* Prepare to put the digit we have onto the end
7331 of the number so far. We check for overflows.
7336 x = u << shift; /* make room for the digit */
7338 if ((x >> shift) != u
7339 && !(PL_hints & HINT_NEW_BINARY)) {
7342 if (ckWARN_d(WARN_OVERFLOW))
7343 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
7344 "Integer overflow in %s number",
7347 u = x | b; /* add the digit to the end */
7350 n *= nvshift[shift];
7351 /* If an NV has not enough bits in its
7352 * mantissa to represent an UV this summing of
7353 * small low-order numbers is a waste of time
7354 * (because the NV cannot preserve the
7355 * low-order bits anyway): we could just
7356 * remember when did we overflow and in the
7357 * end just multiply n by the right
7365 /* if we get here, we had success: make a scalar value from
7370 /* final misplaced underbar check */
7372 if (ckWARN(WARN_SYNTAX))
7373 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
7378 if (ckWARN(WARN_PORTABLE) && n > 4294967295.0)
7379 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
7380 "%s number > %s non-portable",
7386 if (ckWARN(WARN_PORTABLE) && u > 0xffffffff)
7387 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
7388 "%s number > %s non-portable",
7393 if (PL_hints & HINT_NEW_BINARY)
7394 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
7399 handle decimal numbers.
7400 we're also sent here when we read a 0 as the first digit
7402 case '1': case '2': case '3': case '4': case '5':
7403 case '6': case '7': case '8': case '9': case '.':
7406 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
7409 /* read next group of digits and _ and copy into d */
7410 while (isDIGIT(*s) || *s == '_') {
7411 /* skip underscores, checking for misplaced ones
7415 if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
7416 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7417 "Misplaced _ in number");
7421 /* check for end of fixed-length buffer */
7423 Perl_croak(aTHX_ number_too_long);
7424 /* if we're ok, copy the character */
7429 /* final misplaced underbar check */
7430 if (lastub && s == lastub + 1) {
7431 if (ckWARN(WARN_SYNTAX))
7432 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
7435 /* read a decimal portion if there is one. avoid
7436 3..5 being interpreted as the number 3. followed
7439 if (*s == '.' && s[1] != '.') {
7444 if (ckWARN(WARN_SYNTAX))
7445 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7446 "Misplaced _ in number");
7450 /* copy, ignoring underbars, until we run out of digits.
7452 for (; isDIGIT(*s) || *s == '_'; s++) {
7453 /* fixed length buffer check */
7455 Perl_croak(aTHX_ number_too_long);
7457 if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
7458 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7459 "Misplaced _ in number");
7465 /* fractional part ending in underbar? */
7467 if (ckWARN(WARN_SYNTAX))
7468 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7469 "Misplaced _ in number");
7471 if (*s == '.' && isDIGIT(s[1])) {
7472 /* oops, it's really a v-string, but without the "v" */
7478 /* read exponent part, if present */
7479 if (*s && strchr("eE",*s) && strchr("+-0123456789_", s[1])) {
7483 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
7484 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
7486 /* stray preinitial _ */
7488 if (ckWARN(WARN_SYNTAX))
7489 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7490 "Misplaced _ in number");
7494 /* allow positive or negative exponent */
7495 if (*s == '+' || *s == '-')
7498 /* stray initial _ */
7500 if (ckWARN(WARN_SYNTAX))
7501 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7502 "Misplaced _ in number");
7506 /* read digits of exponent */
7507 while (isDIGIT(*s) || *s == '_') {
7510 Perl_croak(aTHX_ number_too_long);
7514 if (ckWARN(WARN_SYNTAX) &&
7515 ((lastub && s == lastub + 1) ||
7516 (!isDIGIT(s[1]) && s[1] != '_')))
7517 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7518 "Misplaced _ in number");
7525 /* make an sv from the string */
7529 We try to do an integer conversion first if no characters
7530 indicating "float" have been found.
7535 int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
7537 if (flags == IS_NUMBER_IN_UV) {
7539 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
7542 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
7543 if (uv <= (UV) IV_MIN)
7544 sv_setiv(sv, -(IV)uv);
7551 /* terminate the string */
7553 nv = Atof(PL_tokenbuf);
7557 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
7558 (PL_hints & HINT_NEW_INTEGER) )
7559 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
7560 (floatit ? "float" : "integer"),
7564 /* if it starts with a v, it could be a v-string */
7567 sv = NEWSV(92,5); /* preallocate storage space */
7568 s = scan_vstring(s,sv);
7572 /* make the op for the constant and return */
7575 lvalp->opval = newSVOP(OP_CONST, 0, sv);
7577 lvalp->opval = Nullop;
7583 S_scan_formline(pTHX_ register char *s)
7587 SV *stuff = newSVpvn("",0);
7588 bool needargs = FALSE;
7591 if (*s == '.' || *s == /*{*/'}') {
7593 #ifdef PERL_STRICT_CR
7594 for (t = s+1;SPACE_OR_TAB(*t); t++) ;
7596 for (t = s+1;SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
7598 if (*t == '\n' || t == PL_bufend)
7601 if (PL_in_eval && !PL_rsfp) {
7602 eol = strchr(s,'\n');
7607 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7609 for (t = s; t < eol; t++) {
7610 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
7612 goto enough; /* ~~ must be first line in formline */
7614 if (*t == '@' || *t == '^')
7618 sv_catpvn(stuff, s, eol-s);
7619 #ifndef PERL_STRICT_CR
7620 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
7621 char *end = SvPVX(stuff) + SvCUR(stuff);
7633 s = filter_gets(PL_linestr, PL_rsfp, 0);
7634 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
7635 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
7636 PL_last_lop = PL_last_uni = Nullch;
7639 yyerror("Format not terminated");
7649 PL_lex_state = LEX_NORMAL;
7650 PL_nextval[PL_nexttoke].ival = 0;
7654 PL_lex_state = LEX_FORMLINE;
7656 if (UTF && is_utf8_string((U8*)SvPVX(stuff), SvCUR(stuff)))
7658 else if (PL_encoding)
7659 sv_recode_to_utf8(stuff, PL_encoding);
7661 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
7663 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
7667 SvREFCNT_dec(stuff);
7668 PL_lex_formbrack = 0;
7679 PL_cshlen = strlen(PL_cshname);
7684 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
7686 I32 oldsavestack_ix = PL_savestack_ix;
7687 CV* outsidecv = PL_compcv;
7690 assert(SvTYPE(PL_compcv) == SVt_PVCV);
7692 SAVEI32(PL_subline);
7693 save_item(PL_subname);
7694 SAVESPTR(PL_compcv);
7696 PL_compcv = (CV*)NEWSV(1104,0);
7697 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
7698 CvFLAGS(PL_compcv) |= flags;
7700 PL_subline = CopLINE(PL_curcop);
7701 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
7702 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
7703 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
7705 return oldsavestack_ix;
7709 #pragma segment Perl_yylex
7712 Perl_yywarn(pTHX_ char *s)
7714 PL_in_eval |= EVAL_WARNONLY;
7716 PL_in_eval &= ~EVAL_WARNONLY;
7721 Perl_yyerror(pTHX_ char *s)
7724 char *context = NULL;
7728 if (!yychar || (yychar == ';' && !PL_rsfp))
7730 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
7731 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
7734 The code below is removed for NetWare because it abends/crashes on NetWare
7735 when the script has error such as not having the closing quotes like:
7737 Checking of white spaces is anyway done in NetWare code.
7740 while (isSPACE(*PL_oldoldbufptr))
7743 context = PL_oldoldbufptr;
7744 contlen = PL_bufptr - PL_oldoldbufptr;
7746 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
7747 PL_oldbufptr != PL_bufptr) {
7750 The code below is removed for NetWare because it abends/crashes on NetWare
7751 when the script has error such as not having the closing quotes like:
7753 Checking of white spaces is anyway done in NetWare code.
7756 while (isSPACE(*PL_oldbufptr))
7759 context = PL_oldbufptr;
7760 contlen = PL_bufptr - PL_oldbufptr;
7762 else if (yychar > 255)
7763 where = "next token ???";
7764 #ifdef USE_PURE_BISON
7765 /* GNU Bison sets the value -2 */
7766 else if (yychar == -2) {
7768 else if ((yychar & 127) == 127) {
7770 if (PL_lex_state == LEX_NORMAL ||
7771 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
7772 where = "at end of line";
7773 else if (PL_lex_inpat)
7774 where = "within pattern";
7776 where = "within string";
7779 SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
7781 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
7782 else if (isPRINT_LC(yychar))
7783 Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
7785 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
7786 where = SvPVX(where_sv);
7788 msg = sv_2mortal(newSVpv(s, 0));
7789 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
7790 OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
7792 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
7794 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
7795 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
7796 Perl_sv_catpvf(aTHX_ msg,
7797 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
7798 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
7801 if (PL_in_eval & EVAL_WARNONLY)
7802 Perl_warn(aTHX_ "%"SVf, msg);
7805 if (PL_error_count >= 10) {
7806 if (PL_in_eval && SvCUR(ERRSV))
7807 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
7808 ERRSV, OutCopFILE(PL_curcop));
7810 Perl_croak(aTHX_ "%s has too many errors.\n",
7811 OutCopFILE(PL_curcop));
7814 PL_in_my_stash = Nullhv;
7818 #pragma segment Main
7822 S_swallow_bom(pTHX_ U8 *s)
7825 slen = SvCUR(PL_linestr);
7829 /* UTF-16 little-endian */
7830 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
7831 Perl_croak(aTHX_ "Unsupported script encoding");
7832 #ifndef PERL_NO_UTF16_FILTER
7833 DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-LE script encoding\n"));
7835 if (PL_bufend > (char*)s) {
7839 filter_add(utf16rev_textfilter, NULL);
7840 New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
7841 PL_bufend = (char*)utf16_to_utf8_reversed(s, news,
7842 PL_bufend - (char*)s - 1,
7844 Copy(news, s, newlen, U8);
7845 SvCUR_set(PL_linestr, newlen);
7846 PL_bufend = SvPVX(PL_linestr) + newlen;
7847 news[newlen++] = '\0';
7851 Perl_croak(aTHX_ "Unsupported script encoding");
7856 if (s[1] == 0xFF) { /* UTF-16 big-endian */
7857 #ifndef PERL_NO_UTF16_FILTER
7858 DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding\n"));
7860 if (PL_bufend > (char *)s) {
7864 filter_add(utf16_textfilter, NULL);
7865 New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
7866 PL_bufend = (char*)utf16_to_utf8(s, news,
7867 PL_bufend - (char*)s,
7869 Copy(news, s, newlen, U8);
7870 SvCUR_set(PL_linestr, newlen);
7871 PL_bufend = SvPVX(PL_linestr) + newlen;
7872 news[newlen++] = '\0';
7876 Perl_croak(aTHX_ "Unsupported script encoding");
7881 if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
7882 DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-8 script encoding\n"));
7887 if (slen > 3 && s[1] == 0 && /* UTF-32 big-endian */
7888 s[2] == 0xFE && s[3] == 0xFF)
7890 Perl_croak(aTHX_ "Unsupported script encoding");
7898 * Restore a source filter.
7902 restore_rsfp(pTHX_ void *f)
7904 PerlIO *fp = (PerlIO*)f;
7906 if (PL_rsfp == PerlIO_stdin())
7907 PerlIO_clearerr(PL_rsfp);
7908 else if (PL_rsfp && (PL_rsfp != fp))
7909 PerlIO_close(PL_rsfp);
7913 #ifndef PERL_NO_UTF16_FILTER
7915 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
7917 I32 count = FILTER_READ(idx+1, sv, maxlen);
7922 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
7923 if (!*SvPV_nolen(sv))
7924 /* Game over, but don't feed an odd-length string to utf16_to_utf8 */
7927 tend = utf16_to_utf8((U8*)SvPVX(sv), tmps, SvCUR(sv), &newlen);
7928 sv_usepvn(sv, (char*)tmps, tend - tmps);
7934 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
7936 I32 count = FILTER_READ(idx+1, sv, maxlen);
7941 if (!*SvPV_nolen(sv))
7942 /* Game over, but don't feed an odd-length string to utf16_to_utf8 */
7945 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
7946 tend = utf16_to_utf8_reversed((U8*)SvPVX(sv), tmps, SvCUR(sv), &newlen);
7947 sv_usepvn(sv, (char*)tmps, tend - tmps);