3 * Copyright (c) 1991-1997, 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
18 static void check_uni _((void));
19 static void force_next _((I32 type));
20 static char *force_version _((char *start));
21 static char *force_word _((char *start, int token, int check_keyword, int allow_pack, int allow_tick));
22 static SV *tokeq _((SV *sv));
23 static char *scan_const _((char *start));
24 static char *scan_formline _((char *s));
25 static char *scan_heredoc _((char *s));
26 static char *scan_ident _((char *s, char *send, char *dest, STRLEN destlen,
28 static char *scan_inputsymbol _((char *start));
29 static char *scan_pat _((char *start));
30 static char *scan_str _((char *start));
31 static char *scan_subst _((char *start));
32 static char *scan_trans _((char *start));
33 static char *scan_word _((char *s, char *dest, STRLEN destlen,
34 int allow_package, STRLEN *slp));
35 static char *skipspace _((char *s));
36 static void checkcomma _((char *s, char *name, char *what));
37 static void force_ident _((char *s, int kind));
38 static void incline _((char *s));
39 static int intuit_method _((char *s, GV *gv));
40 static int intuit_more _((char *s));
41 static I32 lop _((I32 f, expectation x, char *s));
42 static void missingterm _((char *s));
43 static void no_op _((char *what, char *s));
44 static void set_csh _((void));
45 static I32 sublex_done _((void));
46 static I32 sublex_push _((void));
47 static I32 sublex_start _((void));
49 static int uni _((I32 f, char *s));
51 static char * filter_gets _((SV *sv, PerlIO *fp, STRLEN append));
52 static void restore_rsfp _((void *f));
53 static SV *new_constant _((char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type));
54 static void restore_expect _((void *e));
55 static void restore_lex_expect _((void *e));
56 #endif /* PERL_OBJECT */
58 static char ident_too_long[] = "Identifier too long";
60 /* The following are arranged oddly so that the guard on the switch statement
61 * can get by with a single comparison (if the compiler is smart enough).
64 /* #define LEX_NOTPARSING 11 is done in perl.h. */
67 #define LEX_INTERPNORMAL 9
68 #define LEX_INTERPCASEMOD 8
69 #define LEX_INTERPPUSH 7
70 #define LEX_INTERPSTART 6
71 #define LEX_INTERPEND 5
72 #define LEX_INTERPENDMAYBE 4
73 #define LEX_INTERPCONCAT 3
74 #define LEX_INTERPCONST 2
75 #define LEX_FORMLINE 1
76 #define LEX_KNOWNEXT 0
85 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
87 # include <unistd.h> /* Needed for execv() */
100 #define CLINE (copline = (curcop->cop_line < copline ? curcop->cop_line : copline))
102 #define TOKEN(retval) return (bufptr = s,(int)retval)
103 #define OPERATOR(retval) return (expect = XTERM,bufptr = s,(int)retval)
104 #define AOPERATOR(retval) return ao((expect = XTERM,bufptr = s,(int)retval))
105 #define PREBLOCK(retval) return (expect = XBLOCK,bufptr = s,(int)retval)
106 #define PRETERMBLOCK(retval) return (expect = XTERMBLOCK,bufptr = s,(int)retval)
107 #define PREREF(retval) return (expect = XREF,bufptr = s,(int)retval)
108 #define TERM(retval) return (CLINE, expect = XOPERATOR,bufptr = s,(int)retval)
109 #define LOOPX(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)LOOPEX)
110 #define FTST(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)UNIOP)
111 #define FUN0(f) return(yylval.ival = f,expect = XOPERATOR,bufptr = s,(int)FUNC0)
112 #define FUN1(f) return(yylval.ival = f,expect = XOPERATOR,bufptr = s,(int)FUNC1)
113 #define BOop(f) return ao((yylval.ival=f,expect = XTERM,bufptr = s,(int)BITOROP))
114 #define BAop(f) return ao((yylval.ival=f,expect = XTERM,bufptr = s,(int)BITANDOP))
115 #define SHop(f) return ao((yylval.ival=f,expect = XTERM,bufptr = s,(int)SHIFTOP))
116 #define PWop(f) return ao((yylval.ival=f,expect = XTERM,bufptr = s,(int)POWOP))
117 #define PMop(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)MATCHOP)
118 #define Aop(f) return ao((yylval.ival=f,expect = XTERM,bufptr = s,(int)ADDOP))
119 #define Mop(f) return ao((yylval.ival=f,expect = XTERM,bufptr = s,(int)MULOP))
120 #define Eop(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)EQOP)
121 #define Rop(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)RELOP)
123 /* This bit of chicanery makes a unary function followed by
124 * a parenthesis into a function with one argument, highest precedence.
126 #define UNI(f) return(yylval.ival = f, \
129 last_uni = oldbufptr, \
131 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
133 #define UNIBRACK(f) return(yylval.ival = f, \
135 last_uni = oldbufptr, \
136 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
138 /* grandfather return to old style */
139 #define OLDLOP(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)LSTOP)
144 if (*bufptr == '=') {
146 if (toketype == ANDAND)
147 yylval.ival = OP_ANDASSIGN;
148 else if (toketype == OROR)
149 yylval.ival = OP_ORASSIGN;
156 no_op(char *what, char *s)
158 char *oldbp = bufptr;
159 bool is_first = (oldbufptr == linestart);
162 yywarn(form("%s found where operator expected", what));
164 warn("\t(Missing semicolon on previous line?)\n");
165 else if (oldoldbufptr && isIDFIRST(*oldoldbufptr)) {
167 for (t = oldoldbufptr; *t && (isALNUM(*t) || *t == ':'); t++) ;
168 if (t < bufptr && isSPACE(*t))
169 warn("\t(Do you need to predeclare %.*s?)\n",
170 t - oldoldbufptr, oldoldbufptr);
174 warn("\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
184 char *nl = strrchr(s,'\n');
188 else if (multi_close < 32 || multi_close == 127) {
190 tmpbuf[1] = toCTRL(multi_close);
196 *tmpbuf = multi_close;
200 q = strchr(s,'"') ? '\'' : '"';
201 croak("Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
208 warn("Use of %s is deprecated", s);
214 deprecate("comma-less variable list");
220 win32_textfilter(int idx, SV *sv, int maxlen)
222 I32 count = FILTER_READ(idx+1, sv, maxlen);
223 if (count > 0 && !maxlen)
224 win32_strip_return(sv);
238 SAVEI32(lex_brackets);
239 SAVEI32(lex_fakebrack);
240 SAVEI32(lex_casemods);
245 SAVEI16(curcop->cop_line);
249 SAVEPPTR(oldoldbufptr);
252 SAVEPPTR(lex_brackstack);
253 SAVEPPTR(lex_casestack);
254 SAVEDESTRUCTOR(restore_rsfp, rsfp);
258 SAVEDESTRUCTOR(restore_expect, tokenbuf + expect); /* encode as pointer */
259 SAVEDESTRUCTOR(restore_lex_expect, tokenbuf + expect);
261 lex_state = LEX_NORMAL;
266 New(899, lex_brackstack, 120, char);
267 New(899, lex_casestack, 12, char);
268 SAVEFREEPV(lex_brackstack);
269 SAVEFREEPV(lex_casestack);
271 *lex_casestack = '\0';
279 if (SvREADONLY(linestr))
280 linestr = sv_2mortal(newSVsv(linestr));
281 s = SvPV(linestr, len);
282 if (len && s[len-1] != ';') {
283 if (!(SvFLAGS(linestr) & SVs_TEMP))
284 linestr = sv_2mortal(newSVsv(linestr));
285 sv_catpvn(linestr, "\n;", 2);
288 oldoldbufptr = oldbufptr = bufptr = linestart = SvPVX(linestr);
289 bufend = bufptr + SvCUR(linestr);
291 rs = newSVpv("\n", 1);
302 restore_rsfp(void *f)
304 PerlIO *fp = (PerlIO*)f;
306 if (rsfp == PerlIO_stdin())
307 PerlIO_clearerr(rsfp);
308 else if (rsfp && (rsfp != fp))
314 restore_expect(void *e)
316 /* a safe way to store a small integer in a pointer */
317 expect = (expectation)((char *)e - tokenbuf);
321 restore_lex_expect(void *e)
323 /* a safe way to store a small integer in a pointer */
324 lex_expect = (expectation)((char *)e - tokenbuf);
339 while (*s == ' ' || *s == '\t') s++;
340 if (strnEQ(s, "line ", 5)) {
349 while (*s == ' ' || *s == '\t')
351 if (*s == '"' && (t = strchr(s+1, '"')))
355 return; /* false alarm */
356 for (t = s; !isSPACE(*t); t++) ;
361 curcop->cop_filegv = gv_fetchfile(s);
363 curcop->cop_filegv = gv_fetchfile(origfilename);
365 curcop->cop_line = atoi(n)-1;
369 skipspace(register char *s)
372 if (lex_formbrack && lex_brackets <= lex_formbrack) {
373 while (s < bufend && (*s == ' ' || *s == '\t'))
379 while (s < bufend && isSPACE(*s))
381 if (s < bufend && *s == '#') {
382 while (s < bufend && *s != '\n')
387 if (s < bufend || !rsfp || lex_state != LEX_NORMAL)
389 if ((s = filter_gets(linestr, rsfp, (prevlen = SvCUR(linestr)))) == Nullch) {
390 if (minus_n || minus_p) {
391 sv_setpv(linestr,minus_p ?
392 ";}continue{print or die qq(-p destination: $!\\n)" :
394 sv_catpv(linestr,";}");
395 minus_n = minus_p = 0;
398 sv_setpv(linestr,";");
399 oldoldbufptr = oldbufptr = bufptr = s = linestart = SvPVX(linestr);
400 bufend = SvPVX(linestr) + SvCUR(linestr);
401 if (preprocess && !in_eval)
402 (void)PerlProc_pclose(rsfp);
403 else if ((PerlIO*)rsfp == PerlIO_stdin())
404 PerlIO_clearerr(rsfp);
406 (void)PerlIO_close(rsfp);
410 linestart = bufptr = s + prevlen;
411 bufend = s + SvCUR(linestr);
414 if (PERLDB_LINE && curstash != debstash) {
415 SV *sv = NEWSV(85,0);
417 sv_upgrade(sv, SVt_PVMG);
418 sv_setpvn(sv,bufptr,bufend-bufptr);
419 av_store(GvAV(curcop->cop_filegv),(I32)curcop->cop_line,sv);
430 if (oldoldbufptr != last_uni)
432 while (isSPACE(*last_uni))
434 for (s = last_uni; isALNUM(*s) || *s == '-'; s++) ;
435 if ((t = strchr(s, '(')) && t < bufptr)
439 warn("Warning: Use of \"%s\" without parens is ambiguous", last_uni);
446 #define UNI(f) return uni(f,s)
454 last_uni = oldbufptr;
465 #endif /* CRIPPLED_CC */
467 #define LOP(f,x) return lop(f,x,s)
470 lop(I32 f, expectation x, char *s)
477 last_lop = oldbufptr;
493 nexttype[nexttoke] = type;
495 if (lex_state != LEX_KNOWNEXT) {
496 lex_defer = lex_state;
498 lex_state = LEX_KNOWNEXT;
503 force_word(register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
508 start = skipspace(start);
511 (allow_pack && *s == ':') ||
512 (allow_initial_tick && *s == '\'') )
514 s = scan_word(s, tokenbuf, sizeof tokenbuf, allow_pack, &len);
515 if (check_keyword && keyword(tokenbuf, len))
517 if (token == METHOD) {
527 nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(tokenbuf,0));
528 nextval[nexttoke].opval->op_private |= OPpCONST_BARE;
535 force_ident(register char *s, int kind)
538 OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
539 nextval[nexttoke].opval = o;
542 dTHR; /* just for in_eval */
543 o->op_private = OPpCONST_ENTERED;
544 /* XXX see note in pp_entereval() for why we forgo typo
545 warnings if the symbol must be introduced in an eval.
547 gv_fetchpv(s, in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
548 kind == '$' ? SVt_PV :
549 kind == '@' ? SVt_PVAV :
550 kind == '%' ? SVt_PVHV :
558 force_version(char *s)
560 OP *version = Nullop;
564 /* default VERSION number -- GBARR */
569 for( d=s, c = 1; isDIGIT(*d) || *d == '_' || (*d == '.' && c--); d++);
570 if((*d == ';' || isSPACE(*d)) && *(skipspace(d)) != ',') {
572 /* real VERSION number -- GBARR */
573 version = yylval.opval;
577 /* NOTE: The parser sees the package name and the VERSION swapped */
578 nextval[nexttoke].opval = version;
596 s = SvPV_force(sv, len);
600 while (s < send && *s != '\\')
605 if ( hints & HINT_NEW_STRING )
606 pv = sv_2mortal(newSVpv(SvPVX(pv), len));
609 if (s + 1 < send && (s[1] == '\\'))
610 s++; /* all that, just for this */
615 SvCUR_set(sv, d - SvPVX(sv));
617 if ( hints & HINT_NEW_STRING )
618 return new_constant(NULL, 0, "q", sv, pv, "q");
625 register I32 op_type = yylval.ival;
627 if (op_type == OP_NULL) {
628 yylval.opval = lex_op;
632 if (op_type == OP_CONST || op_type == OP_READLINE) {
633 SV *sv = tokeq(lex_stuff);
635 if (SvTYPE(sv) == SVt_PVIV) {
636 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
642 nsv = newSVpv(p, len);
646 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
651 sublex_info.super_state = lex_state;
652 sublex_info.sub_inwhat = op_type;
653 sublex_info.sub_op = lex_op;
654 lex_state = LEX_INTERPPUSH;
658 yylval.opval = lex_op;
672 lex_state = sublex_info.super_state;
674 SAVEI32(lex_brackets);
675 SAVEI32(lex_fakebrack);
676 SAVEI32(lex_casemods);
681 SAVEI16(curcop->cop_line);
684 SAVEPPTR(oldoldbufptr);
687 SAVEPPTR(lex_brackstack);
688 SAVEPPTR(lex_casestack);
693 bufend = bufptr = oldbufptr = oldoldbufptr = linestart = SvPVX(linestr);
694 bufend += SvCUR(linestr);
700 New(899, lex_brackstack, 120, char);
701 New(899, lex_casestack, 12, char);
702 SAVEFREEPV(lex_brackstack);
703 SAVEFREEPV(lex_casestack);
705 *lex_casestack = '\0';
707 lex_state = LEX_INTERPCONCAT;
708 curcop->cop_line = multi_start;
710 lex_inwhat = sublex_info.sub_inwhat;
711 if (lex_inwhat == OP_MATCH || lex_inwhat == OP_SUBST)
712 lex_inpat = sublex_info.sub_op;
724 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv("",0));
728 if (lex_casemods) { /* oops, we've got some unbalanced parens */
729 lex_state = LEX_INTERPCASEMOD;
733 /* Is there a right-hand side to take care of? */
734 if (lex_repl && (lex_inwhat == OP_SUBST || lex_inwhat == OP_TRANS)) {
737 bufend = bufptr = oldbufptr = oldoldbufptr = linestart = SvPVX(linestr);
738 bufend += SvCUR(linestr);
744 *lex_casestack = '\0';
746 if (SvCOMPILED(lex_repl)) {
747 lex_state = LEX_INTERPNORMAL;
751 lex_state = LEX_INTERPCONCAT;
757 bufend = SvPVX(linestr);
758 bufend += SvCUR(linestr);
767 Extracts a pattern, double-quoted string, or transliteration. This
770 It looks at lex_inwhat and lex_inpat to find out whether it's
771 processing a pattern (lex_inpat is true), a transliteration
772 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
774 Returns a pointer to the character scanned up to. Iff this is
775 advanced from the start pointer supplied (ie if anything was
776 successfully parsed), will leave an OP for the substring scanned
777 in yylval. Caller must intuit reason for not parsing further
778 by looking at the next characters herself.
782 double-quoted style: \r and \n
783 regexp special ones: \D \s
785 backrefs: \1 (deprecated in substitution replacements)
786 case and quoting: \U \Q \E
787 stops on @ and $, but not for $ as tail anchor
790 characters are VERY literal, except for - not at the start or end
791 of the string, which indicates a range. scan_const expands the
792 range to the full set of intermediate characters.
794 In double-quoted strings:
796 double-quoted style: \r and \n
798 backrefs: \1 (deprecated)
799 case and quoting: \U \Q \E
802 scan_const does *not* construct ops to handle interpolated strings.
803 It stops processing as soon as it finds an embedded $ or @ variable
804 and leaves it to the caller to work out what's going on.
806 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
808 $ in pattern could be $foo or could be tail anchor. Assumption:
809 it's a tail anchor if $ is the last thing in the string, or if it's
810 followed by one of ")| \n\t"
812 \1 (backreferences) are turned into $1
814 The structure of the code is
815 while (there's a character to process) {
816 handle transliteration ranges
818 skip # initiated comments in //x patterns
819 check for embedded @foo
820 check for embedded scalars
822 leave intact backslashes from leave (below)
823 deprecate \1 in strings and sub replacements
824 handle string-changing backslashes \l \U \Q \E, etc.
825 switch (what was escaped) {
826 handle - in a transliteration (becomes a literal -)
827 handle \132 octal characters
828 handle 0x15 hex characters
829 handle \cV (control V)
830 handle printf backslashes (\f, \r, \n, etc)
833 } (end while character to read)
838 scan_const(char *start)
840 register char *send = bufend; /* end of the constant */
841 SV *sv = NEWSV(93, send - start); /* sv for the constant */
842 register char *s = start; /* start of the constant */
843 register char *d = SvPVX(sv); /* destination for copies */
844 bool dorange = FALSE; /* are we in a translit range? */
847 /* leaveit is the set of acceptably-backslashed characters */
850 ? "\\.^$@AGZdDwWsSbB+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
853 while (s < send || dorange) {
854 /* get transliterations out of the way (they're most literal) */
855 if (lex_inwhat == OP_TRANS) {
856 /* expand a range A-Z to the full set of characters. AIE! */
858 I32 i; /* current expanded character */
859 I32 max; /* last character in range */
861 i = d - SvPVX(sv); /* remember current offset */
862 SvGROW(sv, SvLEN(sv) + 256); /* expand the sv -- there'll never be more'n 256 chars in a range for it to grow by */
863 d = SvPVX(sv) + i; /* restore d after the grow potentially has changed the ptr */
864 d -= 2; /* eat the first char and the - */
866 max = (U8)d[1]; /* last char in range */
868 for (i = (U8)*d; i <= max; i++)
871 /* mark the range as done, and continue */
876 /* range begins (ignore - as first or last char) */
877 else if (*s == '-' && s+1 < send && s != start) {
883 /* if we get here, we're not doing a transliteration */
885 /* skip for regexp comments /(?#comment)/ */
886 else if (*s == '(' && lex_inpat && s[1] == '?') {
888 while (s < send && *s != ')')
890 } else if (s[2] == '{') { /* This should march regcomp.c */
892 char *regparse = s + 3;
895 while (count && (c = *regparse)) {
896 if (c == '\\' && regparse[1])
904 if (*regparse == ')')
907 yyerror("Sequence (?{...}) not terminated or not {}-balanced");
908 while (s < regparse && *s != ')')
913 /* likewise skip #-initiated comments in //x patterns */
914 else if (*s == '#' && lex_inpat &&
915 ((PMOP*)lex_inpat)->op_pmflags & PMf_EXTENDED) {
916 while (s+1 < send && *s != '\n')
920 /* check for embedded arrays (@foo, @:foo, @'foo, @{foo}, @$foo) */
921 else if (*s == '@' && s[1] && (isALNUM(s[1]) || strchr(":'{$", s[1])))
924 /* check for embedded scalars. only stop if we're sure it's a
927 else if (*s == '$') {
928 if (!lex_inpat) /* not a regexp, so $ must be var */
930 if (s + 1 < send && !strchr("()| \n\t", s[1]))
931 break; /* in regexp, $ might be tail anchor */
935 if (*s == '\\' && s+1 < send) {
938 /* some backslashes we leave behind */
939 if (*s && strchr(leaveit, *s)) {
945 /* deprecate \1 in strings and substitution replacements */
946 if (lex_inwhat == OP_SUBST && !lex_inpat &&
947 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
950 warn("\\%c better written as $%c", *s, *s);
955 /* string-change backslash escapes */
956 if (lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
961 /* if we get here, it's either a quoted -, or a digit */
964 /* quoted - in transliterations */
966 if (lex_inwhat == OP_TRANS) {
971 /* default action is to copy the quoted character */
976 /* \132 indicates an octal constant */
977 case '0': case '1': case '2': case '3':
978 case '4': case '5': case '6': case '7':
979 *d++ = scan_oct(s, 3, &len);
983 /* \x24 indicates a hex constant */
985 *d++ = scan_hex(++s, 2, &len);
989 /* \c is a control character */
996 /* printf-style backslashes, formfeeds, newlines, etc */
1022 } /* end if (backslash) */
1025 } /* while loop to process each character */
1027 /* terminate the string and set up the sv */
1029 SvCUR_set(sv, d - SvPVX(sv));
1032 /* shrink the sv if we allocated more than we used */
1033 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1034 SvLEN_set(sv, SvCUR(sv) + 1);
1035 Renew(SvPVX(sv), SvLEN(sv), char);
1038 /* return the substring (via yylval) only if we parsed anything */
1040 if ( hints & ( lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1041 sv = new_constant(start, s - start, (lex_inpat ? "qr" : "q"),
1043 ( lex_inwhat == OP_TRANS
1045 : ( (lex_inwhat == OP_SUBST && !lex_inpat)
1048 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1054 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1056 intuit_more(register char *s)
1060 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1062 if (*s != '{' && *s != '[')
1067 /* In a pattern, so maybe we have {n,m}. */
1084 /* On the other hand, maybe we have a character class */
1087 if (*s == ']' || *s == '^')
1090 int weight = 2; /* let's weigh the evidence */
1092 unsigned char un_char = 255, last_un_char;
1093 char *send = strchr(s,']');
1094 char tmpbuf[sizeof tokenbuf * 4];
1096 if (!send) /* has to be an expression */
1099 Zero(seen,256,char);
1102 else if (isDIGIT(*s)) {
1104 if (isDIGIT(s[1]) && s[2] == ']')
1110 for (; s < send; s++) {
1111 last_un_char = un_char;
1112 un_char = (unsigned char)*s;
1117 weight -= seen[un_char] * 10;
1118 if (isALNUM(s[1])) {
1119 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1120 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1125 else if (*s == '$' && s[1] &&
1126 strchr("[#!%*<>()-=",s[1])) {
1127 if (/*{*/ strchr("])} =",s[2]))
1136 if (strchr("wds]",s[1]))
1138 else if (seen['\''] || seen['"'])
1140 else if (strchr("rnftbxcav",s[1]))
1142 else if (isDIGIT(s[1])) {
1144 while (s[1] && isDIGIT(s[1]))
1154 if (strchr("aA01! ",last_un_char))
1156 if (strchr("zZ79~",s[1]))
1158 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1159 weight -= 5; /* cope with negative subscript */
1162 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1163 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1168 if (keyword(tmpbuf, d - tmpbuf))
1171 if (un_char == last_un_char + 1)
1173 weight -= seen[un_char];
1178 if (weight >= 0) /* probably a character class */
1186 intuit_method(char *start, GV *gv)
1188 char *s = start + (*start == '$');
1189 char tmpbuf[sizeof tokenbuf];
1197 if ((cv = GvCVu(gv))) {
1198 char *proto = SvPVX(cv);
1208 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1209 if (*start == '$') {
1210 if (gv || last_lop_op == OP_PRINT || isUPPER(*tokenbuf))
1215 return *s == '(' ? FUNCMETH : METHOD;
1217 if (!keyword(tmpbuf, len)) {
1218 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1223 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1224 if (indirgv && GvCVu(indirgv))
1226 /* filehandle or package name makes it a method */
1227 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1229 if ((bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1230 return 0; /* no assumptions -- "=>" quotes bearword */
1232 nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1234 nextval[nexttoke].opval->op_private = OPpCONST_BARE;
1238 return *s == '(' ? FUNCMETH : METHOD;
1248 char *pdb = PerlEnv_getenv("PERL5DB");
1252 SETERRNO(0,SS$_NORMAL);
1253 return "BEGIN { require 'perl5db.pl' }";
1259 /* Encoded script support. filter_add() effectively inserts a
1260 * 'pre-processing' function into the current source input stream.
1261 * Note that the filter function only applies to the current source file
1262 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1264 * The datasv parameter (which may be NULL) can be used to pass
1265 * private data to this instance of the filter. The filter function
1266 * can recover the SV using the FILTER_DATA macro and use it to
1267 * store private buffers and state information.
1269 * The supplied datasv parameter is upgraded to a PVIO type
1270 * and the IoDIRP field is used to store the function pointer.
1271 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1272 * private use must be set using malloc'd pointers.
1274 static int filter_debug = 0;
1277 filter_add(filter_t funcp, SV *datasv)
1279 if (!funcp){ /* temporary handy debugging hack to be deleted */
1280 filter_debug = atoi((char*)datasv);
1284 rsfp_filters = newAV();
1286 datasv = NEWSV(255,0);
1287 if (!SvUPGRADE(datasv, SVt_PVIO))
1288 die("Can't upgrade filter_add data to SVt_PVIO");
1289 IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
1291 warn("filter_add func %p (%s)", funcp, SvPV(datasv,na));
1292 av_unshift(rsfp_filters, 1);
1293 av_store(rsfp_filters, 0, datasv) ;
1298 /* Delete most recently added instance of this filter function. */
1300 filter_del(filter_t funcp)
1303 warn("filter_del func %p", funcp);
1304 if (!rsfp_filters || AvFILLp(rsfp_filters)<0)
1306 /* if filter is on top of stack (usual case) just pop it off */
1307 if (IoDIRP(FILTER_DATA(AvFILLp(rsfp_filters))) == (void*)funcp){
1308 sv_free(av_pop(rsfp_filters));
1312 /* we need to search for the correct entry and clear it */
1313 die("filter_del can only delete in reverse order (currently)");
1317 /* Invoke the n'th filter function for the current rsfp. */
1319 filter_read(int idx, SV *buf_sv, int maxlen)
1322 /* 0 = read one text line */
1329 if (idx > AvFILLp(rsfp_filters)){ /* Any more filters? */
1330 /* Provide a default input filter to make life easy. */
1331 /* Note that we append to the line. This is handy. */
1333 warn("filter_read %d: from rsfp\n", idx);
1337 int old_len = SvCUR(buf_sv) ;
1339 /* ensure buf_sv is large enough */
1340 SvGROW(buf_sv, old_len + maxlen) ;
1341 if ((len = PerlIO_read(rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1342 if (PerlIO_error(rsfp))
1343 return -1; /* error */
1345 return 0 ; /* end of file */
1347 SvCUR_set(buf_sv, old_len + len) ;
1350 if (sv_gets(buf_sv, rsfp, SvCUR(buf_sv)) == NULL) {
1351 if (PerlIO_error(rsfp))
1352 return -1; /* error */
1354 return 0 ; /* end of file */
1357 return SvCUR(buf_sv);
1359 /* Skip this filter slot if filter has been deleted */
1360 if ( (datasv = FILTER_DATA(idx)) == &sv_undef){
1362 warn("filter_read %d: skipped (filter deleted)\n", idx);
1363 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1365 /* Get function pointer hidden within datasv */
1366 funcp = (filter_t)IoDIRP(datasv);
1368 warn("filter_read %d: via function %p (%s)\n",
1369 idx, funcp, SvPV(datasv,na));
1370 /* Call function. The function is expected to */
1371 /* call "FILTER_READ(idx+1, buf_sv)" first. */
1372 /* Return: <0:error, =0:eof, >0:not eof */
1373 return (*funcp)(PERL_OBJECT_THIS_ idx, buf_sv, maxlen);
1377 filter_gets(register SV *sv, register PerlIO *fp, STRLEN append)
1380 if (!rsfp_filters) {
1381 filter_add(win32_textfilter,NULL);
1387 SvCUR_set(sv, 0); /* start with empty line */
1388 if (FILTER_READ(0, sv, 0) > 0)
1389 return ( SvPVX(sv) ) ;
1394 return (sv_gets(sv, fp, append));
1399 static char* exp_name[] =
1400 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "TERMBLOCK" };
1403 EXT int yychar; /* last token */
1408 Works out what to call the token just pulled out of the input
1409 stream. The yacc parser takes care of taking the ops we return and
1410 stitching them into a tree.
1416 if read an identifier
1417 if we're in a my declaration
1418 croak if they tried to say my($foo::bar)
1419 build the ops for a my() declaration
1420 if it's an access to a my() variable
1421 are we in a sort block?
1422 croak if my($a); $a <=> $b
1423 build ops for access to a my() variable
1424 if in a dq string, and they've said @foo and we can't find @foo
1426 build ops for a bareword
1427 if we already built the token before, use it.
1441 /* check if there's an identifier for us to look at */
1442 if (pending_ident) {
1443 /* pit holds the identifier we read and pending_ident is reset */
1444 char pit = pending_ident;
1447 /* if we're in a my(), we can't allow dynamics here.
1448 $foo'bar has already been turned into $foo::bar, so
1449 just check for colons.
1451 if it's a legal name, the OP is a PADANY.
1454 if (strchr(tokenbuf,':'))
1455 croak(no_myglob,tokenbuf);
1457 yylval.opval = newOP(OP_PADANY, 0);
1458 yylval.opval->op_targ = pad_allocmy(tokenbuf);
1463 build the ops for accesses to a my() variable.
1465 Deny my($a) or my($b) in a sort block, *if* $a or $b is
1466 then used in a comparison. This catches most, but not
1467 all cases. For instance, it catches
1468 sort { my($a); $a <=> $b }
1470 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
1471 (although why you'd do that is anyone's guess).
1474 if (!strchr(tokenbuf,':')) {
1476 /* Check for single character per-thread SVs */
1477 if (tokenbuf[0] == '$' && tokenbuf[2] == '\0'
1478 && !isALPHA(tokenbuf[1]) /* Rule out obvious non-threadsvs */
1479 && (tmp = find_threadsv(&tokenbuf[1])) != NOT_IN_PAD)
1481 yylval.opval = newOP(OP_THREADSV, 0);
1482 yylval.opval->op_targ = tmp;
1485 #endif /* USE_THREADS */
1486 if ((tmp = pad_findmy(tokenbuf)) != NOT_IN_PAD) {
1487 /* if it's a sort block and they're naming $a or $b */
1488 if (last_lop_op == OP_SORT &&
1489 tokenbuf[0] == '$' &&
1490 (tokenbuf[1] == 'a' || tokenbuf[1] == 'b')
1493 for (d = in_eval ? oldoldbufptr : linestart;
1494 d < bufend && *d != '\n';
1497 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
1498 croak("Can't use \"my %s\" in sort comparison",
1504 yylval.opval = newOP(OP_PADANY, 0);
1505 yylval.opval->op_targ = tmp;
1511 Whine if they've said @foo in a doublequoted string,
1512 and @foo isn't a variable we can find in the symbol
1515 if (pit == '@' && lex_state != LEX_NORMAL && !lex_brackets) {
1516 GV *gv = gv_fetchpv(tokenbuf+1, FALSE, SVt_PVAV);
1517 if (!gv || ((tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
1518 yyerror(form("In string, %s now must be written as \\%s",
1519 tokenbuf, tokenbuf));
1522 /* build ops for a bareword */
1523 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(tokenbuf+1, 0));
1524 yylval.opval->op_private = OPpCONST_ENTERED;
1525 gv_fetchpv(tokenbuf+1, in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
1526 ((tokenbuf[0] == '$') ? SVt_PV
1527 : (tokenbuf[0] == '@') ? SVt_PVAV
1532 /* no identifier pending identification */
1534 switch (lex_state) {
1536 case LEX_NORMAL: /* Some compilers will produce faster */
1537 case LEX_INTERPNORMAL: /* code if we comment these out. */
1541 /* when we're already built the next token, just pull it out the queue */
1544 yylval = nextval[nexttoke];
1546 lex_state = lex_defer;
1547 expect = lex_expect;
1548 lex_defer = LEX_NORMAL;
1550 return(nexttype[nexttoke]);
1552 /* interpolated case modifiers like \L \U, including \Q and \E.
1553 when we get here, bufptr is at the \
1555 case LEX_INTERPCASEMOD:
1557 if (bufptr != bufend && *bufptr != '\\')
1558 croak("panic: INTERPCASEMOD");
1560 /* handle \E or end of string */
1561 if (bufptr == bufend || bufptr[1] == 'E') {
1566 oldmod = lex_casestack[--lex_casemods];
1567 lex_casestack[lex_casemods] = '\0';
1569 if (bufptr != bufend && strchr("LUQ", oldmod)) {
1571 lex_state = LEX_INTERPCONCAT;
1575 if (bufptr != bufend)
1577 lex_state = LEX_INTERPCONCAT;
1582 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
1583 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
1584 if (strchr("LU", *s) &&
1585 (strchr(lex_casestack, 'L') || strchr(lex_casestack, 'U')))
1587 lex_casestack[--lex_casemods] = '\0';
1590 if (lex_casemods > 10) {
1591 char* newlb = Renew(lex_casestack, lex_casemods + 2, char);
1592 if (newlb != lex_casestack) {
1594 lex_casestack = newlb;
1597 lex_casestack[lex_casemods++] = *s;
1598 lex_casestack[lex_casemods] = '\0';
1599 lex_state = LEX_INTERPCONCAT;
1600 nextval[nexttoke].ival = 0;
1603 nextval[nexttoke].ival = OP_LCFIRST;
1605 nextval[nexttoke].ival = OP_UCFIRST;
1607 nextval[nexttoke].ival = OP_LC;
1609 nextval[nexttoke].ival = OP_UC;
1611 nextval[nexttoke].ival = OP_QUOTEMETA;
1613 croak("panic: yylex");
1625 case LEX_INTERPPUSH:
1626 return sublex_push();
1628 case LEX_INTERPSTART:
1629 if (bufptr == bufend)
1630 return sublex_done();
1632 lex_dojoin = (*bufptr == '@');
1633 lex_state = LEX_INTERPNORMAL;
1635 nextval[nexttoke].ival = 0;
1638 nextval[nexttoke].opval = newOP(OP_THREADSV, 0);
1639 nextval[nexttoke].opval->op_targ = find_threadsv("\"");
1640 force_next(PRIVATEREF);
1642 force_ident("\"", '$');
1643 #endif /* USE_THREADS */
1644 nextval[nexttoke].ival = 0;
1646 nextval[nexttoke].ival = 0;
1648 nextval[nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
1657 case LEX_INTERPENDMAYBE:
1658 if (intuit_more(bufptr)) {
1659 lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
1667 lex_state = LEX_INTERPCONCAT;
1671 case LEX_INTERPCONCAT:
1674 croak("panic: INTERPCONCAT");
1676 if (bufptr == bufend)
1677 return sublex_done();
1679 if (SvIVX(linestr) == '\'') {
1680 SV *sv = newSVsv(linestr);
1683 else if ( hints & HINT_NEW_RE )
1684 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
1685 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1689 s = scan_const(bufptr);
1691 lex_state = LEX_INTERPCASEMOD;
1693 lex_state = LEX_INTERPSTART;
1697 nextval[nexttoke] = yylval;
1710 lex_state = LEX_NORMAL;
1711 s = scan_formline(bufptr);
1718 oldoldbufptr = oldbufptr;
1721 PerlIO_printf(PerlIO_stderr(), "### Tokener expecting %s at %s\n", exp_name[expect], s);
1727 croak("Unrecognized character \\%03o", *s & 255);
1730 goto fake_eof; /* emulate EOF on ^D or ^Z */
1736 yyerror("Missing right bracket");
1740 goto retry; /* ignore stray nulls */
1743 if (!in_eval && !preambled) {
1745 sv_setpv(linestr,incl_perldb());
1747 sv_catpv(linestr,";");
1749 while(AvFILLp(preambleav) >= 0) {
1750 SV *tmpsv = av_shift(preambleav);
1751 sv_catsv(linestr, tmpsv);
1752 sv_catpv(linestr, ";");
1755 sv_free((SV*)preambleav);
1758 if (minus_n || minus_p) {
1759 sv_catpv(linestr, "LINE: while (<>) {");
1761 sv_catpv(linestr,"chomp;");
1763 GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
1765 GvIMPORTED_AV_on(gv);
1767 if (strchr("/'\"", *splitstr)
1768 && strchr(splitstr + 1, *splitstr))
1769 sv_catpvf(linestr, "@F=split(%s);", splitstr);
1772 s = "'~#\200\1'"; /* surely one char is unused...*/
1773 while (s[1] && strchr(splitstr, *s)) s++;
1775 sv_catpvf(linestr, "@F=split(%s%c",
1776 "q" + (delim == '\''), delim);
1777 for (s = splitstr; *s; s++) {
1779 sv_catpvn(linestr, "\\", 1);
1780 sv_catpvn(linestr, s, 1);
1782 sv_catpvf(linestr, "%c);", delim);
1786 sv_catpv(linestr,"@F=split(' ');");
1789 sv_catpv(linestr, "\n");
1790 oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr);
1791 bufend = SvPVX(linestr) + SvCUR(linestr);
1792 if (PERLDB_LINE && curstash != debstash) {
1793 SV *sv = NEWSV(85,0);
1795 sv_upgrade(sv, SVt_PVMG);
1796 sv_setsv(sv,linestr);
1797 av_store(GvAV(curcop->cop_filegv),(I32)curcop->cop_line,sv);
1802 if ((s = filter_gets(linestr, rsfp, 0)) == Nullch) {
1805 if (preprocess && !in_eval)
1806 (void)PerlProc_pclose(rsfp);
1807 else if ((PerlIO *)rsfp == PerlIO_stdin())
1808 PerlIO_clearerr(rsfp);
1810 (void)PerlIO_close(rsfp);
1813 if (!in_eval && (minus_n || minus_p)) {
1814 sv_setpv(linestr,minus_p ? ";}continue{print" : "");
1815 sv_catpv(linestr,";}");
1816 oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr);
1817 bufend = SvPVX(linestr) + SvCUR(linestr);
1818 minus_n = minus_p = 0;
1821 oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr);
1822 sv_setpv(linestr,"");
1823 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
1826 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
1829 /* Incest with pod. */
1830 if (*s == '=' && strnEQ(s, "=cut", 4)) {
1831 sv_setpv(linestr, "");
1832 oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr);
1833 bufend = SvPVX(linestr) + SvCUR(linestr);
1838 } while (doextract);
1839 oldoldbufptr = oldbufptr = bufptr = linestart = s;
1840 if (PERLDB_LINE && curstash != debstash) {
1841 SV *sv = NEWSV(85,0);
1843 sv_upgrade(sv, SVt_PVMG);
1844 sv_setsv(sv,linestr);
1845 av_store(GvAV(curcop->cop_filegv),(I32)curcop->cop_line,sv);
1847 bufend = SvPVX(linestr) + SvCUR(linestr);
1848 if (curcop->cop_line == 1) {
1849 while (s < bufend && isSPACE(*s))
1851 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
1855 if (*s == '#' && *(s+1) == '!')
1857 #ifdef ALTERNATE_SHEBANG
1859 static char as[] = ALTERNATE_SHEBANG;
1860 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
1861 d = s + (sizeof(as) - 1);
1863 #endif /* ALTERNATE_SHEBANG */
1872 while (*d && !isSPACE(*d))
1876 #ifdef ARG_ZERO_IS_SCRIPT
1877 if (ipathend > ipath) {
1879 * HP-UX (at least) sets argv[0] to the script name,
1880 * which makes $^X incorrect. And Digital UNIX and Linux,
1881 * at least, set argv[0] to the basename of the Perl
1882 * interpreter. So, having found "#!", we'll set it right.
1884 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
1885 assert(SvPOK(x) || SvGMAGICAL(x));
1886 if (sv_eq(x, GvSV(curcop->cop_filegv))) {
1887 sv_setpvn(x, ipath, ipathend - ipath);
1890 TAINT_NOT; /* $^X is always tainted, but that's OK */
1892 #endif /* ARG_ZERO_IS_SCRIPT */
1897 d = instr(s,"perl -");
1899 d = instr(s,"perl");
1900 #ifdef ALTERNATE_SHEBANG
1902 * If the ALTERNATE_SHEBANG on this system starts with a
1903 * character that can be part of a Perl expression, then if
1904 * we see it but not "perl", we're probably looking at the
1905 * start of Perl code, not a request to hand off to some
1906 * other interpreter. Similarly, if "perl" is there, but
1907 * not in the first 'word' of the line, we assume the line
1908 * contains the start of the Perl program.
1910 if (d && *s != '#') {
1912 while (*c && !strchr("; \t\r\n\f\v#", *c))
1915 d = Nullch; /* "perl" not in first word; ignore */
1917 *s = '#'; /* Don't try to parse shebang line */
1919 #endif /* ALTERNATE_SHEBANG */
1924 !instr(s,"indir") &&
1925 instr(origargv[0],"perl"))
1931 while (s < bufend && isSPACE(*s))
1934 Newz(899,newargv,origargc+3,char*);
1936 while (s < bufend && !isSPACE(*s))
1939 Copy(origargv+1, newargv+2, origargc+1, char*);
1944 execv(ipath, newargv);
1945 croak("Can't exec %s", ipath);
1948 U32 oldpdb = perldb;
1949 bool oldn = minus_n;
1950 bool oldp = minus_p;
1952 while (*d && !isSPACE(*d)) d++;
1953 while (*d == ' ' || *d == '\t') d++;
1957 if (*d == 'M' || *d == 'm') {
1959 while (*d && !isSPACE(*d)) d++;
1960 croak("Too late for \"-%.*s\" option",
1963 d = moreswitches(d);
1965 if (PERLDB_LINE && !oldpdb ||
1966 ( minus_n || minus_p ) && !(oldn || oldp) )
1967 /* if we have already added "LINE: while (<>) {",
1968 we must not do it again */
1970 sv_setpv(linestr, "");
1971 oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr);
1972 bufend = SvPVX(linestr) + SvCUR(linestr);
1975 (void)gv_fetchfile(origfilename);
1982 if (lex_formbrack && lex_brackets <= lex_formbrack) {
1984 lex_state = LEX_FORMLINE;
1989 #ifdef PERL_STRICT_CR
1990 warn("Illegal character \\%03o (carriage return)", '\r');
1992 "(Maybe you didn't strip carriage returns after a network transfer?)\n");
1994 case ' ': case '\t': case '\f': case 013:
1999 if (lex_state != LEX_NORMAL || (in_eval && !rsfp)) {
2001 while (s < d && *s != '\n')
2006 if (lex_formbrack && lex_brackets <= lex_formbrack) {
2008 lex_state = LEX_FORMLINE;
2018 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2023 while (s < bufend && (*s == ' ' || *s == '\t'))
2026 if (strnEQ(s,"=>",2)) {
2027 s = force_word(bufptr,WORD,FALSE,FALSE,FALSE);
2028 OPERATOR('-'); /* unary minus */
2030 last_uni = oldbufptr;
2031 last_lop_op = OP_FTEREAD; /* good enough */
2033 case 'r': FTST(OP_FTEREAD);
2034 case 'w': FTST(OP_FTEWRITE);
2035 case 'x': FTST(OP_FTEEXEC);
2036 case 'o': FTST(OP_FTEOWNED);
2037 case 'R': FTST(OP_FTRREAD);
2038 case 'W': FTST(OP_FTRWRITE);
2039 case 'X': FTST(OP_FTREXEC);
2040 case 'O': FTST(OP_FTROWNED);
2041 case 'e': FTST(OP_FTIS);
2042 case 'z': FTST(OP_FTZERO);
2043 case 's': FTST(OP_FTSIZE);
2044 case 'f': FTST(OP_FTFILE);
2045 case 'd': FTST(OP_FTDIR);
2046 case 'l': FTST(OP_FTLINK);
2047 case 'p': FTST(OP_FTPIPE);
2048 case 'S': FTST(OP_FTSOCK);
2049 case 'u': FTST(OP_FTSUID);
2050 case 'g': FTST(OP_FTSGID);
2051 case 'k': FTST(OP_FTSVTX);
2052 case 'b': FTST(OP_FTBLK);
2053 case 'c': FTST(OP_FTCHR);
2054 case 't': FTST(OP_FTTTY);
2055 case 'T': FTST(OP_FTTEXT);
2056 case 'B': FTST(OP_FTBINARY);
2057 case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2058 case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2059 case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
2061 croak("Unrecognized file test: -%c", (int)tmp);
2068 if (expect == XOPERATOR)
2073 else if (*s == '>') {
2076 if (isIDFIRST(*s)) {
2077 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2085 if (expect == XOPERATOR)
2088 if (isSPACE(*s) || !isSPACE(*bufptr))
2090 OPERATOR('-'); /* unary minus */
2097 if (expect == XOPERATOR)
2102 if (expect == XOPERATOR)
2105 if (isSPACE(*s) || !isSPACE(*bufptr))
2111 if (expect != XOPERATOR) {
2112 s = scan_ident(s, bufend, tokenbuf, sizeof tokenbuf, TRUE);
2114 force_ident(tokenbuf, '*');
2127 if (expect == XOPERATOR) {
2132 s = scan_ident(s, bufend, tokenbuf + 1, sizeof tokenbuf - 1, TRUE);
2135 yyerror("Final % should be \\% or %name");
2138 pending_ident = '%';
2160 if (last_lop == oldoldbufptr || last_uni == oldoldbufptr)
2161 oldbufptr = oldoldbufptr; /* allow print(STDOUT 123) */
2166 if (curcop->cop_line < copline)
2167 copline = curcop->cop_line;
2178 if (lex_brackets <= 0)
2179 yyerror("Unmatched right bracket");
2182 if (lex_state == LEX_INTERPNORMAL) {
2183 if (lex_brackets == 0) {
2184 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
2185 lex_state = LEX_INTERPEND;
2192 if (lex_brackets > 100) {
2193 char* newlb = Renew(lex_brackstack, lex_brackets + 1, char);
2194 if (newlb != lex_brackstack) {
2196 lex_brackstack = newlb;
2201 if (lex_formbrack) {
2205 if (oldoldbufptr == last_lop)
2206 lex_brackstack[lex_brackets++] = XTERM;
2208 lex_brackstack[lex_brackets++] = XOPERATOR;
2209 OPERATOR(HASHBRACK);
2211 while (s < bufend && (*s == ' ' || *s == '\t'))
2215 if (d < bufend && *d == '-') {
2218 while (d < bufend && (*d == ' ' || *d == '\t'))
2221 if (d < bufend && isIDFIRST(*d)) {
2222 d = scan_word(d, tokenbuf + 1, sizeof tokenbuf - 1,
2224 while (d < bufend && (*d == ' ' || *d == '\t'))
2227 char minus = (tokenbuf[0] == '-');
2228 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2235 lex_brackstack[lex_brackets++] = XSTATE;
2239 lex_brackstack[lex_brackets++] = XOPERATOR;
2244 if (oldoldbufptr == last_lop)
2245 lex_brackstack[lex_brackets++] = XTERM;
2247 lex_brackstack[lex_brackets++] = XOPERATOR;
2250 OPERATOR(HASHBRACK);
2251 /* This hack serves to disambiguate a pair of curlies
2252 * as being a block or an anon hash. Normally, expectation
2253 * determines that, but in cases where we're not in a
2254 * position to expect anything in particular (like inside
2255 * eval"") we have to resolve the ambiguity. This code
2256 * covers the case where the first term in the curlies is a
2257 * quoted string. Most other cases need to be explicitly
2258 * disambiguated by prepending a `+' before the opening
2259 * curly in order to force resolution as an anon hash.
2261 * XXX should probably propagate the outer expectation
2262 * into eval"" to rely less on this hack, but that could
2263 * potentially break current behavior of eval"".
2267 if (*s == '\'' || *s == '"' || *s == '`') {
2268 /* common case: get past first string, handling escapes */
2269 for (t++; t < bufend && *t != *s;)
2270 if (*t++ == '\\' && (*t == '\\' || *t == *s))
2274 else if (*s == 'q') {
2277 || ((*t == 'q' || *t == 'x') && ++t < bufend
2278 && !isALNUM(*t)))) {
2280 char open, close, term;
2283 while (t < bufend && isSPACE(*t))
2287 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
2291 for (t++; t < bufend; t++) {
2292 if (*t == '\\' && t+1 < bufend && open != '\\')
2294 else if (*t == open)
2298 for (t++; t < bufend; t++) {
2299 if (*t == '\\' && t+1 < bufend)
2301 else if (*t == close && --brackets <= 0)
2303 else if (*t == open)
2309 else if (isALPHA(*s)) {
2310 for (t++; t < bufend && isALNUM(*t); t++) ;
2312 while (t < bufend && isSPACE(*t))
2314 /* if comma follows first term, call it an anon hash */
2315 /* XXX it could be a comma expression with loop modifiers */
2316 if (t < bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
2317 || (*t == '=' && t[1] == '>')))
2318 OPERATOR(HASHBRACK);
2322 lex_brackstack[lex_brackets-1] = XSTATE;
2328 yylval.ival = curcop->cop_line;
2329 if (isSPACE(*s) || *s == '#')
2330 copline = NOLINE; /* invalidate current command line number */
2335 if (lex_brackets <= 0)
2336 yyerror("Unmatched right bracket");
2338 expect = (expectation)lex_brackstack[--lex_brackets];
2339 if (lex_brackets < lex_formbrack)
2341 if (lex_state == LEX_INTERPNORMAL) {
2342 if (lex_brackets == 0) {
2343 if (lex_fakebrack) {
2344 lex_state = LEX_INTERPEND;
2346 return yylex(); /* ignore fake brackets */
2348 if (*s == '-' && s[1] == '>')
2349 lex_state = LEX_INTERPENDMAYBE;
2350 else if (*s != '[' && *s != '{')
2351 lex_state = LEX_INTERPEND;
2354 if (lex_brackets < lex_fakebrack) {
2357 return yylex(); /* ignore fake brackets */
2367 if (expect == XOPERATOR) {
2368 if (dowarn && isALPHA(*s) && bufptr == linestart) {
2376 s = scan_ident(s - 1, bufend, tokenbuf, sizeof tokenbuf, TRUE);
2379 force_ident(tokenbuf, '&');
2383 yylval.ival = (OPpENTERSUB_AMPER<<8);
2402 if (dowarn && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
2403 warn("Reversed %c= operator",(int)tmp);
2405 if (expect == XSTATE && isALPHA(tmp) &&
2406 (s == linestart+1 || s[-2] == '\n') )
2408 if (in_eval && !rsfp) {
2413 if (strnEQ(s,"=cut",4)) {
2430 if (lex_brackets < lex_formbrack) {
2432 for (t = s; *t == ' ' || *t == '\t'; t++) ;
2433 if (*t == '\n' || *t == '#') {
2451 if (expect != XOPERATOR) {
2452 if (s[1] != '<' && !strchr(s,'>'))
2455 s = scan_heredoc(s);
2457 s = scan_inputsymbol(s);
2458 TERM(sublex_start());
2463 SHop(OP_LEFT_SHIFT);
2477 SHop(OP_RIGHT_SHIFT);
2486 if (expect == XOPERATOR) {
2487 if (lex_formbrack && lex_brackets == lex_formbrack) {
2490 return ','; /* grandfather non-comma-format format */
2494 if (s[1] == '#' && (isALPHA(s[2]) || strchr("_{$:", s[2]))) {
2495 if (expect == XOPERATOR)
2496 no_op("Array length", bufptr);
2498 s = scan_ident(s + 1, bufend, tokenbuf + 1, sizeof tokenbuf - 1,
2503 pending_ident = '#';
2507 if (expect == XOPERATOR)
2508 no_op("Scalar", bufptr);
2510 s = scan_ident(s, bufend, tokenbuf + 1, sizeof tokenbuf - 1, FALSE);
2513 yyerror("Final $ should be \\$ or $name");
2517 /* This kludge not intended to be bulletproof. */
2518 if (tokenbuf[1] == '[' && !tokenbuf[2]) {
2519 yylval.opval = newSVOP(OP_CONST, 0,
2520 newSViv((IV)compiling.cop_arybase));
2521 yylval.opval->op_private = OPpCONST_ARYBASE;
2526 if (lex_state == LEX_NORMAL)
2529 if ((expect != XREF || oldoldbufptr == last_lop) && intuit_more(s)) {
2535 isSPACE(*t) || isALNUM(*t) || *t == '$';
2538 bufptr = skipspace(bufptr);
2539 while (t < bufend && *t != ']')
2541 warn("Multidimensional syntax %.*s not supported",
2542 (t - bufptr) + 1, bufptr);
2546 else if (*s == '{') {
2548 if (dowarn && strEQ(tokenbuf+1, "SIG") &&
2549 (t = strchr(s, '}')) && (t = strchr(t, '=')))
2551 char tmpbuf[sizeof tokenbuf];
2553 for (t++; isSPACE(*t); t++) ;
2554 if (isIDFIRST(*t)) {
2555 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
2556 if (*t != '(' && perl_get_cv(tmpbuf, FALSE))
2557 warn("You need to quote \"%s\"", tmpbuf);
2564 if (lex_state == LEX_NORMAL && isSPACE(*d)) {
2565 bool islop = (last_lop == oldoldbufptr);
2566 if (!islop || last_lop_op == OP_GREPSTART)
2568 else if (strchr("$@\"'`q", *s))
2569 expect = XTERM; /* e.g. print $fh "foo" */
2570 else if (strchr("&*<%", *s) && isIDFIRST(s[1]))
2571 expect = XTERM; /* e.g. print $fh &sub */
2572 else if (isIDFIRST(*s)) {
2573 char tmpbuf[sizeof tokenbuf];
2574 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2575 if (tmp = keyword(tmpbuf, len)) {
2576 /* binary operators exclude handle interpretations */
2588 expect = XTERM; /* e.g. print $fh length() */
2593 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
2594 if (gv && GvCVu(gv))
2595 expect = XTERM; /* e.g. print $fh subr() */
2598 else if (isDIGIT(*s))
2599 expect = XTERM; /* e.g. print $fh 3 */
2600 else if (*s == '.' && isDIGIT(s[1]))
2601 expect = XTERM; /* e.g. print $fh .3 */
2602 else if (strchr("/?-+", *s) && !isSPACE(s[1]))
2603 expect = XTERM; /* e.g. print $fh -1 */
2604 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]))
2605 expect = XTERM; /* print $fh <<"EOF" */
2607 pending_ident = '$';
2611 if (expect == XOPERATOR)
2614 s = scan_ident(s, bufend, tokenbuf + 1, sizeof tokenbuf - 1, FALSE);
2617 yyerror("Final @ should be \\@ or @name");
2620 if (lex_state == LEX_NORMAL)
2622 if ((expect != XREF || oldoldbufptr == last_lop) && intuit_more(s)) {
2626 /* Warn about @ where they meant $. */
2628 if (*s == '[' || *s == '{') {
2630 while (*t && (isALNUM(*t) || strchr(" \t$#+-'\"", *t)))
2632 if (*t == '}' || *t == ']') {
2634 bufptr = skipspace(bufptr);
2635 warn("Scalar value %.*s better written as $%.*s",
2636 t-bufptr, bufptr, t-bufptr-1, bufptr+1);
2641 pending_ident = '@';
2644 case '/': /* may either be division or pattern */
2645 case '?': /* may either be conditional or pattern */
2646 if (expect != XOPERATOR) {
2647 /* Disable warning on "study /blah/" */
2648 if (oldoldbufptr == last_uni
2649 && (*last_uni != 's' || s - last_uni < 5
2650 || memNE(last_uni, "study", 5) || isALNUM(last_uni[5])))
2653 TERM(sublex_start());
2661 if (lex_formbrack && lex_brackets == lex_formbrack && s[1] == '\n' &&
2662 (s == linestart || s[-1] == '\n') ) {
2667 if (expect == XOPERATOR || !isDIGIT(s[1])) {
2673 yylval.ival = OPf_SPECIAL;
2679 if (expect != XOPERATOR)
2684 case '0': case '1': case '2': case '3': case '4':
2685 case '5': case '6': case '7': case '8': case '9':
2687 if (expect == XOPERATOR)
2693 if (expect == XOPERATOR) {
2694 if (lex_formbrack && lex_brackets == lex_formbrack) {
2697 return ','; /* grandfather non-comma-format format */
2703 missingterm((char*)0);
2704 yylval.ival = OP_CONST;
2705 TERM(sublex_start());
2709 if (expect == XOPERATOR) {
2710 if (lex_formbrack && lex_brackets == lex_formbrack) {
2713 return ','; /* grandfather non-comma-format format */
2719 missingterm((char*)0);
2720 yylval.ival = OP_CONST;
2721 for (d = SvPV(lex_stuff, len); len; len--, d++) {
2722 if (*d == '$' || *d == '@' || *d == '\\') {
2723 yylval.ival = OP_STRINGIFY;
2727 TERM(sublex_start());
2731 if (expect == XOPERATOR)
2732 no_op("Backticks",s);
2734 missingterm((char*)0);
2735 yylval.ival = OP_BACKTICK;
2737 TERM(sublex_start());
2741 if (dowarn && lex_inwhat && isDIGIT(*s))
2742 warn("Can't use \\%c to mean $%c in expression", *s, *s);
2743 if (expect == XOPERATOR)
2744 no_op("Backslash",s);
2748 if (isDIGIT(s[1]) && expect == XOPERATOR) {
2787 s = scan_word(s, tokenbuf, sizeof tokenbuf, FALSE, &len);
2789 /* Some keywords can be followed by any delimiter, including ':' */
2790 tmp = (len == 1 && strchr("msyq", tokenbuf[0]) ||
2791 len == 2 && ((tokenbuf[0] == 't' && tokenbuf[1] == 'r') ||
2792 (tokenbuf[0] == 'q' &&
2793 strchr("qwx", tokenbuf[1]))));
2795 /* x::* is just a word, unless x is "CORE" */
2796 if (!tmp && *s == ':' && s[1] == ':' && strNE(tokenbuf, "CORE"))
2800 while (d < bufend && isSPACE(*d))
2801 d++; /* no comments skipped here, or s### is misparsed */
2803 /* Is this a label? */
2804 if (!tmp && expect == XSTATE
2805 && d < bufend && *d == ':' && *(d + 1) != ':') {
2807 yylval.pval = savepv(tokenbuf);
2812 /* Check for keywords */
2813 tmp = keyword(tokenbuf, len);
2815 /* Is this a word before a => operator? */
2816 if (strnEQ(d,"=>",2)) {
2818 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(tokenbuf,0));
2819 yylval.opval->op_private = OPpCONST_BARE;
2823 if (tmp < 0) { /* second-class keyword? */
2824 GV *ogv = Nullgv; /* override (winner) */
2825 GV *hgv = Nullgv; /* hidden (loser) */
2826 if (expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
2828 if ((gv = gv_fetchpv(tokenbuf, FALSE, SVt_PVCV)) &&
2831 if (GvIMPORTED_CV(gv))
2833 else if (! CvMETHOD(cv))
2837 (gvp = (GV**)hv_fetch(globalstash,tokenbuf,len,FALSE)) &&
2838 (gv = *gvp) != (GV*)&sv_undef &&
2839 GvCVu(gv) && GvIMPORTED_CV(gv))
2845 tmp = 0; /* overridden by import or by GLOBAL */
2848 && -tmp==KEY_lock /* XXX generalizable kludge */
2849 && !hv_fetch(GvHVn(incgv), "Thread.pm", 9, FALSE))
2851 tmp = 0; /* any sub overrides "weak" keyword */
2853 else { /* no override */
2858 warn("Ambiguous call resolved as CORE::%s(), "
2859 "qualify as such or use &", GvENAME(hgv));
2866 default: /* not a keyword */
2869 char lastchar = (bufptr == oldoldbufptr ? 0 : bufptr[-1]);
2871 /* Get the rest if it looks like a package qualifier */
2873 if (*s == '\'' || *s == ':' && s[1] == ':') {
2875 s = scan_word(s, tokenbuf + len, sizeof tokenbuf - len,
2878 croak("Bad name after %s%s", tokenbuf,
2879 *s == '\'' ? "'" : "::");
2883 if (expect == XOPERATOR) {
2884 if (bufptr == linestart) {
2890 no_op("Bareword",s);
2893 /* Look for a subroutine with this name in current package,
2894 unless name is "Foo::", in which case Foo is a bearword
2895 (and a package name). */
2898 tokenbuf[len - 2] == ':' && tokenbuf[len - 1] == ':')
2900 if (dowarn && ! gv_fetchpv(tokenbuf, FALSE, SVt_PVHV))
2901 warn("Bareword \"%s\" refers to nonexistent package",
2904 tokenbuf[len] = '\0';
2911 gv = gv_fetchpv(tokenbuf, FALSE, SVt_PVCV);
2914 /* if we saw a global override before, get the right name */
2917 sv = newSVpv("CORE::GLOBAL::",14);
2918 sv_catpv(sv,tokenbuf);
2921 sv = newSVpv(tokenbuf,0);
2923 /* Presume this is going to be a bareword of some sort. */
2926 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2927 yylval.opval->op_private = OPpCONST_BARE;
2929 /* And if "Foo::", then that's what it certainly is. */
2934 /* See if it's the indirect object for a list operator. */
2937 oldoldbufptr < bufptr &&
2938 (oldoldbufptr == last_lop || oldoldbufptr == last_uni) &&
2939 /* NO SKIPSPACE BEFORE HERE! */
2941 || ((opargs[last_lop_op] >> OASHIFT)& 7) == OA_FILEREF
2942 || (last_lop_op == OP_ENTERSUB
2944 && last_proto[last_proto[0] == ';' ? 1 : 0] == '*')) )
2946 bool immediate_paren = *s == '(';
2948 /* (Now we can afford to cross potential line boundary.) */
2951 /* Two barewords in a row may indicate method call. */
2953 if ((isALPHA(*s) || *s == '$') && (tmp=intuit_method(s,gv)))
2956 /* If not a declared subroutine, it's an indirect object. */
2957 /* (But it's an indir obj regardless for sort.) */
2959 if ((last_lop_op == OP_SORT ||
2960 (!immediate_paren && (!gv || !GvCVu(gv))) ) &&
2961 (last_lop_op != OP_MAPSTART && last_lop_op != OP_GREPSTART)){
2962 expect = (last_lop == oldoldbufptr) ? XTERM : XOPERATOR;
2967 /* If followed by a paren, it's certainly a subroutine. */
2973 if (gv && GvCVu(gv)) {
2974 for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
2975 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
2980 nextval[nexttoke].opval = yylval.opval;
2987 /* If followed by var or block, call it a method (unless sub) */
2989 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
2990 last_lop = oldbufptr;
2991 last_lop_op = OP_METHOD;
2995 /* If followed by a bareword, see if it looks like indir obj. */
2997 if ((isALPHA(*s) || *s == '$') && (tmp = intuit_method(s,gv)))
3000 /* Not a method, so call it a subroutine (if defined) */
3002 if (gv && GvCVu(gv)) {
3004 if (lastchar == '-')
3005 warn("Ambiguous use of -%s resolved as -&%s()",
3006 tokenbuf, tokenbuf);
3007 last_lop = oldbufptr;
3008 last_lop_op = OP_ENTERSUB;
3009 /* Check for a constant sub */
3011 if ((sv = cv_const_sv(cv))) {
3013 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3014 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3015 yylval.opval->op_private = 0;
3019 /* Resolve to GV now. */
3020 op_free(yylval.opval);
3021 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3022 /* Is there a prototype? */
3025 last_proto = SvPV((SV*)cv, len);
3028 if (strEQ(last_proto, "$"))
3030 if (*last_proto == '&' && *s == '{') {
3031 sv_setpv(subname,"__ANON__");
3036 nextval[nexttoke].opval = yylval.opval;
3042 if (hints & HINT_STRICT_SUBS &&
3045 last_lop_op != OP_TRUNCATE && /* S/F prototype in opcode.pl */
3046 last_lop_op != OP_ACCEPT &&
3047 last_lop_op != OP_PIPE_OP &&
3048 last_lop_op != OP_SOCKPAIR)
3051 "Bareword \"%s\" not allowed while \"strict subs\" in use",
3056 /* Call it a bare word */
3060 if (lastchar != '-') {
3061 for (d = tokenbuf; *d && isLOWER(*d); d++) ;
3063 warn(warn_reserved, tokenbuf);
3068 if (lastchar && strchr("*%&", lastchar)) {
3069 warn("Operator or semicolon missing before %c%s",
3070 lastchar, tokenbuf);
3071 warn("Ambiguous use of %c resolved as operator %c",
3072 lastchar, lastchar);
3078 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3079 newSVsv(GvSV(curcop->cop_filegv)));
3083 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3084 newSVpvf("%ld", (long)curcop->cop_line));
3087 case KEY___PACKAGE__:
3088 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3090 ? newSVsv(curstname)
3099 if (rsfp && (!in_eval || tokenbuf[2] == 'D')) {
3100 char *pname = "main";
3101 if (tokenbuf[2] == 'D')
3102 pname = HvNAME(curstash ? curstash : defstash);
3103 gv = gv_fetchpv(form("%s::DATA", pname), TRUE, SVt_PVIO);
3106 GvIOp(gv) = newIO();
3107 IoIFP(GvIOp(gv)) = rsfp;
3108 #if defined(HAS_FCNTL) && defined(F_SETFD)
3110 int fd = PerlIO_fileno(rsfp);
3111 fcntl(fd,F_SETFD,fd >= 3);
3114 /* Mark this internal pseudo-handle as clean */
3115 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3117 IoTYPE(GvIOp(gv)) = '|';
3118 else if ((PerlIO*)rsfp == PerlIO_stdin())
3119 IoTYPE(GvIOp(gv)) = '-';
3121 IoTYPE(GvIOp(gv)) = '<';
3132 if (expect == XSTATE) {
3139 if (*s == ':' && s[1] == ':') {
3142 s = scan_word(s, tokenbuf, sizeof tokenbuf, FALSE, &len);
3143 tmp = keyword(tokenbuf, len);
3157 LOP(OP_ACCEPT,XTERM);
3163 LOP(OP_ATAN2,XTERM);
3172 LOP(OP_BLESS,XTERM);
3181 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
3201 LOP(OP_CRYPT,XTERM);
3205 for (d = s; d < bufend && (isSPACE(*d) || *d == '('); d++) ;
3206 if (*d != '0' && isDIGIT(*d))
3207 yywarn("chmod: mode argument is missing initial 0");
3209 LOP(OP_CHMOD,XTERM);
3212 LOP(OP_CHOWN,XTERM);
3215 LOP(OP_CONNECT,XTERM);
3231 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3235 hints |= HINT_BLOCK_SCOPE;
3245 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3246 LOP(OP_DBMOPEN,XTERM);
3252 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3259 yylval.ival = curcop->cop_line;
3273 expect = (*s == '{') ? XTERMBLOCK : XTERM;
3274 UNIBRACK(OP_ENTEREVAL);
3289 case KEY_endhostent:
3295 case KEY_endservent:
3298 case KEY_endprotoent:
3309 yylval.ival = curcop->cop_line;
3311 if (expect == XSTATE && isIDFIRST(*s)) {
3313 if ((bufend - p) >= 3 &&
3314 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3318 croak("Missing $ on loop variable");
3323 LOP(OP_FORMLINE,XTERM);
3329 LOP(OP_FCNTL,XTERM);
3335 LOP(OP_FLOCK,XTERM);
3344 LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
3347 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3362 case KEY_getpriority:
3363 LOP(OP_GETPRIORITY,XTERM);
3365 case KEY_getprotobyname:
3368 case KEY_getprotobynumber:
3369 LOP(OP_GPBYNUMBER,XTERM);
3371 case KEY_getprotoent:
3383 case KEY_getpeername:
3384 UNI(OP_GETPEERNAME);
3386 case KEY_gethostbyname:
3389 case KEY_gethostbyaddr:
3390 LOP(OP_GHBYADDR,XTERM);
3392 case KEY_gethostent:
3395 case KEY_getnetbyname:
3398 case KEY_getnetbyaddr:
3399 LOP(OP_GNBYADDR,XTERM);
3404 case KEY_getservbyname:
3405 LOP(OP_GSBYNAME,XTERM);
3407 case KEY_getservbyport:
3408 LOP(OP_GSBYPORT,XTERM);
3410 case KEY_getservent:
3413 case KEY_getsockname:
3414 UNI(OP_GETSOCKNAME);
3416 case KEY_getsockopt:
3417 LOP(OP_GSOCKOPT,XTERM);
3439 yylval.ival = curcop->cop_line;
3443 LOP(OP_INDEX,XTERM);
3449 LOP(OP_IOCTL,XTERM);
3461 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3492 LOP(OP_LISTEN,XTERM);
3502 TERM(sublex_start());
3505 LOP(OP_MAPSTART,XREF);
3508 LOP(OP_MKDIR,XTERM);
3511 LOP(OP_MSGCTL,XTERM);
3514 LOP(OP_MSGGET,XTERM);
3517 LOP(OP_MSGRCV,XTERM);
3520 LOP(OP_MSGSND,XTERM);
3525 if (isIDFIRST(*s)) {
3526 s = scan_word(s, tokenbuf, sizeof tokenbuf, TRUE, &len);
3527 in_my_stash = gv_stashpv(tokenbuf, FALSE);
3531 sprintf(tmpbuf, "No such class %.1000s", tokenbuf);
3538 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3545 if (expect != XSTATE)
3546 yyerror("\"no\" not allowed in expression");
3547 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3548 s = force_version(s);
3557 if (isIDFIRST(*s)) {
3559 for (d = s; isALNUM(*d); d++) ;
3561 if (strchr("|&*+-=!?:.", *t))
3562 warn("Precedence problem: open %.*s should be open(%.*s)",
3568 yylval.ival = OP_OR;
3578 LOP(OP_OPEN_DIR,XTERM);
3581 checkcomma(s,tokenbuf,"filehandle");
3585 checkcomma(s,tokenbuf,"filehandle");
3604 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3608 LOP(OP_PIPE_OP,XTERM);
3613 missingterm((char*)0);
3614 yylval.ival = OP_CONST;
3615 TERM(sublex_start());
3623 missingterm((char*)0);
3624 if (dowarn && SvLEN(lex_stuff)) {
3625 d = SvPV_force(lex_stuff, len);
3626 for (; len; --len, ++d) {
3628 warn("Possible attempt to separate words with commas");
3632 warn("Possible attempt to put comments in qw() list");
3638 nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, tokeq(lex_stuff));
3642 nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(" ",1));
3645 yylval.ival = OP_SPLIT;
3649 last_lop = oldbufptr;
3650 last_lop_op = OP_SPLIT;
3656 missingterm((char*)0);
3657 yylval.ival = OP_STRINGIFY;
3658 if (SvIVX(lex_stuff) == '\'')
3659 SvIVX(lex_stuff) = 0; /* qq'$foo' should intepolate */
3660 TERM(sublex_start());
3665 missingterm((char*)0);
3666 yylval.ival = OP_BACKTICK;
3668 TERM(sublex_start());
3675 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3676 if (isIDFIRST(*tokenbuf))
3677 gv_stashpvn(tokenbuf, strlen(tokenbuf), TRUE);
3679 yyerror("<> should be quotes");
3686 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3690 LOP(OP_RENAME,XTERM);
3699 LOP(OP_RINDEX,XTERM);
3722 LOP(OP_REVERSE,XTERM);
3733 TERM(sublex_start());
3735 TOKEN(1); /* force error */
3744 LOP(OP_SELECT,XTERM);
3750 LOP(OP_SEMCTL,XTERM);
3753 LOP(OP_SEMGET,XTERM);
3756 LOP(OP_SEMOP,XTERM);
3762 LOP(OP_SETPGRP,XTERM);
3764 case KEY_setpriority:
3765 LOP(OP_SETPRIORITY,XTERM);
3767 case KEY_sethostent:
3773 case KEY_setservent:
3776 case KEY_setprotoent:
3786 LOP(OP_SEEKDIR,XTERM);
3788 case KEY_setsockopt:
3789 LOP(OP_SSOCKOPT,XTERM);
3795 LOP(OP_SHMCTL,XTERM);
3798 LOP(OP_SHMGET,XTERM);
3801 LOP(OP_SHMREAD,XTERM);
3804 LOP(OP_SHMWRITE,XTERM);
3807 LOP(OP_SHUTDOWN,XTERM);
3816 LOP(OP_SOCKET,XTERM);
3818 case KEY_socketpair:
3819 LOP(OP_SOCKPAIR,XTERM);
3822 checkcomma(s,tokenbuf,"subroutine name");
3824 if (*s == ';' || *s == ')') /* probably a close */
3825 croak("sort is now a reserved word");
3827 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3831 LOP(OP_SPLIT,XTERM);
3834 LOP(OP_SPRINTF,XTERM);
3837 LOP(OP_SPLICE,XTERM);
3853 LOP(OP_SUBSTR,XTERM);
3860 if (isIDFIRST(*s) || *s == '\'' || *s == ':') {
3861 char tmpbuf[sizeof tokenbuf];
3863 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3864 if (strchr(tmpbuf, ':'))
3865 sv_setpv(subname, tmpbuf);
3867 sv_setsv(subname,curstname);
3868 sv_catpvn(subname,"::",2);
3869 sv_catpvn(subname,tmpbuf,len);
3871 s = force_word(s,WORD,FALSE,TRUE,TRUE);
3875 expect = XTERMBLOCK;
3876 sv_setpv(subname,"?");
3879 if (tmp == KEY_format) {
3882 lex_formbrack = lex_brackets + 1;
3886 /* Look for a prototype */
3893 SvREFCNT_dec(lex_stuff);
3895 croak("Prototype not terminated");
3898 d = SvPVX(lex_stuff);
3900 for (p = d; *p; ++p) {
3905 SvCUR(lex_stuff) = tmp;
3908 nextval[1] = nextval[0];
3909 nexttype[1] = nexttype[0];
3910 nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, lex_stuff);
3911 nexttype[0] = THING;
3912 if (nexttoke == 1) {
3913 lex_defer = lex_state;
3914 lex_expect = expect;
3915 lex_state = LEX_KNOWNEXT;
3920 if (*SvPV(subname,na) == '?') {
3921 sv_setpv(subname,"__ANON__");
3928 LOP(OP_SYSTEM,XREF);
3931 LOP(OP_SYMLINK,XTERM);
3934 LOP(OP_SYSCALL,XTERM);
3937 LOP(OP_SYSOPEN,XTERM);
3940 LOP(OP_SYSSEEK,XTERM);
3943 LOP(OP_SYSREAD,XTERM);
3946 LOP(OP_SYSWRITE,XTERM);
3950 TERM(sublex_start());
3971 LOP(OP_TRUNCATE,XTERM);
3983 yylval.ival = curcop->cop_line;
3987 yylval.ival = curcop->cop_line;
3991 LOP(OP_UNLINK,XTERM);
3997 LOP(OP_UNPACK,XTERM);
4000 LOP(OP_UTIME,XTERM);
4004 for (d = s; d < bufend && (isSPACE(*d) || *d == '('); d++) ;
4005 if (*d != '0' && isDIGIT(*d))
4006 yywarn("umask: argument is missing initial 0");
4011 LOP(OP_UNSHIFT,XTERM);
4014 if (expect != XSTATE)
4015 yyerror("\"use\" not allowed in expression");
4018 s = force_version(s);
4019 if(*s == ';' || (s = skipspace(s), *s == ';')) {
4020 nextval[nexttoke].opval = Nullop;
4025 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4026 s = force_version(s);
4039 yylval.ival = curcop->cop_line;
4043 hints |= HINT_BLOCK_SCOPE;
4050 LOP(OP_WAITPID,XTERM);
4056 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
4060 if (expect == XOPERATOR)
4066 yylval.ival = OP_XOR;
4071 TERM(sublex_start());
4077 keyword(register char *d, I32 len)
4082 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
4083 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
4084 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
4085 if (strEQ(d,"__DATA__")) return KEY___DATA__;
4086 if (strEQ(d,"__END__")) return KEY___END__;
4090 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
4095 if (strEQ(d,"and")) return -KEY_and;
4096 if (strEQ(d,"abs")) return -KEY_abs;
4099 if (strEQ(d,"alarm")) return -KEY_alarm;
4100 if (strEQ(d,"atan2")) return -KEY_atan2;
4103 if (strEQ(d,"accept")) return -KEY_accept;
4108 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
4111 if (strEQ(d,"bless")) return -KEY_bless;
4112 if (strEQ(d,"bind")) return -KEY_bind;
4113 if (strEQ(d,"binmode")) return -KEY_binmode;
4116 if (strEQ(d,"CORE")) return -KEY_CORE;
4121 if (strEQ(d,"cmp")) return -KEY_cmp;
4122 if (strEQ(d,"chr")) return -KEY_chr;
4123 if (strEQ(d,"cos")) return -KEY_cos;
4126 if (strEQ(d,"chop")) return KEY_chop;
4129 if (strEQ(d,"close")) return -KEY_close;
4130 if (strEQ(d,"chdir")) return -KEY_chdir;
4131 if (strEQ(d,"chomp")) return KEY_chomp;
4132 if (strEQ(d,"chmod")) return -KEY_chmod;
4133 if (strEQ(d,"chown")) return -KEY_chown;
4134 if (strEQ(d,"crypt")) return -KEY_crypt;
4137 if (strEQ(d,"chroot")) return -KEY_chroot;
4138 if (strEQ(d,"caller")) return -KEY_caller;
4141 if (strEQ(d,"connect")) return -KEY_connect;
4144 if (strEQ(d,"closedir")) return -KEY_closedir;
4145 if (strEQ(d,"continue")) return -KEY_continue;
4150 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
4155 if (strEQ(d,"do")) return KEY_do;
4158 if (strEQ(d,"die")) return -KEY_die;
4161 if (strEQ(d,"dump")) return -KEY_dump;
4164 if (strEQ(d,"delete")) return KEY_delete;
4167 if (strEQ(d,"defined")) return KEY_defined;
4168 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
4171 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
4176 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
4177 if (strEQ(d,"END")) return KEY_END;
4182 if (strEQ(d,"eq")) return -KEY_eq;
4185 if (strEQ(d,"eof")) return -KEY_eof;
4186 if (strEQ(d,"exp")) return -KEY_exp;
4189 if (strEQ(d,"else")) return KEY_else;
4190 if (strEQ(d,"exit")) return -KEY_exit;
4191 if (strEQ(d,"eval")) return KEY_eval;
4192 if (strEQ(d,"exec")) return -KEY_exec;
4193 if (strEQ(d,"each")) return KEY_each;
4196 if (strEQ(d,"elsif")) return KEY_elsif;
4199 if (strEQ(d,"exists")) return KEY_exists;
4200 if (strEQ(d,"elseif")) warn("elseif should be elsif");
4203 if (strEQ(d,"endgrent")) return -KEY_endgrent;
4204 if (strEQ(d,"endpwent")) return -KEY_endpwent;
4207 if (strEQ(d,"endnetent")) return -KEY_endnetent;
4210 if (strEQ(d,"endhostent")) return -KEY_endhostent;
4211 if (strEQ(d,"endservent")) return -KEY_endservent;
4214 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
4221 if (strEQ(d,"for")) return KEY_for;
4224 if (strEQ(d,"fork")) return -KEY_fork;
4227 if (strEQ(d,"fcntl")) return -KEY_fcntl;
4228 if (strEQ(d,"flock")) return -KEY_flock;
4231 if (strEQ(d,"format")) return KEY_format;
4232 if (strEQ(d,"fileno")) return -KEY_fileno;
4235 if (strEQ(d,"foreach")) return KEY_foreach;
4238 if (strEQ(d,"formline")) return -KEY_formline;
4244 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
4245 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
4249 if (strnEQ(d,"get",3)) {
4254 if (strEQ(d,"ppid")) return -KEY_getppid;
4255 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
4258 if (strEQ(d,"pwent")) return -KEY_getpwent;
4259 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
4260 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
4263 if (strEQ(d,"peername")) return -KEY_getpeername;
4264 if (strEQ(d,"protoent")) return -KEY_getprotoent;
4265 if (strEQ(d,"priority")) return -KEY_getpriority;
4268 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
4271 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
4275 else if (*d == 'h') {
4276 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
4277 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
4278 if (strEQ(d,"hostent")) return -KEY_gethostent;
4280 else if (*d == 'n') {
4281 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
4282 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
4283 if (strEQ(d,"netent")) return -KEY_getnetent;
4285 else if (*d == 's') {
4286 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
4287 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
4288 if (strEQ(d,"servent")) return -KEY_getservent;
4289 if (strEQ(d,"sockname")) return -KEY_getsockname;
4290 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
4292 else if (*d == 'g') {
4293 if (strEQ(d,"grent")) return -KEY_getgrent;
4294 if (strEQ(d,"grnam")) return -KEY_getgrnam;
4295 if (strEQ(d,"grgid")) return -KEY_getgrgid;
4297 else if (*d == 'l') {
4298 if (strEQ(d,"login")) return -KEY_getlogin;
4300 else if (strEQ(d,"c")) return -KEY_getc;
4305 if (strEQ(d,"gt")) return -KEY_gt;
4306 if (strEQ(d,"ge")) return -KEY_ge;
4309 if (strEQ(d,"grep")) return KEY_grep;
4310 if (strEQ(d,"goto")) return KEY_goto;
4311 if (strEQ(d,"glob")) return KEY_glob;
4314 if (strEQ(d,"gmtime")) return -KEY_gmtime;
4319 if (strEQ(d,"hex")) return -KEY_hex;
4322 if (strEQ(d,"INIT")) return KEY_INIT;
4327 if (strEQ(d,"if")) return KEY_if;
4330 if (strEQ(d,"int")) return -KEY_int;
4333 if (strEQ(d,"index")) return -KEY_index;
4334 if (strEQ(d,"ioctl")) return -KEY_ioctl;
4339 if (strEQ(d,"join")) return -KEY_join;
4343 if (strEQ(d,"keys")) return KEY_keys;
4344 if (strEQ(d,"kill")) return -KEY_kill;
4349 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
4350 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
4356 if (strEQ(d,"lt")) return -KEY_lt;
4357 if (strEQ(d,"le")) return -KEY_le;
4358 if (strEQ(d,"lc")) return -KEY_lc;
4361 if (strEQ(d,"log")) return -KEY_log;
4364 if (strEQ(d,"last")) return KEY_last;
4365 if (strEQ(d,"link")) return -KEY_link;
4366 if (strEQ(d,"lock")) return -KEY_lock;
4369 if (strEQ(d,"local")) return KEY_local;
4370 if (strEQ(d,"lstat")) return -KEY_lstat;
4373 if (strEQ(d,"length")) return -KEY_length;
4374 if (strEQ(d,"listen")) return -KEY_listen;
4377 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
4380 if (strEQ(d,"localtime")) return -KEY_localtime;
4386 case 1: return KEY_m;
4388 if (strEQ(d,"my")) return KEY_my;
4391 if (strEQ(d,"map")) return KEY_map;
4394 if (strEQ(d,"mkdir")) return -KEY_mkdir;
4397 if (strEQ(d,"msgctl")) return -KEY_msgctl;
4398 if (strEQ(d,"msgget")) return -KEY_msgget;
4399 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
4400 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
4405 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
4408 if (strEQ(d,"next")) return KEY_next;
4409 if (strEQ(d,"ne")) return -KEY_ne;
4410 if (strEQ(d,"not")) return -KEY_not;
4411 if (strEQ(d,"no")) return KEY_no;
4416 if (strEQ(d,"or")) return -KEY_or;
4419 if (strEQ(d,"ord")) return -KEY_ord;
4420 if (strEQ(d,"oct")) return -KEY_oct;
4421 if (strEQ(d,"our")) { deprecate("reserved word \"our\"");
4425 if (strEQ(d,"open")) return -KEY_open;
4428 if (strEQ(d,"opendir")) return -KEY_opendir;
4435 if (strEQ(d,"pop")) return KEY_pop;
4436 if (strEQ(d,"pos")) return KEY_pos;
4439 if (strEQ(d,"push")) return KEY_push;
4440 if (strEQ(d,"pack")) return -KEY_pack;
4441 if (strEQ(d,"pipe")) return -KEY_pipe;
4444 if (strEQ(d,"print")) return KEY_print;
4447 if (strEQ(d,"printf")) return KEY_printf;
4450 if (strEQ(d,"package")) return KEY_package;
4453 if (strEQ(d,"prototype")) return KEY_prototype;
4458 if (strEQ(d,"q")) return KEY_q;
4459 if (strEQ(d,"qq")) return KEY_qq;
4460 if (strEQ(d,"qw")) return KEY_qw;
4461 if (strEQ(d,"qx")) return KEY_qx;
4463 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
4468 if (strEQ(d,"ref")) return -KEY_ref;
4471 if (strEQ(d,"read")) return -KEY_read;
4472 if (strEQ(d,"rand")) return -KEY_rand;
4473 if (strEQ(d,"recv")) return -KEY_recv;
4474 if (strEQ(d,"redo")) return KEY_redo;
4477 if (strEQ(d,"rmdir")) return -KEY_rmdir;
4478 if (strEQ(d,"reset")) return -KEY_reset;
4481 if (strEQ(d,"return")) return KEY_return;
4482 if (strEQ(d,"rename")) return -KEY_rename;
4483 if (strEQ(d,"rindex")) return -KEY_rindex;
4486 if (strEQ(d,"require")) return -KEY_require;
4487 if (strEQ(d,"reverse")) return -KEY_reverse;
4488 if (strEQ(d,"readdir")) return -KEY_readdir;
4491 if (strEQ(d,"readlink")) return -KEY_readlink;
4492 if (strEQ(d,"readline")) return -KEY_readline;
4493 if (strEQ(d,"readpipe")) return -KEY_readpipe;
4496 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
4502 case 0: return KEY_s;
4504 if (strEQ(d,"scalar")) return KEY_scalar;
4509 if (strEQ(d,"seek")) return -KEY_seek;
4510 if (strEQ(d,"send")) return -KEY_send;
4513 if (strEQ(d,"semop")) return -KEY_semop;
4516 if (strEQ(d,"select")) return -KEY_select;
4517 if (strEQ(d,"semctl")) return -KEY_semctl;
4518 if (strEQ(d,"semget")) return -KEY_semget;
4521 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
4522 if (strEQ(d,"seekdir")) return -KEY_seekdir;
4525 if (strEQ(d,"setpwent")) return -KEY_setpwent;
4526 if (strEQ(d,"setgrent")) return -KEY_setgrent;
4529 if (strEQ(d,"setnetent")) return -KEY_setnetent;
4532 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
4533 if (strEQ(d,"sethostent")) return -KEY_sethostent;
4534 if (strEQ(d,"setservent")) return -KEY_setservent;
4537 if (strEQ(d,"setpriority")) return -KEY_setpriority;
4538 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
4545 if (strEQ(d,"shift")) return KEY_shift;
4548 if (strEQ(d,"shmctl")) return -KEY_shmctl;
4549 if (strEQ(d,"shmget")) return -KEY_shmget;
4552 if (strEQ(d,"shmread")) return -KEY_shmread;
4555 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
4556 if (strEQ(d,"shutdown")) return -KEY_shutdown;
4561 if (strEQ(d,"sin")) return -KEY_sin;
4564 if (strEQ(d,"sleep")) return -KEY_sleep;
4567 if (strEQ(d,"sort")) return KEY_sort;
4568 if (strEQ(d,"socket")) return -KEY_socket;
4569 if (strEQ(d,"socketpair")) return -KEY_socketpair;
4572 if (strEQ(d,"split")) return KEY_split;
4573 if (strEQ(d,"sprintf")) return -KEY_sprintf;
4574 if (strEQ(d,"splice")) return KEY_splice;
4577 if (strEQ(d,"sqrt")) return -KEY_sqrt;
4580 if (strEQ(d,"srand")) return -KEY_srand;
4583 if (strEQ(d,"stat")) return -KEY_stat;
4584 if (strEQ(d,"study")) return KEY_study;
4587 if (strEQ(d,"substr")) return -KEY_substr;
4588 if (strEQ(d,"sub")) return KEY_sub;
4593 if (strEQ(d,"system")) return -KEY_system;
4596 if (strEQ(d,"symlink")) return -KEY_symlink;
4597 if (strEQ(d,"syscall")) return -KEY_syscall;
4598 if (strEQ(d,"sysopen")) return -KEY_sysopen;
4599 if (strEQ(d,"sysread")) return -KEY_sysread;
4600 if (strEQ(d,"sysseek")) return -KEY_sysseek;
4603 if (strEQ(d,"syswrite")) return -KEY_syswrite;
4612 if (strEQ(d,"tr")) return KEY_tr;
4615 if (strEQ(d,"tie")) return KEY_tie;
4618 if (strEQ(d,"tell")) return -KEY_tell;
4619 if (strEQ(d,"tied")) return KEY_tied;
4620 if (strEQ(d,"time")) return -KEY_time;
4623 if (strEQ(d,"times")) return -KEY_times;
4626 if (strEQ(d,"telldir")) return -KEY_telldir;
4629 if (strEQ(d,"truncate")) return -KEY_truncate;
4636 if (strEQ(d,"uc")) return -KEY_uc;
4639 if (strEQ(d,"use")) return KEY_use;
4642 if (strEQ(d,"undef")) return KEY_undef;
4643 if (strEQ(d,"until")) return KEY_until;
4644 if (strEQ(d,"untie")) return KEY_untie;
4645 if (strEQ(d,"utime")) return -KEY_utime;
4646 if (strEQ(d,"umask")) return -KEY_umask;
4649 if (strEQ(d,"unless")) return KEY_unless;
4650 if (strEQ(d,"unpack")) return -KEY_unpack;
4651 if (strEQ(d,"unlink")) return -KEY_unlink;
4654 if (strEQ(d,"unshift")) return KEY_unshift;
4655 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
4660 if (strEQ(d,"values")) return -KEY_values;
4661 if (strEQ(d,"vec")) return -KEY_vec;
4666 if (strEQ(d,"warn")) return -KEY_warn;
4667 if (strEQ(d,"wait")) return -KEY_wait;
4670 if (strEQ(d,"while")) return KEY_while;
4671 if (strEQ(d,"write")) return -KEY_write;
4674 if (strEQ(d,"waitpid")) return -KEY_waitpid;
4677 if (strEQ(d,"wantarray")) return -KEY_wantarray;
4682 if (len == 1) return -KEY_x;
4683 if (strEQ(d,"xor")) return -KEY_xor;
4686 if (len == 1) return KEY_y;
4695 checkcomma(register char *s, char *name, char *what)
4699 if (dowarn && *s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
4701 for (w = s+2; *w && level; w++) {
4708 for (; *w && isSPACE(*w); w++) ;
4709 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
4710 warn("%s (...) interpreted as function",name);
4712 while (s < bufend && isSPACE(*s))
4716 while (s < bufend && isSPACE(*s))
4718 if (isIDFIRST(*s)) {
4722 while (s < bufend && isSPACE(*s))
4727 kw = keyword(w, s - w) || perl_get_cv(w, FALSE) != 0;
4731 croak("No comma allowed after %s", what);
4737 new_constant(char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)
4740 HV *table = GvHV(hintgv); /* ^H */
4743 bool oldcatch = CATCH_GET;
4749 yyerror("%^H is not defined");
4752 cvp = hv_fetch(table, key, strlen(key), FALSE);
4753 if (!cvp || !SvOK(*cvp)) {
4754 sprintf(buf,"$^H{%s} is not defined", key);
4758 sv_2mortal(sv); /* Parent created it permanently */
4761 pv = sv_2mortal(newSVpv(s, len));
4763 typesv = sv_2mortal(newSVpv(type, 0));
4767 Zero(&myop, 1, BINOP);
4768 myop.op_last = (OP *) &myop;
4769 myop.op_next = Nullop;
4770 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
4772 PUSHSTACKi(PERLSI_OVERLOAD);
4776 if (PERLDB_SUB && curstash != debstash)
4777 op->op_private |= OPpENTERSUB_DB;
4788 if (op = pp_entersub(ARGS))
4795 CATCH_SET(oldcatch);
4799 sprintf(buf,"Call to &{$^H{%s}} did not return a defined value", key);
4802 return SvREFCNT_inc(res);
4806 scan_word(register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
4808 register char *d = dest;
4809 register char *e = d + destlen - 3; /* two-character token, ending NUL */
4812 croak(ident_too_long);
4815 else if (*s == '\'' && allow_package && isIDFIRST(s[1])) {
4820 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
4833 scan_ident(register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
4840 if (lex_brackets == 0)
4845 e = d + destlen - 3; /* two-character token, ending NUL */
4847 while (isDIGIT(*s)) {
4849 croak(ident_too_long);
4856 croak(ident_too_long);
4859 else if (*s == '\'' && isIDFIRST(s[1])) {
4864 else if (*s == ':' && s[1] == ':') {
4875 if (lex_state != LEX_NORMAL)
4876 lex_state = LEX_INTERPENDMAYBE;
4879 if (*s == '$' && s[1] &&
4880 (isALNUM(s[1]) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
4882 if (isDIGIT(s[1]) && lex_state == LEX_INTERPNORMAL)
4883 deprecate("\"$$<digit>\" to mean \"${$}<digit>\"");
4896 if (*d == '^' && *s && (isUPPER(*s) || strchr("[\\]^_?", *s))) {
4901 if (isSPACE(s[-1])) {
4904 if (ch != ' ' && ch != '\t') {
4910 if (isIDFIRST(*d)) {
4912 while (isALNUM(*s) || *s == ':')
4915 while (s < send && (*s == ' ' || *s == '\t')) s++;
4916 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
4917 if (dowarn && keyword(dest, d - dest)) {
4918 char *brack = *s == '[' ? "[...]" : "{...}";
4919 warn("Ambiguous use of %c{%s%s} resolved to %c%s%s",
4920 funny, dest, brack, funny, dest, brack);
4922 lex_fakebrack = lex_brackets+1;
4924 lex_brackstack[lex_brackets++] = XOPERATOR;
4930 if (lex_state == LEX_INTERPNORMAL && !lex_brackets)
4931 lex_state = LEX_INTERPEND;
4934 if (dowarn && lex_state == LEX_NORMAL &&
4935 (keyword(dest, d - dest) || perl_get_cv(dest, FALSE)))
4936 warn("Ambiguous use of %c{%s} resolved to %c%s",
4937 funny, dest, funny, dest);
4940 s = bracket; /* let the parser handle it */
4944 else if (lex_state == LEX_INTERPNORMAL && !lex_brackets && !intuit_more(s))
4945 lex_state = LEX_INTERPEND;
4949 void pmflag(U16 *pmfl, int ch)
4954 *pmfl |= PMf_GLOBAL;
4956 *pmfl |= PMf_CONTINUE;
4960 *pmfl |= PMf_MULTILINE;
4962 *pmfl |= PMf_SINGLELINE;
4964 *pmfl |= PMf_EXTENDED;
4968 scan_pat(char *start)
4973 s = scan_str(start);
4976 SvREFCNT_dec(lex_stuff);
4978 croak("Search pattern not terminated");
4981 pm = (PMOP*)newPMOP(OP_MATCH, 0);
4982 if (multi_open == '?')
4983 pm->op_pmflags |= PMf_ONCE;
4984 while (*s && strchr("iogcmsx", *s))
4985 pmflag(&pm->op_pmflags,*s++);
4986 pm->op_pmpermflags = pm->op_pmflags;
4989 yylval.ival = OP_MATCH;
4994 scan_subst(char *start)
5001 yylval.ival = OP_NULL;
5003 s = scan_str(start);
5007 SvREFCNT_dec(lex_stuff);
5009 croak("Substitution pattern not terminated");
5012 if (s[-1] == multi_open)
5015 first_start = multi_start;
5019 SvREFCNT_dec(lex_stuff);
5022 SvREFCNT_dec(lex_repl);
5024 croak("Substitution replacement not terminated");
5026 multi_start = first_start; /* so whole substitution is taken together */
5028 pm = (PMOP*)newPMOP(OP_SUBST, 0);
5034 else if (strchr("iogcmsx", *s))
5035 pmflag(&pm->op_pmflags,*s++);
5042 pm->op_pmflags |= PMf_EVAL;
5043 repl = newSVpv("",0);
5045 sv_catpv(repl, es ? "eval " : "do ");
5046 sv_catpvn(repl, "{ ", 2);
5047 sv_catsv(repl, lex_repl);
5048 sv_catpvn(repl, " };", 2);
5049 SvCOMPILED_on(repl);
5050 SvREFCNT_dec(lex_repl);
5054 pm->op_pmpermflags = pm->op_pmflags;
5056 yylval.ival = OP_SUBST;
5061 scan_trans(char *start)
5070 yylval.ival = OP_NULL;
5072 s = scan_str(start);
5075 SvREFCNT_dec(lex_stuff);
5077 croak("Transliteration pattern not terminated");
5079 if (s[-1] == multi_open)
5085 SvREFCNT_dec(lex_stuff);
5088 SvREFCNT_dec(lex_repl);
5090 croak("Transliteration replacement not terminated");
5093 New(803,tbl,256,short);
5094 o = newPVOP(OP_TRANS, 0, (char*)tbl);
5096 complement = Delete = squash = 0;
5097 while (*s == 'c' || *s == 'd' || *s == 's') {
5099 complement = OPpTRANS_COMPLEMENT;
5101 Delete = OPpTRANS_DELETE;
5103 squash = OPpTRANS_SQUASH;
5106 o->op_private = Delete|squash|complement;
5109 yylval.ival = OP_TRANS;
5114 scan_heredoc(register char *s)
5118 I32 op_type = OP_SCALAR;
5125 int outer = (rsfp && !(lex_inwhat == OP_SCALAR));
5129 e = tokenbuf + sizeof tokenbuf - 1;
5132 for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5133 if (*peek && strchr("`'\"",*peek)) {
5136 s = delimcpy(d, e, s, bufend, term, &len);
5147 deprecate("bare << to mean <<\"\"");
5148 for (; isALNUM(*s); s++) {
5153 if (d >= tokenbuf + sizeof tokenbuf - 1)
5154 croak("Delimiter for here document is too long");
5159 if (outer || !(d=ninstr(s,bufend,d,d+1)))
5160 herewas = newSVpv(s,bufend-s);
5162 s--, herewas = newSVpv(s,d-s);
5163 s += SvCUR(herewas);
5165 tmpstr = NEWSV(87,79);
5166 sv_upgrade(tmpstr, SVt_PVIV);
5171 else if (term == '`') {
5172 op_type = OP_BACKTICK;
5173 SvIVX(tmpstr) = '\\';
5177 multi_start = curcop->cop_line;
5178 multi_open = multi_close = '<';
5182 while (s < bufend &&
5183 (*s != term || memNE(s,tokenbuf,len)) ) {
5188 curcop->cop_line = multi_start;
5189 missingterm(tokenbuf);
5191 sv_setpvn(tmpstr,d+1,s-d);
5193 curcop->cop_line++; /* the preceding stmt passes a newline */
5195 sv_catpvn(herewas,s,bufend-s);
5196 sv_setsv(linestr,herewas);
5197 oldoldbufptr = oldbufptr = bufptr = s = linestart = SvPVX(linestr);
5198 bufend = SvPVX(linestr) + SvCUR(linestr);
5201 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
5202 while (s >= bufend) { /* multiple line string? */
5204 !(oldoldbufptr = oldbufptr = s = linestart = filter_gets(linestr, rsfp, 0))) {
5205 curcop->cop_line = multi_start;
5206 missingterm(tokenbuf);
5209 if (PERLDB_LINE && curstash != debstash) {
5210 SV *sv = NEWSV(88,0);
5212 sv_upgrade(sv, SVt_PVMG);
5213 sv_setsv(sv,linestr);
5214 av_store(GvAV(curcop->cop_filegv),
5215 (I32)curcop->cop_line,sv);
5217 bufend = SvPVX(linestr) + SvCUR(linestr);
5218 if (*s == term && memEQ(s,tokenbuf,len)) {
5221 sv_catsv(linestr,herewas);
5222 bufend = SvPVX(linestr) + SvCUR(linestr);
5226 sv_catsv(tmpstr,linestr);
5229 multi_end = curcop->cop_line;
5231 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
5232 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
5233 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
5235 SvREFCNT_dec(herewas);
5237 yylval.ival = op_type;
5242 takes: current position in input buffer
5243 returns: new position in input buffer
5244 side-effects: yylval and lex_op are set.
5249 <FH> read from filehandle
5250 <pkg::FH> read from package qualified filehandle
5251 <pkg'FH> read from package qualified filehandle
5252 <$fh> read from filehandle in $fh
5258 scan_inputsymbol(char *start)
5260 register char *s = start; /* current position in buffer */
5265 d = tokenbuf; /* start of temp holding space */
5266 e = tokenbuf + sizeof tokenbuf; /* end of temp holding space */
5267 s = delimcpy(d, e, s + 1, bufend, '>', &len); /* extract until > */
5269 /* die if we didn't have space for the contents of the <>,
5273 if (len >= sizeof tokenbuf)
5274 croak("Excessively long <> operator");
5276 croak("Unterminated <> operator");
5281 Remember, only scalar variables are interpreted as filehandles by
5282 this code. Anything more complex (e.g., <$fh{$num}>) will be
5283 treated as a glob() call.
5284 This code makes use of the fact that except for the $ at the front,
5285 a scalar variable and a filehandle look the same.
5287 if (*d == '$' && d[1]) d++;
5289 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
5290 while (*d && (isALNUM(*d) || *d == '\'' || *d == ':'))
5293 /* If we've tried to read what we allow filehandles to look like, and
5294 there's still text left, then it must be a glob() and not a getline.
5295 Use scan_str to pull out the stuff between the <> and treat it
5296 as nothing more than a string.
5299 if (d - tokenbuf != len) {
5300 yylval.ival = OP_GLOB;
5302 s = scan_str(start);
5304 croak("Glob not terminated");
5308 /* we're in a filehandle read situation */
5311 /* turn <> into <ARGV> */
5313 (void)strcpy(d,"ARGV");
5315 /* if <$fh>, create the ops to turn the variable into a
5321 /* try to find it in the pad for this block, otherwise find
5322 add symbol table ops
5324 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
5325 OP *o = newOP(OP_PADSV, 0);
5327 lex_op = (OP*)newUNOP(OP_READLINE, 0, newUNOP(OP_RV2GV, 0, o));
5330 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
5331 lex_op = (OP*)newUNOP(OP_READLINE, 0,
5332 newUNOP(OP_RV2GV, 0,
5333 newUNOP(OP_RV2SV, 0,
5334 newGVOP(OP_GV, 0, gv))));
5336 /* we created the ops in lex_op, so make yylval.ival a null op */
5337 yylval.ival = OP_NULL;
5340 /* If it's none of the above, it must be a literal filehandle
5341 (<Foo::BAR> or <FOO>) so build a simple readline OP */
5343 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
5344 lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
5345 yylval.ival = OP_NULL;
5354 takes: start position in buffer
5355 returns: position to continue reading from buffer
5356 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
5357 updates the read buffer.
5359 This subroutine pulls a string out of the input. It is called for:
5360 q single quotes q(literal text)
5361 ' single quotes 'literal text'
5362 qq double quotes qq(interpolate $here please)
5363 " double quotes "interpolate $here please"
5364 qx backticks qx(/bin/ls -l)
5365 ` backticks `/bin/ls -l`
5366 qw quote words @EXPORT_OK = qw( func() $spam )
5367 m// regexp match m/this/
5368 s/// regexp substitute s/this/that/
5369 tr/// string transliterate tr/this/that/
5370 y/// string transliterate y/this/that/
5371 ($*@) sub prototypes sub foo ($)
5372 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
5374 In most of these cases (all but <>, patterns and transliterate)
5375 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
5376 calls scan_str(). s/// makes yylex() call scan_subst() which calls
5377 scan_str(). tr/// and y/// make yylex() call scan_trans() which
5380 It skips whitespace before the string starts, and treats the first
5381 character as the delimiter. If the delimiter is one of ([{< then
5382 the corresponding "close" character )]}> is used as the closing
5383 delimiter. It allows quoting of delimiters, and if the string has
5384 balanced delimiters ([{<>}]) it allows nesting.
5386 The lexer always reads these strings into lex_stuff, except in the
5387 case of the operators which take *two* arguments (s/// and tr///)
5388 when it checks to see if lex_stuff is full (presumably with the 1st
5389 arg to s or tr) and if so puts the string into lex_repl.
5394 scan_str(char *start)
5397 SV *sv; /* scalar value: string */
5398 char *tmps; /* temp string, used for delimiter matching */
5399 register char *s = start; /* current position in the buffer */
5400 register char term; /* terminating character */
5401 register char *to; /* current position in the sv's data */
5402 I32 brackets = 1; /* bracket nesting level */
5404 /* skip space before the delimiter */
5408 /* mark where we are, in case we need to report errors */
5411 /* after skipping whitespace, the next character is the terminator */
5413 /* mark where we are */
5414 multi_start = curcop->cop_line;
5417 /* find corresponding closing delimiter */
5418 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5422 /* create a new SV to hold the contents. 87 is leak category, I'm
5423 assuming. 79 is the SV's initial length. What a random number. */
5425 sv_upgrade(sv, SVt_PVIV);
5427 (void)SvPOK_only(sv); /* validate pointer */
5429 /* move past delimiter and try to read a complete string */
5432 /* extend sv if need be */
5433 SvGROW(sv, SvCUR(sv) + (bufend - s) + 1);
5434 /* set 'to' to the next character in the sv's string */
5435 to = SvPVX(sv)+SvCUR(sv);
5437 /* if open delimiter is the close delimiter read unbridle */
5438 if (multi_open == multi_close) {
5439 for (; s < bufend; s++,to++) {
5440 /* embedded newlines increment the current line number */
5441 if (*s == '\n' && !rsfp)
5443 /* handle quoted delimiters */
5444 if (*s == '\\' && s+1 < bufend && term != '\\') {
5447 /* any other quotes are simply copied straight through */
5451 /* terminate when run out of buffer (the for() condition), or
5452 have found the terminator */
5453 else if (*s == term)
5459 /* if the terminator isn't the same as the start character (e.g.,
5460 matched brackets), we have to allow more in the quoting, and
5461 be prepared for nested brackets.
5464 /* read until we run out of string, or we find the terminator */
5465 for (; s < bufend; s++,to++) {
5466 /* embedded newlines increment the line count */
5467 if (*s == '\n' && !rsfp)
5469 /* backslashes can escape the open or closing characters */
5470 if (*s == '\\' && s+1 < bufend) {
5471 if ((s[1] == multi_open) || (s[1] == multi_close))
5476 /* allow nested opens and closes */
5477 else if (*s == multi_close && --brackets <= 0)
5479 else if (*s == multi_open)
5484 /* terminate the copied string and update the sv's end-of-string */
5486 SvCUR_set(sv, to - SvPVX(sv));
5489 * this next chunk reads more into the buffer if we're not done yet
5492 if (s < bufend) break; /* handle case where we are done yet :-) */
5494 /* if we're out of file, or a read fails, bail and reset the current
5495 line marker so we can report where the unterminated string began
5498 !(oldoldbufptr = oldbufptr = s = linestart = filter_gets(linestr, rsfp, 0))) {
5500 curcop->cop_line = multi_start;
5503 /* we read a line, so increment our line counter */
5506 /* update debugger info */
5507 if (PERLDB_LINE && curstash != debstash) {
5508 SV *sv = NEWSV(88,0);
5510 sv_upgrade(sv, SVt_PVMG);
5511 sv_setsv(sv,linestr);
5512 av_store(GvAV(curcop->cop_filegv),
5513 (I32)curcop->cop_line, sv);
5516 /* having changed the buffer, we must update bufend */
5517 bufend = SvPVX(linestr) + SvCUR(linestr);
5520 /* at this point, we have successfully read the delimited string */
5522 multi_end = curcop->cop_line;
5525 /* if we allocated too much space, give some back */
5526 if (SvCUR(sv) + 5 < SvLEN(sv)) {
5527 SvLEN_set(sv, SvCUR(sv) + 1);
5528 Renew(SvPVX(sv), SvLEN(sv), char);
5531 /* decide whether this is the first or second quoted string we've read
5544 takes: pointer to position in buffer
5545 returns: pointer to new position in buffer
5546 side-effects: builds ops for the constant in yylval.op
5548 Read a number in any of the formats that Perl accepts:
5550 0(x[0-7A-F]+)|([0-7]+)
5551 [\d_]+(\.[\d_]*)?[Ee](\d+)
5553 Underbars (_) are allowed in decimal numbers. If -w is on,
5554 underbars before a decimal point must be at three digit intervals.
5556 Like most scan_ routines, it uses the tokenbuf buffer to hold the
5559 If it reads a number without a decimal point or an exponent, it will
5560 try converting the number to an integer and see if it can do so
5561 without loss of precision.
5565 scan_num(char *start)
5567 register char *s = start; /* current position in buffer */
5568 register char *d; /* destination in temp buffer */
5569 register char *e; /* end of temp buffer */
5570 I32 tryiv; /* used to see if it can be an int */
5571 double value; /* number read, as a double */
5572 SV *sv; /* place to put the converted number */
5573 I32 floatit; /* boolean: int or float? */
5574 char *lastub = 0; /* position of last underbar */
5575 static char number_too_long[] = "Number too long";
5577 /* We use the first character to decide what type of number this is */
5581 croak("panic: scan_num");
5583 /* if it starts with a 0, it could be an octal number, a decimal in
5584 0.13 disguise, or a hexadecimal number.
5589 u holds the "number so far"
5590 shift the power of 2 of the base (hex == 4, octal == 3)
5591 overflowed was the number more than we can hold?
5593 Shift is used when we add a digit. It also serves as an "are
5594 we in octal or hex?" indicator to disallow hex characters when
5599 bool overflowed = FALSE;
5606 /* check for a decimal in disguise */
5607 else if (s[1] == '.')
5609 /* so it must be octal */
5614 /* read the rest of the octal number */
5616 UV n, b; /* n is used in the overflow test, b is the digit we're adding on */
5620 /* if we don't mention it, we're done */
5629 /* 8 and 9 are not octal */
5632 yyerror("Illegal octal digit");
5636 case '0': case '1': case '2': case '3': case '4':
5637 case '5': case '6': case '7':
5638 b = *s++ & 15; /* ASCII digit -> value of digit */
5642 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
5643 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
5644 /* make sure they said 0x */
5649 /* Prepare to put the digit we have onto the end
5650 of the number so far. We check for overflows.
5654 n = u << shift; /* make room for the digit */
5655 if (!overflowed && (n >> shift) != u
5656 && !(hints & HINT_NEW_BINARY)) {
5657 warn("Integer overflow in %s number",
5658 (shift == 4) ? "hex" : "octal");
5661 u = n | b; /* add the digit to the end */
5666 /* if we get here, we had success: make a scalar value from
5672 if ( hints & HINT_NEW_BINARY)
5673 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
5678 handle decimal numbers.
5679 we're also sent here when we read a 0 as the first digit
5681 case '1': case '2': case '3': case '4': case '5':
5682 case '6': case '7': case '8': case '9': case '.':
5685 e = tokenbuf + sizeof tokenbuf - 6; /* room for various punctuation */
5688 /* read next group of digits and _ and copy into d */
5689 while (isDIGIT(*s) || *s == '_') {
5690 /* skip underscores, checking for misplaced ones
5694 if (dowarn && lastub && s - lastub != 3)
5695 warn("Misplaced _ in number");
5699 /* check for end of fixed-length buffer */
5701 croak(number_too_long);
5702 /* if we're ok, copy the character */
5707 /* final misplaced underbar check */
5708 if (dowarn && lastub && s - lastub != 3)
5709 warn("Misplaced _ in number");
5711 /* read a decimal portion if there is one. avoid
5712 3..5 being interpreted as the number 3. followed
5715 if (*s == '.' && s[1] != '.') {
5719 /* copy, ignoring underbars, until we run out of
5720 digits. Note: no misplaced underbar checks!
5722 for (; isDIGIT(*s) || *s == '_'; s++) {
5723 /* fixed length buffer check */
5725 croak(number_too_long);
5731 /* read exponent part, if present */
5732 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
5736 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
5737 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
5739 /* allow positive or negative exponent */
5740 if (*s == '+' || *s == '-')
5743 /* read digits of exponent (no underbars :-) */
5744 while (isDIGIT(*s)) {
5746 croak(number_too_long);
5751 /* terminate the string */
5754 /* make an sv from the string */
5756 /* reset numeric locale in case we were earlier left in Swaziland */
5757 SET_NUMERIC_STANDARD();
5758 value = atof(tokenbuf);
5761 See if we can make do with an integer value without loss of
5762 precision. We use I_V to cast to an int, because some
5763 compilers have issues. Then we try casting it back and see
5764 if it was the same. We only do this if we know we
5765 specifically read an integer.
5767 Note: if floatit is true, then we don't need to do the
5771 if (!floatit && (double)tryiv == value)
5772 sv_setiv(sv, tryiv);
5774 sv_setnv(sv, value);
5775 if ( floatit ? (hints & HINT_NEW_FLOAT) : (hints & HINT_NEW_INTEGER) )
5776 sv = new_constant(tokenbuf, d - tokenbuf,
5777 (floatit ? "float" : "integer"), sv, Nullsv, NULL);
5781 /* make the op for the constant and return */
5783 yylval.opval = newSVOP(OP_CONST, 0, sv);
5789 scan_formline(register char *s)
5794 SV *stuff = newSVpv("",0);
5795 bool needargs = FALSE;
5798 if (*s == '.' || *s == '}') {
5800 for (t = s+1; *t == ' ' || *t == '\t'; t++) ;
5804 if (in_eval && !rsfp) {
5805 eol = strchr(s,'\n');
5810 eol = bufend = SvPVX(linestr) + SvCUR(linestr);
5812 for (t = s; t < eol; t++) {
5813 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
5815 goto enough; /* ~~ must be first line in formline */
5817 if (*t == '@' || *t == '^')
5820 sv_catpvn(stuff, s, eol-s);
5824 s = filter_gets(linestr, rsfp, 0);
5825 oldoldbufptr = oldbufptr = bufptr = linestart = SvPVX(linestr);
5826 bufend = bufptr + SvCUR(linestr);
5829 yyerror("Format not terminated");
5839 lex_state = LEX_NORMAL;
5840 nextval[nexttoke].ival = 0;
5844 lex_state = LEX_FORMLINE;
5845 nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
5847 nextval[nexttoke].ival = OP_FORMLINE;
5851 SvREFCNT_dec(stuff);
5863 cshlen = strlen(cshname);
5868 start_subparse(I32 is_format, U32 flags)
5871 I32 oldsavestack_ix = savestack_ix;
5872 CV* outsidecv = compcv;
5876 assert(SvTYPE(compcv) == SVt_PVCV);
5883 SAVESPTR(comppad_name);
5885 SAVEI32(comppad_name_fill);
5886 SAVEI32(min_intro_pending);
5887 SAVEI32(max_intro_pending);
5888 SAVEI32(pad_reset_pending);
5890 compcv = (CV*)NEWSV(1104,0);
5891 sv_upgrade((SV *)compcv, is_format ? SVt_PVFM : SVt_PVCV);
5892 CvFLAGS(compcv) |= flags;
5895 av_push(comppad, Nullsv);
5896 curpad = AvARRAY(comppad);
5897 comppad_name = newAV();
5898 comppad_name_fill = 0;
5899 min_intro_pending = 0;
5901 subline = curcop->cop_line;
5903 av_store(comppad_name, 0, newSVpv("@_", 2));
5904 curpad[0] = (SV*)newAV();
5905 SvPADMY_on(curpad[0]); /* XXX Needed? */
5906 CvOWNER(compcv) = 0;
5907 New(666, CvMUTEXP(compcv), 1, perl_mutex);
5908 MUTEX_INIT(CvMUTEXP(compcv));
5909 #endif /* USE_THREADS */
5911 comppadlist = newAV();
5912 AvREAL_off(comppadlist);
5913 av_store(comppadlist, 0, (SV*)comppad_name);
5914 av_store(comppadlist, 1, (SV*)comppad);
5916 CvPADLIST(compcv) = comppadlist;
5917 CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc(outsidecv);
5919 CvOWNER(compcv) = 0;
5920 New(666, CvMUTEXP(compcv), 1, perl_mutex);
5921 MUTEX_INIT(CvMUTEXP(compcv));
5922 #endif /* USE_THREADS */
5924 return oldsavestack_ix;
5943 char *context = NULL;
5947 if (!yychar || (yychar == ';' && !rsfp))
5949 else if (bufptr > oldoldbufptr && bufptr - oldoldbufptr < 200 &&
5950 oldoldbufptr != oldbufptr && oldbufptr != bufptr) {
5951 while (isSPACE(*oldoldbufptr))
5953 context = oldoldbufptr;
5954 contlen = bufptr - oldoldbufptr;
5956 else if (bufptr > oldbufptr && bufptr - oldbufptr < 200 &&
5957 oldbufptr != bufptr) {
5958 while (isSPACE(*oldbufptr))
5960 context = oldbufptr;
5961 contlen = bufptr - oldbufptr;
5963 else if (yychar > 255)
5964 where = "next token ???";
5965 else if ((yychar & 127) == 127) {
5966 if (lex_state == LEX_NORMAL ||
5967 (lex_state == LEX_KNOWNEXT && lex_defer == LEX_NORMAL))
5968 where = "at end of line";
5970 where = "within pattern";
5972 where = "within string";
5975 SV *where_sv = sv_2mortal(newSVpv("next char ", 0));
5977 sv_catpvf(where_sv, "^%c", toCTRL(yychar));
5978 else if (isPRINT_LC(yychar))
5979 sv_catpvf(where_sv, "%c", yychar);
5981 sv_catpvf(where_sv, "\\%03o", yychar & 255);
5982 where = SvPVX(where_sv);
5984 msg = sv_2mortal(newSVpv(s, 0));
5985 sv_catpvf(msg, " at %_ line %ld, ",
5986 GvSV(curcop->cop_filegv), (long)curcop->cop_line);
5988 sv_catpvf(msg, "near \"%.*s\"\n", contlen, context);
5990 sv_catpvf(msg, "%s\n", where);
5991 if (multi_start < multi_end && (U32)(curcop->cop_line - multi_end) <= 1) {
5993 " (Might be a runaway multi-line %c%c string starting on line %ld)\n",
5994 (int)multi_open,(int)multi_close,(long)multi_start);
6000 sv_catsv(ERRSV, msg);
6002 PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
6003 if (++error_count >= 10)
6004 croak("%_ has too many errors.\n", GvSV(curcop->cop_filegv));
6006 in_my_stash = Nullhv;