3 * Copyright (c) 1991-2000, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "It all comes from here, the stench and the peril." --Frodo
15 * This file is the lexer for Perl. It's closely linked to the
18 * The main routine is yylex(), which returns the next token.
22 #define PERL_IN_TOKE_C
25 #define yychar PL_yychar
26 #define yylval PL_yylval
28 static char ident_too_long[] = "Identifier too long";
30 static void restore_rsfp(pTHXo_ void *f);
32 #define XFAKEBRACK 128
35 /*#define UTF (SvUTF8(PL_linestr) && !(PL_hints & HINT_BYTE))*/
36 #define UTF (PL_hints & HINT_UTF8)
38 /* In variables name $^X, these are the legal values for X.
39 * 1999-02-27 mjd-perl-patch@plover.com */
40 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
42 /* On MacOS, respect nonbreaking spaces */
43 #ifdef MACOS_TRADITIONAL
44 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\312'||(c)=='\t')
46 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\t')
49 /* LEX_* are values for PL_lex_state, the state of the lexer.
50 * They are arranged oddly so that the guard on the switch statement
51 * can get by with a single comparison (if the compiler is smart enough).
54 /* #define LEX_NOTPARSING 11 is done in perl.h. */
57 #define LEX_INTERPNORMAL 9
58 #define LEX_INTERPCASEMOD 8
59 #define LEX_INTERPPUSH 7
60 #define LEX_INTERPSTART 6
61 #define LEX_INTERPEND 5
62 #define LEX_INTERPENDMAYBE 4
63 #define LEX_INTERPCONCAT 3
64 #define LEX_INTERPCONST 2
65 #define LEX_FORMLINE 1
66 #define LEX_KNOWNEXT 0
68 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
70 # include <unistd.h> /* Needed for execv() */
79 YYSTYPE* yylval_pointer = NULL;
80 int* yychar_pointer = NULL;
83 # define yylval (*yylval_pointer)
84 # define yychar (*yychar_pointer)
85 # define PERL_YYLEX_PARAM yylval_pointer,yychar_pointer
87 # define yylex() Perl_yylex(aTHX_ yylval_pointer, yychar_pointer)
92 /* CLINE is a macro that ensures PL_copline has a sane value */
97 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
100 * Convenience functions to return different tokens and prime the
101 * lexer for the next token. They all take an argument.
103 * TOKEN : generic token (used for '(', DOLSHARP, etc)
104 * OPERATOR : generic operator
105 * AOPERATOR : assignment operator
106 * PREBLOCK : beginning the block after an if, while, foreach, ...
107 * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
108 * PREREF : *EXPR where EXPR is not a simple identifier
109 * TERM : expression term
110 * LOOPX : loop exiting command (goto, last, dump, etc)
111 * FTST : file test operator
112 * FUN0 : zero-argument function
113 * FUN1 : not used, except for not, which isn't a UNIOP
114 * BOop : bitwise or or xor
116 * SHop : shift operator
117 * PWop : power operator
118 * PMop : pattern-matching operator
119 * Aop : addition-level operator
120 * Mop : multiplication-level operator
121 * Eop : equality-testing operator
122 * Rop : relational operator <= != gt
124 * Also see LOP and lop() below.
127 #define TOKEN(retval) return (PL_bufptr = s,(int)retval)
128 #define OPERATOR(retval) return (PL_expect = XTERM,PL_bufptr = s,(int)retval)
129 #define AOPERATOR(retval) return ao((PL_expect = XTERM,PL_bufptr = s,(int)retval))
130 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s,(int)retval)
131 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval)
132 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s,(int)retval)
133 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR,PL_bufptr = s,(int)retval)
134 #define LOOPX(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX)
135 #define FTST(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)UNIOP)
136 #define FUN0(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0)
137 #define FUN1(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1)
138 #define BOop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITOROP))
139 #define BAop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP))
140 #define SHop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP))
141 #define PWop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)POWOP))
142 #define PMop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP)
143 #define Aop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)ADDOP))
144 #define Mop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MULOP))
145 #define Eop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)EQOP)
146 #define Rop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)RELOP)
148 /* This bit of chicanery makes a unary function followed by
149 * a parenthesis into a function with one argument, highest precedence.
151 #define UNI(f) return(yylval.ival = f, \
154 PL_last_uni = PL_oldbufptr, \
155 PL_last_lop_op = f, \
156 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
158 #define UNIBRACK(f) return(yylval.ival = f, \
160 PL_last_uni = PL_oldbufptr, \
161 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
163 /* grandfather return to old style */
164 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
169 * This subroutine detects &&= and ||= and turns an ANDAND or OROR
170 * into an OP_ANDASSIGN or OP_ORASSIGN
174 S_ao(pTHX_ int toketype)
176 if (*PL_bufptr == '=') {
178 if (toketype == ANDAND)
179 yylval.ival = OP_ANDASSIGN;
180 else if (toketype == OROR)
181 yylval.ival = OP_ORASSIGN;
189 * When Perl expects an operator and finds something else, no_op
190 * prints the warning. It always prints "<something> found where
191 * operator expected. It prints "Missing semicolon on previous line?"
192 * if the surprise occurs at the start of the line. "do you need to
193 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
194 * where the compiler doesn't know if foo is a method call or a function.
195 * It prints "Missing operator before end of line" if there's nothing
196 * after the missing operator, or "... before <...>" if there is something
197 * after the missing operator.
201 S_no_op(pTHX_ char *what, char *s)
203 char *oldbp = PL_bufptr;
204 bool is_first = (PL_oldbufptr == PL_linestart);
212 yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
214 Perl_warn(aTHX_ "\t(Missing semicolon on previous line?)\n");
215 else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
217 for (t = PL_oldoldbufptr; *t && (isALNUM_lazy_if(t,UTF) || *t == ':'); t++) ;
218 if (t < PL_bufptr && isSPACE(*t))
219 Perl_warn(aTHX_ "\t(Do you need to predeclare %.*s?)\n",
220 t - PL_oldoldbufptr, PL_oldoldbufptr);
223 Perl_warn(aTHX_ "\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
229 * Complain about missing quote/regexp/heredoc terminator.
230 * If it's called with (char *)NULL then it cauterizes the line buffer.
231 * If we're in a delimited string and the delimiter is a control
232 * character, it's reformatted into a two-char sequence like ^C.
237 S_missingterm(pTHX_ char *s)
242 char *nl = strrchr(s,'\n');
248 iscntrl(PL_multi_close)
250 PL_multi_close < 32 || PL_multi_close == 127
254 tmpbuf[1] = toCTRL(PL_multi_close);
260 *tmpbuf = PL_multi_close;
264 q = strchr(s,'"') ? '\'' : '"';
265 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
273 Perl_deprecate(pTHX_ char *s)
276 if (ckWARN(WARN_DEPRECATED))
277 Perl_warner(aTHX_ WARN_DEPRECATED, "Use of %s is deprecated", s);
282 * Deprecate a comma-less variable list.
288 deprecate("comma-less variable list");
292 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
293 * utf16-to-utf8-reversed.
296 #ifdef PERL_CR_FILTER
300 register char *s = SvPVX(sv);
301 register char *e = s + SvCUR(sv);
302 /* outer loop optimized to do nothing if there are no CR-LFs */
304 if (*s++ == '\r' && *s == '\n') {
305 /* hit a CR-LF, need to copy the rest */
306 register char *d = s - 1;
309 if (*s == '\r' && s[1] == '\n')
320 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
322 I32 count = FILTER_READ(idx+1, sv, maxlen);
323 if (count > 0 && !maxlen)
331 S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
333 I32 count = FILTER_READ(idx+1, sv, maxlen);
337 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
338 tend = utf16_to_utf8((U16*)SvPVX(sv), tmps, SvCUR(sv));
339 sv_usepvn(sv, (char*)tmps, tend - tmps);
345 S_utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
347 I32 count = FILTER_READ(idx+1, sv, maxlen);
351 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
352 tend = utf16_to_utf8_reversed((U16*)SvPVX(sv), tmps, SvCUR(sv));
353 sv_usepvn(sv, (char*)tmps, tend - tmps);
361 * Initialize variables. Uses the Perl save_stack to save its state (for
362 * recursive calls to the parser).
366 Perl_lex_start(pTHX_ SV *line)
372 SAVEI32(PL_lex_dojoin);
373 SAVEI32(PL_lex_brackets);
374 SAVEI32(PL_lex_casemods);
375 SAVEI32(PL_lex_starts);
376 SAVEI32(PL_lex_state);
377 SAVEVPTR(PL_lex_inpat);
378 SAVEI32(PL_lex_inwhat);
379 if (PL_lex_state == LEX_KNOWNEXT) {
380 I32 toke = PL_nexttoke;
381 while (--toke >= 0) {
382 SAVEI32(PL_nexttype[toke]);
383 SAVEVPTR(PL_nextval[toke]);
385 SAVEI32(PL_nexttoke);
388 SAVECOPLINE(PL_curcop);
391 SAVEPPTR(PL_oldbufptr);
392 SAVEPPTR(PL_oldoldbufptr);
393 SAVEPPTR(PL_linestart);
394 SAVESPTR(PL_linestr);
395 SAVEPPTR(PL_lex_brackstack);
396 SAVEPPTR(PL_lex_casestack);
397 SAVEDESTRUCTOR_X(restore_rsfp, PL_rsfp);
398 SAVESPTR(PL_lex_stuff);
399 SAVEI32(PL_lex_defer);
400 SAVEI32(PL_sublex_info.sub_inwhat);
401 SAVESPTR(PL_lex_repl);
403 SAVEINT(PL_lex_expect);
405 PL_lex_state = LEX_NORMAL;
409 New(899, PL_lex_brackstack, 120, char);
410 New(899, PL_lex_casestack, 12, char);
411 SAVEFREEPV(PL_lex_brackstack);
412 SAVEFREEPV(PL_lex_casestack);
414 *PL_lex_casestack = '\0';
417 PL_lex_stuff = Nullsv;
418 PL_lex_repl = Nullsv;
421 PL_sublex_info.sub_inwhat = 0;
423 if (SvREADONLY(PL_linestr))
424 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
425 s = SvPV(PL_linestr, len);
426 if (len && s[len-1] != ';') {
427 if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
428 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
429 sv_catpvn(PL_linestr, "\n;", 2);
431 SvTEMP_off(PL_linestr);
432 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
433 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
435 PL_rs = newSVpvn("\n", 1);
441 * Finalizer for lexing operations. Must be called when the parser is
442 * done with the lexer.
448 PL_doextract = FALSE;
453 * This subroutine has nothing to do with tilting, whether at windmills
454 * or pinball tables. Its name is short for "increment line". It
455 * increments the current line number in CopLINE(PL_curcop) and checks
456 * to see whether the line starts with a comment of the form
457 * # line 500 "foo.pm"
458 * If so, it sets the current line number and file to the values in the comment.
462 S_incline(pTHX_ char *s)
470 CopLINE_inc(PL_curcop);
473 while (SPACE_OR_TAB(*s)) s++;
474 if (strnEQ(s, "line", 4))
478 if (*s == ' ' || *s == '\t')
482 while (SPACE_OR_TAB(*s)) s++;
488 while (SPACE_OR_TAB(*s))
490 if (*s == '"' && (t = strchr(s+1, '"'))) {
495 for (t = s; !isSPACE(*t); t++) ;
498 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
500 if (*e != '\n' && *e != '\0')
501 return; /* false alarm */
506 CopFILE_set(PL_curcop, s);
508 CopLINE_set(PL_curcop, atoi(n)-1);
513 * Called to gobble the appropriate amount and type of whitespace.
514 * Skips comments as well.
518 S_skipspace(pTHX_ register char *s)
521 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
522 while (s < PL_bufend && SPACE_OR_TAB(*s))
528 SSize_t oldprevlen, oldoldprevlen;
529 SSize_t oldloplen, oldunilen;
530 while (s < PL_bufend && isSPACE(*s)) {
531 if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
536 if (s < PL_bufend && *s == '#') {
537 while (s < PL_bufend && *s != '\n')
541 if (PL_in_eval && !PL_rsfp) {
548 /* only continue to recharge the buffer if we're at the end
549 * of the buffer, we're not reading from a source filter, and
550 * we're in normal lexing mode
552 if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat ||
553 PL_lex_state == LEX_FORMLINE)
556 /* try to recharge the buffer */
557 if ((s = filter_gets(PL_linestr, PL_rsfp,
558 (prevlen = SvCUR(PL_linestr)))) == Nullch)
560 /* end of file. Add on the -p or -n magic */
561 if (PL_minus_n || PL_minus_p) {
562 sv_setpv(PL_linestr,PL_minus_p ?
563 ";}continue{print or die qq(-p destination: $!\\n)" :
565 sv_catpv(PL_linestr,";}");
566 PL_minus_n = PL_minus_p = 0;
569 sv_setpv(PL_linestr,";");
571 /* reset variables for next time we lex */
572 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
574 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
576 /* Close the filehandle. Could be from -P preprocessor,
577 * STDIN, or a regular file. If we were reading code from
578 * STDIN (because the commandline held no -e or filename)
579 * then we don't close it, we reset it so the code can
580 * read from STDIN too.
583 if (PL_preprocess && !PL_in_eval)
584 (void)PerlProc_pclose(PL_rsfp);
585 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
586 PerlIO_clearerr(PL_rsfp);
588 (void)PerlIO_close(PL_rsfp);
593 /* not at end of file, so we only read another line */
594 /* make corresponding updates to old pointers, for yyerror() */
595 oldprevlen = PL_oldbufptr - PL_bufend;
596 oldoldprevlen = PL_oldoldbufptr - PL_bufend;
598 oldunilen = PL_last_uni - PL_bufend;
600 oldloplen = PL_last_lop - PL_bufend;
601 PL_linestart = PL_bufptr = s + prevlen;
602 PL_bufend = s + SvCUR(PL_linestr);
604 PL_oldbufptr = s + oldprevlen;
605 PL_oldoldbufptr = s + oldoldprevlen;
607 PL_last_uni = s + oldunilen;
609 PL_last_lop = s + oldloplen;
612 /* debugger active and we're not compiling the debugger code,
613 * so store the line into the debugger's array of lines
615 if (PERLDB_LINE && PL_curstash != PL_debstash) {
616 SV *sv = NEWSV(85,0);
618 sv_upgrade(sv, SVt_PVMG);
619 sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
620 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
627 * Check the unary operators to ensure there's no ambiguity in how they're
628 * used. An ambiguous piece of code would be:
630 * This doesn't mean rand() + 5. Because rand() is a unary operator,
631 * the +5 is its argument.
641 if (PL_oldoldbufptr != PL_last_uni)
643 while (isSPACE(*PL_last_uni))
645 for (s = PL_last_uni; isALNUM_lazy_if(s,UTF) || *s == '-'; s++) ;
646 if ((t = strchr(s, '(')) && t < PL_bufptr)
648 if (ckWARN_d(WARN_AMBIGUOUS)){
651 Perl_warner(aTHX_ WARN_AMBIGUOUS,
652 "Warning: Use of \"%s\" without parens is ambiguous",
658 /* workaround to replace the UNI() macro with a function. Only the
659 * hints/uts.sh file mentions this. Other comments elsewhere in the
660 * source indicate Microport Unix might need it too.
666 #define UNI(f) return uni(f,s)
669 S_uni(pTHX_ I32 f, char *s)
674 PL_last_uni = PL_oldbufptr;
685 #endif /* CRIPPLED_CC */
688 * LOP : macro to build a list operator. Its behaviour has been replaced
689 * with a subroutine, S_lop() for which LOP is just another name.
692 #define LOP(f,x) return lop(f,x,s)
696 * Build a list operator (or something that might be one). The rules:
697 * - if we have a next token, then it's a list operator [why?]
698 * - if the next thing is an opening paren, then it's a function
699 * - else it's a list operator
703 S_lop(pTHX_ I32 f, int x, char *s)
710 PL_last_lop = PL_oldbufptr;
725 * When the lexer realizes it knows the next token (for instance,
726 * it is reordering tokens for the parser) then it can call S_force_next
727 * to know what token to return the next time the lexer is called. Caller
728 * will need to set PL_nextval[], and possibly PL_expect to ensure the lexer
729 * handles the token correctly.
733 S_force_next(pTHX_ I32 type)
735 PL_nexttype[PL_nexttoke] = type;
737 if (PL_lex_state != LEX_KNOWNEXT) {
738 PL_lex_defer = PL_lex_state;
739 PL_lex_expect = PL_expect;
740 PL_lex_state = LEX_KNOWNEXT;
746 * When the lexer knows the next thing is a word (for instance, it has
747 * just seen -> and it knows that the next char is a word char, then
748 * it calls S_force_word to stick the next word into the PL_next lookahead.
751 * char *start : buffer position (must be within PL_linestr)
752 * int token : PL_next will be this type of bare word (e.g., METHOD,WORD)
753 * int check_keyword : if true, Perl checks to make sure the word isn't
754 * a keyword (do this if the word is a label, e.g. goto FOO)
755 * int allow_pack : if true, : characters will also be allowed (require,
757 * int allow_initial_tick : used by the "sub" lexer only.
761 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
766 start = skipspace(start);
768 if (isIDFIRST_lazy_if(s,UTF) ||
769 (allow_pack && *s == ':') ||
770 (allow_initial_tick && *s == '\'') )
772 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
773 if (check_keyword && keyword(PL_tokenbuf, len))
775 if (token == METHOD) {
780 PL_expect = XOPERATOR;
783 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(PL_tokenbuf,0));
784 PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
792 * Called when the lexer wants $foo *foo &foo etc, but the program
793 * text only contains the "foo" portion. The first argument is a pointer
794 * to the "foo", and the second argument is the type symbol to prefix.
795 * Forces the next token to be a "WORD".
796 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
800 S_force_ident(pTHX_ register char *s, int kind)
803 OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
804 PL_nextval[PL_nexttoke].opval = o;
807 dTHR; /* just for in_eval */
808 o->op_private = OPpCONST_ENTERED;
809 /* XXX see note in pp_entereval() for why we forgo typo
810 warnings if the symbol must be introduced in an eval.
812 gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
813 kind == '$' ? SVt_PV :
814 kind == '@' ? SVt_PVAV :
815 kind == '%' ? SVt_PVHV :
823 Perl_str_to_version(pTHX_ SV *sv)
828 char *start = SvPVx(sv,len);
829 bool utf = SvUTF8(sv) ? TRUE : FALSE;
830 char *end = start + len;
831 while (start < end) {
835 n = utf8_to_uv((U8*)start, &skip);
840 retval += ((NV)n)/nshift;
849 * Forces the next token to be a version number.
853 S_force_version(pTHX_ char *s)
855 OP *version = Nullop;
864 for (; isDIGIT(*d) || *d == '_' || *d == '.'; d++);
865 if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
868 version = yylval.opval;
869 ver = cSVOPx(version)->op_sv;
870 if (SvPOK(ver) && !SvNIOK(ver)) {
871 (void)SvUPGRADE(ver, SVt_PVNV);
872 SvNVX(ver) = str_to_version(ver);
873 SvNOK_on(ver); /* hint that it is a version */
878 /* NOTE: The parser sees the package name and the VERSION swapped */
879 PL_nextval[PL_nexttoke].opval = version;
887 * Tokenize a quoted string passed in as an SV. It finds the next
888 * chunk, up to end of string or a backslash. It may make a new
889 * SV containing that chunk (if HINT_NEW_STRING is on). It also
894 S_tokeq(pTHX_ SV *sv)
905 s = SvPV_force(sv, len);
906 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
909 while (s < send && *s != '\\')
914 if ( PL_hints & HINT_NEW_STRING )
915 pv = sv_2mortal(newSVpvn(SvPVX(pv), len));
918 if (s + 1 < send && (s[1] == '\\'))
919 s++; /* all that, just for this */
924 SvCUR_set(sv, d - SvPVX(sv));
926 if ( PL_hints & HINT_NEW_STRING )
927 return new_constant(NULL, 0, "q", sv, pv, "q");
932 * Now come three functions related to double-quote context,
933 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
934 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
935 * interact with PL_lex_state, and create fake ( ... ) argument lists
936 * to handle functions and concatenation.
937 * They assume that whoever calls them will be setting up a fake
938 * join call, because each subthing puts a ',' after it. This lets
941 * join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
943 * (I'm not sure whether the spurious commas at the end of lcfirst's
944 * arguments and join's arguments are created or not).
949 * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST).
951 * Pattern matching will set PL_lex_op to the pattern-matching op to
952 * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise).
954 * OP_CONST and OP_READLINE are easy--just make the new op and return.
956 * Everything else becomes a FUNC.
958 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
959 * had an OP_CONST or OP_READLINE). This just sets us up for a
960 * call to S_sublex_push().
966 register I32 op_type = yylval.ival;
968 if (op_type == OP_NULL) {
969 yylval.opval = PL_lex_op;
973 if (op_type == OP_CONST || op_type == OP_READLINE) {
974 SV *sv = tokeq(PL_lex_stuff);
976 if (SvTYPE(sv) == SVt_PVIV) {
977 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
983 nsv = newSVpvn(p, len);
987 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
988 PL_lex_stuff = Nullsv;
992 PL_sublex_info.super_state = PL_lex_state;
993 PL_sublex_info.sub_inwhat = op_type;
994 PL_sublex_info.sub_op = PL_lex_op;
995 PL_lex_state = LEX_INTERPPUSH;
999 yylval.opval = PL_lex_op;
1009 * Create a new scope to save the lexing state. The scope will be
1010 * ended in S_sublex_done. Returns a '(', starting the function arguments
1011 * to the uc, lc, etc. found before.
1012 * Sets PL_lex_state to LEX_INTERPCONCAT.
1021 PL_lex_state = PL_sublex_info.super_state;
1022 SAVEI32(PL_lex_dojoin);
1023 SAVEI32(PL_lex_brackets);
1024 SAVEI32(PL_lex_casemods);
1025 SAVEI32(PL_lex_starts);
1026 SAVEI32(PL_lex_state);
1027 SAVEVPTR(PL_lex_inpat);
1028 SAVEI32(PL_lex_inwhat);
1029 SAVECOPLINE(PL_curcop);
1030 SAVEPPTR(PL_bufptr);
1031 SAVEPPTR(PL_oldbufptr);
1032 SAVEPPTR(PL_oldoldbufptr);
1033 SAVEPPTR(PL_linestart);
1034 SAVESPTR(PL_linestr);
1035 SAVEPPTR(PL_lex_brackstack);
1036 SAVEPPTR(PL_lex_casestack);
1038 PL_linestr = PL_lex_stuff;
1039 PL_lex_stuff = Nullsv;
1041 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
1042 = SvPVX(PL_linestr);
1043 PL_bufend += SvCUR(PL_linestr);
1044 SAVEFREESV(PL_linestr);
1046 PL_lex_dojoin = FALSE;
1047 PL_lex_brackets = 0;
1048 New(899, PL_lex_brackstack, 120, char);
1049 New(899, PL_lex_casestack, 12, char);
1050 SAVEFREEPV(PL_lex_brackstack);
1051 SAVEFREEPV(PL_lex_casestack);
1052 PL_lex_casemods = 0;
1053 *PL_lex_casestack = '\0';
1055 PL_lex_state = LEX_INTERPCONCAT;
1056 CopLINE_set(PL_curcop, PL_multi_start);
1058 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1059 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1060 PL_lex_inpat = PL_sublex_info.sub_op;
1062 PL_lex_inpat = Nullop;
1069 * Restores lexer state after a S_sublex_push.
1075 if (!PL_lex_starts++) {
1076 PL_expect = XOPERATOR;
1077 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpvn("",0));
1081 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
1082 PL_lex_state = LEX_INTERPCASEMOD;
1086 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1087 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1088 PL_linestr = PL_lex_repl;
1090 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1091 PL_bufend += SvCUR(PL_linestr);
1092 SAVEFREESV(PL_linestr);
1093 PL_lex_dojoin = FALSE;
1094 PL_lex_brackets = 0;
1095 PL_lex_casemods = 0;
1096 *PL_lex_casestack = '\0';
1098 if (SvEVALED(PL_lex_repl)) {
1099 PL_lex_state = LEX_INTERPNORMAL;
1101 /* we don't clear PL_lex_repl here, so that we can check later
1102 whether this is an evalled subst; that means we rely on the
1103 logic to ensure sublex_done() is called again only via the
1104 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1107 PL_lex_state = LEX_INTERPCONCAT;
1108 PL_lex_repl = Nullsv;
1114 PL_bufend = SvPVX(PL_linestr);
1115 PL_bufend += SvCUR(PL_linestr);
1116 PL_expect = XOPERATOR;
1117 PL_sublex_info.sub_inwhat = 0;
1125 Extracts a pattern, double-quoted string, or transliteration. This
1128 It looks at lex_inwhat and PL_lex_inpat to find out whether it's
1129 processing a pattern (PL_lex_inpat is true), a transliteration
1130 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
1132 Returns a pointer to the character scanned up to. Iff this is
1133 advanced from the start pointer supplied (ie if anything was
1134 successfully parsed), will leave an OP for the substring scanned
1135 in yylval. Caller must intuit reason for not parsing further
1136 by looking at the next characters herself.
1140 double-quoted style: \r and \n
1141 regexp special ones: \D \s
1143 backrefs: \1 (deprecated in substitution replacements)
1144 case and quoting: \U \Q \E
1145 stops on @ and $, but not for $ as tail anchor
1147 In transliterations:
1148 characters are VERY literal, except for - not at the start or end
1149 of the string, which indicates a range. scan_const expands the
1150 range to the full set of intermediate characters.
1152 In double-quoted strings:
1154 double-quoted style: \r and \n
1156 backrefs: \1 (deprecated)
1157 case and quoting: \U \Q \E
1160 scan_const does *not* construct ops to handle interpolated strings.
1161 It stops processing as soon as it finds an embedded $ or @ variable
1162 and leaves it to the caller to work out what's going on.
1164 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
1166 $ in pattern could be $foo or could be tail anchor. Assumption:
1167 it's a tail anchor if $ is the last thing in the string, or if it's
1168 followed by one of ")| \n\t"
1170 \1 (backreferences) are turned into $1
1172 The structure of the code is
1173 while (there's a character to process) {
1174 handle transliteration ranges
1175 skip regexp comments
1176 skip # initiated comments in //x patterns
1177 check for embedded @foo
1178 check for embedded scalars
1180 leave intact backslashes from leave (below)
1181 deprecate \1 in strings and sub replacements
1182 handle string-changing backslashes \l \U \Q \E, etc.
1183 switch (what was escaped) {
1184 handle - in a transliteration (becomes a literal -)
1185 handle \132 octal characters
1186 handle 0x15 hex characters
1187 handle \cV (control V)
1188 handle printf backslashes (\f, \r, \n, etc)
1190 } (end if backslash)
1191 } (end while character to read)
1196 S_scan_const(pTHX_ char *start)
1198 register char *send = PL_bufend; /* end of the constant */
1199 SV *sv = NEWSV(93, send - start); /* sv for the constant */
1200 register char *s = start; /* start of the constant */
1201 register char *d = SvPVX(sv); /* destination for copies */
1202 bool dorange = FALSE; /* are we in a translit range? */
1203 bool has_utf = FALSE; /* embedded \x{} */
1207 I32 utf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op)
1208 ? (PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
1210 I32 thisutf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op)
1211 ? (PL_sublex_info.sub_op->op_private & (PL_lex_repl ?
1212 OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF))
1214 const char *leaveit = /* set of acceptably-backslashed characters */
1216 ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
1219 while (s < send || dorange) {
1220 /* get transliterations out of the way (they're most literal) */
1221 if (PL_lex_inwhat == OP_TRANS) {
1222 /* expand a range A-Z to the full set of characters. AIE! */
1224 I32 i; /* current expanded character */
1225 I32 min; /* first character in range */
1226 I32 max; /* last character in range */
1228 i = d - SvPVX(sv); /* remember current offset */
1229 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
1230 d = SvPVX(sv) + i; /* refresh d after realloc */
1231 d -= 2; /* eat the first char and the - */
1233 min = (U8)*d; /* first char in range */
1234 max = (U8)d[1]; /* last char in range */
1237 if ((isLOWER(min) && isLOWER(max)) ||
1238 (isUPPER(min) && isUPPER(max))) {
1240 for (i = min; i <= max; i++)
1244 for (i = min; i <= max; i++)
1251 for (i = min; i <= max; i++)
1254 /* mark the range as done, and continue */
1259 /* range begins (ignore - as first or last char) */
1260 else if (*s == '-' && s+1 < send && s != start) {
1262 *d++ = (char)0xff; /* use illegal utf8 byte--see pmtrans */
1271 /* if we get here, we're not doing a transliteration */
1273 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
1274 except for the last char, which will be done separately. */
1275 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
1277 while (s < send && *s != ')')
1280 else if (s[2] == '{' /* This should match regcomp.c */
1281 || ((s[2] == 'p' || s[2] == '?') && s[3] == '{'))
1284 char *regparse = s + (s[2] == '{' ? 3 : 4);
1287 while (count && (c = *regparse)) {
1288 if (c == '\\' && regparse[1])
1296 if (*regparse != ')') {
1297 regparse--; /* Leave one char for continuation. */
1298 yyerror("Sequence (?{...}) not terminated or not {}-balanced");
1300 while (s < regparse)
1305 /* likewise skip #-initiated comments in //x patterns */
1306 else if (*s == '#' && PL_lex_inpat &&
1307 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
1308 while (s+1 < send && *s != '\n')
1312 /* check for embedded arrays (@foo, @:foo, @'foo, @{foo}, @$foo) */
1313 else if (*s == '@' && s[1]
1314 && (isALNUM_lazy_if(s+1,UTF) || strchr(":'{$", s[1])))
1317 /* check for embedded scalars. only stop if we're sure it's a
1320 else if (*s == '$') {
1321 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
1323 if (s + 1 < send && !strchr("()| \n\t", s[1]))
1324 break; /* in regexp, $ might be tail anchor */
1327 /* (now in tr/// code again) */
1329 if (*s & 0x80 && thisutf) {
1330 (void)utf8_to_uv((U8*)s, &len);
1332 /* illegal UTF8, make it valid */
1333 char *old_pvx = SvPVX(sv);
1334 /* need space for one extra char (NOTE: SvCUR() not set here) */
1335 d = SvGROW(sv, SvLEN(sv) + 1) + (d - old_pvx);
1336 d = (char*)uv_to_utf8((U8*)d, (U8)*s++);
1347 if (*s == '\\' && s+1 < send) {
1350 /* some backslashes we leave behind */
1351 if (*leaveit && *s && strchr(leaveit, *s)) {
1357 /* deprecate \1 in strings and substitution replacements */
1358 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1359 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1361 dTHR; /* only for ckWARN */
1362 if (ckWARN(WARN_SYNTAX))
1363 Perl_warner(aTHX_ WARN_SYNTAX, "\\%c better written as $%c", *s, *s);
1368 /* string-change backslash escapes */
1369 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1374 /* if we get here, it's either a quoted -, or a digit */
1377 /* quoted - in transliterations */
1379 if (PL_lex_inwhat == OP_TRANS) {
1387 if (ckWARN(WARN_MISC) && isALNUM(*s))
1388 Perl_warner(aTHX_ WARN_MISC,
1389 "Unrecognized escape \\%c passed through",
1391 /* default action is to copy the quoted character */
1396 /* \132 indicates an octal constant */
1397 case '0': case '1': case '2': case '3':
1398 case '4': case '5': case '6': case '7':
1399 len = 0; /* disallow underscores */
1400 uv = (UV)scan_oct(s, 3, &len);
1402 goto NUM_ESCAPE_INSERT;
1404 /* \x24 indicates a hex constant */
1408 char* e = strchr(s, '}');
1410 yyerror("Missing right brace on \\x{}");
1413 len = 1; /* allow underscores */
1414 uv = (UV)scan_hex(s + 1, e - s - 1, &len);
1418 len = 0; /* disallow underscores */
1419 uv = (UV)scan_hex(s, 2, &len);
1424 /* Insert oct or hex escaped character.
1425 * There will always enough room in sv since such escapes will
1426 * be longer than any utf8 sequence they can end up as
1429 if (!thisutf && !has_utf && uv > 255) {
1430 /* might need to recode whatever we have accumulated so far
1431 * if it contains any hibit chars
1435 for (c = SvPVX(sv); c < d; c++) {
1440 char *old_pvx = SvPVX(sv);
1442 d = SvGROW(sv, SvCUR(sv) + hicount + 1) + (d - old_pvx);
1451 uv_to_utf8((U8*)dst, (U8)*src--);
1461 if (thisutf || uv > 255) {
1462 d = (char*)uv_to_utf8((U8*)d, uv);
1474 /* \N{latin small letter a} is a named character */
1478 char* e = strchr(s, '}');
1484 yyerror("Missing right brace on \\N{}");
1488 res = newSVpvn(s + 1, e - s - 1);
1489 res = new_constant( Nullch, 0, "charnames",
1490 res, Nullsv, "\\N{...}" );
1491 str = SvPV(res,len);
1492 if (!has_utf && SvUTF8(res)) {
1493 char *ostart = SvPVX(sv);
1494 SvCUR_set(sv, d - ostart);
1496 sv_utf8_upgrade(sv);
1497 d = SvPVX(sv) + SvCUR(sv);
1500 if (len > e - s + 4) {
1501 char *odest = SvPVX(sv);
1503 SvGROW(sv, (SvCUR(sv) + len - (e - s + 4)));
1504 d = SvPVX(sv) + (d - odest);
1506 Copy(str, d, len, char);
1513 yyerror("Missing braces on \\N{}");
1516 /* \c is a control character */
1531 /* printf-style backslashes, formfeeds, newlines, etc */
1549 *d++ = '\047'; /* CP 1047 */
1552 *d++ = '\057'; /* CP 1047 */
1566 } /* end if (backslash) */
1569 } /* while loop to process each character */
1571 /* terminate the string and set up the sv */
1573 SvCUR_set(sv, d - SvPVX(sv));
1578 /* shrink the sv if we allocated more than we used */
1579 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1580 SvLEN_set(sv, SvCUR(sv) + 1);
1581 Renew(SvPVX(sv), SvLEN(sv), char);
1584 /* return the substring (via yylval) only if we parsed anything */
1585 if (s > PL_bufptr) {
1586 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1587 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1589 ( PL_lex_inwhat == OP_TRANS
1591 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1594 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1601 * Returns TRUE if there's more to the expression (e.g., a subscript),
1604 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
1606 * ->[ and ->{ return TRUE
1607 * { and [ outside a pattern are always subscripts, so return TRUE
1608 * if we're outside a pattern and it's not { or [, then return FALSE
1609 * if we're in a pattern and the first char is a {
1610 * {4,5} (any digits around the comma) returns FALSE
1611 * if we're in a pattern and the first char is a [
1613 * [SOMETHING] has a funky algorithm to decide whether it's a
1614 * character class or not. It has to deal with things like
1615 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
1616 * anything else returns TRUE
1619 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1622 S_intuit_more(pTHX_ register char *s)
1624 if (PL_lex_brackets)
1626 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1628 if (*s != '{' && *s != '[')
1633 /* In a pattern, so maybe we have {n,m}. */
1650 /* On the other hand, maybe we have a character class */
1653 if (*s == ']' || *s == '^')
1656 /* this is terrifying, and it works */
1657 int weight = 2; /* let's weigh the evidence */
1659 unsigned char un_char = 255, last_un_char;
1660 char *send = strchr(s,']');
1661 char tmpbuf[sizeof PL_tokenbuf * 4];
1663 if (!send) /* has to be an expression */
1666 Zero(seen,256,char);
1669 else if (isDIGIT(*s)) {
1671 if (isDIGIT(s[1]) && s[2] == ']')
1677 for (; s < send; s++) {
1678 last_un_char = un_char;
1679 un_char = (unsigned char)*s;
1684 weight -= seen[un_char] * 10;
1685 if (isALNUM_lazy_if(s+1,UTF)) {
1686 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1687 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1692 else if (*s == '$' && s[1] &&
1693 strchr("[#!%*<>()-=",s[1])) {
1694 if (/*{*/ strchr("])} =",s[2]))
1703 if (strchr("wds]",s[1]))
1705 else if (seen['\''] || seen['"'])
1707 else if (strchr("rnftbxcav",s[1]))
1709 else if (isDIGIT(s[1])) {
1711 while (s[1] && isDIGIT(s[1]))
1721 if (strchr("aA01! ",last_un_char))
1723 if (strchr("zZ79~",s[1]))
1725 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1726 weight -= 5; /* cope with negative subscript */
1729 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1730 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1735 if (keyword(tmpbuf, d - tmpbuf))
1738 if (un_char == last_un_char + 1)
1740 weight -= seen[un_char];
1745 if (weight >= 0) /* probably a character class */
1755 * Does all the checking to disambiguate
1757 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
1758 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
1760 * First argument is the stuff after the first token, e.g. "bar".
1762 * Not a method if bar is a filehandle.
1763 * Not a method if foo is a subroutine prototyped to take a filehandle.
1764 * Not a method if it's really "Foo $bar"
1765 * Method if it's "foo $bar"
1766 * Not a method if it's really "print foo $bar"
1767 * Method if it's really "foo package::" (interpreted as package->foo)
1768 * Not a method if bar is known to be a subroutne ("sub bar; foo bar")
1769 * Not a method if bar is a filehandle or package, but is quoted with
1774 S_intuit_method(pTHX_ char *start, GV *gv)
1776 char *s = start + (*start == '$');
1777 char tmpbuf[sizeof PL_tokenbuf];
1785 if ((cv = GvCVu(gv))) {
1786 char *proto = SvPVX(cv);
1796 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1797 /* start is the beginning of the possible filehandle/object,
1798 * and s is the end of it
1799 * tmpbuf is a copy of it
1802 if (*start == '$') {
1803 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1808 return *s == '(' ? FUNCMETH : METHOD;
1810 if (!keyword(tmpbuf, len)) {
1811 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1816 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1817 if (indirgv && GvCVu(indirgv))
1819 /* filehandle or package name makes it a method */
1820 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1822 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1823 return 0; /* no assumptions -- "=>" quotes bearword */
1825 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1826 newSVpvn(tmpbuf,len));
1827 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1831 return *s == '(' ? FUNCMETH : METHOD;
1839 * Return a string of Perl code to load the debugger. If PERL5DB
1840 * is set, it will return the contents of that, otherwise a
1841 * compile-time require of perl5db.pl.
1848 char *pdb = PerlEnv_getenv("PERL5DB");
1852 SETERRNO(0,SS$_NORMAL);
1853 return "BEGIN { require 'perl5db.pl' }";
1859 /* Encoded script support. filter_add() effectively inserts a
1860 * 'pre-processing' function into the current source input stream.
1861 * Note that the filter function only applies to the current source file
1862 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1864 * The datasv parameter (which may be NULL) can be used to pass
1865 * private data to this instance of the filter. The filter function
1866 * can recover the SV using the FILTER_DATA macro and use it to
1867 * store private buffers and state information.
1869 * The supplied datasv parameter is upgraded to a PVIO type
1870 * and the IoDIRP field is used to store the function pointer,
1871 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
1872 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1873 * private use must be set using malloc'd pointers.
1877 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
1882 if (!PL_rsfp_filters)
1883 PL_rsfp_filters = newAV();
1885 datasv = NEWSV(255,0);
1886 if (!SvUPGRADE(datasv, SVt_PVIO))
1887 Perl_die(aTHX_ "Can't upgrade filter_add data to SVt_PVIO");
1888 IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
1889 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
1890 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
1891 funcp, SvPV_nolen(datasv)));
1892 av_unshift(PL_rsfp_filters, 1);
1893 av_store(PL_rsfp_filters, 0, datasv) ;
1898 /* Delete most recently added instance of this filter function. */
1900 Perl_filter_del(pTHX_ filter_t funcp)
1903 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", funcp));
1904 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
1906 /* if filter is on top of stack (usual case) just pop it off */
1907 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
1908 if (IoDIRP(datasv) == (DIR*)funcp) {
1909 IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
1910 IoDIRP(datasv) = (DIR*)NULL;
1911 sv_free(av_pop(PL_rsfp_filters));
1915 /* we need to search for the correct entry and clear it */
1916 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
1920 /* Invoke the n'th filter function for the current rsfp. */
1922 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
1925 /* 0 = read one text line */
1930 if (!PL_rsfp_filters)
1932 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
1933 /* Provide a default input filter to make life easy. */
1934 /* Note that we append to the line. This is handy. */
1935 DEBUG_P(PerlIO_printf(Perl_debug_log,
1936 "filter_read %d: from rsfp\n", idx));
1940 int old_len = SvCUR(buf_sv) ;
1942 /* ensure buf_sv is large enough */
1943 SvGROW(buf_sv, old_len + maxlen) ;
1944 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1945 if (PerlIO_error(PL_rsfp))
1946 return -1; /* error */
1948 return 0 ; /* end of file */
1950 SvCUR_set(buf_sv, old_len + len) ;
1953 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
1954 if (PerlIO_error(PL_rsfp))
1955 return -1; /* error */
1957 return 0 ; /* end of file */
1960 return SvCUR(buf_sv);
1962 /* Skip this filter slot if filter has been deleted */
1963 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
1964 DEBUG_P(PerlIO_printf(Perl_debug_log,
1965 "filter_read %d: skipped (filter deleted)\n",
1967 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1969 /* Get function pointer hidden within datasv */
1970 funcp = (filter_t)IoDIRP(datasv);
1971 DEBUG_P(PerlIO_printf(Perl_debug_log,
1972 "filter_read %d: via function %p (%s)\n",
1973 idx, funcp, SvPV_nolen(datasv)));
1974 /* Call function. The function is expected to */
1975 /* call "FILTER_READ(idx+1, buf_sv)" first. */
1976 /* Return: <0:error, =0:eof, >0:not eof */
1977 return (*funcp)(aTHXo_ idx, buf_sv, maxlen);
1981 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
1983 #ifdef PERL_CR_FILTER
1984 if (!PL_rsfp_filters) {
1985 filter_add(S_cr_textfilter,NULL);
1988 if (PL_rsfp_filters) {
1991 SvCUR_set(sv, 0); /* start with empty line */
1992 if (FILTER_READ(0, sv, 0) > 0)
1993 return ( SvPVX(sv) ) ;
1998 return (sv_gets(sv, fp, append));
2003 static char* exp_name[] =
2004 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
2005 "ATTRTERM", "TERMBLOCK"
2012 Works out what to call the token just pulled out of the input
2013 stream. The yacc parser takes care of taking the ops we return and
2014 stitching them into a tree.
2020 if read an identifier
2021 if we're in a my declaration
2022 croak if they tried to say my($foo::bar)
2023 build the ops for a my() declaration
2024 if it's an access to a my() variable
2025 are we in a sort block?
2026 croak if my($a); $a <=> $b
2027 build ops for access to a my() variable
2028 if in a dq string, and they've said @foo and we can't find @foo
2030 build ops for a bareword
2031 if we already built the token before, use it.
2035 #pragma segment Perl_yylex
2038 #ifdef USE_PURE_BISON
2039 Perl_yylex(pTHX_ YYSTYPE *lvalp, int *lcharp)
2052 #ifdef USE_PURE_BISON
2053 yylval_pointer = lvalp;
2054 yychar_pointer = lcharp;
2057 /* check if there's an identifier for us to look at */
2058 if (PL_pending_ident) {
2059 /* pit holds the identifier we read and pending_ident is reset */
2060 char pit = PL_pending_ident;
2061 PL_pending_ident = 0;
2063 /* if we're in a my(), we can't allow dynamics here.
2064 $foo'bar has already been turned into $foo::bar, so
2065 just check for colons.
2067 if it's a legal name, the OP is a PADANY.
2070 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
2071 if (strchr(PL_tokenbuf,':'))
2072 yyerror(Perl_form(aTHX_ "No package name allowed for "
2073 "variable %s in \"our\"",
2075 tmp = pad_allocmy(PL_tokenbuf);
2078 if (strchr(PL_tokenbuf,':'))
2079 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
2081 yylval.opval = newOP(OP_PADANY, 0);
2082 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
2088 build the ops for accesses to a my() variable.
2090 Deny my($a) or my($b) in a sort block, *if* $a or $b is
2091 then used in a comparison. This catches most, but not
2092 all cases. For instance, it catches
2093 sort { my($a); $a <=> $b }
2095 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
2096 (although why you'd do that is anyone's guess).
2099 if (!strchr(PL_tokenbuf,':')) {
2101 /* Check for single character per-thread SVs */
2102 if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
2103 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
2104 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
2106 yylval.opval = newOP(OP_THREADSV, 0);
2107 yylval.opval->op_targ = tmp;
2110 #endif /* USE_THREADS */
2111 if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
2112 SV *namesv = AvARRAY(PL_comppad_name)[tmp];
2113 /* might be an "our" variable" */
2114 if (SvFLAGS(namesv) & SVpad_OUR) {
2115 /* build ops for a bareword */
2116 SV *sym = newSVpv(HvNAME(GvSTASH(namesv)),0);
2117 sv_catpvn(sym, "::", 2);
2118 sv_catpv(sym, PL_tokenbuf+1);
2119 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
2120 yylval.opval->op_private = OPpCONST_ENTERED;
2121 gv_fetchpv(SvPVX(sym),
2123 ? (GV_ADDMULTI | GV_ADDINEVAL)
2126 ((PL_tokenbuf[0] == '$') ? SVt_PV
2127 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
2132 /* if it's a sort block and they're naming $a or $b */
2133 if (PL_last_lop_op == OP_SORT &&
2134 PL_tokenbuf[0] == '$' &&
2135 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
2138 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
2139 d < PL_bufend && *d != '\n';
2142 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
2143 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
2149 yylval.opval = newOP(OP_PADANY, 0);
2150 yylval.opval->op_targ = tmp;
2156 Whine if they've said @foo in a doublequoted string,
2157 and @foo isn't a variable we can find in the symbol
2160 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
2161 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
2162 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
2163 && ckWARN(WARN_AMBIGUOUS))
2165 /* Downgraded from fatal to warning 20000522 mjd */
2166 Perl_warner(aTHX_ WARN_AMBIGUOUS,
2167 "Possible unintended interpolation of %s in string",
2172 /* build ops for a bareword */
2173 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
2174 yylval.opval->op_private = OPpCONST_ENTERED;
2175 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
2176 ((PL_tokenbuf[0] == '$') ? SVt_PV
2177 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
2182 /* no identifier pending identification */
2184 switch (PL_lex_state) {
2186 case LEX_NORMAL: /* Some compilers will produce faster */
2187 case LEX_INTERPNORMAL: /* code if we comment these out. */
2191 /* when we've already built the next token, just pull it out of the queue */
2194 yylval = PL_nextval[PL_nexttoke];
2196 PL_lex_state = PL_lex_defer;
2197 PL_expect = PL_lex_expect;
2198 PL_lex_defer = LEX_NORMAL;
2200 return(PL_nexttype[PL_nexttoke]);
2202 /* interpolated case modifiers like \L \U, including \Q and \E.
2203 when we get here, PL_bufptr is at the \
2205 case LEX_INTERPCASEMOD:
2207 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
2208 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
2210 /* handle \E or end of string */
2211 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
2215 if (PL_lex_casemods) {
2216 oldmod = PL_lex_casestack[--PL_lex_casemods];
2217 PL_lex_casestack[PL_lex_casemods] = '\0';
2219 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
2221 PL_lex_state = LEX_INTERPCONCAT;
2225 if (PL_bufptr != PL_bufend)
2227 PL_lex_state = LEX_INTERPCONCAT;
2232 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
2233 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
2234 if (strchr("LU", *s) &&
2235 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
2237 PL_lex_casestack[--PL_lex_casemods] = '\0';
2240 if (PL_lex_casemods > 10) {
2241 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
2242 if (newlb != PL_lex_casestack) {
2244 PL_lex_casestack = newlb;
2247 PL_lex_casestack[PL_lex_casemods++] = *s;
2248 PL_lex_casestack[PL_lex_casemods] = '\0';
2249 PL_lex_state = LEX_INTERPCONCAT;
2250 PL_nextval[PL_nexttoke].ival = 0;
2253 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
2255 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
2257 PL_nextval[PL_nexttoke].ival = OP_LC;
2259 PL_nextval[PL_nexttoke].ival = OP_UC;
2261 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
2263 Perl_croak(aTHX_ "panic: yylex");
2266 if (PL_lex_starts) {
2275 case LEX_INTERPPUSH:
2276 return sublex_push();
2278 case LEX_INTERPSTART:
2279 if (PL_bufptr == PL_bufend)
2280 return sublex_done();
2282 PL_lex_dojoin = (*PL_bufptr == '@');
2283 PL_lex_state = LEX_INTERPNORMAL;
2284 if (PL_lex_dojoin) {
2285 PL_nextval[PL_nexttoke].ival = 0;
2288 PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
2289 PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
2290 force_next(PRIVATEREF);
2292 force_ident("\"", '$');
2293 #endif /* USE_THREADS */
2294 PL_nextval[PL_nexttoke].ival = 0;
2296 PL_nextval[PL_nexttoke].ival = 0;
2298 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
2301 if (PL_lex_starts++) {
2307 case LEX_INTERPENDMAYBE:
2308 if (intuit_more(PL_bufptr)) {
2309 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
2315 if (PL_lex_dojoin) {
2316 PL_lex_dojoin = FALSE;
2317 PL_lex_state = LEX_INTERPCONCAT;
2320 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
2321 && SvEVALED(PL_lex_repl))
2323 if (PL_bufptr != PL_bufend)
2324 Perl_croak(aTHX_ "Bad evalled substitution pattern");
2325 PL_lex_repl = Nullsv;
2328 case LEX_INTERPCONCAT:
2330 if (PL_lex_brackets)
2331 Perl_croak(aTHX_ "panic: INTERPCONCAT");
2333 if (PL_bufptr == PL_bufend)
2334 return sublex_done();
2336 if (SvIVX(PL_linestr) == '\'') {
2337 SV *sv = newSVsv(PL_linestr);
2340 else if ( PL_hints & HINT_NEW_RE )
2341 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
2342 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2346 s = scan_const(PL_bufptr);
2348 PL_lex_state = LEX_INTERPCASEMOD;
2350 PL_lex_state = LEX_INTERPSTART;
2353 if (s != PL_bufptr) {
2354 PL_nextval[PL_nexttoke] = yylval;
2357 if (PL_lex_starts++)
2367 PL_lex_state = LEX_NORMAL;
2368 s = scan_formline(PL_bufptr);
2369 if (!PL_lex_formbrack)
2375 PL_oldoldbufptr = PL_oldbufptr;
2378 PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at %s\n",
2379 exp_name[PL_expect], s);
2385 if (isIDFIRST_lazy_if(s,UTF))
2387 Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
2390 goto fake_eof; /* emulate EOF on ^D or ^Z */
2395 if (PL_lex_brackets)
2396 yyerror("Missing right curly or square bracket");
2399 if (s++ < PL_bufend)
2400 goto retry; /* ignore stray nulls */
2403 if (!PL_in_eval && !PL_preambled) {
2404 PL_preambled = TRUE;
2405 sv_setpv(PL_linestr,incl_perldb());
2406 if (SvCUR(PL_linestr))
2407 sv_catpv(PL_linestr,";");
2409 while(AvFILLp(PL_preambleav) >= 0) {
2410 SV *tmpsv = av_shift(PL_preambleav);
2411 sv_catsv(PL_linestr, tmpsv);
2412 sv_catpv(PL_linestr, ";");
2415 sv_free((SV*)PL_preambleav);
2416 PL_preambleav = NULL;
2418 if (PL_minus_n || PL_minus_p) {
2419 sv_catpv(PL_linestr, "LINE: while (<>) {");
2421 sv_catpv(PL_linestr,"chomp;");
2423 GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
2425 GvIMPORTED_AV_on(gv);
2427 if (strchr("/'\"", *PL_splitstr)
2428 && strchr(PL_splitstr + 1, *PL_splitstr))
2429 Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s);", PL_splitstr);
2432 s = "'~#\200\1'"; /* surely one char is unused...*/
2433 while (s[1] && strchr(PL_splitstr, *s)) s++;
2435 Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s%c",
2436 "q" + (delim == '\''), delim);
2437 for (s = PL_splitstr; *s; s++) {
2439 sv_catpvn(PL_linestr, "\\", 1);
2440 sv_catpvn(PL_linestr, s, 1);
2442 Perl_sv_catpvf(aTHX_ PL_linestr, "%c);", delim);
2446 sv_catpv(PL_linestr,"@F=split(' ');");
2449 sv_catpv(PL_linestr, "\n");
2450 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2451 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2452 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2453 SV *sv = NEWSV(85,0);
2455 sv_upgrade(sv, SVt_PVMG);
2456 sv_setsv(sv,PL_linestr);
2457 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2462 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
2465 if (PL_preprocess && !PL_in_eval)
2466 (void)PerlProc_pclose(PL_rsfp);
2467 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2468 PerlIO_clearerr(PL_rsfp);
2470 (void)PerlIO_close(PL_rsfp);
2472 PL_doextract = FALSE;
2474 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2475 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
2476 sv_catpv(PL_linestr,";}");
2477 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2478 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2479 PL_minus_n = PL_minus_p = 0;
2482 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2483 sv_setpv(PL_linestr,"");
2484 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
2487 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
2488 PL_doextract = FALSE;
2490 /* Incest with pod. */
2491 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2492 sv_setpv(PL_linestr, "");
2493 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2494 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2495 PL_doextract = FALSE;
2499 } while (PL_doextract);
2500 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2501 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2502 SV *sv = NEWSV(85,0);
2504 sv_upgrade(sv, SVt_PVMG);
2505 sv_setsv(sv,PL_linestr);
2506 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2508 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2509 if (CopLINE(PL_curcop) == 1) {
2510 while (s < PL_bufend && isSPACE(*s))
2512 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2516 if (*s == '#' && *(s+1) == '!')
2518 #ifdef ALTERNATE_SHEBANG
2520 static char as[] = ALTERNATE_SHEBANG;
2521 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2522 d = s + (sizeof(as) - 1);
2524 #endif /* ALTERNATE_SHEBANG */
2533 while (*d && !isSPACE(*d))
2537 #ifdef ARG_ZERO_IS_SCRIPT
2538 if (ipathend > ipath) {
2540 * HP-UX (at least) sets argv[0] to the script name,
2541 * which makes $^X incorrect. And Digital UNIX and Linux,
2542 * at least, set argv[0] to the basename of the Perl
2543 * interpreter. So, having found "#!", we'll set it right.
2545 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
2546 assert(SvPOK(x) || SvGMAGICAL(x));
2547 if (sv_eq(x, CopFILESV(PL_curcop))) {
2548 sv_setpvn(x, ipath, ipathend - ipath);
2551 TAINT_NOT; /* $^X is always tainted, but that's OK */
2553 #endif /* ARG_ZERO_IS_SCRIPT */
2558 d = instr(s,"perl -");
2560 d = instr(s,"perl");
2562 /* avoid getting into infinite loops when shebang
2563 * line contains "Perl" rather than "perl" */
2565 for (d = ipathend-4; d >= ipath; --d) {
2566 if ((*d == 'p' || *d == 'P')
2567 && !ibcmp(d, "perl", 4))
2577 #ifdef ALTERNATE_SHEBANG
2579 * If the ALTERNATE_SHEBANG on this system starts with a
2580 * character that can be part of a Perl expression, then if
2581 * we see it but not "perl", we're probably looking at the
2582 * start of Perl code, not a request to hand off to some
2583 * other interpreter. Similarly, if "perl" is there, but
2584 * not in the first 'word' of the line, we assume the line
2585 * contains the start of the Perl program.
2587 if (d && *s != '#') {
2589 while (*c && !strchr("; \t\r\n\f\v#", *c))
2592 d = Nullch; /* "perl" not in first word; ignore */
2594 *s = '#'; /* Don't try to parse shebang line */
2596 #endif /* ALTERNATE_SHEBANG */
2597 #ifndef MACOS_TRADITIONAL
2602 !instr(s,"indir") &&
2603 instr(PL_origargv[0],"perl"))
2609 while (s < PL_bufend && isSPACE(*s))
2611 if (s < PL_bufend) {
2612 Newz(899,newargv,PL_origargc+3,char*);
2614 while (s < PL_bufend && !isSPACE(*s))
2617 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2620 newargv = PL_origargv;
2622 PerlProc_execv(ipath, newargv);
2623 Perl_croak(aTHX_ "Can't exec %s", ipath);
2627 U32 oldpdb = PL_perldb;
2628 bool oldn = PL_minus_n;
2629 bool oldp = PL_minus_p;
2631 while (*d && !isSPACE(*d)) d++;
2632 while (SPACE_OR_TAB(*d)) d++;
2636 if (*d == 'M' || *d == 'm') {
2638 while (*d && !isSPACE(*d)) d++;
2639 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2642 d = moreswitches(d);
2644 if ((PERLDB_LINE && !oldpdb) ||
2645 ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
2646 /* if we have already added "LINE: while (<>) {",
2647 we must not do it again */
2649 sv_setpv(PL_linestr, "");
2650 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2651 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2652 PL_preambled = FALSE;
2654 (void)gv_fetchfile(PL_origfilename);
2661 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2663 PL_lex_state = LEX_FORMLINE;
2668 #ifdef PERL_STRICT_CR
2669 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2671 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
2673 case ' ': case '\t': case '\f': case 013:
2674 #ifdef MACOS_TRADITIONAL
2681 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2682 if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
2683 /* handle eval qq[#line 1 "foo"\n ...] */
2684 CopLINE_dec(PL_curcop);
2688 while (s < d && *s != '\n')
2693 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2695 PL_lex_state = LEX_FORMLINE;
2705 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2710 while (s < PL_bufend && SPACE_OR_TAB(*s))
2713 if (strnEQ(s,"=>",2)) {
2714 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2715 OPERATOR('-'); /* unary minus */
2717 PL_last_uni = PL_oldbufptr;
2718 PL_last_lop_op = OP_FTEREAD; /* good enough */
2720 case 'r': FTST(OP_FTEREAD);
2721 case 'w': FTST(OP_FTEWRITE);
2722 case 'x': FTST(OP_FTEEXEC);
2723 case 'o': FTST(OP_FTEOWNED);
2724 case 'R': FTST(OP_FTRREAD);
2725 case 'W': FTST(OP_FTRWRITE);
2726 case 'X': FTST(OP_FTREXEC);
2727 case 'O': FTST(OP_FTROWNED);
2728 case 'e': FTST(OP_FTIS);
2729 case 'z': FTST(OP_FTZERO);
2730 case 's': FTST(OP_FTSIZE);
2731 case 'f': FTST(OP_FTFILE);
2732 case 'd': FTST(OP_FTDIR);
2733 case 'l': FTST(OP_FTLINK);
2734 case 'p': FTST(OP_FTPIPE);
2735 case 'S': FTST(OP_FTSOCK);
2736 case 'u': FTST(OP_FTSUID);
2737 case 'g': FTST(OP_FTSGID);
2738 case 'k': FTST(OP_FTSVTX);
2739 case 'b': FTST(OP_FTBLK);
2740 case 'c': FTST(OP_FTCHR);
2741 case 't': FTST(OP_FTTTY);
2742 case 'T': FTST(OP_FTTEXT);
2743 case 'B': FTST(OP_FTBINARY);
2744 case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2745 case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2746 case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
2748 Perl_croak(aTHX_ "Unrecognized file test: -%c", (int)tmp);
2755 if (PL_expect == XOPERATOR)
2760 else if (*s == '>') {
2763 if (isIDFIRST_lazy_if(s,UTF)) {
2764 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2772 if (PL_expect == XOPERATOR)
2775 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2777 OPERATOR('-'); /* unary minus */
2784 if (PL_expect == XOPERATOR)
2789 if (PL_expect == XOPERATOR)
2792 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2798 if (PL_expect != XOPERATOR) {
2799 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2800 PL_expect = XOPERATOR;
2801 force_ident(PL_tokenbuf, '*');
2814 if (PL_expect == XOPERATOR) {
2818 PL_tokenbuf[0] = '%';
2819 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2820 if (!PL_tokenbuf[1]) {
2822 yyerror("Final % should be \\% or %name");
2825 PL_pending_ident = '%';
2844 switch (PL_expect) {
2847 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
2849 PL_bufptr = s; /* update in case we back off */
2855 PL_expect = XTERMBLOCK;
2859 while (isIDFIRST_lazy_if(s,UTF)) {
2860 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2861 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
2862 if (tmp < 0) tmp = -tmp;
2877 d = scan_str(d,TRUE,TRUE);
2880 SvREFCNT_dec(PL_lex_stuff);
2881 PL_lex_stuff = Nullsv;
2883 /* MUST advance bufptr here to avoid bogus
2884 "at end of line" context messages from yyerror().
2886 PL_bufptr = s + len;
2887 yyerror("Unterminated attribute parameter in attribute list");
2890 return 0; /* EOF indicator */
2894 SV *sv = newSVpvn(s, len);
2895 sv_catsv(sv, PL_lex_stuff);
2896 attrs = append_elem(OP_LIST, attrs,
2897 newSVOP(OP_CONST, 0, sv));
2898 SvREFCNT_dec(PL_lex_stuff);
2899 PL_lex_stuff = Nullsv;
2902 attrs = append_elem(OP_LIST, attrs,
2903 newSVOP(OP_CONST, 0,
2907 if (*s == ':' && s[1] != ':')
2910 break; /* require real whitespace or :'s */
2912 tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
2913 if (*s != ';' && *s != tmp && (tmp != '=' || *s != ')')) {
2914 char q = ((*s == '\'') ? '"' : '\'');
2915 /* If here for an expression, and parsed no attrs, back off. */
2916 if (tmp == '=' && !attrs) {
2920 /* MUST advance bufptr here to avoid bogus "at end of line"
2921 context messages from yyerror().
2925 yyerror("Unterminated attribute list");
2927 yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list",
2935 PL_nextval[PL_nexttoke].opval = attrs;
2943 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
2944 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
2949 if (CopLINE(PL_curcop) < PL_copline)
2950 PL_copline = CopLINE(PL_curcop);
2961 if (PL_lex_brackets <= 0)
2962 yyerror("Unmatched right square bracket");
2965 if (PL_lex_state == LEX_INTERPNORMAL) {
2966 if (PL_lex_brackets == 0) {
2967 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
2968 PL_lex_state = LEX_INTERPEND;
2975 if (PL_lex_brackets > 100) {
2976 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
2977 if (newlb != PL_lex_brackstack) {
2979 PL_lex_brackstack = newlb;
2982 switch (PL_expect) {
2984 if (PL_lex_formbrack) {
2988 if (PL_oldoldbufptr == PL_last_lop)
2989 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2991 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2992 OPERATOR(HASHBRACK);
2994 while (s < PL_bufend && SPACE_OR_TAB(*s))
2997 PL_tokenbuf[0] = '\0';
2998 if (d < PL_bufend && *d == '-') {
2999 PL_tokenbuf[0] = '-';
3001 while (d < PL_bufend && SPACE_OR_TAB(*d))
3004 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
3005 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
3007 while (d < PL_bufend && SPACE_OR_TAB(*d))
3010 char minus = (PL_tokenbuf[0] == '-');
3011 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
3019 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
3024 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3029 if (PL_oldoldbufptr == PL_last_lop)
3030 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3032 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3035 OPERATOR(HASHBRACK);
3036 /* This hack serves to disambiguate a pair of curlies
3037 * as being a block or an anon hash. Normally, expectation
3038 * determines that, but in cases where we're not in a
3039 * position to expect anything in particular (like inside
3040 * eval"") we have to resolve the ambiguity. This code
3041 * covers the case where the first term in the curlies is a
3042 * quoted string. Most other cases need to be explicitly
3043 * disambiguated by prepending a `+' before the opening
3044 * curly in order to force resolution as an anon hash.
3046 * XXX should probably propagate the outer expectation
3047 * into eval"" to rely less on this hack, but that could
3048 * potentially break current behavior of eval"".
3052 if (*s == '\'' || *s == '"' || *s == '`') {
3053 /* common case: get past first string, handling escapes */
3054 for (t++; t < PL_bufend && *t != *s;)
3055 if (*t++ == '\\' && (*t == '\\' || *t == *s))
3059 else if (*s == 'q') {
3062 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
3066 char open, close, term;
3069 while (t < PL_bufend && isSPACE(*t))
3073 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
3077 for (t++; t < PL_bufend; t++) {
3078 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
3080 else if (*t == open)
3084 for (t++; t < PL_bufend; t++) {
3085 if (*t == '\\' && t+1 < PL_bufend)
3087 else if (*t == close && --brackets <= 0)
3089 else if (*t == open)
3095 else if (isALNUM_lazy_if(t,UTF)) {
3097 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3100 while (t < PL_bufend && isSPACE(*t))
3102 /* if comma follows first term, call it an anon hash */
3103 /* XXX it could be a comma expression with loop modifiers */
3104 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
3105 || (*t == '=' && t[1] == '>')))
3106 OPERATOR(HASHBRACK);
3107 if (PL_expect == XREF)
3110 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
3116 yylval.ival = CopLINE(PL_curcop);
3117 if (isSPACE(*s) || *s == '#')
3118 PL_copline = NOLINE; /* invalidate current command line number */
3123 if (PL_lex_brackets <= 0)
3124 yyerror("Unmatched right curly bracket");
3126 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
3127 if (PL_lex_brackets < PL_lex_formbrack)
3128 PL_lex_formbrack = 0;
3129 if (PL_lex_state == LEX_INTERPNORMAL) {
3130 if (PL_lex_brackets == 0) {
3131 if (PL_expect & XFAKEBRACK) {
3132 PL_expect &= XENUMMASK;
3133 PL_lex_state = LEX_INTERPEND;
3135 return yylex(); /* ignore fake brackets */
3137 if (*s == '-' && s[1] == '>')
3138 PL_lex_state = LEX_INTERPENDMAYBE;
3139 else if (*s != '[' && *s != '{')
3140 PL_lex_state = LEX_INTERPEND;
3143 if (PL_expect & XFAKEBRACK) {
3144 PL_expect &= XENUMMASK;
3146 return yylex(); /* ignore fake brackets */
3156 if (PL_expect == XOPERATOR) {
3157 if (ckWARN(WARN_SEMICOLON)
3158 && isIDFIRST_lazy_if(s,UTF) && PL_bufptr == PL_linestart)
3160 CopLINE_dec(PL_curcop);
3161 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3162 CopLINE_inc(PL_curcop);
3167 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3169 PL_expect = XOPERATOR;
3170 force_ident(PL_tokenbuf, '&');
3174 yylval.ival = (OPpENTERSUB_AMPER<<8);
3193 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
3194 Perl_warner(aTHX_ WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
3196 if (PL_expect == XSTATE && isALPHA(tmp) &&
3197 (s == PL_linestart+1 || s[-2] == '\n') )
3199 if (PL_in_eval && !PL_rsfp) {
3204 if (strnEQ(s,"=cut",4)) {
3218 PL_doextract = TRUE;
3221 if (PL_lex_brackets < PL_lex_formbrack) {
3223 #ifdef PERL_STRICT_CR
3224 for (t = s; SPACE_OR_TAB(*t); t++) ;
3226 for (t = s; SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
3228 if (*t == '\n' || *t == '#') {
3246 if (PL_expect != XOPERATOR) {
3247 if (s[1] != '<' && !strchr(s,'>'))
3250 s = scan_heredoc(s);
3252 s = scan_inputsymbol(s);
3253 TERM(sublex_start());
3258 SHop(OP_LEFT_SHIFT);
3272 SHop(OP_RIGHT_SHIFT);
3281 if (PL_expect == XOPERATOR) {
3282 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3285 return ','; /* grandfather non-comma-format format */
3289 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
3290 PL_tokenbuf[0] = '@';
3291 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3292 sizeof PL_tokenbuf - 1, FALSE);
3293 if (PL_expect == XOPERATOR)
3294 no_op("Array length", s);
3295 if (!PL_tokenbuf[1])
3297 PL_expect = XOPERATOR;
3298 PL_pending_ident = '#';
3302 PL_tokenbuf[0] = '$';
3303 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3304 sizeof PL_tokenbuf - 1, FALSE);
3305 if (PL_expect == XOPERATOR)
3307 if (!PL_tokenbuf[1]) {
3309 yyerror("Final $ should be \\$ or $name");
3313 /* This kludge not intended to be bulletproof. */
3314 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
3315 yylval.opval = newSVOP(OP_CONST, 0,
3316 newSViv(PL_compiling.cop_arybase));
3317 yylval.opval->op_private = OPpCONST_ARYBASE;
3323 if (PL_lex_state == LEX_NORMAL)
3326 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3329 PL_tokenbuf[0] = '@';
3330 if (ckWARN(WARN_SYNTAX)) {
3332 isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$';
3335 PL_bufptr = skipspace(PL_bufptr);
3336 while (t < PL_bufend && *t != ']')
3338 Perl_warner(aTHX_ WARN_SYNTAX,
3339 "Multidimensional syntax %.*s not supported",
3340 (t - PL_bufptr) + 1, PL_bufptr);
3344 else if (*s == '{') {
3345 PL_tokenbuf[0] = '%';
3346 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
3347 (t = strchr(s, '}')) && (t = strchr(t, '=')))
3349 char tmpbuf[sizeof PL_tokenbuf];
3351 for (t++; isSPACE(*t); t++) ;
3352 if (isIDFIRST_lazy_if(t,UTF)) {
3353 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
3354 for (; isSPACE(*t); t++) ;
3355 if (*t == ';' && get_cv(tmpbuf, FALSE))
3356 Perl_warner(aTHX_ WARN_SYNTAX,
3357 "You need to quote \"%s\"", tmpbuf);
3363 PL_expect = XOPERATOR;
3364 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3365 bool islop = (PL_last_lop == PL_oldoldbufptr);
3366 if (!islop || PL_last_lop_op == OP_GREPSTART)
3367 PL_expect = XOPERATOR;
3368 else if (strchr("$@\"'`q", *s))
3369 PL_expect = XTERM; /* e.g. print $fh "foo" */
3370 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
3371 PL_expect = XTERM; /* e.g. print $fh &sub */
3372 else if (isIDFIRST_lazy_if(s,UTF)) {
3373 char tmpbuf[sizeof PL_tokenbuf];
3374 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3375 if ((tmp = keyword(tmpbuf, len))) {
3376 /* binary operators exclude handle interpretations */
3388 PL_expect = XTERM; /* e.g. print $fh length() */
3393 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
3394 if (gv && GvCVu(gv))
3395 PL_expect = XTERM; /* e.g. print $fh subr() */
3398 else if (isDIGIT(*s))
3399 PL_expect = XTERM; /* e.g. print $fh 3 */
3400 else if (*s == '.' && isDIGIT(s[1]))
3401 PL_expect = XTERM; /* e.g. print $fh .3 */
3402 else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
3403 PL_expect = XTERM; /* e.g. print $fh -1 */
3404 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3405 PL_expect = XTERM; /* print $fh <<"EOF" */
3407 PL_pending_ident = '$';
3411 if (PL_expect == XOPERATOR)
3413 PL_tokenbuf[0] = '@';
3414 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3415 if (!PL_tokenbuf[1]) {
3417 yyerror("Final @ should be \\@ or @name");
3420 if (PL_lex_state == LEX_NORMAL)
3422 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3424 PL_tokenbuf[0] = '%';
3426 /* Warn about @ where they meant $. */
3427 if (ckWARN(WARN_SYNTAX)) {
3428 if (*s == '[' || *s == '{') {
3430 while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
3432 if (*t == '}' || *t == ']') {
3434 PL_bufptr = skipspace(PL_bufptr);
3435 Perl_warner(aTHX_ WARN_SYNTAX,
3436 "Scalar value %.*s better written as $%.*s",
3437 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
3442 PL_pending_ident = '@';
3445 case '/': /* may either be division or pattern */
3446 case '?': /* may either be conditional or pattern */
3447 if (PL_expect != XOPERATOR) {
3448 /* Disable warning on "study /blah/" */
3449 if (PL_oldoldbufptr == PL_last_uni
3450 && (*PL_last_uni != 's' || s - PL_last_uni < 5
3451 || memNE(PL_last_uni, "study", 5)
3452 || isALNUM_lazy_if(PL_last_uni+5,UTF)))
3454 s = scan_pat(s,OP_MATCH);
3455 TERM(sublex_start());
3463 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3464 #ifdef PERL_STRICT_CR
3467 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3469 && (s == PL_linestart || s[-1] == '\n') )
3471 PL_lex_formbrack = 0;
3475 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
3481 yylval.ival = OPf_SPECIAL;
3487 if (PL_expect != XOPERATOR)
3492 case '0': case '1': case '2': case '3': case '4':
3493 case '5': case '6': case '7': case '8': case '9':
3495 if (PL_expect == XOPERATOR)
3500 s = scan_str(s,FALSE,FALSE);
3501 if (PL_expect == XOPERATOR) {
3502 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3505 return ','; /* grandfather non-comma-format format */
3511 missingterm((char*)0);
3512 yylval.ival = OP_CONST;
3513 TERM(sublex_start());
3516 s = scan_str(s,FALSE,FALSE);
3517 if (PL_expect == XOPERATOR) {
3518 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3521 return ','; /* grandfather non-comma-format format */
3527 missingterm((char*)0);
3528 yylval.ival = OP_CONST;
3529 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
3530 if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
3531 yylval.ival = OP_STRINGIFY;
3535 TERM(sublex_start());
3538 s = scan_str(s,FALSE,FALSE);
3539 if (PL_expect == XOPERATOR)
3540 no_op("Backticks",s);
3542 missingterm((char*)0);
3543 yylval.ival = OP_BACKTICK;
3545 TERM(sublex_start());
3549 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
3550 Perl_warner(aTHX_ WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
3552 if (PL_expect == XOPERATOR)
3553 no_op("Backslash",s);
3557 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
3561 while (isDIGIT(*start) || *start == '_')
3563 if (*start == '.' && isDIGIT(start[1])) {
3567 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
3568 else if (!isALPHA(*start) && (PL_expect == XTERM || PL_expect == XREF)) {
3572 gv = gv_fetchpv(s, FALSE, SVt_PVCV);
3582 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
3621 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3623 /* Some keywords can be followed by any delimiter, including ':' */
3624 tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
3625 (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
3626 (PL_tokenbuf[0] == 'q' &&
3627 strchr("qwxr", PL_tokenbuf[1])))));
3629 /* x::* is just a word, unless x is "CORE" */
3630 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
3634 while (d < PL_bufend && isSPACE(*d))
3635 d++; /* no comments skipped here, or s### is misparsed */
3637 /* Is this a label? */
3638 if (!tmp && PL_expect == XSTATE
3639 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
3641 yylval.pval = savepv(PL_tokenbuf);
3646 /* Check for keywords */
3647 tmp = keyword(PL_tokenbuf, len);
3649 /* Is this a word before a => operator? */
3650 if (*d == '=' && d[1] == '>') {
3652 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
3653 yylval.opval->op_private = OPpCONST_BARE;
3657 if (tmp < 0) { /* second-class keyword? */
3658 GV *ogv = Nullgv; /* override (winner) */
3659 GV *hgv = Nullgv; /* hidden (loser) */
3660 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3662 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3665 if (GvIMPORTED_CV(gv))
3667 else if (! CvMETHOD(cv))
3671 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3672 (gv = *gvp) != (GV*)&PL_sv_undef &&
3673 GvCVu(gv) && GvIMPORTED_CV(gv))
3679 tmp = 0; /* overridden by import or by GLOBAL */
3682 && -tmp==KEY_lock /* XXX generalizable kludge */
3684 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3686 tmp = 0; /* any sub overrides "weak" keyword */
3688 else { /* no override */
3692 if (ckWARN(WARN_AMBIGUOUS) && hgv
3693 && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3694 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3695 "Ambiguous call resolved as CORE::%s(), %s",
3696 GvENAME(hgv), "qualify as such or use &");
3703 default: /* not a keyword */
3706 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3708 /* Get the rest if it looks like a package qualifier */
3710 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
3712 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3715 Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
3716 *s == '\'' ? "'" : "::");
3720 if (PL_expect == XOPERATOR) {
3721 if (PL_bufptr == PL_linestart) {
3722 CopLINE_dec(PL_curcop);
3723 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3724 CopLINE_inc(PL_curcop);
3727 no_op("Bareword",s);
3730 /* Look for a subroutine with this name in current package,
3731 unless name is "Foo::", in which case Foo is a bearword
3732 (and a package name). */
3735 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3737 if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3738 Perl_warner(aTHX_ WARN_BAREWORD,
3739 "Bareword \"%s\" refers to nonexistent package",
3742 PL_tokenbuf[len] = '\0';
3749 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3752 /* if we saw a global override before, get the right name */
3755 sv = newSVpvn("CORE::GLOBAL::",14);
3756 sv_catpv(sv,PL_tokenbuf);
3759 sv = newSVpv(PL_tokenbuf,0);
3761 /* Presume this is going to be a bareword of some sort. */
3764 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3765 yylval.opval->op_private = OPpCONST_BARE;
3767 /* And if "Foo::", then that's what it certainly is. */
3772 /* See if it's the indirect object for a list operator. */
3774 if (PL_oldoldbufptr &&
3775 PL_oldoldbufptr < PL_bufptr &&
3776 (PL_oldoldbufptr == PL_last_lop
3777 || PL_oldoldbufptr == PL_last_uni) &&
3778 /* NO SKIPSPACE BEFORE HERE! */
3779 (PL_expect == XREF ||
3780 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
3782 bool immediate_paren = *s == '(';
3784 /* (Now we can afford to cross potential line boundary.) */
3787 /* Two barewords in a row may indicate method call. */
3789 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp=intuit_method(s,gv)))
3792 /* If not a declared subroutine, it's an indirect object. */
3793 /* (But it's an indir obj regardless for sort.) */
3795 if ((PL_last_lop_op == OP_SORT ||
3796 (!immediate_paren && (!gv || !GvCVu(gv)))) &&
3797 (PL_last_lop_op != OP_MAPSTART &&
3798 PL_last_lop_op != OP_GREPSTART))
3800 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3806 PL_expect = XOPERATOR;
3809 /* Is this a word before a => operator? */
3810 if (*s == '=' && s[1] == '>') {
3812 sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
3816 /* If followed by a paren, it's certainly a subroutine. */
3819 if (gv && GvCVu(gv)) {
3820 for (d = s + 1; SPACE_OR_TAB(*d); d++) ;
3821 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
3826 PL_nextval[PL_nexttoke].opval = yylval.opval;
3827 PL_expect = XOPERATOR;
3833 /* If followed by var or block, call it a method (unless sub) */
3835 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3836 PL_last_lop = PL_oldbufptr;
3837 PL_last_lop_op = OP_METHOD;
3841 /* If followed by a bareword, see if it looks like indir obj. */
3843 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp = intuit_method(s,gv)))
3846 /* Not a method, so call it a subroutine (if defined) */
3848 if (gv && GvCVu(gv)) {
3850 if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
3851 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3852 "Ambiguous use of -%s resolved as -&%s()",
3853 PL_tokenbuf, PL_tokenbuf);
3854 /* Check for a constant sub */
3856 if ((sv = cv_const_sv(cv))) {
3858 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3859 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3860 yylval.opval->op_private = 0;
3864 /* Resolve to GV now. */
3865 op_free(yylval.opval);
3866 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3867 yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
3868 PL_last_lop = PL_oldbufptr;
3869 PL_last_lop_op = OP_ENTERSUB;
3870 /* Is there a prototype? */
3873 char *proto = SvPV((SV*)cv, len);
3876 if (strEQ(proto, "$"))
3878 if (*proto == '&' && *s == '{') {
3879 sv_setpv(PL_subname,"__ANON__");
3883 PL_nextval[PL_nexttoke].opval = yylval.opval;
3889 /* Call it a bare word */
3891 if (PL_hints & HINT_STRICT_SUBS)
3892 yylval.opval->op_private |= OPpCONST_STRICT;
3895 if (ckWARN(WARN_RESERVED)) {
3896 if (lastchar != '-') {
3897 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3899 Perl_warner(aTHX_ WARN_RESERVED, PL_warn_reserved,
3906 if (lastchar && strchr("*%&", lastchar) && ckWARN_d(WARN_AMBIGUOUS)) {
3907 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3908 "Operator or semicolon missing before %c%s",
3909 lastchar, PL_tokenbuf);
3910 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3911 "Ambiguous use of %c resolved as operator %c",
3912 lastchar, lastchar);
3918 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3919 newSVpv(CopFILE(PL_curcop),0));
3923 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3924 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
3927 case KEY___PACKAGE__:
3928 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3930 ? newSVsv(PL_curstname)
3939 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3940 char *pname = "main";
3941 if (PL_tokenbuf[2] == 'D')
3942 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3943 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
3946 GvIOp(gv) = newIO();
3947 IoIFP(GvIOp(gv)) = PL_rsfp;
3948 #if defined(HAS_FCNTL) && defined(F_SETFD)
3950 int fd = PerlIO_fileno(PL_rsfp);
3951 fcntl(fd,F_SETFD,fd >= 3);
3954 /* Mark this internal pseudo-handle as clean */
3955 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3957 IoTYPE(GvIOp(gv)) = '|';
3958 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
3959 IoTYPE(GvIOp(gv)) = '-';
3961 IoTYPE(GvIOp(gv)) = '<';
3962 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
3963 /* if the script was opened in binmode, we need to revert
3964 * it to text mode for compatibility; but only iff it has CRs
3965 * XXX this is a questionable hack at best. */
3966 if (PL_bufend-PL_bufptr > 2
3967 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
3970 if (IoTYPE(GvIOp(gv)) == '<') {
3971 loc = PerlIO_tell(PL_rsfp);
3972 (void)PerlIO_seek(PL_rsfp, 0L, 0);
3974 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
3975 #if defined(__BORLANDC__)
3976 /* XXX see note in do_binmode() */
3977 ((FILE*)PL_rsfp)->flags |= _F_BIN;
3980 PerlIO_seek(PL_rsfp, loc, 0);
3995 if (PL_expect == XSTATE) {
4002 if (*s == ':' && s[1] == ':') {
4005 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4006 if (!(tmp = keyword(PL_tokenbuf, len)))
4007 Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
4021 LOP(OP_ACCEPT,XTERM);
4027 LOP(OP_ATAN2,XTERM);
4033 LOP(OP_BINMODE,XTERM);
4036 LOP(OP_BLESS,XTERM);
4045 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
4062 if (!PL_cryptseen) {
4063 PL_cryptseen = TRUE;
4067 LOP(OP_CRYPT,XTERM);
4070 if (ckWARN(WARN_CHMOD)) {
4071 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4072 if (*d != '0' && isDIGIT(*d))
4073 Perl_warner(aTHX_ WARN_CHMOD,
4074 "chmod() mode argument is missing initial 0");
4076 LOP(OP_CHMOD,XTERM);
4079 LOP(OP_CHOWN,XTERM);
4082 LOP(OP_CONNECT,XTERM);
4098 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4102 PL_hints |= HINT_BLOCK_SCOPE;
4112 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
4113 LOP(OP_DBMOPEN,XTERM);
4119 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4126 yylval.ival = CopLINE(PL_curcop);
4140 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
4141 UNIBRACK(OP_ENTEREVAL);
4156 case KEY_endhostent:
4162 case KEY_endservent:
4165 case KEY_endprotoent:
4176 yylval.ival = CopLINE(PL_curcop);
4178 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
4180 if ((PL_bufend - p) >= 3 &&
4181 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
4183 else if ((PL_bufend - p) >= 4 &&
4184 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
4187 if (isIDFIRST_lazy_if(p,UTF)) {
4188 p = scan_ident(p, PL_bufend,
4189 PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4193 Perl_croak(aTHX_ "Missing $ on loop variable");
4198 LOP(OP_FORMLINE,XTERM);
4204 LOP(OP_FCNTL,XTERM);
4210 LOP(OP_FLOCK,XTERM);
4219 LOP(OP_GREPSTART, XREF);
4222 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4237 case KEY_getpriority:
4238 LOP(OP_GETPRIORITY,XTERM);
4240 case KEY_getprotobyname:
4243 case KEY_getprotobynumber:
4244 LOP(OP_GPBYNUMBER,XTERM);
4246 case KEY_getprotoent:
4258 case KEY_getpeername:
4259 UNI(OP_GETPEERNAME);
4261 case KEY_gethostbyname:
4264 case KEY_gethostbyaddr:
4265 LOP(OP_GHBYADDR,XTERM);
4267 case KEY_gethostent:
4270 case KEY_getnetbyname:
4273 case KEY_getnetbyaddr:
4274 LOP(OP_GNBYADDR,XTERM);
4279 case KEY_getservbyname:
4280 LOP(OP_GSBYNAME,XTERM);
4282 case KEY_getservbyport:
4283 LOP(OP_GSBYPORT,XTERM);
4285 case KEY_getservent:
4288 case KEY_getsockname:
4289 UNI(OP_GETSOCKNAME);
4291 case KEY_getsockopt:
4292 LOP(OP_GSOCKOPT,XTERM);
4314 yylval.ival = CopLINE(PL_curcop);
4318 LOP(OP_INDEX,XTERM);
4324 LOP(OP_IOCTL,XTERM);
4336 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4368 LOP(OP_LISTEN,XTERM);
4377 s = scan_pat(s,OP_MATCH);
4378 TERM(sublex_start());
4381 LOP(OP_MAPSTART, XREF);
4384 LOP(OP_MKDIR,XTERM);
4387 LOP(OP_MSGCTL,XTERM);
4390 LOP(OP_MSGGET,XTERM);
4393 LOP(OP_MSGRCV,XTERM);
4396 LOP(OP_MSGSND,XTERM);
4402 if (isIDFIRST_lazy_if(s,UTF)) {
4403 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
4404 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
4406 PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
4407 if (!PL_in_my_stash) {
4410 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
4418 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4425 if (PL_expect != XSTATE)
4426 yyerror("\"no\" not allowed in expression");
4427 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4428 s = force_version(s);
4433 if (*s == '(' || (s = skipspace(s), *s == '('))
4440 if (isIDFIRST_lazy_if(s,UTF)) {
4442 for (d = s; isALNUM_lazy_if(d,UTF); d++) ;
4444 if (strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE))
4445 Perl_warner(aTHX_ WARN_PRECEDENCE,
4446 "Precedence problem: open %.*s should be open(%.*s)",
4452 yylval.ival = OP_OR;
4462 LOP(OP_OPEN_DIR,XTERM);
4465 checkcomma(s,PL_tokenbuf,"filehandle");
4469 checkcomma(s,PL_tokenbuf,"filehandle");
4488 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4492 LOP(OP_PIPE_OP,XTERM);
4495 s = scan_str(s,FALSE,FALSE);
4497 missingterm((char*)0);
4498 yylval.ival = OP_CONST;
4499 TERM(sublex_start());
4505 s = scan_str(s,FALSE,FALSE);
4507 missingterm((char*)0);
4509 if (SvCUR(PL_lex_stuff)) {
4512 d = SvPV_force(PL_lex_stuff, len);
4514 for (; isSPACE(*d) && len; --len, ++d) ;
4517 if (!warned && ckWARN(WARN_QW)) {
4518 for (; !isSPACE(*d) && len; --len, ++d) {
4520 Perl_warner(aTHX_ WARN_QW,
4521 "Possible attempt to separate words with commas");
4524 else if (*d == '#') {
4525 Perl_warner(aTHX_ WARN_QW,
4526 "Possible attempt to put comments in qw() list");
4532 for (; !isSPACE(*d) && len; --len, ++d) ;
4534 words = append_elem(OP_LIST, words,
4535 newSVOP(OP_CONST, 0, tokeq(newSVpvn(b, d-b))));
4539 PL_nextval[PL_nexttoke].opval = words;
4544 SvREFCNT_dec(PL_lex_stuff);
4545 PL_lex_stuff = Nullsv;
4550 s = scan_str(s,FALSE,FALSE);
4552 missingterm((char*)0);
4553 yylval.ival = OP_STRINGIFY;
4554 if (SvIVX(PL_lex_stuff) == '\'')
4555 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
4556 TERM(sublex_start());
4559 s = scan_pat(s,OP_QR);
4560 TERM(sublex_start());
4563 s = scan_str(s,FALSE,FALSE);
4565 missingterm((char*)0);
4566 yylval.ival = OP_BACKTICK;
4568 TERM(sublex_start());
4575 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4576 s = force_version(s);
4579 *PL_tokenbuf = '\0';
4580 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4581 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
4582 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
4584 yyerror("<> should be quotes");
4592 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4596 LOP(OP_RENAME,XTERM);
4605 LOP(OP_RINDEX,XTERM);
4628 LOP(OP_REVERSE,XTERM);
4639 TERM(sublex_start());
4641 TOKEN(1); /* force error */
4650 LOP(OP_SELECT,XTERM);
4656 LOP(OP_SEMCTL,XTERM);
4659 LOP(OP_SEMGET,XTERM);
4662 LOP(OP_SEMOP,XTERM);
4668 LOP(OP_SETPGRP,XTERM);
4670 case KEY_setpriority:
4671 LOP(OP_SETPRIORITY,XTERM);
4673 case KEY_sethostent:
4679 case KEY_setservent:
4682 case KEY_setprotoent:
4692 LOP(OP_SEEKDIR,XTERM);
4694 case KEY_setsockopt:
4695 LOP(OP_SSOCKOPT,XTERM);
4701 LOP(OP_SHMCTL,XTERM);
4704 LOP(OP_SHMGET,XTERM);
4707 LOP(OP_SHMREAD,XTERM);
4710 LOP(OP_SHMWRITE,XTERM);
4713 LOP(OP_SHUTDOWN,XTERM);
4722 LOP(OP_SOCKET,XTERM);
4724 case KEY_socketpair:
4725 LOP(OP_SOCKPAIR,XTERM);
4728 checkcomma(s,PL_tokenbuf,"subroutine name");
4730 if (*s == ';' || *s == ')') /* probably a close */
4731 Perl_croak(aTHX_ "sort is now a reserved word");
4733 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4737 LOP(OP_SPLIT,XTERM);
4740 LOP(OP_SPRINTF,XTERM);
4743 LOP(OP_SPLICE,XTERM);
4758 LOP(OP_SUBSTR,XTERM);
4764 char tmpbuf[sizeof PL_tokenbuf];
4766 expectation attrful;
4767 bool have_name, have_proto;
4772 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
4773 (*s == ':' && s[1] == ':'))
4776 attrful = XATTRBLOCK;
4777 /* remember buffer pos'n for later force_word */
4778 tboffset = s - PL_oldbufptr;
4779 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4780 if (strchr(tmpbuf, ':'))
4781 sv_setpv(PL_subname, tmpbuf);
4783 sv_setsv(PL_subname,PL_curstname);
4784 sv_catpvn(PL_subname,"::",2);
4785 sv_catpvn(PL_subname,tmpbuf,len);
4792 Perl_croak(aTHX_ "Missing name in \"my sub\"");
4793 PL_expect = XTERMBLOCK;
4794 attrful = XATTRTERM;
4795 sv_setpv(PL_subname,"?");
4799 if (key == KEY_format) {
4801 PL_lex_formbrack = PL_lex_brackets + 1;
4803 (void) force_word(PL_oldbufptr + tboffset, WORD,
4808 /* Look for a prototype */
4812 s = scan_str(s,FALSE,FALSE);
4815 SvREFCNT_dec(PL_lex_stuff);
4816 PL_lex_stuff = Nullsv;
4817 Perl_croak(aTHX_ "Prototype not terminated");
4820 d = SvPVX(PL_lex_stuff);
4822 for (p = d; *p; ++p) {
4827 SvCUR(PL_lex_stuff) = tmp;
4835 if (*s == ':' && s[1] != ':')
4836 PL_expect = attrful;
4839 PL_nextval[PL_nexttoke].opval =
4840 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4841 PL_lex_stuff = Nullsv;
4845 sv_setpv(PL_subname,"__ANON__");
4848 (void) force_word(PL_oldbufptr + tboffset, WORD,
4857 LOP(OP_SYSTEM,XREF);
4860 LOP(OP_SYMLINK,XTERM);
4863 LOP(OP_SYSCALL,XTERM);
4866 LOP(OP_SYSOPEN,XTERM);
4869 LOP(OP_SYSSEEK,XTERM);
4872 LOP(OP_SYSREAD,XTERM);
4875 LOP(OP_SYSWRITE,XTERM);
4879 TERM(sublex_start());
4900 LOP(OP_TRUNCATE,XTERM);
4912 yylval.ival = CopLINE(PL_curcop);
4916 yylval.ival = CopLINE(PL_curcop);
4920 LOP(OP_UNLINK,XTERM);
4926 LOP(OP_UNPACK,XTERM);
4929 LOP(OP_UTIME,XTERM);
4932 if (ckWARN(WARN_UMASK)) {
4933 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4934 if (*d != '0' && isDIGIT(*d))
4935 Perl_warner(aTHX_ WARN_UMASK,
4936 "umask: argument is missing initial 0");
4941 LOP(OP_UNSHIFT,XTERM);
4944 if (PL_expect != XSTATE)
4945 yyerror("\"use\" not allowed in expression");
4947 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4948 s = force_version(s);
4949 if (*s == ';' || (s = skipspace(s), *s == ';')) {
4950 PL_nextval[PL_nexttoke].opval = Nullop;
4955 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4956 s = force_version(s);
4968 yylval.ival = CopLINE(PL_curcop);
4972 PL_hints |= HINT_BLOCK_SCOPE;
4979 LOP(OP_WAITPID,XTERM);
4987 static char ctl_l[2];
4989 if (ctl_l[0] == '\0')
4990 ctl_l[0] = toCTRL('L');
4991 gv_fetchpv(ctl_l,TRUE, SVt_PV);
4994 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
4999 if (PL_expect == XOPERATOR)
5005 yylval.ival = OP_XOR;
5010 TERM(sublex_start());
5015 #pragma segment Main
5019 Perl_keyword(pTHX_ register char *d, I32 len)
5024 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
5025 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
5026 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
5027 if (strEQ(d,"__DATA__")) return KEY___DATA__;
5028 if (strEQ(d,"__END__")) return KEY___END__;
5032 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
5037 if (strEQ(d,"and")) return -KEY_and;
5038 if (strEQ(d,"abs")) return -KEY_abs;
5041 if (strEQ(d,"alarm")) return -KEY_alarm;
5042 if (strEQ(d,"atan2")) return -KEY_atan2;
5045 if (strEQ(d,"accept")) return -KEY_accept;
5050 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
5053 if (strEQ(d,"bless")) return -KEY_bless;
5054 if (strEQ(d,"bind")) return -KEY_bind;
5055 if (strEQ(d,"binmode")) return -KEY_binmode;
5058 if (strEQ(d,"CORE")) return -KEY_CORE;
5059 if (strEQ(d,"CHECK")) return KEY_CHECK;
5064 if (strEQ(d,"cmp")) return -KEY_cmp;
5065 if (strEQ(d,"chr")) return -KEY_chr;
5066 if (strEQ(d,"cos")) return -KEY_cos;
5069 if (strEQ(d,"chop")) return KEY_chop;
5072 if (strEQ(d,"close")) return -KEY_close;
5073 if (strEQ(d,"chdir")) return -KEY_chdir;
5074 if (strEQ(d,"chomp")) return KEY_chomp;
5075 if (strEQ(d,"chmod")) return -KEY_chmod;
5076 if (strEQ(d,"chown")) return -KEY_chown;
5077 if (strEQ(d,"crypt")) return -KEY_crypt;
5080 if (strEQ(d,"chroot")) return -KEY_chroot;
5081 if (strEQ(d,"caller")) return -KEY_caller;
5084 if (strEQ(d,"connect")) return -KEY_connect;
5087 if (strEQ(d,"closedir")) return -KEY_closedir;
5088 if (strEQ(d,"continue")) return -KEY_continue;
5093 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
5098 if (strEQ(d,"do")) return KEY_do;
5101 if (strEQ(d,"die")) return -KEY_die;
5104 if (strEQ(d,"dump")) return -KEY_dump;
5107 if (strEQ(d,"delete")) return KEY_delete;
5110 if (strEQ(d,"defined")) return KEY_defined;
5111 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
5114 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
5119 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
5120 if (strEQ(d,"END")) return KEY_END;
5125 if (strEQ(d,"eq")) return -KEY_eq;
5128 if (strEQ(d,"eof")) return -KEY_eof;
5129 if (strEQ(d,"exp")) return -KEY_exp;
5132 if (strEQ(d,"else")) return KEY_else;
5133 if (strEQ(d,"exit")) return -KEY_exit;
5134 if (strEQ(d,"eval")) return KEY_eval;
5135 if (strEQ(d,"exec")) return -KEY_exec;
5136 if (strEQ(d,"each")) return KEY_each;
5139 if (strEQ(d,"elsif")) return KEY_elsif;
5142 if (strEQ(d,"exists")) return KEY_exists;
5143 if (strEQ(d,"elseif")) Perl_warn(aTHX_ "elseif should be elsif");
5146 if (strEQ(d,"endgrent")) return -KEY_endgrent;
5147 if (strEQ(d,"endpwent")) return -KEY_endpwent;
5150 if (strEQ(d,"endnetent")) return -KEY_endnetent;
5153 if (strEQ(d,"endhostent")) return -KEY_endhostent;
5154 if (strEQ(d,"endservent")) return -KEY_endservent;
5157 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
5164 if (strEQ(d,"for")) return KEY_for;
5167 if (strEQ(d,"fork")) return -KEY_fork;
5170 if (strEQ(d,"fcntl")) return -KEY_fcntl;
5171 if (strEQ(d,"flock")) return -KEY_flock;
5174 if (strEQ(d,"format")) return KEY_format;
5175 if (strEQ(d,"fileno")) return -KEY_fileno;
5178 if (strEQ(d,"foreach")) return KEY_foreach;
5181 if (strEQ(d,"formline")) return -KEY_formline;
5187 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
5188 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
5192 if (strnEQ(d,"get",3)) {
5197 if (strEQ(d,"ppid")) return -KEY_getppid;
5198 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
5201 if (strEQ(d,"pwent")) return -KEY_getpwent;
5202 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
5203 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
5206 if (strEQ(d,"peername")) return -KEY_getpeername;
5207 if (strEQ(d,"protoent")) return -KEY_getprotoent;
5208 if (strEQ(d,"priority")) return -KEY_getpriority;
5211 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
5214 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
5218 else if (*d == 'h') {
5219 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
5220 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
5221 if (strEQ(d,"hostent")) return -KEY_gethostent;
5223 else if (*d == 'n') {
5224 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
5225 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
5226 if (strEQ(d,"netent")) return -KEY_getnetent;
5228 else if (*d == 's') {
5229 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
5230 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
5231 if (strEQ(d,"servent")) return -KEY_getservent;
5232 if (strEQ(d,"sockname")) return -KEY_getsockname;
5233 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
5235 else if (*d == 'g') {
5236 if (strEQ(d,"grent")) return -KEY_getgrent;
5237 if (strEQ(d,"grnam")) return -KEY_getgrnam;
5238 if (strEQ(d,"grgid")) return -KEY_getgrgid;
5240 else if (*d == 'l') {
5241 if (strEQ(d,"login")) return -KEY_getlogin;
5243 else if (strEQ(d,"c")) return -KEY_getc;
5248 if (strEQ(d,"gt")) return -KEY_gt;
5249 if (strEQ(d,"ge")) return -KEY_ge;
5252 if (strEQ(d,"grep")) return KEY_grep;
5253 if (strEQ(d,"goto")) return KEY_goto;
5254 if (strEQ(d,"glob")) return KEY_glob;
5257 if (strEQ(d,"gmtime")) return -KEY_gmtime;
5262 if (strEQ(d,"hex")) return -KEY_hex;
5265 if (strEQ(d,"INIT")) return KEY_INIT;
5270 if (strEQ(d,"if")) return KEY_if;
5273 if (strEQ(d,"int")) return -KEY_int;
5276 if (strEQ(d,"index")) return -KEY_index;
5277 if (strEQ(d,"ioctl")) return -KEY_ioctl;
5282 if (strEQ(d,"join")) return -KEY_join;
5286 if (strEQ(d,"keys")) return KEY_keys;
5287 if (strEQ(d,"kill")) return -KEY_kill;
5292 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
5293 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
5299 if (strEQ(d,"lt")) return -KEY_lt;
5300 if (strEQ(d,"le")) return -KEY_le;
5301 if (strEQ(d,"lc")) return -KEY_lc;
5304 if (strEQ(d,"log")) return -KEY_log;
5307 if (strEQ(d,"last")) return KEY_last;
5308 if (strEQ(d,"link")) return -KEY_link;
5309 if (strEQ(d,"lock")) return -KEY_lock;
5312 if (strEQ(d,"local")) return KEY_local;
5313 if (strEQ(d,"lstat")) return -KEY_lstat;
5316 if (strEQ(d,"length")) return -KEY_length;
5317 if (strEQ(d,"listen")) return -KEY_listen;
5320 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
5323 if (strEQ(d,"localtime")) return -KEY_localtime;
5329 case 1: return KEY_m;
5331 if (strEQ(d,"my")) return KEY_my;
5334 if (strEQ(d,"map")) return KEY_map;
5337 if (strEQ(d,"mkdir")) return -KEY_mkdir;
5340 if (strEQ(d,"msgctl")) return -KEY_msgctl;
5341 if (strEQ(d,"msgget")) return -KEY_msgget;
5342 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
5343 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
5348 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
5351 if (strEQ(d,"next")) return KEY_next;
5352 if (strEQ(d,"ne")) return -KEY_ne;
5353 if (strEQ(d,"not")) return -KEY_not;
5354 if (strEQ(d,"no")) return KEY_no;
5359 if (strEQ(d,"or")) return -KEY_or;
5362 if (strEQ(d,"ord")) return -KEY_ord;
5363 if (strEQ(d,"oct")) return -KEY_oct;
5364 if (strEQ(d,"our")) return KEY_our;
5367 if (strEQ(d,"open")) return -KEY_open;
5370 if (strEQ(d,"opendir")) return -KEY_opendir;
5377 if (strEQ(d,"pop")) return KEY_pop;
5378 if (strEQ(d,"pos")) return KEY_pos;
5381 if (strEQ(d,"push")) return KEY_push;
5382 if (strEQ(d,"pack")) return -KEY_pack;
5383 if (strEQ(d,"pipe")) return -KEY_pipe;
5386 if (strEQ(d,"print")) return KEY_print;
5389 if (strEQ(d,"printf")) return KEY_printf;
5392 if (strEQ(d,"package")) return KEY_package;
5395 if (strEQ(d,"prototype")) return KEY_prototype;
5400 if (strEQ(d,"q")) return KEY_q;
5401 if (strEQ(d,"qr")) return KEY_qr;
5402 if (strEQ(d,"qq")) return KEY_qq;
5403 if (strEQ(d,"qw")) return KEY_qw;
5404 if (strEQ(d,"qx")) return KEY_qx;
5406 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
5411 if (strEQ(d,"ref")) return -KEY_ref;
5414 if (strEQ(d,"read")) return -KEY_read;
5415 if (strEQ(d,"rand")) return -KEY_rand;
5416 if (strEQ(d,"recv")) return -KEY_recv;
5417 if (strEQ(d,"redo")) return KEY_redo;
5420 if (strEQ(d,"rmdir")) return -KEY_rmdir;
5421 if (strEQ(d,"reset")) return -KEY_reset;
5424 if (strEQ(d,"return")) return KEY_return;
5425 if (strEQ(d,"rename")) return -KEY_rename;
5426 if (strEQ(d,"rindex")) return -KEY_rindex;
5429 if (strEQ(d,"require")) return -KEY_require;
5430 if (strEQ(d,"reverse")) return -KEY_reverse;
5431 if (strEQ(d,"readdir")) return -KEY_readdir;
5434 if (strEQ(d,"readlink")) return -KEY_readlink;
5435 if (strEQ(d,"readline")) return -KEY_readline;
5436 if (strEQ(d,"readpipe")) return -KEY_readpipe;
5439 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
5445 case 0: return KEY_s;
5447 if (strEQ(d,"scalar")) return KEY_scalar;
5452 if (strEQ(d,"seek")) return -KEY_seek;
5453 if (strEQ(d,"send")) return -KEY_send;
5456 if (strEQ(d,"semop")) return -KEY_semop;
5459 if (strEQ(d,"select")) return -KEY_select;
5460 if (strEQ(d,"semctl")) return -KEY_semctl;
5461 if (strEQ(d,"semget")) return -KEY_semget;
5464 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
5465 if (strEQ(d,"seekdir")) return -KEY_seekdir;
5468 if (strEQ(d,"setpwent")) return -KEY_setpwent;
5469 if (strEQ(d,"setgrent")) return -KEY_setgrent;
5472 if (strEQ(d,"setnetent")) return -KEY_setnetent;
5475 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
5476 if (strEQ(d,"sethostent")) return -KEY_sethostent;
5477 if (strEQ(d,"setservent")) return -KEY_setservent;
5480 if (strEQ(d,"setpriority")) return -KEY_setpriority;
5481 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
5488 if (strEQ(d,"shift")) return KEY_shift;
5491 if (strEQ(d,"shmctl")) return -KEY_shmctl;
5492 if (strEQ(d,"shmget")) return -KEY_shmget;
5495 if (strEQ(d,"shmread")) return -KEY_shmread;
5498 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
5499 if (strEQ(d,"shutdown")) return -KEY_shutdown;
5504 if (strEQ(d,"sin")) return -KEY_sin;
5507 if (strEQ(d,"sleep")) return -KEY_sleep;
5510 if (strEQ(d,"sort")) return KEY_sort;
5511 if (strEQ(d,"socket")) return -KEY_socket;
5512 if (strEQ(d,"socketpair")) return -KEY_socketpair;
5515 if (strEQ(d,"split")) return KEY_split;
5516 if (strEQ(d,"sprintf")) return -KEY_sprintf;
5517 if (strEQ(d,"splice")) return KEY_splice;
5520 if (strEQ(d,"sqrt")) return -KEY_sqrt;
5523 if (strEQ(d,"srand")) return -KEY_srand;
5526 if (strEQ(d,"stat")) return -KEY_stat;
5527 if (strEQ(d,"study")) return KEY_study;
5530 if (strEQ(d,"substr")) return -KEY_substr;
5531 if (strEQ(d,"sub")) return KEY_sub;
5536 if (strEQ(d,"system")) return -KEY_system;
5539 if (strEQ(d,"symlink")) return -KEY_symlink;
5540 if (strEQ(d,"syscall")) return -KEY_syscall;
5541 if (strEQ(d,"sysopen")) return -KEY_sysopen;
5542 if (strEQ(d,"sysread")) return -KEY_sysread;
5543 if (strEQ(d,"sysseek")) return -KEY_sysseek;
5546 if (strEQ(d,"syswrite")) return -KEY_syswrite;
5555 if (strEQ(d,"tr")) return KEY_tr;
5558 if (strEQ(d,"tie")) return KEY_tie;
5561 if (strEQ(d,"tell")) return -KEY_tell;
5562 if (strEQ(d,"tied")) return KEY_tied;
5563 if (strEQ(d,"time")) return -KEY_time;
5566 if (strEQ(d,"times")) return -KEY_times;
5569 if (strEQ(d,"telldir")) return -KEY_telldir;
5572 if (strEQ(d,"truncate")) return -KEY_truncate;
5579 if (strEQ(d,"uc")) return -KEY_uc;
5582 if (strEQ(d,"use")) return KEY_use;
5585 if (strEQ(d,"undef")) return KEY_undef;
5586 if (strEQ(d,"until")) return KEY_until;
5587 if (strEQ(d,"untie")) return KEY_untie;
5588 if (strEQ(d,"utime")) return -KEY_utime;
5589 if (strEQ(d,"umask")) return -KEY_umask;
5592 if (strEQ(d,"unless")) return KEY_unless;
5593 if (strEQ(d,"unpack")) return -KEY_unpack;
5594 if (strEQ(d,"unlink")) return -KEY_unlink;
5597 if (strEQ(d,"unshift")) return KEY_unshift;
5598 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
5603 if (strEQ(d,"values")) return -KEY_values;
5604 if (strEQ(d,"vec")) return -KEY_vec;
5609 if (strEQ(d,"warn")) return -KEY_warn;
5610 if (strEQ(d,"wait")) return -KEY_wait;
5613 if (strEQ(d,"while")) return KEY_while;
5614 if (strEQ(d,"write")) return -KEY_write;
5617 if (strEQ(d,"waitpid")) return -KEY_waitpid;
5620 if (strEQ(d,"wantarray")) return -KEY_wantarray;
5625 if (len == 1) return -KEY_x;
5626 if (strEQ(d,"xor")) return -KEY_xor;
5629 if (len == 1) return KEY_y;
5638 S_checkcomma(pTHX_ register char *s, char *name, char *what)
5642 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
5643 dTHR; /* only for ckWARN */
5644 if (ckWARN(WARN_SYNTAX)) {
5646 for (w = s+2; *w && level; w++) {
5653 for (; *w && isSPACE(*w); w++) ;
5654 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
5655 Perl_warner(aTHX_ WARN_SYNTAX,
5656 "%s (...) interpreted as function",name);
5659 while (s < PL_bufend && isSPACE(*s))
5663 while (s < PL_bufend && isSPACE(*s))
5665 if (isIDFIRST_lazy_if(s,UTF)) {
5667 while (isALNUM_lazy_if(s,UTF))
5669 while (s < PL_bufend && isSPACE(*s))
5674 kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
5678 Perl_croak(aTHX_ "No comma allowed after %s", what);
5683 /* Either returns sv, or mortalizes sv and returns a new SV*.
5684 Best used as sv=new_constant(..., sv, ...).
5685 If s, pv are NULL, calls subroutine with one argument,
5686 and type is used with error messages only. */
5689 S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv,
5693 HV *table = GvHV(PL_hintgv); /* ^H */
5697 const char *why1, *why2, *why3;
5699 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
5702 why1 = "%^H is not consistent";
5703 why2 = strEQ(key,"charnames")
5704 ? " (missing \"use charnames ...\"?)"
5708 msg = Perl_newSVpvf(aTHX_ "constant(%s): %s%s%s",
5709 (type ? type: "undef"), why1, why2, why3);
5710 yyerror(SvPVX(msg));
5714 cvp = hv_fetch(table, key, strlen(key), FALSE);
5715 if (!cvp || !SvOK(*cvp)) {
5718 why3 = "} is not defined";
5721 sv_2mortal(sv); /* Parent created it permanently */
5724 pv = sv_2mortal(newSVpvn(s, len));
5726 typesv = sv_2mortal(newSVpv(type, 0));
5728 typesv = &PL_sv_undef;
5730 PUSHSTACKi(PERLSI_OVERLOAD);
5743 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
5747 /* Check the eval first */
5748 if (!PL_in_eval && SvTRUE(ERRSV)) {
5750 sv_catpv(ERRSV, "Propagated");
5751 yyerror(SvPV(ERRSV, n_a)); /* Duplicates the message inside eval */
5753 res = SvREFCNT_inc(sv);
5757 (void)SvREFCNT_inc(res);
5766 why1 = "Call to &{$^H{";
5768 why3 = "}} did not return a defined value";
5777 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
5779 register char *d = dest;
5780 register char *e = d + destlen - 3; /* two-character token, ending NUL */
5783 Perl_croak(aTHX_ ident_too_long);
5784 if (isALNUM(*s)) /* UTF handled below */
5786 else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) {
5791 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
5795 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5796 char *t = s + UTF8SKIP(s);
5797 while (*t & 0x80 && is_utf8_mark((U8*)t))
5799 if (d + (t - s) > e)
5800 Perl_croak(aTHX_ ident_too_long);
5801 Copy(s, d, t - s, char);
5814 S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
5824 e = d + destlen - 3; /* two-character token, ending NUL */
5826 while (isDIGIT(*s)) {
5828 Perl_croak(aTHX_ ident_too_long);
5835 Perl_croak(aTHX_ ident_too_long);
5836 if (isALNUM(*s)) /* UTF handled below */
5838 else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
5843 else if (*s == ':' && s[1] == ':') {
5847 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5848 char *t = s + UTF8SKIP(s);
5849 while (*t & 0x80 && is_utf8_mark((U8*)t))
5851 if (d + (t - s) > e)
5852 Perl_croak(aTHX_ ident_too_long);
5853 Copy(s, d, t - s, char);
5864 if (PL_lex_state != LEX_NORMAL)
5865 PL_lex_state = LEX_INTERPENDMAYBE;
5868 if (*s == '$' && s[1] &&
5869 (isALNUM_lazy_if(s+1,UTF) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
5882 if (*d == '^' && *s && isCONTROLVAR(*s)) {
5887 if (isSPACE(s[-1])) {
5890 if (!SPACE_OR_TAB(ch)) {
5896 if (isIDFIRST_lazy_if(d,UTF)) {
5900 while ((e < send && isALNUM_lazy_if(e,UTF)) || *e == ':') {
5902 while (e < send && *e & 0x80 && is_utf8_mark((U8*)e))
5905 Copy(s, d, e - s, char);
5910 while ((isALNUM(*s) || *s == ':') && d < e)
5913 Perl_croak(aTHX_ ident_too_long);
5916 while (s < send && SPACE_OR_TAB(*s)) s++;
5917 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
5918 dTHR; /* only for ckWARN */
5919 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
5920 const char *brack = *s == '[' ? "[...]" : "{...}";
5921 Perl_warner(aTHX_ WARN_AMBIGUOUS,
5922 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
5923 funny, dest, brack, funny, dest, brack);
5926 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
5930 /* Handle extended ${^Foo} variables
5931 * 1999-02-27 mjd-perl-patch@plover.com */
5932 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
5936 while (isALNUM(*s) && d < e) {
5940 Perl_croak(aTHX_ ident_too_long);
5945 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
5946 PL_lex_state = LEX_INTERPEND;
5949 if (PL_lex_state == LEX_NORMAL) {
5950 dTHR; /* only for ckWARN */
5951 if (ckWARN(WARN_AMBIGUOUS) &&
5952 (keyword(dest, d - dest) || get_cv(dest, FALSE)))
5954 Perl_warner(aTHX_ WARN_AMBIGUOUS,
5955 "Ambiguous use of %c{%s} resolved to %c%s",
5956 funny, dest, funny, dest);
5961 s = bracket; /* let the parser handle it */
5965 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
5966 PL_lex_state = LEX_INTERPEND;
5971 Perl_pmflag(pTHX_ U16 *pmfl, int ch)
5976 *pmfl |= PMf_GLOBAL;
5978 *pmfl |= PMf_CONTINUE;
5982 *pmfl |= PMf_MULTILINE;
5984 *pmfl |= PMf_SINGLELINE;
5986 *pmfl |= PMf_EXTENDED;
5990 S_scan_pat(pTHX_ char *start, I32 type)
5995 s = scan_str(start,FALSE,FALSE);
5998 SvREFCNT_dec(PL_lex_stuff);
5999 PL_lex_stuff = Nullsv;
6000 Perl_croak(aTHX_ "Search pattern not terminated");
6003 pm = (PMOP*)newPMOP(type, 0);
6004 if (PL_multi_open == '?')
6005 pm->op_pmflags |= PMf_ONCE;
6007 while (*s && strchr("iomsx", *s))
6008 pmflag(&pm->op_pmflags,*s++);
6011 while (*s && strchr("iogcmsx", *s))
6012 pmflag(&pm->op_pmflags,*s++);
6014 pm->op_pmpermflags = pm->op_pmflags;
6016 PL_lex_op = (OP*)pm;
6017 yylval.ival = OP_MATCH;
6022 S_scan_subst(pTHX_ char *start)
6029 yylval.ival = OP_NULL;
6031 s = scan_str(start,FALSE,FALSE);
6035 SvREFCNT_dec(PL_lex_stuff);
6036 PL_lex_stuff = Nullsv;
6037 Perl_croak(aTHX_ "Substitution pattern not terminated");
6040 if (s[-1] == PL_multi_open)
6043 first_start = PL_multi_start;
6044 s = scan_str(s,FALSE,FALSE);
6047 SvREFCNT_dec(PL_lex_stuff);
6048 PL_lex_stuff = Nullsv;
6050 SvREFCNT_dec(PL_lex_repl);
6051 PL_lex_repl = Nullsv;
6052 Perl_croak(aTHX_ "Substitution replacement not terminated");
6054 PL_multi_start = first_start; /* so whole substitution is taken together */
6056 pm = (PMOP*)newPMOP(OP_SUBST, 0);
6062 else if (strchr("iogcmsx", *s))
6063 pmflag(&pm->op_pmflags,*s++);
6070 PL_sublex_info.super_bufptr = s;
6071 PL_sublex_info.super_bufend = PL_bufend;
6073 pm->op_pmflags |= PMf_EVAL;
6074 repl = newSVpvn("",0);
6076 sv_catpv(repl, es ? "eval " : "do ");
6077 sv_catpvn(repl, "{ ", 2);
6078 sv_catsv(repl, PL_lex_repl);
6079 sv_catpvn(repl, " };", 2);
6081 SvREFCNT_dec(PL_lex_repl);
6085 pm->op_pmpermflags = pm->op_pmflags;
6086 PL_lex_op = (OP*)pm;
6087 yylval.ival = OP_SUBST;
6092 S_scan_trans(pTHX_ char *start)
6103 yylval.ival = OP_NULL;
6105 s = scan_str(start,FALSE,FALSE);
6108 SvREFCNT_dec(PL_lex_stuff);
6109 PL_lex_stuff = Nullsv;
6110 Perl_croak(aTHX_ "Transliteration pattern not terminated");
6112 if (s[-1] == PL_multi_open)
6115 s = scan_str(s,FALSE,FALSE);
6118 SvREFCNT_dec(PL_lex_stuff);
6119 PL_lex_stuff = Nullsv;
6121 SvREFCNT_dec(PL_lex_repl);
6122 PL_lex_repl = Nullsv;
6123 Perl_croak(aTHX_ "Transliteration replacement not terminated");
6127 o = newSVOP(OP_TRANS, 0, 0);
6128 utf8 = OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF;
6131 New(803,tbl,256,short);
6132 o = newPVOP(OP_TRANS, 0, (char*)tbl);
6136 complement = del = squash = 0;
6137 while (strchr("cdsCU", *s)) {
6139 complement = OPpTRANS_COMPLEMENT;
6141 del = OPpTRANS_DELETE;
6143 squash = OPpTRANS_SQUASH;
6148 utf8 &= ~OPpTRANS_FROM_UTF;
6150 utf8 |= OPpTRANS_FROM_UTF;
6154 utf8 &= ~OPpTRANS_TO_UTF;
6156 utf8 |= OPpTRANS_TO_UTF;
6159 Perl_croak(aTHX_ "Too many /C and /U options");
6164 o->op_private = del|squash|complement|utf8;
6167 yylval.ival = OP_TRANS;
6172 S_scan_heredoc(pTHX_ register char *s)
6176 I32 op_type = OP_SCALAR;
6183 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
6187 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
6190 for (peek = s; SPACE_OR_TAB(*peek); peek++) ;
6191 if (*peek && strchr("`'\"",*peek)) {
6194 s = delimcpy(d, e, s, PL_bufend, term, &len);
6204 if (!isALNUM_lazy_if(s,UTF))
6205 deprecate("bare << to mean <<\"\"");
6206 for (; isALNUM_lazy_if(s,UTF); s++) {
6211 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
6212 Perl_croak(aTHX_ "Delimiter for here document is too long");
6215 len = d - PL_tokenbuf;
6216 #ifndef PERL_STRICT_CR
6217 d = strchr(s, '\r');
6221 while (s < PL_bufend) {
6227 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
6236 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6241 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
6242 herewas = newSVpvn(s,PL_bufend-s);
6244 s--, herewas = newSVpvn(s,d-s);
6245 s += SvCUR(herewas);
6247 tmpstr = NEWSV(87,79);
6248 sv_upgrade(tmpstr, SVt_PVIV);
6253 else if (term == '`') {
6254 op_type = OP_BACKTICK;
6255 SvIVX(tmpstr) = '\\';
6259 PL_multi_start = CopLINE(PL_curcop);
6260 PL_multi_open = PL_multi_close = '<';
6261 term = *PL_tokenbuf;
6262 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
6263 char *bufptr = PL_sublex_info.super_bufptr;
6264 char *bufend = PL_sublex_info.super_bufend;
6265 char *olds = s - SvCUR(herewas);
6266 s = strchr(bufptr, '\n');
6270 while (s < bufend &&
6271 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6273 CopLINE_inc(PL_curcop);
6276 CopLINE_set(PL_curcop, PL_multi_start);
6277 missingterm(PL_tokenbuf);
6279 sv_setpvn(herewas,bufptr,d-bufptr+1);
6280 sv_setpvn(tmpstr,d+1,s-d);
6282 sv_catpvn(herewas,s,bufend-s);
6283 (void)strcpy(bufptr,SvPVX(herewas));
6290 while (s < PL_bufend &&
6291 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6293 CopLINE_inc(PL_curcop);
6295 if (s >= PL_bufend) {
6296 CopLINE_set(PL_curcop, PL_multi_start);
6297 missingterm(PL_tokenbuf);
6299 sv_setpvn(tmpstr,d+1,s-d);
6301 CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
6303 sv_catpvn(herewas,s,PL_bufend-s);
6304 sv_setsv(PL_linestr,herewas);
6305 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
6306 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6309 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
6310 while (s >= PL_bufend) { /* multiple line string? */
6312 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6313 CopLINE_set(PL_curcop, PL_multi_start);
6314 missingterm(PL_tokenbuf);
6316 CopLINE_inc(PL_curcop);
6317 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6318 #ifndef PERL_STRICT_CR
6319 if (PL_bufend - PL_linestart >= 2) {
6320 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
6321 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
6323 PL_bufend[-2] = '\n';
6325 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6327 else if (PL_bufend[-1] == '\r')
6328 PL_bufend[-1] = '\n';
6330 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
6331 PL_bufend[-1] = '\n';
6333 if (PERLDB_LINE && PL_curstash != PL_debstash) {
6334 SV *sv = NEWSV(88,0);
6336 sv_upgrade(sv, SVt_PVMG);
6337 sv_setsv(sv,PL_linestr);
6338 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop),sv);
6340 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
6343 sv_catsv(PL_linestr,herewas);
6344 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6348 sv_catsv(tmpstr,PL_linestr);
6353 PL_multi_end = CopLINE(PL_curcop);
6354 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
6355 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
6356 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
6358 SvREFCNT_dec(herewas);
6359 PL_lex_stuff = tmpstr;
6360 yylval.ival = op_type;
6365 takes: current position in input buffer
6366 returns: new position in input buffer
6367 side-effects: yylval and lex_op are set.
6372 <FH> read from filehandle
6373 <pkg::FH> read from package qualified filehandle
6374 <pkg'FH> read from package qualified filehandle
6375 <$fh> read from filehandle in $fh
6381 S_scan_inputsymbol(pTHX_ char *start)
6383 register char *s = start; /* current position in buffer */
6389 d = PL_tokenbuf; /* start of temp holding space */
6390 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
6391 end = strchr(s, '\n');
6394 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
6396 /* die if we didn't have space for the contents of the <>,
6397 or if it didn't end, or if we see a newline
6400 if (len >= sizeof PL_tokenbuf)
6401 Perl_croak(aTHX_ "Excessively long <> operator");
6403 Perl_croak(aTHX_ "Unterminated <> operator");
6408 Remember, only scalar variables are interpreted as filehandles by
6409 this code. Anything more complex (e.g., <$fh{$num}>) will be
6410 treated as a glob() call.
6411 This code makes use of the fact that except for the $ at the front,
6412 a scalar variable and a filehandle look the same.
6414 if (*d == '$' && d[1]) d++;
6416 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
6417 while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
6420 /* If we've tried to read what we allow filehandles to look like, and
6421 there's still text left, then it must be a glob() and not a getline.
6422 Use scan_str to pull out the stuff between the <> and treat it
6423 as nothing more than a string.
6426 if (d - PL_tokenbuf != len) {
6427 yylval.ival = OP_GLOB;
6429 s = scan_str(start,FALSE,FALSE);
6431 Perl_croak(aTHX_ "Glob not terminated");
6435 /* we're in a filehandle read situation */
6438 /* turn <> into <ARGV> */
6440 (void)strcpy(d,"ARGV");
6442 /* if <$fh>, create the ops to turn the variable into a
6448 /* try to find it in the pad for this block, otherwise find
6449 add symbol table ops
6451 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
6452 OP *o = newOP(OP_PADSV, 0);
6454 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, o);
6457 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
6458 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
6459 newUNOP(OP_RV2SV, 0,
6460 newGVOP(OP_GV, 0, gv)));
6462 PL_lex_op->op_flags |= OPf_SPECIAL;
6463 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
6464 yylval.ival = OP_NULL;
6467 /* If it's none of the above, it must be a literal filehandle
6468 (<Foo::BAR> or <FOO>) so build a simple readline OP */
6470 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
6471 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
6472 yylval.ival = OP_NULL;
6481 takes: start position in buffer
6482 keep_quoted preserve \ on the embedded delimiter(s)
6483 keep_delims preserve the delimiters around the string
6484 returns: position to continue reading from buffer
6485 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
6486 updates the read buffer.
6488 This subroutine pulls a string out of the input. It is called for:
6489 q single quotes q(literal text)
6490 ' single quotes 'literal text'
6491 qq double quotes qq(interpolate $here please)
6492 " double quotes "interpolate $here please"
6493 qx backticks qx(/bin/ls -l)
6494 ` backticks `/bin/ls -l`
6495 qw quote words @EXPORT_OK = qw( func() $spam )
6496 m// regexp match m/this/
6497 s/// regexp substitute s/this/that/
6498 tr/// string transliterate tr/this/that/
6499 y/// string transliterate y/this/that/
6500 ($*@) sub prototypes sub foo ($)
6501 (stuff) sub attr parameters sub foo : attr(stuff)
6502 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
6504 In most of these cases (all but <>, patterns and transliterate)
6505 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
6506 calls scan_str(). s/// makes yylex() call scan_subst() which calls
6507 scan_str(). tr/// and y/// make yylex() call scan_trans() which
6510 It skips whitespace before the string starts, and treats the first
6511 character as the delimiter. If the delimiter is one of ([{< then
6512 the corresponding "close" character )]}> is used as the closing
6513 delimiter. It allows quoting of delimiters, and if the string has
6514 balanced delimiters ([{<>}]) it allows nesting.
6516 The lexer always reads these strings into lex_stuff, except in the
6517 case of the operators which take *two* arguments (s/// and tr///)
6518 when it checks to see if lex_stuff is full (presumably with the 1st
6519 arg to s or tr) and if so puts the string into lex_repl.
6524 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
6527 SV *sv; /* scalar value: string */
6528 char *tmps; /* temp string, used for delimiter matching */
6529 register char *s = start; /* current position in the buffer */
6530 register char term; /* terminating character */
6531 register char *to; /* current position in the sv's data */
6532 I32 brackets = 1; /* bracket nesting level */
6533 bool has_utf = FALSE; /* is there any utf8 content? */
6535 /* skip space before the delimiter */
6539 /* mark where we are, in case we need to report errors */
6542 /* after skipping whitespace, the next character is the terminator */
6544 if ((term & 0x80) && UTF)
6547 /* mark where we are */
6548 PL_multi_start = CopLINE(PL_curcop);
6549 PL_multi_open = term;
6551 /* find corresponding closing delimiter */
6552 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
6554 PL_multi_close = term;
6556 /* create a new SV to hold the contents. 87 is leak category, I'm
6557 assuming. 79 is the SV's initial length. What a random number. */
6559 sv_upgrade(sv, SVt_PVIV);
6561 (void)SvPOK_only(sv); /* validate pointer */
6563 /* move past delimiter and try to read a complete string */
6565 sv_catpvn(sv, s, 1);
6568 /* extend sv if need be */
6569 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
6570 /* set 'to' to the next character in the sv's string */
6571 to = SvPVX(sv)+SvCUR(sv);
6573 /* if open delimiter is the close delimiter read unbridle */
6574 if (PL_multi_open == PL_multi_close) {
6575 for (; s < PL_bufend; s++,to++) {
6576 /* embedded newlines increment the current line number */
6577 if (*s == '\n' && !PL_rsfp)
6578 CopLINE_inc(PL_curcop);
6579 /* handle quoted delimiters */
6580 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
6581 if (!keep_quoted && s[1] == term)
6583 /* any other quotes are simply copied straight through */
6587 /* terminate when run out of buffer (the for() condition), or
6588 have found the terminator */
6589 else if (*s == term)
6591 else if (!has_utf && (*s & 0x80) && UTF)
6597 /* if the terminator isn't the same as the start character (e.g.,
6598 matched brackets), we have to allow more in the quoting, and
6599 be prepared for nested brackets.
6602 /* read until we run out of string, or we find the terminator */
6603 for (; s < PL_bufend; s++,to++) {
6604 /* embedded newlines increment the line count */
6605 if (*s == '\n' && !PL_rsfp)
6606 CopLINE_inc(PL_curcop);
6607 /* backslashes can escape the open or closing characters */
6608 if (*s == '\\' && s+1 < PL_bufend) {
6610 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
6615 /* allow nested opens and closes */
6616 else if (*s == PL_multi_close && --brackets <= 0)
6618 else if (*s == PL_multi_open)
6620 else if (!has_utf && (*s & 0x80) && UTF)
6625 /* terminate the copied string and update the sv's end-of-string */
6627 SvCUR_set(sv, to - SvPVX(sv));
6630 * this next chunk reads more into the buffer if we're not done yet
6634 break; /* handle case where we are done yet :-) */
6636 #ifndef PERL_STRICT_CR
6637 if (to - SvPVX(sv) >= 2) {
6638 if ((to[-2] == '\r' && to[-1] == '\n') ||
6639 (to[-2] == '\n' && to[-1] == '\r'))
6643 SvCUR_set(sv, to - SvPVX(sv));
6645 else if (to[-1] == '\r')
6648 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
6652 /* if we're out of file, or a read fails, bail and reset the current
6653 line marker so we can report where the unterminated string began
6656 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6658 CopLINE_set(PL_curcop, PL_multi_start);
6661 /* we read a line, so increment our line counter */
6662 CopLINE_inc(PL_curcop);
6664 /* update debugger info */
6665 if (PERLDB_LINE && PL_curstash != PL_debstash) {
6666 SV *sv = NEWSV(88,0);
6668 sv_upgrade(sv, SVt_PVMG);
6669 sv_setsv(sv,PL_linestr);
6670 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop), sv);
6673 /* having changed the buffer, we must update PL_bufend */
6674 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6677 /* at this point, we have successfully read the delimited string */
6680 sv_catpvn(sv, s, 1);
6683 PL_multi_end = CopLINE(PL_curcop);
6686 /* if we allocated too much space, give some back */
6687 if (SvCUR(sv) + 5 < SvLEN(sv)) {
6688 SvLEN_set(sv, SvCUR(sv) + 1);
6689 Renew(SvPVX(sv), SvLEN(sv), char);
6692 /* decide whether this is the first or second quoted string we've read
6705 takes: pointer to position in buffer
6706 returns: pointer to new position in buffer
6707 side-effects: builds ops for the constant in yylval.op
6709 Read a number in any of the formats that Perl accepts:
6711 0(x[0-7A-F]+)|([0-7]+)|(b[01])
6712 [\d_]+(\.[\d_]*)?[Ee](\d+)
6714 Underbars (_) are allowed in decimal numbers. If -w is on,
6715 underbars before a decimal point must be at three digit intervals.
6717 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
6720 If it reads a number without a decimal point or an exponent, it will
6721 try converting the number to an integer and see if it can do so
6722 without loss of precision.
6726 Perl_scan_num(pTHX_ char *start)
6728 register char *s = start; /* current position in buffer */
6729 register char *d; /* destination in temp buffer */
6730 register char *e; /* end of temp buffer */
6731 NV nv; /* number read, as a double */
6732 SV *sv = Nullsv; /* place to put the converted number */
6733 bool floatit; /* boolean: int or float? */
6734 char *lastub = 0; /* position of last underbar */
6735 static char number_too_long[] = "Number too long";
6737 /* We use the first character to decide what type of number this is */
6741 Perl_croak(aTHX_ "panic: scan_num");
6743 /* if it starts with a 0, it could be an octal number, a decimal in
6744 0.13 disguise, or a hexadecimal number, or a binary number. */
6748 u holds the "number so far"
6749 shift the power of 2 of the base
6750 (hex == 4, octal == 3, binary == 1)
6751 overflowed was the number more than we can hold?
6753 Shift is used when we add a digit. It also serves as an "are
6754 we in octal/hex/binary?" indicator to disallow hex characters
6761 bool overflowed = FALSE;
6762 static NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
6763 static char* bases[5] = { "", "binary", "", "octal",
6765 static char* Bases[5] = { "", "Binary", "", "Octal",
6767 static char *maxima[5] = { "",
6768 "0b11111111111111111111111111111111",
6772 char *base, *Base, *max;
6778 } else if (s[1] == 'b') {
6782 /* check for a decimal in disguise */
6783 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
6785 /* so it must be octal */
6789 base = bases[shift];
6790 Base = Bases[shift];
6791 max = maxima[shift];
6793 /* read the rest of the number */
6795 /* x is used in the overflow test,
6796 b is the digit we're adding on. */
6801 /* if we don't mention it, we're done */
6810 /* 8 and 9 are not octal */
6813 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
6817 case '2': case '3': case '4':
6818 case '5': case '6': case '7':
6820 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
6824 b = *s++ & 15; /* ASCII digit -> value of digit */
6828 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
6829 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
6830 /* make sure they said 0x */
6835 /* Prepare to put the digit we have onto the end
6836 of the number so far. We check for overflows.
6841 x = u << shift; /* make room for the digit */
6843 if ((x >> shift) != u
6844 && !(PL_hints & HINT_NEW_BINARY)) {
6848 if (ckWARN_d(WARN_OVERFLOW))
6849 Perl_warner(aTHX_ WARN_OVERFLOW,
6850 "Integer overflow in %s number",
6853 u = x | b; /* add the digit to the end */
6856 n *= nvshift[shift];
6857 /* If an NV has not enough bits in its
6858 * mantissa to represent an UV this summing of
6859 * small low-order numbers is a waste of time
6860 * (because the NV cannot preserve the
6861 * low-order bits anyway): we could just
6862 * remember when did we overflow and in the
6863 * end just multiply n by the right
6871 /* if we get here, we had success: make a scalar value from
6878 if (ckWARN(WARN_PORTABLE) && n > 4294967295.0)
6879 Perl_warner(aTHX_ WARN_PORTABLE,
6880 "%s number > %s non-portable",
6887 if (ckWARN(WARN_PORTABLE) && u > 0xffffffff)
6888 Perl_warner(aTHX_ WARN_PORTABLE,
6889 "%s number > %s non-portable",
6894 if (PL_hints & HINT_NEW_BINARY)
6895 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
6900 handle decimal numbers.
6901 we're also sent here when we read a 0 as the first digit
6903 case '1': case '2': case '3': case '4': case '5':
6904 case '6': case '7': case '8': case '9': case '.':
6907 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
6910 /* read next group of digits and _ and copy into d */
6911 while (isDIGIT(*s) || *s == '_') {
6912 /* skip underscores, checking for misplaced ones
6916 dTHR; /* only for ckWARN */
6917 if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
6918 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
6922 /* check for end of fixed-length buffer */
6924 Perl_croak(aTHX_ number_too_long);
6925 /* if we're ok, copy the character */
6930 /* final misplaced underbar check */
6931 if (lastub && s - lastub != 3) {
6933 if (ckWARN(WARN_SYNTAX))
6934 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
6937 /* read a decimal portion if there is one. avoid
6938 3..5 being interpreted as the number 3. followed
6941 if (*s == '.' && s[1] != '.') {
6945 /* copy, ignoring underbars, until we run out of
6946 digits. Note: no misplaced underbar checks!
6948 for (; isDIGIT(*s) || *s == '_'; s++) {
6949 /* fixed length buffer check */
6951 Perl_croak(aTHX_ number_too_long);
6955 if (*s == '.' && isDIGIT(s[1])) {
6956 /* oops, it's really a v-string, but without the "v" */
6962 /* read exponent part, if present */
6963 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
6967 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
6968 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
6970 /* allow positive or negative exponent */
6971 if (*s == '+' || *s == '-')
6974 /* read digits of exponent (no underbars :-) */
6975 while (isDIGIT(*s)) {
6977 Perl_croak(aTHX_ number_too_long);
6982 /* terminate the string */
6985 /* make an sv from the string */
6988 #if defined(Strtol) && defined(Strtoul)
6991 strtol/strtoll sets errno to ERANGE if the number is too big
6992 for an integer. We try to do an integer conversion first
6993 if no characters indicating "float" have been found.
7000 if (*PL_tokenbuf == '-')
7001 iv = Strtol(PL_tokenbuf, (char**)NULL, 10);
7003 uv = Strtoul(PL_tokenbuf, (char**)NULL, 10);
7005 floatit = TRUE; /* Probably just too large. */
7006 else if (*PL_tokenbuf == '-')
7008 else if (uv <= IV_MAX)
7009 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
7014 nv = Atof(PL_tokenbuf);
7019 No working strtou?ll?.
7021 Unfortunately atol() doesn't do range checks (returning
7022 LONG_MIN/LONG_MAX, and setting errno to ERANGE on overflows)
7023 everywhere [1], so we cannot use use atol() (or atoll()).
7024 If we could, they would be used, as Atol(), very much like
7025 Strtol() and Strtoul() are used above.
7027 [1] XXX Configure test needed to check for atol()
7028 (and atoll()) overflow behaviour XXX
7032 We need to do this the hard way. */
7034 nv = Atof(PL_tokenbuf);
7036 /* See if we can make do with an integer value without loss of
7037 precision. We use U_V to cast to a UV, because some
7038 compilers have issues. Then we try casting it back and see
7039 if it was the same [1]. We only do this if we know we
7040 specifically read an integer. If floatit is true, then we
7041 don't need to do the conversion at all.
7043 [1] Note that this is lossy if our NVs cannot preserve our
7044 UVs. There are metaconfig defines NV_PRESERVES_UV (a boolean)
7045 and NV_PRESERVES_UV_BITS (a number), but in general we really
7046 do hope all such potentially lossy platforms have strtou?ll?
7047 to do a lossless IV/UV conversion.
7049 Maybe could do some tricks with DBL_DIG, LDBL_DIG and
7050 DBL_MANT_DIG and LDBL_MANT_DIG (these are already available
7051 as NV_DIG and NV_MANT_DIG)?
7057 if (!floatit && (NV)uv == nv) {
7059 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
7067 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
7068 (PL_hints & HINT_NEW_INTEGER) )
7069 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
7070 (floatit ? "float" : "integer"),
7074 /* if it starts with a v, it could be a v-string */
7080 while (isDIGIT(*pos) || *pos == '_')
7082 if (!isALPHA(*pos)) {
7084 U8 tmpbuf[UTF8_MAXLEN];
7087 s++; /* get past 'v' */
7090 sv_setpvn(sv, "", 0);
7093 if (*s == '0' && isDIGIT(s[1]))
7094 yyerror("Octal number in vector unsupported");
7097 /* this is atoi() that tolerates underscores */
7100 while (--end >= s) {
7105 rev += (*end - '0') * mult;
7107 if (orev > rev && ckWARN_d(WARN_OVERFLOW))
7108 Perl_warner(aTHX_ WARN_OVERFLOW,
7109 "Integer overflow in decimal number");
7112 tmpend = uv_to_utf8(tmpbuf, rev);
7113 utf8 = utf8 || rev > 127;
7114 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
7115 if (*pos == '.' && isDIGIT(pos[1]))
7121 while (isDIGIT(*pos) || *pos == '_')
7129 sv_utf8_downgrade(sv, TRUE);
7136 /* make the op for the constant and return */
7139 yylval.opval = newSVOP(OP_CONST, 0, sv);
7141 yylval.opval = Nullop;
7147 S_scan_formline(pTHX_ register char *s)
7152 SV *stuff = newSVpvn("",0);
7153 bool needargs = FALSE;
7156 if (*s == '.' || *s == '}') {
7158 #ifdef PERL_STRICT_CR
7159 for (t = s+1;SPACE_OR_TAB(*t); t++) ;
7161 for (t = s+1;SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
7163 if (*t == '\n' || t == PL_bufend)
7166 if (PL_in_eval && !PL_rsfp) {
7167 eol = strchr(s,'\n');
7172 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7174 for (t = s; t < eol; t++) {
7175 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
7177 goto enough; /* ~~ must be first line in formline */
7179 if (*t == '@' || *t == '^')
7182 sv_catpvn(stuff, s, eol-s);
7183 #ifndef PERL_STRICT_CR
7184 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
7185 char *end = SvPVX(stuff) + SvCUR(stuff);
7194 s = filter_gets(PL_linestr, PL_rsfp, 0);
7195 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
7196 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
7199 yyerror("Format not terminated");
7209 PL_lex_state = LEX_NORMAL;
7210 PL_nextval[PL_nexttoke].ival = 0;
7214 PL_lex_state = LEX_FORMLINE;
7215 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
7217 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
7221 SvREFCNT_dec(stuff);
7222 PL_lex_formbrack = 0;
7233 PL_cshlen = strlen(PL_cshname);
7238 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
7241 I32 oldsavestack_ix = PL_savestack_ix;
7242 CV* outsidecv = PL_compcv;
7246 assert(SvTYPE(PL_compcv) == SVt_PVCV);
7248 SAVEI32(PL_subline);
7249 save_item(PL_subname);
7252 SAVESPTR(PL_comppad_name);
7253 SAVESPTR(PL_compcv);
7254 SAVEI32(PL_comppad_name_fill);
7255 SAVEI32(PL_min_intro_pending);
7256 SAVEI32(PL_max_intro_pending);
7257 SAVEI32(PL_pad_reset_pending);
7259 PL_compcv = (CV*)NEWSV(1104,0);
7260 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
7261 CvFLAGS(PL_compcv) |= flags;
7263 PL_comppad = newAV();
7264 av_push(PL_comppad, Nullsv);
7265 PL_curpad = AvARRAY(PL_comppad);
7266 PL_comppad_name = newAV();
7267 PL_comppad_name_fill = 0;
7268 PL_min_intro_pending = 0;
7270 PL_subline = CopLINE(PL_curcop);
7272 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
7273 PL_curpad[0] = (SV*)newAV();
7274 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
7275 #endif /* USE_THREADS */
7277 comppadlist = newAV();
7278 AvREAL_off(comppadlist);
7279 av_store(comppadlist, 0, (SV*)PL_comppad_name);
7280 av_store(comppadlist, 1, (SV*)PL_comppad);
7282 CvPADLIST(PL_compcv) = comppadlist;
7283 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
7285 CvOWNER(PL_compcv) = 0;
7286 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
7287 MUTEX_INIT(CvMUTEXP(PL_compcv));
7288 #endif /* USE_THREADS */
7290 return oldsavestack_ix;
7294 Perl_yywarn(pTHX_ char *s)
7297 PL_in_eval |= EVAL_WARNONLY;
7299 PL_in_eval &= ~EVAL_WARNONLY;
7304 Perl_yyerror(pTHX_ char *s)
7308 char *context = NULL;
7312 if (!yychar || (yychar == ';' && !PL_rsfp))
7314 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
7315 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
7316 while (isSPACE(*PL_oldoldbufptr))
7318 context = PL_oldoldbufptr;
7319 contlen = PL_bufptr - PL_oldoldbufptr;
7321 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
7322 PL_oldbufptr != PL_bufptr) {
7323 while (isSPACE(*PL_oldbufptr))
7325 context = PL_oldbufptr;
7326 contlen = PL_bufptr - PL_oldbufptr;
7328 else if (yychar > 255)
7329 where = "next token ???";
7330 #ifdef USE_PURE_BISON
7331 /* GNU Bison sets the value -2 */
7332 else if (yychar == -2) {
7334 else if ((yychar & 127) == 127) {
7336 if (PL_lex_state == LEX_NORMAL ||
7337 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
7338 where = "at end of line";
7339 else if (PL_lex_inpat)
7340 where = "within pattern";
7342 where = "within string";
7345 SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
7347 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
7348 else if (isPRINT_LC(yychar))
7349 Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
7351 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
7352 where = SvPVX(where_sv);
7354 msg = sv_2mortal(newSVpv(s, 0));
7355 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
7356 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
7358 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
7360 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
7361 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
7362 Perl_sv_catpvf(aTHX_ msg,
7363 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
7364 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
7367 if (PL_in_eval & EVAL_WARNONLY)
7368 Perl_warn(aTHX_ "%"SVf, msg);
7371 if (PL_error_count >= 10) {
7372 if (PL_in_eval && SvCUR(ERRSV))
7373 Perl_croak(aTHX_ "%_%s has too many errors.\n",
7374 ERRSV, CopFILE(PL_curcop));
7376 Perl_croak(aTHX_ "%s has too many errors.\n",
7377 CopFILE(PL_curcop));
7380 PL_in_my_stash = Nullhv;
7391 * Restore a source filter.
7395 restore_rsfp(pTHXo_ void *f)
7397 PerlIO *fp = (PerlIO*)f;
7399 if (PL_rsfp == PerlIO_stdin())
7400 PerlIO_clearerr(PL_rsfp);
7401 else if (PL_rsfp && (PL_rsfp != fp))
7402 PerlIO_close(PL_rsfp);