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 parentheses 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;
789 if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
790 SvUTF8_on(((SVOP*)PL_nextval[PL_nexttoke].opval)->op_sv);
798 * Called when the lexer wants $foo *foo &foo etc, but the program
799 * text only contains the "foo" portion. The first argument is a pointer
800 * to the "foo", and the second argument is the type symbol to prefix.
801 * Forces the next token to be a "WORD".
802 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
806 S_force_ident(pTHX_ register char *s, int kind)
809 OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
810 PL_nextval[PL_nexttoke].opval = o;
813 o->op_private = OPpCONST_ENTERED;
814 /* XXX see note in pp_entereval() for why we forgo typo
815 warnings if the symbol must be introduced in an eval.
817 gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
818 kind == '$' ? SVt_PV :
819 kind == '@' ? SVt_PVAV :
820 kind == '%' ? SVt_PVHV :
828 Perl_str_to_version(pTHX_ SV *sv)
833 char *start = SvPVx(sv,len);
834 bool utf = SvUTF8(sv) ? TRUE : FALSE;
835 char *end = start + len;
836 while (start < end) {
840 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
845 retval += ((NV)n)/nshift;
854 * Forces the next token to be a version number.
855 * If the next token appears to be an invalid version number, (e.g. "v2b"),
856 * and if "guessing" is TRUE, then no new token is created (and the caller
857 * must use an alternative parsing method).
861 S_force_version(pTHX_ char *s, int guessing)
863 OP *version = Nullop;
872 while (isDIGIT(*d) || *d == '_' || *d == '.')
874 if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
876 s = scan_num(s, &yylval);
877 version = yylval.opval;
878 ver = cSVOPx(version)->op_sv;
879 if (SvPOK(ver) && !SvNIOK(ver)) {
880 (void)SvUPGRADE(ver, SVt_PVNV);
881 SvNVX(ver) = str_to_version(ver);
882 SvNOK_on(ver); /* hint that it is a version */
889 /* NOTE: The parser sees the package name and the VERSION swapped */
890 PL_nextval[PL_nexttoke].opval = version;
898 * Tokenize a quoted string passed in as an SV. It finds the next
899 * chunk, up to end of string or a backslash. It may make a new
900 * SV containing that chunk (if HINT_NEW_STRING is on). It also
905 S_tokeq(pTHX_ SV *sv)
916 s = SvPV_force(sv, len);
917 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
920 while (s < send && *s != '\\')
925 if ( PL_hints & HINT_NEW_STRING ) {
926 pv = sv_2mortal(newSVpvn(SvPVX(pv), len));
932 if (s + 1 < send && (s[1] == '\\'))
933 s++; /* all that, just for this */
938 SvCUR_set(sv, d - SvPVX(sv));
940 if ( PL_hints & HINT_NEW_STRING )
941 return new_constant(NULL, 0, "q", sv, pv, "q");
946 * Now come three functions related to double-quote context,
947 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
948 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
949 * interact with PL_lex_state, and create fake ( ... ) argument lists
950 * to handle functions and concatenation.
951 * They assume that whoever calls them will be setting up a fake
952 * join call, because each subthing puts a ',' after it. This lets
955 * join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
957 * (I'm not sure whether the spurious commas at the end of lcfirst's
958 * arguments and join's arguments are created or not).
963 * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST).
965 * Pattern matching will set PL_lex_op to the pattern-matching op to
966 * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise).
968 * OP_CONST and OP_READLINE are easy--just make the new op and return.
970 * Everything else becomes a FUNC.
972 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
973 * had an OP_CONST or OP_READLINE). This just sets us up for a
974 * call to S_sublex_push().
980 register I32 op_type = yylval.ival;
982 if (op_type == OP_NULL) {
983 yylval.opval = PL_lex_op;
987 if (op_type == OP_CONST || op_type == OP_READLINE) {
988 SV *sv = tokeq(PL_lex_stuff);
990 if (SvTYPE(sv) == SVt_PVIV) {
991 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
997 nsv = newSVpvn(p, len);
1003 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
1004 PL_lex_stuff = Nullsv;
1005 /* Allow <FH> // "foo" */
1006 if (op_type == OP_READLINE)
1007 PL_expect = XTERMORDORDOR;
1011 PL_sublex_info.super_state = PL_lex_state;
1012 PL_sublex_info.sub_inwhat = op_type;
1013 PL_sublex_info.sub_op = PL_lex_op;
1014 PL_lex_state = LEX_INTERPPUSH;
1018 yylval.opval = PL_lex_op;
1028 * Create a new scope to save the lexing state. The scope will be
1029 * ended in S_sublex_done. Returns a '(', starting the function arguments
1030 * to the uc, lc, etc. found before.
1031 * Sets PL_lex_state to LEX_INTERPCONCAT.
1039 PL_lex_state = PL_sublex_info.super_state;
1040 SAVEI32(PL_lex_dojoin);
1041 SAVEI32(PL_lex_brackets);
1042 SAVEI32(PL_lex_casemods);
1043 SAVEI32(PL_lex_starts);
1044 SAVEI32(PL_lex_state);
1045 SAVEVPTR(PL_lex_inpat);
1046 SAVEI32(PL_lex_inwhat);
1047 SAVECOPLINE(PL_curcop);
1048 SAVEPPTR(PL_bufptr);
1049 SAVEPPTR(PL_bufend);
1050 SAVEPPTR(PL_oldbufptr);
1051 SAVEPPTR(PL_oldoldbufptr);
1052 SAVEPPTR(PL_last_lop);
1053 SAVEPPTR(PL_last_uni);
1054 SAVEPPTR(PL_linestart);
1055 SAVESPTR(PL_linestr);
1056 SAVEGENERICPV(PL_lex_brackstack);
1057 SAVEGENERICPV(PL_lex_casestack);
1059 PL_linestr = PL_lex_stuff;
1060 PL_lex_stuff = Nullsv;
1062 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
1063 = SvPVX(PL_linestr);
1064 PL_bufend += SvCUR(PL_linestr);
1065 PL_last_lop = PL_last_uni = Nullch;
1066 SAVEFREESV(PL_linestr);
1068 PL_lex_dojoin = FALSE;
1069 PL_lex_brackets = 0;
1070 New(899, PL_lex_brackstack, 120, char);
1071 New(899, PL_lex_casestack, 12, char);
1072 PL_lex_casemods = 0;
1073 *PL_lex_casestack = '\0';
1075 PL_lex_state = LEX_INTERPCONCAT;
1076 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
1078 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1079 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1080 PL_lex_inpat = PL_sublex_info.sub_op;
1082 PL_lex_inpat = Nullop;
1089 * Restores lexer state after a S_sublex_push.
1095 if (!PL_lex_starts++) {
1096 SV *sv = newSVpvn("",0);
1097 if (SvUTF8(PL_linestr))
1099 PL_expect = XOPERATOR;
1100 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1104 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
1105 PL_lex_state = LEX_INTERPCASEMOD;
1109 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1110 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1111 PL_linestr = PL_lex_repl;
1113 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1114 PL_bufend += SvCUR(PL_linestr);
1115 PL_last_lop = PL_last_uni = Nullch;
1116 SAVEFREESV(PL_linestr);
1117 PL_lex_dojoin = FALSE;
1118 PL_lex_brackets = 0;
1119 PL_lex_casemods = 0;
1120 *PL_lex_casestack = '\0';
1122 if (SvEVALED(PL_lex_repl)) {
1123 PL_lex_state = LEX_INTERPNORMAL;
1125 /* we don't clear PL_lex_repl here, so that we can check later
1126 whether this is an evalled subst; that means we rely on the
1127 logic to ensure sublex_done() is called again only via the
1128 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1131 PL_lex_state = LEX_INTERPCONCAT;
1132 PL_lex_repl = Nullsv;
1138 PL_bufend = SvPVX(PL_linestr);
1139 PL_bufend += SvCUR(PL_linestr);
1140 PL_expect = XOPERATOR;
1141 PL_sublex_info.sub_inwhat = 0;
1149 Extracts a pattern, double-quoted string, or transliteration. This
1152 It looks at lex_inwhat and PL_lex_inpat to find out whether it's
1153 processing a pattern (PL_lex_inpat is true), a transliteration
1154 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
1156 Returns a pointer to the character scanned up to. Iff this is
1157 advanced from the start pointer supplied (ie if anything was
1158 successfully parsed), will leave an OP for the substring scanned
1159 in yylval. Caller must intuit reason for not parsing further
1160 by looking at the next characters herself.
1164 double-quoted style: \r and \n
1165 regexp special ones: \D \s
1167 backrefs: \1 (deprecated in substitution replacements)
1168 case and quoting: \U \Q \E
1169 stops on @ and $, but not for $ as tail anchor
1171 In transliterations:
1172 characters are VERY literal, except for - not at the start or end
1173 of the string, which indicates a range. scan_const expands the
1174 range to the full set of intermediate characters.
1176 In double-quoted strings:
1178 double-quoted style: \r and \n
1180 backrefs: \1 (deprecated)
1181 case and quoting: \U \Q \E
1184 scan_const does *not* construct ops to handle interpolated strings.
1185 It stops processing as soon as it finds an embedded $ or @ variable
1186 and leaves it to the caller to work out what's going on.
1188 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @::foo.
1190 $ in pattern could be $foo or could be tail anchor. Assumption:
1191 it's a tail anchor if $ is the last thing in the string, or if it's
1192 followed by one of ")| \n\t"
1194 \1 (backreferences) are turned into $1
1196 The structure of the code is
1197 while (there's a character to process) {
1198 handle transliteration ranges
1199 skip regexp comments
1200 skip # initiated comments in //x patterns
1201 check for embedded @foo
1202 check for embedded scalars
1204 leave intact backslashes from leave (below)
1205 deprecate \1 in strings and sub replacements
1206 handle string-changing backslashes \l \U \Q \E, etc.
1207 switch (what was escaped) {
1208 handle - in a transliteration (becomes a literal -)
1209 handle \132 octal characters
1210 handle 0x15 hex characters
1211 handle \cV (control V)
1212 handle printf backslashes (\f, \r, \n, etc)
1214 } (end if backslash)
1215 } (end while character to read)
1220 S_scan_const(pTHX_ char *start)
1222 register char *send = PL_bufend; /* end of the constant */
1223 SV *sv = NEWSV(93, send - start); /* sv for the constant */
1224 register char *s = start; /* start of the constant */
1225 register char *d = SvPVX(sv); /* destination for copies */
1226 bool dorange = FALSE; /* are we in a translit range? */
1227 bool didrange = FALSE; /* did we just finish a range? */
1228 I32 has_utf8 = FALSE; /* Output constant is UTF8 */
1229 I32 this_utf8 = UTF; /* The source string is assumed to be UTF8 */
1232 const char *leaveit = /* set of acceptably-backslashed characters */
1234 ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
1237 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1238 /* If we are doing a trans and we know we want UTF8 set expectation */
1239 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
1240 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1244 while (s < send || dorange) {
1245 /* get transliterations out of the way (they're most literal) */
1246 if (PL_lex_inwhat == OP_TRANS) {
1247 /* expand a range A-Z to the full set of characters. AIE! */
1249 I32 i; /* current expanded character */
1250 I32 min; /* first character in range */
1251 I32 max; /* last character in range */
1254 char *c = (char*)utf8_hop((U8*)d, -1);
1258 *c = (char)UTF_TO_NATIVE(0xff);
1259 /* mark the range as done, and continue */
1265 i = d - SvPVX(sv); /* remember current offset */
1266 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
1267 d = SvPVX(sv) + i; /* refresh d after realloc */
1268 d -= 2; /* eat the first char and the - */
1270 min = (U8)*d; /* first char in range */
1271 max = (U8)d[1]; /* last char in range */
1275 "Invalid range \"%c-%c\" in transliteration operator",
1276 (char)min, (char)max);
1280 if ((isLOWER(min) && isLOWER(max)) ||
1281 (isUPPER(min) && isUPPER(max))) {
1283 for (i = min; i <= max; i++)
1285 *d++ = NATIVE_TO_NEED(has_utf8,i);
1287 for (i = min; i <= max; i++)
1289 *d++ = NATIVE_TO_NEED(has_utf8,i);
1294 for (i = min; i <= max; i++)
1297 /* mark the range as done, and continue */
1303 /* range begins (ignore - as first or last char) */
1304 else if (*s == '-' && s+1 < send && s != start) {
1306 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
1309 *d++ = (char)UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */
1321 /* if we get here, we're not doing a transliteration */
1323 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
1324 except for the last char, which will be done separately. */
1325 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
1327 while (s+1 < send && *s != ')')
1328 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1330 else if (s[2] == '{' /* This should match regcomp.c */
1331 || ((s[2] == 'p' || s[2] == '?') && s[3] == '{'))
1334 char *regparse = s + (s[2] == '{' ? 3 : 4);
1337 while (count && (c = *regparse)) {
1338 if (c == '\\' && regparse[1])
1346 if (*regparse != ')')
1347 regparse--; /* Leave one char for continuation. */
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 if (PL_lex_formbrack)
2432 yyerror("Format not terminated");
2434 yyerror("Missing right curly or square bracket");
2436 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2437 "### Tokener got EOF\n");
2441 if (s++ < PL_bufend)
2442 goto retry; /* ignore stray nulls */
2445 if (!PL_in_eval && !PL_preambled) {
2446 PL_preambled = TRUE;
2447 sv_setpv(PL_linestr,incl_perldb());
2448 if (SvCUR(PL_linestr))
2449 sv_catpv(PL_linestr,";");
2451 while(AvFILLp(PL_preambleav) >= 0) {
2452 SV *tmpsv = av_shift(PL_preambleav);
2453 sv_catsv(PL_linestr, tmpsv);
2454 sv_catpv(PL_linestr, ";");
2457 sv_free((SV*)PL_preambleav);
2458 PL_preambleav = NULL;
2460 if (PL_minus_n || PL_minus_p) {
2461 sv_catpv(PL_linestr, "LINE: while (<>) {");
2463 sv_catpv(PL_linestr,"chomp;");
2466 if (strchr("/'\"", *PL_splitstr)
2467 && strchr(PL_splitstr + 1, *PL_splitstr))
2468 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
2471 s = "'~#\200\1'"; /* surely one char is unused...*/
2472 while (s[1] && strchr(PL_splitstr, *s)) s++;
2474 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s%c",
2475 "q" + (delim == '\''), delim);
2476 for (s = PL_splitstr; *s; s++) {
2478 sv_catpvn(PL_linestr, "\\", 1);
2479 sv_catpvn(PL_linestr, s, 1);
2481 Perl_sv_catpvf(aTHX_ PL_linestr, "%c);", delim);
2485 sv_catpv(PL_linestr,"our @F=split(' ');");
2488 sv_catpv(PL_linestr, "\n");
2489 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2490 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2491 PL_last_lop = PL_last_uni = Nullch;
2492 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2493 SV *sv = NEWSV(85,0);
2495 sv_upgrade(sv, SVt_PVMG);
2496 sv_setsv(sv,PL_linestr);
2499 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2504 bof = PL_rsfp ? TRUE : FALSE;
2505 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
2508 if (PL_preprocess && !PL_in_eval)
2509 (void)PerlProc_pclose(PL_rsfp);
2510 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2511 PerlIO_clearerr(PL_rsfp);
2513 (void)PerlIO_close(PL_rsfp);
2515 PL_doextract = FALSE;
2517 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2518 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
2519 sv_catpv(PL_linestr,";}");
2520 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2521 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2522 PL_last_lop = PL_last_uni = Nullch;
2523 PL_minus_n = PL_minus_p = 0;
2526 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2527 PL_last_lop = PL_last_uni = Nullch;
2528 sv_setpv(PL_linestr,"");
2529 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
2531 /* if it looks like the start of a BOM, check if it in fact is */
2532 else if (bof && (!*s || *(U8*)s == 0xEF || *(U8*)s >= 0xFE)) {
2533 #ifdef PERLIO_IS_STDIO
2534 # ifdef __GNU_LIBRARY__
2535 # if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
2536 # define FTELL_FOR_PIPE_IS_BROKEN
2540 # if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
2541 # define FTELL_FOR_PIPE_IS_BROKEN
2546 #ifdef FTELL_FOR_PIPE_IS_BROKEN
2547 /* This loses the possibility to detect the bof
2548 * situation on perl -P when the libc5 is being used.
2549 * Workaround? Maybe attach some extra state to PL_rsfp?
2552 bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
2554 bof = PerlIO_tell(PL_rsfp) == (Off_t)SvCUR(PL_linestr);
2557 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2558 s = swallow_bom((U8*)s);
2562 /* Incest with pod. */
2563 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2564 sv_setpv(PL_linestr, "");
2565 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2566 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2567 PL_last_lop = PL_last_uni = Nullch;
2568 PL_doextract = FALSE;
2572 } while (PL_doextract);
2573 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2574 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2575 SV *sv = NEWSV(85,0);
2577 sv_upgrade(sv, SVt_PVMG);
2578 sv_setsv(sv,PL_linestr);
2581 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2583 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2584 PL_last_lop = PL_last_uni = Nullch;
2585 if (CopLINE(PL_curcop) == 1) {
2586 while (s < PL_bufend && isSPACE(*s))
2588 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2592 if (*s == '#' && *(s+1) == '!')
2594 #ifdef ALTERNATE_SHEBANG
2596 static char as[] = ALTERNATE_SHEBANG;
2597 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2598 d = s + (sizeof(as) - 1);
2600 #endif /* ALTERNATE_SHEBANG */
2609 while (*d && !isSPACE(*d))
2613 #ifdef ARG_ZERO_IS_SCRIPT
2614 if (ipathend > ipath) {
2616 * HP-UX (at least) sets argv[0] to the script name,
2617 * which makes $^X incorrect. And Digital UNIX and Linux,
2618 * at least, set argv[0] to the basename of the Perl
2619 * interpreter. So, having found "#!", we'll set it right.
2621 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV)); /* $^X */
2622 assert(SvPOK(x) || SvGMAGICAL(x));
2623 if (sv_eq(x, CopFILESV(PL_curcop))) {
2624 sv_setpvn(x, ipath, ipathend - ipath);
2630 char *bstart = SvPV(CopFILESV(PL_curcop),blen);
2631 char *lstart = SvPV(x,llen);
2633 bstart += blen - llen;
2634 if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
2635 sv_setpvn(x, ipath, ipathend - ipath);
2640 TAINT_NOT; /* $^X is always tainted, but that's OK */
2642 #endif /* ARG_ZERO_IS_SCRIPT */
2647 d = instr(s,"perl -");
2649 d = instr(s,"perl");
2651 /* avoid getting into infinite loops when shebang
2652 * line contains "Perl" rather than "perl" */
2654 for (d = ipathend-4; d >= ipath; --d) {
2655 if ((*d == 'p' || *d == 'P')
2656 && !ibcmp(d, "perl", 4))
2666 #ifdef ALTERNATE_SHEBANG
2668 * If the ALTERNATE_SHEBANG on this system starts with a
2669 * character that can be part of a Perl expression, then if
2670 * we see it but not "perl", we're probably looking at the
2671 * start of Perl code, not a request to hand off to some
2672 * other interpreter. Similarly, if "perl" is there, but
2673 * not in the first 'word' of the line, we assume the line
2674 * contains the start of the Perl program.
2676 if (d && *s != '#') {
2678 while (*c && !strchr("; \t\r\n\f\v#", *c))
2681 d = Nullch; /* "perl" not in first word; ignore */
2683 *s = '#'; /* Don't try to parse shebang line */
2685 #endif /* ALTERNATE_SHEBANG */
2686 #ifndef MACOS_TRADITIONAL
2691 !instr(s,"indir") &&
2692 instr(PL_origargv[0],"perl"))
2698 while (s < PL_bufend && isSPACE(*s))
2700 if (s < PL_bufend) {
2701 Newz(899,newargv,PL_origargc+3,char*);
2703 while (s < PL_bufend && !isSPACE(*s))
2706 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2709 newargv = PL_origargv;
2712 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
2714 Perl_croak(aTHX_ "Can't exec %s", ipath);
2718 U32 oldpdb = PL_perldb;
2719 bool oldn = PL_minus_n;
2720 bool oldp = PL_minus_p;
2722 while (*d && !isSPACE(*d)) d++;
2723 while (SPACE_OR_TAB(*d)) d++;
2726 bool switches_done = PL_doswitches;
2728 if (*d == 'M' || *d == 'm') {
2730 while (*d && !isSPACE(*d)) d++;
2731 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2734 d = moreswitches(d);
2736 if (PL_doswitches && !switches_done) {
2737 int argc = PL_origargc;
2738 char **argv = PL_origargv;
2741 } while (argc && argv[0][0] == '-' && argv[0][1]);
2742 init_argv_symbols(argc,argv);
2744 if ((PERLDB_LINE && !oldpdb) ||
2745 ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
2746 /* if we have already added "LINE: while (<>) {",
2747 we must not do it again */
2749 sv_setpv(PL_linestr, "");
2750 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2751 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2752 PL_last_lop = PL_last_uni = Nullch;
2753 PL_preambled = FALSE;
2755 (void)gv_fetchfile(PL_origfilename);
2758 if (PL_doswitches && !switches_done) {
2759 int argc = PL_origargc;
2760 char **argv = PL_origargv;
2763 } while (argc && argv[0][0] == '-' && argv[0][1]);
2764 init_argv_symbols(argc,argv);
2770 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2772 PL_lex_state = LEX_FORMLINE;
2777 #ifdef PERL_STRICT_CR
2778 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2780 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
2782 case ' ': case '\t': case '\f': case 013:
2783 #ifdef MACOS_TRADITIONAL
2790 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2791 if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
2792 /* handle eval qq[#line 1 "foo"\n ...] */
2793 CopLINE_dec(PL_curcop);
2797 while (s < d && *s != '\n')
2801 else if (s > d) /* Found by Ilya: feed random input to Perl. */
2802 Perl_croak(aTHX_ "panic: input overflow");
2804 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2806 PL_lex_state = LEX_FORMLINE;
2816 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2823 while (s < PL_bufend && SPACE_OR_TAB(*s))
2826 if (strnEQ(s,"=>",2)) {
2827 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2828 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2829 "### Saw unary minus before =>, forcing word '%s'\n", s);
2831 OPERATOR('-'); /* unary minus */
2833 PL_last_uni = PL_oldbufptr;
2835 case 'r': ftst = OP_FTEREAD; break;
2836 case 'w': ftst = OP_FTEWRITE; break;
2837 case 'x': ftst = OP_FTEEXEC; break;
2838 case 'o': ftst = OP_FTEOWNED; break;
2839 case 'R': ftst = OP_FTRREAD; break;
2840 case 'W': ftst = OP_FTRWRITE; break;
2841 case 'X': ftst = OP_FTREXEC; break;
2842 case 'O': ftst = OP_FTROWNED; break;
2843 case 'e': ftst = OP_FTIS; break;
2844 case 'z': ftst = OP_FTZERO; break;
2845 case 's': ftst = OP_FTSIZE; break;
2846 case 'f': ftst = OP_FTFILE; break;
2847 case 'd': ftst = OP_FTDIR; break;
2848 case 'l': ftst = OP_FTLINK; break;
2849 case 'p': ftst = OP_FTPIPE; break;
2850 case 'S': ftst = OP_FTSOCK; break;
2851 case 'u': ftst = OP_FTSUID; break;
2852 case 'g': ftst = OP_FTSGID; break;
2853 case 'k': ftst = OP_FTSVTX; break;
2854 case 'b': ftst = OP_FTBLK; break;
2855 case 'c': ftst = OP_FTCHR; break;
2856 case 't': ftst = OP_FTTTY; break;
2857 case 'T': ftst = OP_FTTEXT; break;
2858 case 'B': ftst = OP_FTBINARY; break;
2859 case 'M': case 'A': case 'C':
2860 gv_fetchpv("\024",TRUE, SVt_PV);
2862 case 'M': ftst = OP_FTMTIME; break;
2863 case 'A': ftst = OP_FTATIME; break;
2864 case 'C': ftst = OP_FTCTIME; break;
2872 PL_last_lop_op = (OPCODE)ftst;
2873 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2874 "### Saw file test %c\n", (int)ftst);
2879 /* Assume it was a minus followed by a one-letter named
2880 * subroutine call (or a -bareword), then. */
2881 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2882 "### '-%c' looked like a file test but was not\n",
2891 if (PL_expect == XOPERATOR)
2896 else if (*s == '>') {
2899 if (isIDFIRST_lazy_if(s,UTF)) {
2900 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2908 if (PL_expect == XOPERATOR)
2911 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2913 OPERATOR('-'); /* unary minus */
2920 if (PL_expect == XOPERATOR)
2925 if (PL_expect == XOPERATOR)
2928 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2934 if (PL_expect != XOPERATOR) {
2935 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2936 PL_expect = XOPERATOR;
2937 force_ident(PL_tokenbuf, '*');
2950 if (PL_expect == XOPERATOR) {
2954 PL_tokenbuf[0] = '%';
2955 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2956 if (!PL_tokenbuf[1]) {
2959 PL_pending_ident = '%';
2978 switch (PL_expect) {
2981 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
2983 PL_bufptr = s; /* update in case we back off */
2989 PL_expect = XTERMBLOCK;
2993 while (isIDFIRST_lazy_if(s,UTF)) {
2994 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2995 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
2996 if (tmp < 0) tmp = -tmp;
3012 d = scan_str(d,TRUE,TRUE);
3014 /* MUST advance bufptr here to avoid bogus
3015 "at end of line" context messages from yyerror().
3017 PL_bufptr = s + len;
3018 yyerror("Unterminated attribute parameter in attribute list");
3021 return 0; /* EOF indicator */
3025 SV *sv = newSVpvn(s, len);
3026 sv_catsv(sv, PL_lex_stuff);
3027 attrs = append_elem(OP_LIST, attrs,
3028 newSVOP(OP_CONST, 0, sv));
3029 SvREFCNT_dec(PL_lex_stuff);
3030 PL_lex_stuff = Nullsv;
3033 /* NOTE: any CV attrs applied here need to be part of
3034 the CVf_BUILTIN_ATTRS define in cv.h! */
3035 if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len))
3036 CvLVALUE_on(PL_compcv);
3037 else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len))
3038 CvLOCKED_on(PL_compcv);
3039 else if (!PL_in_my && len == 6 && strnEQ(s, "method", len))
3040 CvMETHOD_on(PL_compcv);
3041 else if (!PL_in_my && len == 9 && strnEQ(s, "assertion", len))
3042 CvASSERTION_on(PL_compcv);
3043 else if (PL_in_my == KEY_our && len == 6 &&
3044 strnEQ(s, "unique", len))
3046 GvUNIQUE_on(cGVOPx_gv(yylval.opval));
3048 ; /* skip that case to avoid loading attributes.pm */
3050 /* After we've set the flags, it could be argued that
3051 we don't need to do the attributes.pm-based setting
3052 process, and shouldn't bother appending recognized
3053 flags. To experiment with that, uncomment the
3054 following "else". (Note that's already been
3055 uncommented. That keeps the above-applied built-in
3056 attributes from being intercepted (and possibly
3057 rejected) by a package's attribute routines, but is
3058 justified by the performance win for the common case
3059 of applying only built-in attributes.) */
3061 attrs = append_elem(OP_LIST, attrs,
3062 newSVOP(OP_CONST, 0,
3066 if (*s == ':' && s[1] != ':')
3069 break; /* require real whitespace or :'s */
3071 tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
3072 if (*s != ';' && *s != '}' && *s != tmp && (tmp != '=' || *s != ')')) {
3073 char q = ((*s == '\'') ? '"' : '\'');
3074 /* If here for an expression, and parsed no attrs, back off. */
3075 if (tmp == '=' && !attrs) {
3079 /* MUST advance bufptr here to avoid bogus "at end of line"
3080 context messages from yyerror().
3084 yyerror("Unterminated attribute list");
3086 yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list",
3094 PL_nextval[PL_nexttoke].opval = attrs;
3102 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
3103 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
3120 if (PL_lex_brackets <= 0)
3121 yyerror("Unmatched right square bracket");
3124 if (PL_lex_state == LEX_INTERPNORMAL) {
3125 if (PL_lex_brackets == 0) {
3126 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
3127 PL_lex_state = LEX_INTERPEND;
3134 if (PL_lex_brackets > 100) {
3135 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
3137 switch (PL_expect) {
3139 if (PL_lex_formbrack) {
3143 if (PL_oldoldbufptr == PL_last_lop)
3144 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3146 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3147 OPERATOR(HASHBRACK);
3149 while (s < PL_bufend && SPACE_OR_TAB(*s))
3152 PL_tokenbuf[0] = '\0';
3153 if (d < PL_bufend && *d == '-') {
3154 PL_tokenbuf[0] = '-';
3156 while (d < PL_bufend && SPACE_OR_TAB(*d))
3159 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
3160 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
3162 while (d < PL_bufend && SPACE_OR_TAB(*d))
3165 char minus = (PL_tokenbuf[0] == '-');
3166 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
3174 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
3179 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3184 if (PL_oldoldbufptr == PL_last_lop)
3185 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3187 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3190 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
3192 /* This hack is to get the ${} in the message. */
3194 yyerror("syntax error");
3197 OPERATOR(HASHBRACK);
3199 /* This hack serves to disambiguate a pair of curlies
3200 * as being a block or an anon hash. Normally, expectation
3201 * determines that, but in cases where we're not in a
3202 * position to expect anything in particular (like inside
3203 * eval"") we have to resolve the ambiguity. This code
3204 * covers the case where the first term in the curlies is a
3205 * quoted string. Most other cases need to be explicitly
3206 * disambiguated by prepending a `+' before the opening
3207 * curly in order to force resolution as an anon hash.
3209 * XXX should probably propagate the outer expectation
3210 * into eval"" to rely less on this hack, but that could
3211 * potentially break current behavior of eval"".
3215 if (*s == '\'' || *s == '"' || *s == '`') {
3216 /* common case: get past first string, handling escapes */
3217 for (t++; t < PL_bufend && *t != *s;)
3218 if (*t++ == '\\' && (*t == '\\' || *t == *s))
3222 else if (*s == 'q') {
3225 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
3228 /* skip q//-like construct */
3230 char open, close, term;
3233 while (t < PL_bufend && isSPACE(*t))
3235 /* check for q => */
3236 if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
3237 OPERATOR(HASHBRACK);
3241 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
3245 for (t++; t < PL_bufend; t++) {
3246 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
3248 else if (*t == open)
3252 for (t++; t < PL_bufend; t++) {
3253 if (*t == '\\' && t+1 < PL_bufend)
3255 else if (*t == close && --brackets <= 0)
3257 else if (*t == open)
3264 /* skip plain q word */
3265 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3268 else if (isALNUM_lazy_if(t,UTF)) {
3270 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3273 while (t < PL_bufend && isSPACE(*t))
3275 /* if comma follows first term, call it an anon hash */
3276 /* XXX it could be a comma expression with loop modifiers */
3277 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
3278 || (*t == '=' && t[1] == '>')))
3279 OPERATOR(HASHBRACK);
3280 if (PL_expect == XREF)
3283 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
3289 yylval.ival = CopLINE(PL_curcop);
3290 if (isSPACE(*s) || *s == '#')
3291 PL_copline = NOLINE; /* invalidate current command line number */
3296 if (PL_lex_brackets <= 0)
3297 yyerror("Unmatched right curly bracket");
3299 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
3300 if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
3301 PL_lex_formbrack = 0;
3302 if (PL_lex_state == LEX_INTERPNORMAL) {
3303 if (PL_lex_brackets == 0) {
3304 if (PL_expect & XFAKEBRACK) {
3305 PL_expect &= XENUMMASK;
3306 PL_lex_state = LEX_INTERPEND;
3308 return yylex(); /* ignore fake brackets */
3310 if (*s == '-' && s[1] == '>')
3311 PL_lex_state = LEX_INTERPENDMAYBE;
3312 else if (*s != '[' && *s != '{')
3313 PL_lex_state = LEX_INTERPEND;
3316 if (PL_expect & XFAKEBRACK) {
3317 PL_expect &= XENUMMASK;
3319 return yylex(); /* ignore fake brackets */
3329 if (PL_expect == XOPERATOR) {
3330 if (ckWARN(WARN_SEMICOLON)
3331 && isIDFIRST_lazy_if(s,UTF) && PL_bufptr == PL_linestart)
3333 CopLINE_dec(PL_curcop);
3334 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
3335 CopLINE_inc(PL_curcop);
3340 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3342 PL_expect = XOPERATOR;
3343 force_ident(PL_tokenbuf, '&');
3347 yylval.ival = (OPpENTERSUB_AMPER<<8);
3366 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
3367 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Reversed %c= operator",(int)tmp);
3369 if (PL_expect == XSTATE && isALPHA(tmp) &&
3370 (s == PL_linestart+1 || s[-2] == '\n') )
3372 if (PL_in_eval && !PL_rsfp) {
3377 if (strnEQ(s,"=cut",4)) {
3391 PL_doextract = TRUE;
3394 if (PL_lex_brackets < PL_lex_formbrack) {
3396 #ifdef PERL_STRICT_CR
3397 for (t = s; SPACE_OR_TAB(*t); t++) ;
3399 for (t = s; SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
3401 if (*t == '\n' || *t == '#') {
3419 if (PL_expect != XOPERATOR) {
3420 if (s[1] != '<' && !strchr(s,'>'))
3423 s = scan_heredoc(s);
3425 s = scan_inputsymbol(s);
3426 TERM(sublex_start());
3431 SHop(OP_LEFT_SHIFT);
3445 SHop(OP_RIGHT_SHIFT);
3454 if (PL_expect == XOPERATOR) {
3455 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3458 return ','; /* grandfather non-comma-format format */
3462 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
3463 PL_tokenbuf[0] = '@';
3464 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3465 sizeof PL_tokenbuf - 1, FALSE);
3466 if (PL_expect == XOPERATOR)
3467 no_op("Array length", s);
3468 if (!PL_tokenbuf[1])
3470 PL_expect = XOPERATOR;
3471 PL_pending_ident = '#';
3475 PL_tokenbuf[0] = '$';
3476 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3477 sizeof PL_tokenbuf - 1, FALSE);
3478 if (PL_expect == XOPERATOR)
3480 if (!PL_tokenbuf[1]) {
3482 yyerror("Final $ should be \\$ or $name");
3486 /* This kludge not intended to be bulletproof. */
3487 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
3488 yylval.opval = newSVOP(OP_CONST, 0,
3489 newSViv(PL_compiling.cop_arybase));
3490 yylval.opval->op_private = OPpCONST_ARYBASE;
3496 if (PL_lex_state == LEX_NORMAL)
3499 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3502 PL_tokenbuf[0] = '@';
3503 if (ckWARN(WARN_SYNTAX)) {
3505 isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$';
3508 PL_bufptr = skipspace(PL_bufptr);
3509 while (t < PL_bufend && *t != ']')
3511 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3512 "Multidimensional syntax %.*s not supported",
3513 (t - PL_bufptr) + 1, PL_bufptr);
3517 else if (*s == '{') {
3518 PL_tokenbuf[0] = '%';
3519 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
3520 (t = strchr(s, '}')) && (t = strchr(t, '=')))
3522 char tmpbuf[sizeof PL_tokenbuf];
3524 for (t++; isSPACE(*t); t++) ;
3525 if (isIDFIRST_lazy_if(t,UTF)) {
3526 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
3527 for (; isSPACE(*t); t++) ;
3528 if (*t == ';' && get_cv(tmpbuf, FALSE))
3529 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3530 "You need to quote \"%s\"", tmpbuf);
3536 PL_expect = XOPERATOR;
3537 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3538 bool islop = (PL_last_lop == PL_oldoldbufptr);
3539 if (!islop || PL_last_lop_op == OP_GREPSTART)
3540 PL_expect = XOPERATOR;
3541 else if (strchr("$@\"'`q", *s))
3542 PL_expect = XTERM; /* e.g. print $fh "foo" */
3543 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
3544 PL_expect = XTERM; /* e.g. print $fh &sub */
3545 else if (isIDFIRST_lazy_if(s,UTF)) {
3546 char tmpbuf[sizeof PL_tokenbuf];
3547 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3548 if ((tmp = keyword(tmpbuf, len))) {
3549 /* binary operators exclude handle interpretations */
3561 PL_expect = XTERM; /* e.g. print $fh length() */
3566 PL_expect = XTERM; /* e.g. print $fh subr() */
3569 else if (isDIGIT(*s))
3570 PL_expect = XTERM; /* e.g. print $fh 3 */
3571 else if (*s == '.' && isDIGIT(s[1]))
3572 PL_expect = XTERM; /* e.g. print $fh .3 */
3573 else if (strchr("?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
3574 PL_expect = XTERM; /* e.g. print $fh -1 */
3575 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '=' && s[1] != '/')
3576 PL_expect = XTERM; /* e.g. print $fh /.../
3577 XXX except DORDOR operator */
3578 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3579 PL_expect = XTERM; /* print $fh <<"EOF" */
3581 PL_pending_ident = '$';
3585 if (PL_expect == XOPERATOR)
3587 PL_tokenbuf[0] = '@';
3588 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3589 if (!PL_tokenbuf[1]) {
3592 if (PL_lex_state == LEX_NORMAL)
3594 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3596 PL_tokenbuf[0] = '%';
3598 /* Warn about @ where they meant $. */
3599 if (ckWARN(WARN_SYNTAX)) {
3600 if (*s == '[' || *s == '{') {
3602 while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
3604 if (*t == '}' || *t == ']') {
3606 PL_bufptr = skipspace(PL_bufptr);
3607 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3608 "Scalar value %.*s better written as $%.*s",
3609 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
3614 PL_pending_ident = '@';
3617 case '/': /* may be division, defined-or, or pattern */
3618 if (PL_expect == XTERMORDORDOR && s[1] == '/') {
3622 case '?': /* may either be conditional or pattern */
3623 if(PL_expect == XOPERATOR) {
3631 /* A // operator. */
3641 /* Disable warning on "study /blah/" */
3642 if (PL_oldoldbufptr == PL_last_uni
3643 && (*PL_last_uni != 's' || s - PL_last_uni < 5
3644 || memNE(PL_last_uni, "study", 5)
3645 || isALNUM_lazy_if(PL_last_uni+5,UTF)
3648 s = scan_pat(s,OP_MATCH);
3649 TERM(sublex_start());
3653 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3654 #ifdef PERL_STRICT_CR
3657 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3659 && (s == PL_linestart || s[-1] == '\n') )
3661 PL_lex_formbrack = 0;
3665 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
3671 yylval.ival = OPf_SPECIAL;
3677 if (PL_expect != XOPERATOR)
3682 case '0': case '1': case '2': case '3': case '4':
3683 case '5': case '6': case '7': case '8': case '9':
3684 s = scan_num(s, &yylval);
3685 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3686 "### Saw number in '%s'\n", s);
3688 if (PL_expect == XOPERATOR)
3693 s = scan_str(s,FALSE,FALSE);
3694 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3695 "### Saw string before '%s'\n", s);
3697 if (PL_expect == XOPERATOR) {
3698 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3701 return ','; /* grandfather non-comma-format format */
3707 missingterm((char*)0);
3708 yylval.ival = OP_CONST;
3709 TERM(sublex_start());
3712 s = scan_str(s,FALSE,FALSE);
3713 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3714 "### Saw string before '%s'\n", s);
3716 if (PL_expect == XOPERATOR) {
3717 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3720 return ','; /* grandfather non-comma-format format */
3726 missingterm((char*)0);
3727 yylval.ival = OP_CONST;
3728 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
3729 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
3730 yylval.ival = OP_STRINGIFY;
3734 TERM(sublex_start());
3737 s = scan_str(s,FALSE,FALSE);
3738 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3739 "### Saw backtick string before '%s'\n", s);
3741 if (PL_expect == XOPERATOR)
3742 no_op("Backticks",s);
3744 missingterm((char*)0);
3745 yylval.ival = OP_BACKTICK;
3747 TERM(sublex_start());
3751 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
3752 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
3754 if (PL_expect == XOPERATOR)
3755 no_op("Backslash",s);
3759 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
3763 while (isDIGIT(*start) || *start == '_')
3765 if (*start == '.' && isDIGIT(start[1])) {
3766 s = scan_num(s, &yylval);
3769 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
3770 else if (!isALPHA(*start) && (PL_expect == XTERM
3771 || PL_expect == XREF || PL_expect == XSTATE
3772 || PL_expect == XTERMORDORDOR)) {
3776 gv = gv_fetchpv(s, FALSE, SVt_PVCV);
3779 s = scan_num(s, &yylval);
3786 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
3826 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3828 /* Some keywords can be followed by any delimiter, including ':' */
3829 tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
3830 (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
3831 (PL_tokenbuf[0] == 'q' &&
3832 strchr("qwxr", PL_tokenbuf[1])))));
3834 /* x::* is just a word, unless x is "CORE" */
3835 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
3839 while (d < PL_bufend && isSPACE(*d))
3840 d++; /* no comments skipped here, or s### is misparsed */
3842 /* Is this a label? */
3843 if (!tmp && PL_expect == XSTATE
3844 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
3846 yylval.pval = savepv(PL_tokenbuf);
3851 /* Check for keywords */
3852 tmp = keyword(PL_tokenbuf, len);
3854 /* Is this a word before a => operator? */
3855 if (*d == '=' && d[1] == '>') {
3857 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
3858 yylval.opval->op_private = OPpCONST_BARE;
3859 if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
3860 SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
3864 if (tmp < 0) { /* second-class keyword? */
3865 GV *ogv = Nullgv; /* override (winner) */
3866 GV *hgv = Nullgv; /* hidden (loser) */
3867 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3869 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3872 if (GvIMPORTED_CV(gv))
3874 else if (! CvMETHOD(cv))
3878 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3879 (gv = *gvp) != (GV*)&PL_sv_undef &&
3880 GvCVu(gv) && GvIMPORTED_CV(gv))
3887 tmp = 0; /* overridden by import or by GLOBAL */
3890 && -tmp==KEY_lock /* XXX generalizable kludge */
3892 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3894 tmp = 0; /* any sub overrides "weak" keyword */
3896 else { /* no override */
3898 if (tmp == KEY_dump && ckWARN(WARN_MISC)) {
3899 Perl_warner(aTHX_ packWARN(WARN_MISC),
3900 "dump() better written as CORE::dump()");
3904 if (ckWARN(WARN_AMBIGUOUS) && hgv
3905 && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3906 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
3907 "Ambiguous call resolved as CORE::%s(), %s",
3908 GvENAME(hgv), "qualify as such or use &");
3915 default: /* not a keyword */
3919 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3921 /* Get the rest if it looks like a package qualifier */
3923 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
3925 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3928 Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
3929 *s == '\'' ? "'" : "::");
3934 if (PL_expect == XOPERATOR) {
3935 if (PL_bufptr == PL_linestart) {
3936 CopLINE_dec(PL_curcop);
3937 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
3938 CopLINE_inc(PL_curcop);
3941 no_op("Bareword",s);
3944 /* Look for a subroutine with this name in current package,
3945 unless name is "Foo::", in which case Foo is a bearword
3946 (and a package name). */
3949 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3951 if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3952 Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
3953 "Bareword \"%s\" refers to nonexistent package",
3956 PL_tokenbuf[len] = '\0';
3963 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3966 /* if we saw a global override before, get the right name */
3969 sv = newSVpvn("CORE::GLOBAL::",14);
3970 sv_catpv(sv,PL_tokenbuf);
3973 sv = newSVpv(PL_tokenbuf,0);
3975 /* Presume this is going to be a bareword of some sort. */
3978 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3979 yylval.opval->op_private = OPpCONST_BARE;
3980 /* UTF-8 package name? */
3981 if (UTF && !IN_BYTES &&
3982 is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
3985 /* And if "Foo::", then that's what it certainly is. */
3990 /* See if it's the indirect object for a list operator. */
3992 if (PL_oldoldbufptr &&
3993 PL_oldoldbufptr < PL_bufptr &&
3994 (PL_oldoldbufptr == PL_last_lop
3995 || PL_oldoldbufptr == PL_last_uni) &&
3996 /* NO SKIPSPACE BEFORE HERE! */
3997 (PL_expect == XREF ||
3998 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
4000 bool immediate_paren = *s == '(';
4002 /* (Now we can afford to cross potential line boundary.) */
4005 /* Two barewords in a row may indicate method call. */
4007 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp=intuit_method(s,gv)))
4010 /* If not a declared subroutine, it's an indirect object. */
4011 /* (But it's an indir obj regardless for sort.) */
4013 if ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
4014 ((!gv || !GvCVu(gv)) &&
4015 (PL_last_lop_op != OP_MAPSTART &&
4016 PL_last_lop_op != OP_GREPSTART))))
4018 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
4023 PL_expect = XOPERATOR;
4026 /* Is this a word before a => operator? */
4027 if (*s == '=' && s[1] == '>' && !pkgname) {
4029 sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
4030 if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
4031 SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
4035 /* If followed by a paren, it's certainly a subroutine. */
4038 if (gv && GvCVu(gv)) {
4039 for (d = s + 1; SPACE_OR_TAB(*d); d++) ;
4040 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
4045 PL_nextval[PL_nexttoke].opval = yylval.opval;
4046 PL_expect = XOPERATOR;
4052 /* If followed by var or block, call it a method (unless sub) */
4054 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
4055 PL_last_lop = PL_oldbufptr;
4056 PL_last_lop_op = OP_METHOD;
4060 /* If followed by a bareword, see if it looks like indir obj. */
4063 && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
4064 && (tmp = intuit_method(s,gv)))
4067 /* Not a method, so call it a subroutine (if defined) */
4069 if (gv && GvCVu(gv)) {
4071 if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
4072 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4073 "Ambiguous use of -%s resolved as -&%s()",
4074 PL_tokenbuf, PL_tokenbuf);
4075 /* Check for a constant sub */
4077 if ((sv = cv_const_sv(cv))) {
4079 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
4080 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
4081 yylval.opval->op_private = 0;
4085 /* Resolve to GV now. */
4086 op_free(yylval.opval);
4087 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
4088 yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
4089 PL_last_lop = PL_oldbufptr;
4090 PL_last_lop_op = OP_ENTERSUB;
4091 /* Is there a prototype? */
4094 char *proto = SvPV((SV*)cv, len);
4097 if (strEQ(proto, "$"))
4099 while (*proto == ';')
4101 if (*proto == '&' && *s == '{') {
4102 sv_setpv(PL_subname, PL_curstash ?
4103 "__ANON__" : "__ANON__::__ANON__");
4107 PL_nextval[PL_nexttoke].opval = yylval.opval;
4113 /* Call it a bare word */
4115 if (PL_hints & HINT_STRICT_SUBS)
4116 yylval.opval->op_private |= OPpCONST_STRICT;
4119 if (ckWARN(WARN_RESERVED)) {
4120 if (lastchar != '-') {
4121 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
4122 if (!*d && !gv_stashpv(PL_tokenbuf,FALSE))
4123 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
4130 if (lastchar && strchr("*%&", lastchar) && ckWARN_d(WARN_AMBIGUOUS)) {
4131 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4132 "Operator or semicolon missing before %c%s",
4133 lastchar, PL_tokenbuf);
4134 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4135 "Ambiguous use of %c resolved as operator %c",
4136 lastchar, lastchar);
4142 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4143 newSVpv(CopFILE(PL_curcop),0));
4147 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4148 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
4151 case KEY___PACKAGE__:
4152 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4154 ? newSVsv(PL_curstname)
4163 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
4164 char *pname = "main";
4165 if (PL_tokenbuf[2] == 'D')
4166 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
4167 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
4170 GvIOp(gv) = newIO();
4171 IoIFP(GvIOp(gv)) = PL_rsfp;
4172 #if defined(HAS_FCNTL) && defined(F_SETFD)
4174 int fd = PerlIO_fileno(PL_rsfp);
4175 fcntl(fd,F_SETFD,fd >= 3);
4178 /* Mark this internal pseudo-handle as clean */
4179 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
4181 IoTYPE(GvIOp(gv)) = IoTYPE_PIPE;
4182 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
4183 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
4185 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
4186 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
4187 /* if the script was opened in binmode, we need to revert
4188 * it to text mode for compatibility; but only iff it has CRs
4189 * XXX this is a questionable hack at best. */
4190 if (PL_bufend-PL_bufptr > 2
4191 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
4194 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
4195 loc = PerlIO_tell(PL_rsfp);
4196 (void)PerlIO_seek(PL_rsfp, 0L, 0);
4199 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
4201 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
4202 #endif /* NETWARE */
4203 #ifdef PERLIO_IS_STDIO /* really? */
4204 # if defined(__BORLANDC__)
4205 /* XXX see note in do_binmode() */
4206 ((FILE*)PL_rsfp)->flags &= ~_F_BIN;
4210 PerlIO_seek(PL_rsfp, loc, 0);
4214 #ifdef PERLIO_LAYERS
4217 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
4218 else if (PL_encoding) {
4225 XPUSHs(PL_encoding);
4227 call_method("name", G_SCALAR);
4231 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
4232 Perl_form(aTHX_ ":encoding(%"SVf")",
4250 if (PL_expect == XSTATE) {
4257 if (*s == ':' && s[1] == ':') {
4260 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4261 if (!(tmp = keyword(PL_tokenbuf, len)))
4262 Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
4276 LOP(OP_ACCEPT,XTERM);
4282 LOP(OP_ATAN2,XTERM);
4288 LOP(OP_BINMODE,XTERM);
4291 LOP(OP_BLESS,XTERM);
4300 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
4317 if (!PL_cryptseen) {
4318 PL_cryptseen = TRUE;
4322 LOP(OP_CRYPT,XTERM);
4325 LOP(OP_CHMOD,XTERM);
4328 LOP(OP_CHOWN,XTERM);
4331 LOP(OP_CONNECT,XTERM);
4347 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4351 PL_hints |= HINT_BLOCK_SCOPE;
4361 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
4362 LOP(OP_DBMOPEN,XTERM);
4368 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4375 yylval.ival = CopLINE(PL_curcop);
4389 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
4390 UNIBRACK(OP_ENTEREVAL);
4408 case KEY_endhostent:
4414 case KEY_endservent:
4417 case KEY_endprotoent:
4428 yylval.ival = CopLINE(PL_curcop);
4430 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
4432 if ((PL_bufend - p) >= 3 &&
4433 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
4435 else if ((PL_bufend - p) >= 4 &&
4436 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
4439 if (isIDFIRST_lazy_if(p,UTF)) {
4440 p = scan_ident(p, PL_bufend,
4441 PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4445 Perl_croak(aTHX_ "Missing $ on loop variable");
4450 LOP(OP_FORMLINE,XTERM);
4456 LOP(OP_FCNTL,XTERM);
4462 LOP(OP_FLOCK,XTERM);
4471 LOP(OP_GREPSTART, XREF);
4474 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4489 case KEY_getpriority:
4490 LOP(OP_GETPRIORITY,XTERM);
4492 case KEY_getprotobyname:
4495 case KEY_getprotobynumber:
4496 LOP(OP_GPBYNUMBER,XTERM);
4498 case KEY_getprotoent:
4510 case KEY_getpeername:
4511 UNI(OP_GETPEERNAME);
4513 case KEY_gethostbyname:
4516 case KEY_gethostbyaddr:
4517 LOP(OP_GHBYADDR,XTERM);
4519 case KEY_gethostent:
4522 case KEY_getnetbyname:
4525 case KEY_getnetbyaddr:
4526 LOP(OP_GNBYADDR,XTERM);
4531 case KEY_getservbyname:
4532 LOP(OP_GSBYNAME,XTERM);
4534 case KEY_getservbyport:
4535 LOP(OP_GSBYPORT,XTERM);
4537 case KEY_getservent:
4540 case KEY_getsockname:
4541 UNI(OP_GETSOCKNAME);
4543 case KEY_getsockopt:
4544 LOP(OP_GSOCKOPT,XTERM);
4566 yylval.ival = CopLINE(PL_curcop);
4570 LOP(OP_INDEX,XTERM);
4576 LOP(OP_IOCTL,XTERM);
4588 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4620 LOP(OP_LISTEN,XTERM);
4629 s = scan_pat(s,OP_MATCH);
4630 TERM(sublex_start());
4633 LOP(OP_MAPSTART, XREF);
4636 LOP(OP_MKDIR,XTERM);
4639 LOP(OP_MSGCTL,XTERM);
4642 LOP(OP_MSGGET,XTERM);
4645 LOP(OP_MSGRCV,XTERM);
4648 LOP(OP_MSGSND,XTERM);
4654 if (isIDFIRST_lazy_if(s,UTF)) {
4655 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
4656 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
4658 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
4659 if (!PL_in_my_stash) {
4662 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
4670 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4677 if (PL_expect != XSTATE)
4678 yyerror("\"no\" not allowed in expression");
4679 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4680 s = force_version(s, FALSE);
4685 if (*s == '(' || (s = skipspace(s), *s == '('))
4692 if (isIDFIRST_lazy_if(s,UTF)) {
4694 for (d = s; isALNUM_lazy_if(d,UTF); d++) ;
4696 if (strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
4698 && !(t[0] == '=' && t[1] == '>')
4700 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4701 "Precedence problem: open %.*s should be open(%.*s)",
4702 d - s, s, d - s, s);
4708 yylval.ival = OP_OR;
4718 LOP(OP_OPEN_DIR,XTERM);
4721 checkcomma(s,PL_tokenbuf,"filehandle");
4725 checkcomma(s,PL_tokenbuf,"filehandle");
4744 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4748 LOP(OP_PIPE_OP,XTERM);
4751 s = scan_str(s,FALSE,FALSE);
4753 missingterm((char*)0);
4754 yylval.ival = OP_CONST;
4755 TERM(sublex_start());
4761 s = scan_str(s,FALSE,FALSE);
4763 missingterm((char*)0);
4765 if (SvCUR(PL_lex_stuff)) {
4768 d = SvPV_force(PL_lex_stuff, len);
4771 for (; isSPACE(*d) && len; --len, ++d) ;
4774 if (!warned && ckWARN(WARN_QW)) {
4775 for (; !isSPACE(*d) && len; --len, ++d) {
4777 Perl_warner(aTHX_ packWARN(WARN_QW),
4778 "Possible attempt to separate words with commas");
4781 else if (*d == '#') {
4782 Perl_warner(aTHX_ packWARN(WARN_QW),
4783 "Possible attempt to put comments in qw() list");
4789 for (; !isSPACE(*d) && len; --len, ++d) ;
4791 sv = newSVpvn(b, d-b);
4792 if (DO_UTF8(PL_lex_stuff))
4794 words = append_elem(OP_LIST, words,
4795 newSVOP(OP_CONST, 0, tokeq(sv)));
4799 PL_nextval[PL_nexttoke].opval = words;
4804 SvREFCNT_dec(PL_lex_stuff);
4805 PL_lex_stuff = Nullsv;
4811 s = scan_str(s,FALSE,FALSE);
4813 missingterm((char*)0);
4814 yylval.ival = OP_STRINGIFY;
4815 if (SvIVX(PL_lex_stuff) == '\'')
4816 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
4817 TERM(sublex_start());
4820 s = scan_pat(s,OP_QR);
4821 TERM(sublex_start());
4824 s = scan_str(s,FALSE,FALSE);
4826 missingterm((char*)0);
4827 yylval.ival = OP_BACKTICK;
4829 TERM(sublex_start());
4837 s = force_version(s, FALSE);
4839 else if (*s != 'v' || !isDIGIT(s[1])
4840 || (s = force_version(s, TRUE), *s == 'v'))
4842 *PL_tokenbuf = '\0';
4843 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4844 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
4845 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
4847 yyerror("<> should be quotes");
4855 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4859 LOP(OP_RENAME,XTERM);
4868 LOP(OP_RINDEX,XTERM);
4878 UNIDOR(OP_READLINE);
4891 LOP(OP_REVERSE,XTERM);
4894 UNIDOR(OP_READLINK);
4902 TERM(sublex_start());
4904 TOKEN(1); /* force error */
4913 LOP(OP_SELECT,XTERM);
4919 LOP(OP_SEMCTL,XTERM);
4922 LOP(OP_SEMGET,XTERM);
4925 LOP(OP_SEMOP,XTERM);
4931 LOP(OP_SETPGRP,XTERM);
4933 case KEY_setpriority:
4934 LOP(OP_SETPRIORITY,XTERM);
4936 case KEY_sethostent:
4942 case KEY_setservent:
4945 case KEY_setprotoent:
4955 LOP(OP_SEEKDIR,XTERM);
4957 case KEY_setsockopt:
4958 LOP(OP_SSOCKOPT,XTERM);
4964 LOP(OP_SHMCTL,XTERM);
4967 LOP(OP_SHMGET,XTERM);
4970 LOP(OP_SHMREAD,XTERM);
4973 LOP(OP_SHMWRITE,XTERM);
4976 LOP(OP_SHUTDOWN,XTERM);
4985 LOP(OP_SOCKET,XTERM);
4987 case KEY_socketpair:
4988 LOP(OP_SOCKPAIR,XTERM);
4991 checkcomma(s,PL_tokenbuf,"subroutine name");
4993 if (*s == ';' || *s == ')') /* probably a close */
4994 Perl_croak(aTHX_ "sort is now a reserved word");
4996 s = force_word(s,WORD,TRUE,TRUE,FALSE);
5000 LOP(OP_SPLIT,XTERM);
5003 LOP(OP_SPRINTF,XTERM);
5006 LOP(OP_SPLICE,XTERM);
5021 LOP(OP_SUBSTR,XTERM);
5027 char tmpbuf[sizeof PL_tokenbuf];
5028 SSize_t tboffset = 0;
5029 expectation attrful;
5030 bool have_name, have_proto, bad_proto;
5035 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
5036 (*s == ':' && s[1] == ':'))
5039 attrful = XATTRBLOCK;
5040 /* remember buffer pos'n for later force_word */
5041 tboffset = s - PL_oldbufptr;
5042 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
5043 if (strchr(tmpbuf, ':'))
5044 sv_setpv(PL_subname, tmpbuf);
5046 sv_setsv(PL_subname,PL_curstname);
5047 sv_catpvn(PL_subname,"::",2);
5048 sv_catpvn(PL_subname,tmpbuf,len);
5055 Perl_croak(aTHX_ "Missing name in \"my sub\"");
5056 PL_expect = XTERMBLOCK;
5057 attrful = XATTRTERM;
5058 sv_setpv(PL_subname,"?");
5062 if (key == KEY_format) {
5064 PL_lex_formbrack = PL_lex_brackets + 1;
5066 (void) force_word(PL_oldbufptr + tboffset, WORD,
5071 /* Look for a prototype */
5075 s = scan_str(s,FALSE,FALSE);
5077 Perl_croak(aTHX_ "Prototype not terminated");
5078 /* strip spaces and check for bad characters */
5079 d = SvPVX(PL_lex_stuff);
5082 for (p = d; *p; ++p) {
5085 if (!strchr("$@%*;[]&\\", *p))
5090 if (bad_proto && ckWARN(WARN_SYNTAX))
5091 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5092 "Illegal character in prototype for %"SVf" : %s",
5094 SvCUR(PL_lex_stuff) = tmp;
5102 if (*s == ':' && s[1] != ':')
5103 PL_expect = attrful;
5104 else if (!have_name && *s != '{' && key == KEY_sub)
5105 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
5108 PL_nextval[PL_nexttoke].opval =
5109 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
5110 PL_lex_stuff = Nullsv;
5114 sv_setpv(PL_subname,
5115 PL_curstash ? "__ANON__" : "__ANON__::__ANON__");
5118 (void) force_word(PL_oldbufptr + tboffset, WORD,
5127 LOP(OP_SYSTEM,XREF);
5130 LOP(OP_SYMLINK,XTERM);
5133 LOP(OP_SYSCALL,XTERM);
5136 LOP(OP_SYSOPEN,XTERM);
5139 LOP(OP_SYSSEEK,XTERM);
5142 LOP(OP_SYSREAD,XTERM);
5145 LOP(OP_SYSWRITE,XTERM);
5149 TERM(sublex_start());
5170 LOP(OP_TRUNCATE,XTERM);
5182 yylval.ival = CopLINE(PL_curcop);
5186 yylval.ival = CopLINE(PL_curcop);
5190 LOP(OP_UNLINK,XTERM);
5196 LOP(OP_UNPACK,XTERM);
5199 LOP(OP_UTIME,XTERM);
5205 LOP(OP_UNSHIFT,XTERM);
5208 if (PL_expect != XSTATE)
5209 yyerror("\"use\" not allowed in expression");
5211 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
5212 s = force_version(s, TRUE);
5213 if (*s == ';' || (s = skipspace(s), *s == ';')) {
5214 PL_nextval[PL_nexttoke].opval = Nullop;
5217 else if (*s == 'v') {
5218 s = force_word(s,WORD,FALSE,TRUE,FALSE);
5219 s = force_version(s, FALSE);
5223 s = force_word(s,WORD,FALSE,TRUE,FALSE);
5224 s = force_version(s, FALSE);
5236 yylval.ival = CopLINE(PL_curcop);
5240 PL_hints |= HINT_BLOCK_SCOPE;
5247 LOP(OP_WAITPID,XTERM);
5256 ctl_l[0] = toCTRL('L');
5258 gv_fetchpv(ctl_l,TRUE, SVt_PV);
5261 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
5266 if (PL_expect == XOPERATOR)
5272 yylval.ival = OP_XOR;
5277 TERM(sublex_start());
5282 #pragma segment Main
5286 S_pending_ident(pTHX)
5289 register I32 tmp = 0;
5290 /* pit holds the identifier we read and pending_ident is reset */
5291 char pit = PL_pending_ident;
5292 PL_pending_ident = 0;
5294 DEBUG_T({ PerlIO_printf(Perl_debug_log,
5295 "### Tokener saw identifier '%s'\n", PL_tokenbuf); });
5297 /* if we're in a my(), we can't allow dynamics here.
5298 $foo'bar has already been turned into $foo::bar, so
5299 just check for colons.
5301 if it's a legal name, the OP is a PADANY.
5304 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
5305 if (strchr(PL_tokenbuf,':'))
5306 yyerror(Perl_form(aTHX_ "No package name allowed for "
5307 "variable %s in \"our\"",
5309 tmp = allocmy(PL_tokenbuf);
5312 if (strchr(PL_tokenbuf,':'))
5313 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
5315 yylval.opval = newOP(OP_PADANY, 0);
5316 yylval.opval->op_targ = allocmy(PL_tokenbuf);
5322 build the ops for accesses to a my() variable.
5324 Deny my($a) or my($b) in a sort block, *if* $a or $b is
5325 then used in a comparison. This catches most, but not
5326 all cases. For instance, it catches
5327 sort { my($a); $a <=> $b }
5329 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
5330 (although why you'd do that is anyone's guess).
5333 if (!strchr(PL_tokenbuf,':')) {
5335 tmp = pad_findmy(PL_tokenbuf);
5336 if (tmp != NOT_IN_PAD) {
5337 /* might be an "our" variable" */
5338 if (PAD_COMPNAME_FLAGS(tmp) & SVpad_OUR) {
5339 /* build ops for a bareword */
5340 SV *sym = newSVpv(HvNAME(PAD_COMPNAME_OURSTASH(tmp)), 0);
5341 sv_catpvn(sym, "::", 2);
5342 sv_catpv(sym, PL_tokenbuf+1);
5343 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
5344 yylval.opval->op_private = OPpCONST_ENTERED;
5345 gv_fetchpv(SvPVX(sym),
5347 ? (GV_ADDMULTI | GV_ADDINEVAL)
5350 ((PL_tokenbuf[0] == '$') ? SVt_PV
5351 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5356 /* if it's a sort block and they're naming $a or $b */
5357 if (PL_last_lop_op == OP_SORT &&
5358 PL_tokenbuf[0] == '$' &&
5359 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
5362 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
5363 d < PL_bufend && *d != '\n';
5366 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
5367 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
5373 yylval.opval = newOP(OP_PADANY, 0);
5374 yylval.opval->op_targ = tmp;
5380 Whine if they've said @foo in a doublequoted string,
5381 and @foo isn't a variable we can find in the symbol
5384 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
5385 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
5386 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
5387 && ckWARN(WARN_AMBIGUOUS))
5389 /* Downgraded from fatal to warning 20000522 mjd */
5390 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5391 "Possible unintended interpolation of %s in string",
5396 /* build ops for a bareword */
5397 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
5398 yylval.opval->op_private = OPpCONST_ENTERED;
5399 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
5400 ((PL_tokenbuf[0] == '$') ? SVt_PV
5401 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5407 Perl_keyword(pTHX_ register char *d, I32 len)
5412 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
5413 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
5414 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
5415 if (strEQ(d,"__DATA__")) return KEY___DATA__;
5416 if (strEQ(d,"__END__")) return KEY___END__;
5420 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
5425 if (strEQ(d,"and")) return -KEY_and;
5426 if (strEQ(d,"abs")) return -KEY_abs;
5429 if (strEQ(d,"alarm")) return -KEY_alarm;
5430 if (strEQ(d,"atan2")) return -KEY_atan2;
5433 if (strEQ(d,"accept")) return -KEY_accept;
5438 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
5441 if (strEQ(d,"bless")) return -KEY_bless;
5442 if (strEQ(d,"bind")) return -KEY_bind;
5443 if (strEQ(d,"binmode")) return -KEY_binmode;
5446 if (strEQ(d,"CORE")) return -KEY_CORE;
5447 if (strEQ(d,"CHECK")) return KEY_CHECK;
5452 if (strEQ(d,"cmp")) return -KEY_cmp;
5453 if (strEQ(d,"chr")) return -KEY_chr;
5454 if (strEQ(d,"cos")) return -KEY_cos;
5457 if (strEQ(d,"chop")) return -KEY_chop;
5460 if (strEQ(d,"close")) return -KEY_close;
5461 if (strEQ(d,"chdir")) return -KEY_chdir;
5462 if (strEQ(d,"chomp")) return -KEY_chomp;
5463 if (strEQ(d,"chmod")) return -KEY_chmod;
5464 if (strEQ(d,"chown")) return -KEY_chown;
5465 if (strEQ(d,"crypt")) return -KEY_crypt;
5468 if (strEQ(d,"chroot")) return -KEY_chroot;
5469 if (strEQ(d,"caller")) return -KEY_caller;
5472 if (strEQ(d,"connect")) return -KEY_connect;
5475 if (strEQ(d,"closedir")) return -KEY_closedir;
5476 if (strEQ(d,"continue")) return -KEY_continue;
5481 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
5486 if (strEQ(d,"do")) return KEY_do;
5489 if (strEQ(d,"die")) return -KEY_die;
5492 if (strEQ(d,"dump")) return -KEY_dump;
5495 if (strEQ(d,"delete")) return KEY_delete;
5498 if (strEQ(d,"defined")) return KEY_defined;
5499 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
5502 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
5507 if (strEQ(d,"END")) return KEY_END;
5512 if (strEQ(d,"eq")) return -KEY_eq;
5515 if (strEQ(d,"eof")) return -KEY_eof;
5516 if (strEQ(d,"err")) return -KEY_err;
5517 if (strEQ(d,"exp")) return -KEY_exp;
5520 if (strEQ(d,"else")) return KEY_else;
5521 if (strEQ(d,"exit")) return -KEY_exit;
5522 if (strEQ(d,"eval")) return KEY_eval;
5523 if (strEQ(d,"exec")) return -KEY_exec;
5524 if (strEQ(d,"each")) return -KEY_each;
5527 if (strEQ(d,"elsif")) return KEY_elsif;
5530 if (strEQ(d,"exists")) return KEY_exists;
5531 if (strEQ(d,"elseif")) Perl_warn(aTHX_ "elseif should be elsif");
5534 if (strEQ(d,"endgrent")) return -KEY_endgrent;
5535 if (strEQ(d,"endpwent")) return -KEY_endpwent;
5538 if (strEQ(d,"endnetent")) return -KEY_endnetent;
5541 if (strEQ(d,"endhostent")) return -KEY_endhostent;
5542 if (strEQ(d,"endservent")) return -KEY_endservent;
5545 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
5552 if (strEQ(d,"for")) return KEY_for;
5555 if (strEQ(d,"fork")) return -KEY_fork;
5558 if (strEQ(d,"fcntl")) return -KEY_fcntl;
5559 if (strEQ(d,"flock")) return -KEY_flock;
5562 if (strEQ(d,"format")) return KEY_format;
5563 if (strEQ(d,"fileno")) return -KEY_fileno;
5566 if (strEQ(d,"foreach")) return KEY_foreach;
5569 if (strEQ(d,"formline")) return -KEY_formline;
5574 if (strnEQ(d,"get",3)) {
5579 if (strEQ(d,"ppid")) return -KEY_getppid;
5580 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
5583 if (strEQ(d,"pwent")) return -KEY_getpwent;
5584 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
5585 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
5588 if (strEQ(d,"peername")) return -KEY_getpeername;
5589 if (strEQ(d,"protoent")) return -KEY_getprotoent;
5590 if (strEQ(d,"priority")) return -KEY_getpriority;
5593 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
5596 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
5600 else if (*d == 'h') {
5601 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
5602 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
5603 if (strEQ(d,"hostent")) return -KEY_gethostent;
5605 else if (*d == 'n') {
5606 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
5607 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
5608 if (strEQ(d,"netent")) return -KEY_getnetent;
5610 else if (*d == 's') {
5611 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
5612 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
5613 if (strEQ(d,"servent")) return -KEY_getservent;
5614 if (strEQ(d,"sockname")) return -KEY_getsockname;
5615 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
5617 else if (*d == 'g') {
5618 if (strEQ(d,"grent")) return -KEY_getgrent;
5619 if (strEQ(d,"grnam")) return -KEY_getgrnam;
5620 if (strEQ(d,"grgid")) return -KEY_getgrgid;
5622 else if (*d == 'l') {
5623 if (strEQ(d,"login")) return -KEY_getlogin;
5625 else if (strEQ(d,"c")) return -KEY_getc;
5630 if (strEQ(d,"gt")) return -KEY_gt;
5631 if (strEQ(d,"ge")) return -KEY_ge;
5634 if (strEQ(d,"grep")) return KEY_grep;
5635 if (strEQ(d,"goto")) return KEY_goto;
5636 if (strEQ(d,"glob")) return KEY_glob;
5639 if (strEQ(d,"gmtime")) return -KEY_gmtime;
5644 if (strEQ(d,"hex")) return -KEY_hex;
5647 if (strEQ(d,"INIT")) return KEY_INIT;
5652 if (strEQ(d,"if")) return KEY_if;
5655 if (strEQ(d,"int")) return -KEY_int;
5658 if (strEQ(d,"index")) return -KEY_index;
5659 if (strEQ(d,"ioctl")) return -KEY_ioctl;
5664 if (strEQ(d,"join")) return -KEY_join;
5668 if (strEQ(d,"keys")) return -KEY_keys;
5669 if (strEQ(d,"kill")) return -KEY_kill;
5675 if (strEQ(d,"lt")) return -KEY_lt;
5676 if (strEQ(d,"le")) return -KEY_le;
5677 if (strEQ(d,"lc")) return -KEY_lc;
5680 if (strEQ(d,"log")) return -KEY_log;
5683 if (strEQ(d,"last")) return KEY_last;
5684 if (strEQ(d,"link")) return -KEY_link;
5685 if (strEQ(d,"lock")) return -KEY_lock;
5688 if (strEQ(d,"local")) return KEY_local;
5689 if (strEQ(d,"lstat")) return -KEY_lstat;
5692 if (strEQ(d,"length")) return -KEY_length;
5693 if (strEQ(d,"listen")) return -KEY_listen;
5696 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
5699 if (strEQ(d,"localtime")) return -KEY_localtime;
5705 case 1: return KEY_m;
5707 if (strEQ(d,"my")) return KEY_my;
5710 if (strEQ(d,"map")) return KEY_map;
5713 if (strEQ(d,"mkdir")) return -KEY_mkdir;
5716 if (strEQ(d,"msgctl")) return -KEY_msgctl;
5717 if (strEQ(d,"msgget")) return -KEY_msgget;
5718 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
5719 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
5724 if (strEQ(d,"next")) return KEY_next;
5725 if (strEQ(d,"ne")) return -KEY_ne;
5726 if (strEQ(d,"not")) return -KEY_not;
5727 if (strEQ(d,"no")) return KEY_no;
5732 if (strEQ(d,"or")) return -KEY_or;
5735 if (strEQ(d,"ord")) return -KEY_ord;
5736 if (strEQ(d,"oct")) return -KEY_oct;
5737 if (strEQ(d,"our")) return KEY_our;
5740 if (strEQ(d,"open")) return -KEY_open;
5743 if (strEQ(d,"opendir")) return -KEY_opendir;
5750 if (strEQ(d,"pop")) return -KEY_pop;
5751 if (strEQ(d,"pos")) return KEY_pos;
5754 if (strEQ(d,"push")) return -KEY_push;
5755 if (strEQ(d,"pack")) return -KEY_pack;
5756 if (strEQ(d,"pipe")) return -KEY_pipe;
5759 if (strEQ(d,"print")) return KEY_print;
5762 if (strEQ(d,"printf")) return KEY_printf;
5765 if (strEQ(d,"package")) return KEY_package;
5768 if (strEQ(d,"prototype")) return KEY_prototype;
5773 if (strEQ(d,"q")) return KEY_q;
5774 if (strEQ(d,"qr")) return KEY_qr;
5775 if (strEQ(d,"qq")) return KEY_qq;
5776 if (strEQ(d,"qw")) return KEY_qw;
5777 if (strEQ(d,"qx")) return KEY_qx;
5779 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
5784 if (strEQ(d,"ref")) return -KEY_ref;
5787 if (strEQ(d,"read")) return -KEY_read;
5788 if (strEQ(d,"rand")) return -KEY_rand;
5789 if (strEQ(d,"recv")) return -KEY_recv;
5790 if (strEQ(d,"redo")) return KEY_redo;
5793 if (strEQ(d,"rmdir")) return -KEY_rmdir;
5794 if (strEQ(d,"reset")) return -KEY_reset;
5797 if (strEQ(d,"return")) return KEY_return;
5798 if (strEQ(d,"rename")) return -KEY_rename;
5799 if (strEQ(d,"rindex")) return -KEY_rindex;
5802 if (strEQ(d,"require")) return KEY_require;
5803 if (strEQ(d,"reverse")) return -KEY_reverse;
5804 if (strEQ(d,"readdir")) return -KEY_readdir;
5807 if (strEQ(d,"readlink")) return -KEY_readlink;
5808 if (strEQ(d,"readline")) return -KEY_readline;
5809 if (strEQ(d,"readpipe")) return -KEY_readpipe;
5812 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
5818 case 0: return KEY_s;
5820 if (strEQ(d,"scalar")) return KEY_scalar;
5825 if (strEQ(d,"seek")) return -KEY_seek;
5826 if (strEQ(d,"send")) return -KEY_send;
5829 if (strEQ(d,"semop")) return -KEY_semop;
5832 if (strEQ(d,"select")) return -KEY_select;
5833 if (strEQ(d,"semctl")) return -KEY_semctl;
5834 if (strEQ(d,"semget")) return -KEY_semget;
5837 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
5838 if (strEQ(d,"seekdir")) return -KEY_seekdir;
5841 if (strEQ(d,"setpwent")) return -KEY_setpwent;
5842 if (strEQ(d,"setgrent")) return -KEY_setgrent;
5845 if (strEQ(d,"setnetent")) return -KEY_setnetent;
5848 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
5849 if (strEQ(d,"sethostent")) return -KEY_sethostent;
5850 if (strEQ(d,"setservent")) return -KEY_setservent;
5853 if (strEQ(d,"setpriority")) return -KEY_setpriority;
5854 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
5861 if (strEQ(d,"shift")) return -KEY_shift;
5864 if (strEQ(d,"shmctl")) return -KEY_shmctl;
5865 if (strEQ(d,"shmget")) return -KEY_shmget;
5868 if (strEQ(d,"shmread")) return -KEY_shmread;
5871 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
5872 if (strEQ(d,"shutdown")) return -KEY_shutdown;
5877 if (strEQ(d,"sin")) return -KEY_sin;
5880 if (strEQ(d,"sleep")) return -KEY_sleep;
5883 if (strEQ(d,"sort")) return KEY_sort;
5884 if (strEQ(d,"socket")) return -KEY_socket;
5885 if (strEQ(d,"socketpair")) return -KEY_socketpair;
5888 if (strEQ(d,"split")) return KEY_split;
5889 if (strEQ(d,"sprintf")) return -KEY_sprintf;
5890 if (strEQ(d,"splice")) return -KEY_splice;
5893 if (strEQ(d,"sqrt")) return -KEY_sqrt;
5896 if (strEQ(d,"srand")) return -KEY_srand;
5899 if (strEQ(d,"stat")) return -KEY_stat;
5900 if (strEQ(d,"study")) return KEY_study;
5903 if (strEQ(d,"substr")) return -KEY_substr;
5904 if (strEQ(d,"sub")) return KEY_sub;
5909 if (strEQ(d,"system")) return -KEY_system;
5912 if (strEQ(d,"symlink")) return -KEY_symlink;
5913 if (strEQ(d,"syscall")) return -KEY_syscall;
5914 if (strEQ(d,"sysopen")) return -KEY_sysopen;
5915 if (strEQ(d,"sysread")) return -KEY_sysread;
5916 if (strEQ(d,"sysseek")) return -KEY_sysseek;
5919 if (strEQ(d,"syswrite")) return -KEY_syswrite;
5928 if (strEQ(d,"tr")) return KEY_tr;
5931 if (strEQ(d,"tie")) return KEY_tie;
5934 if (strEQ(d,"tell")) return -KEY_tell;
5935 if (strEQ(d,"tied")) return KEY_tied;
5936 if (strEQ(d,"time")) return -KEY_time;
5939 if (strEQ(d,"times")) return -KEY_times;
5942 if (strEQ(d,"telldir")) return -KEY_telldir;
5945 if (strEQ(d,"truncate")) return -KEY_truncate;
5952 if (strEQ(d,"uc")) return -KEY_uc;
5955 if (strEQ(d,"use")) return KEY_use;
5958 if (strEQ(d,"undef")) return KEY_undef;
5959 if (strEQ(d,"until")) return KEY_until;
5960 if (strEQ(d,"untie")) return KEY_untie;
5961 if (strEQ(d,"utime")) return -KEY_utime;
5962 if (strEQ(d,"umask")) return -KEY_umask;
5965 if (strEQ(d,"unless")) return KEY_unless;
5966 if (strEQ(d,"unpack")) return -KEY_unpack;
5967 if (strEQ(d,"unlink")) return -KEY_unlink;
5970 if (strEQ(d,"unshift")) return -KEY_unshift;
5971 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
5976 if (strEQ(d,"values")) return -KEY_values;
5977 if (strEQ(d,"vec")) return -KEY_vec;
5982 if (strEQ(d,"warn")) return -KEY_warn;
5983 if (strEQ(d,"wait")) return -KEY_wait;
5986 if (strEQ(d,"while")) return KEY_while;
5987 if (strEQ(d,"write")) return -KEY_write;
5990 if (strEQ(d,"waitpid")) return -KEY_waitpid;
5993 if (strEQ(d,"wantarray")) return -KEY_wantarray;
5998 if (len == 1) return -KEY_x;
5999 if (strEQ(d,"xor")) return -KEY_xor;
6002 if (len == 1) return KEY_y;
6011 S_checkcomma(pTHX_ register char *s, char *name, char *what)
6015 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
6016 if (ckWARN(WARN_SYNTAX)) {
6018 for (w = s+2; *w && level; w++) {
6025 for (; *w && isSPACE(*w); w++) ;
6026 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
6027 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6028 "%s (...) interpreted as function",name);
6031 while (s < PL_bufend && isSPACE(*s))
6035 while (s < PL_bufend && isSPACE(*s))
6037 if (isIDFIRST_lazy_if(s,UTF)) {
6039 while (isALNUM_lazy_if(s,UTF))
6041 while (s < PL_bufend && isSPACE(*s))
6046 kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
6050 Perl_croak(aTHX_ "No comma allowed after %s", what);
6055 /* Either returns sv, or mortalizes sv and returns a new SV*.
6056 Best used as sv=new_constant(..., sv, ...).
6057 If s, pv are NULL, calls subroutine with one argument,
6058 and type is used with error messages only. */
6061 S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv,
6065 HV *table = GvHV(PL_hintgv); /* ^H */
6069 const char *why1, *why2, *why3;
6071 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
6074 why2 = strEQ(key,"charnames")
6075 ? "(possibly a missing \"use charnames ...\")"
6077 msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
6078 (type ? type: "undef"), why2);
6080 /* This is convoluted and evil ("goto considered harmful")
6081 * but I do not understand the intricacies of all the different
6082 * failure modes of %^H in here. The goal here is to make
6083 * the most probable error message user-friendly. --jhi */
6088 msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
6089 (type ? type: "undef"), why1, why2, why3);
6091 yyerror(SvPVX(msg));
6095 cvp = hv_fetch(table, key, strlen(key), FALSE);
6096 if (!cvp || !SvOK(*cvp)) {
6099 why3 = "} is not defined";
6102 sv_2mortal(sv); /* Parent created it permanently */
6105 pv = sv_2mortal(newSVpvn(s, len));
6107 typesv = sv_2mortal(newSVpv(type, 0));
6109 typesv = &PL_sv_undef;
6111 PUSHSTACKi(PERLSI_OVERLOAD);
6123 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
6127 /* Check the eval first */
6128 if (!PL_in_eval && SvTRUE(ERRSV)) {
6130 sv_catpv(ERRSV, "Propagated");
6131 yyerror(SvPV(ERRSV, n_a)); /* Duplicates the message inside eval */
6133 res = SvREFCNT_inc(sv);
6137 (void)SvREFCNT_inc(res);
6146 why1 = "Call to &{$^H{";
6148 why3 = "}} did not return a defined value";
6157 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
6159 register char *d = dest;
6160 register char *e = d + destlen - 3; /* two-character token, ending NUL */
6163 Perl_croak(aTHX_ ident_too_long);
6164 if (isALNUM(*s)) /* UTF handled below */
6166 else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) {
6171 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
6175 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
6176 char *t = s + UTF8SKIP(s);
6177 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
6179 if (d + (t - s) > e)
6180 Perl_croak(aTHX_ ident_too_long);
6181 Copy(s, d, t - s, char);
6194 S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
6204 e = d + destlen - 3; /* two-character token, ending NUL */
6206 while (isDIGIT(*s)) {
6208 Perl_croak(aTHX_ ident_too_long);
6215 Perl_croak(aTHX_ ident_too_long);
6216 if (isALNUM(*s)) /* UTF handled below */
6218 else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
6223 else if (*s == ':' && s[1] == ':') {
6227 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
6228 char *t = s + UTF8SKIP(s);
6229 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
6231 if (d + (t - s) > e)
6232 Perl_croak(aTHX_ ident_too_long);
6233 Copy(s, d, t - s, char);
6244 if (PL_lex_state != LEX_NORMAL)
6245 PL_lex_state = LEX_INTERPENDMAYBE;
6248 if (*s == '$' && s[1] &&
6249 (isALNUM_lazy_if(s+1,UTF) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
6262 if (*d == '^' && *s && isCONTROLVAR(*s)) {
6267 if (isSPACE(s[-1])) {
6270 if (!SPACE_OR_TAB(ch)) {
6276 if (isIDFIRST_lazy_if(d,UTF)) {
6280 while ((e < send && isALNUM_lazy_if(e,UTF)) || *e == ':') {
6282 while (e < send && UTF8_IS_CONTINUED(*e) && is_utf8_mark((U8*)e))
6285 Copy(s, d, e - s, char);
6290 while ((isALNUM(*s) || *s == ':') && d < e)
6293 Perl_croak(aTHX_ ident_too_long);
6296 while (s < send && SPACE_OR_TAB(*s)) s++;
6297 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
6298 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
6299 const char *brack = *s == '[' ? "[...]" : "{...}";
6300 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
6301 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
6302 funny, dest, brack, funny, dest, brack);
6305 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
6309 /* Handle extended ${^Foo} variables
6310 * 1999-02-27 mjd-perl-patch@plover.com */
6311 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
6315 while (isALNUM(*s) && d < e) {
6319 Perl_croak(aTHX_ ident_too_long);
6324 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
6325 PL_lex_state = LEX_INTERPEND;
6330 if (PL_lex_state == LEX_NORMAL) {
6331 if (ckWARN(WARN_AMBIGUOUS) &&
6332 (keyword(dest, d - dest) || get_cv(dest, FALSE)))
6334 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
6335 "Ambiguous use of %c{%s} resolved to %c%s",
6336 funny, dest, funny, dest);
6341 s = bracket; /* let the parser handle it */
6345 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
6346 PL_lex_state = LEX_INTERPEND;
6351 Perl_pmflag(pTHX_ U32* pmfl, int ch)
6356 *pmfl |= PMf_GLOBAL;
6358 *pmfl |= PMf_CONTINUE;
6362 *pmfl |= PMf_MULTILINE;
6364 *pmfl |= PMf_SINGLELINE;
6366 *pmfl |= PMf_EXTENDED;
6370 S_scan_pat(pTHX_ char *start, I32 type)
6375 s = scan_str(start,FALSE,FALSE);
6377 Perl_croak(aTHX_ "Search pattern not terminated");
6379 pm = (PMOP*)newPMOP(type, 0);
6380 if (PL_multi_open == '?')
6381 pm->op_pmflags |= PMf_ONCE;
6383 while (*s && strchr("iomsx", *s))
6384 pmflag(&pm->op_pmflags,*s++);
6387 while (*s && strchr("iogcmsx", *s))
6388 pmflag(&pm->op_pmflags,*s++);
6390 /* issue a warning if /c is specified,but /g is not */
6391 if (ckWARN(WARN_REGEXP) &&
6392 (pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL))
6394 Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_without_g);
6397 pm->op_pmpermflags = pm->op_pmflags;
6399 PL_lex_op = (OP*)pm;
6400 yylval.ival = OP_MATCH;
6405 S_scan_subst(pTHX_ char *start)
6412 yylval.ival = OP_NULL;
6414 s = scan_str(start,FALSE,FALSE);
6417 Perl_croak(aTHX_ "Substitution pattern not terminated");
6419 if (s[-1] == PL_multi_open)
6422 first_start = PL_multi_start;
6423 s = scan_str(s,FALSE,FALSE);
6426 SvREFCNT_dec(PL_lex_stuff);
6427 PL_lex_stuff = Nullsv;
6429 Perl_croak(aTHX_ "Substitution replacement not terminated");
6431 PL_multi_start = first_start; /* so whole substitution is taken together */
6433 pm = (PMOP*)newPMOP(OP_SUBST, 0);
6439 else if (strchr("iogcmsx", *s))
6440 pmflag(&pm->op_pmflags,*s++);
6445 /* /c is not meaningful with s/// */
6446 if (ckWARN(WARN_REGEXP) && (pm->op_pmflags & PMf_CONTINUE))
6448 Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_in_subst);
6453 PL_sublex_info.super_bufptr = s;
6454 PL_sublex_info.super_bufend = PL_bufend;
6456 pm->op_pmflags |= PMf_EVAL;
6457 repl = newSVpvn("",0);
6459 sv_catpv(repl, es ? "eval " : "do ");
6460 sv_catpvn(repl, "{ ", 2);
6461 sv_catsv(repl, PL_lex_repl);
6462 sv_catpvn(repl, " };", 2);
6464 SvREFCNT_dec(PL_lex_repl);
6468 pm->op_pmpermflags = pm->op_pmflags;
6469 PL_lex_op = (OP*)pm;
6470 yylval.ival = OP_SUBST;
6475 S_scan_trans(pTHX_ char *start)
6484 yylval.ival = OP_NULL;
6486 s = scan_str(start,FALSE,FALSE);
6488 Perl_croak(aTHX_ "Transliteration pattern not terminated");
6489 if (s[-1] == PL_multi_open)
6492 s = scan_str(s,FALSE,FALSE);
6495 SvREFCNT_dec(PL_lex_stuff);
6496 PL_lex_stuff = Nullsv;
6498 Perl_croak(aTHX_ "Transliteration replacement not terminated");
6501 complement = del = squash = 0;
6502 while (strchr("cds", *s)) {
6504 complement = OPpTRANS_COMPLEMENT;
6506 del = OPpTRANS_DELETE;
6508 squash = OPpTRANS_SQUASH;
6512 New(803, tbl, complement&&!del?258:256, short);
6513 o = newPVOP(OP_TRANS, 0, (char*)tbl);
6514 o->op_private = del|squash|complement|
6515 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
6516 (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0);
6519 yylval.ival = OP_TRANS;
6524 S_scan_heredoc(pTHX_ register char *s)
6527 I32 op_type = OP_SCALAR;
6534 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
6538 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
6541 for (peek = s; SPACE_OR_TAB(*peek); peek++) ;
6542 if (*peek && strchr("`'\"",*peek)) {
6545 s = delimcpy(d, e, s, PL_bufend, term, &len);
6555 if (!isALNUM_lazy_if(s,UTF))
6556 deprecate_old("bare << to mean <<\"\"");
6557 for (; isALNUM_lazy_if(s,UTF); s++) {
6562 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
6563 Perl_croak(aTHX_ "Delimiter for here document is too long");
6566 len = d - PL_tokenbuf;
6567 #ifndef PERL_STRICT_CR
6568 d = strchr(s, '\r');
6572 while (s < PL_bufend) {
6578 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
6587 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6592 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
6593 herewas = newSVpvn(s,PL_bufend-s);
6595 s--, herewas = newSVpvn(s,d-s);
6596 s += SvCUR(herewas);
6598 tmpstr = NEWSV(87,79);
6599 sv_upgrade(tmpstr, SVt_PVIV);
6604 else if (term == '`') {
6605 op_type = OP_BACKTICK;
6606 SvIVX(tmpstr) = '\\';
6610 PL_multi_start = CopLINE(PL_curcop);
6611 PL_multi_open = PL_multi_close = '<';
6612 term = *PL_tokenbuf;
6613 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
6614 char *bufptr = PL_sublex_info.super_bufptr;
6615 char *bufend = PL_sublex_info.super_bufend;
6616 char *olds = s - SvCUR(herewas);
6617 s = strchr(bufptr, '\n');
6621 while (s < bufend &&
6622 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6624 CopLINE_inc(PL_curcop);
6627 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
6628 missingterm(PL_tokenbuf);
6630 sv_setpvn(herewas,bufptr,d-bufptr+1);
6631 sv_setpvn(tmpstr,d+1,s-d);
6633 sv_catpvn(herewas,s,bufend-s);
6634 (void)strcpy(bufptr,SvPVX(herewas));
6641 while (s < PL_bufend &&
6642 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6644 CopLINE_inc(PL_curcop);
6646 if (s >= PL_bufend) {
6647 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
6648 missingterm(PL_tokenbuf);
6650 sv_setpvn(tmpstr,d+1,s-d);
6652 CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
6654 sv_catpvn(herewas,s,PL_bufend-s);
6655 sv_setsv(PL_linestr,herewas);
6656 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
6657 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6658 PL_last_lop = PL_last_uni = Nullch;
6661 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
6662 while (s >= PL_bufend) { /* multiple line string? */
6664 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6665 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
6666 missingterm(PL_tokenbuf);
6668 CopLINE_inc(PL_curcop);
6669 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6670 PL_last_lop = PL_last_uni = Nullch;
6671 #ifndef PERL_STRICT_CR
6672 if (PL_bufend - PL_linestart >= 2) {
6673 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
6674 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
6676 PL_bufend[-2] = '\n';
6678 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6680 else if (PL_bufend[-1] == '\r')
6681 PL_bufend[-1] = '\n';
6683 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
6684 PL_bufend[-1] = '\n';
6686 if (PERLDB_LINE && PL_curstash != PL_debstash) {
6687 SV *sv = NEWSV(88,0);
6689 sv_upgrade(sv, SVt_PVMG);
6690 sv_setsv(sv,PL_linestr);
6693 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop),sv);
6695 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
6698 sv_catsv(PL_linestr,herewas);
6699 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6703 sv_catsv(tmpstr,PL_linestr);
6708 PL_multi_end = CopLINE(PL_curcop);
6709 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
6710 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
6711 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
6713 SvREFCNT_dec(herewas);
6715 if (UTF && is_utf8_string((U8*)SvPVX(tmpstr), SvCUR(tmpstr)))
6717 else if (PL_encoding)
6718 sv_recode_to_utf8(tmpstr, PL_encoding);
6720 PL_lex_stuff = tmpstr;
6721 yylval.ival = op_type;
6726 takes: current position in input buffer
6727 returns: new position in input buffer
6728 side-effects: yylval and lex_op are set.
6733 <FH> read from filehandle
6734 <pkg::FH> read from package qualified filehandle
6735 <pkg'FH> read from package qualified filehandle
6736 <$fh> read from filehandle in $fh
6742 S_scan_inputsymbol(pTHX_ char *start)
6744 register char *s = start; /* current position in buffer */
6750 d = PL_tokenbuf; /* start of temp holding space */
6751 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
6752 end = strchr(s, '\n');
6755 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
6757 /* die if we didn't have space for the contents of the <>,
6758 or if it didn't end, or if we see a newline
6761 if (len >= sizeof PL_tokenbuf)
6762 Perl_croak(aTHX_ "Excessively long <> operator");
6764 Perl_croak(aTHX_ "Unterminated <> operator");
6769 Remember, only scalar variables are interpreted as filehandles by
6770 this code. Anything more complex (e.g., <$fh{$num}>) will be
6771 treated as a glob() call.
6772 This code makes use of the fact that except for the $ at the front,
6773 a scalar variable and a filehandle look the same.
6775 if (*d == '$' && d[1]) d++;
6777 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
6778 while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
6781 /* If we've tried to read what we allow filehandles to look like, and
6782 there's still text left, then it must be a glob() and not a getline.
6783 Use scan_str to pull out the stuff between the <> and treat it
6784 as nothing more than a string.
6787 if (d - PL_tokenbuf != len) {
6788 yylval.ival = OP_GLOB;
6790 s = scan_str(start,FALSE,FALSE);
6792 Perl_croak(aTHX_ "Glob not terminated");
6796 bool readline_overriden = FALSE;
6797 GV *gv_readline = Nullgv;
6799 /* we're in a filehandle read situation */
6802 /* turn <> into <ARGV> */
6804 (void)strcpy(d,"ARGV");
6806 /* Check whether readline() is overriden */
6807 if (((gv_readline = gv_fetchpv("readline", FALSE, SVt_PVCV))
6808 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
6810 ((gvp = (GV**)hv_fetch(PL_globalstash, "readline", 8, FALSE))
6811 && (gv_readline = *gvp) != (GV*)&PL_sv_undef
6812 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
6813 readline_overriden = TRUE;
6815 /* if <$fh>, create the ops to turn the variable into a
6821 /* try to find it in the pad for this block, otherwise find
6822 add symbol table ops
6824 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
6825 if (PAD_COMPNAME_FLAGS(tmp) & SVpad_OUR) {
6826 SV *sym = sv_2mortal(
6827 newSVpv(HvNAME(PAD_COMPNAME_OURSTASH(tmp)),0));
6828 sv_catpvn(sym, "::", 2);
6834 OP *o = newOP(OP_PADSV, 0);
6836 PL_lex_op = readline_overriden
6837 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
6838 append_elem(OP_LIST, o,
6839 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
6840 : (OP*)newUNOP(OP_READLINE, 0, o);
6849 ? (GV_ADDMULTI | GV_ADDINEVAL)
6852 PL_lex_op = readline_overriden
6853 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
6854 append_elem(OP_LIST,
6855 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
6856 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
6857 : (OP*)newUNOP(OP_READLINE, 0,
6858 newUNOP(OP_RV2SV, 0,
6859 newGVOP(OP_GV, 0, gv)));
6861 if (!readline_overriden)
6862 PL_lex_op->op_flags |= OPf_SPECIAL;
6863 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
6864 yylval.ival = OP_NULL;
6867 /* If it's none of the above, it must be a literal filehandle
6868 (<Foo::BAR> or <FOO>) so build a simple readline OP */
6870 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
6871 PL_lex_op = readline_overriden
6872 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
6873 append_elem(OP_LIST,
6874 newGVOP(OP_GV, 0, gv),
6875 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
6876 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
6877 yylval.ival = OP_NULL;
6886 takes: start position in buffer
6887 keep_quoted preserve \ on the embedded delimiter(s)
6888 keep_delims preserve the delimiters around the string
6889 returns: position to continue reading from buffer
6890 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
6891 updates the read buffer.
6893 This subroutine pulls a string out of the input. It is called for:
6894 q single quotes q(literal text)
6895 ' single quotes 'literal text'
6896 qq double quotes qq(interpolate $here please)
6897 " double quotes "interpolate $here please"
6898 qx backticks qx(/bin/ls -l)
6899 ` backticks `/bin/ls -l`
6900 qw quote words @EXPORT_OK = qw( func() $spam )
6901 m// regexp match m/this/
6902 s/// regexp substitute s/this/that/
6903 tr/// string transliterate tr/this/that/
6904 y/// string transliterate y/this/that/
6905 ($*@) sub prototypes sub foo ($)
6906 (stuff) sub attr parameters sub foo : attr(stuff)
6907 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
6909 In most of these cases (all but <>, patterns and transliterate)
6910 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
6911 calls scan_str(). s/// makes yylex() call scan_subst() which calls
6912 scan_str(). tr/// and y/// make yylex() call scan_trans() which
6915 It skips whitespace before the string starts, and treats the first
6916 character as the delimiter. If the delimiter is one of ([{< then
6917 the corresponding "close" character )]}> is used as the closing
6918 delimiter. It allows quoting of delimiters, and if the string has
6919 balanced delimiters ([{<>}]) it allows nesting.
6921 On success, the SV with the resulting string is put into lex_stuff or,
6922 if that is already non-NULL, into lex_repl. The second case occurs only
6923 when parsing the RHS of the special constructs s/// and tr/// (y///).
6924 For convenience, the terminating delimiter character is stuffed into
6929 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
6931 SV *sv; /* scalar value: string */
6932 char *tmps; /* temp string, used for delimiter matching */
6933 register char *s = start; /* current position in the buffer */
6934 register char term; /* terminating character */
6935 register char *to; /* current position in the sv's data */
6936 I32 brackets = 1; /* bracket nesting level */
6937 bool has_utf8 = FALSE; /* is there any utf8 content? */
6938 I32 termcode; /* terminating char. code */
6939 U8 termstr[UTF8_MAXLEN]; /* terminating string */
6940 STRLEN termlen; /* length of terminating string */
6941 char *last = NULL; /* last position for nesting bracket */
6943 /* skip space before the delimiter */
6947 /* mark where we are, in case we need to report errors */
6950 /* after skipping whitespace, the next character is the terminator */
6953 termcode = termstr[0] = term;
6957 termcode = utf8_to_uvchr((U8*)s, &termlen);
6958 Copy(s, termstr, termlen, U8);
6959 if (!UTF8_IS_INVARIANT(term))
6963 /* mark where we are */
6964 PL_multi_start = CopLINE(PL_curcop);
6965 PL_multi_open = term;
6967 /* find corresponding closing delimiter */
6968 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
6969 termcode = termstr[0] = term = tmps[5];
6971 PL_multi_close = term;
6973 /* create a new SV to hold the contents. 87 is leak category, I'm
6974 assuming. 79 is the SV's initial length. What a random number. */
6976 sv_upgrade(sv, SVt_PVIV);
6977 SvIVX(sv) = termcode;
6978 (void)SvPOK_only(sv); /* validate pointer */
6980 /* move past delimiter and try to read a complete string */
6982 sv_catpvn(sv, s, termlen);
6985 if (PL_encoding && !UTF) {
6989 int offset = s - SvPVX(PL_linestr);
6990 bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
6991 &offset, (char*)termstr, termlen);
6992 char *ns = SvPVX(PL_linestr) + offset;
6993 char *svlast = SvEND(sv) - 1;
6995 for (; s < ns; s++) {
6996 if (*s == '\n' && !PL_rsfp)
6997 CopLINE_inc(PL_curcop);
7000 goto read_more_line;
7002 /* handle quoted delimiters */
7003 if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
7005 for (t = svlast-2; t >= SvPVX(sv) && *t == '\\';)
7007 if ((svlast-1 - t) % 2) {
7011 SvCUR_set(sv, SvCUR(sv) - 1);
7016 if (PL_multi_open == PL_multi_close) {
7023 for (w = t = last; t < svlast; w++, t++) {
7024 /* At here, all closes are "was quoted" one,
7025 so we don't check PL_multi_close. */
7027 if (!keep_quoted && *(t+1) == PL_multi_open)
7032 else if (*t == PL_multi_open)
7040 SvCUR_set(sv, w - SvPVX(sv));
7043 if (--brackets <= 0)
7049 SvCUR_set(sv, SvCUR(sv) - 1);
7055 /* extend sv if need be */
7056 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
7057 /* set 'to' to the next character in the sv's string */
7058 to = SvPVX(sv)+SvCUR(sv);
7060 /* if open delimiter is the close delimiter read unbridle */
7061 if (PL_multi_open == PL_multi_close) {
7062 for (; s < PL_bufend; s++,to++) {
7063 /* embedded newlines increment the current line number */
7064 if (*s == '\n' && !PL_rsfp)
7065 CopLINE_inc(PL_curcop);
7066 /* handle quoted delimiters */
7067 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
7068 if (!keep_quoted && s[1] == term)
7070 /* any other quotes are simply copied straight through */
7074 /* terminate when run out of buffer (the for() condition), or
7075 have found the terminator */
7076 else if (*s == term) {
7079 if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
7082 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
7088 /* if the terminator isn't the same as the start character (e.g.,
7089 matched brackets), we have to allow more in the quoting, and
7090 be prepared for nested brackets.
7093 /* read until we run out of string, or we find the terminator */
7094 for (; s < PL_bufend; s++,to++) {
7095 /* embedded newlines increment the line count */
7096 if (*s == '\n' && !PL_rsfp)
7097 CopLINE_inc(PL_curcop);
7098 /* backslashes can escape the open or closing characters */
7099 if (*s == '\\' && s+1 < PL_bufend) {
7101 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
7106 /* allow nested opens and closes */
7107 else if (*s == PL_multi_close && --brackets <= 0)
7109 else if (*s == PL_multi_open)
7111 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
7116 /* terminate the copied string and update the sv's end-of-string */
7118 SvCUR_set(sv, to - SvPVX(sv));
7121 * this next chunk reads more into the buffer if we're not done yet
7125 break; /* handle case where we are done yet :-) */
7127 #ifndef PERL_STRICT_CR
7128 if (to - SvPVX(sv) >= 2) {
7129 if ((to[-2] == '\r' && to[-1] == '\n') ||
7130 (to[-2] == '\n' && to[-1] == '\r'))
7134 SvCUR_set(sv, to - SvPVX(sv));
7136 else if (to[-1] == '\r')
7139 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
7144 /* if we're out of file, or a read fails, bail and reset the current
7145 line marker so we can report where the unterminated string began
7148 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
7150 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
7153 /* we read a line, so increment our line counter */
7154 CopLINE_inc(PL_curcop);
7156 /* update debugger info */
7157 if (PERLDB_LINE && PL_curstash != PL_debstash) {
7158 SV *sv = NEWSV(88,0);
7160 sv_upgrade(sv, SVt_PVMG);
7161 sv_setsv(sv,PL_linestr);
7164 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop), sv);
7167 /* having changed the buffer, we must update PL_bufend */
7168 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7169 PL_last_lop = PL_last_uni = Nullch;
7172 /* at this point, we have successfully read the delimited string */
7174 if (!PL_encoding || UTF) {
7176 sv_catpvn(sv, s, termlen);
7179 if (has_utf8 || PL_encoding)
7182 PL_multi_end = CopLINE(PL_curcop);
7184 /* if we allocated too much space, give some back */
7185 if (SvCUR(sv) + 5 < SvLEN(sv)) {
7186 SvLEN_set(sv, SvCUR(sv) + 1);
7187 Renew(SvPVX(sv), SvLEN(sv), char);
7190 /* decide whether this is the first or second quoted string we've read
7203 takes: pointer to position in buffer
7204 returns: pointer to new position in buffer
7205 side-effects: builds ops for the constant in yylval.op
7207 Read a number in any of the formats that Perl accepts:
7209 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
7210 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
7213 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
7215 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
7218 If it reads a number without a decimal point or an exponent, it will
7219 try converting the number to an integer and see if it can do so
7220 without loss of precision.
7224 Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp)
7226 register char *s = start; /* current position in buffer */
7227 register char *d; /* destination in temp buffer */
7228 register char *e; /* end of temp buffer */
7229 NV nv; /* number read, as a double */
7230 SV *sv = Nullsv; /* place to put the converted number */
7231 bool floatit; /* boolean: int or float? */
7232 char *lastub = 0; /* position of last underbar */
7233 static char number_too_long[] = "Number too long";
7235 /* We use the first character to decide what type of number this is */
7239 Perl_croak(aTHX_ "panic: scan_num");
7241 /* if it starts with a 0, it could be an octal number, a decimal in
7242 0.13 disguise, or a hexadecimal number, or a binary number. */
7246 u holds the "number so far"
7247 shift the power of 2 of the base
7248 (hex == 4, octal == 3, binary == 1)
7249 overflowed was the number more than we can hold?
7251 Shift is used when we add a digit. It also serves as an "are
7252 we in octal/hex/binary?" indicator to disallow hex characters
7258 bool overflowed = FALSE;
7259 bool just_zero = TRUE; /* just plain 0 or binary number? */
7260 static NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
7261 static char* bases[5] = { "", "binary", "", "octal",
7263 static char* Bases[5] = { "", "Binary", "", "Octal",
7265 static char *maxima[5] = { "",
7266 "0b11111111111111111111111111111111",
7270 char *base, *Base, *max;
7277 } else if (s[1] == 'b') {
7282 /* check for a decimal in disguise */
7283 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
7285 /* so it must be octal */
7292 if (ckWARN(WARN_SYNTAX))
7293 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7294 "Misplaced _ in number");
7298 base = bases[shift];
7299 Base = Bases[shift];
7300 max = maxima[shift];
7302 /* read the rest of the number */
7304 /* x is used in the overflow test,
7305 b is the digit we're adding on. */
7310 /* if we don't mention it, we're done */
7314 /* _ are ignored -- but warned about if consecutive */
7316 if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
7317 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7318 "Misplaced _ in number");
7322 /* 8 and 9 are not octal */
7325 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
7329 case '2': case '3': case '4':
7330 case '5': case '6': case '7':
7332 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
7336 b = *s++ & 15; /* ASCII digit -> value of digit */
7340 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
7341 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
7342 /* make sure they said 0x */
7347 /* Prepare to put the digit we have onto the end
7348 of the number so far. We check for overflows.
7354 x = u << shift; /* make room for the digit */
7356 if ((x >> shift) != u
7357 && !(PL_hints & HINT_NEW_BINARY)) {
7360 if (ckWARN_d(WARN_OVERFLOW))
7361 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
7362 "Integer overflow in %s number",
7365 u = x | b; /* add the digit to the end */
7368 n *= nvshift[shift];
7369 /* If an NV has not enough bits in its
7370 * mantissa to represent an UV this summing of
7371 * small low-order numbers is a waste of time
7372 * (because the NV cannot preserve the
7373 * low-order bits anyway): we could just
7374 * remember when did we overflow and in the
7375 * end just multiply n by the right
7383 /* if we get here, we had success: make a scalar value from
7388 /* final misplaced underbar check */
7390 if (ckWARN(WARN_SYNTAX))
7391 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
7396 if (ckWARN(WARN_PORTABLE) && n > 4294967295.0)
7397 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
7398 "%s number > %s non-portable",
7404 if (ckWARN(WARN_PORTABLE) && u > 0xffffffff)
7405 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
7406 "%s number > %s non-portable",
7411 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
7412 sv = new_constant(start, s - start, "integer",
7414 else if (PL_hints & HINT_NEW_BINARY)
7415 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
7420 handle decimal numbers.
7421 we're also sent here when we read a 0 as the first digit
7423 case '1': case '2': case '3': case '4': case '5':
7424 case '6': case '7': case '8': case '9': case '.':
7427 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
7430 /* read next group of digits and _ and copy into d */
7431 while (isDIGIT(*s) || *s == '_') {
7432 /* skip underscores, checking for misplaced ones
7436 if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
7437 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7438 "Misplaced _ in number");
7442 /* check for end of fixed-length buffer */
7444 Perl_croak(aTHX_ number_too_long);
7445 /* if we're ok, copy the character */
7450 /* final misplaced underbar check */
7451 if (lastub && s == lastub + 1) {
7452 if (ckWARN(WARN_SYNTAX))
7453 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
7456 /* read a decimal portion if there is one. avoid
7457 3..5 being interpreted as the number 3. followed
7460 if (*s == '.' && s[1] != '.') {
7465 if (ckWARN(WARN_SYNTAX))
7466 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7467 "Misplaced _ in number");
7471 /* copy, ignoring underbars, until we run out of digits.
7473 for (; isDIGIT(*s) || *s == '_'; s++) {
7474 /* fixed length buffer check */
7476 Perl_croak(aTHX_ number_too_long);
7478 if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
7479 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7480 "Misplaced _ in number");
7486 /* fractional part ending in underbar? */
7488 if (ckWARN(WARN_SYNTAX))
7489 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7490 "Misplaced _ in number");
7492 if (*s == '.' && isDIGIT(s[1])) {
7493 /* oops, it's really a v-string, but without the "v" */
7499 /* read exponent part, if present */
7500 if (*s && strchr("eE",*s) && strchr("+-0123456789_", s[1])) {
7504 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
7505 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
7507 /* stray preinitial _ */
7509 if (ckWARN(WARN_SYNTAX))
7510 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7511 "Misplaced _ in number");
7515 /* allow positive or negative exponent */
7516 if (*s == '+' || *s == '-')
7519 /* stray initial _ */
7521 if (ckWARN(WARN_SYNTAX))
7522 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7523 "Misplaced _ in number");
7527 /* read digits of exponent */
7528 while (isDIGIT(*s) || *s == '_') {
7531 Perl_croak(aTHX_ number_too_long);
7535 if (ckWARN(WARN_SYNTAX) &&
7536 ((lastub && s == lastub + 1) ||
7537 (!isDIGIT(s[1]) && s[1] != '_')))
7538 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7539 "Misplaced _ in number");
7546 /* make an sv from the string */
7550 We try to do an integer conversion first if no characters
7551 indicating "float" have been found.
7556 int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
7558 if (flags == IS_NUMBER_IN_UV) {
7560 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
7563 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
7564 if (uv <= (UV) IV_MIN)
7565 sv_setiv(sv, -(IV)uv);
7572 /* terminate the string */
7574 nv = Atof(PL_tokenbuf);
7578 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
7579 (PL_hints & HINT_NEW_INTEGER) )
7580 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
7581 (floatit ? "float" : "integer"),
7585 /* if it starts with a v, it could be a v-string */
7588 sv = NEWSV(92,5); /* preallocate storage space */
7589 s = scan_vstring(s,sv);
7593 /* make the op for the constant and return */
7596 lvalp->opval = newSVOP(OP_CONST, 0, sv);
7598 lvalp->opval = Nullop;
7604 S_scan_formline(pTHX_ register char *s)
7608 SV *stuff = newSVpvn("",0);
7609 bool needargs = FALSE;
7613 if (*s == '.' || *s == /*{*/'}') {
7615 #ifdef PERL_STRICT_CR
7616 for (t = s+1;SPACE_OR_TAB(*t); t++) ;
7618 for (t = s+1;SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
7620 if (*t == '\n' || t == PL_bufend) {
7625 if (PL_in_eval && !PL_rsfp) {
7626 eol = strchr(s,'\n');
7631 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7633 for (t = s; t < eol; t++) {
7634 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
7636 goto enough; /* ~~ must be first line in formline */
7638 if (*t == '@' || *t == '^')
7642 sv_catpvn(stuff, s, eol-s);
7643 #ifndef PERL_STRICT_CR
7644 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
7645 char *end = SvPVX(stuff) + SvCUR(stuff);
7657 s = filter_gets(PL_linestr, PL_rsfp, 0);
7658 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
7659 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
7660 PL_last_lop = PL_last_uni = Nullch;
7672 PL_lex_state = LEX_NORMAL;
7673 PL_nextval[PL_nexttoke].ival = 0;
7677 PL_lex_state = LEX_FORMLINE;
7679 if (UTF && is_utf8_string((U8*)SvPVX(stuff), SvCUR(stuff)))
7681 else if (PL_encoding)
7682 sv_recode_to_utf8(stuff, PL_encoding);
7684 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
7686 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
7690 SvREFCNT_dec(stuff);
7692 PL_lex_formbrack = 0;
7703 PL_cshlen = strlen(PL_cshname);
7708 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
7710 I32 oldsavestack_ix = PL_savestack_ix;
7711 CV* outsidecv = PL_compcv;
7714 assert(SvTYPE(PL_compcv) == SVt_PVCV);
7716 SAVEI32(PL_subline);
7717 save_item(PL_subname);
7718 SAVESPTR(PL_compcv);
7720 PL_compcv = (CV*)NEWSV(1104,0);
7721 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
7722 CvFLAGS(PL_compcv) |= flags;
7724 PL_subline = CopLINE(PL_curcop);
7725 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
7726 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
7727 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
7729 return oldsavestack_ix;
7733 #pragma segment Perl_yylex
7736 Perl_yywarn(pTHX_ char *s)
7738 PL_in_eval |= EVAL_WARNONLY;
7740 PL_in_eval &= ~EVAL_WARNONLY;
7745 Perl_yyerror(pTHX_ char *s)
7748 char *context = NULL;
7752 if (!yychar || (yychar == ';' && !PL_rsfp))
7754 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
7755 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
7758 The code below is removed for NetWare because it abends/crashes on NetWare
7759 when the script has error such as not having the closing quotes like:
7761 Checking of white spaces is anyway done in NetWare code.
7764 while (isSPACE(*PL_oldoldbufptr))
7767 context = PL_oldoldbufptr;
7768 contlen = PL_bufptr - PL_oldoldbufptr;
7770 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
7771 PL_oldbufptr != PL_bufptr) {
7774 The code below is removed for NetWare because it abends/crashes on NetWare
7775 when the script has error such as not having the closing quotes like:
7777 Checking of white spaces is anyway done in NetWare code.
7780 while (isSPACE(*PL_oldbufptr))
7783 context = PL_oldbufptr;
7784 contlen = PL_bufptr - PL_oldbufptr;
7786 else if (yychar > 255)
7787 where = "next token ???";
7788 #ifdef USE_PURE_BISON
7789 /* GNU Bison sets the value -2 */
7790 else if (yychar == -2) {
7792 else if ((yychar & 127) == 127) {
7794 if (PL_lex_state == LEX_NORMAL ||
7795 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
7796 where = "at end of line";
7797 else if (PL_lex_inpat)
7798 where = "within pattern";
7800 where = "within string";
7803 SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
7805 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
7806 else if (isPRINT_LC(yychar))
7807 Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
7809 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
7810 where = SvPVX(where_sv);
7812 msg = sv_2mortal(newSVpv(s, 0));
7813 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
7814 OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
7816 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
7818 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
7819 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
7820 Perl_sv_catpvf(aTHX_ msg,
7821 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
7822 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
7825 if (PL_in_eval & EVAL_WARNONLY)
7826 Perl_warn(aTHX_ "%"SVf, msg);
7829 if (PL_error_count >= 10) {
7830 if (PL_in_eval && SvCUR(ERRSV))
7831 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
7832 ERRSV, OutCopFILE(PL_curcop));
7834 Perl_croak(aTHX_ "%s has too many errors.\n",
7835 OutCopFILE(PL_curcop));
7838 PL_in_my_stash = Nullhv;
7842 #pragma segment Main
7846 S_swallow_bom(pTHX_ U8 *s)
7849 slen = SvCUR(PL_linestr);
7853 /* UTF-16 little-endian */
7854 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
7855 Perl_croak(aTHX_ "Unsupported script encoding");
7856 #ifndef PERL_NO_UTF16_FILTER
7857 DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-LE script encoding\n"));
7859 if (PL_bufend > (char*)s) {
7863 filter_add(utf16rev_textfilter, NULL);
7864 New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
7865 PL_bufend = (char*)utf16_to_utf8_reversed(s, news,
7866 PL_bufend - (char*)s - 1,
7868 Copy(news, s, newlen, U8);
7869 SvCUR_set(PL_linestr, newlen);
7870 PL_bufend = SvPVX(PL_linestr) + newlen;
7871 news[newlen++] = '\0';
7875 Perl_croak(aTHX_ "Unsupported script encoding");
7880 if (s[1] == 0xFF) { /* UTF-16 big-endian */
7881 #ifndef PERL_NO_UTF16_FILTER
7882 DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding\n"));
7884 if (PL_bufend > (char *)s) {
7888 filter_add(utf16_textfilter, NULL);
7889 New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
7890 PL_bufend = (char*)utf16_to_utf8(s, news,
7891 PL_bufend - (char*)s,
7893 Copy(news, s, newlen, U8);
7894 SvCUR_set(PL_linestr, newlen);
7895 PL_bufend = SvPVX(PL_linestr) + newlen;
7896 news[newlen++] = '\0';
7900 Perl_croak(aTHX_ "Unsupported script encoding");
7905 if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
7906 DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-8 script encoding\n"));
7911 if (slen > 3 && s[1] == 0 && /* UTF-32 big-endian */
7912 s[2] == 0xFE && s[3] == 0xFF)
7914 Perl_croak(aTHX_ "Unsupported script encoding");
7922 * Restore a source filter.
7926 restore_rsfp(pTHX_ void *f)
7928 PerlIO *fp = (PerlIO*)f;
7930 if (PL_rsfp == PerlIO_stdin())
7931 PerlIO_clearerr(PL_rsfp);
7932 else if (PL_rsfp && (PL_rsfp != fp))
7933 PerlIO_close(PL_rsfp);
7937 #ifndef PERL_NO_UTF16_FILTER
7939 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
7941 I32 count = FILTER_READ(idx+1, sv, maxlen);
7946 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
7947 if (!*SvPV_nolen(sv))
7948 /* Game over, but don't feed an odd-length string to utf16_to_utf8 */
7951 tend = utf16_to_utf8((U8*)SvPVX(sv), tmps, SvCUR(sv), &newlen);
7952 sv_usepvn(sv, (char*)tmps, tend - tmps);
7958 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
7960 I32 count = FILTER_READ(idx+1, sv, maxlen);
7965 if (!*SvPV_nolen(sv))
7966 /* Game over, but don't feed an odd-length string to utf16_to_utf8 */
7969 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
7970 tend = utf16_to_utf8_reversed((U8*)SvPVX(sv), tmps, SvCUR(sv), &newlen);
7971 sv_usepvn(sv, (char*)tmps, tend - tmps);
7978 Returns a pointer to the next character after the parsed
7979 vstring, as well as updating the passed in sv.
7981 Function must be called like
7984 s = scan_vstring(s,sv);
7986 The sv should already be large enough to store the vstring
7987 passed in, for performance reasons.
7992 Perl_scan_vstring(pTHX_ char *s, SV *sv)
7996 if (*pos == 'v') pos++; /* get past 'v' */
7997 while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
8000 /* this may not be a v-string if followed by => */
8002 while (next < PL_bufend && isSPACE(*next))
8004 if ((PL_bufend - next) >= 2 && *next == '=' && next[1] == '>' ) {
8005 /* return string not v-string */
8006 sv_setpvn(sv,(char *)s,pos-s);
8011 if (!isALPHA(*pos)) {
8013 U8 tmpbuf[UTF8_MAXLEN+1];
8016 if (*s == 'v') s++; /* get past 'v' */
8018 sv_setpvn(sv, "", 0);
8023 /* this is atoi() that tolerates underscores */
8026 while (--end >= s) {
8031 rev += (*end - '0') * mult;
8033 if (orev > rev && ckWARN_d(WARN_OVERFLOW))
8034 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
8035 "Integer overflow in decimal number");
8039 if (rev > 0x7FFFFFFF)
8040 Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
8042 /* Append native character for the rev point */
8043 tmpend = uvchr_to_utf8(tmpbuf, rev);
8044 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
8045 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
8047 if (pos + 1 < PL_bufend && *pos == '.' && isDIGIT(pos[1]))
8053 while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
8057 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);