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 #ifdef PERL_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 */
1248 "Invalid [] range \"%c-%c\" in transliteration operator",
1253 if ((isLOWER(min) && isLOWER(max)) ||
1254 (isUPPER(min) && isUPPER(max))) {
1256 for (i = min; i <= max; i++)
1260 for (i = min; i <= max; i++)
1267 for (i = min; i <= max; i++)
1270 /* mark the range as done, and continue */
1276 /* range begins (ignore - as first or last char) */
1277 else if (*s == '-' && s+1 < send && s != start) {
1279 croak("Ambiguous range in transliteration operator");
1282 *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) && *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));
2023 STATIC HV *S_find_in_my_stash(pTHX_ char *pkgname, I32 len)
2027 if (*pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
2031 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
2032 (gv = gv_fetchpv(pkgname, FALSE, SVt_PVHV))) {
2033 return GvHV(gv); /* Foo:: */
2036 /* use constant CLASS => 'MyClass' */
2037 if ((gv = gv_fetchpv(pkgname, FALSE, SVt_PVCV))) {
2039 if (GvCV(gv) && (sv = cv_const_sv(GvCV(gv)))) {
2040 pkgname = SvPV_nolen(sv);
2044 return gv_stashpv(pkgname, FALSE);
2048 static char* exp_name[] =
2049 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
2050 "ATTRTERM", "TERMBLOCK"
2057 Works out what to call the token just pulled out of the input
2058 stream. The yacc parser takes care of taking the ops we return and
2059 stitching them into a tree.
2065 if read an identifier
2066 if we're in a my declaration
2067 croak if they tried to say my($foo::bar)
2068 build the ops for a my() declaration
2069 if it's an access to a my() variable
2070 are we in a sort block?
2071 croak if my($a); $a <=> $b
2072 build ops for access to a my() variable
2073 if in a dq string, and they've said @foo and we can't find @foo
2075 build ops for a bareword
2076 if we already built the token before, use it.
2080 #pragma segment Perl_yylex
2083 #ifdef USE_PURE_BISON
2084 Perl_yylex(pTHX_ YYSTYPE *lvalp, int *lcharp)
2097 #ifdef USE_PURE_BISON
2098 yylval_pointer = lvalp;
2099 yychar_pointer = lcharp;
2102 /* check if there's an identifier for us to look at */
2103 if (PL_pending_ident) {
2104 /* pit holds the identifier we read and pending_ident is reset */
2105 char pit = PL_pending_ident;
2106 PL_pending_ident = 0;
2108 /* if we're in a my(), we can't allow dynamics here.
2109 $foo'bar has already been turned into $foo::bar, so
2110 just check for colons.
2112 if it's a legal name, the OP is a PADANY.
2115 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
2116 if (strchr(PL_tokenbuf,':'))
2117 yyerror(Perl_form(aTHX_ "No package name allowed for "
2118 "variable %s in \"our\"",
2120 tmp = pad_allocmy(PL_tokenbuf);
2123 if (strchr(PL_tokenbuf,':'))
2124 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
2126 yylval.opval = newOP(OP_PADANY, 0);
2127 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
2133 build the ops for accesses to a my() variable.
2135 Deny my($a) or my($b) in a sort block, *if* $a or $b is
2136 then used in a comparison. This catches most, but not
2137 all cases. For instance, it catches
2138 sort { my($a); $a <=> $b }
2140 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
2141 (although why you'd do that is anyone's guess).
2144 if (!strchr(PL_tokenbuf,':')) {
2146 /* Check for single character per-thread SVs */
2147 if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
2148 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
2149 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
2151 yylval.opval = newOP(OP_THREADSV, 0);
2152 yylval.opval->op_targ = tmp;
2155 #endif /* USE_THREADS */
2156 if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
2157 SV *namesv = AvARRAY(PL_comppad_name)[tmp];
2158 /* might be an "our" variable" */
2159 if (SvFLAGS(namesv) & SVpad_OUR) {
2160 /* build ops for a bareword */
2161 SV *sym = newSVpv(HvNAME(GvSTASH(namesv)),0);
2162 sv_catpvn(sym, "::", 2);
2163 sv_catpv(sym, PL_tokenbuf+1);
2164 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
2165 yylval.opval->op_private = OPpCONST_ENTERED;
2166 gv_fetchpv(SvPVX(sym),
2168 ? (GV_ADDMULTI | GV_ADDINEVAL)
2171 ((PL_tokenbuf[0] == '$') ? SVt_PV
2172 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
2177 /* if it's a sort block and they're naming $a or $b */
2178 if (PL_last_lop_op == OP_SORT &&
2179 PL_tokenbuf[0] == '$' &&
2180 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
2183 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
2184 d < PL_bufend && *d != '\n';
2187 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
2188 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
2194 yylval.opval = newOP(OP_PADANY, 0);
2195 yylval.opval->op_targ = tmp;
2201 Whine if they've said @foo in a doublequoted string,
2202 and @foo isn't a variable we can find in the symbol
2205 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
2206 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
2207 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
2208 && ckWARN(WARN_AMBIGUOUS))
2210 /* Downgraded from fatal to warning 20000522 mjd */
2211 Perl_warner(aTHX_ WARN_AMBIGUOUS,
2212 "Possible unintended interpolation of %s in string",
2217 /* build ops for a bareword */
2218 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
2219 yylval.opval->op_private = OPpCONST_ENTERED;
2220 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
2221 ((PL_tokenbuf[0] == '$') ? SVt_PV
2222 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
2227 /* no identifier pending identification */
2229 switch (PL_lex_state) {
2231 case LEX_NORMAL: /* Some compilers will produce faster */
2232 case LEX_INTERPNORMAL: /* code if we comment these out. */
2236 /* when we've already built the next token, just pull it out of the queue */
2239 yylval = PL_nextval[PL_nexttoke];
2241 PL_lex_state = PL_lex_defer;
2242 PL_expect = PL_lex_expect;
2243 PL_lex_defer = LEX_NORMAL;
2245 return(PL_nexttype[PL_nexttoke]);
2247 /* interpolated case modifiers like \L \U, including \Q and \E.
2248 when we get here, PL_bufptr is at the \
2250 case LEX_INTERPCASEMOD:
2252 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
2253 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
2255 /* handle \E or end of string */
2256 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
2260 if (PL_lex_casemods) {
2261 oldmod = PL_lex_casestack[--PL_lex_casemods];
2262 PL_lex_casestack[PL_lex_casemods] = '\0';
2264 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
2266 PL_lex_state = LEX_INTERPCONCAT;
2270 if (PL_bufptr != PL_bufend)
2272 PL_lex_state = LEX_INTERPCONCAT;
2277 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
2278 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
2279 if (strchr("LU", *s) &&
2280 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
2282 PL_lex_casestack[--PL_lex_casemods] = '\0';
2285 if (PL_lex_casemods > 10) {
2286 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
2287 if (newlb != PL_lex_casestack) {
2289 PL_lex_casestack = newlb;
2292 PL_lex_casestack[PL_lex_casemods++] = *s;
2293 PL_lex_casestack[PL_lex_casemods] = '\0';
2294 PL_lex_state = LEX_INTERPCONCAT;
2295 PL_nextval[PL_nexttoke].ival = 0;
2298 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
2300 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
2302 PL_nextval[PL_nexttoke].ival = OP_LC;
2304 PL_nextval[PL_nexttoke].ival = OP_UC;
2306 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
2308 Perl_croak(aTHX_ "panic: yylex");
2311 if (PL_lex_starts) {
2320 case LEX_INTERPPUSH:
2321 return sublex_push();
2323 case LEX_INTERPSTART:
2324 if (PL_bufptr == PL_bufend)
2325 return sublex_done();
2327 PL_lex_dojoin = (*PL_bufptr == '@');
2328 PL_lex_state = LEX_INTERPNORMAL;
2329 if (PL_lex_dojoin) {
2330 PL_nextval[PL_nexttoke].ival = 0;
2333 PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
2334 PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
2335 force_next(PRIVATEREF);
2337 force_ident("\"", '$');
2338 #endif /* USE_THREADS */
2339 PL_nextval[PL_nexttoke].ival = 0;
2341 PL_nextval[PL_nexttoke].ival = 0;
2343 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
2346 if (PL_lex_starts++) {
2352 case LEX_INTERPENDMAYBE:
2353 if (intuit_more(PL_bufptr)) {
2354 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
2360 if (PL_lex_dojoin) {
2361 PL_lex_dojoin = FALSE;
2362 PL_lex_state = LEX_INTERPCONCAT;
2365 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
2366 && SvEVALED(PL_lex_repl))
2368 if (PL_bufptr != PL_bufend)
2369 Perl_croak(aTHX_ "Bad evalled substitution pattern");
2370 PL_lex_repl = Nullsv;
2373 case LEX_INTERPCONCAT:
2375 if (PL_lex_brackets)
2376 Perl_croak(aTHX_ "panic: INTERPCONCAT");
2378 if (PL_bufptr == PL_bufend)
2379 return sublex_done();
2381 if (SvIVX(PL_linestr) == '\'') {
2382 SV *sv = newSVsv(PL_linestr);
2385 else if ( PL_hints & HINT_NEW_RE )
2386 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
2387 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2391 s = scan_const(PL_bufptr);
2393 PL_lex_state = LEX_INTERPCASEMOD;
2395 PL_lex_state = LEX_INTERPSTART;
2398 if (s != PL_bufptr) {
2399 PL_nextval[PL_nexttoke] = yylval;
2402 if (PL_lex_starts++)
2412 PL_lex_state = LEX_NORMAL;
2413 s = scan_formline(PL_bufptr);
2414 if (!PL_lex_formbrack)
2420 PL_oldoldbufptr = PL_oldbufptr;
2423 PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at %s\n",
2424 exp_name[PL_expect], s);
2430 if (isIDFIRST_lazy_if(s,UTF))
2432 Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
2435 goto fake_eof; /* emulate EOF on ^D or ^Z */
2440 if (PL_lex_brackets)
2441 yyerror("Missing right curly or square bracket");
2444 if (s++ < PL_bufend)
2445 goto retry; /* ignore stray nulls */
2448 if (!PL_in_eval && !PL_preambled) {
2449 PL_preambled = TRUE;
2450 sv_setpv(PL_linestr,incl_perldb());
2451 if (SvCUR(PL_linestr))
2452 sv_catpv(PL_linestr,";");
2454 while(AvFILLp(PL_preambleav) >= 0) {
2455 SV *tmpsv = av_shift(PL_preambleav);
2456 sv_catsv(PL_linestr, tmpsv);
2457 sv_catpv(PL_linestr, ";");
2460 sv_free((SV*)PL_preambleav);
2461 PL_preambleav = NULL;
2463 if (PL_minus_n || PL_minus_p) {
2464 sv_catpv(PL_linestr, "LINE: while (<>) {");
2466 sv_catpv(PL_linestr,"chomp;");
2468 GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
2470 GvIMPORTED_AV_on(gv);
2472 if (strchr("/'\"", *PL_splitstr)
2473 && strchr(PL_splitstr + 1, *PL_splitstr))
2474 Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s);", PL_splitstr);
2477 s = "'~#\200\1'"; /* surely one char is unused...*/
2478 while (s[1] && strchr(PL_splitstr, *s)) s++;
2480 Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s%c",
2481 "q" + (delim == '\''), delim);
2482 for (s = PL_splitstr; *s; s++) {
2484 sv_catpvn(PL_linestr, "\\", 1);
2485 sv_catpvn(PL_linestr, s, 1);
2487 Perl_sv_catpvf(aTHX_ PL_linestr, "%c);", delim);
2491 sv_catpv(PL_linestr,"@F=split(' ');");
2494 sv_catpv(PL_linestr, "\n");
2495 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2496 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2497 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2498 SV *sv = NEWSV(85,0);
2500 sv_upgrade(sv, SVt_PVMG);
2501 sv_setsv(sv,PL_linestr);
2502 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2508 bof = PL_rsfp && (PerlIO_tell(PL_rsfp)==0); /* *Before* read! */
2509 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
2512 if (PL_preprocess && !PL_in_eval)
2513 (void)PerlProc_pclose(PL_rsfp);
2514 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2515 PerlIO_clearerr(PL_rsfp);
2517 (void)PerlIO_close(PL_rsfp);
2519 PL_doextract = FALSE;
2521 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2522 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
2523 sv_catpv(PL_linestr,";}");
2524 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2525 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2526 PL_minus_n = PL_minus_p = 0;
2529 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2530 sv_setpv(PL_linestr,"");
2531 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
2534 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
2535 PL_doextract = FALSE;
2537 /* Incest with pod. */
2538 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2539 sv_setpv(PL_linestr, "");
2540 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2541 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2542 PL_doextract = FALSE;
2548 } while (PL_doextract);
2549 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2550 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2551 SV *sv = NEWSV(85,0);
2553 sv_upgrade(sv, SVt_PVMG);
2554 sv_setsv(sv,PL_linestr);
2555 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2557 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2558 if (CopLINE(PL_curcop) == 1) {
2559 while (s < PL_bufend && isSPACE(*s))
2561 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2565 if (*s == '#' && *(s+1) == '!')
2567 #ifdef ALTERNATE_SHEBANG
2569 static char as[] = ALTERNATE_SHEBANG;
2570 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2571 d = s + (sizeof(as) - 1);
2573 #endif /* ALTERNATE_SHEBANG */
2582 while (*d && !isSPACE(*d))
2586 #ifdef ARG_ZERO_IS_SCRIPT
2587 if (ipathend > ipath) {
2589 * HP-UX (at least) sets argv[0] to the script name,
2590 * which makes $^X incorrect. And Digital UNIX and Linux,
2591 * at least, set argv[0] to the basename of the Perl
2592 * interpreter. So, having found "#!", we'll set it right.
2594 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
2595 assert(SvPOK(x) || SvGMAGICAL(x));
2596 if (sv_eq(x, CopFILESV(PL_curcop))) {
2597 sv_setpvn(x, ipath, ipathend - ipath);
2600 TAINT_NOT; /* $^X is always tainted, but that's OK */
2602 #endif /* ARG_ZERO_IS_SCRIPT */
2607 d = instr(s,"perl -");
2609 d = instr(s,"perl");
2611 /* avoid getting into infinite loops when shebang
2612 * line contains "Perl" rather than "perl" */
2614 for (d = ipathend-4; d >= ipath; --d) {
2615 if ((*d == 'p' || *d == 'P')
2616 && !ibcmp(d, "perl", 4))
2626 #ifdef ALTERNATE_SHEBANG
2628 * If the ALTERNATE_SHEBANG on this system starts with a
2629 * character that can be part of a Perl expression, then if
2630 * we see it but not "perl", we're probably looking at the
2631 * start of Perl code, not a request to hand off to some
2632 * other interpreter. Similarly, if "perl" is there, but
2633 * not in the first 'word' of the line, we assume the line
2634 * contains the start of the Perl program.
2636 if (d && *s != '#') {
2638 while (*c && !strchr("; \t\r\n\f\v#", *c))
2641 d = Nullch; /* "perl" not in first word; ignore */
2643 *s = '#'; /* Don't try to parse shebang line */
2645 #endif /* ALTERNATE_SHEBANG */
2646 #ifndef MACOS_TRADITIONAL
2651 !instr(s,"indir") &&
2652 instr(PL_origargv[0],"perl"))
2658 while (s < PL_bufend && isSPACE(*s))
2660 if (s < PL_bufend) {
2661 Newz(899,newargv,PL_origargc+3,char*);
2663 while (s < PL_bufend && !isSPACE(*s))
2666 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2669 newargv = PL_origargv;
2671 PerlProc_execv(ipath, newargv);
2672 Perl_croak(aTHX_ "Can't exec %s", ipath);
2676 U32 oldpdb = PL_perldb;
2677 bool oldn = PL_minus_n;
2678 bool oldp = PL_minus_p;
2680 while (*d && !isSPACE(*d)) d++;
2681 while (SPACE_OR_TAB(*d)) d++;
2685 if (*d == 'M' || *d == 'm') {
2687 while (*d && !isSPACE(*d)) d++;
2688 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2691 d = moreswitches(d);
2693 if ((PERLDB_LINE && !oldpdb) ||
2694 ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
2695 /* if we have already added "LINE: while (<>) {",
2696 we must not do it again */
2698 sv_setpv(PL_linestr, "");
2699 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2700 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2701 PL_preambled = FALSE;
2703 (void)gv_fetchfile(PL_origfilename);
2710 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2712 PL_lex_state = LEX_FORMLINE;
2717 #ifdef PERL_STRICT_CR
2718 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2720 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
2722 case ' ': case '\t': case '\f': case 013:
2723 #ifdef MACOS_TRADITIONAL
2730 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2731 if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
2732 /* handle eval qq[#line 1 "foo"\n ...] */
2733 CopLINE_dec(PL_curcop);
2737 while (s < d && *s != '\n')
2742 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2744 PL_lex_state = LEX_FORMLINE;
2754 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2759 while (s < PL_bufend && SPACE_OR_TAB(*s))
2762 if (strnEQ(s,"=>",2)) {
2763 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2764 OPERATOR('-'); /* unary minus */
2766 PL_last_uni = PL_oldbufptr;
2767 PL_last_lop_op = OP_FTEREAD; /* good enough */
2769 case 'r': FTST(OP_FTEREAD);
2770 case 'w': FTST(OP_FTEWRITE);
2771 case 'x': FTST(OP_FTEEXEC);
2772 case 'o': FTST(OP_FTEOWNED);
2773 case 'R': FTST(OP_FTRREAD);
2774 case 'W': FTST(OP_FTRWRITE);
2775 case 'X': FTST(OP_FTREXEC);
2776 case 'O': FTST(OP_FTROWNED);
2777 case 'e': FTST(OP_FTIS);
2778 case 'z': FTST(OP_FTZERO);
2779 case 's': FTST(OP_FTSIZE);
2780 case 'f': FTST(OP_FTFILE);
2781 case 'd': FTST(OP_FTDIR);
2782 case 'l': FTST(OP_FTLINK);
2783 case 'p': FTST(OP_FTPIPE);
2784 case 'S': FTST(OP_FTSOCK);
2785 case 'u': FTST(OP_FTSUID);
2786 case 'g': FTST(OP_FTSGID);
2787 case 'k': FTST(OP_FTSVTX);
2788 case 'b': FTST(OP_FTBLK);
2789 case 'c': FTST(OP_FTCHR);
2790 case 't': FTST(OP_FTTTY);
2791 case 'T': FTST(OP_FTTEXT);
2792 case 'B': FTST(OP_FTBINARY);
2793 case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2794 case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2795 case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
2797 Perl_croak(aTHX_ "Unrecognized file test: -%c", (int)tmp);
2804 if (PL_expect == XOPERATOR)
2809 else if (*s == '>') {
2812 if (isIDFIRST_lazy_if(s,UTF)) {
2813 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2821 if (PL_expect == XOPERATOR)
2824 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2826 OPERATOR('-'); /* unary minus */
2833 if (PL_expect == XOPERATOR)
2838 if (PL_expect == XOPERATOR)
2841 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2847 if (PL_expect != XOPERATOR) {
2848 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2849 PL_expect = XOPERATOR;
2850 force_ident(PL_tokenbuf, '*');
2863 if (PL_expect == XOPERATOR) {
2867 PL_tokenbuf[0] = '%';
2868 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2869 if (!PL_tokenbuf[1]) {
2871 yyerror("Final % should be \\% or %name");
2874 PL_pending_ident = '%';
2893 switch (PL_expect) {
2896 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
2898 PL_bufptr = s; /* update in case we back off */
2904 PL_expect = XTERMBLOCK;
2908 while (isIDFIRST_lazy_if(s,UTF)) {
2909 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2910 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
2911 if (tmp < 0) tmp = -tmp;
2926 d = scan_str(d,TRUE,TRUE);
2929 SvREFCNT_dec(PL_lex_stuff);
2930 PL_lex_stuff = Nullsv;
2932 /* MUST advance bufptr here to avoid bogus
2933 "at end of line" context messages from yyerror().
2935 PL_bufptr = s + len;
2936 yyerror("Unterminated attribute parameter in attribute list");
2939 return 0; /* EOF indicator */
2943 SV *sv = newSVpvn(s, len);
2944 sv_catsv(sv, PL_lex_stuff);
2945 attrs = append_elem(OP_LIST, attrs,
2946 newSVOP(OP_CONST, 0, sv));
2947 SvREFCNT_dec(PL_lex_stuff);
2948 PL_lex_stuff = Nullsv;
2951 attrs = append_elem(OP_LIST, attrs,
2952 newSVOP(OP_CONST, 0,
2956 if (*s == ':' && s[1] != ':')
2959 break; /* require real whitespace or :'s */
2961 tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
2962 if (*s != ';' && *s != tmp && (tmp != '=' || *s != ')')) {
2963 char q = ((*s == '\'') ? '"' : '\'');
2964 /* If here for an expression, and parsed no attrs, back off. */
2965 if (tmp == '=' && !attrs) {
2969 /* MUST advance bufptr here to avoid bogus "at end of line"
2970 context messages from yyerror().
2974 yyerror("Unterminated attribute list");
2976 yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list",
2984 PL_nextval[PL_nexttoke].opval = attrs;
2992 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
2993 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
3009 if (PL_lex_brackets <= 0)
3010 yyerror("Unmatched right square bracket");
3013 if (PL_lex_state == LEX_INTERPNORMAL) {
3014 if (PL_lex_brackets == 0) {
3015 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
3016 PL_lex_state = LEX_INTERPEND;
3023 if (PL_lex_brackets > 100) {
3024 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
3025 if (newlb != PL_lex_brackstack) {
3027 PL_lex_brackstack = newlb;
3030 switch (PL_expect) {
3032 if (PL_lex_formbrack) {
3036 if (PL_oldoldbufptr == PL_last_lop)
3037 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3039 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3040 OPERATOR(HASHBRACK);
3042 while (s < PL_bufend && SPACE_OR_TAB(*s))
3045 PL_tokenbuf[0] = '\0';
3046 if (d < PL_bufend && *d == '-') {
3047 PL_tokenbuf[0] = '-';
3049 while (d < PL_bufend && SPACE_OR_TAB(*d))
3052 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
3053 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
3055 while (d < PL_bufend && SPACE_OR_TAB(*d))
3058 char minus = (PL_tokenbuf[0] == '-');
3059 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
3067 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
3072 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3077 if (PL_oldoldbufptr == PL_last_lop)
3078 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3080 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3083 OPERATOR(HASHBRACK);
3084 /* This hack serves to disambiguate a pair of curlies
3085 * as being a block or an anon hash. Normally, expectation
3086 * determines that, but in cases where we're not in a
3087 * position to expect anything in particular (like inside
3088 * eval"") we have to resolve the ambiguity. This code
3089 * covers the case where the first term in the curlies is a
3090 * quoted string. Most other cases need to be explicitly
3091 * disambiguated by prepending a `+' before the opening
3092 * curly in order to force resolution as an anon hash.
3094 * XXX should probably propagate the outer expectation
3095 * into eval"" to rely less on this hack, but that could
3096 * potentially break current behavior of eval"".
3100 if (*s == '\'' || *s == '"' || *s == '`') {
3101 /* common case: get past first string, handling escapes */
3102 for (t++; t < PL_bufend && *t != *s;)
3103 if (*t++ == '\\' && (*t == '\\' || *t == *s))
3107 else if (*s == 'q') {
3110 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
3114 char open, close, term;
3117 while (t < PL_bufend && isSPACE(*t))
3121 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
3125 for (t++; t < PL_bufend; t++) {
3126 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
3128 else if (*t == open)
3132 for (t++; t < PL_bufend; t++) {
3133 if (*t == '\\' && t+1 < PL_bufend)
3135 else if (*t == close && --brackets <= 0)
3137 else if (*t == open)
3143 else if (isALNUM_lazy_if(t,UTF)) {
3145 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3148 while (t < PL_bufend && isSPACE(*t))
3150 /* if comma follows first term, call it an anon hash */
3151 /* XXX it could be a comma expression with loop modifiers */
3152 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
3153 || (*t == '=' && t[1] == '>')))
3154 OPERATOR(HASHBRACK);
3155 if (PL_expect == XREF)
3158 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
3164 yylval.ival = CopLINE(PL_curcop);
3165 if (isSPACE(*s) || *s == '#')
3166 PL_copline = NOLINE; /* invalidate current command line number */
3171 if (PL_lex_brackets <= 0)
3172 yyerror("Unmatched right curly bracket");
3174 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
3175 if (PL_lex_brackets < PL_lex_formbrack)
3176 PL_lex_formbrack = 0;
3177 if (PL_lex_state == LEX_INTERPNORMAL) {
3178 if (PL_lex_brackets == 0) {
3179 if (PL_expect & XFAKEBRACK) {
3180 PL_expect &= XENUMMASK;
3181 PL_lex_state = LEX_INTERPEND;
3183 return yylex(); /* ignore fake brackets */
3185 if (*s == '-' && s[1] == '>')
3186 PL_lex_state = LEX_INTERPENDMAYBE;
3187 else if (*s != '[' && *s != '{')
3188 PL_lex_state = LEX_INTERPEND;
3191 if (PL_expect & XFAKEBRACK) {
3192 PL_expect &= XENUMMASK;
3194 return yylex(); /* ignore fake brackets */
3204 if (PL_expect == XOPERATOR) {
3205 if (ckWARN(WARN_SEMICOLON)
3206 && isIDFIRST_lazy_if(s,UTF) && PL_bufptr == PL_linestart)
3208 CopLINE_dec(PL_curcop);
3209 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3210 CopLINE_inc(PL_curcop);
3215 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3217 PL_expect = XOPERATOR;
3218 force_ident(PL_tokenbuf, '&');
3222 yylval.ival = (OPpENTERSUB_AMPER<<8);
3241 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
3242 Perl_warner(aTHX_ WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
3244 if (PL_expect == XSTATE && isALPHA(tmp) &&
3245 (s == PL_linestart+1 || s[-2] == '\n') )
3247 if (PL_in_eval && !PL_rsfp) {
3252 if (strnEQ(s,"=cut",4)) {
3266 PL_doextract = TRUE;
3269 if (PL_lex_brackets < PL_lex_formbrack) {
3271 #ifdef PERL_STRICT_CR
3272 for (t = s; SPACE_OR_TAB(*t); t++) ;
3274 for (t = s; SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
3276 if (*t == '\n' || *t == '#') {
3294 if (PL_expect != XOPERATOR) {
3295 if (s[1] != '<' && !strchr(s,'>'))
3298 s = scan_heredoc(s);
3300 s = scan_inputsymbol(s);
3301 TERM(sublex_start());
3306 SHop(OP_LEFT_SHIFT);
3320 SHop(OP_RIGHT_SHIFT);
3329 if (PL_expect == XOPERATOR) {
3330 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3333 return ','; /* grandfather non-comma-format format */
3337 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
3338 PL_tokenbuf[0] = '@';
3339 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3340 sizeof PL_tokenbuf - 1, FALSE);
3341 if (PL_expect == XOPERATOR)
3342 no_op("Array length", s);
3343 if (!PL_tokenbuf[1])
3345 PL_expect = XOPERATOR;
3346 PL_pending_ident = '#';
3350 PL_tokenbuf[0] = '$';
3351 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3352 sizeof PL_tokenbuf - 1, FALSE);
3353 if (PL_expect == XOPERATOR)
3355 if (!PL_tokenbuf[1]) {
3357 yyerror("Final $ should be \\$ or $name");
3361 /* This kludge not intended to be bulletproof. */
3362 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
3363 yylval.opval = newSVOP(OP_CONST, 0,
3364 newSViv(PL_compiling.cop_arybase));
3365 yylval.opval->op_private = OPpCONST_ARYBASE;
3371 if (PL_lex_state == LEX_NORMAL)
3374 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3377 PL_tokenbuf[0] = '@';
3378 if (ckWARN(WARN_SYNTAX)) {
3380 isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$';
3383 PL_bufptr = skipspace(PL_bufptr);
3384 while (t < PL_bufend && *t != ']')
3386 Perl_warner(aTHX_ WARN_SYNTAX,
3387 "Multidimensional syntax %.*s not supported",
3388 (t - PL_bufptr) + 1, PL_bufptr);
3392 else if (*s == '{') {
3393 PL_tokenbuf[0] = '%';
3394 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
3395 (t = strchr(s, '}')) && (t = strchr(t, '=')))
3397 char tmpbuf[sizeof PL_tokenbuf];
3399 for (t++; isSPACE(*t); t++) ;
3400 if (isIDFIRST_lazy_if(t,UTF)) {
3401 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
3402 for (; isSPACE(*t); t++) ;
3403 if (*t == ';' && get_cv(tmpbuf, FALSE))
3404 Perl_warner(aTHX_ WARN_SYNTAX,
3405 "You need to quote \"%s\"", tmpbuf);
3411 PL_expect = XOPERATOR;
3412 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3413 bool islop = (PL_last_lop == PL_oldoldbufptr);
3414 if (!islop || PL_last_lop_op == OP_GREPSTART)
3415 PL_expect = XOPERATOR;
3416 else if (strchr("$@\"'`q", *s))
3417 PL_expect = XTERM; /* e.g. print $fh "foo" */
3418 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
3419 PL_expect = XTERM; /* e.g. print $fh &sub */
3420 else if (isIDFIRST_lazy_if(s,UTF)) {
3421 char tmpbuf[sizeof PL_tokenbuf];
3422 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3423 if ((tmp = keyword(tmpbuf, len))) {
3424 /* binary operators exclude handle interpretations */
3436 PL_expect = XTERM; /* e.g. print $fh length() */
3441 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
3442 if (gv && GvCVu(gv))
3443 PL_expect = XTERM; /* e.g. print $fh subr() */
3446 else if (isDIGIT(*s))
3447 PL_expect = XTERM; /* e.g. print $fh 3 */
3448 else if (*s == '.' && isDIGIT(s[1]))
3449 PL_expect = XTERM; /* e.g. print $fh .3 */
3450 else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
3451 PL_expect = XTERM; /* e.g. print $fh -1 */
3452 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3453 PL_expect = XTERM; /* print $fh <<"EOF" */
3455 PL_pending_ident = '$';
3459 if (PL_expect == XOPERATOR)
3461 PL_tokenbuf[0] = '@';
3462 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3463 if (!PL_tokenbuf[1]) {
3465 yyerror("Final @ should be \\@ or @name");
3468 if (PL_lex_state == LEX_NORMAL)
3470 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3472 PL_tokenbuf[0] = '%';
3474 /* Warn about @ where they meant $. */
3475 if (ckWARN(WARN_SYNTAX)) {
3476 if (*s == '[' || *s == '{') {
3478 while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
3480 if (*t == '}' || *t == ']') {
3482 PL_bufptr = skipspace(PL_bufptr);
3483 Perl_warner(aTHX_ WARN_SYNTAX,
3484 "Scalar value %.*s better written as $%.*s",
3485 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
3490 PL_pending_ident = '@';
3493 case '/': /* may either be division or pattern */
3494 case '?': /* may either be conditional or pattern */
3495 if (PL_expect != XOPERATOR) {
3496 /* Disable warning on "study /blah/" */
3497 if (PL_oldoldbufptr == PL_last_uni
3498 && (*PL_last_uni != 's' || s - PL_last_uni < 5
3499 || memNE(PL_last_uni, "study", 5)
3500 || isALNUM_lazy_if(PL_last_uni+5,UTF)))
3502 s = scan_pat(s,OP_MATCH);
3503 TERM(sublex_start());
3511 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3512 #ifdef PERL_STRICT_CR
3515 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3517 && (s == PL_linestart || s[-1] == '\n') )
3519 PL_lex_formbrack = 0;
3523 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
3529 yylval.ival = OPf_SPECIAL;
3535 if (PL_expect != XOPERATOR)
3540 case '0': case '1': case '2': case '3': case '4':
3541 case '5': case '6': case '7': case '8': case '9':
3543 if (PL_expect == XOPERATOR)
3548 s = scan_str(s,FALSE,FALSE);
3549 if (PL_expect == XOPERATOR) {
3550 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3553 return ','; /* grandfather non-comma-format format */
3559 missingterm((char*)0);
3560 yylval.ival = OP_CONST;
3561 TERM(sublex_start());
3564 s = scan_str(s,FALSE,FALSE);
3565 if (PL_expect == XOPERATOR) {
3566 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3569 return ','; /* grandfather non-comma-format format */
3575 missingterm((char*)0);
3576 yylval.ival = OP_CONST;
3577 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
3578 if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
3579 yylval.ival = OP_STRINGIFY;
3583 TERM(sublex_start());
3586 s = scan_str(s,FALSE,FALSE);
3587 if (PL_expect == XOPERATOR)
3588 no_op("Backticks",s);
3590 missingterm((char*)0);
3591 yylval.ival = OP_BACKTICK;
3593 TERM(sublex_start());
3597 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
3598 Perl_warner(aTHX_ WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
3600 if (PL_expect == XOPERATOR)
3601 no_op("Backslash",s);
3605 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
3609 while (isDIGIT(*start) || *start == '_')
3611 if (*start == '.' && isDIGIT(start[1])) {
3615 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
3616 else if (!isALPHA(*start) && (PL_expect == XTERM || PL_expect == XREF)) {
3620 gv = gv_fetchpv(s, FALSE, SVt_PVCV);
3630 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
3669 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3671 /* Some keywords can be followed by any delimiter, including ':' */
3672 tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
3673 (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
3674 (PL_tokenbuf[0] == 'q' &&
3675 strchr("qwxr", PL_tokenbuf[1])))));
3677 /* x::* is just a word, unless x is "CORE" */
3678 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
3682 while (d < PL_bufend && isSPACE(*d))
3683 d++; /* no comments skipped here, or s### is misparsed */
3685 /* Is this a label? */
3686 if (!tmp && PL_expect == XSTATE
3687 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
3689 yylval.pval = savepv(PL_tokenbuf);
3694 /* Check for keywords */
3695 tmp = keyword(PL_tokenbuf, len);
3697 /* Is this a word before a => operator? */
3698 if (*d == '=' && d[1] == '>') {
3700 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
3701 yylval.opval->op_private = OPpCONST_BARE;
3705 if (tmp < 0) { /* second-class keyword? */
3706 GV *ogv = Nullgv; /* override (winner) */
3707 GV *hgv = Nullgv; /* hidden (loser) */
3708 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3710 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3713 if (GvIMPORTED_CV(gv))
3715 else if (! CvMETHOD(cv))
3719 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3720 (gv = *gvp) != (GV*)&PL_sv_undef &&
3721 GvCVu(gv) && GvIMPORTED_CV(gv))
3727 tmp = 0; /* overridden by import or by GLOBAL */
3730 && -tmp==KEY_lock /* XXX generalizable kludge */
3732 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3734 tmp = 0; /* any sub overrides "weak" keyword */
3736 else { /* no override */
3740 if (ckWARN(WARN_AMBIGUOUS) && hgv
3741 && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3742 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3743 "Ambiguous call resolved as CORE::%s(), %s",
3744 GvENAME(hgv), "qualify as such or use &");
3751 default: /* not a keyword */
3754 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3756 /* Get the rest if it looks like a package qualifier */
3758 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
3760 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3763 Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
3764 *s == '\'' ? "'" : "::");
3768 if (PL_expect == XOPERATOR) {
3769 if (PL_bufptr == PL_linestart) {
3770 CopLINE_dec(PL_curcop);
3771 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3772 CopLINE_inc(PL_curcop);
3775 no_op("Bareword",s);
3778 /* Look for a subroutine with this name in current package,
3779 unless name is "Foo::", in which case Foo is a bearword
3780 (and a package name). */
3783 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3785 if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3786 Perl_warner(aTHX_ WARN_BAREWORD,
3787 "Bareword \"%s\" refers to nonexistent package",
3790 PL_tokenbuf[len] = '\0';
3797 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3800 /* if we saw a global override before, get the right name */
3803 sv = newSVpvn("CORE::GLOBAL::",14);
3804 sv_catpv(sv,PL_tokenbuf);
3807 sv = newSVpv(PL_tokenbuf,0);
3809 /* Presume this is going to be a bareword of some sort. */
3812 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3813 yylval.opval->op_private = OPpCONST_BARE;
3815 /* And if "Foo::", then that's what it certainly is. */
3820 /* See if it's the indirect object for a list operator. */
3822 if (PL_oldoldbufptr &&
3823 PL_oldoldbufptr < PL_bufptr &&
3824 (PL_oldoldbufptr == PL_last_lop
3825 || PL_oldoldbufptr == PL_last_uni) &&
3826 /* NO SKIPSPACE BEFORE HERE! */
3827 (PL_expect == XREF ||
3828 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
3830 bool immediate_paren = *s == '(';
3832 /* (Now we can afford to cross potential line boundary.) */
3835 /* Two barewords in a row may indicate method call. */
3837 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp=intuit_method(s,gv)))
3840 /* If not a declared subroutine, it's an indirect object. */
3841 /* (But it's an indir obj regardless for sort.) */
3843 if ((PL_last_lop_op == OP_SORT ||
3844 (!immediate_paren && (!gv || !GvCVu(gv)))) &&
3845 (PL_last_lop_op != OP_MAPSTART &&
3846 PL_last_lop_op != OP_GREPSTART))
3848 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3854 PL_expect = XOPERATOR;
3857 /* Is this a word before a => operator? */
3858 if (*s == '=' && s[1] == '>') {
3860 sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
3864 /* If followed by a paren, it's certainly a subroutine. */
3867 if (gv && GvCVu(gv)) {
3868 for (d = s + 1; SPACE_OR_TAB(*d); d++) ;
3869 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
3874 PL_nextval[PL_nexttoke].opval = yylval.opval;
3875 PL_expect = XOPERATOR;
3881 /* If followed by var or block, call it a method (unless sub) */
3883 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3884 PL_last_lop = PL_oldbufptr;
3885 PL_last_lop_op = OP_METHOD;
3889 /* If followed by a bareword, see if it looks like indir obj. */
3891 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp = intuit_method(s,gv)))
3894 /* Not a method, so call it a subroutine (if defined) */
3896 if (gv && GvCVu(gv)) {
3898 if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
3899 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3900 "Ambiguous use of -%s resolved as -&%s()",
3901 PL_tokenbuf, PL_tokenbuf);
3902 /* Check for a constant sub */
3904 if ((sv = cv_const_sv(cv))) {
3906 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3907 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3908 yylval.opval->op_private = 0;
3912 /* Resolve to GV now. */
3913 op_free(yylval.opval);
3914 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3915 yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
3916 PL_last_lop = PL_oldbufptr;
3917 PL_last_lop_op = OP_ENTERSUB;
3918 /* Is there a prototype? */
3921 char *proto = SvPV((SV*)cv, len);
3924 if (strEQ(proto, "$"))
3926 if (*proto == '&' && *s == '{') {
3927 sv_setpv(PL_subname,"__ANON__");
3931 PL_nextval[PL_nexttoke].opval = yylval.opval;
3937 /* Call it a bare word */
3939 if (PL_hints & HINT_STRICT_SUBS)
3940 yylval.opval->op_private |= OPpCONST_STRICT;
3943 if (ckWARN(WARN_RESERVED)) {
3944 if (lastchar != '-') {
3945 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3947 Perl_warner(aTHX_ WARN_RESERVED, PL_warn_reserved,
3954 if (lastchar && strchr("*%&", lastchar) && ckWARN_d(WARN_AMBIGUOUS)) {
3955 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3956 "Operator or semicolon missing before %c%s",
3957 lastchar, PL_tokenbuf);
3958 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3959 "Ambiguous use of %c resolved as operator %c",
3960 lastchar, lastchar);
3966 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3967 newSVpv(CopFILE(PL_curcop),0));
3971 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3972 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
3975 case KEY___PACKAGE__:
3976 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3978 ? newSVsv(PL_curstname)
3987 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3988 char *pname = "main";
3989 if (PL_tokenbuf[2] == 'D')
3990 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3991 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
3994 GvIOp(gv) = newIO();
3995 IoIFP(GvIOp(gv)) = PL_rsfp;
3996 #if defined(HAS_FCNTL) && defined(F_SETFD)
3998 int fd = PerlIO_fileno(PL_rsfp);
3999 fcntl(fd,F_SETFD,fd >= 3);
4002 /* Mark this internal pseudo-handle as clean */
4003 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
4005 IoTYPE(GvIOp(gv)) = '|';
4006 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
4007 IoTYPE(GvIOp(gv)) = '-';
4009 IoTYPE(GvIOp(gv)) = '<';
4010 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
4011 /* if the script was opened in binmode, we need to revert
4012 * it to text mode for compatibility; but only iff it has CRs
4013 * XXX this is a questionable hack at best. */
4014 if (PL_bufend-PL_bufptr > 2
4015 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
4018 if (IoTYPE(GvIOp(gv)) == '<') {
4019 loc = PerlIO_tell(PL_rsfp);
4020 (void)PerlIO_seek(PL_rsfp, 0L, 0);
4022 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
4023 #if defined(__BORLANDC__)
4024 /* XXX see note in do_binmode() */
4025 ((FILE*)PL_rsfp)->flags |= _F_BIN;
4028 PerlIO_seek(PL_rsfp, loc, 0);
4043 if (PL_expect == XSTATE) {
4050 if (*s == ':' && s[1] == ':') {
4053 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4054 if (!(tmp = keyword(PL_tokenbuf, len)))
4055 Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
4069 LOP(OP_ACCEPT,XTERM);
4075 LOP(OP_ATAN2,XTERM);
4081 LOP(OP_BINMODE,XTERM);
4084 LOP(OP_BLESS,XTERM);
4093 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
4110 if (!PL_cryptseen) {
4111 PL_cryptseen = TRUE;
4115 LOP(OP_CRYPT,XTERM);
4118 if (ckWARN(WARN_CHMOD)) {
4119 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4120 if (*d != '0' && isDIGIT(*d))
4121 Perl_warner(aTHX_ WARN_CHMOD,
4122 "chmod() mode argument is missing initial 0");
4124 LOP(OP_CHMOD,XTERM);
4127 LOP(OP_CHOWN,XTERM);
4130 LOP(OP_CONNECT,XTERM);
4146 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4150 PL_hints |= HINT_BLOCK_SCOPE;
4160 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
4161 LOP(OP_DBMOPEN,XTERM);
4167 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4174 yylval.ival = CopLINE(PL_curcop);
4188 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
4189 UNIBRACK(OP_ENTEREVAL);
4204 case KEY_endhostent:
4210 case KEY_endservent:
4213 case KEY_endprotoent:
4224 yylval.ival = CopLINE(PL_curcop);
4226 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
4228 if ((PL_bufend - p) >= 3 &&
4229 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
4231 else if ((PL_bufend - p) >= 4 &&
4232 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
4235 if (isIDFIRST_lazy_if(p,UTF)) {
4236 p = scan_ident(p, PL_bufend,
4237 PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4241 Perl_croak(aTHX_ "Missing $ on loop variable");
4246 LOP(OP_FORMLINE,XTERM);
4252 LOP(OP_FCNTL,XTERM);
4258 LOP(OP_FLOCK,XTERM);
4267 LOP(OP_GREPSTART, XREF);
4270 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4285 case KEY_getpriority:
4286 LOP(OP_GETPRIORITY,XTERM);
4288 case KEY_getprotobyname:
4291 case KEY_getprotobynumber:
4292 LOP(OP_GPBYNUMBER,XTERM);
4294 case KEY_getprotoent:
4306 case KEY_getpeername:
4307 UNI(OP_GETPEERNAME);
4309 case KEY_gethostbyname:
4312 case KEY_gethostbyaddr:
4313 LOP(OP_GHBYADDR,XTERM);
4315 case KEY_gethostent:
4318 case KEY_getnetbyname:
4321 case KEY_getnetbyaddr:
4322 LOP(OP_GNBYADDR,XTERM);
4327 case KEY_getservbyname:
4328 LOP(OP_GSBYNAME,XTERM);
4330 case KEY_getservbyport:
4331 LOP(OP_GSBYPORT,XTERM);
4333 case KEY_getservent:
4336 case KEY_getsockname:
4337 UNI(OP_GETSOCKNAME);
4339 case KEY_getsockopt:
4340 LOP(OP_GSOCKOPT,XTERM);
4362 yylval.ival = CopLINE(PL_curcop);
4366 LOP(OP_INDEX,XTERM);
4372 LOP(OP_IOCTL,XTERM);
4384 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4416 LOP(OP_LISTEN,XTERM);
4425 s = scan_pat(s,OP_MATCH);
4426 TERM(sublex_start());
4429 LOP(OP_MAPSTART, XREF);
4432 LOP(OP_MKDIR,XTERM);
4435 LOP(OP_MSGCTL,XTERM);
4438 LOP(OP_MSGGET,XTERM);
4441 LOP(OP_MSGRCV,XTERM);
4444 LOP(OP_MSGSND,XTERM);
4450 if (isIDFIRST_lazy_if(s,UTF)) {
4451 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
4452 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
4454 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
4455 if (!PL_in_my_stash) {
4458 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
4466 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4473 if (PL_expect != XSTATE)
4474 yyerror("\"no\" not allowed in expression");
4475 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4476 s = force_version(s);
4481 if (*s == '(' || (s = skipspace(s), *s == '('))
4488 if (isIDFIRST_lazy_if(s,UTF)) {
4490 for (d = s; isALNUM_lazy_if(d,UTF); d++) ;
4492 if (strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE))
4493 Perl_warner(aTHX_ WARN_PRECEDENCE,
4494 "Precedence problem: open %.*s should be open(%.*s)",
4500 yylval.ival = OP_OR;
4510 LOP(OP_OPEN_DIR,XTERM);
4513 checkcomma(s,PL_tokenbuf,"filehandle");
4517 checkcomma(s,PL_tokenbuf,"filehandle");
4536 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4540 LOP(OP_PIPE_OP,XTERM);
4543 s = scan_str(s,FALSE,FALSE);
4545 missingterm((char*)0);
4546 yylval.ival = OP_CONST;
4547 TERM(sublex_start());
4553 s = scan_str(s,FALSE,FALSE);
4555 missingterm((char*)0);
4557 if (SvCUR(PL_lex_stuff)) {
4560 d = SvPV_force(PL_lex_stuff, len);
4562 for (; isSPACE(*d) && len; --len, ++d) ;
4565 if (!warned && ckWARN(WARN_QW)) {
4566 for (; !isSPACE(*d) && len; --len, ++d) {
4568 Perl_warner(aTHX_ WARN_QW,
4569 "Possible attempt to separate words with commas");
4572 else if (*d == '#') {
4573 Perl_warner(aTHX_ WARN_QW,
4574 "Possible attempt to put comments in qw() list");
4580 for (; !isSPACE(*d) && len; --len, ++d) ;
4582 words = append_elem(OP_LIST, words,
4583 newSVOP(OP_CONST, 0, tokeq(newSVpvn(b, d-b))));
4587 PL_nextval[PL_nexttoke].opval = words;
4592 SvREFCNT_dec(PL_lex_stuff);
4593 PL_lex_stuff = Nullsv;
4598 s = scan_str(s,FALSE,FALSE);
4600 missingterm((char*)0);
4601 yylval.ival = OP_STRINGIFY;
4602 if (SvIVX(PL_lex_stuff) == '\'')
4603 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
4604 TERM(sublex_start());
4607 s = scan_pat(s,OP_QR);
4608 TERM(sublex_start());
4611 s = scan_str(s,FALSE,FALSE);
4613 missingterm((char*)0);
4614 yylval.ival = OP_BACKTICK;
4616 TERM(sublex_start());
4623 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4624 s = force_version(s);
4627 *PL_tokenbuf = '\0';
4628 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4629 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
4630 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
4632 yyerror("<> should be quotes");
4640 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4644 LOP(OP_RENAME,XTERM);
4653 LOP(OP_RINDEX,XTERM);
4676 LOP(OP_REVERSE,XTERM);
4687 TERM(sublex_start());
4689 TOKEN(1); /* force error */
4698 LOP(OP_SELECT,XTERM);
4704 LOP(OP_SEMCTL,XTERM);
4707 LOP(OP_SEMGET,XTERM);
4710 LOP(OP_SEMOP,XTERM);
4716 LOP(OP_SETPGRP,XTERM);
4718 case KEY_setpriority:
4719 LOP(OP_SETPRIORITY,XTERM);
4721 case KEY_sethostent:
4727 case KEY_setservent:
4730 case KEY_setprotoent:
4740 LOP(OP_SEEKDIR,XTERM);
4742 case KEY_setsockopt:
4743 LOP(OP_SSOCKOPT,XTERM);
4749 LOP(OP_SHMCTL,XTERM);
4752 LOP(OP_SHMGET,XTERM);
4755 LOP(OP_SHMREAD,XTERM);
4758 LOP(OP_SHMWRITE,XTERM);
4761 LOP(OP_SHUTDOWN,XTERM);
4770 LOP(OP_SOCKET,XTERM);
4772 case KEY_socketpair:
4773 LOP(OP_SOCKPAIR,XTERM);
4776 checkcomma(s,PL_tokenbuf,"subroutine name");
4778 if (*s == ';' || *s == ')') /* probably a close */
4779 Perl_croak(aTHX_ "sort is now a reserved word");
4781 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4785 LOP(OP_SPLIT,XTERM);
4788 LOP(OP_SPRINTF,XTERM);
4791 LOP(OP_SPLICE,XTERM);
4806 LOP(OP_SUBSTR,XTERM);
4812 char tmpbuf[sizeof PL_tokenbuf];
4814 expectation attrful;
4815 bool have_name, have_proto;
4820 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
4821 (*s == ':' && s[1] == ':'))
4824 attrful = XATTRBLOCK;
4825 /* remember buffer pos'n for later force_word */
4826 tboffset = s - PL_oldbufptr;
4827 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4828 if (strchr(tmpbuf, ':'))
4829 sv_setpv(PL_subname, tmpbuf);
4831 sv_setsv(PL_subname,PL_curstname);
4832 sv_catpvn(PL_subname,"::",2);
4833 sv_catpvn(PL_subname,tmpbuf,len);
4840 Perl_croak(aTHX_ "Missing name in \"my sub\"");
4841 PL_expect = XTERMBLOCK;
4842 attrful = XATTRTERM;
4843 sv_setpv(PL_subname,"?");
4847 if (key == KEY_format) {
4849 PL_lex_formbrack = PL_lex_brackets + 1;
4851 (void) force_word(PL_oldbufptr + tboffset, WORD,
4856 /* Look for a prototype */
4860 s = scan_str(s,FALSE,FALSE);
4863 SvREFCNT_dec(PL_lex_stuff);
4864 PL_lex_stuff = Nullsv;
4865 Perl_croak(aTHX_ "Prototype not terminated");
4868 d = SvPVX(PL_lex_stuff);
4870 for (p = d; *p; ++p) {
4875 SvCUR(PL_lex_stuff) = tmp;
4883 if (*s == ':' && s[1] != ':')
4884 PL_expect = attrful;
4887 PL_nextval[PL_nexttoke].opval =
4888 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4889 PL_lex_stuff = Nullsv;
4893 sv_setpv(PL_subname,"__ANON__");
4896 (void) force_word(PL_oldbufptr + tboffset, WORD,
4905 LOP(OP_SYSTEM,XREF);
4908 LOP(OP_SYMLINK,XTERM);
4911 LOP(OP_SYSCALL,XTERM);
4914 LOP(OP_SYSOPEN,XTERM);
4917 LOP(OP_SYSSEEK,XTERM);
4920 LOP(OP_SYSREAD,XTERM);
4923 LOP(OP_SYSWRITE,XTERM);
4927 TERM(sublex_start());
4948 LOP(OP_TRUNCATE,XTERM);
4960 yylval.ival = CopLINE(PL_curcop);
4964 yylval.ival = CopLINE(PL_curcop);
4968 LOP(OP_UNLINK,XTERM);
4974 LOP(OP_UNPACK,XTERM);
4977 LOP(OP_UTIME,XTERM);
4980 if (ckWARN(WARN_UMASK)) {
4981 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4982 if (*d != '0' && isDIGIT(*d))
4983 Perl_warner(aTHX_ WARN_UMASK,
4984 "umask: argument is missing initial 0");
4989 LOP(OP_UNSHIFT,XTERM);
4992 if (PL_expect != XSTATE)
4993 yyerror("\"use\" not allowed in expression");
4995 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4996 s = force_version(s);
4997 if (*s == ';' || (s = skipspace(s), *s == ';')) {
4998 PL_nextval[PL_nexttoke].opval = Nullop;
5003 s = force_word(s,WORD,FALSE,TRUE,FALSE);
5004 s = force_version(s);
5016 yylval.ival = CopLINE(PL_curcop);
5020 PL_hints |= HINT_BLOCK_SCOPE;
5027 LOP(OP_WAITPID,XTERM);
5035 static char ctl_l[2];
5037 if (ctl_l[0] == '\0')
5038 ctl_l[0] = toCTRL('L');
5039 gv_fetchpv(ctl_l,TRUE, SVt_PV);
5042 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
5047 if (PL_expect == XOPERATOR)
5053 yylval.ival = OP_XOR;
5058 TERM(sublex_start());
5063 #pragma segment Main
5067 Perl_keyword(pTHX_ register char *d, I32 len)
5072 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
5073 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
5074 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
5075 if (strEQ(d,"__DATA__")) return KEY___DATA__;
5076 if (strEQ(d,"__END__")) return KEY___END__;
5080 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
5085 if (strEQ(d,"and")) return -KEY_and;
5086 if (strEQ(d,"abs")) return -KEY_abs;
5089 if (strEQ(d,"alarm")) return -KEY_alarm;
5090 if (strEQ(d,"atan2")) return -KEY_atan2;
5093 if (strEQ(d,"accept")) return -KEY_accept;
5098 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
5101 if (strEQ(d,"bless")) return -KEY_bless;
5102 if (strEQ(d,"bind")) return -KEY_bind;
5103 if (strEQ(d,"binmode")) return -KEY_binmode;
5106 if (strEQ(d,"CORE")) return -KEY_CORE;
5107 if (strEQ(d,"CHECK")) return KEY_CHECK;
5112 if (strEQ(d,"cmp")) return -KEY_cmp;
5113 if (strEQ(d,"chr")) return -KEY_chr;
5114 if (strEQ(d,"cos")) return -KEY_cos;
5117 if (strEQ(d,"chop")) return KEY_chop;
5120 if (strEQ(d,"close")) return -KEY_close;
5121 if (strEQ(d,"chdir")) return -KEY_chdir;
5122 if (strEQ(d,"chomp")) return KEY_chomp;
5123 if (strEQ(d,"chmod")) return -KEY_chmod;
5124 if (strEQ(d,"chown")) return -KEY_chown;
5125 if (strEQ(d,"crypt")) return -KEY_crypt;
5128 if (strEQ(d,"chroot")) return -KEY_chroot;
5129 if (strEQ(d,"caller")) return -KEY_caller;
5132 if (strEQ(d,"connect")) return -KEY_connect;
5135 if (strEQ(d,"closedir")) return -KEY_closedir;
5136 if (strEQ(d,"continue")) return -KEY_continue;
5141 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
5146 if (strEQ(d,"do")) return KEY_do;
5149 if (strEQ(d,"die")) return -KEY_die;
5152 if (strEQ(d,"dump")) return -KEY_dump;
5155 if (strEQ(d,"delete")) return KEY_delete;
5158 if (strEQ(d,"defined")) return KEY_defined;
5159 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
5162 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
5167 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
5168 if (strEQ(d,"END")) return KEY_END;
5173 if (strEQ(d,"eq")) return -KEY_eq;
5176 if (strEQ(d,"eof")) return -KEY_eof;
5177 if (strEQ(d,"exp")) return -KEY_exp;
5180 if (strEQ(d,"else")) return KEY_else;
5181 if (strEQ(d,"exit")) return -KEY_exit;
5182 if (strEQ(d,"eval")) return KEY_eval;
5183 if (strEQ(d,"exec")) return -KEY_exec;
5184 if (strEQ(d,"each")) return KEY_each;
5187 if (strEQ(d,"elsif")) return KEY_elsif;
5190 if (strEQ(d,"exists")) return KEY_exists;
5191 if (strEQ(d,"elseif")) Perl_warn(aTHX_ "elseif should be elsif");
5194 if (strEQ(d,"endgrent")) return -KEY_endgrent;
5195 if (strEQ(d,"endpwent")) return -KEY_endpwent;
5198 if (strEQ(d,"endnetent")) return -KEY_endnetent;
5201 if (strEQ(d,"endhostent")) return -KEY_endhostent;
5202 if (strEQ(d,"endservent")) return -KEY_endservent;
5205 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
5212 if (strEQ(d,"for")) return KEY_for;
5215 if (strEQ(d,"fork")) return -KEY_fork;
5218 if (strEQ(d,"fcntl")) return -KEY_fcntl;
5219 if (strEQ(d,"flock")) return -KEY_flock;
5222 if (strEQ(d,"format")) return KEY_format;
5223 if (strEQ(d,"fileno")) return -KEY_fileno;
5226 if (strEQ(d,"foreach")) return KEY_foreach;
5229 if (strEQ(d,"formline")) return -KEY_formline;
5235 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
5236 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
5240 if (strnEQ(d,"get",3)) {
5245 if (strEQ(d,"ppid")) return -KEY_getppid;
5246 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
5249 if (strEQ(d,"pwent")) return -KEY_getpwent;
5250 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
5251 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
5254 if (strEQ(d,"peername")) return -KEY_getpeername;
5255 if (strEQ(d,"protoent")) return -KEY_getprotoent;
5256 if (strEQ(d,"priority")) return -KEY_getpriority;
5259 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
5262 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
5266 else if (*d == 'h') {
5267 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
5268 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
5269 if (strEQ(d,"hostent")) return -KEY_gethostent;
5271 else if (*d == 'n') {
5272 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
5273 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
5274 if (strEQ(d,"netent")) return -KEY_getnetent;
5276 else if (*d == 's') {
5277 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
5278 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
5279 if (strEQ(d,"servent")) return -KEY_getservent;
5280 if (strEQ(d,"sockname")) return -KEY_getsockname;
5281 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
5283 else if (*d == 'g') {
5284 if (strEQ(d,"grent")) return -KEY_getgrent;
5285 if (strEQ(d,"grnam")) return -KEY_getgrnam;
5286 if (strEQ(d,"grgid")) return -KEY_getgrgid;
5288 else if (*d == 'l') {
5289 if (strEQ(d,"login")) return -KEY_getlogin;
5291 else if (strEQ(d,"c")) return -KEY_getc;
5296 if (strEQ(d,"gt")) return -KEY_gt;
5297 if (strEQ(d,"ge")) return -KEY_ge;
5300 if (strEQ(d,"grep")) return KEY_grep;
5301 if (strEQ(d,"goto")) return KEY_goto;
5302 if (strEQ(d,"glob")) return KEY_glob;
5305 if (strEQ(d,"gmtime")) return -KEY_gmtime;
5310 if (strEQ(d,"hex")) return -KEY_hex;
5313 if (strEQ(d,"INIT")) return KEY_INIT;
5318 if (strEQ(d,"if")) return KEY_if;
5321 if (strEQ(d,"int")) return -KEY_int;
5324 if (strEQ(d,"index")) return -KEY_index;
5325 if (strEQ(d,"ioctl")) return -KEY_ioctl;
5330 if (strEQ(d,"join")) return -KEY_join;
5334 if (strEQ(d,"keys")) return KEY_keys;
5335 if (strEQ(d,"kill")) return -KEY_kill;
5340 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
5341 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
5347 if (strEQ(d,"lt")) return -KEY_lt;
5348 if (strEQ(d,"le")) return -KEY_le;
5349 if (strEQ(d,"lc")) return -KEY_lc;
5352 if (strEQ(d,"log")) return -KEY_log;
5355 if (strEQ(d,"last")) return KEY_last;
5356 if (strEQ(d,"link")) return -KEY_link;
5357 if (strEQ(d,"lock")) return -KEY_lock;
5360 if (strEQ(d,"local")) return KEY_local;
5361 if (strEQ(d,"lstat")) return -KEY_lstat;
5364 if (strEQ(d,"length")) return -KEY_length;
5365 if (strEQ(d,"listen")) return -KEY_listen;
5368 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
5371 if (strEQ(d,"localtime")) return -KEY_localtime;
5377 case 1: return KEY_m;
5379 if (strEQ(d,"my")) return KEY_my;
5382 if (strEQ(d,"map")) return KEY_map;
5385 if (strEQ(d,"mkdir")) return -KEY_mkdir;
5388 if (strEQ(d,"msgctl")) return -KEY_msgctl;
5389 if (strEQ(d,"msgget")) return -KEY_msgget;
5390 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
5391 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
5396 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
5399 if (strEQ(d,"next")) return KEY_next;
5400 if (strEQ(d,"ne")) return -KEY_ne;
5401 if (strEQ(d,"not")) return -KEY_not;
5402 if (strEQ(d,"no")) return KEY_no;
5407 if (strEQ(d,"or")) return -KEY_or;
5410 if (strEQ(d,"ord")) return -KEY_ord;
5411 if (strEQ(d,"oct")) return -KEY_oct;
5412 if (strEQ(d,"our")) return KEY_our;
5415 if (strEQ(d,"open")) return -KEY_open;
5418 if (strEQ(d,"opendir")) return -KEY_opendir;
5425 if (strEQ(d,"pop")) return KEY_pop;
5426 if (strEQ(d,"pos")) return KEY_pos;
5429 if (strEQ(d,"push")) return KEY_push;
5430 if (strEQ(d,"pack")) return -KEY_pack;
5431 if (strEQ(d,"pipe")) return -KEY_pipe;
5434 if (strEQ(d,"print")) return KEY_print;
5437 if (strEQ(d,"printf")) return KEY_printf;
5440 if (strEQ(d,"package")) return KEY_package;
5443 if (strEQ(d,"prototype")) return KEY_prototype;
5448 if (strEQ(d,"q")) return KEY_q;
5449 if (strEQ(d,"qr")) return KEY_qr;
5450 if (strEQ(d,"qq")) return KEY_qq;
5451 if (strEQ(d,"qw")) return KEY_qw;
5452 if (strEQ(d,"qx")) return KEY_qx;
5454 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
5459 if (strEQ(d,"ref")) return -KEY_ref;
5462 if (strEQ(d,"read")) return -KEY_read;
5463 if (strEQ(d,"rand")) return -KEY_rand;
5464 if (strEQ(d,"recv")) return -KEY_recv;
5465 if (strEQ(d,"redo")) return KEY_redo;
5468 if (strEQ(d,"rmdir")) return -KEY_rmdir;
5469 if (strEQ(d,"reset")) return -KEY_reset;
5472 if (strEQ(d,"return")) return KEY_return;
5473 if (strEQ(d,"rename")) return -KEY_rename;
5474 if (strEQ(d,"rindex")) return -KEY_rindex;
5477 if (strEQ(d,"require")) return -KEY_require;
5478 if (strEQ(d,"reverse")) return -KEY_reverse;
5479 if (strEQ(d,"readdir")) return -KEY_readdir;
5482 if (strEQ(d,"readlink")) return -KEY_readlink;
5483 if (strEQ(d,"readline")) return -KEY_readline;
5484 if (strEQ(d,"readpipe")) return -KEY_readpipe;
5487 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
5493 case 0: return KEY_s;
5495 if (strEQ(d,"scalar")) return KEY_scalar;
5500 if (strEQ(d,"seek")) return -KEY_seek;
5501 if (strEQ(d,"send")) return -KEY_send;
5504 if (strEQ(d,"semop")) return -KEY_semop;
5507 if (strEQ(d,"select")) return -KEY_select;
5508 if (strEQ(d,"semctl")) return -KEY_semctl;
5509 if (strEQ(d,"semget")) return -KEY_semget;
5512 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
5513 if (strEQ(d,"seekdir")) return -KEY_seekdir;
5516 if (strEQ(d,"setpwent")) return -KEY_setpwent;
5517 if (strEQ(d,"setgrent")) return -KEY_setgrent;
5520 if (strEQ(d,"setnetent")) return -KEY_setnetent;
5523 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
5524 if (strEQ(d,"sethostent")) return -KEY_sethostent;
5525 if (strEQ(d,"setservent")) return -KEY_setservent;
5528 if (strEQ(d,"setpriority")) return -KEY_setpriority;
5529 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
5536 if (strEQ(d,"shift")) return KEY_shift;
5539 if (strEQ(d,"shmctl")) return -KEY_shmctl;
5540 if (strEQ(d,"shmget")) return -KEY_shmget;
5543 if (strEQ(d,"shmread")) return -KEY_shmread;
5546 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
5547 if (strEQ(d,"shutdown")) return -KEY_shutdown;
5552 if (strEQ(d,"sin")) return -KEY_sin;
5555 if (strEQ(d,"sleep")) return -KEY_sleep;
5558 if (strEQ(d,"sort")) return KEY_sort;
5559 if (strEQ(d,"socket")) return -KEY_socket;
5560 if (strEQ(d,"socketpair")) return -KEY_socketpair;
5563 if (strEQ(d,"split")) return KEY_split;
5564 if (strEQ(d,"sprintf")) return -KEY_sprintf;
5565 if (strEQ(d,"splice")) return KEY_splice;
5568 if (strEQ(d,"sqrt")) return -KEY_sqrt;
5571 if (strEQ(d,"srand")) return -KEY_srand;
5574 if (strEQ(d,"stat")) return -KEY_stat;
5575 if (strEQ(d,"study")) return KEY_study;
5578 if (strEQ(d,"substr")) return -KEY_substr;
5579 if (strEQ(d,"sub")) return KEY_sub;
5584 if (strEQ(d,"system")) return -KEY_system;
5587 if (strEQ(d,"symlink")) return -KEY_symlink;
5588 if (strEQ(d,"syscall")) return -KEY_syscall;
5589 if (strEQ(d,"sysopen")) return -KEY_sysopen;
5590 if (strEQ(d,"sysread")) return -KEY_sysread;
5591 if (strEQ(d,"sysseek")) return -KEY_sysseek;
5594 if (strEQ(d,"syswrite")) return -KEY_syswrite;
5603 if (strEQ(d,"tr")) return KEY_tr;
5606 if (strEQ(d,"tie")) return KEY_tie;
5609 if (strEQ(d,"tell")) return -KEY_tell;
5610 if (strEQ(d,"tied")) return KEY_tied;
5611 if (strEQ(d,"time")) return -KEY_time;
5614 if (strEQ(d,"times")) return -KEY_times;
5617 if (strEQ(d,"telldir")) return -KEY_telldir;
5620 if (strEQ(d,"truncate")) return -KEY_truncate;
5627 if (strEQ(d,"uc")) return -KEY_uc;
5630 if (strEQ(d,"use")) return KEY_use;
5633 if (strEQ(d,"undef")) return KEY_undef;
5634 if (strEQ(d,"until")) return KEY_until;
5635 if (strEQ(d,"untie")) return KEY_untie;
5636 if (strEQ(d,"utime")) return -KEY_utime;
5637 if (strEQ(d,"umask")) return -KEY_umask;
5640 if (strEQ(d,"unless")) return KEY_unless;
5641 if (strEQ(d,"unpack")) return -KEY_unpack;
5642 if (strEQ(d,"unlink")) return -KEY_unlink;
5645 if (strEQ(d,"unshift")) return KEY_unshift;
5646 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
5651 if (strEQ(d,"values")) return -KEY_values;
5652 if (strEQ(d,"vec")) return -KEY_vec;
5657 if (strEQ(d,"warn")) return -KEY_warn;
5658 if (strEQ(d,"wait")) return -KEY_wait;
5661 if (strEQ(d,"while")) return KEY_while;
5662 if (strEQ(d,"write")) return -KEY_write;
5665 if (strEQ(d,"waitpid")) return -KEY_waitpid;
5668 if (strEQ(d,"wantarray")) return -KEY_wantarray;
5673 if (len == 1) return -KEY_x;
5674 if (strEQ(d,"xor")) return -KEY_xor;
5677 if (len == 1) return KEY_y;
5686 S_checkcomma(pTHX_ register char *s, char *name, char *what)
5690 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
5691 dTHR; /* only for ckWARN */
5692 if (ckWARN(WARN_SYNTAX)) {
5694 for (w = s+2; *w && level; w++) {
5701 for (; *w && isSPACE(*w); w++) ;
5702 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
5703 Perl_warner(aTHX_ WARN_SYNTAX,
5704 "%s (...) interpreted as function",name);
5707 while (s < PL_bufend && isSPACE(*s))
5711 while (s < PL_bufend && isSPACE(*s))
5713 if (isIDFIRST_lazy_if(s,UTF)) {
5715 while (isALNUM_lazy_if(s,UTF))
5717 while (s < PL_bufend && isSPACE(*s))
5722 kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
5726 Perl_croak(aTHX_ "No comma allowed after %s", what);
5731 /* Either returns sv, or mortalizes sv and returns a new SV*.
5732 Best used as sv=new_constant(..., sv, ...).
5733 If s, pv are NULL, calls subroutine with one argument,
5734 and type is used with error messages only. */
5737 S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv,
5741 HV *table = GvHV(PL_hintgv); /* ^H */
5745 const char *why1, *why2, *why3;
5747 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
5750 why1 = "%^H is not consistent";
5751 why2 = strEQ(key,"charnames")
5752 ? " (missing \"use charnames ...\"?)"
5756 msg = Perl_newSVpvf(aTHX_ "constant(%s): %s%s%s",
5757 (type ? type: "undef"), why1, why2, why3);
5758 yyerror(SvPVX(msg));
5762 cvp = hv_fetch(table, key, strlen(key), FALSE);
5763 if (!cvp || !SvOK(*cvp)) {
5766 why3 = "} is not defined";
5769 sv_2mortal(sv); /* Parent created it permanently */
5772 pv = sv_2mortal(newSVpvn(s, len));
5774 typesv = sv_2mortal(newSVpv(type, 0));
5776 typesv = &PL_sv_undef;
5778 PUSHSTACKi(PERLSI_OVERLOAD);
5791 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
5795 /* Check the eval first */
5796 if (!PL_in_eval && SvTRUE(ERRSV)) {
5798 sv_catpv(ERRSV, "Propagated");
5799 yyerror(SvPV(ERRSV, n_a)); /* Duplicates the message inside eval */
5801 res = SvREFCNT_inc(sv);
5805 (void)SvREFCNT_inc(res);
5814 why1 = "Call to &{$^H{";
5816 why3 = "}} did not return a defined value";
5825 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
5827 register char *d = dest;
5828 register char *e = d + destlen - 3; /* two-character token, ending NUL */
5831 Perl_croak(aTHX_ ident_too_long);
5832 if (isALNUM(*s)) /* UTF handled below */
5834 else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) {
5839 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
5843 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5844 char *t = s + UTF8SKIP(s);
5845 while (*t & 0x80 && is_utf8_mark((U8*)t))
5847 if (d + (t - s) > e)
5848 Perl_croak(aTHX_ ident_too_long);
5849 Copy(s, d, t - s, char);
5862 S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
5872 e = d + destlen - 3; /* two-character token, ending NUL */
5874 while (isDIGIT(*s)) {
5876 Perl_croak(aTHX_ ident_too_long);
5883 Perl_croak(aTHX_ ident_too_long);
5884 if (isALNUM(*s)) /* UTF handled below */
5886 else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
5891 else if (*s == ':' && s[1] == ':') {
5895 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5896 char *t = s + UTF8SKIP(s);
5897 while (*t & 0x80 && is_utf8_mark((U8*)t))
5899 if (d + (t - s) > e)
5900 Perl_croak(aTHX_ ident_too_long);
5901 Copy(s, d, t - s, char);
5912 if (PL_lex_state != LEX_NORMAL)
5913 PL_lex_state = LEX_INTERPENDMAYBE;
5916 if (*s == '$' && s[1] &&
5917 (isALNUM_lazy_if(s+1,UTF) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
5930 if (*d == '^' && *s && isCONTROLVAR(*s)) {
5935 if (isSPACE(s[-1])) {
5938 if (!SPACE_OR_TAB(ch)) {
5944 if (isIDFIRST_lazy_if(d,UTF)) {
5948 while ((e < send && isALNUM_lazy_if(e,UTF)) || *e == ':') {
5950 while (e < send && *e & 0x80 && is_utf8_mark((U8*)e))
5953 Copy(s, d, e - s, char);
5958 while ((isALNUM(*s) || *s == ':') && d < e)
5961 Perl_croak(aTHX_ ident_too_long);
5964 while (s < send && SPACE_OR_TAB(*s)) s++;
5965 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
5966 dTHR; /* only for ckWARN */
5967 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
5968 const char *brack = *s == '[' ? "[...]" : "{...}";
5969 Perl_warner(aTHX_ WARN_AMBIGUOUS,
5970 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
5971 funny, dest, brack, funny, dest, brack);
5974 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
5978 /* Handle extended ${^Foo} variables
5979 * 1999-02-27 mjd-perl-patch@plover.com */
5980 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
5984 while (isALNUM(*s) && d < e) {
5988 Perl_croak(aTHX_ ident_too_long);
5993 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
5994 PL_lex_state = LEX_INTERPEND;
5997 if (PL_lex_state == LEX_NORMAL) {
5998 dTHR; /* only for ckWARN */
5999 if (ckWARN(WARN_AMBIGUOUS) &&
6000 (keyword(dest, d - dest) || get_cv(dest, FALSE)))
6002 Perl_warner(aTHX_ WARN_AMBIGUOUS,
6003 "Ambiguous use of %c{%s} resolved to %c%s",
6004 funny, dest, funny, dest);
6009 s = bracket; /* let the parser handle it */
6013 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
6014 PL_lex_state = LEX_INTERPEND;
6019 Perl_pmflag(pTHX_ U16 *pmfl, int ch)
6024 *pmfl |= PMf_GLOBAL;
6026 *pmfl |= PMf_CONTINUE;
6030 *pmfl |= PMf_MULTILINE;
6032 *pmfl |= PMf_SINGLELINE;
6034 *pmfl |= PMf_EXTENDED;
6038 S_scan_pat(pTHX_ char *start, I32 type)
6043 s = scan_str(start,FALSE,FALSE);
6046 SvREFCNT_dec(PL_lex_stuff);
6047 PL_lex_stuff = Nullsv;
6048 Perl_croak(aTHX_ "Search pattern not terminated");
6051 pm = (PMOP*)newPMOP(type, 0);
6052 if (PL_multi_open == '?')
6053 pm->op_pmflags |= PMf_ONCE;
6055 while (*s && strchr("iomsx", *s))
6056 pmflag(&pm->op_pmflags,*s++);
6059 while (*s && strchr("iogcmsx", *s))
6060 pmflag(&pm->op_pmflags,*s++);
6062 pm->op_pmpermflags = pm->op_pmflags;
6064 PL_lex_op = (OP*)pm;
6065 yylval.ival = OP_MATCH;
6070 S_scan_subst(pTHX_ char *start)
6077 yylval.ival = OP_NULL;
6079 s = scan_str(start,FALSE,FALSE);
6083 SvREFCNT_dec(PL_lex_stuff);
6084 PL_lex_stuff = Nullsv;
6085 Perl_croak(aTHX_ "Substitution pattern not terminated");
6088 if (s[-1] == PL_multi_open)
6091 first_start = PL_multi_start;
6092 s = scan_str(s,FALSE,FALSE);
6095 SvREFCNT_dec(PL_lex_stuff);
6096 PL_lex_stuff = Nullsv;
6098 SvREFCNT_dec(PL_lex_repl);
6099 PL_lex_repl = Nullsv;
6100 Perl_croak(aTHX_ "Substitution replacement not terminated");
6102 PL_multi_start = first_start; /* so whole substitution is taken together */
6104 pm = (PMOP*)newPMOP(OP_SUBST, 0);
6110 else if (strchr("iogcmsx", *s))
6111 pmflag(&pm->op_pmflags,*s++);
6118 PL_sublex_info.super_bufptr = s;
6119 PL_sublex_info.super_bufend = PL_bufend;
6121 pm->op_pmflags |= PMf_EVAL;
6122 repl = newSVpvn("",0);
6124 sv_catpv(repl, es ? "eval " : "do ");
6125 sv_catpvn(repl, "{ ", 2);
6126 sv_catsv(repl, PL_lex_repl);
6127 sv_catpvn(repl, " };", 2);
6129 SvREFCNT_dec(PL_lex_repl);
6133 pm->op_pmpermflags = pm->op_pmflags;
6134 PL_lex_op = (OP*)pm;
6135 yylval.ival = OP_SUBST;
6140 S_scan_trans(pTHX_ char *start)
6151 yylval.ival = OP_NULL;
6153 s = scan_str(start,FALSE,FALSE);
6156 SvREFCNT_dec(PL_lex_stuff);
6157 PL_lex_stuff = Nullsv;
6158 Perl_croak(aTHX_ "Transliteration pattern not terminated");
6160 if (s[-1] == PL_multi_open)
6163 s = scan_str(s,FALSE,FALSE);
6166 SvREFCNT_dec(PL_lex_stuff);
6167 PL_lex_stuff = Nullsv;
6169 SvREFCNT_dec(PL_lex_repl);
6170 PL_lex_repl = Nullsv;
6171 Perl_croak(aTHX_ "Transliteration replacement not terminated");
6174 New(803,tbl,256,short);
6175 o = newPVOP(OP_TRANS, 0, (char*)tbl);
6177 complement = del = squash = 0;
6178 while (strchr("cds", *s)) {
6180 complement = OPpTRANS_COMPLEMENT;
6182 del = OPpTRANS_DELETE;
6184 squash = OPpTRANS_SQUASH;
6187 o->op_private = del|squash|complement;
6190 yylval.ival = OP_TRANS;
6195 S_scan_heredoc(pTHX_ register char *s)
6199 I32 op_type = OP_SCALAR;
6206 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
6210 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
6213 for (peek = s; SPACE_OR_TAB(*peek); peek++) ;
6214 if (*peek && strchr("`'\"",*peek)) {
6217 s = delimcpy(d, e, s, PL_bufend, term, &len);
6227 if (!isALNUM_lazy_if(s,UTF))
6228 deprecate("bare << to mean <<\"\"");
6229 for (; isALNUM_lazy_if(s,UTF); s++) {
6234 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
6235 Perl_croak(aTHX_ "Delimiter for here document is too long");
6238 len = d - PL_tokenbuf;
6239 #ifndef PERL_STRICT_CR
6240 d = strchr(s, '\r');
6244 while (s < PL_bufend) {
6250 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
6259 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6264 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
6265 herewas = newSVpvn(s,PL_bufend-s);
6267 s--, herewas = newSVpvn(s,d-s);
6268 s += SvCUR(herewas);
6270 tmpstr = NEWSV(87,79);
6271 sv_upgrade(tmpstr, SVt_PVIV);
6276 else if (term == '`') {
6277 op_type = OP_BACKTICK;
6278 SvIVX(tmpstr) = '\\';
6282 PL_multi_start = CopLINE(PL_curcop);
6283 PL_multi_open = PL_multi_close = '<';
6284 term = *PL_tokenbuf;
6285 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
6286 char *bufptr = PL_sublex_info.super_bufptr;
6287 char *bufend = PL_sublex_info.super_bufend;
6288 char *olds = s - SvCUR(herewas);
6289 s = strchr(bufptr, '\n');
6293 while (s < bufend &&
6294 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6296 CopLINE_inc(PL_curcop);
6299 CopLINE_set(PL_curcop, PL_multi_start);
6300 missingterm(PL_tokenbuf);
6302 sv_setpvn(herewas,bufptr,d-bufptr+1);
6303 sv_setpvn(tmpstr,d+1,s-d);
6305 sv_catpvn(herewas,s,bufend-s);
6306 (void)strcpy(bufptr,SvPVX(herewas));
6313 while (s < PL_bufend &&
6314 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6316 CopLINE_inc(PL_curcop);
6318 if (s >= PL_bufend) {
6319 CopLINE_set(PL_curcop, PL_multi_start);
6320 missingterm(PL_tokenbuf);
6322 sv_setpvn(tmpstr,d+1,s-d);
6324 CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
6326 sv_catpvn(herewas,s,PL_bufend-s);
6327 sv_setsv(PL_linestr,herewas);
6328 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
6329 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6332 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
6333 while (s >= PL_bufend) { /* multiple line string? */
6335 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6336 CopLINE_set(PL_curcop, PL_multi_start);
6337 missingterm(PL_tokenbuf);
6339 CopLINE_inc(PL_curcop);
6340 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6341 #ifndef PERL_STRICT_CR
6342 if (PL_bufend - PL_linestart >= 2) {
6343 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
6344 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
6346 PL_bufend[-2] = '\n';
6348 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6350 else if (PL_bufend[-1] == '\r')
6351 PL_bufend[-1] = '\n';
6353 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
6354 PL_bufend[-1] = '\n';
6356 if (PERLDB_LINE && PL_curstash != PL_debstash) {
6357 SV *sv = NEWSV(88,0);
6359 sv_upgrade(sv, SVt_PVMG);
6360 sv_setsv(sv,PL_linestr);
6361 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop),sv);
6363 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
6366 sv_catsv(PL_linestr,herewas);
6367 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6371 sv_catsv(tmpstr,PL_linestr);
6376 PL_multi_end = CopLINE(PL_curcop);
6377 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
6378 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
6379 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
6381 SvREFCNT_dec(herewas);
6382 PL_lex_stuff = tmpstr;
6383 yylval.ival = op_type;
6388 takes: current position in input buffer
6389 returns: new position in input buffer
6390 side-effects: yylval and lex_op are set.
6395 <FH> read from filehandle
6396 <pkg::FH> read from package qualified filehandle
6397 <pkg'FH> read from package qualified filehandle
6398 <$fh> read from filehandle in $fh
6404 S_scan_inputsymbol(pTHX_ char *start)
6406 register char *s = start; /* current position in buffer */
6412 d = PL_tokenbuf; /* start of temp holding space */
6413 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
6414 end = strchr(s, '\n');
6417 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
6419 /* die if we didn't have space for the contents of the <>,
6420 or if it didn't end, or if we see a newline
6423 if (len >= sizeof PL_tokenbuf)
6424 Perl_croak(aTHX_ "Excessively long <> operator");
6426 Perl_croak(aTHX_ "Unterminated <> operator");
6431 Remember, only scalar variables are interpreted as filehandles by
6432 this code. Anything more complex (e.g., <$fh{$num}>) will be
6433 treated as a glob() call.
6434 This code makes use of the fact that except for the $ at the front,
6435 a scalar variable and a filehandle look the same.
6437 if (*d == '$' && d[1]) d++;
6439 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
6440 while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
6443 /* If we've tried to read what we allow filehandles to look like, and
6444 there's still text left, then it must be a glob() and not a getline.
6445 Use scan_str to pull out the stuff between the <> and treat it
6446 as nothing more than a string.
6449 if (d - PL_tokenbuf != len) {
6450 yylval.ival = OP_GLOB;
6452 s = scan_str(start,FALSE,FALSE);
6454 Perl_croak(aTHX_ "Glob not terminated");
6458 /* we're in a filehandle read situation */
6461 /* turn <> into <ARGV> */
6463 (void)strcpy(d,"ARGV");
6465 /* if <$fh>, create the ops to turn the variable into a
6471 /* try to find it in the pad for this block, otherwise find
6472 add symbol table ops
6474 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
6475 OP *o = newOP(OP_PADSV, 0);
6477 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, o);
6480 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
6481 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
6482 newUNOP(OP_RV2SV, 0,
6483 newGVOP(OP_GV, 0, gv)));
6485 PL_lex_op->op_flags |= OPf_SPECIAL;
6486 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
6487 yylval.ival = OP_NULL;
6490 /* If it's none of the above, it must be a literal filehandle
6491 (<Foo::BAR> or <FOO>) so build a simple readline OP */
6493 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
6494 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
6495 yylval.ival = OP_NULL;
6504 takes: start position in buffer
6505 keep_quoted preserve \ on the embedded delimiter(s)
6506 keep_delims preserve the delimiters around the string
6507 returns: position to continue reading from buffer
6508 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
6509 updates the read buffer.
6511 This subroutine pulls a string out of the input. It is called for:
6512 q single quotes q(literal text)
6513 ' single quotes 'literal text'
6514 qq double quotes qq(interpolate $here please)
6515 " double quotes "interpolate $here please"
6516 qx backticks qx(/bin/ls -l)
6517 ` backticks `/bin/ls -l`
6518 qw quote words @EXPORT_OK = qw( func() $spam )
6519 m// regexp match m/this/
6520 s/// regexp substitute s/this/that/
6521 tr/// string transliterate tr/this/that/
6522 y/// string transliterate y/this/that/
6523 ($*@) sub prototypes sub foo ($)
6524 (stuff) sub attr parameters sub foo : attr(stuff)
6525 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
6527 In most of these cases (all but <>, patterns and transliterate)
6528 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
6529 calls scan_str(). s/// makes yylex() call scan_subst() which calls
6530 scan_str(). tr/// and y/// make yylex() call scan_trans() which
6533 It skips whitespace before the string starts, and treats the first
6534 character as the delimiter. If the delimiter is one of ([{< then
6535 the corresponding "close" character )]}> is used as the closing
6536 delimiter. It allows quoting of delimiters, and if the string has
6537 balanced delimiters ([{<>}]) it allows nesting.
6539 The lexer always reads these strings into lex_stuff, except in the
6540 case of the operators which take *two* arguments (s/// and tr///)
6541 when it checks to see if lex_stuff is full (presumably with the 1st
6542 arg to s or tr) and if so puts the string into lex_repl.
6547 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
6550 SV *sv; /* scalar value: string */
6551 char *tmps; /* temp string, used for delimiter matching */
6552 register char *s = start; /* current position in the buffer */
6553 register char term; /* terminating character */
6554 register char *to; /* current position in the sv's data */
6555 I32 brackets = 1; /* bracket nesting level */
6556 bool has_utf = FALSE; /* is there any utf8 content? */
6558 /* skip space before the delimiter */
6562 /* mark where we are, in case we need to report errors */
6565 /* after skipping whitespace, the next character is the terminator */
6567 if ((term & 0x80) && UTF)
6570 /* mark where we are */
6571 PL_multi_start = CopLINE(PL_curcop);
6572 PL_multi_open = term;
6574 /* find corresponding closing delimiter */
6575 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
6577 PL_multi_close = term;
6579 /* create a new SV to hold the contents. 87 is leak category, I'm
6580 assuming. 79 is the SV's initial length. What a random number. */
6582 sv_upgrade(sv, SVt_PVIV);
6584 (void)SvPOK_only(sv); /* validate pointer */
6586 /* move past delimiter and try to read a complete string */
6588 sv_catpvn(sv, s, 1);
6591 /* extend sv if need be */
6592 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
6593 /* set 'to' to the next character in the sv's string */
6594 to = SvPVX(sv)+SvCUR(sv);
6596 /* if open delimiter is the close delimiter read unbridle */
6597 if (PL_multi_open == PL_multi_close) {
6598 for (; s < PL_bufend; s++,to++) {
6599 /* embedded newlines increment the current line number */
6600 if (*s == '\n' && !PL_rsfp)
6601 CopLINE_inc(PL_curcop);
6602 /* handle quoted delimiters */
6603 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
6604 if (!keep_quoted && s[1] == term)
6606 /* any other quotes are simply copied straight through */
6610 /* terminate when run out of buffer (the for() condition), or
6611 have found the terminator */
6612 else if (*s == term)
6614 else if (!has_utf && (*s & 0x80) && UTF)
6620 /* if the terminator isn't the same as the start character (e.g.,
6621 matched brackets), we have to allow more in the quoting, and
6622 be prepared for nested brackets.
6625 /* read until we run out of string, or we find the terminator */
6626 for (; s < PL_bufend; s++,to++) {
6627 /* embedded newlines increment the line count */
6628 if (*s == '\n' && !PL_rsfp)
6629 CopLINE_inc(PL_curcop);
6630 /* backslashes can escape the open or closing characters */
6631 if (*s == '\\' && s+1 < PL_bufend) {
6633 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
6638 /* allow nested opens and closes */
6639 else if (*s == PL_multi_close && --brackets <= 0)
6641 else if (*s == PL_multi_open)
6643 else if (!has_utf && (*s & 0x80) && UTF)
6648 /* terminate the copied string and update the sv's end-of-string */
6650 SvCUR_set(sv, to - SvPVX(sv));
6653 * this next chunk reads more into the buffer if we're not done yet
6657 break; /* handle case where we are done yet :-) */
6659 #ifndef PERL_STRICT_CR
6660 if (to - SvPVX(sv) >= 2) {
6661 if ((to[-2] == '\r' && to[-1] == '\n') ||
6662 (to[-2] == '\n' && to[-1] == '\r'))
6666 SvCUR_set(sv, to - SvPVX(sv));
6668 else if (to[-1] == '\r')
6671 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
6675 /* if we're out of file, or a read fails, bail and reset the current
6676 line marker so we can report where the unterminated string began
6679 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6681 CopLINE_set(PL_curcop, PL_multi_start);
6684 /* we read a line, so increment our line counter */
6685 CopLINE_inc(PL_curcop);
6687 /* update debugger info */
6688 if (PERLDB_LINE && PL_curstash != PL_debstash) {
6689 SV *sv = NEWSV(88,0);
6691 sv_upgrade(sv, SVt_PVMG);
6692 sv_setsv(sv,PL_linestr);
6693 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop), sv);
6696 /* having changed the buffer, we must update PL_bufend */
6697 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6700 /* at this point, we have successfully read the delimited string */
6703 sv_catpvn(sv, s, 1);
6706 PL_multi_end = CopLINE(PL_curcop);
6709 /* if we allocated too much space, give some back */
6710 if (SvCUR(sv) + 5 < SvLEN(sv)) {
6711 SvLEN_set(sv, SvCUR(sv) + 1);
6712 Renew(SvPVX(sv), SvLEN(sv), char);
6715 /* decide whether this is the first or second quoted string we've read
6728 takes: pointer to position in buffer
6729 returns: pointer to new position in buffer
6730 side-effects: builds ops for the constant in yylval.op
6732 Read a number in any of the formats that Perl accepts:
6734 0(x[0-7A-F]+)|([0-7]+)|(b[01])
6735 [\d_]+(\.[\d_]*)?[Ee](\d+)
6737 Underbars (_) are allowed in decimal numbers. If -w is on,
6738 underbars before a decimal point must be at three digit intervals.
6740 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
6743 If it reads a number without a decimal point or an exponent, it will
6744 try converting the number to an integer and see if it can do so
6745 without loss of precision.
6749 Perl_scan_num(pTHX_ char *start)
6751 register char *s = start; /* current position in buffer */
6752 register char *d; /* destination in temp buffer */
6753 register char *e; /* end of temp buffer */
6754 NV nv; /* number read, as a double */
6755 SV *sv = Nullsv; /* place to put the converted number */
6756 bool floatit; /* boolean: int or float? */
6757 char *lastub = 0; /* position of last underbar */
6758 static char number_too_long[] = "Number too long";
6760 /* We use the first character to decide what type of number this is */
6764 Perl_croak(aTHX_ "panic: scan_num");
6766 /* if it starts with a 0, it could be an octal number, a decimal in
6767 0.13 disguise, or a hexadecimal number, or a binary number. */
6771 u holds the "number so far"
6772 shift the power of 2 of the base
6773 (hex == 4, octal == 3, binary == 1)
6774 overflowed was the number more than we can hold?
6776 Shift is used when we add a digit. It also serves as an "are
6777 we in octal/hex/binary?" indicator to disallow hex characters
6784 bool overflowed = FALSE;
6785 static NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
6786 static char* bases[5] = { "", "binary", "", "octal",
6788 static char* Bases[5] = { "", "Binary", "", "Octal",
6790 static char *maxima[5] = { "",
6791 "0b11111111111111111111111111111111",
6795 char *base, *Base, *max;
6801 } else if (s[1] == 'b') {
6805 /* check for a decimal in disguise */
6806 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
6808 /* so it must be octal */
6812 base = bases[shift];
6813 Base = Bases[shift];
6814 max = maxima[shift];
6816 /* read the rest of the number */
6818 /* x is used in the overflow test,
6819 b is the digit we're adding on. */
6824 /* if we don't mention it, we're done */
6833 /* 8 and 9 are not octal */
6836 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
6840 case '2': case '3': case '4':
6841 case '5': case '6': case '7':
6843 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
6847 b = *s++ & 15; /* ASCII digit -> value of digit */
6851 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
6852 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
6853 /* make sure they said 0x */
6858 /* Prepare to put the digit we have onto the end
6859 of the number so far. We check for overflows.
6864 x = u << shift; /* make room for the digit */
6866 if ((x >> shift) != u
6867 && !(PL_hints & HINT_NEW_BINARY)) {
6871 if (ckWARN_d(WARN_OVERFLOW))
6872 Perl_warner(aTHX_ WARN_OVERFLOW,
6873 "Integer overflow in %s number",
6876 u = x | b; /* add the digit to the end */
6879 n *= nvshift[shift];
6880 /* If an NV has not enough bits in its
6881 * mantissa to represent an UV this summing of
6882 * small low-order numbers is a waste of time
6883 * (because the NV cannot preserve the
6884 * low-order bits anyway): we could just
6885 * remember when did we overflow and in the
6886 * end just multiply n by the right
6894 /* if we get here, we had success: make a scalar value from
6901 if (ckWARN(WARN_PORTABLE) && n > 4294967295.0)
6902 Perl_warner(aTHX_ WARN_PORTABLE,
6903 "%s number > %s non-portable",
6910 if (ckWARN(WARN_PORTABLE) && u > 0xffffffff)
6911 Perl_warner(aTHX_ WARN_PORTABLE,
6912 "%s number > %s non-portable",
6917 if (PL_hints & HINT_NEW_BINARY)
6918 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
6923 handle decimal numbers.
6924 we're also sent here when we read a 0 as the first digit
6926 case '1': case '2': case '3': case '4': case '5':
6927 case '6': case '7': case '8': case '9': case '.':
6930 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
6933 /* read next group of digits and _ and copy into d */
6934 while (isDIGIT(*s) || *s == '_') {
6935 /* skip underscores, checking for misplaced ones
6939 dTHR; /* only for ckWARN */
6940 if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
6941 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
6945 /* check for end of fixed-length buffer */
6947 Perl_croak(aTHX_ number_too_long);
6948 /* if we're ok, copy the character */
6953 /* final misplaced underbar check */
6954 if (lastub && s - lastub != 3) {
6956 if (ckWARN(WARN_SYNTAX))
6957 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
6960 /* read a decimal portion if there is one. avoid
6961 3..5 being interpreted as the number 3. followed
6964 if (*s == '.' && s[1] != '.') {
6968 /* copy, ignoring underbars, until we run out of
6969 digits. Note: no misplaced underbar checks!
6971 for (; isDIGIT(*s) || *s == '_'; s++) {
6972 /* fixed length buffer check */
6974 Perl_croak(aTHX_ number_too_long);
6978 if (*s == '.' && isDIGIT(s[1])) {
6979 /* oops, it's really a v-string, but without the "v" */
6985 /* read exponent part, if present */
6986 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
6990 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
6991 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
6993 /* allow positive or negative exponent */
6994 if (*s == '+' || *s == '-')
6997 /* read digits of exponent (no underbars :-) */
6998 while (isDIGIT(*s)) {
7000 Perl_croak(aTHX_ number_too_long);
7005 /* terminate the string */
7008 /* make an sv from the string */
7011 #if defined(Strtol) && defined(Strtoul)
7014 strtol/strtoll sets errno to ERANGE if the number is too big
7015 for an integer. We try to do an integer conversion first
7016 if no characters indicating "float" have been found.
7023 if (*PL_tokenbuf == '-')
7024 iv = Strtol(PL_tokenbuf, (char**)NULL, 10);
7026 uv = Strtoul(PL_tokenbuf, (char**)NULL, 10);
7028 floatit = TRUE; /* Probably just too large. */
7029 else if (*PL_tokenbuf == '-')
7031 else if (uv <= IV_MAX)
7032 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
7037 nv = Atof(PL_tokenbuf);
7042 No working strtou?ll?.
7044 Unfortunately atol() doesn't do range checks (returning
7045 LONG_MIN/LONG_MAX, and setting errno to ERANGE on overflows)
7046 everywhere [1], so we cannot use use atol() (or atoll()).
7047 If we could, they would be used, as Atol(), very much like
7048 Strtol() and Strtoul() are used above.
7050 [1] XXX Configure test needed to check for atol()
7051 (and atoll()) overflow behaviour XXX
7055 We need to do this the hard way. */
7057 nv = Atof(PL_tokenbuf);
7059 /* See if we can make do with an integer value without loss of
7060 precision. We use U_V to cast to a UV, because some
7061 compilers have issues. Then we try casting it back and see
7062 if it was the same [1]. We only do this if we know we
7063 specifically read an integer. If floatit is true, then we
7064 don't need to do the conversion at all.
7066 [1] Note that this is lossy if our NVs cannot preserve our
7067 UVs. There are metaconfig defines NV_PRESERVES_UV (a boolean)
7068 and NV_PRESERVES_UV_BITS (a number), but in general we really
7069 do hope all such potentially lossy platforms have strtou?ll?
7070 to do a lossless IV/UV conversion.
7072 Maybe could do some tricks with DBL_DIG, LDBL_DIG and
7073 DBL_MANT_DIG and LDBL_MANT_DIG (these are already available
7074 as NV_DIG and NV_MANT_DIG)?
7080 if (!floatit && (NV)uv == nv) {
7082 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
7090 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
7091 (PL_hints & HINT_NEW_INTEGER) )
7092 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
7093 (floatit ? "float" : "integer"),
7097 /* if it starts with a v, it could be a v-string */
7103 while (isDIGIT(*pos) || *pos == '_')
7105 if (!isALPHA(*pos)) {
7107 U8 tmpbuf[UTF8_MAXLEN];
7110 s++; /* get past 'v' */
7113 sv_setpvn(sv, "", 0);
7116 if (*s == '0' && isDIGIT(s[1]))
7117 yyerror("Octal number in vector unsupported");
7120 /* this is atoi() that tolerates underscores */
7123 while (--end >= s) {
7128 rev += (*end - '0') * mult;
7130 if (orev > rev && ckWARN_d(WARN_OVERFLOW))
7131 Perl_warner(aTHX_ WARN_OVERFLOW,
7132 "Integer overflow in decimal number");
7135 tmpend = uv_to_utf8(tmpbuf, rev);
7136 utf8 = utf8 || rev > 127;
7137 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
7138 if (*pos == '.' && isDIGIT(pos[1]))
7144 while (isDIGIT(*pos) || *pos == '_')
7152 sv_utf8_downgrade(sv, TRUE);
7159 /* make the op for the constant and return */
7162 yylval.opval = newSVOP(OP_CONST, 0, sv);
7164 yylval.opval = Nullop;
7170 S_scan_formline(pTHX_ register char *s)
7175 SV *stuff = newSVpvn("",0);
7176 bool needargs = FALSE;
7179 if (*s == '.' || *s == '}') {
7181 #ifdef PERL_STRICT_CR
7182 for (t = s+1;SPACE_OR_TAB(*t); t++) ;
7184 for (t = s+1;SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
7186 if (*t == '\n' || t == PL_bufend)
7189 if (PL_in_eval && !PL_rsfp) {
7190 eol = strchr(s,'\n');
7195 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7197 for (t = s; t < eol; t++) {
7198 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
7200 goto enough; /* ~~ must be first line in formline */
7202 if (*t == '@' || *t == '^')
7205 sv_catpvn(stuff, s, eol-s);
7206 #ifndef PERL_STRICT_CR
7207 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
7208 char *end = SvPVX(stuff) + SvCUR(stuff);
7217 s = filter_gets(PL_linestr, PL_rsfp, 0);
7218 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
7219 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
7222 yyerror("Format not terminated");
7232 PL_lex_state = LEX_NORMAL;
7233 PL_nextval[PL_nexttoke].ival = 0;
7237 PL_lex_state = LEX_FORMLINE;
7238 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
7240 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
7244 SvREFCNT_dec(stuff);
7245 PL_lex_formbrack = 0;
7256 PL_cshlen = strlen(PL_cshname);
7261 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
7264 I32 oldsavestack_ix = PL_savestack_ix;
7265 CV* outsidecv = PL_compcv;
7269 assert(SvTYPE(PL_compcv) == SVt_PVCV);
7271 SAVEI32(PL_subline);
7272 save_item(PL_subname);
7275 SAVESPTR(PL_comppad_name);
7276 SAVESPTR(PL_compcv);
7277 SAVEI32(PL_comppad_name_fill);
7278 SAVEI32(PL_min_intro_pending);
7279 SAVEI32(PL_max_intro_pending);
7280 SAVEI32(PL_pad_reset_pending);
7282 PL_compcv = (CV*)NEWSV(1104,0);
7283 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
7284 CvFLAGS(PL_compcv) |= flags;
7286 PL_comppad = newAV();
7287 av_push(PL_comppad, Nullsv);
7288 PL_curpad = AvARRAY(PL_comppad);
7289 PL_comppad_name = newAV();
7290 PL_comppad_name_fill = 0;
7291 PL_min_intro_pending = 0;
7293 PL_subline = CopLINE(PL_curcop);
7295 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
7296 PL_curpad[0] = (SV*)newAV();
7297 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
7298 #endif /* USE_THREADS */
7300 comppadlist = newAV();
7301 AvREAL_off(comppadlist);
7302 av_store(comppadlist, 0, (SV*)PL_comppad_name);
7303 av_store(comppadlist, 1, (SV*)PL_comppad);
7305 CvPADLIST(PL_compcv) = comppadlist;
7306 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
7308 CvOWNER(PL_compcv) = 0;
7309 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
7310 MUTEX_INIT(CvMUTEXP(PL_compcv));
7311 #endif /* USE_THREADS */
7313 return oldsavestack_ix;
7317 Perl_yywarn(pTHX_ char *s)
7320 PL_in_eval |= EVAL_WARNONLY;
7322 PL_in_eval &= ~EVAL_WARNONLY;
7327 Perl_yyerror(pTHX_ char *s)
7331 char *context = NULL;
7335 if (!yychar || (yychar == ';' && !PL_rsfp))
7337 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
7338 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
7339 while (isSPACE(*PL_oldoldbufptr))
7341 context = PL_oldoldbufptr;
7342 contlen = PL_bufptr - PL_oldoldbufptr;
7344 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
7345 PL_oldbufptr != PL_bufptr) {
7346 while (isSPACE(*PL_oldbufptr))
7348 context = PL_oldbufptr;
7349 contlen = PL_bufptr - PL_oldbufptr;
7351 else if (yychar > 255)
7352 where = "next token ???";
7353 #ifdef USE_PURE_BISON
7354 /* GNU Bison sets the value -2 */
7355 else if (yychar == -2) {
7357 else if ((yychar & 127) == 127) {
7359 if (PL_lex_state == LEX_NORMAL ||
7360 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
7361 where = "at end of line";
7362 else if (PL_lex_inpat)
7363 where = "within pattern";
7365 where = "within string";
7368 SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
7370 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
7371 else if (isPRINT_LC(yychar))
7372 Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
7374 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
7375 where = SvPVX(where_sv);
7377 msg = sv_2mortal(newSVpv(s, 0));
7378 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
7379 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
7381 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
7383 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
7384 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
7385 Perl_sv_catpvf(aTHX_ msg,
7386 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
7387 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
7390 if (PL_in_eval & EVAL_WARNONLY)
7391 Perl_warn(aTHX_ "%"SVf, msg);
7394 if (PL_error_count >= 10) {
7395 if (PL_in_eval && SvCUR(ERRSV))
7396 Perl_croak(aTHX_ "%_%s has too many errors.\n",
7397 ERRSV, CopFILE(PL_curcop));
7399 Perl_croak(aTHX_ "%s has too many errors.\n",
7400 CopFILE(PL_curcop));
7403 PL_in_my_stash = Nullhv;
7409 S_swallow_bom(pTHX_ char *s) {
7411 slen = SvCUR(PL_linestr);
7414 if ((s[1] & 255) == 254) {
7415 /* UTF-16 little-endian */
7416 #ifdef PERL_UTF16_FILTER
7420 if (*s == 0 && s[1] == 0) /* UTF-32 little-endian */
7421 Perl_croak(aTHX_ "Unsupported script encoding");
7422 #ifdef PERL_UTF16_FILTER
7423 filter_add(S_utf16rev_textfilter, NULL);
7424 New(898, news, (PL_bufend - s) * 3 / 2 + 1, U8);
7425 PL_bufend = utf16_to_utf8((U16*)s, news, PL_bufend - s);
7428 Perl_croak(aTHX_ "Unsupported script encoding");
7434 if ((s[1] & 255) == 255) { /* UTF-16 big-endian */
7435 #ifdef PERL_UTF16_FILTER
7437 filter_add(S_utf16_textfilter, NULL);
7438 New(898, news, (PL_bufend - s) * 3 / 2 + 1, U8);
7439 PL_bufend = utf16_to_utf8((U16*)s, news, PL_bufend - s);
7442 Perl_croak(aTHX_ "Unsupported script encoding");
7448 if ( slen>2 && (s[1] & 255) == 187 && (s[2] & 255) == 191) {
7453 if (slen > 3 && s[1] == 0 && /* UTF-32 big-endian */
7454 s[2] & 255 == 254 && s[3] & 255 == 255)
7455 Perl_croak(aTHX_ "Unsupported script encoding");
7466 * Restore a source filter.
7470 restore_rsfp(pTHXo_ void *f)
7472 PerlIO *fp = (PerlIO*)f;
7474 if (PL_rsfp == PerlIO_stdin())
7475 PerlIO_clearerr(PL_rsfp);
7476 else if (PL_rsfp && (PL_rsfp != fp))
7477 PerlIO_close(PL_rsfp);