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)
329 #ifndef PERL_NO_UTF16_FILTER
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 */
507 Safefree(CopFILE(PL_curcop));
509 SvREFCNT_dec(CopFILEGV(PL_curcop));
511 CopFILE_set(PL_curcop, s);
514 CopLINE_set(PL_curcop, atoi(n)-1);
519 * Called to gobble the appropriate amount and type of whitespace.
520 * Skips comments as well.
524 S_skipspace(pTHX_ register char *s)
527 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
528 while (s < PL_bufend && SPACE_OR_TAB(*s))
534 SSize_t oldprevlen, oldoldprevlen;
535 SSize_t oldloplen, oldunilen;
536 while (s < PL_bufend && isSPACE(*s)) {
537 if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
542 if (s < PL_bufend && *s == '#') {
543 while (s < PL_bufend && *s != '\n')
547 if (PL_in_eval && !PL_rsfp) {
554 /* only continue to recharge the buffer if we're at the end
555 * of the buffer, we're not reading from a source filter, and
556 * we're in normal lexing mode
558 if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat ||
559 PL_lex_state == LEX_FORMLINE)
562 /* try to recharge the buffer */
563 if ((s = filter_gets(PL_linestr, PL_rsfp,
564 (prevlen = SvCUR(PL_linestr)))) == Nullch)
566 /* end of file. Add on the -p or -n magic */
567 if (PL_minus_n || PL_minus_p) {
568 sv_setpv(PL_linestr,PL_minus_p ?
569 ";}continue{print or die qq(-p destination: $!\\n)" :
571 sv_catpv(PL_linestr,";}");
572 PL_minus_n = PL_minus_p = 0;
575 sv_setpv(PL_linestr,";");
577 /* reset variables for next time we lex */
578 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
580 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
582 /* Close the filehandle. Could be from -P preprocessor,
583 * STDIN, or a regular file. If we were reading code from
584 * STDIN (because the commandline held no -e or filename)
585 * then we don't close it, we reset it so the code can
586 * read from STDIN too.
589 if (PL_preprocess && !PL_in_eval)
590 (void)PerlProc_pclose(PL_rsfp);
591 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
592 PerlIO_clearerr(PL_rsfp);
594 (void)PerlIO_close(PL_rsfp);
599 /* not at end of file, so we only read another line */
600 /* make corresponding updates to old pointers, for yyerror() */
601 oldprevlen = PL_oldbufptr - PL_bufend;
602 oldoldprevlen = PL_oldoldbufptr - PL_bufend;
604 oldunilen = PL_last_uni - PL_bufend;
606 oldloplen = PL_last_lop - PL_bufend;
607 PL_linestart = PL_bufptr = s + prevlen;
608 PL_bufend = s + SvCUR(PL_linestr);
610 PL_oldbufptr = s + oldprevlen;
611 PL_oldoldbufptr = s + oldoldprevlen;
613 PL_last_uni = s + oldunilen;
615 PL_last_lop = s + oldloplen;
618 /* debugger active and we're not compiling the debugger code,
619 * so store the line into the debugger's array of lines
621 if (PERLDB_LINE && PL_curstash != PL_debstash) {
622 SV *sv = NEWSV(85,0);
624 sv_upgrade(sv, SVt_PVMG);
625 sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
626 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
633 * Check the unary operators to ensure there's no ambiguity in how they're
634 * used. An ambiguous piece of code would be:
636 * This doesn't mean rand() + 5. Because rand() is a unary operator,
637 * the +5 is its argument.
647 if (PL_oldoldbufptr != PL_last_uni)
649 while (isSPACE(*PL_last_uni))
651 for (s = PL_last_uni; isALNUM_lazy_if(s,UTF) || *s == '-'; s++) ;
652 if ((t = strchr(s, '(')) && t < PL_bufptr)
654 if (ckWARN_d(WARN_AMBIGUOUS)){
657 Perl_warner(aTHX_ WARN_AMBIGUOUS,
658 "Warning: Use of \"%s\" without parens is ambiguous",
664 /* workaround to replace the UNI() macro with a function. Only the
665 * hints/uts.sh file mentions this. Other comments elsewhere in the
666 * source indicate Microport Unix might need it too.
672 #define UNI(f) return uni(f,s)
675 S_uni(pTHX_ I32 f, char *s)
680 PL_last_uni = PL_oldbufptr;
691 #endif /* CRIPPLED_CC */
694 * LOP : macro to build a list operator. Its behaviour has been replaced
695 * with a subroutine, S_lop() for which LOP is just another name.
698 #define LOP(f,x) return lop(f,x,s)
702 * Build a list operator (or something that might be one). The rules:
703 * - if we have a next token, then it's a list operator [why?]
704 * - if the next thing is an opening paren, then it's a function
705 * - else it's a list operator
709 S_lop(pTHX_ I32 f, int x, char *s)
716 PL_last_lop = PL_oldbufptr;
731 * When the lexer realizes it knows the next token (for instance,
732 * it is reordering tokens for the parser) then it can call S_force_next
733 * to know what token to return the next time the lexer is called. Caller
734 * will need to set PL_nextval[], and possibly PL_expect to ensure the lexer
735 * handles the token correctly.
739 S_force_next(pTHX_ I32 type)
741 PL_nexttype[PL_nexttoke] = type;
743 if (PL_lex_state != LEX_KNOWNEXT) {
744 PL_lex_defer = PL_lex_state;
745 PL_lex_expect = PL_expect;
746 PL_lex_state = LEX_KNOWNEXT;
752 * When the lexer knows the next thing is a word (for instance, it has
753 * just seen -> and it knows that the next char is a word char, then
754 * it calls S_force_word to stick the next word into the PL_next lookahead.
757 * char *start : buffer position (must be within PL_linestr)
758 * int token : PL_next will be this type of bare word (e.g., METHOD,WORD)
759 * int check_keyword : if true, Perl checks to make sure the word isn't
760 * a keyword (do this if the word is a label, e.g. goto FOO)
761 * int allow_pack : if true, : characters will also be allowed (require,
763 * int allow_initial_tick : used by the "sub" lexer only.
767 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
772 start = skipspace(start);
774 if (isIDFIRST_lazy_if(s,UTF) ||
775 (allow_pack && *s == ':') ||
776 (allow_initial_tick && *s == '\'') )
778 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
779 if (check_keyword && keyword(PL_tokenbuf, len))
781 if (token == METHOD) {
786 PL_expect = XOPERATOR;
789 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(PL_tokenbuf,0));
790 PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
798 * Called when the lexer wants $foo *foo &foo etc, but the program
799 * text only contains the "foo" portion. The first argument is a pointer
800 * to the "foo", and the second argument is the type symbol to prefix.
801 * Forces the next token to be a "WORD".
802 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
806 S_force_ident(pTHX_ register char *s, int kind)
809 OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
810 PL_nextval[PL_nexttoke].opval = o;
813 dTHR; /* just for in_eval */
814 o->op_private = OPpCONST_ENTERED;
815 /* XXX see note in pp_entereval() for why we forgo typo
816 warnings if the symbol must be introduced in an eval.
818 gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
819 kind == '$' ? SVt_PV :
820 kind == '@' ? SVt_PVAV :
821 kind == '%' ? SVt_PVHV :
829 Perl_str_to_version(pTHX_ SV *sv)
834 char *start = SvPVx(sv,len);
835 bool utf = SvUTF8(sv) ? TRUE : FALSE;
836 char *end = start + len;
837 while (start < end) {
841 n = utf8_to_uv((U8*)start, &skip);
846 retval += ((NV)n)/nshift;
855 * Forces the next token to be a version number.
859 S_force_version(pTHX_ char *s)
861 OP *version = Nullop;
870 for (; isDIGIT(*d) || *d == '_' || *d == '.'; d++);
871 if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
874 version = yylval.opval;
875 ver = cSVOPx(version)->op_sv;
876 if (SvPOK(ver) && !SvNIOK(ver)) {
877 (void)SvUPGRADE(ver, SVt_PVNV);
878 SvNVX(ver) = str_to_version(ver);
879 SvNOK_on(ver); /* hint that it is a version */
884 /* NOTE: The parser sees the package name and the VERSION swapped */
885 PL_nextval[PL_nexttoke].opval = version;
893 * Tokenize a quoted string passed in as an SV. It finds the next
894 * chunk, up to end of string or a backslash. It may make a new
895 * SV containing that chunk (if HINT_NEW_STRING is on). It also
900 S_tokeq(pTHX_ SV *sv)
911 s = SvPV_force(sv, len);
912 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
915 while (s < send && *s != '\\')
920 if ( PL_hints & HINT_NEW_STRING )
921 pv = sv_2mortal(newSVpvn(SvPVX(pv), len));
924 if (s + 1 < send && (s[1] == '\\'))
925 s++; /* all that, just for this */
930 SvCUR_set(sv, d - SvPVX(sv));
932 if ( PL_hints & HINT_NEW_STRING )
933 return new_constant(NULL, 0, "q", sv, pv, "q");
938 * Now come three functions related to double-quote context,
939 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
940 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
941 * interact with PL_lex_state, and create fake ( ... ) argument lists
942 * to handle functions and concatenation.
943 * They assume that whoever calls them will be setting up a fake
944 * join call, because each subthing puts a ',' after it. This lets
947 * join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
949 * (I'm not sure whether the spurious commas at the end of lcfirst's
950 * arguments and join's arguments are created or not).
955 * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST).
957 * Pattern matching will set PL_lex_op to the pattern-matching op to
958 * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise).
960 * OP_CONST and OP_READLINE are easy--just make the new op and return.
962 * Everything else becomes a FUNC.
964 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
965 * had an OP_CONST or OP_READLINE). This just sets us up for a
966 * call to S_sublex_push().
972 register I32 op_type = yylval.ival;
974 if (op_type == OP_NULL) {
975 yylval.opval = PL_lex_op;
979 if (op_type == OP_CONST || op_type == OP_READLINE) {
980 SV *sv = tokeq(PL_lex_stuff);
982 if (SvTYPE(sv) == SVt_PVIV) {
983 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
989 nsv = newSVpvn(p, len);
995 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
996 PL_lex_stuff = Nullsv;
1000 PL_sublex_info.super_state = PL_lex_state;
1001 PL_sublex_info.sub_inwhat = op_type;
1002 PL_sublex_info.sub_op = PL_lex_op;
1003 PL_lex_state = LEX_INTERPPUSH;
1007 yylval.opval = PL_lex_op;
1017 * Create a new scope to save the lexing state. The scope will be
1018 * ended in S_sublex_done. Returns a '(', starting the function arguments
1019 * to the uc, lc, etc. found before.
1020 * Sets PL_lex_state to LEX_INTERPCONCAT.
1029 PL_lex_state = PL_sublex_info.super_state;
1030 SAVEI32(PL_lex_dojoin);
1031 SAVEI32(PL_lex_brackets);
1032 SAVEI32(PL_lex_casemods);
1033 SAVEI32(PL_lex_starts);
1034 SAVEI32(PL_lex_state);
1035 SAVEVPTR(PL_lex_inpat);
1036 SAVEI32(PL_lex_inwhat);
1037 SAVECOPLINE(PL_curcop);
1038 SAVEPPTR(PL_bufptr);
1039 SAVEPPTR(PL_oldbufptr);
1040 SAVEPPTR(PL_oldoldbufptr);
1041 SAVEPPTR(PL_linestart);
1042 SAVESPTR(PL_linestr);
1043 SAVEPPTR(PL_lex_brackstack);
1044 SAVEPPTR(PL_lex_casestack);
1046 PL_linestr = PL_lex_stuff;
1047 PL_lex_stuff = Nullsv;
1049 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
1050 = SvPVX(PL_linestr);
1051 PL_bufend += SvCUR(PL_linestr);
1052 SAVEFREESV(PL_linestr);
1054 PL_lex_dojoin = FALSE;
1055 PL_lex_brackets = 0;
1056 New(899, PL_lex_brackstack, 120, char);
1057 New(899, PL_lex_casestack, 12, char);
1058 SAVEFREEPV(PL_lex_brackstack);
1059 SAVEFREEPV(PL_lex_casestack);
1060 PL_lex_casemods = 0;
1061 *PL_lex_casestack = '\0';
1063 PL_lex_state = LEX_INTERPCONCAT;
1064 CopLINE_set(PL_curcop, PL_multi_start);
1066 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1067 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1068 PL_lex_inpat = PL_sublex_info.sub_op;
1070 PL_lex_inpat = Nullop;
1077 * Restores lexer state after a S_sublex_push.
1083 if (!PL_lex_starts++) {
1084 PL_expect = XOPERATOR;
1085 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpvn("",0));
1089 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
1090 PL_lex_state = LEX_INTERPCASEMOD;
1094 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1095 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1096 PL_linestr = PL_lex_repl;
1098 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1099 PL_bufend += SvCUR(PL_linestr);
1100 SAVEFREESV(PL_linestr);
1101 PL_lex_dojoin = FALSE;
1102 PL_lex_brackets = 0;
1103 PL_lex_casemods = 0;
1104 *PL_lex_casestack = '\0';
1106 if (SvEVALED(PL_lex_repl)) {
1107 PL_lex_state = LEX_INTERPNORMAL;
1109 /* we don't clear PL_lex_repl here, so that we can check later
1110 whether this is an evalled subst; that means we rely on the
1111 logic to ensure sublex_done() is called again only via the
1112 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1115 PL_lex_state = LEX_INTERPCONCAT;
1116 PL_lex_repl = Nullsv;
1122 PL_bufend = SvPVX(PL_linestr);
1123 PL_bufend += SvCUR(PL_linestr);
1124 PL_expect = XOPERATOR;
1125 PL_sublex_info.sub_inwhat = 0;
1133 Extracts a pattern, double-quoted string, or transliteration. This
1136 It looks at lex_inwhat and PL_lex_inpat to find out whether it's
1137 processing a pattern (PL_lex_inpat is true), a transliteration
1138 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
1140 Returns a pointer to the character scanned up to. Iff this is
1141 advanced from the start pointer supplied (ie if anything was
1142 successfully parsed), will leave an OP for the substring scanned
1143 in yylval. Caller must intuit reason for not parsing further
1144 by looking at the next characters herself.
1148 double-quoted style: \r and \n
1149 regexp special ones: \D \s
1151 backrefs: \1 (deprecated in substitution replacements)
1152 case and quoting: \U \Q \E
1153 stops on @ and $, but not for $ as tail anchor
1155 In transliterations:
1156 characters are VERY literal, except for - not at the start or end
1157 of the string, which indicates a range. scan_const expands the
1158 range to the full set of intermediate characters.
1160 In double-quoted strings:
1162 double-quoted style: \r and \n
1164 backrefs: \1 (deprecated)
1165 case and quoting: \U \Q \E
1168 scan_const does *not* construct ops to handle interpolated strings.
1169 It stops processing as soon as it finds an embedded $ or @ variable
1170 and leaves it to the caller to work out what's going on.
1172 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
1174 $ in pattern could be $foo or could be tail anchor. Assumption:
1175 it's a tail anchor if $ is the last thing in the string, or if it's
1176 followed by one of ")| \n\t"
1178 \1 (backreferences) are turned into $1
1180 The structure of the code is
1181 while (there's a character to process) {
1182 handle transliteration ranges
1183 skip regexp comments
1184 skip # initiated comments in //x patterns
1185 check for embedded @foo
1186 check for embedded scalars
1188 leave intact backslashes from leave (below)
1189 deprecate \1 in strings and sub replacements
1190 handle string-changing backslashes \l \U \Q \E, etc.
1191 switch (what was escaped) {
1192 handle - in a transliteration (becomes a literal -)
1193 handle \132 octal characters
1194 handle 0x15 hex characters
1195 handle \cV (control V)
1196 handle printf backslashes (\f, \r, \n, etc)
1198 } (end if backslash)
1199 } (end while character to read)
1204 S_scan_const(pTHX_ char *start)
1206 register char *send = PL_bufend; /* end of the constant */
1207 SV *sv = NEWSV(93, send - start); /* sv for the constant */
1208 register char *s = start; /* start of the constant */
1209 register char *d = SvPVX(sv); /* destination for copies */
1210 bool dorange = FALSE; /* are we in a translit range? */
1211 bool didrange = FALSE; /* did we just finish a range? */
1212 bool has_utf = FALSE; /* embedded \x{} */
1216 I32 utf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op)
1217 ? (PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
1219 I32 thisutf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op)
1220 ? (PL_sublex_info.sub_op->op_private & (PL_lex_repl ?
1221 OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF))
1223 const char *leaveit = /* set of acceptably-backslashed characters */
1225 ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
1228 while (s < send || dorange) {
1229 /* get transliterations out of the way (they're most literal) */
1230 if (PL_lex_inwhat == OP_TRANS) {
1231 /* expand a range A-Z to the full set of characters. AIE! */
1233 I32 i; /* current expanded character */
1234 I32 min; /* first character in range */
1235 I32 max; /* last character in range */
1237 i = d - SvPVX(sv); /* remember current offset */
1238 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
1239 d = SvPVX(sv) + i; /* refresh d after realloc */
1240 d -= 2; /* eat the first char and the - */
1242 min = (U8)*d; /* first char in range */
1243 max = (U8)d[1]; /* last char in range */
1247 "Invalid [] range \"%c-%c\" in transliteration operator",
1252 if ((isLOWER(min) && isLOWER(max)) ||
1253 (isUPPER(min) && isUPPER(max))) {
1255 for (i = min; i <= max; i++)
1259 for (i = min; i <= max; i++)
1266 for (i = min; i <= max; i++)
1269 /* mark the range as done, and continue */
1275 /* range begins (ignore - as first or last char) */
1276 else if (*s == '-' && s+1 < send && s != start) {
1278 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
1281 *d++ = (char)0xff; /* use illegal utf8 byte--see pmtrans */
1293 /* if we get here, we're not doing a transliteration */
1295 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
1296 except for the last char, which will be done separately. */
1297 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
1299 while (s < send && *s != ')')
1302 else if (s[2] == '{' /* This should match regcomp.c */
1303 || ((s[2] == 'p' || s[2] == '?') && s[3] == '{'))
1306 char *regparse = s + (s[2] == '{' ? 3 : 4);
1309 while (count && (c = *regparse)) {
1310 if (c == '\\' && regparse[1])
1318 if (*regparse != ')') {
1319 regparse--; /* Leave one char for continuation. */
1320 yyerror("Sequence (?{...}) not terminated or not {}-balanced");
1322 while (s < regparse)
1327 /* likewise skip #-initiated comments in //x patterns */
1328 else if (*s == '#' && PL_lex_inpat &&
1329 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
1330 while (s+1 < send && *s != '\n')
1334 /* check for embedded arrays (@foo, @:foo, @'foo, @{foo}, @$foo) */
1335 else if (*s == '@' && s[1]
1336 && (isALNUM_lazy_if(s+1,UTF) || strchr(":'{$", s[1])))
1339 /* check for embedded scalars. only stop if we're sure it's a
1342 else if (*s == '$') {
1343 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
1345 if (s + 1 < send && !strchr("()| \n\t", s[1]))
1346 break; /* in regexp, $ might be tail anchor */
1349 /* (now in tr/// code again) */
1351 if (*s & 0x80 && thisutf) {
1352 (void)utf8_to_uv((U8*)s, &len);
1354 /* illegal UTF8, make it valid */
1355 char *old_pvx = SvPVX(sv);
1356 /* need space for one extra char (NOTE: SvCUR() not set here) */
1357 d = SvGROW(sv, SvLEN(sv) + 1) + (d - old_pvx);
1358 d = (char*)uv_to_utf8((U8*)d, (U8)*s++);
1369 if (*s == '\\' && s+1 < send) {
1372 /* some backslashes we leave behind */
1373 if (*leaveit && *s && strchr(leaveit, *s)) {
1379 /* deprecate \1 in strings and substitution replacements */
1380 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1381 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1383 dTHR; /* only for ckWARN */
1384 if (ckWARN(WARN_SYNTAX))
1385 Perl_warner(aTHX_ WARN_SYNTAX, "\\%c better written as $%c", *s, *s);
1390 /* string-change backslash escapes */
1391 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1396 /* if we get here, it's either a quoted -, or a digit */
1399 /* quoted - in transliterations */
1401 if (PL_lex_inwhat == OP_TRANS) {
1409 if (ckWARN(WARN_MISC) && isALNUM(*s))
1410 Perl_warner(aTHX_ WARN_MISC,
1411 "Unrecognized escape \\%c passed through",
1413 /* default action is to copy the quoted character */
1418 /* \132 indicates an octal constant */
1419 case '0': case '1': case '2': case '3':
1420 case '4': case '5': case '6': case '7':
1421 len = 0; /* disallow underscores */
1422 uv = (UV)scan_oct(s, 3, &len);
1424 goto NUM_ESCAPE_INSERT;
1426 /* \x24 indicates a hex constant */
1430 char* e = strchr(s, '}');
1432 yyerror("Missing right brace on \\x{}");
1435 len = 1; /* allow underscores */
1436 uv = (UV)scan_hex(s + 1, e - s - 1, &len);
1440 len = 0; /* disallow underscores */
1441 uv = (UV)scan_hex(s, 2, &len);
1446 /* Insert oct or hex escaped character.
1447 * There will always enough room in sv since such escapes will
1448 * be longer than any utf8 sequence they can end up as
1451 if (!thisutf && !has_utf && uv > 255) {
1452 /* might need to recode whatever we have accumulated so far
1453 * if it contains any hibit chars
1457 for (c = SvPVX(sv); c < d; c++) {
1462 char *old_pvx = SvPVX(sv);
1464 d = SvGROW(sv, SvCUR(sv) + hicount + 1) + (d - old_pvx);
1473 uv_to_utf8((U8*)dst, (U8)*src--);
1483 if (thisutf || uv > 255) {
1484 d = (char*)uv_to_utf8((U8*)d, uv);
1496 /* \N{latin small letter a} is a named character */
1500 char* e = strchr(s, '}');
1506 yyerror("Missing right brace on \\N{}");
1510 res = newSVpvn(s + 1, e - s - 1);
1511 res = new_constant( Nullch, 0, "charnames",
1512 res, Nullsv, "\\N{...}" );
1513 str = SvPV(res,len);
1514 if (!has_utf && SvUTF8(res)) {
1515 char *ostart = SvPVX(sv);
1516 SvCUR_set(sv, d - ostart);
1518 sv_utf8_upgrade(sv);
1519 d = SvPVX(sv) + SvCUR(sv);
1522 if (len > e - s + 4) {
1523 char *odest = SvPVX(sv);
1525 SvGROW(sv, (SvCUR(sv) + len - (e - s + 4)));
1526 d = SvPVX(sv) + (d - odest);
1528 Copy(str, d, len, char);
1535 yyerror("Missing braces on \\N{}");
1538 /* \c is a control character */
1553 /* printf-style backslashes, formfeeds, newlines, etc */
1571 *d++ = '\047'; /* CP 1047 */
1574 *d++ = '\057'; /* CP 1047 */
1588 } /* end if (backslash) */
1591 } /* while loop to process each character */
1593 /* terminate the string and set up the sv */
1595 SvCUR_set(sv, d - SvPVX(sv));
1600 /* shrink the sv if we allocated more than we used */
1601 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1602 SvLEN_set(sv, SvCUR(sv) + 1);
1603 Renew(SvPVX(sv), SvLEN(sv), char);
1606 /* return the substring (via yylval) only if we parsed anything */
1607 if (s > PL_bufptr) {
1608 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1609 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1611 ( PL_lex_inwhat == OP_TRANS
1613 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1616 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1623 * Returns TRUE if there's more to the expression (e.g., a subscript),
1626 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
1628 * ->[ and ->{ return TRUE
1629 * { and [ outside a pattern are always subscripts, so return TRUE
1630 * if we're outside a pattern and it's not { or [, then return FALSE
1631 * if we're in a pattern and the first char is a {
1632 * {4,5} (any digits around the comma) returns FALSE
1633 * if we're in a pattern and the first char is a [
1635 * [SOMETHING] has a funky algorithm to decide whether it's a
1636 * character class or not. It has to deal with things like
1637 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
1638 * anything else returns TRUE
1641 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1644 S_intuit_more(pTHX_ register char *s)
1646 if (PL_lex_brackets)
1648 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1650 if (*s != '{' && *s != '[')
1655 /* In a pattern, so maybe we have {n,m}. */
1672 /* On the other hand, maybe we have a character class */
1675 if (*s == ']' || *s == '^')
1678 /* this is terrifying, and it works */
1679 int weight = 2; /* let's weigh the evidence */
1681 unsigned char un_char = 255, last_un_char;
1682 char *send = strchr(s,']');
1683 char tmpbuf[sizeof PL_tokenbuf * 4];
1685 if (!send) /* has to be an expression */
1688 Zero(seen,256,char);
1691 else if (isDIGIT(*s)) {
1693 if (isDIGIT(s[1]) && s[2] == ']')
1699 for (; s < send; s++) {
1700 last_un_char = un_char;
1701 un_char = (unsigned char)*s;
1706 weight -= seen[un_char] * 10;
1707 if (isALNUM_lazy_if(s+1,UTF)) {
1708 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1709 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1714 else if (*s == '$' && s[1] &&
1715 strchr("[#!%*<>()-=",s[1])) {
1716 if (/*{*/ strchr("])} =",s[2]))
1725 if (strchr("wds]",s[1]))
1727 else if (seen['\''] || seen['"'])
1729 else if (strchr("rnftbxcav",s[1]))
1731 else if (isDIGIT(s[1])) {
1733 while (s[1] && isDIGIT(s[1]))
1743 if (strchr("aA01! ",last_un_char))
1745 if (strchr("zZ79~",s[1]))
1747 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1748 weight -= 5; /* cope with negative subscript */
1751 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1752 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1757 if (keyword(tmpbuf, d - tmpbuf))
1760 if (un_char == last_un_char + 1)
1762 weight -= seen[un_char];
1767 if (weight >= 0) /* probably a character class */
1777 * Does all the checking to disambiguate
1779 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
1780 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
1782 * First argument is the stuff after the first token, e.g. "bar".
1784 * Not a method if bar is a filehandle.
1785 * Not a method if foo is a subroutine prototyped to take a filehandle.
1786 * Not a method if it's really "Foo $bar"
1787 * Method if it's "foo $bar"
1788 * Not a method if it's really "print foo $bar"
1789 * Method if it's really "foo package::" (interpreted as package->foo)
1790 * Not a method if bar is known to be a subroutne ("sub bar; foo bar")
1791 * Not a method if bar is a filehandle or package, but is quoted with
1796 S_intuit_method(pTHX_ char *start, GV *gv)
1798 char *s = start + (*start == '$');
1799 char tmpbuf[sizeof PL_tokenbuf];
1807 if ((cv = GvCVu(gv))) {
1808 char *proto = SvPVX(cv);
1818 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1819 /* start is the beginning of the possible filehandle/object,
1820 * and s is the end of it
1821 * tmpbuf is a copy of it
1824 if (*start == '$') {
1825 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1830 return *s == '(' ? FUNCMETH : METHOD;
1832 if (!keyword(tmpbuf, len)) {
1833 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1838 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1839 if (indirgv && GvCVu(indirgv))
1841 /* filehandle or package name makes it a method */
1842 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1844 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1845 return 0; /* no assumptions -- "=>" quotes bearword */
1847 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1848 newSVpvn(tmpbuf,len));
1849 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1853 return *s == '(' ? FUNCMETH : METHOD;
1861 * Return a string of Perl code to load the debugger. If PERL5DB
1862 * is set, it will return the contents of that, otherwise a
1863 * compile-time require of perl5db.pl.
1870 char *pdb = PerlEnv_getenv("PERL5DB");
1874 SETERRNO(0,SS$_NORMAL);
1875 return "BEGIN { require 'perl5db.pl' }";
1881 /* Encoded script support. filter_add() effectively inserts a
1882 * 'pre-processing' function into the current source input stream.
1883 * Note that the filter function only applies to the current source file
1884 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1886 * The datasv parameter (which may be NULL) can be used to pass
1887 * private data to this instance of the filter. The filter function
1888 * can recover the SV using the FILTER_DATA macro and use it to
1889 * store private buffers and state information.
1891 * The supplied datasv parameter is upgraded to a PVIO type
1892 * and the IoDIRP/IoANY field is used to store the function pointer,
1893 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
1894 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1895 * private use must be set using malloc'd pointers.
1899 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
1904 if (!PL_rsfp_filters)
1905 PL_rsfp_filters = newAV();
1907 datasv = NEWSV(255,0);
1908 if (!SvUPGRADE(datasv, SVt_PVIO))
1909 Perl_die(aTHX_ "Can't upgrade filter_add data to SVt_PVIO");
1910 IoANY(datasv) = (void *)funcp; /* stash funcp into spare field */
1911 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
1912 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
1913 funcp, SvPV_nolen(datasv)));
1914 av_unshift(PL_rsfp_filters, 1);
1915 av_store(PL_rsfp_filters, 0, datasv) ;
1920 /* Delete most recently added instance of this filter function. */
1922 Perl_filter_del(pTHX_ filter_t funcp)
1925 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", funcp));
1926 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
1928 /* if filter is on top of stack (usual case) just pop it off */
1929 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
1930 if (IoANY(datasv) == (void *)funcp) {
1931 IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
1932 IoANY(datasv) = (void *)NULL;
1933 sv_free(av_pop(PL_rsfp_filters));
1937 /* we need to search for the correct entry and clear it */
1938 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
1942 /* Invoke the n'th filter function for the current rsfp. */
1944 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
1947 /* 0 = read one text line */
1952 if (!PL_rsfp_filters)
1954 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
1955 /* Provide a default input filter to make life easy. */
1956 /* Note that we append to the line. This is handy. */
1957 DEBUG_P(PerlIO_printf(Perl_debug_log,
1958 "filter_read %d: from rsfp\n", idx));
1962 int old_len = SvCUR(buf_sv) ;
1964 /* ensure buf_sv is large enough */
1965 SvGROW(buf_sv, old_len + maxlen) ;
1966 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1967 if (PerlIO_error(PL_rsfp))
1968 return -1; /* error */
1970 return 0 ; /* end of file */
1972 SvCUR_set(buf_sv, old_len + len) ;
1975 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
1976 if (PerlIO_error(PL_rsfp))
1977 return -1; /* error */
1979 return 0 ; /* end of file */
1982 return SvCUR(buf_sv);
1984 /* Skip this filter slot if filter has been deleted */
1985 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
1986 DEBUG_P(PerlIO_printf(Perl_debug_log,
1987 "filter_read %d: skipped (filter deleted)\n",
1989 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1991 /* Get function pointer hidden within datasv */
1992 funcp = (filter_t)IoANY(datasv);
1993 DEBUG_P(PerlIO_printf(Perl_debug_log,
1994 "filter_read %d: via function %p (%s)\n",
1995 idx, funcp, SvPV_nolen(datasv)));
1996 /* Call function. The function is expected to */
1997 /* call "FILTER_READ(idx+1, buf_sv)" first. */
1998 /* Return: <0:error, =0:eof, >0:not eof */
1999 return (*funcp)(aTHXo_ idx, buf_sv, maxlen);
2003 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
2005 #ifdef PERL_CR_FILTER
2006 if (!PL_rsfp_filters) {
2007 filter_add(S_cr_textfilter,NULL);
2010 if (PL_rsfp_filters) {
2013 SvCUR_set(sv, 0); /* start with empty line */
2014 if (FILTER_READ(0, sv, 0) > 0)
2015 return ( SvPVX(sv) ) ;
2020 return (sv_gets(sv, fp, append));
2024 S_find_in_my_stash(pTHX_ char *pkgname, I32 len)
2028 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
2032 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
2033 (gv = gv_fetchpv(pkgname, FALSE, SVt_PVHV)))
2035 return GvHV(gv); /* Foo:: */
2038 /* use constant CLASS => 'MyClass' */
2039 if ((gv = gv_fetchpv(pkgname, FALSE, SVt_PVCV))) {
2041 if (GvCV(gv) && (sv = cv_const_sv(GvCV(gv)))) {
2042 pkgname = SvPV_nolen(sv);
2046 return gv_stashpv(pkgname, FALSE);
2050 static char* exp_name[] =
2051 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
2052 "ATTRTERM", "TERMBLOCK"
2059 Works out what to call the token just pulled out of the input
2060 stream. The yacc parser takes care of taking the ops we return and
2061 stitching them into a tree.
2067 if read an identifier
2068 if we're in a my declaration
2069 croak if they tried to say my($foo::bar)
2070 build the ops for a my() declaration
2071 if it's an access to a my() variable
2072 are we in a sort block?
2073 croak if my($a); $a <=> $b
2074 build ops for access to a my() variable
2075 if in a dq string, and they've said @foo and we can't find @foo
2077 build ops for a bareword
2078 if we already built the token before, use it.
2082 #pragma segment Perl_yylex
2085 #ifdef USE_PURE_BISON
2086 Perl_yylex(pTHX_ YYSTYPE *lvalp, int *lcharp)
2099 #ifdef USE_PURE_BISON
2100 yylval_pointer = lvalp;
2101 yychar_pointer = lcharp;
2104 /* check if there's an identifier for us to look at */
2105 if (PL_pending_ident) {
2106 /* pit holds the identifier we read and pending_ident is reset */
2107 char pit = PL_pending_ident;
2108 PL_pending_ident = 0;
2110 /* if we're in a my(), we can't allow dynamics here.
2111 $foo'bar has already been turned into $foo::bar, so
2112 just check for colons.
2114 if it's a legal name, the OP is a PADANY.
2117 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
2118 if (strchr(PL_tokenbuf,':'))
2119 yyerror(Perl_form(aTHX_ "No package name allowed for "
2120 "variable %s in \"our\"",
2122 tmp = pad_allocmy(PL_tokenbuf);
2125 if (strchr(PL_tokenbuf,':'))
2126 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
2128 yylval.opval = newOP(OP_PADANY, 0);
2129 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
2135 build the ops for accesses to a my() variable.
2137 Deny my($a) or my($b) in a sort block, *if* $a or $b is
2138 then used in a comparison. This catches most, but not
2139 all cases. For instance, it catches
2140 sort { my($a); $a <=> $b }
2142 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
2143 (although why you'd do that is anyone's guess).
2146 if (!strchr(PL_tokenbuf,':')) {
2148 /* Check for single character per-thread SVs */
2149 if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
2150 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
2151 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
2153 yylval.opval = newOP(OP_THREADSV, 0);
2154 yylval.opval->op_targ = tmp;
2157 #endif /* USE_THREADS */
2158 if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
2159 SV *namesv = AvARRAY(PL_comppad_name)[tmp];
2160 /* might be an "our" variable" */
2161 if (SvFLAGS(namesv) & SVpad_OUR) {
2162 /* build ops for a bareword */
2163 SV *sym = newSVpv(HvNAME(GvSTASH(namesv)),0);
2164 sv_catpvn(sym, "::", 2);
2165 sv_catpv(sym, PL_tokenbuf+1);
2166 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
2167 yylval.opval->op_private = OPpCONST_ENTERED;
2168 gv_fetchpv(SvPVX(sym),
2170 ? (GV_ADDMULTI | GV_ADDINEVAL)
2173 ((PL_tokenbuf[0] == '$') ? SVt_PV
2174 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
2179 /* if it's a sort block and they're naming $a or $b */
2180 if (PL_last_lop_op == OP_SORT &&
2181 PL_tokenbuf[0] == '$' &&
2182 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
2185 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
2186 d < PL_bufend && *d != '\n';
2189 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
2190 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
2196 yylval.opval = newOP(OP_PADANY, 0);
2197 yylval.opval->op_targ = tmp;
2203 Whine if they've said @foo in a doublequoted string,
2204 and @foo isn't a variable we can find in the symbol
2207 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
2208 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
2209 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
2210 && ckWARN(WARN_AMBIGUOUS))
2212 /* Downgraded from fatal to warning 20000522 mjd */
2213 Perl_warner(aTHX_ WARN_AMBIGUOUS,
2214 "Possible unintended interpolation of %s in string",
2219 /* build ops for a bareword */
2220 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
2221 yylval.opval->op_private = OPpCONST_ENTERED;
2222 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
2223 ((PL_tokenbuf[0] == '$') ? SVt_PV
2224 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
2229 /* no identifier pending identification */
2231 switch (PL_lex_state) {
2233 case LEX_NORMAL: /* Some compilers will produce faster */
2234 case LEX_INTERPNORMAL: /* code if we comment these out. */
2238 /* when we've already built the next token, just pull it out of the queue */
2241 yylval = PL_nextval[PL_nexttoke];
2243 PL_lex_state = PL_lex_defer;
2244 PL_expect = PL_lex_expect;
2245 PL_lex_defer = LEX_NORMAL;
2247 return(PL_nexttype[PL_nexttoke]);
2249 /* interpolated case modifiers like \L \U, including \Q and \E.
2250 when we get here, PL_bufptr is at the \
2252 case LEX_INTERPCASEMOD:
2254 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
2255 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
2257 /* handle \E or end of string */
2258 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
2262 if (PL_lex_casemods) {
2263 oldmod = PL_lex_casestack[--PL_lex_casemods];
2264 PL_lex_casestack[PL_lex_casemods] = '\0';
2266 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
2268 PL_lex_state = LEX_INTERPCONCAT;
2272 if (PL_bufptr != PL_bufend)
2274 PL_lex_state = LEX_INTERPCONCAT;
2279 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
2280 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
2281 if (strchr("LU", *s) &&
2282 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
2284 PL_lex_casestack[--PL_lex_casemods] = '\0';
2287 if (PL_lex_casemods > 10) {
2288 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
2289 if (newlb != PL_lex_casestack) {
2291 PL_lex_casestack = newlb;
2294 PL_lex_casestack[PL_lex_casemods++] = *s;
2295 PL_lex_casestack[PL_lex_casemods] = '\0';
2296 PL_lex_state = LEX_INTERPCONCAT;
2297 PL_nextval[PL_nexttoke].ival = 0;
2300 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
2302 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
2304 PL_nextval[PL_nexttoke].ival = OP_LC;
2306 PL_nextval[PL_nexttoke].ival = OP_UC;
2308 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
2310 Perl_croak(aTHX_ "panic: yylex");
2313 if (PL_lex_starts) {
2322 case LEX_INTERPPUSH:
2323 return sublex_push();
2325 case LEX_INTERPSTART:
2326 if (PL_bufptr == PL_bufend)
2327 return sublex_done();
2329 PL_lex_dojoin = (*PL_bufptr == '@');
2330 PL_lex_state = LEX_INTERPNORMAL;
2331 if (PL_lex_dojoin) {
2332 PL_nextval[PL_nexttoke].ival = 0;
2335 PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
2336 PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
2337 force_next(PRIVATEREF);
2339 force_ident("\"", '$');
2340 #endif /* USE_THREADS */
2341 PL_nextval[PL_nexttoke].ival = 0;
2343 PL_nextval[PL_nexttoke].ival = 0;
2345 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
2348 if (PL_lex_starts++) {
2354 case LEX_INTERPENDMAYBE:
2355 if (intuit_more(PL_bufptr)) {
2356 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
2362 if (PL_lex_dojoin) {
2363 PL_lex_dojoin = FALSE;
2364 PL_lex_state = LEX_INTERPCONCAT;
2367 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
2368 && SvEVALED(PL_lex_repl))
2370 if (PL_bufptr != PL_bufend)
2371 Perl_croak(aTHX_ "Bad evalled substitution pattern");
2372 PL_lex_repl = Nullsv;
2375 case LEX_INTERPCONCAT:
2377 if (PL_lex_brackets)
2378 Perl_croak(aTHX_ "panic: INTERPCONCAT");
2380 if (PL_bufptr == PL_bufend)
2381 return sublex_done();
2383 if (SvIVX(PL_linestr) == '\'') {
2384 SV *sv = newSVsv(PL_linestr);
2387 else if ( PL_hints & HINT_NEW_RE )
2388 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
2389 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2393 s = scan_const(PL_bufptr);
2395 PL_lex_state = LEX_INTERPCASEMOD;
2397 PL_lex_state = LEX_INTERPSTART;
2400 if (s != PL_bufptr) {
2401 PL_nextval[PL_nexttoke] = yylval;
2404 if (PL_lex_starts++)
2414 PL_lex_state = LEX_NORMAL;
2415 s = scan_formline(PL_bufptr);
2416 if (!PL_lex_formbrack)
2422 PL_oldoldbufptr = PL_oldbufptr;
2425 PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at %s\n",
2426 exp_name[PL_expect], s);
2432 if (isIDFIRST_lazy_if(s,UTF))
2434 Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
2437 goto fake_eof; /* emulate EOF on ^D or ^Z */
2442 if (PL_lex_brackets)
2443 yyerror("Missing right curly or square bracket");
2446 if (s++ < PL_bufend)
2447 goto retry; /* ignore stray nulls */
2450 if (!PL_in_eval && !PL_preambled) {
2451 PL_preambled = TRUE;
2452 sv_setpv(PL_linestr,incl_perldb());
2453 if (SvCUR(PL_linestr))
2454 sv_catpv(PL_linestr,";");
2456 while(AvFILLp(PL_preambleav) >= 0) {
2457 SV *tmpsv = av_shift(PL_preambleav);
2458 sv_catsv(PL_linestr, tmpsv);
2459 sv_catpv(PL_linestr, ";");
2462 sv_free((SV*)PL_preambleav);
2463 PL_preambleav = NULL;
2465 if (PL_minus_n || PL_minus_p) {
2466 sv_catpv(PL_linestr, "LINE: while (<>) {");
2468 sv_catpv(PL_linestr,"chomp;");
2470 GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
2472 GvIMPORTED_AV_on(gv);
2474 if (strchr("/'\"", *PL_splitstr)
2475 && strchr(PL_splitstr + 1, *PL_splitstr))
2476 Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s);", PL_splitstr);
2479 s = "'~#\200\1'"; /* surely one char is unused...*/
2480 while (s[1] && strchr(PL_splitstr, *s)) s++;
2482 Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s%c",
2483 "q" + (delim == '\''), delim);
2484 for (s = PL_splitstr; *s; s++) {
2486 sv_catpvn(PL_linestr, "\\", 1);
2487 sv_catpvn(PL_linestr, s, 1);
2489 Perl_sv_catpvf(aTHX_ PL_linestr, "%c);", delim);
2493 sv_catpv(PL_linestr,"@F=split(' ');");
2496 sv_catpv(PL_linestr, "\n");
2497 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2498 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2499 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2500 SV *sv = NEWSV(85,0);
2502 sv_upgrade(sv, SVt_PVMG);
2503 sv_setsv(sv,PL_linestr);
2504 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2510 bof = PL_rsfp && (PerlIO_tell(PL_rsfp) == 0); /* *Before* read! */
2511 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
2514 if (PL_preprocess && !PL_in_eval)
2515 (void)PerlProc_pclose(PL_rsfp);
2516 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2517 PerlIO_clearerr(PL_rsfp);
2519 (void)PerlIO_close(PL_rsfp);
2521 PL_doextract = FALSE;
2523 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2524 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
2525 sv_catpv(PL_linestr,";}");
2526 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2527 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2528 PL_minus_n = PL_minus_p = 0;
2531 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2532 sv_setpv(PL_linestr,"");
2533 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
2536 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
2537 PL_doextract = FALSE;
2539 /* Incest with pod. */
2540 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2541 sv_setpv(PL_linestr, "");
2542 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2543 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2544 PL_doextract = FALSE;
2548 s = swallow_bom((U8*)s);
2550 } while (PL_doextract);
2551 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2552 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2553 SV *sv = NEWSV(85,0);
2555 sv_upgrade(sv, SVt_PVMG);
2556 sv_setsv(sv,PL_linestr);
2557 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2559 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2560 if (CopLINE(PL_curcop) == 1) {
2561 while (s < PL_bufend && isSPACE(*s))
2563 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2567 if (*s == '#' && *(s+1) == '!')
2569 #ifdef ALTERNATE_SHEBANG
2571 static char as[] = ALTERNATE_SHEBANG;
2572 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2573 d = s + (sizeof(as) - 1);
2575 #endif /* ALTERNATE_SHEBANG */
2584 while (*d && !isSPACE(*d))
2588 #ifdef ARG_ZERO_IS_SCRIPT
2589 if (ipathend > ipath) {
2591 * HP-UX (at least) sets argv[0] to the script name,
2592 * which makes $^X incorrect. And Digital UNIX and Linux,
2593 * at least, set argv[0] to the basename of the Perl
2594 * interpreter. So, having found "#!", we'll set it right.
2596 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
2597 assert(SvPOK(x) || SvGMAGICAL(x));
2598 if (sv_eq(x, CopFILESV(PL_curcop))) {
2599 sv_setpvn(x, ipath, ipathend - ipath);
2602 TAINT_NOT; /* $^X is always tainted, but that's OK */
2604 #endif /* ARG_ZERO_IS_SCRIPT */
2609 d = instr(s,"perl -");
2611 d = instr(s,"perl");
2613 /* avoid getting into infinite loops when shebang
2614 * line contains "Perl" rather than "perl" */
2616 for (d = ipathend-4; d >= ipath; --d) {
2617 if ((*d == 'p' || *d == 'P')
2618 && !ibcmp(d, "perl", 4))
2628 #ifdef ALTERNATE_SHEBANG
2630 * If the ALTERNATE_SHEBANG on this system starts with a
2631 * character that can be part of a Perl expression, then if
2632 * we see it but not "perl", we're probably looking at the
2633 * start of Perl code, not a request to hand off to some
2634 * other interpreter. Similarly, if "perl" is there, but
2635 * not in the first 'word' of the line, we assume the line
2636 * contains the start of the Perl program.
2638 if (d && *s != '#') {
2640 while (*c && !strchr("; \t\r\n\f\v#", *c))
2643 d = Nullch; /* "perl" not in first word; ignore */
2645 *s = '#'; /* Don't try to parse shebang line */
2647 #endif /* ALTERNATE_SHEBANG */
2648 #ifndef MACOS_TRADITIONAL
2653 !instr(s,"indir") &&
2654 instr(PL_origargv[0],"perl"))
2660 while (s < PL_bufend && isSPACE(*s))
2662 if (s < PL_bufend) {
2663 Newz(899,newargv,PL_origargc+3,char*);
2665 while (s < PL_bufend && !isSPACE(*s))
2668 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2671 newargv = PL_origargv;
2673 PerlProc_execv(ipath, newargv);
2674 Perl_croak(aTHX_ "Can't exec %s", ipath);
2678 U32 oldpdb = PL_perldb;
2679 bool oldn = PL_minus_n;
2680 bool oldp = PL_minus_p;
2682 while (*d && !isSPACE(*d)) d++;
2683 while (SPACE_OR_TAB(*d)) d++;
2687 if (*d == 'M' || *d == 'm') {
2689 while (*d && !isSPACE(*d)) d++;
2690 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2693 d = moreswitches(d);
2695 if ((PERLDB_LINE && !oldpdb) ||
2696 ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
2697 /* if we have already added "LINE: while (<>) {",
2698 we must not do it again */
2700 sv_setpv(PL_linestr, "");
2701 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2702 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2703 PL_preambled = FALSE;
2705 (void)gv_fetchfile(PL_origfilename);
2712 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2714 PL_lex_state = LEX_FORMLINE;
2719 #ifdef PERL_STRICT_CR
2720 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2722 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
2724 case ' ': case '\t': case '\f': case 013:
2725 #ifdef MACOS_TRADITIONAL
2732 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2733 if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
2734 /* handle eval qq[#line 1 "foo"\n ...] */
2735 CopLINE_dec(PL_curcop);
2739 while (s < d && *s != '\n')
2744 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2746 PL_lex_state = LEX_FORMLINE;
2756 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2761 while (s < PL_bufend && SPACE_OR_TAB(*s))
2764 if (strnEQ(s,"=>",2)) {
2765 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2766 OPERATOR('-'); /* unary minus */
2768 PL_last_uni = PL_oldbufptr;
2769 PL_last_lop_op = OP_FTEREAD; /* good enough */
2771 case 'r': FTST(OP_FTEREAD);
2772 case 'w': FTST(OP_FTEWRITE);
2773 case 'x': FTST(OP_FTEEXEC);
2774 case 'o': FTST(OP_FTEOWNED);
2775 case 'R': FTST(OP_FTRREAD);
2776 case 'W': FTST(OP_FTRWRITE);
2777 case 'X': FTST(OP_FTREXEC);
2778 case 'O': FTST(OP_FTROWNED);
2779 case 'e': FTST(OP_FTIS);
2780 case 'z': FTST(OP_FTZERO);
2781 case 's': FTST(OP_FTSIZE);
2782 case 'f': FTST(OP_FTFILE);
2783 case 'd': FTST(OP_FTDIR);
2784 case 'l': FTST(OP_FTLINK);
2785 case 'p': FTST(OP_FTPIPE);
2786 case 'S': FTST(OP_FTSOCK);
2787 case 'u': FTST(OP_FTSUID);
2788 case 'g': FTST(OP_FTSGID);
2789 case 'k': FTST(OP_FTSVTX);
2790 case 'b': FTST(OP_FTBLK);
2791 case 'c': FTST(OP_FTCHR);
2792 case 't': FTST(OP_FTTTY);
2793 case 'T': FTST(OP_FTTEXT);
2794 case 'B': FTST(OP_FTBINARY);
2795 case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2796 case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2797 case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
2799 Perl_croak(aTHX_ "Unrecognized file test: -%c", (int)tmp);
2806 if (PL_expect == XOPERATOR)
2811 else if (*s == '>') {
2814 if (isIDFIRST_lazy_if(s,UTF)) {
2815 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2823 if (PL_expect == XOPERATOR)
2826 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2828 OPERATOR('-'); /* unary minus */
2835 if (PL_expect == XOPERATOR)
2840 if (PL_expect == XOPERATOR)
2843 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2849 if (PL_expect != XOPERATOR) {
2850 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2851 PL_expect = XOPERATOR;
2852 force_ident(PL_tokenbuf, '*');
2865 if (PL_expect == XOPERATOR) {
2869 PL_tokenbuf[0] = '%';
2870 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2871 if (!PL_tokenbuf[1]) {
2873 yyerror("Final % should be \\% or %name");
2876 PL_pending_ident = '%';
2895 switch (PL_expect) {
2898 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
2900 PL_bufptr = s; /* update in case we back off */
2906 PL_expect = XTERMBLOCK;
2910 while (isIDFIRST_lazy_if(s,UTF)) {
2911 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2912 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
2913 if (tmp < 0) tmp = -tmp;
2928 d = scan_str(d,TRUE,TRUE);
2931 SvREFCNT_dec(PL_lex_stuff);
2932 PL_lex_stuff = Nullsv;
2934 /* MUST advance bufptr here to avoid bogus
2935 "at end of line" context messages from yyerror().
2937 PL_bufptr = s + len;
2938 yyerror("Unterminated attribute parameter in attribute list");
2941 return 0; /* EOF indicator */
2945 SV *sv = newSVpvn(s, len);
2946 sv_catsv(sv, PL_lex_stuff);
2947 attrs = append_elem(OP_LIST, attrs,
2948 newSVOP(OP_CONST, 0, sv));
2949 SvREFCNT_dec(PL_lex_stuff);
2950 PL_lex_stuff = Nullsv;
2953 attrs = append_elem(OP_LIST, attrs,
2954 newSVOP(OP_CONST, 0,
2958 if (*s == ':' && s[1] != ':')
2961 break; /* require real whitespace or :'s */
2963 tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
2964 if (*s != ';' && *s != tmp && (tmp != '=' || *s != ')')) {
2965 char q = ((*s == '\'') ? '"' : '\'');
2966 /* If here for an expression, and parsed no attrs, back off. */
2967 if (tmp == '=' && !attrs) {
2971 /* MUST advance bufptr here to avoid bogus "at end of line"
2972 context messages from yyerror().
2976 yyerror("Unterminated attribute list");
2978 yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list",
2986 PL_nextval[PL_nexttoke].opval = attrs;
2994 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
2995 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
3011 if (PL_lex_brackets <= 0)
3012 yyerror("Unmatched right square bracket");
3015 if (PL_lex_state == LEX_INTERPNORMAL) {
3016 if (PL_lex_brackets == 0) {
3017 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
3018 PL_lex_state = LEX_INTERPEND;
3025 if (PL_lex_brackets > 100) {
3026 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
3027 if (newlb != PL_lex_brackstack) {
3029 PL_lex_brackstack = newlb;
3032 switch (PL_expect) {
3034 if (PL_lex_formbrack) {
3038 if (PL_oldoldbufptr == PL_last_lop)
3039 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3041 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3042 OPERATOR(HASHBRACK);
3044 while (s < PL_bufend && SPACE_OR_TAB(*s))
3047 PL_tokenbuf[0] = '\0';
3048 if (d < PL_bufend && *d == '-') {
3049 PL_tokenbuf[0] = '-';
3051 while (d < PL_bufend && SPACE_OR_TAB(*d))
3054 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
3055 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
3057 while (d < PL_bufend && SPACE_OR_TAB(*d))
3060 char minus = (PL_tokenbuf[0] == '-');
3061 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
3069 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
3074 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3079 if (PL_oldoldbufptr == PL_last_lop)
3080 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3082 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3085 OPERATOR(HASHBRACK);
3086 /* This hack serves to disambiguate a pair of curlies
3087 * as being a block or an anon hash. Normally, expectation
3088 * determines that, but in cases where we're not in a
3089 * position to expect anything in particular (like inside
3090 * eval"") we have to resolve the ambiguity. This code
3091 * covers the case where the first term in the curlies is a
3092 * quoted string. Most other cases need to be explicitly
3093 * disambiguated by prepending a `+' before the opening
3094 * curly in order to force resolution as an anon hash.
3096 * XXX should probably propagate the outer expectation
3097 * into eval"" to rely less on this hack, but that could
3098 * potentially break current behavior of eval"".
3102 if (*s == '\'' || *s == '"' || *s == '`') {
3103 /* common case: get past first string, handling escapes */
3104 for (t++; t < PL_bufend && *t != *s;)
3105 if (*t++ == '\\' && (*t == '\\' || *t == *s))
3109 else if (*s == 'q') {
3112 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
3116 char open, close, term;
3119 while (t < PL_bufend && isSPACE(*t))
3123 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
3127 for (t++; t < PL_bufend; t++) {
3128 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
3130 else if (*t == open)
3134 for (t++; t < PL_bufend; t++) {
3135 if (*t == '\\' && t+1 < PL_bufend)
3137 else if (*t == close && --brackets <= 0)
3139 else if (*t == open)
3145 else if (isALNUM_lazy_if(t,UTF)) {
3147 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3150 while (t < PL_bufend && isSPACE(*t))
3152 /* if comma follows first term, call it an anon hash */
3153 /* XXX it could be a comma expression with loop modifiers */
3154 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
3155 || (*t == '=' && t[1] == '>')))
3156 OPERATOR(HASHBRACK);
3157 if (PL_expect == XREF)
3160 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
3166 yylval.ival = CopLINE(PL_curcop);
3167 if (isSPACE(*s) || *s == '#')
3168 PL_copline = NOLINE; /* invalidate current command line number */
3173 if (PL_lex_brackets <= 0)
3174 yyerror("Unmatched right curly bracket");
3176 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
3177 if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
3178 PL_lex_formbrack = 0;
3179 if (PL_lex_state == LEX_INTERPNORMAL) {
3180 if (PL_lex_brackets == 0) {
3181 if (PL_expect & XFAKEBRACK) {
3182 PL_expect &= XENUMMASK;
3183 PL_lex_state = LEX_INTERPEND;
3185 return yylex(); /* ignore fake brackets */
3187 if (*s == '-' && s[1] == '>')
3188 PL_lex_state = LEX_INTERPENDMAYBE;
3189 else if (*s != '[' && *s != '{')
3190 PL_lex_state = LEX_INTERPEND;
3193 if (PL_expect & XFAKEBRACK) {
3194 PL_expect &= XENUMMASK;
3196 return yylex(); /* ignore fake brackets */
3206 if (PL_expect == XOPERATOR) {
3207 if (ckWARN(WARN_SEMICOLON)
3208 && isIDFIRST_lazy_if(s,UTF) && PL_bufptr == PL_linestart)
3210 CopLINE_dec(PL_curcop);
3211 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3212 CopLINE_inc(PL_curcop);
3217 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3219 PL_expect = XOPERATOR;
3220 force_ident(PL_tokenbuf, '&');
3224 yylval.ival = (OPpENTERSUB_AMPER<<8);
3243 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
3244 Perl_warner(aTHX_ WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
3246 if (PL_expect == XSTATE && isALPHA(tmp) &&
3247 (s == PL_linestart+1 || s[-2] == '\n') )
3249 if (PL_in_eval && !PL_rsfp) {
3254 if (strnEQ(s,"=cut",4)) {
3268 PL_doextract = TRUE;
3271 if (PL_lex_brackets < PL_lex_formbrack) {
3273 #ifdef PERL_STRICT_CR
3274 for (t = s; SPACE_OR_TAB(*t); t++) ;
3276 for (t = s; SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
3278 if (*t == '\n' || *t == '#') {
3296 if (PL_expect != XOPERATOR) {
3297 if (s[1] != '<' && !strchr(s,'>'))
3300 s = scan_heredoc(s);
3302 s = scan_inputsymbol(s);
3303 TERM(sublex_start());
3308 SHop(OP_LEFT_SHIFT);
3322 SHop(OP_RIGHT_SHIFT);
3331 if (PL_expect == XOPERATOR) {
3332 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3335 return ','; /* grandfather non-comma-format format */
3339 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
3340 PL_tokenbuf[0] = '@';
3341 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3342 sizeof PL_tokenbuf - 1, FALSE);
3343 if (PL_expect == XOPERATOR)
3344 no_op("Array length", s);
3345 if (!PL_tokenbuf[1])
3347 PL_expect = XOPERATOR;
3348 PL_pending_ident = '#';
3352 PL_tokenbuf[0] = '$';
3353 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3354 sizeof PL_tokenbuf - 1, FALSE);
3355 if (PL_expect == XOPERATOR)
3357 if (!PL_tokenbuf[1]) {
3359 yyerror("Final $ should be \\$ or $name");
3363 /* This kludge not intended to be bulletproof. */
3364 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
3365 yylval.opval = newSVOP(OP_CONST, 0,
3366 newSViv(PL_compiling.cop_arybase));
3367 yylval.opval->op_private = OPpCONST_ARYBASE;
3373 if (PL_lex_state == LEX_NORMAL)
3376 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3379 PL_tokenbuf[0] = '@';
3380 if (ckWARN(WARN_SYNTAX)) {
3382 isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$';
3385 PL_bufptr = skipspace(PL_bufptr);
3386 while (t < PL_bufend && *t != ']')
3388 Perl_warner(aTHX_ WARN_SYNTAX,
3389 "Multidimensional syntax %.*s not supported",
3390 (t - PL_bufptr) + 1, PL_bufptr);
3394 else if (*s == '{') {
3395 PL_tokenbuf[0] = '%';
3396 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
3397 (t = strchr(s, '}')) && (t = strchr(t, '=')))
3399 char tmpbuf[sizeof PL_tokenbuf];
3401 for (t++; isSPACE(*t); t++) ;
3402 if (isIDFIRST_lazy_if(t,UTF)) {
3403 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
3404 for (; isSPACE(*t); t++) ;
3405 if (*t == ';' && get_cv(tmpbuf, FALSE))
3406 Perl_warner(aTHX_ WARN_SYNTAX,
3407 "You need to quote \"%s\"", tmpbuf);
3413 PL_expect = XOPERATOR;
3414 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3415 bool islop = (PL_last_lop == PL_oldoldbufptr);
3416 if (!islop || PL_last_lop_op == OP_GREPSTART)
3417 PL_expect = XOPERATOR;
3418 else if (strchr("$@\"'`q", *s))
3419 PL_expect = XTERM; /* e.g. print $fh "foo" */
3420 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
3421 PL_expect = XTERM; /* e.g. print $fh &sub */
3422 else if (isIDFIRST_lazy_if(s,UTF)) {
3423 char tmpbuf[sizeof PL_tokenbuf];
3424 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3425 if ((tmp = keyword(tmpbuf, len))) {
3426 /* binary operators exclude handle interpretations */
3438 PL_expect = XTERM; /* e.g. print $fh length() */
3443 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
3444 if (gv && GvCVu(gv))
3445 PL_expect = XTERM; /* e.g. print $fh subr() */
3448 else if (isDIGIT(*s))
3449 PL_expect = XTERM; /* e.g. print $fh 3 */
3450 else if (*s == '.' && isDIGIT(s[1]))
3451 PL_expect = XTERM; /* e.g. print $fh .3 */
3452 else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
3453 PL_expect = XTERM; /* e.g. print $fh -1 */
3454 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3455 PL_expect = XTERM; /* print $fh <<"EOF" */
3457 PL_pending_ident = '$';
3461 if (PL_expect == XOPERATOR)
3463 PL_tokenbuf[0] = '@';
3464 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3465 if (!PL_tokenbuf[1]) {
3467 yyerror("Final @ should be \\@ or @name");
3470 if (PL_lex_state == LEX_NORMAL)
3472 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3474 PL_tokenbuf[0] = '%';
3476 /* Warn about @ where they meant $. */
3477 if (ckWARN(WARN_SYNTAX)) {
3478 if (*s == '[' || *s == '{') {
3480 while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
3482 if (*t == '}' || *t == ']') {
3484 PL_bufptr = skipspace(PL_bufptr);
3485 Perl_warner(aTHX_ WARN_SYNTAX,
3486 "Scalar value %.*s better written as $%.*s",
3487 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
3492 PL_pending_ident = '@';
3495 case '/': /* may either be division or pattern */
3496 case '?': /* may either be conditional or pattern */
3497 if (PL_expect != XOPERATOR) {
3498 /* Disable warning on "study /blah/" */
3499 if (PL_oldoldbufptr == PL_last_uni
3500 && (*PL_last_uni != 's' || s - PL_last_uni < 5
3501 || memNE(PL_last_uni, "study", 5)
3502 || isALNUM_lazy_if(PL_last_uni+5,UTF)))
3504 s = scan_pat(s,OP_MATCH);
3505 TERM(sublex_start());
3513 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3514 #ifdef PERL_STRICT_CR
3517 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3519 && (s == PL_linestart || s[-1] == '\n') )
3521 PL_lex_formbrack = 0;
3525 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
3531 yylval.ival = OPf_SPECIAL;
3537 if (PL_expect != XOPERATOR)
3542 case '0': case '1': case '2': case '3': case '4':
3543 case '5': case '6': case '7': case '8': case '9':
3545 if (PL_expect == XOPERATOR)
3550 s = scan_str(s,FALSE,FALSE);
3551 if (PL_expect == XOPERATOR) {
3552 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3555 return ','; /* grandfather non-comma-format format */
3561 missingterm((char*)0);
3562 yylval.ival = OP_CONST;
3563 TERM(sublex_start());
3566 s = scan_str(s,FALSE,FALSE);
3567 if (PL_expect == XOPERATOR) {
3568 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3571 return ','; /* grandfather non-comma-format format */
3577 missingterm((char*)0);
3578 yylval.ival = OP_CONST;
3579 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
3580 if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
3581 yylval.ival = OP_STRINGIFY;
3585 TERM(sublex_start());
3588 s = scan_str(s,FALSE,FALSE);
3589 if (PL_expect == XOPERATOR)
3590 no_op("Backticks",s);
3592 missingterm((char*)0);
3593 yylval.ival = OP_BACKTICK;
3595 TERM(sublex_start());
3599 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
3600 Perl_warner(aTHX_ WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
3602 if (PL_expect == XOPERATOR)
3603 no_op("Backslash",s);
3607 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
3611 while (isDIGIT(*start) || *start == '_')
3613 if (*start == '.' && isDIGIT(start[1])) {
3617 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
3618 else if (!isALPHA(*start) && (PL_expect == XTERM || PL_expect == XREF)) {
3622 gv = gv_fetchpv(s, FALSE, SVt_PVCV);
3632 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
3671 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3673 /* Some keywords can be followed by any delimiter, including ':' */
3674 tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
3675 (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
3676 (PL_tokenbuf[0] == 'q' &&
3677 strchr("qwxr", PL_tokenbuf[1])))));
3679 /* x::* is just a word, unless x is "CORE" */
3680 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
3684 while (d < PL_bufend && isSPACE(*d))
3685 d++; /* no comments skipped here, or s### is misparsed */
3687 /* Is this a label? */
3688 if (!tmp && PL_expect == XSTATE
3689 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
3691 yylval.pval = savepv(PL_tokenbuf);
3696 /* Check for keywords */
3697 tmp = keyword(PL_tokenbuf, len);
3699 /* Is this a word before a => operator? */
3700 if (*d == '=' && d[1] == '>') {
3702 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
3703 yylval.opval->op_private = OPpCONST_BARE;
3707 if (tmp < 0) { /* second-class keyword? */
3708 GV *ogv = Nullgv; /* override (winner) */
3709 GV *hgv = Nullgv; /* hidden (loser) */
3710 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3712 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3715 if (GvIMPORTED_CV(gv))
3717 else if (! CvMETHOD(cv))
3721 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3722 (gv = *gvp) != (GV*)&PL_sv_undef &&
3723 GvCVu(gv) && GvIMPORTED_CV(gv))
3729 tmp = 0; /* overridden by import or by GLOBAL */
3732 && -tmp==KEY_lock /* XXX generalizable kludge */
3734 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3736 tmp = 0; /* any sub overrides "weak" keyword */
3738 else { /* no override */
3742 if (ckWARN(WARN_AMBIGUOUS) && hgv
3743 && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3744 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3745 "Ambiguous call resolved as CORE::%s(), %s",
3746 GvENAME(hgv), "qualify as such or use &");
3753 default: /* not a keyword */
3756 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3758 /* Get the rest if it looks like a package qualifier */
3760 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
3762 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3765 Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
3766 *s == '\'' ? "'" : "::");
3770 if (PL_expect == XOPERATOR) {
3771 if (PL_bufptr == PL_linestart) {
3772 CopLINE_dec(PL_curcop);
3773 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3774 CopLINE_inc(PL_curcop);
3777 no_op("Bareword",s);
3780 /* Look for a subroutine with this name in current package,
3781 unless name is "Foo::", in which case Foo is a bearword
3782 (and a package name). */
3785 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3787 if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3788 Perl_warner(aTHX_ WARN_BAREWORD,
3789 "Bareword \"%s\" refers to nonexistent package",
3792 PL_tokenbuf[len] = '\0';
3799 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3802 /* if we saw a global override before, get the right name */
3805 sv = newSVpvn("CORE::GLOBAL::",14);
3806 sv_catpv(sv,PL_tokenbuf);
3809 sv = newSVpv(PL_tokenbuf,0);
3811 /* Presume this is going to be a bareword of some sort. */
3814 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3815 yylval.opval->op_private = OPpCONST_BARE;
3817 /* And if "Foo::", then that's what it certainly is. */
3822 /* See if it's the indirect object for a list operator. */
3824 if (PL_oldoldbufptr &&
3825 PL_oldoldbufptr < PL_bufptr &&
3826 (PL_oldoldbufptr == PL_last_lop
3827 || PL_oldoldbufptr == PL_last_uni) &&
3828 /* NO SKIPSPACE BEFORE HERE! */
3829 (PL_expect == XREF ||
3830 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
3832 bool immediate_paren = *s == '(';
3834 /* (Now we can afford to cross potential line boundary.) */
3837 /* Two barewords in a row may indicate method call. */
3839 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp=intuit_method(s,gv)))
3842 /* If not a declared subroutine, it's an indirect object. */
3843 /* (But it's an indir obj regardless for sort.) */
3845 if ((PL_last_lop_op == OP_SORT ||
3846 (!immediate_paren && (!gv || !GvCVu(gv)))) &&
3847 (PL_last_lop_op != OP_MAPSTART &&
3848 PL_last_lop_op != OP_GREPSTART))
3850 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3856 PL_expect = XOPERATOR;
3859 /* Is this a word before a => operator? */
3860 if (*s == '=' && s[1] == '>') {
3862 sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
3866 /* If followed by a paren, it's certainly a subroutine. */
3869 if (gv && GvCVu(gv)) {
3870 for (d = s + 1; SPACE_OR_TAB(*d); d++) ;
3871 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
3876 PL_nextval[PL_nexttoke].opval = yylval.opval;
3877 PL_expect = XOPERATOR;
3883 /* If followed by var or block, call it a method (unless sub) */
3885 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3886 PL_last_lop = PL_oldbufptr;
3887 PL_last_lop_op = OP_METHOD;
3891 /* If followed by a bareword, see if it looks like indir obj. */
3893 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp = intuit_method(s,gv)))
3896 /* Not a method, so call it a subroutine (if defined) */
3898 if (gv && GvCVu(gv)) {
3900 if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
3901 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3902 "Ambiguous use of -%s resolved as -&%s()",
3903 PL_tokenbuf, PL_tokenbuf);
3904 /* Check for a constant sub */
3906 if ((sv = cv_const_sv(cv))) {
3908 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3909 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3910 yylval.opval->op_private = 0;
3914 /* Resolve to GV now. */
3915 op_free(yylval.opval);
3916 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3917 yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
3918 PL_last_lop = PL_oldbufptr;
3919 PL_last_lop_op = OP_ENTERSUB;
3920 /* Is there a prototype? */
3923 char *proto = SvPV((SV*)cv, len);
3926 if (strEQ(proto, "$"))
3928 if (*proto == '&' && *s == '{') {
3929 sv_setpv(PL_subname,"__ANON__");
3933 PL_nextval[PL_nexttoke].opval = yylval.opval;
3939 /* Call it a bare word */
3941 if (PL_hints & HINT_STRICT_SUBS)
3942 yylval.opval->op_private |= OPpCONST_STRICT;
3945 if (ckWARN(WARN_RESERVED)) {
3946 if (lastchar != '-') {
3947 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3949 Perl_warner(aTHX_ WARN_RESERVED, PL_warn_reserved,
3956 if (lastchar && strchr("*%&", lastchar) && ckWARN_d(WARN_AMBIGUOUS)) {
3957 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3958 "Operator or semicolon missing before %c%s",
3959 lastchar, PL_tokenbuf);
3960 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3961 "Ambiguous use of %c resolved as operator %c",
3962 lastchar, lastchar);
3968 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3969 newSVpv(CopFILE(PL_curcop),0));
3973 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3974 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
3977 case KEY___PACKAGE__:
3978 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3980 ? newSVsv(PL_curstname)
3989 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3990 char *pname = "main";
3991 if (PL_tokenbuf[2] == 'D')
3992 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3993 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
3996 GvIOp(gv) = newIO();
3997 IoIFP(GvIOp(gv)) = PL_rsfp;
3998 #if defined(HAS_FCNTL) && defined(F_SETFD)
4000 int fd = PerlIO_fileno(PL_rsfp);
4001 fcntl(fd,F_SETFD,fd >= 3);
4004 /* Mark this internal pseudo-handle as clean */
4005 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
4007 IoTYPE(GvIOp(gv)) = '|';
4008 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
4009 IoTYPE(GvIOp(gv)) = '-';
4011 IoTYPE(GvIOp(gv)) = '<';
4012 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
4013 /* if the script was opened in binmode, we need to revert
4014 * it to text mode for compatibility; but only iff it has CRs
4015 * XXX this is a questionable hack at best. */
4016 if (PL_bufend-PL_bufptr > 2
4017 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
4020 if (IoTYPE(GvIOp(gv)) == '<') {
4021 loc = PerlIO_tell(PL_rsfp);
4022 (void)PerlIO_seek(PL_rsfp, 0L, 0);
4024 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
4025 #if defined(__BORLANDC__)
4026 /* XXX see note in do_binmode() */
4027 ((FILE*)PL_rsfp)->flags |= _F_BIN;
4030 PerlIO_seek(PL_rsfp, loc, 0);
4045 if (PL_expect == XSTATE) {
4052 if (*s == ':' && s[1] == ':') {
4055 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4056 if (!(tmp = keyword(PL_tokenbuf, len)))
4057 Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
4071 LOP(OP_ACCEPT,XTERM);
4077 LOP(OP_ATAN2,XTERM);
4083 LOP(OP_BINMODE,XTERM);
4086 LOP(OP_BLESS,XTERM);
4095 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
4112 if (!PL_cryptseen) {
4113 PL_cryptseen = TRUE;
4117 LOP(OP_CRYPT,XTERM);
4120 if (ckWARN(WARN_CHMOD)) {
4121 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4122 if (*d != '0' && isDIGIT(*d))
4123 Perl_warner(aTHX_ WARN_CHMOD,
4124 "chmod() mode argument is missing initial 0");
4126 LOP(OP_CHMOD,XTERM);
4129 LOP(OP_CHOWN,XTERM);
4132 LOP(OP_CONNECT,XTERM);
4148 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4152 PL_hints |= HINT_BLOCK_SCOPE;
4162 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
4163 LOP(OP_DBMOPEN,XTERM);
4169 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4176 yylval.ival = CopLINE(PL_curcop);
4190 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
4191 UNIBRACK(OP_ENTEREVAL);
4206 case KEY_endhostent:
4212 case KEY_endservent:
4215 case KEY_endprotoent:
4226 yylval.ival = CopLINE(PL_curcop);
4228 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
4230 if ((PL_bufend - p) >= 3 &&
4231 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
4233 else if ((PL_bufend - p) >= 4 &&
4234 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
4237 if (isIDFIRST_lazy_if(p,UTF)) {
4238 p = scan_ident(p, PL_bufend,
4239 PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4243 Perl_croak(aTHX_ "Missing $ on loop variable");
4248 LOP(OP_FORMLINE,XTERM);
4254 LOP(OP_FCNTL,XTERM);
4260 LOP(OP_FLOCK,XTERM);
4269 LOP(OP_GREPSTART, XREF);
4272 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4287 case KEY_getpriority:
4288 LOP(OP_GETPRIORITY,XTERM);
4290 case KEY_getprotobyname:
4293 case KEY_getprotobynumber:
4294 LOP(OP_GPBYNUMBER,XTERM);
4296 case KEY_getprotoent:
4308 case KEY_getpeername:
4309 UNI(OP_GETPEERNAME);
4311 case KEY_gethostbyname:
4314 case KEY_gethostbyaddr:
4315 LOP(OP_GHBYADDR,XTERM);
4317 case KEY_gethostent:
4320 case KEY_getnetbyname:
4323 case KEY_getnetbyaddr:
4324 LOP(OP_GNBYADDR,XTERM);
4329 case KEY_getservbyname:
4330 LOP(OP_GSBYNAME,XTERM);
4332 case KEY_getservbyport:
4333 LOP(OP_GSBYPORT,XTERM);
4335 case KEY_getservent:
4338 case KEY_getsockname:
4339 UNI(OP_GETSOCKNAME);
4341 case KEY_getsockopt:
4342 LOP(OP_GSOCKOPT,XTERM);
4364 yylval.ival = CopLINE(PL_curcop);
4368 LOP(OP_INDEX,XTERM);
4374 LOP(OP_IOCTL,XTERM);
4386 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4418 LOP(OP_LISTEN,XTERM);
4427 s = scan_pat(s,OP_MATCH);
4428 TERM(sublex_start());
4431 LOP(OP_MAPSTART, XREF);
4434 LOP(OP_MKDIR,XTERM);
4437 LOP(OP_MSGCTL,XTERM);
4440 LOP(OP_MSGGET,XTERM);
4443 LOP(OP_MSGRCV,XTERM);
4446 LOP(OP_MSGSND,XTERM);
4452 if (isIDFIRST_lazy_if(s,UTF)) {
4453 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
4454 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
4456 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
4457 if (!PL_in_my_stash) {
4460 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
4468 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4475 if (PL_expect != XSTATE)
4476 yyerror("\"no\" not allowed in expression");
4477 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4478 s = force_version(s);
4483 if (*s == '(' || (s = skipspace(s), *s == '('))
4490 if (isIDFIRST_lazy_if(s,UTF)) {
4492 for (d = s; isALNUM_lazy_if(d,UTF); d++) ;
4494 if (strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE))
4495 Perl_warner(aTHX_ WARN_PRECEDENCE,
4496 "Precedence problem: open %.*s should be open(%.*s)",
4502 yylval.ival = OP_OR;
4512 LOP(OP_OPEN_DIR,XTERM);
4515 checkcomma(s,PL_tokenbuf,"filehandle");
4519 checkcomma(s,PL_tokenbuf,"filehandle");
4538 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4542 LOP(OP_PIPE_OP,XTERM);
4545 s = scan_str(s,FALSE,FALSE);
4547 missingterm((char*)0);
4548 yylval.ival = OP_CONST;
4549 TERM(sublex_start());
4555 s = scan_str(s,FALSE,FALSE);
4557 missingterm((char*)0);
4559 if (SvCUR(PL_lex_stuff)) {
4562 d = SvPV_force(PL_lex_stuff, len);
4564 for (; isSPACE(*d) && len; --len, ++d) ;
4567 if (!warned && ckWARN(WARN_QW)) {
4568 for (; !isSPACE(*d) && len; --len, ++d) {
4570 Perl_warner(aTHX_ WARN_QW,
4571 "Possible attempt to separate words with commas");
4574 else if (*d == '#') {
4575 Perl_warner(aTHX_ WARN_QW,
4576 "Possible attempt to put comments in qw() list");
4582 for (; !isSPACE(*d) && len; --len, ++d) ;
4584 words = append_elem(OP_LIST, words,
4585 newSVOP(OP_CONST, 0, tokeq(newSVpvn(b, d-b))));
4589 PL_nextval[PL_nexttoke].opval = words;
4594 SvREFCNT_dec(PL_lex_stuff);
4595 PL_lex_stuff = Nullsv;
4600 s = scan_str(s,FALSE,FALSE);
4602 missingterm((char*)0);
4603 yylval.ival = OP_STRINGIFY;
4604 if (SvIVX(PL_lex_stuff) == '\'')
4605 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
4606 TERM(sublex_start());
4609 s = scan_pat(s,OP_QR);
4610 TERM(sublex_start());
4613 s = scan_str(s,FALSE,FALSE);
4615 missingterm((char*)0);
4616 yylval.ival = OP_BACKTICK;
4618 TERM(sublex_start());
4625 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4626 s = force_version(s);
4629 *PL_tokenbuf = '\0';
4630 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4631 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
4632 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
4634 yyerror("<> should be quotes");
4642 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4646 LOP(OP_RENAME,XTERM);
4655 LOP(OP_RINDEX,XTERM);
4678 LOP(OP_REVERSE,XTERM);
4689 TERM(sublex_start());
4691 TOKEN(1); /* force error */
4700 LOP(OP_SELECT,XTERM);
4706 LOP(OP_SEMCTL,XTERM);
4709 LOP(OP_SEMGET,XTERM);
4712 LOP(OP_SEMOP,XTERM);
4718 LOP(OP_SETPGRP,XTERM);
4720 case KEY_setpriority:
4721 LOP(OP_SETPRIORITY,XTERM);
4723 case KEY_sethostent:
4729 case KEY_setservent:
4732 case KEY_setprotoent:
4742 LOP(OP_SEEKDIR,XTERM);
4744 case KEY_setsockopt:
4745 LOP(OP_SSOCKOPT,XTERM);
4751 LOP(OP_SHMCTL,XTERM);
4754 LOP(OP_SHMGET,XTERM);
4757 LOP(OP_SHMREAD,XTERM);
4760 LOP(OP_SHMWRITE,XTERM);
4763 LOP(OP_SHUTDOWN,XTERM);
4772 LOP(OP_SOCKET,XTERM);
4774 case KEY_socketpair:
4775 LOP(OP_SOCKPAIR,XTERM);
4778 checkcomma(s,PL_tokenbuf,"subroutine name");
4780 if (*s == ';' || *s == ')') /* probably a close */
4781 Perl_croak(aTHX_ "sort is now a reserved word");
4783 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4787 LOP(OP_SPLIT,XTERM);
4790 LOP(OP_SPRINTF,XTERM);
4793 LOP(OP_SPLICE,XTERM);
4808 LOP(OP_SUBSTR,XTERM);
4814 char tmpbuf[sizeof PL_tokenbuf];
4816 expectation attrful;
4817 bool have_name, have_proto;
4822 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
4823 (*s == ':' && s[1] == ':'))
4826 attrful = XATTRBLOCK;
4827 /* remember buffer pos'n for later force_word */
4828 tboffset = s - PL_oldbufptr;
4829 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4830 if (strchr(tmpbuf, ':'))
4831 sv_setpv(PL_subname, tmpbuf);
4833 sv_setsv(PL_subname,PL_curstname);
4834 sv_catpvn(PL_subname,"::",2);
4835 sv_catpvn(PL_subname,tmpbuf,len);
4842 Perl_croak(aTHX_ "Missing name in \"my sub\"");
4843 PL_expect = XTERMBLOCK;
4844 attrful = XATTRTERM;
4845 sv_setpv(PL_subname,"?");
4849 if (key == KEY_format) {
4851 PL_lex_formbrack = PL_lex_brackets + 1;
4853 (void) force_word(PL_oldbufptr + tboffset, WORD,
4858 /* Look for a prototype */
4862 s = scan_str(s,FALSE,FALSE);
4865 SvREFCNT_dec(PL_lex_stuff);
4866 PL_lex_stuff = Nullsv;
4867 Perl_croak(aTHX_ "Prototype not terminated");
4870 d = SvPVX(PL_lex_stuff);
4872 for (p = d; *p; ++p) {
4877 SvCUR(PL_lex_stuff) = tmp;
4885 if (*s == ':' && s[1] != ':')
4886 PL_expect = attrful;
4889 PL_nextval[PL_nexttoke].opval =
4890 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4891 PL_lex_stuff = Nullsv;
4895 sv_setpv(PL_subname,"__ANON__");
4898 (void) force_word(PL_oldbufptr + tboffset, WORD,
4907 LOP(OP_SYSTEM,XREF);
4910 LOP(OP_SYMLINK,XTERM);
4913 LOP(OP_SYSCALL,XTERM);
4916 LOP(OP_SYSOPEN,XTERM);
4919 LOP(OP_SYSSEEK,XTERM);
4922 LOP(OP_SYSREAD,XTERM);
4925 LOP(OP_SYSWRITE,XTERM);
4929 TERM(sublex_start());
4950 LOP(OP_TRUNCATE,XTERM);
4962 yylval.ival = CopLINE(PL_curcop);
4966 yylval.ival = CopLINE(PL_curcop);
4970 LOP(OP_UNLINK,XTERM);
4976 LOP(OP_UNPACK,XTERM);
4979 LOP(OP_UTIME,XTERM);
4982 if (ckWARN(WARN_UMASK)) {
4983 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4984 if (*d != '0' && isDIGIT(*d))
4985 Perl_warner(aTHX_ WARN_UMASK,
4986 "umask: argument is missing initial 0");
4991 LOP(OP_UNSHIFT,XTERM);
4994 if (PL_expect != XSTATE)
4995 yyerror("\"use\" not allowed in expression");
4997 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4998 s = force_version(s);
4999 if (*s == ';' || (s = skipspace(s), *s == ';')) {
5000 PL_nextval[PL_nexttoke].opval = Nullop;
5005 s = force_word(s,WORD,FALSE,TRUE,FALSE);
5006 s = force_version(s);
5018 yylval.ival = CopLINE(PL_curcop);
5022 PL_hints |= HINT_BLOCK_SCOPE;
5029 LOP(OP_WAITPID,XTERM);
5037 static char ctl_l[2];
5039 if (ctl_l[0] == '\0')
5040 ctl_l[0] = toCTRL('L');
5041 gv_fetchpv(ctl_l,TRUE, SVt_PV);
5044 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
5049 if (PL_expect == XOPERATOR)
5055 yylval.ival = OP_XOR;
5060 TERM(sublex_start());
5065 #pragma segment Main
5069 Perl_keyword(pTHX_ register char *d, I32 len)
5074 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
5075 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
5076 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
5077 if (strEQ(d,"__DATA__")) return KEY___DATA__;
5078 if (strEQ(d,"__END__")) return KEY___END__;
5082 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
5087 if (strEQ(d,"and")) return -KEY_and;
5088 if (strEQ(d,"abs")) return -KEY_abs;
5091 if (strEQ(d,"alarm")) return -KEY_alarm;
5092 if (strEQ(d,"atan2")) return -KEY_atan2;
5095 if (strEQ(d,"accept")) return -KEY_accept;
5100 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
5103 if (strEQ(d,"bless")) return -KEY_bless;
5104 if (strEQ(d,"bind")) return -KEY_bind;
5105 if (strEQ(d,"binmode")) return -KEY_binmode;
5108 if (strEQ(d,"CORE")) return -KEY_CORE;
5109 if (strEQ(d,"CHECK")) return KEY_CHECK;
5114 if (strEQ(d,"cmp")) return -KEY_cmp;
5115 if (strEQ(d,"chr")) return -KEY_chr;
5116 if (strEQ(d,"cos")) return -KEY_cos;
5119 if (strEQ(d,"chop")) return KEY_chop;
5122 if (strEQ(d,"close")) return -KEY_close;
5123 if (strEQ(d,"chdir")) return -KEY_chdir;
5124 if (strEQ(d,"chomp")) return KEY_chomp;
5125 if (strEQ(d,"chmod")) return -KEY_chmod;
5126 if (strEQ(d,"chown")) return -KEY_chown;
5127 if (strEQ(d,"crypt")) return -KEY_crypt;
5130 if (strEQ(d,"chroot")) return -KEY_chroot;
5131 if (strEQ(d,"caller")) return -KEY_caller;
5134 if (strEQ(d,"connect")) return -KEY_connect;
5137 if (strEQ(d,"closedir")) return -KEY_closedir;
5138 if (strEQ(d,"continue")) return -KEY_continue;
5143 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
5148 if (strEQ(d,"do")) return KEY_do;
5151 if (strEQ(d,"die")) return -KEY_die;
5154 if (strEQ(d,"dump")) return -KEY_dump;
5157 if (strEQ(d,"delete")) return KEY_delete;
5160 if (strEQ(d,"defined")) return KEY_defined;
5161 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
5164 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
5169 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
5170 if (strEQ(d,"END")) return KEY_END;
5175 if (strEQ(d,"eq")) return -KEY_eq;
5178 if (strEQ(d,"eof")) return -KEY_eof;
5179 if (strEQ(d,"exp")) return -KEY_exp;
5182 if (strEQ(d,"else")) return KEY_else;
5183 if (strEQ(d,"exit")) return -KEY_exit;
5184 if (strEQ(d,"eval")) return KEY_eval;
5185 if (strEQ(d,"exec")) return -KEY_exec;
5186 if (strEQ(d,"each")) return KEY_each;
5189 if (strEQ(d,"elsif")) return KEY_elsif;
5192 if (strEQ(d,"exists")) return KEY_exists;
5193 if (strEQ(d,"elseif")) Perl_warn(aTHX_ "elseif should be elsif");
5196 if (strEQ(d,"endgrent")) return -KEY_endgrent;
5197 if (strEQ(d,"endpwent")) return -KEY_endpwent;
5200 if (strEQ(d,"endnetent")) return -KEY_endnetent;
5203 if (strEQ(d,"endhostent")) return -KEY_endhostent;
5204 if (strEQ(d,"endservent")) return -KEY_endservent;
5207 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
5214 if (strEQ(d,"for")) return KEY_for;
5217 if (strEQ(d,"fork")) return -KEY_fork;
5220 if (strEQ(d,"fcntl")) return -KEY_fcntl;
5221 if (strEQ(d,"flock")) return -KEY_flock;
5224 if (strEQ(d,"format")) return KEY_format;
5225 if (strEQ(d,"fileno")) return -KEY_fileno;
5228 if (strEQ(d,"foreach")) return KEY_foreach;
5231 if (strEQ(d,"formline")) return -KEY_formline;
5237 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
5238 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
5242 if (strnEQ(d,"get",3)) {
5247 if (strEQ(d,"ppid")) return -KEY_getppid;
5248 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
5251 if (strEQ(d,"pwent")) return -KEY_getpwent;
5252 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
5253 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
5256 if (strEQ(d,"peername")) return -KEY_getpeername;
5257 if (strEQ(d,"protoent")) return -KEY_getprotoent;
5258 if (strEQ(d,"priority")) return -KEY_getpriority;
5261 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
5264 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
5268 else if (*d == 'h') {
5269 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
5270 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
5271 if (strEQ(d,"hostent")) return -KEY_gethostent;
5273 else if (*d == 'n') {
5274 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
5275 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
5276 if (strEQ(d,"netent")) return -KEY_getnetent;
5278 else if (*d == 's') {
5279 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
5280 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
5281 if (strEQ(d,"servent")) return -KEY_getservent;
5282 if (strEQ(d,"sockname")) return -KEY_getsockname;
5283 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
5285 else if (*d == 'g') {
5286 if (strEQ(d,"grent")) return -KEY_getgrent;
5287 if (strEQ(d,"grnam")) return -KEY_getgrnam;
5288 if (strEQ(d,"grgid")) return -KEY_getgrgid;
5290 else if (*d == 'l') {
5291 if (strEQ(d,"login")) return -KEY_getlogin;
5293 else if (strEQ(d,"c")) return -KEY_getc;
5298 if (strEQ(d,"gt")) return -KEY_gt;
5299 if (strEQ(d,"ge")) return -KEY_ge;
5302 if (strEQ(d,"grep")) return KEY_grep;
5303 if (strEQ(d,"goto")) return KEY_goto;
5304 if (strEQ(d,"glob")) return KEY_glob;
5307 if (strEQ(d,"gmtime")) return -KEY_gmtime;
5312 if (strEQ(d,"hex")) return -KEY_hex;
5315 if (strEQ(d,"INIT")) return KEY_INIT;
5320 if (strEQ(d,"if")) return KEY_if;
5323 if (strEQ(d,"int")) return -KEY_int;
5326 if (strEQ(d,"index")) return -KEY_index;
5327 if (strEQ(d,"ioctl")) return -KEY_ioctl;
5332 if (strEQ(d,"join")) return -KEY_join;
5336 if (strEQ(d,"keys")) return KEY_keys;
5337 if (strEQ(d,"kill")) return -KEY_kill;
5342 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
5343 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
5349 if (strEQ(d,"lt")) return -KEY_lt;
5350 if (strEQ(d,"le")) return -KEY_le;
5351 if (strEQ(d,"lc")) return -KEY_lc;
5354 if (strEQ(d,"log")) return -KEY_log;
5357 if (strEQ(d,"last")) return KEY_last;
5358 if (strEQ(d,"link")) return -KEY_link;
5359 if (strEQ(d,"lock")) return -KEY_lock;
5362 if (strEQ(d,"local")) return KEY_local;
5363 if (strEQ(d,"lstat")) return -KEY_lstat;
5366 if (strEQ(d,"length")) return -KEY_length;
5367 if (strEQ(d,"listen")) return -KEY_listen;
5370 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
5373 if (strEQ(d,"localtime")) return -KEY_localtime;
5379 case 1: return KEY_m;
5381 if (strEQ(d,"my")) return KEY_my;
5384 if (strEQ(d,"map")) return KEY_map;
5387 if (strEQ(d,"mkdir")) return -KEY_mkdir;
5390 if (strEQ(d,"msgctl")) return -KEY_msgctl;
5391 if (strEQ(d,"msgget")) return -KEY_msgget;
5392 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
5393 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
5398 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
5401 if (strEQ(d,"next")) return KEY_next;
5402 if (strEQ(d,"ne")) return -KEY_ne;
5403 if (strEQ(d,"not")) return -KEY_not;
5404 if (strEQ(d,"no")) return KEY_no;
5409 if (strEQ(d,"or")) return -KEY_or;
5412 if (strEQ(d,"ord")) return -KEY_ord;
5413 if (strEQ(d,"oct")) return -KEY_oct;
5414 if (strEQ(d,"our")) return KEY_our;
5417 if (strEQ(d,"open")) return -KEY_open;
5420 if (strEQ(d,"opendir")) return -KEY_opendir;
5427 if (strEQ(d,"pop")) return KEY_pop;
5428 if (strEQ(d,"pos")) return KEY_pos;
5431 if (strEQ(d,"push")) return KEY_push;
5432 if (strEQ(d,"pack")) return -KEY_pack;
5433 if (strEQ(d,"pipe")) return -KEY_pipe;
5436 if (strEQ(d,"print")) return KEY_print;
5439 if (strEQ(d,"printf")) return KEY_printf;
5442 if (strEQ(d,"package")) return KEY_package;
5445 if (strEQ(d,"prototype")) return KEY_prototype;
5450 if (strEQ(d,"q")) return KEY_q;
5451 if (strEQ(d,"qr")) return KEY_qr;
5452 if (strEQ(d,"qq")) return KEY_qq;
5453 if (strEQ(d,"qw")) return KEY_qw;
5454 if (strEQ(d,"qx")) return KEY_qx;
5456 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
5461 if (strEQ(d,"ref")) return -KEY_ref;
5464 if (strEQ(d,"read")) return -KEY_read;
5465 if (strEQ(d,"rand")) return -KEY_rand;
5466 if (strEQ(d,"recv")) return -KEY_recv;
5467 if (strEQ(d,"redo")) return KEY_redo;
5470 if (strEQ(d,"rmdir")) return -KEY_rmdir;
5471 if (strEQ(d,"reset")) return -KEY_reset;
5474 if (strEQ(d,"return")) return KEY_return;
5475 if (strEQ(d,"rename")) return -KEY_rename;
5476 if (strEQ(d,"rindex")) return -KEY_rindex;
5479 if (strEQ(d,"require")) return -KEY_require;
5480 if (strEQ(d,"reverse")) return -KEY_reverse;
5481 if (strEQ(d,"readdir")) return -KEY_readdir;
5484 if (strEQ(d,"readlink")) return -KEY_readlink;
5485 if (strEQ(d,"readline")) return -KEY_readline;
5486 if (strEQ(d,"readpipe")) return -KEY_readpipe;
5489 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
5495 case 0: return KEY_s;
5497 if (strEQ(d,"scalar")) return KEY_scalar;
5502 if (strEQ(d,"seek")) return -KEY_seek;
5503 if (strEQ(d,"send")) return -KEY_send;
5506 if (strEQ(d,"semop")) return -KEY_semop;
5509 if (strEQ(d,"select")) return -KEY_select;
5510 if (strEQ(d,"semctl")) return -KEY_semctl;
5511 if (strEQ(d,"semget")) return -KEY_semget;
5514 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
5515 if (strEQ(d,"seekdir")) return -KEY_seekdir;
5518 if (strEQ(d,"setpwent")) return -KEY_setpwent;
5519 if (strEQ(d,"setgrent")) return -KEY_setgrent;
5522 if (strEQ(d,"setnetent")) return -KEY_setnetent;
5525 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
5526 if (strEQ(d,"sethostent")) return -KEY_sethostent;
5527 if (strEQ(d,"setservent")) return -KEY_setservent;
5530 if (strEQ(d,"setpriority")) return -KEY_setpriority;
5531 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
5538 if (strEQ(d,"shift")) return KEY_shift;
5541 if (strEQ(d,"shmctl")) return -KEY_shmctl;
5542 if (strEQ(d,"shmget")) return -KEY_shmget;
5545 if (strEQ(d,"shmread")) return -KEY_shmread;
5548 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
5549 if (strEQ(d,"shutdown")) return -KEY_shutdown;
5554 if (strEQ(d,"sin")) return -KEY_sin;
5557 if (strEQ(d,"sleep")) return -KEY_sleep;
5560 if (strEQ(d,"sort")) return KEY_sort;
5561 if (strEQ(d,"socket")) return -KEY_socket;
5562 if (strEQ(d,"socketpair")) return -KEY_socketpair;
5565 if (strEQ(d,"split")) return KEY_split;
5566 if (strEQ(d,"sprintf")) return -KEY_sprintf;
5567 if (strEQ(d,"splice")) return KEY_splice;
5570 if (strEQ(d,"sqrt")) return -KEY_sqrt;
5573 if (strEQ(d,"srand")) return -KEY_srand;
5576 if (strEQ(d,"stat")) return -KEY_stat;
5577 if (strEQ(d,"study")) return KEY_study;
5580 if (strEQ(d,"substr")) return -KEY_substr;
5581 if (strEQ(d,"sub")) return KEY_sub;
5586 if (strEQ(d,"system")) return -KEY_system;
5589 if (strEQ(d,"symlink")) return -KEY_symlink;
5590 if (strEQ(d,"syscall")) return -KEY_syscall;
5591 if (strEQ(d,"sysopen")) return -KEY_sysopen;
5592 if (strEQ(d,"sysread")) return -KEY_sysread;
5593 if (strEQ(d,"sysseek")) return -KEY_sysseek;
5596 if (strEQ(d,"syswrite")) return -KEY_syswrite;
5605 if (strEQ(d,"tr")) return KEY_tr;
5608 if (strEQ(d,"tie")) return KEY_tie;
5611 if (strEQ(d,"tell")) return -KEY_tell;
5612 if (strEQ(d,"tied")) return KEY_tied;
5613 if (strEQ(d,"time")) return -KEY_time;
5616 if (strEQ(d,"times")) return -KEY_times;
5619 if (strEQ(d,"telldir")) return -KEY_telldir;
5622 if (strEQ(d,"truncate")) return -KEY_truncate;
5629 if (strEQ(d,"uc")) return -KEY_uc;
5632 if (strEQ(d,"use")) return KEY_use;
5635 if (strEQ(d,"undef")) return KEY_undef;
5636 if (strEQ(d,"until")) return KEY_until;
5637 if (strEQ(d,"untie")) return KEY_untie;
5638 if (strEQ(d,"utime")) return -KEY_utime;
5639 if (strEQ(d,"umask")) return -KEY_umask;
5642 if (strEQ(d,"unless")) return KEY_unless;
5643 if (strEQ(d,"unpack")) return -KEY_unpack;
5644 if (strEQ(d,"unlink")) return -KEY_unlink;
5647 if (strEQ(d,"unshift")) return KEY_unshift;
5648 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
5653 if (strEQ(d,"values")) return -KEY_values;
5654 if (strEQ(d,"vec")) return -KEY_vec;
5659 if (strEQ(d,"warn")) return -KEY_warn;
5660 if (strEQ(d,"wait")) return -KEY_wait;
5663 if (strEQ(d,"while")) return KEY_while;
5664 if (strEQ(d,"write")) return -KEY_write;
5667 if (strEQ(d,"waitpid")) return -KEY_waitpid;
5670 if (strEQ(d,"wantarray")) return -KEY_wantarray;
5675 if (len == 1) return -KEY_x;
5676 if (strEQ(d,"xor")) return -KEY_xor;
5679 if (len == 1) return KEY_y;
5688 S_checkcomma(pTHX_ register char *s, char *name, char *what)
5692 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
5693 dTHR; /* only for ckWARN */
5694 if (ckWARN(WARN_SYNTAX)) {
5696 for (w = s+2; *w && level; w++) {
5703 for (; *w && isSPACE(*w); w++) ;
5704 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
5705 Perl_warner(aTHX_ WARN_SYNTAX,
5706 "%s (...) interpreted as function",name);
5709 while (s < PL_bufend && isSPACE(*s))
5713 while (s < PL_bufend && isSPACE(*s))
5715 if (isIDFIRST_lazy_if(s,UTF)) {
5717 while (isALNUM_lazy_if(s,UTF))
5719 while (s < PL_bufend && isSPACE(*s))
5724 kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
5728 Perl_croak(aTHX_ "No comma allowed after %s", what);
5733 /* Either returns sv, or mortalizes sv and returns a new SV*.
5734 Best used as sv=new_constant(..., sv, ...).
5735 If s, pv are NULL, calls subroutine with one argument,
5736 and type is used with error messages only. */
5739 S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv,
5743 HV *table = GvHV(PL_hintgv); /* ^H */
5747 const char *why1, *why2, *why3;
5749 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
5752 why1 = "%^H is not consistent";
5753 why2 = strEQ(key,"charnames")
5754 ? " (missing \"use charnames ...\"?)"
5758 msg = Perl_newSVpvf(aTHX_ "constant(%s): %s%s%s",
5759 (type ? type: "undef"), why1, why2, why3);
5760 yyerror(SvPVX(msg));
5764 cvp = hv_fetch(table, key, strlen(key), FALSE);
5765 if (!cvp || !SvOK(*cvp)) {
5768 why3 = "} is not defined";
5771 sv_2mortal(sv); /* Parent created it permanently */
5774 pv = sv_2mortal(newSVpvn(s, len));
5776 typesv = sv_2mortal(newSVpv(type, 0));
5778 typesv = &PL_sv_undef;
5780 PUSHSTACKi(PERLSI_OVERLOAD);
5793 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
5797 /* Check the eval first */
5798 if (!PL_in_eval && SvTRUE(ERRSV)) {
5800 sv_catpv(ERRSV, "Propagated");
5801 yyerror(SvPV(ERRSV, n_a)); /* Duplicates the message inside eval */
5803 res = SvREFCNT_inc(sv);
5807 (void)SvREFCNT_inc(res);
5816 why1 = "Call to &{$^H{";
5818 why3 = "}} did not return a defined value";
5827 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
5829 register char *d = dest;
5830 register char *e = d + destlen - 3; /* two-character token, ending NUL */
5833 Perl_croak(aTHX_ ident_too_long);
5834 if (isALNUM(*s)) /* UTF handled below */
5836 else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) {
5841 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
5845 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5846 char *t = s + UTF8SKIP(s);
5847 while (*t & 0x80 && is_utf8_mark((U8*)t))
5849 if (d + (t - s) > e)
5850 Perl_croak(aTHX_ ident_too_long);
5851 Copy(s, d, t - s, char);
5864 S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
5874 e = d + destlen - 3; /* two-character token, ending NUL */
5876 while (isDIGIT(*s)) {
5878 Perl_croak(aTHX_ ident_too_long);
5885 Perl_croak(aTHX_ ident_too_long);
5886 if (isALNUM(*s)) /* UTF handled below */
5888 else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
5893 else if (*s == ':' && s[1] == ':') {
5897 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5898 char *t = s + UTF8SKIP(s);
5899 while (*t & 0x80 && is_utf8_mark((U8*)t))
5901 if (d + (t - s) > e)
5902 Perl_croak(aTHX_ ident_too_long);
5903 Copy(s, d, t - s, char);
5914 if (PL_lex_state != LEX_NORMAL)
5915 PL_lex_state = LEX_INTERPENDMAYBE;
5918 if (*s == '$' && s[1] &&
5919 (isALNUM_lazy_if(s+1,UTF) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
5932 if (*d == '^' && *s && isCONTROLVAR(*s)) {
5937 if (isSPACE(s[-1])) {
5940 if (!SPACE_OR_TAB(ch)) {
5946 if (isIDFIRST_lazy_if(d,UTF)) {
5950 while ((e < send && isALNUM_lazy_if(e,UTF)) || *e == ':') {
5952 while (e < send && *e & 0x80 && is_utf8_mark((U8*)e))
5955 Copy(s, d, e - s, char);
5960 while ((isALNUM(*s) || *s == ':') && d < e)
5963 Perl_croak(aTHX_ ident_too_long);
5966 while (s < send && SPACE_OR_TAB(*s)) s++;
5967 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
5968 dTHR; /* only for ckWARN */
5969 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
5970 const char *brack = *s == '[' ? "[...]" : "{...}";
5971 Perl_warner(aTHX_ WARN_AMBIGUOUS,
5972 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
5973 funny, dest, brack, funny, dest, brack);
5976 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
5980 /* Handle extended ${^Foo} variables
5981 * 1999-02-27 mjd-perl-patch@plover.com */
5982 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
5986 while (isALNUM(*s) && d < e) {
5990 Perl_croak(aTHX_ ident_too_long);
5995 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
5996 PL_lex_state = LEX_INTERPEND;
5999 if (PL_lex_state == LEX_NORMAL) {
6000 dTHR; /* only for ckWARN */
6001 if (ckWARN(WARN_AMBIGUOUS) &&
6002 (keyword(dest, d - dest) || get_cv(dest, FALSE)))
6004 Perl_warner(aTHX_ WARN_AMBIGUOUS,
6005 "Ambiguous use of %c{%s} resolved to %c%s",
6006 funny, dest, funny, dest);
6011 s = bracket; /* let the parser handle it */
6015 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
6016 PL_lex_state = LEX_INTERPEND;
6021 Perl_pmflag(pTHX_ U16 *pmfl, int ch)
6026 *pmfl |= PMf_GLOBAL;
6028 *pmfl |= PMf_CONTINUE;
6032 *pmfl |= PMf_MULTILINE;
6034 *pmfl |= PMf_SINGLELINE;
6036 *pmfl |= PMf_EXTENDED;
6040 S_scan_pat(pTHX_ char *start, I32 type)
6045 s = scan_str(start,FALSE,FALSE);
6048 SvREFCNT_dec(PL_lex_stuff);
6049 PL_lex_stuff = Nullsv;
6050 Perl_croak(aTHX_ "Search pattern not terminated");
6053 pm = (PMOP*)newPMOP(type, 0);
6054 if (PL_multi_open == '?')
6055 pm->op_pmflags |= PMf_ONCE;
6057 while (*s && strchr("iomsx", *s))
6058 pmflag(&pm->op_pmflags,*s++);
6061 while (*s && strchr("iogcmsx", *s))
6062 pmflag(&pm->op_pmflags,*s++);
6064 pm->op_pmpermflags = pm->op_pmflags;
6066 PL_lex_op = (OP*)pm;
6067 yylval.ival = OP_MATCH;
6072 S_scan_subst(pTHX_ char *start)
6079 yylval.ival = OP_NULL;
6081 s = scan_str(start,FALSE,FALSE);
6085 SvREFCNT_dec(PL_lex_stuff);
6086 PL_lex_stuff = Nullsv;
6087 Perl_croak(aTHX_ "Substitution pattern not terminated");
6090 if (s[-1] == PL_multi_open)
6093 first_start = PL_multi_start;
6094 s = scan_str(s,FALSE,FALSE);
6097 SvREFCNT_dec(PL_lex_stuff);
6098 PL_lex_stuff = Nullsv;
6100 SvREFCNT_dec(PL_lex_repl);
6101 PL_lex_repl = Nullsv;
6102 Perl_croak(aTHX_ "Substitution replacement not terminated");
6104 PL_multi_start = first_start; /* so whole substitution is taken together */
6106 pm = (PMOP*)newPMOP(OP_SUBST, 0);
6112 else if (strchr("iogcmsx", *s))
6113 pmflag(&pm->op_pmflags,*s++);
6120 PL_sublex_info.super_bufptr = s;
6121 PL_sublex_info.super_bufend = PL_bufend;
6123 pm->op_pmflags |= PMf_EVAL;
6124 repl = newSVpvn("",0);
6126 sv_catpv(repl, es ? "eval " : "do ");
6127 sv_catpvn(repl, "{ ", 2);
6128 sv_catsv(repl, PL_lex_repl);
6129 sv_catpvn(repl, " };", 2);
6131 SvREFCNT_dec(PL_lex_repl);
6135 pm->op_pmpermflags = pm->op_pmflags;
6136 PL_lex_op = (OP*)pm;
6137 yylval.ival = OP_SUBST;
6142 S_scan_trans(pTHX_ char *start)
6153 yylval.ival = OP_NULL;
6155 s = scan_str(start,FALSE,FALSE);
6158 SvREFCNT_dec(PL_lex_stuff);
6159 PL_lex_stuff = Nullsv;
6160 Perl_croak(aTHX_ "Transliteration pattern not terminated");
6162 if (s[-1] == PL_multi_open)
6165 s = scan_str(s,FALSE,FALSE);
6168 SvREFCNT_dec(PL_lex_stuff);
6169 PL_lex_stuff = Nullsv;
6171 SvREFCNT_dec(PL_lex_repl);
6172 PL_lex_repl = Nullsv;
6173 Perl_croak(aTHX_ "Transliteration replacement not terminated");
6176 New(803,tbl,256,short);
6177 o = newPVOP(OP_TRANS, 0, (char*)tbl);
6179 complement = del = squash = 0;
6180 while (strchr("cds", *s)) {
6182 complement = OPpTRANS_COMPLEMENT;
6184 del = OPpTRANS_DELETE;
6186 squash = OPpTRANS_SQUASH;
6189 o->op_private = del|squash|complement;
6192 yylval.ival = OP_TRANS;
6197 S_scan_heredoc(pTHX_ register char *s)
6201 I32 op_type = OP_SCALAR;
6208 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
6212 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
6215 for (peek = s; SPACE_OR_TAB(*peek); peek++) ;
6216 if (*peek && strchr("`'\"",*peek)) {
6219 s = delimcpy(d, e, s, PL_bufend, term, &len);
6229 if (!isALNUM_lazy_if(s,UTF))
6230 deprecate("bare << to mean <<\"\"");
6231 for (; isALNUM_lazy_if(s,UTF); s++) {
6236 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
6237 Perl_croak(aTHX_ "Delimiter for here document is too long");
6240 len = d - PL_tokenbuf;
6241 #ifndef PERL_STRICT_CR
6242 d = strchr(s, '\r');
6246 while (s < PL_bufend) {
6252 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
6261 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6266 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
6267 herewas = newSVpvn(s,PL_bufend-s);
6269 s--, herewas = newSVpvn(s,d-s);
6270 s += SvCUR(herewas);
6272 tmpstr = NEWSV(87,79);
6273 sv_upgrade(tmpstr, SVt_PVIV);
6278 else if (term == '`') {
6279 op_type = OP_BACKTICK;
6280 SvIVX(tmpstr) = '\\';
6284 PL_multi_start = CopLINE(PL_curcop);
6285 PL_multi_open = PL_multi_close = '<';
6286 term = *PL_tokenbuf;
6287 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
6288 char *bufptr = PL_sublex_info.super_bufptr;
6289 char *bufend = PL_sublex_info.super_bufend;
6290 char *olds = s - SvCUR(herewas);
6291 s = strchr(bufptr, '\n');
6295 while (s < bufend &&
6296 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6298 CopLINE_inc(PL_curcop);
6301 CopLINE_set(PL_curcop, PL_multi_start);
6302 missingterm(PL_tokenbuf);
6304 sv_setpvn(herewas,bufptr,d-bufptr+1);
6305 sv_setpvn(tmpstr,d+1,s-d);
6307 sv_catpvn(herewas,s,bufend-s);
6308 (void)strcpy(bufptr,SvPVX(herewas));
6315 while (s < PL_bufend &&
6316 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6318 CopLINE_inc(PL_curcop);
6320 if (s >= PL_bufend) {
6321 CopLINE_set(PL_curcop, PL_multi_start);
6322 missingterm(PL_tokenbuf);
6324 sv_setpvn(tmpstr,d+1,s-d);
6326 CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
6328 sv_catpvn(herewas,s,PL_bufend-s);
6329 sv_setsv(PL_linestr,herewas);
6330 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
6331 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6334 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
6335 while (s >= PL_bufend) { /* multiple line string? */
6337 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6338 CopLINE_set(PL_curcop, PL_multi_start);
6339 missingterm(PL_tokenbuf);
6341 CopLINE_inc(PL_curcop);
6342 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6343 #ifndef PERL_STRICT_CR
6344 if (PL_bufend - PL_linestart >= 2) {
6345 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
6346 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
6348 PL_bufend[-2] = '\n';
6350 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6352 else if (PL_bufend[-1] == '\r')
6353 PL_bufend[-1] = '\n';
6355 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
6356 PL_bufend[-1] = '\n';
6358 if (PERLDB_LINE && PL_curstash != PL_debstash) {
6359 SV *sv = NEWSV(88,0);
6361 sv_upgrade(sv, SVt_PVMG);
6362 sv_setsv(sv,PL_linestr);
6363 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop),sv);
6365 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
6368 sv_catsv(PL_linestr,herewas);
6369 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6373 sv_catsv(tmpstr,PL_linestr);
6378 PL_multi_end = CopLINE(PL_curcop);
6379 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
6380 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
6381 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
6383 SvREFCNT_dec(herewas);
6384 PL_lex_stuff = tmpstr;
6385 yylval.ival = op_type;
6390 takes: current position in input buffer
6391 returns: new position in input buffer
6392 side-effects: yylval and lex_op are set.
6397 <FH> read from filehandle
6398 <pkg::FH> read from package qualified filehandle
6399 <pkg'FH> read from package qualified filehandle
6400 <$fh> read from filehandle in $fh
6406 S_scan_inputsymbol(pTHX_ char *start)
6408 register char *s = start; /* current position in buffer */
6414 d = PL_tokenbuf; /* start of temp holding space */
6415 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
6416 end = strchr(s, '\n');
6419 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
6421 /* die if we didn't have space for the contents of the <>,
6422 or if it didn't end, or if we see a newline
6425 if (len >= sizeof PL_tokenbuf)
6426 Perl_croak(aTHX_ "Excessively long <> operator");
6428 Perl_croak(aTHX_ "Unterminated <> operator");
6433 Remember, only scalar variables are interpreted as filehandles by
6434 this code. Anything more complex (e.g., <$fh{$num}>) will be
6435 treated as a glob() call.
6436 This code makes use of the fact that except for the $ at the front,
6437 a scalar variable and a filehandle look the same.
6439 if (*d == '$' && d[1]) d++;
6441 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
6442 while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
6445 /* If we've tried to read what we allow filehandles to look like, and
6446 there's still text left, then it must be a glob() and not a getline.
6447 Use scan_str to pull out the stuff between the <> and treat it
6448 as nothing more than a string.
6451 if (d - PL_tokenbuf != len) {
6452 yylval.ival = OP_GLOB;
6454 s = scan_str(start,FALSE,FALSE);
6456 Perl_croak(aTHX_ "Glob not terminated");
6460 /* we're in a filehandle read situation */
6463 /* turn <> into <ARGV> */
6465 (void)strcpy(d,"ARGV");
6467 /* if <$fh>, create the ops to turn the variable into a
6473 /* try to find it in the pad for this block, otherwise find
6474 add symbol table ops
6476 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
6477 OP *o = newOP(OP_PADSV, 0);
6479 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, o);
6482 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
6483 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
6484 newUNOP(OP_RV2SV, 0,
6485 newGVOP(OP_GV, 0, gv)));
6487 PL_lex_op->op_flags |= OPf_SPECIAL;
6488 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
6489 yylval.ival = OP_NULL;
6492 /* If it's none of the above, it must be a literal filehandle
6493 (<Foo::BAR> or <FOO>) so build a simple readline OP */
6495 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
6496 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
6497 yylval.ival = OP_NULL;
6506 takes: start position in buffer
6507 keep_quoted preserve \ on the embedded delimiter(s)
6508 keep_delims preserve the delimiters around the string
6509 returns: position to continue reading from buffer
6510 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
6511 updates the read buffer.
6513 This subroutine pulls a string out of the input. It is called for:
6514 q single quotes q(literal text)
6515 ' single quotes 'literal text'
6516 qq double quotes qq(interpolate $here please)
6517 " double quotes "interpolate $here please"
6518 qx backticks qx(/bin/ls -l)
6519 ` backticks `/bin/ls -l`
6520 qw quote words @EXPORT_OK = qw( func() $spam )
6521 m// regexp match m/this/
6522 s/// regexp substitute s/this/that/
6523 tr/// string transliterate tr/this/that/
6524 y/// string transliterate y/this/that/
6525 ($*@) sub prototypes sub foo ($)
6526 (stuff) sub attr parameters sub foo : attr(stuff)
6527 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
6529 In most of these cases (all but <>, patterns and transliterate)
6530 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
6531 calls scan_str(). s/// makes yylex() call scan_subst() which calls
6532 scan_str(). tr/// and y/// make yylex() call scan_trans() which
6535 It skips whitespace before the string starts, and treats the first
6536 character as the delimiter. If the delimiter is one of ([{< then
6537 the corresponding "close" character )]}> is used as the closing
6538 delimiter. It allows quoting of delimiters, and if the string has
6539 balanced delimiters ([{<>}]) it allows nesting.
6541 The lexer always reads these strings into lex_stuff, except in the
6542 case of the operators which take *two* arguments (s/// and tr///)
6543 when it checks to see if lex_stuff is full (presumably with the 1st
6544 arg to s or tr) and if so puts the string into lex_repl.
6549 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
6552 SV *sv; /* scalar value: string */
6553 char *tmps; /* temp string, used for delimiter matching */
6554 register char *s = start; /* current position in the buffer */
6555 register char term; /* terminating character */
6556 register char *to; /* current position in the sv's data */
6557 I32 brackets = 1; /* bracket nesting level */
6558 bool has_utf = FALSE; /* is there any utf8 content? */
6560 /* skip space before the delimiter */
6564 /* mark where we are, in case we need to report errors */
6567 /* after skipping whitespace, the next character is the terminator */
6569 if ((term & 0x80) && UTF)
6572 /* mark where we are */
6573 PL_multi_start = CopLINE(PL_curcop);
6574 PL_multi_open = term;
6576 /* find corresponding closing delimiter */
6577 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
6579 PL_multi_close = term;
6581 /* create a new SV to hold the contents. 87 is leak category, I'm
6582 assuming. 79 is the SV's initial length. What a random number. */
6584 sv_upgrade(sv, SVt_PVIV);
6586 (void)SvPOK_only(sv); /* validate pointer */
6588 /* move past delimiter and try to read a complete string */
6590 sv_catpvn(sv, s, 1);
6593 /* extend sv if need be */
6594 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
6595 /* set 'to' to the next character in the sv's string */
6596 to = SvPVX(sv)+SvCUR(sv);
6598 /* if open delimiter is the close delimiter read unbridle */
6599 if (PL_multi_open == PL_multi_close) {
6600 for (; s < PL_bufend; s++,to++) {
6601 /* embedded newlines increment the current line number */
6602 if (*s == '\n' && !PL_rsfp)
6603 CopLINE_inc(PL_curcop);
6604 /* handle quoted delimiters */
6605 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
6606 if (!keep_quoted && s[1] == term)
6608 /* any other quotes are simply copied straight through */
6612 /* terminate when run out of buffer (the for() condition), or
6613 have found the terminator */
6614 else if (*s == term)
6616 else if (!has_utf && (*s & 0x80) && UTF)
6622 /* if the terminator isn't the same as the start character (e.g.,
6623 matched brackets), we have to allow more in the quoting, and
6624 be prepared for nested brackets.
6627 /* read until we run out of string, or we find the terminator */
6628 for (; s < PL_bufend; s++,to++) {
6629 /* embedded newlines increment the line count */
6630 if (*s == '\n' && !PL_rsfp)
6631 CopLINE_inc(PL_curcop);
6632 /* backslashes can escape the open or closing characters */
6633 if (*s == '\\' && s+1 < PL_bufend) {
6635 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
6640 /* allow nested opens and closes */
6641 else if (*s == PL_multi_close && --brackets <= 0)
6643 else if (*s == PL_multi_open)
6645 else if (!has_utf && (*s & 0x80) && UTF)
6650 /* terminate the copied string and update the sv's end-of-string */
6652 SvCUR_set(sv, to - SvPVX(sv));
6655 * this next chunk reads more into the buffer if we're not done yet
6659 break; /* handle case where we are done yet :-) */
6661 #ifndef PERL_STRICT_CR
6662 if (to - SvPVX(sv) >= 2) {
6663 if ((to[-2] == '\r' && to[-1] == '\n') ||
6664 (to[-2] == '\n' && to[-1] == '\r'))
6668 SvCUR_set(sv, to - SvPVX(sv));
6670 else if (to[-1] == '\r')
6673 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
6677 /* if we're out of file, or a read fails, bail and reset the current
6678 line marker so we can report where the unterminated string began
6681 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6683 CopLINE_set(PL_curcop, PL_multi_start);
6686 /* we read a line, so increment our line counter */
6687 CopLINE_inc(PL_curcop);
6689 /* update debugger info */
6690 if (PERLDB_LINE && PL_curstash != PL_debstash) {
6691 SV *sv = NEWSV(88,0);
6693 sv_upgrade(sv, SVt_PVMG);
6694 sv_setsv(sv,PL_linestr);
6695 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop), sv);
6698 /* having changed the buffer, we must update PL_bufend */
6699 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6702 /* at this point, we have successfully read the delimited string */
6705 sv_catpvn(sv, s, 1);
6708 PL_multi_end = CopLINE(PL_curcop);
6711 /* if we allocated too much space, give some back */
6712 if (SvCUR(sv) + 5 < SvLEN(sv)) {
6713 SvLEN_set(sv, SvCUR(sv) + 1);
6714 Renew(SvPVX(sv), SvLEN(sv), char);
6717 /* decide whether this is the first or second quoted string we've read
6730 takes: pointer to position in buffer
6731 returns: pointer to new position in buffer
6732 side-effects: builds ops for the constant in yylval.op
6734 Read a number in any of the formats that Perl accepts:
6736 0(x[0-7A-F]+)|([0-7]+)|(b[01])
6737 [\d_]+(\.[\d_]*)?[Ee](\d+)
6739 Underbars (_) are allowed in decimal numbers. If -w is on,
6740 underbars before a decimal point must be at three digit intervals.
6742 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
6745 If it reads a number without a decimal point or an exponent, it will
6746 try converting the number to an integer and see if it can do so
6747 without loss of precision.
6751 Perl_scan_num(pTHX_ char *start)
6753 register char *s = start; /* current position in buffer */
6754 register char *d; /* destination in temp buffer */
6755 register char *e; /* end of temp buffer */
6756 NV nv; /* number read, as a double */
6757 SV *sv = Nullsv; /* place to put the converted number */
6758 bool floatit; /* boolean: int or float? */
6759 char *lastub = 0; /* position of last underbar */
6760 static char number_too_long[] = "Number too long";
6762 /* We use the first character to decide what type of number this is */
6766 Perl_croak(aTHX_ "panic: scan_num");
6768 /* if it starts with a 0, it could be an octal number, a decimal in
6769 0.13 disguise, or a hexadecimal number, or a binary number. */
6773 u holds the "number so far"
6774 shift the power of 2 of the base
6775 (hex == 4, octal == 3, binary == 1)
6776 overflowed was the number more than we can hold?
6778 Shift is used when we add a digit. It also serves as an "are
6779 we in octal/hex/binary?" indicator to disallow hex characters
6786 bool overflowed = FALSE;
6787 static NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
6788 static char* bases[5] = { "", "binary", "", "octal",
6790 static char* Bases[5] = { "", "Binary", "", "Octal",
6792 static char *maxima[5] = { "",
6793 "0b11111111111111111111111111111111",
6797 char *base, *Base, *max;
6803 } else if (s[1] == 'b') {
6807 /* check for a decimal in disguise */
6808 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
6810 /* so it must be octal */
6814 base = bases[shift];
6815 Base = Bases[shift];
6816 max = maxima[shift];
6818 /* read the rest of the number */
6820 /* x is used in the overflow test,
6821 b is the digit we're adding on. */
6826 /* if we don't mention it, we're done */
6835 /* 8 and 9 are not octal */
6838 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
6842 case '2': case '3': case '4':
6843 case '5': case '6': case '7':
6845 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
6849 b = *s++ & 15; /* ASCII digit -> value of digit */
6853 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
6854 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
6855 /* make sure they said 0x */
6860 /* Prepare to put the digit we have onto the end
6861 of the number so far. We check for overflows.
6866 x = u << shift; /* make room for the digit */
6868 if ((x >> shift) != u
6869 && !(PL_hints & HINT_NEW_BINARY)) {
6873 if (ckWARN_d(WARN_OVERFLOW))
6874 Perl_warner(aTHX_ WARN_OVERFLOW,
6875 "Integer overflow in %s number",
6878 u = x | b; /* add the digit to the end */
6881 n *= nvshift[shift];
6882 /* If an NV has not enough bits in its
6883 * mantissa to represent an UV this summing of
6884 * small low-order numbers is a waste of time
6885 * (because the NV cannot preserve the
6886 * low-order bits anyway): we could just
6887 * remember when did we overflow and in the
6888 * end just multiply n by the right
6896 /* if we get here, we had success: make a scalar value from
6903 if (ckWARN(WARN_PORTABLE) && n > 4294967295.0)
6904 Perl_warner(aTHX_ WARN_PORTABLE,
6905 "%s number > %s non-portable",
6912 if (ckWARN(WARN_PORTABLE) && u > 0xffffffff)
6913 Perl_warner(aTHX_ WARN_PORTABLE,
6914 "%s number > %s non-portable",
6919 if (PL_hints & HINT_NEW_BINARY)
6920 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
6925 handle decimal numbers.
6926 we're also sent here when we read a 0 as the first digit
6928 case '1': case '2': case '3': case '4': case '5':
6929 case '6': case '7': case '8': case '9': case '.':
6932 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
6935 /* read next group of digits and _ and copy into d */
6936 while (isDIGIT(*s) || *s == '_') {
6937 /* skip underscores, checking for misplaced ones
6941 dTHR; /* only for ckWARN */
6942 if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
6943 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
6947 /* check for end of fixed-length buffer */
6949 Perl_croak(aTHX_ number_too_long);
6950 /* if we're ok, copy the character */
6955 /* final misplaced underbar check */
6956 if (lastub && s - lastub != 3) {
6958 if (ckWARN(WARN_SYNTAX))
6959 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
6962 /* read a decimal portion if there is one. avoid
6963 3..5 being interpreted as the number 3. followed
6966 if (*s == '.' && s[1] != '.') {
6970 /* copy, ignoring underbars, until we run out of
6971 digits. Note: no misplaced underbar checks!
6973 for (; isDIGIT(*s) || *s == '_'; s++) {
6974 /* fixed length buffer check */
6976 Perl_croak(aTHX_ number_too_long);
6980 if (*s == '.' && isDIGIT(s[1])) {
6981 /* oops, it's really a v-string, but without the "v" */
6987 /* read exponent part, if present */
6988 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
6992 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
6993 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
6995 /* allow positive or negative exponent */
6996 if (*s == '+' || *s == '-')
6999 /* read digits of exponent (no underbars :-) */
7000 while (isDIGIT(*s)) {
7002 Perl_croak(aTHX_ number_too_long);
7007 /* terminate the string */
7010 /* make an sv from the string */
7013 #if defined(Strtol) && defined(Strtoul)
7016 strtol/strtoll sets errno to ERANGE if the number is too big
7017 for an integer. We try to do an integer conversion first
7018 if no characters indicating "float" have been found.
7025 if (*PL_tokenbuf == '-')
7026 iv = Strtol(PL_tokenbuf, (char**)NULL, 10);
7028 uv = Strtoul(PL_tokenbuf, (char**)NULL, 10);
7030 floatit = TRUE; /* Probably just too large. */
7031 else if (*PL_tokenbuf == '-')
7033 else if (uv <= IV_MAX)
7034 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
7039 nv = Atof(PL_tokenbuf);
7044 No working strtou?ll?.
7046 Unfortunately atol() doesn't do range checks (returning
7047 LONG_MIN/LONG_MAX, and setting errno to ERANGE on overflows)
7048 everywhere [1], so we cannot use use atol() (or atoll()).
7049 If we could, they would be used, as Atol(), very much like
7050 Strtol() and Strtoul() are used above.
7052 [1] XXX Configure test needed to check for atol()
7053 (and atoll()) overflow behaviour XXX
7057 We need to do this the hard way. */
7059 nv = Atof(PL_tokenbuf);
7061 /* See if we can make do with an integer value without loss of
7062 precision. We use U_V to cast to a UV, because some
7063 compilers have issues. Then we try casting it back and see
7064 if it was the same [1]. We only do this if we know we
7065 specifically read an integer. If floatit is true, then we
7066 don't need to do the conversion at all.
7068 [1] Note that this is lossy if our NVs cannot preserve our
7069 UVs. There are metaconfig defines NV_PRESERVES_UV (a boolean)
7070 and NV_PRESERVES_UV_BITS (a number), but in general we really
7071 do hope all such potentially lossy platforms have strtou?ll?
7072 to do a lossless IV/UV conversion.
7074 Maybe could do some tricks with DBL_DIG, LDBL_DIG and
7075 DBL_MANT_DIG and LDBL_MANT_DIG (these are already available
7076 as NV_DIG and NV_MANT_DIG)?
7082 if (!floatit && (NV)uv == nv) {
7084 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
7092 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
7093 (PL_hints & HINT_NEW_INTEGER) )
7094 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
7095 (floatit ? "float" : "integer"),
7099 /* if it starts with a v, it could be a v-string */
7105 while (isDIGIT(*pos) || *pos == '_')
7107 if (!isALPHA(*pos)) {
7109 U8 tmpbuf[UTF8_MAXLEN];
7112 s++; /* get past 'v' */
7115 sv_setpvn(sv, "", 0);
7118 if (*s == '0' && isDIGIT(s[1]))
7119 yyerror("Octal number in vector unsupported");
7122 /* this is atoi() that tolerates underscores */
7125 while (--end >= s) {
7130 rev += (*end - '0') * mult;
7132 if (orev > rev && ckWARN_d(WARN_OVERFLOW))
7133 Perl_warner(aTHX_ WARN_OVERFLOW,
7134 "Integer overflow in decimal number");
7137 tmpend = uv_to_utf8(tmpbuf, rev);
7138 utf8 = utf8 || rev > 127;
7139 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
7140 if (*pos == '.' && isDIGIT(pos[1]))
7146 while (isDIGIT(*pos) || *pos == '_')
7154 sv_utf8_downgrade(sv, TRUE);
7161 /* make the op for the constant and return */
7164 yylval.opval = newSVOP(OP_CONST, 0, sv);
7166 yylval.opval = Nullop;
7172 S_scan_formline(pTHX_ register char *s)
7177 SV *stuff = newSVpvn("",0);
7178 bool needargs = FALSE;
7181 if (*s == '.' || *s == /*{*/'}') {
7183 #ifdef PERL_STRICT_CR
7184 for (t = s+1;SPACE_OR_TAB(*t); t++) ;
7186 for (t = s+1;SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
7188 if (*t == '\n' || t == PL_bufend)
7191 if (PL_in_eval && !PL_rsfp) {
7192 eol = strchr(s,'\n');
7197 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7199 for (t = s; t < eol; t++) {
7200 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
7202 goto enough; /* ~~ must be first line in formline */
7204 if (*t == '@' || *t == '^')
7207 sv_catpvn(stuff, s, eol-s);
7208 #ifndef PERL_STRICT_CR
7209 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
7210 char *end = SvPVX(stuff) + SvCUR(stuff);
7219 s = filter_gets(PL_linestr, PL_rsfp, 0);
7220 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
7221 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
7224 yyerror("Format not terminated");
7234 PL_lex_state = LEX_NORMAL;
7235 PL_nextval[PL_nexttoke].ival = 0;
7239 PL_lex_state = LEX_FORMLINE;
7240 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
7242 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
7246 SvREFCNT_dec(stuff);
7247 PL_lex_formbrack = 0;
7258 PL_cshlen = strlen(PL_cshname);
7263 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
7266 I32 oldsavestack_ix = PL_savestack_ix;
7267 CV* outsidecv = PL_compcv;
7271 assert(SvTYPE(PL_compcv) == SVt_PVCV);
7273 SAVEI32(PL_subline);
7274 save_item(PL_subname);
7277 SAVESPTR(PL_comppad_name);
7278 SAVESPTR(PL_compcv);
7279 SAVEI32(PL_comppad_name_fill);
7280 SAVEI32(PL_min_intro_pending);
7281 SAVEI32(PL_max_intro_pending);
7282 SAVEI32(PL_pad_reset_pending);
7284 PL_compcv = (CV*)NEWSV(1104,0);
7285 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
7286 CvFLAGS(PL_compcv) |= flags;
7288 PL_comppad = newAV();
7289 av_push(PL_comppad, Nullsv);
7290 PL_curpad = AvARRAY(PL_comppad);
7291 PL_comppad_name = newAV();
7292 PL_comppad_name_fill = 0;
7293 PL_min_intro_pending = 0;
7295 PL_subline = CopLINE(PL_curcop);
7297 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
7298 PL_curpad[0] = (SV*)newAV();
7299 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
7300 #endif /* USE_THREADS */
7302 comppadlist = newAV();
7303 AvREAL_off(comppadlist);
7304 av_store(comppadlist, 0, (SV*)PL_comppad_name);
7305 av_store(comppadlist, 1, (SV*)PL_comppad);
7307 CvPADLIST(PL_compcv) = comppadlist;
7308 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
7310 CvOWNER(PL_compcv) = 0;
7311 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
7312 MUTEX_INIT(CvMUTEXP(PL_compcv));
7313 #endif /* USE_THREADS */
7315 return oldsavestack_ix;
7319 Perl_yywarn(pTHX_ char *s)
7322 PL_in_eval |= EVAL_WARNONLY;
7324 PL_in_eval &= ~EVAL_WARNONLY;
7329 Perl_yyerror(pTHX_ char *s)
7333 char *context = NULL;
7337 if (!yychar || (yychar == ';' && !PL_rsfp))
7339 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
7340 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
7341 while (isSPACE(*PL_oldoldbufptr))
7343 context = PL_oldoldbufptr;
7344 contlen = PL_bufptr - PL_oldoldbufptr;
7346 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
7347 PL_oldbufptr != PL_bufptr) {
7348 while (isSPACE(*PL_oldbufptr))
7350 context = PL_oldbufptr;
7351 contlen = PL_bufptr - PL_oldbufptr;
7353 else if (yychar > 255)
7354 where = "next token ???";
7355 #ifdef USE_PURE_BISON
7356 /* GNU Bison sets the value -2 */
7357 else if (yychar == -2) {
7359 else if ((yychar & 127) == 127) {
7361 if (PL_lex_state == LEX_NORMAL ||
7362 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
7363 where = "at end of line";
7364 else if (PL_lex_inpat)
7365 where = "within pattern";
7367 where = "within string";
7370 SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
7372 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
7373 else if (isPRINT_LC(yychar))
7374 Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
7376 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
7377 where = SvPVX(where_sv);
7379 msg = sv_2mortal(newSVpv(s, 0));
7380 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
7381 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
7383 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
7385 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
7386 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
7387 Perl_sv_catpvf(aTHX_ msg,
7388 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
7389 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
7392 if (PL_in_eval & EVAL_WARNONLY)
7393 Perl_warn(aTHX_ "%"SVf, msg);
7396 if (PL_error_count >= 10) {
7397 if (PL_in_eval && SvCUR(ERRSV))
7398 Perl_croak(aTHX_ "%_%s has too many errors.\n",
7399 ERRSV, CopFILE(PL_curcop));
7401 Perl_croak(aTHX_ "%s has too many errors.\n",
7402 CopFILE(PL_curcop));
7405 PL_in_my_stash = Nullhv;
7410 S_swallow_bom(pTHX_ U8 *s)
7413 slen = SvCUR(PL_linestr);
7417 /* UTF-16 little-endian */
7418 #ifndef PERL_NO_UTF16_FILTER
7421 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
7422 Perl_croak(aTHX_ "Unsupported script encoding");
7423 #ifndef PERL_NO_UTF16_FILTER
7425 filter_add(S_utf16rev_textfilter, NULL);
7426 New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
7427 PL_bufend = (char*)utf16_to_utf8((U16*)s, news,
7428 PL_bufend - (char*)s);
7431 Perl_croak(aTHX_ "Unsupported script encoding");
7436 if (s[1] == 0xFF) { /* UTF-16 big-endian */
7437 #ifndef PERL_NO_UTF16_FILTER
7439 filter_add(S_utf16_textfilter, NULL);
7440 New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
7441 PL_bufend = (char*)utf16_to_utf8((U16*)s, news,
7442 PL_bufend - (char*)s);
7445 Perl_croak(aTHX_ "Unsupported script encoding");
7450 if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
7455 if (slen > 3 && s[1] == 0 && /* UTF-32 big-endian */
7456 s[2] == 0xFE && s[3] == 0xFF)
7458 Perl_croak(aTHX_ "Unsupported script encoding");
7470 * Restore a source filter.
7474 restore_rsfp(pTHXo_ void *f)
7476 PerlIO *fp = (PerlIO*)f;
7478 if (PL_rsfp == PerlIO_stdin())
7479 PerlIO_clearerr(PL_rsfp);
7480 else if (PL_rsfp && (PL_rsfp != fp))
7481 PerlIO_close(PL_rsfp);