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 | 8) : 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 | 8) : 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;
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 if (expect != XOPERATOR && (*s != ':' || s[1] != ':') &&
2825 (((gv = gv_fetchpv(tokenbuf, FALSE, SVt_PVCV)) &&
2826 GvCVu(gv) && GvIMPORTED_CV(gv)) ||
2827 ((gvp = (GV**)hv_fetch(globalstash,tokenbuf,len,FALSE)) &&
2828 (gv = *gvp) != (GV*)&sv_undef &&
2829 GvCVu(gv) && GvIMPORTED_CV(gv))))
2831 tmp = 0; /* overridden by importation */
2834 && -tmp==KEY_lock /* XXX generalizable kludge */
2835 && !hv_fetch(GvHVn(incgv), "Thread.pm", 9, FALSE))
2837 tmp = 0; /* any sub overrides "weak" keyword */
2840 tmp = -tmp; gv = Nullgv; gvp = 0;
2847 default: /* not a keyword */
2850 char lastchar = (bufptr == oldoldbufptr ? 0 : bufptr[-1]);
2852 /* Get the rest if it looks like a package qualifier */
2854 if (*s == '\'' || *s == ':' && s[1] == ':') {
2856 s = scan_word(s, tokenbuf + len, sizeof tokenbuf - len,
2859 croak("Bad name after %s%s", tokenbuf,
2860 *s == '\'' ? "'" : "::");
2864 if (expect == XOPERATOR) {
2865 if (bufptr == linestart) {
2871 no_op("Bareword",s);
2874 /* Look for a subroutine with this name in current package,
2875 unless name is "Foo::", in which case Foo is a bearword
2876 (and a package name). */
2879 tokenbuf[len - 2] == ':' && tokenbuf[len - 1] == ':')
2881 if (dowarn && ! gv_fetchpv(tokenbuf, FALSE, SVt_PVHV))
2882 warn("Bareword \"%s\" refers to nonexistent package",
2885 tokenbuf[len] = '\0';
2892 gv = gv_fetchpv(tokenbuf, FALSE, SVt_PVCV);
2895 /* if we saw a global override before, get the right name */
2898 sv = newSVpv("CORE::GLOBAL::",14);
2899 sv_catpv(sv,tokenbuf);
2902 sv = newSVpv(tokenbuf,0);
2904 /* Presume this is going to be a bareword of some sort. */
2907 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2908 yylval.opval->op_private = OPpCONST_BARE;
2910 /* And if "Foo::", then that's what it certainly is. */
2915 /* See if it's the indirect object for a list operator. */
2918 oldoldbufptr < bufptr &&
2919 (oldoldbufptr == last_lop || oldoldbufptr == last_uni) &&
2920 /* NO SKIPSPACE BEFORE HERE! */
2922 || ((opargs[last_lop_op] >> OASHIFT)& 7) == OA_FILEREF
2923 || (last_lop_op == OP_ENTERSUB
2925 && last_proto[last_proto[0] == ';' ? 1 : 0] == '*')) )
2927 bool immediate_paren = *s == '(';
2929 /* (Now we can afford to cross potential line boundary.) */
2932 /* Two barewords in a row may indicate method call. */
2934 if ((isALPHA(*s) || *s == '$') && (tmp=intuit_method(s,gv)))
2937 /* If not a declared subroutine, it's an indirect object. */
2938 /* (But it's an indir obj regardless for sort.) */
2940 if ((last_lop_op == OP_SORT ||
2941 (!immediate_paren && (!gv || !GvCVu(gv))) ) &&
2942 (last_lop_op != OP_MAPSTART && last_lop_op != OP_GREPSTART)){
2943 expect = (last_lop == oldoldbufptr) ? XTERM : XOPERATOR;
2948 /* If followed by a paren, it's certainly a subroutine. */
2954 if (gv && GvCVu(gv)) {
2955 for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
2956 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
2961 nextval[nexttoke].opval = yylval.opval;
2968 /* If followed by var or block, call it a method (unless sub) */
2970 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
2971 last_lop = oldbufptr;
2972 last_lop_op = OP_METHOD;
2976 /* If followed by a bareword, see if it looks like indir obj. */
2978 if ((isALPHA(*s) || *s == '$') && (tmp = intuit_method(s,gv)))
2981 /* Not a method, so call it a subroutine (if defined) */
2983 if (gv && GvCVu(gv)) {
2985 if (lastchar == '-')
2986 warn("Ambiguous use of -%s resolved as -&%s()",
2987 tokenbuf, tokenbuf);
2988 last_lop = oldbufptr;
2989 last_lop_op = OP_ENTERSUB;
2990 /* Check for a constant sub */
2992 if ((sv = cv_const_sv(cv))) {
2994 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
2995 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
2996 yylval.opval->op_private = 0;
3000 /* Resolve to GV now. */
3001 op_free(yylval.opval);
3002 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3003 /* Is there a prototype? */
3006 last_proto = SvPV((SV*)cv, len);
3009 if (strEQ(last_proto, "$"))
3011 if (*last_proto == '&' && *s == '{') {
3012 sv_setpv(subname,"__ANON__");
3017 nextval[nexttoke].opval = yylval.opval;
3023 if (hints & HINT_STRICT_SUBS &&
3026 last_lop_op != OP_TRUNCATE && /* S/F prototype in opcode.pl */
3027 last_lop_op != OP_ACCEPT &&
3028 last_lop_op != OP_PIPE_OP &&
3029 last_lop_op != OP_SOCKPAIR)
3032 "Bareword \"%s\" not allowed while \"strict subs\" in use",
3037 /* Call it a bare word */
3041 if (lastchar != '-') {
3042 for (d = tokenbuf; *d && isLOWER(*d); d++) ;
3044 warn(warn_reserved, tokenbuf);
3049 if (lastchar && strchr("*%&", lastchar)) {
3050 warn("Operator or semicolon missing before %c%s",
3051 lastchar, tokenbuf);
3052 warn("Ambiguous use of %c resolved as operator %c",
3053 lastchar, lastchar);
3059 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3060 newSVsv(GvSV(curcop->cop_filegv)));
3064 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3065 newSVpvf("%ld", (long)curcop->cop_line));
3068 case KEY___PACKAGE__:
3069 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3071 ? newSVsv(curstname)
3080 if (rsfp && (!in_eval || tokenbuf[2] == 'D')) {
3081 char *pname = "main";
3082 if (tokenbuf[2] == 'D')
3083 pname = HvNAME(curstash ? curstash : defstash);
3084 gv = gv_fetchpv(form("%s::DATA", pname), TRUE, SVt_PVIO);
3087 GvIOp(gv) = newIO();
3088 IoIFP(GvIOp(gv)) = rsfp;
3089 #if defined(HAS_FCNTL) && defined(F_SETFD)
3091 int fd = PerlIO_fileno(rsfp);
3092 fcntl(fd,F_SETFD,fd >= 3);
3095 /* Mark this internal pseudo-handle as clean */
3096 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3098 IoTYPE(GvIOp(gv)) = '|';
3099 else if ((PerlIO*)rsfp == PerlIO_stdin())
3100 IoTYPE(GvIOp(gv)) = '-';
3102 IoTYPE(GvIOp(gv)) = '<';
3113 if (expect == XSTATE) {
3120 if (*s == ':' && s[1] == ':') {
3123 s = scan_word(s, tokenbuf, sizeof tokenbuf, FALSE, &len);
3124 tmp = keyword(tokenbuf, len);
3138 LOP(OP_ACCEPT,XTERM);
3144 LOP(OP_ATAN2,XTERM);
3153 LOP(OP_BLESS,XTERM);
3162 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
3182 LOP(OP_CRYPT,XTERM);
3186 for (d = s; d < bufend && (isSPACE(*d) || *d == '('); d++) ;
3187 if (*d != '0' && isDIGIT(*d))
3188 yywarn("chmod: mode argument is missing initial 0");
3190 LOP(OP_CHMOD,XTERM);
3193 LOP(OP_CHOWN,XTERM);
3196 LOP(OP_CONNECT,XTERM);
3212 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3216 hints |= HINT_BLOCK_SCOPE;
3226 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3227 LOP(OP_DBMOPEN,XTERM);
3233 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3240 yylval.ival = curcop->cop_line;
3254 expect = (*s == '{') ? XTERMBLOCK : XTERM;
3255 UNIBRACK(OP_ENTEREVAL);
3270 case KEY_endhostent:
3276 case KEY_endservent:
3279 case KEY_endprotoent:
3290 yylval.ival = curcop->cop_line;
3292 if (expect == XSTATE && isIDFIRST(*s)) {
3294 if ((bufend - p) >= 3 &&
3295 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3299 croak("Missing $ on loop variable");
3304 LOP(OP_FORMLINE,XTERM);
3310 LOP(OP_FCNTL,XTERM);
3316 LOP(OP_FLOCK,XTERM);
3325 LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
3328 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3343 case KEY_getpriority:
3344 LOP(OP_GETPRIORITY,XTERM);
3346 case KEY_getprotobyname:
3349 case KEY_getprotobynumber:
3350 LOP(OP_GPBYNUMBER,XTERM);
3352 case KEY_getprotoent:
3364 case KEY_getpeername:
3365 UNI(OP_GETPEERNAME);
3367 case KEY_gethostbyname:
3370 case KEY_gethostbyaddr:
3371 LOP(OP_GHBYADDR,XTERM);
3373 case KEY_gethostent:
3376 case KEY_getnetbyname:
3379 case KEY_getnetbyaddr:
3380 LOP(OP_GNBYADDR,XTERM);
3385 case KEY_getservbyname:
3386 LOP(OP_GSBYNAME,XTERM);
3388 case KEY_getservbyport:
3389 LOP(OP_GSBYPORT,XTERM);
3391 case KEY_getservent:
3394 case KEY_getsockname:
3395 UNI(OP_GETSOCKNAME);
3397 case KEY_getsockopt:
3398 LOP(OP_GSOCKOPT,XTERM);
3420 yylval.ival = curcop->cop_line;
3424 LOP(OP_INDEX,XTERM);
3430 LOP(OP_IOCTL,XTERM);
3442 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3473 LOP(OP_LISTEN,XTERM);
3483 TERM(sublex_start());
3486 LOP(OP_MAPSTART,XREF);
3489 LOP(OP_MKDIR,XTERM);
3492 LOP(OP_MSGCTL,XTERM);
3495 LOP(OP_MSGGET,XTERM);
3498 LOP(OP_MSGRCV,XTERM);
3501 LOP(OP_MSGSND,XTERM);
3506 if (isIDFIRST(*s)) {
3507 s = scan_word(s, tokenbuf, sizeof tokenbuf, TRUE, &len);
3508 in_my_stash = gv_stashpv(tokenbuf, FALSE);
3512 sprintf(tmpbuf, "No such class %.1000s", tokenbuf);
3519 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3526 if (expect != XSTATE)
3527 yyerror("\"no\" not allowed in expression");
3528 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3529 s = force_version(s);
3538 if (isIDFIRST(*s)) {
3540 for (d = s; isALNUM(*d); d++) ;
3542 if (strchr("|&*+-=!?:.", *t))
3543 warn("Precedence problem: open %.*s should be open(%.*s)",
3549 yylval.ival = OP_OR;
3559 LOP(OP_OPEN_DIR,XTERM);
3562 checkcomma(s,tokenbuf,"filehandle");
3566 checkcomma(s,tokenbuf,"filehandle");
3585 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3589 LOP(OP_PIPE_OP,XTERM);
3594 missingterm((char*)0);
3595 yylval.ival = OP_CONST;
3596 TERM(sublex_start());
3604 missingterm((char*)0);
3605 if (dowarn && SvLEN(lex_stuff)) {
3606 d = SvPV_force(lex_stuff, len);
3607 for (; len; --len, ++d) {
3609 warn("Possible attempt to separate words with commas");
3613 warn("Possible attempt to put comments in qw() list");
3619 nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, tokeq(lex_stuff));
3623 nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(" ",1));
3626 yylval.ival = OP_SPLIT;
3630 last_lop = oldbufptr;
3631 last_lop_op = OP_SPLIT;
3637 missingterm((char*)0);
3638 yylval.ival = OP_STRINGIFY;
3639 if (SvIVX(lex_stuff) == '\'')
3640 SvIVX(lex_stuff) = 0; /* qq'$foo' should intepolate */
3641 TERM(sublex_start());
3646 missingterm((char*)0);
3647 yylval.ival = OP_BACKTICK;
3649 TERM(sublex_start());
3656 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3657 if (isIDFIRST(*tokenbuf))
3658 gv_stashpvn(tokenbuf, strlen(tokenbuf), TRUE);
3660 yyerror("<> should be quotes");
3667 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3671 LOP(OP_RENAME,XTERM);
3680 LOP(OP_RINDEX,XTERM);
3703 LOP(OP_REVERSE,XTERM);
3714 TERM(sublex_start());
3716 TOKEN(1); /* force error */
3725 LOP(OP_SELECT,XTERM);
3731 LOP(OP_SEMCTL,XTERM);
3734 LOP(OP_SEMGET,XTERM);
3737 LOP(OP_SEMOP,XTERM);
3743 LOP(OP_SETPGRP,XTERM);
3745 case KEY_setpriority:
3746 LOP(OP_SETPRIORITY,XTERM);
3748 case KEY_sethostent:
3754 case KEY_setservent:
3757 case KEY_setprotoent:
3767 LOP(OP_SEEKDIR,XTERM);
3769 case KEY_setsockopt:
3770 LOP(OP_SSOCKOPT,XTERM);
3776 LOP(OP_SHMCTL,XTERM);
3779 LOP(OP_SHMGET,XTERM);
3782 LOP(OP_SHMREAD,XTERM);
3785 LOP(OP_SHMWRITE,XTERM);
3788 LOP(OP_SHUTDOWN,XTERM);
3797 LOP(OP_SOCKET,XTERM);
3799 case KEY_socketpair:
3800 LOP(OP_SOCKPAIR,XTERM);
3803 checkcomma(s,tokenbuf,"subroutine name");
3805 if (*s == ';' || *s == ')') /* probably a close */
3806 croak("sort is now a reserved word");
3808 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3812 LOP(OP_SPLIT,XTERM);
3815 LOP(OP_SPRINTF,XTERM);
3818 LOP(OP_SPLICE,XTERM);
3834 LOP(OP_SUBSTR,XTERM);
3841 if (isIDFIRST(*s) || *s == '\'' || *s == ':') {
3842 char tmpbuf[sizeof tokenbuf];
3844 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3845 if (strchr(tmpbuf, ':'))
3846 sv_setpv(subname, tmpbuf);
3848 sv_setsv(subname,curstname);
3849 sv_catpvn(subname,"::",2);
3850 sv_catpvn(subname,tmpbuf,len);
3852 s = force_word(s,WORD,FALSE,TRUE,TRUE);
3856 expect = XTERMBLOCK;
3857 sv_setpv(subname,"?");
3860 if (tmp == KEY_format) {
3863 lex_formbrack = lex_brackets + 1;
3867 /* Look for a prototype */
3874 SvREFCNT_dec(lex_stuff);
3876 croak("Prototype not terminated");
3879 d = SvPVX(lex_stuff);
3881 for (p = d; *p; ++p) {
3886 SvCUR(lex_stuff) = tmp;
3889 nextval[1] = nextval[0];
3890 nexttype[1] = nexttype[0];
3891 nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, lex_stuff);
3892 nexttype[0] = THING;
3893 if (nexttoke == 1) {
3894 lex_defer = lex_state;
3895 lex_expect = expect;
3896 lex_state = LEX_KNOWNEXT;
3901 if (*SvPV(subname,na) == '?') {
3902 sv_setpv(subname,"__ANON__");
3909 LOP(OP_SYSTEM,XREF);
3912 LOP(OP_SYMLINK,XTERM);
3915 LOP(OP_SYSCALL,XTERM);
3918 LOP(OP_SYSOPEN,XTERM);
3921 LOP(OP_SYSSEEK,XTERM);
3924 LOP(OP_SYSREAD,XTERM);
3927 LOP(OP_SYSWRITE,XTERM);
3931 TERM(sublex_start());
3952 LOP(OP_TRUNCATE,XTERM);
3964 yylval.ival = curcop->cop_line;
3968 yylval.ival = curcop->cop_line;
3972 LOP(OP_UNLINK,XTERM);
3978 LOP(OP_UNPACK,XTERM);
3981 LOP(OP_UTIME,XTERM);
3985 for (d = s; d < bufend && (isSPACE(*d) || *d == '('); d++) ;
3986 if (*d != '0' && isDIGIT(*d))
3987 yywarn("umask: argument is missing initial 0");
3992 LOP(OP_UNSHIFT,XTERM);
3995 if (expect != XSTATE)
3996 yyerror("\"use\" not allowed in expression");
3999 s = force_version(s);
4000 if(*s == ';' || (s = skipspace(s), *s == ';')) {
4001 nextval[nexttoke].opval = Nullop;
4006 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4007 s = force_version(s);
4020 yylval.ival = curcop->cop_line;
4024 hints |= HINT_BLOCK_SCOPE;
4031 LOP(OP_WAITPID,XTERM);
4037 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
4041 if (expect == XOPERATOR)
4047 yylval.ival = OP_XOR;
4052 TERM(sublex_start());
4058 keyword(register char *d, I32 len)
4063 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
4064 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
4065 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
4066 if (strEQ(d,"__DATA__")) return KEY___DATA__;
4067 if (strEQ(d,"__END__")) return KEY___END__;
4071 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
4076 if (strEQ(d,"and")) return -KEY_and;
4077 if (strEQ(d,"abs")) return -KEY_abs;
4080 if (strEQ(d,"alarm")) return -KEY_alarm;
4081 if (strEQ(d,"atan2")) return -KEY_atan2;
4084 if (strEQ(d,"accept")) return -KEY_accept;
4089 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
4092 if (strEQ(d,"bless")) return -KEY_bless;
4093 if (strEQ(d,"bind")) return -KEY_bind;
4094 if (strEQ(d,"binmode")) return -KEY_binmode;
4097 if (strEQ(d,"CORE")) return -KEY_CORE;
4102 if (strEQ(d,"cmp")) return -KEY_cmp;
4103 if (strEQ(d,"chr")) return -KEY_chr;
4104 if (strEQ(d,"cos")) return -KEY_cos;
4107 if (strEQ(d,"chop")) return KEY_chop;
4110 if (strEQ(d,"close")) return -KEY_close;
4111 if (strEQ(d,"chdir")) return -KEY_chdir;
4112 if (strEQ(d,"chomp")) return KEY_chomp;
4113 if (strEQ(d,"chmod")) return -KEY_chmod;
4114 if (strEQ(d,"chown")) return -KEY_chown;
4115 if (strEQ(d,"crypt")) return -KEY_crypt;
4118 if (strEQ(d,"chroot")) return -KEY_chroot;
4119 if (strEQ(d,"caller")) return -KEY_caller;
4122 if (strEQ(d,"connect")) return -KEY_connect;
4125 if (strEQ(d,"closedir")) return -KEY_closedir;
4126 if (strEQ(d,"continue")) return -KEY_continue;
4131 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
4136 if (strEQ(d,"do")) return KEY_do;
4139 if (strEQ(d,"die")) return -KEY_die;
4142 if (strEQ(d,"dump")) return -KEY_dump;
4145 if (strEQ(d,"delete")) return KEY_delete;
4148 if (strEQ(d,"defined")) return KEY_defined;
4149 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
4152 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
4157 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
4158 if (strEQ(d,"END")) return KEY_END;
4163 if (strEQ(d,"eq")) return -KEY_eq;
4166 if (strEQ(d,"eof")) return -KEY_eof;
4167 if (strEQ(d,"exp")) return -KEY_exp;
4170 if (strEQ(d,"else")) return KEY_else;
4171 if (strEQ(d,"exit")) return -KEY_exit;
4172 if (strEQ(d,"eval")) return KEY_eval;
4173 if (strEQ(d,"exec")) return -KEY_exec;
4174 if (strEQ(d,"each")) return KEY_each;
4177 if (strEQ(d,"elsif")) return KEY_elsif;
4180 if (strEQ(d,"exists")) return KEY_exists;
4181 if (strEQ(d,"elseif")) warn("elseif should be elsif");
4184 if (strEQ(d,"endgrent")) return -KEY_endgrent;
4185 if (strEQ(d,"endpwent")) return -KEY_endpwent;
4188 if (strEQ(d,"endnetent")) return -KEY_endnetent;
4191 if (strEQ(d,"endhostent")) return -KEY_endhostent;
4192 if (strEQ(d,"endservent")) return -KEY_endservent;
4195 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
4202 if (strEQ(d,"for")) return KEY_for;
4205 if (strEQ(d,"fork")) return -KEY_fork;
4208 if (strEQ(d,"fcntl")) return -KEY_fcntl;
4209 if (strEQ(d,"flock")) return -KEY_flock;
4212 if (strEQ(d,"format")) return KEY_format;
4213 if (strEQ(d,"fileno")) return -KEY_fileno;
4216 if (strEQ(d,"foreach")) return KEY_foreach;
4219 if (strEQ(d,"formline")) return -KEY_formline;
4225 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
4226 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
4230 if (strnEQ(d,"get",3)) {
4235 if (strEQ(d,"ppid")) return -KEY_getppid;
4236 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
4239 if (strEQ(d,"pwent")) return -KEY_getpwent;
4240 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
4241 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
4244 if (strEQ(d,"peername")) return -KEY_getpeername;
4245 if (strEQ(d,"protoent")) return -KEY_getprotoent;
4246 if (strEQ(d,"priority")) return -KEY_getpriority;
4249 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
4252 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
4256 else if (*d == 'h') {
4257 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
4258 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
4259 if (strEQ(d,"hostent")) return -KEY_gethostent;
4261 else if (*d == 'n') {
4262 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
4263 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
4264 if (strEQ(d,"netent")) return -KEY_getnetent;
4266 else if (*d == 's') {
4267 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
4268 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
4269 if (strEQ(d,"servent")) return -KEY_getservent;
4270 if (strEQ(d,"sockname")) return -KEY_getsockname;
4271 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
4273 else if (*d == 'g') {
4274 if (strEQ(d,"grent")) return -KEY_getgrent;
4275 if (strEQ(d,"grnam")) return -KEY_getgrnam;
4276 if (strEQ(d,"grgid")) return -KEY_getgrgid;
4278 else if (*d == 'l') {
4279 if (strEQ(d,"login")) return -KEY_getlogin;
4281 else if (strEQ(d,"c")) return -KEY_getc;
4286 if (strEQ(d,"gt")) return -KEY_gt;
4287 if (strEQ(d,"ge")) return -KEY_ge;
4290 if (strEQ(d,"grep")) return KEY_grep;
4291 if (strEQ(d,"goto")) return KEY_goto;
4292 if (strEQ(d,"glob")) return KEY_glob;
4295 if (strEQ(d,"gmtime")) return -KEY_gmtime;
4300 if (strEQ(d,"hex")) return -KEY_hex;
4303 if (strEQ(d,"INIT")) return KEY_INIT;
4308 if (strEQ(d,"if")) return KEY_if;
4311 if (strEQ(d,"int")) return -KEY_int;
4314 if (strEQ(d,"index")) return -KEY_index;
4315 if (strEQ(d,"ioctl")) return -KEY_ioctl;
4320 if (strEQ(d,"join")) return -KEY_join;
4324 if (strEQ(d,"keys")) return KEY_keys;
4325 if (strEQ(d,"kill")) return -KEY_kill;
4330 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
4331 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
4337 if (strEQ(d,"lt")) return -KEY_lt;
4338 if (strEQ(d,"le")) return -KEY_le;
4339 if (strEQ(d,"lc")) return -KEY_lc;
4342 if (strEQ(d,"log")) return -KEY_log;
4345 if (strEQ(d,"last")) return KEY_last;
4346 if (strEQ(d,"link")) return -KEY_link;
4347 if (strEQ(d,"lock")) return -KEY_lock;
4350 if (strEQ(d,"local")) return KEY_local;
4351 if (strEQ(d,"lstat")) return -KEY_lstat;
4354 if (strEQ(d,"length")) return -KEY_length;
4355 if (strEQ(d,"listen")) return -KEY_listen;
4358 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
4361 if (strEQ(d,"localtime")) return -KEY_localtime;
4367 case 1: return KEY_m;
4369 if (strEQ(d,"my")) return KEY_my;
4372 if (strEQ(d,"map")) return KEY_map;
4375 if (strEQ(d,"mkdir")) return -KEY_mkdir;
4378 if (strEQ(d,"msgctl")) return -KEY_msgctl;
4379 if (strEQ(d,"msgget")) return -KEY_msgget;
4380 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
4381 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
4386 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
4389 if (strEQ(d,"next")) return KEY_next;
4390 if (strEQ(d,"ne")) return -KEY_ne;
4391 if (strEQ(d,"not")) return -KEY_not;
4392 if (strEQ(d,"no")) return KEY_no;
4397 if (strEQ(d,"or")) return -KEY_or;
4400 if (strEQ(d,"ord")) return -KEY_ord;
4401 if (strEQ(d,"oct")) return -KEY_oct;
4404 if (strEQ(d,"open")) return -KEY_open;
4407 if (strEQ(d,"opendir")) return -KEY_opendir;
4414 if (strEQ(d,"pop")) return KEY_pop;
4415 if (strEQ(d,"pos")) return KEY_pos;
4418 if (strEQ(d,"push")) return KEY_push;
4419 if (strEQ(d,"pack")) return -KEY_pack;
4420 if (strEQ(d,"pipe")) return -KEY_pipe;
4423 if (strEQ(d,"print")) return KEY_print;
4426 if (strEQ(d,"printf")) return KEY_printf;
4429 if (strEQ(d,"package")) return KEY_package;
4432 if (strEQ(d,"prototype")) return KEY_prototype;
4437 if (strEQ(d,"q")) return KEY_q;
4438 if (strEQ(d,"qq")) return KEY_qq;
4439 if (strEQ(d,"qw")) return KEY_qw;
4440 if (strEQ(d,"qx")) return KEY_qx;
4442 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
4447 if (strEQ(d,"ref")) return -KEY_ref;
4450 if (strEQ(d,"read")) return -KEY_read;
4451 if (strEQ(d,"rand")) return -KEY_rand;
4452 if (strEQ(d,"recv")) return -KEY_recv;
4453 if (strEQ(d,"redo")) return KEY_redo;
4456 if (strEQ(d,"rmdir")) return -KEY_rmdir;
4457 if (strEQ(d,"reset")) return -KEY_reset;
4460 if (strEQ(d,"return")) return KEY_return;
4461 if (strEQ(d,"rename")) return -KEY_rename;
4462 if (strEQ(d,"rindex")) return -KEY_rindex;
4465 if (strEQ(d,"require")) return -KEY_require;
4466 if (strEQ(d,"reverse")) return -KEY_reverse;
4467 if (strEQ(d,"readdir")) return -KEY_readdir;
4470 if (strEQ(d,"readlink")) return -KEY_readlink;
4471 if (strEQ(d,"readline")) return -KEY_readline;
4472 if (strEQ(d,"readpipe")) return -KEY_readpipe;
4475 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
4481 case 0: return KEY_s;
4483 if (strEQ(d,"scalar")) return KEY_scalar;
4488 if (strEQ(d,"seek")) return -KEY_seek;
4489 if (strEQ(d,"send")) return -KEY_send;
4492 if (strEQ(d,"semop")) return -KEY_semop;
4495 if (strEQ(d,"select")) return -KEY_select;
4496 if (strEQ(d,"semctl")) return -KEY_semctl;
4497 if (strEQ(d,"semget")) return -KEY_semget;
4500 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
4501 if (strEQ(d,"seekdir")) return -KEY_seekdir;
4504 if (strEQ(d,"setpwent")) return -KEY_setpwent;
4505 if (strEQ(d,"setgrent")) return -KEY_setgrent;
4508 if (strEQ(d,"setnetent")) return -KEY_setnetent;
4511 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
4512 if (strEQ(d,"sethostent")) return -KEY_sethostent;
4513 if (strEQ(d,"setservent")) return -KEY_setservent;
4516 if (strEQ(d,"setpriority")) return -KEY_setpriority;
4517 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
4524 if (strEQ(d,"shift")) return KEY_shift;
4527 if (strEQ(d,"shmctl")) return -KEY_shmctl;
4528 if (strEQ(d,"shmget")) return -KEY_shmget;
4531 if (strEQ(d,"shmread")) return -KEY_shmread;
4534 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
4535 if (strEQ(d,"shutdown")) return -KEY_shutdown;
4540 if (strEQ(d,"sin")) return -KEY_sin;
4543 if (strEQ(d,"sleep")) return -KEY_sleep;
4546 if (strEQ(d,"sort")) return KEY_sort;
4547 if (strEQ(d,"socket")) return -KEY_socket;
4548 if (strEQ(d,"socketpair")) return -KEY_socketpair;
4551 if (strEQ(d,"split")) return KEY_split;
4552 if (strEQ(d,"sprintf")) return -KEY_sprintf;
4553 if (strEQ(d,"splice")) return KEY_splice;
4556 if (strEQ(d,"sqrt")) return -KEY_sqrt;
4559 if (strEQ(d,"srand")) return -KEY_srand;
4562 if (strEQ(d,"stat")) return -KEY_stat;
4563 if (strEQ(d,"study")) return KEY_study;
4566 if (strEQ(d,"substr")) return -KEY_substr;
4567 if (strEQ(d,"sub")) return KEY_sub;
4572 if (strEQ(d,"system")) return -KEY_system;
4575 if (strEQ(d,"symlink")) return -KEY_symlink;
4576 if (strEQ(d,"syscall")) return -KEY_syscall;
4577 if (strEQ(d,"sysopen")) return -KEY_sysopen;
4578 if (strEQ(d,"sysread")) return -KEY_sysread;
4579 if (strEQ(d,"sysseek")) return -KEY_sysseek;
4582 if (strEQ(d,"syswrite")) return -KEY_syswrite;
4591 if (strEQ(d,"tr")) return KEY_tr;
4594 if (strEQ(d,"tie")) return KEY_tie;
4597 if (strEQ(d,"tell")) return -KEY_tell;
4598 if (strEQ(d,"tied")) return KEY_tied;
4599 if (strEQ(d,"time")) return -KEY_time;
4602 if (strEQ(d,"times")) return -KEY_times;
4605 if (strEQ(d,"telldir")) return -KEY_telldir;
4608 if (strEQ(d,"truncate")) return -KEY_truncate;
4615 if (strEQ(d,"uc")) return -KEY_uc;
4618 if (strEQ(d,"use")) return KEY_use;
4621 if (strEQ(d,"undef")) return KEY_undef;
4622 if (strEQ(d,"until")) return KEY_until;
4623 if (strEQ(d,"untie")) return KEY_untie;
4624 if (strEQ(d,"utime")) return -KEY_utime;
4625 if (strEQ(d,"umask")) return -KEY_umask;
4628 if (strEQ(d,"unless")) return KEY_unless;
4629 if (strEQ(d,"unpack")) return -KEY_unpack;
4630 if (strEQ(d,"unlink")) return -KEY_unlink;
4633 if (strEQ(d,"unshift")) return KEY_unshift;
4634 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
4639 if (strEQ(d,"values")) return -KEY_values;
4640 if (strEQ(d,"vec")) return -KEY_vec;
4645 if (strEQ(d,"warn")) return -KEY_warn;
4646 if (strEQ(d,"wait")) return -KEY_wait;
4649 if (strEQ(d,"while")) return KEY_while;
4650 if (strEQ(d,"write")) return -KEY_write;
4653 if (strEQ(d,"waitpid")) return -KEY_waitpid;
4656 if (strEQ(d,"wantarray")) return -KEY_wantarray;
4661 if (len == 1) return -KEY_x;
4662 if (strEQ(d,"xor")) return -KEY_xor;
4665 if (len == 1) return KEY_y;
4674 checkcomma(register char *s, char *name, char *what)
4678 if (dowarn && *s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
4680 for (w = s+2; *w && level; w++) {
4687 for (; *w && isSPACE(*w); w++) ;
4688 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
4689 warn("%s (...) interpreted as function",name);
4691 while (s < bufend && isSPACE(*s))
4695 while (s < bufend && isSPACE(*s))
4697 if (isIDFIRST(*s)) {
4701 while (s < bufend && isSPACE(*s))
4706 kw = keyword(w, s - w) || perl_get_cv(w, FALSE) != 0;
4710 croak("No comma allowed after %s", what);
4716 new_constant(char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)
4719 HV *table = GvHV(hintgv); /* ^H */
4722 bool oldcatch = CATCH_GET;
4728 yyerror("%^H is not defined");
4731 cvp = hv_fetch(table, key, strlen(key), FALSE);
4732 if (!cvp || !SvOK(*cvp)) {
4733 sprintf(buf,"$^H{%s} is not defined", key);
4737 sv_2mortal(sv); /* Parent created it permanently */
4740 pv = sv_2mortal(newSVpv(s, len));
4742 typesv = sv_2mortal(newSVpv(type, 0));
4746 Zero(&myop, 1, BINOP);
4747 myop.op_last = (OP *) &myop;
4748 myop.op_next = Nullop;
4749 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
4751 PUSHSTACKi(SI_OVERLOAD);
4755 if (PERLDB_SUB && curstash != debstash)
4756 op->op_private |= OPpENTERSUB_DB;
4767 if (op = pp_entersub(ARGS))
4774 CATCH_SET(oldcatch);
4778 sprintf(buf,"Call to &{$^H{%s}} did not return a defined value", key);
4781 return SvREFCNT_inc(res);
4785 scan_word(register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
4787 register char *d = dest;
4788 register char *e = d + destlen - 3; /* two-character token, ending NUL */
4791 croak(ident_too_long);
4794 else if (*s == '\'' && allow_package && isIDFIRST(s[1])) {
4799 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
4812 scan_ident(register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
4819 if (lex_brackets == 0)
4824 e = d + destlen - 3; /* two-character token, ending NUL */
4826 while (isDIGIT(*s)) {
4828 croak(ident_too_long);
4835 croak(ident_too_long);
4838 else if (*s == '\'' && isIDFIRST(s[1])) {
4843 else if (*s == ':' && s[1] == ':') {
4854 if (lex_state != LEX_NORMAL)
4855 lex_state = LEX_INTERPENDMAYBE;
4858 if (*s == '$' && s[1] &&
4859 (isALNUM(s[1]) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
4861 if (isDIGIT(s[1]) && lex_state == LEX_INTERPNORMAL)
4862 deprecate("\"$$<digit>\" to mean \"${$}<digit>\"");
4875 if (*d == '^' && *s && (isUPPER(*s) || strchr("[\\]^_?", *s))) {
4880 if (isSPACE(s[-1])) {
4883 if (ch != ' ' && ch != '\t') {
4889 if (isIDFIRST(*d)) {
4891 while (isALNUM(*s) || *s == ':')
4894 while (s < send && (*s == ' ' || *s == '\t')) s++;
4895 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
4896 if (dowarn && keyword(dest, d - dest)) {
4897 char *brack = *s == '[' ? "[...]" : "{...}";
4898 warn("Ambiguous use of %c{%s%s} resolved to %c%s%s",
4899 funny, dest, brack, funny, dest, brack);
4901 lex_fakebrack = lex_brackets+1;
4903 lex_brackstack[lex_brackets++] = XOPERATOR;
4909 if (lex_state == LEX_INTERPNORMAL && !lex_brackets)
4910 lex_state = LEX_INTERPEND;
4913 if (dowarn && lex_state == LEX_NORMAL &&
4914 (keyword(dest, d - dest) || perl_get_cv(dest, FALSE)))
4915 warn("Ambiguous use of %c{%s} resolved to %c%s",
4916 funny, dest, funny, dest);
4919 s = bracket; /* let the parser handle it */
4923 else if (lex_state == LEX_INTERPNORMAL && !lex_brackets && !intuit_more(s))
4924 lex_state = LEX_INTERPEND;
4928 void pmflag(U16 *pmfl, int ch)
4933 *pmfl |= PMf_GLOBAL;
4935 *pmfl |= PMf_CONTINUE;
4939 *pmfl |= PMf_MULTILINE;
4941 *pmfl |= PMf_SINGLELINE;
4943 *pmfl |= PMf_TAINTMEM;
4945 *pmfl |= PMf_EXTENDED;
4949 scan_pat(char *start)
4954 s = scan_str(start);
4957 SvREFCNT_dec(lex_stuff);
4959 croak("Search pattern not terminated");
4962 pm = (PMOP*)newPMOP(OP_MATCH, 0);
4963 if (multi_open == '?')
4964 pm->op_pmflags |= PMf_ONCE;
4965 while (*s && strchr("iogcmstx", *s))
4966 pmflag(&pm->op_pmflags,*s++);
4967 pm->op_pmpermflags = pm->op_pmflags;
4970 yylval.ival = OP_MATCH;
4975 scan_subst(char *start)
4982 yylval.ival = OP_NULL;
4984 s = scan_str(start);
4988 SvREFCNT_dec(lex_stuff);
4990 croak("Substitution pattern not terminated");
4993 if (s[-1] == multi_open)
4996 first_start = multi_start;
5000 SvREFCNT_dec(lex_stuff);
5003 SvREFCNT_dec(lex_repl);
5005 croak("Substitution replacement not terminated");
5007 multi_start = first_start; /* so whole substitution is taken together */
5009 pm = (PMOP*)newPMOP(OP_SUBST, 0);
5015 else if (strchr("iogcmstx", *s))
5016 pmflag(&pm->op_pmflags,*s++);
5023 pm->op_pmflags |= PMf_EVAL;
5024 repl = newSVpv("",0);
5026 sv_catpv(repl, es ? "eval " : "do ");
5027 sv_catpvn(repl, "{ ", 2);
5028 sv_catsv(repl, lex_repl);
5029 sv_catpvn(repl, " };", 2);
5030 SvCOMPILED_on(repl);
5031 SvREFCNT_dec(lex_repl);
5035 pm->op_pmpermflags = pm->op_pmflags;
5037 yylval.ival = OP_SUBST;
5042 scan_trans(char *start)
5051 yylval.ival = OP_NULL;
5053 s = scan_str(start);
5056 SvREFCNT_dec(lex_stuff);
5058 croak("Transliteration pattern not terminated");
5060 if (s[-1] == multi_open)
5066 SvREFCNT_dec(lex_stuff);
5069 SvREFCNT_dec(lex_repl);
5071 croak("Transliteration replacement not terminated");
5074 New(803,tbl,256,short);
5075 o = newPVOP(OP_TRANS, 0, (char*)tbl);
5077 complement = Delete = squash = 0;
5078 while (*s == 'c' || *s == 'd' || *s == 's') {
5080 complement = OPpTRANS_COMPLEMENT;
5082 Delete = OPpTRANS_DELETE;
5084 squash = OPpTRANS_SQUASH;
5087 o->op_private = Delete|squash|complement;
5090 yylval.ival = OP_TRANS;
5095 scan_heredoc(register char *s)
5099 I32 op_type = OP_SCALAR;
5106 int outer = (rsfp && !(lex_inwhat == OP_SCALAR));
5110 e = tokenbuf + sizeof tokenbuf - 1;
5113 for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5114 if (*peek && strchr("`'\"",*peek)) {
5117 s = delimcpy(d, e, s, bufend, term, &len);
5128 deprecate("bare << to mean <<\"\"");
5129 for (; isALNUM(*s); s++) {
5134 if (d >= tokenbuf + sizeof tokenbuf - 1)
5135 croak("Delimiter for here document is too long");
5140 if (outer || !(d=ninstr(s,bufend,d,d+1)))
5141 herewas = newSVpv(s,bufend-s);
5143 s--, herewas = newSVpv(s,d-s);
5144 s += SvCUR(herewas);
5146 tmpstr = NEWSV(87,79);
5147 sv_upgrade(tmpstr, SVt_PVIV);
5152 else if (term == '`') {
5153 op_type = OP_BACKTICK;
5154 SvIVX(tmpstr) = '\\';
5158 multi_start = curcop->cop_line;
5159 multi_open = multi_close = '<';
5163 while (s < bufend &&
5164 (*s != term || memNE(s,tokenbuf,len)) ) {
5169 curcop->cop_line = multi_start;
5170 missingterm(tokenbuf);
5172 sv_setpvn(tmpstr,d+1,s-d);
5174 curcop->cop_line++; /* the preceding stmt passes a newline */
5176 sv_catpvn(herewas,s,bufend-s);
5177 sv_setsv(linestr,herewas);
5178 oldoldbufptr = oldbufptr = bufptr = s = linestart = SvPVX(linestr);
5179 bufend = SvPVX(linestr) + SvCUR(linestr);
5182 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
5183 while (s >= bufend) { /* multiple line string? */
5185 !(oldoldbufptr = oldbufptr = s = linestart = filter_gets(linestr, rsfp, 0))) {
5186 curcop->cop_line = multi_start;
5187 missingterm(tokenbuf);
5190 if (PERLDB_LINE && curstash != debstash) {
5191 SV *sv = NEWSV(88,0);
5193 sv_upgrade(sv, SVt_PVMG);
5194 sv_setsv(sv,linestr);
5195 av_store(GvAV(curcop->cop_filegv),
5196 (I32)curcop->cop_line,sv);
5198 bufend = SvPVX(linestr) + SvCUR(linestr);
5199 if (*s == term && memEQ(s,tokenbuf,len)) {
5202 sv_catsv(linestr,herewas);
5203 bufend = SvPVX(linestr) + SvCUR(linestr);
5207 sv_catsv(tmpstr,linestr);
5210 multi_end = curcop->cop_line;
5212 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
5213 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
5214 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
5216 SvREFCNT_dec(herewas);
5218 yylval.ival = op_type;
5223 takes: current position in input buffer
5224 returns: new position in input buffer
5225 side-effects: yylval and lex_op are set.
5230 <FH> read from filehandle
5231 <pkg::FH> read from package qualified filehandle
5232 <pkg'FH> read from package qualified filehandle
5233 <$fh> read from filehandle in $fh
5239 scan_inputsymbol(char *start)
5241 register char *s = start; /* current position in buffer */
5246 d = tokenbuf; /* start of temp holding space */
5247 e = tokenbuf + sizeof tokenbuf; /* end of temp holding space */
5248 s = delimcpy(d, e, s + 1, bufend, '>', &len); /* extract until > */
5250 /* die if we didn't have space for the contents of the <>,
5254 if (len >= sizeof tokenbuf)
5255 croak("Excessively long <> operator");
5257 croak("Unterminated <> operator");
5262 Remember, only scalar variables are interpreted as filehandles by
5263 this code. Anything more complex (e.g., <$fh{$num}>) will be
5264 treated as a glob() call.
5265 This code makes use of the fact that except for the $ at the front,
5266 a scalar variable and a filehandle look the same.
5268 if (*d == '$' && d[1]) d++;
5270 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
5271 while (*d && (isALNUM(*d) || *d == '\'' || *d == ':'))
5274 /* If we've tried to read what we allow filehandles to look like, and
5275 there's still text left, then it must be a glob() and not a getline.
5276 Use scan_str to pull out the stuff between the <> and treat it
5277 as nothing more than a string.
5280 if (d - tokenbuf != len) {
5281 yylval.ival = OP_GLOB;
5283 s = scan_str(start);
5285 croak("Glob not terminated");
5289 /* we're in a filehandle read situation */
5292 /* turn <> into <ARGV> */
5294 (void)strcpy(d,"ARGV");
5296 /* if <$fh>, create the ops to turn the variable into a
5302 /* try to find it in the pad for this block, otherwise find
5303 add symbol table ops
5305 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
5306 OP *o = newOP(OP_PADSV, 0);
5308 lex_op = (OP*)newUNOP(OP_READLINE, 0, newUNOP(OP_RV2GV, 0, o));
5311 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
5312 lex_op = (OP*)newUNOP(OP_READLINE, 0,
5313 newUNOP(OP_RV2GV, 0,
5314 newUNOP(OP_RV2SV, 0,
5315 newGVOP(OP_GV, 0, gv))));
5317 /* we created the ops in lex_op, so make yylval.ival a null op */
5318 yylval.ival = OP_NULL;
5321 /* If it's none of the above, it must be a literal filehandle
5322 (<Foo::BAR> or <FOO>) so build a simple readline OP */
5324 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
5325 lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
5326 yylval.ival = OP_NULL;
5335 takes: start position in buffer
5336 returns: position to continue reading from buffer
5337 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
5338 updates the read buffer.
5340 This subroutine pulls a string out of the input. It is called for:
5341 q single quotes q(literal text)
5342 ' single quotes 'literal text'
5343 qq double quotes qq(interpolate $here please)
5344 " double quotes "interpolate $here please"
5345 qx backticks qx(/bin/ls -l)
5346 ` backticks `/bin/ls -l`
5347 qw quote words @EXPORT_OK = qw( func() $spam )
5348 m// regexp match m/this/
5349 s/// regexp substitute s/this/that/
5350 tr/// string transliterate tr/this/that/
5351 y/// string transliterate y/this/that/
5352 ($*@) sub prototypes sub foo ($)
5353 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
5355 In most of these cases (all but <>, patterns and transliterate)
5356 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
5357 calls scan_str(). s/// makes yylex() call scan_subst() which calls
5358 scan_str(). tr/// and y/// make yylex() call scan_trans() which
5361 It skips whitespace before the string starts, and treats the first
5362 character as the delimiter. If the delimiter is one of ([{< then
5363 the corresponding "close" character )]}> is used as the closing
5364 delimiter. It allows quoting of delimiters, and if the string has
5365 balanced delimiters ([{<>}]) it allows nesting.
5367 The lexer always reads these strings into lex_stuff, except in the
5368 case of the operators which take *two* arguments (s/// and tr///)
5369 when it checks to see if lex_stuff is full (presumably with the 1st
5370 arg to s or tr) and if so puts the string into lex_repl.
5375 scan_str(char *start)
5378 SV *sv; /* scalar value: string */
5379 char *tmps; /* temp string, used for delimiter matching */
5380 register char *s = start; /* current position in the buffer */
5381 register char term; /* terminating character */
5382 register char *to; /* current position in the sv's data */
5383 I32 brackets = 1; /* bracket nesting level */
5385 /* skip space before the delimiter */
5389 /* mark where we are, in case we need to report errors */
5392 /* after skipping whitespace, the next character is the terminator */
5394 /* mark where we are */
5395 multi_start = curcop->cop_line;
5398 /* find corresponding closing delimiter */
5399 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5403 /* create a new SV to hold the contents. 87 is leak category, I'm
5404 assuming. 79 is the SV's initial length. What a random number. */
5406 sv_upgrade(sv, SVt_PVIV);
5408 (void)SvPOK_only(sv); /* validate pointer */
5410 /* move past delimiter and try to read a complete string */
5413 /* extend sv if need be */
5414 SvGROW(sv, SvCUR(sv) + (bufend - s) + 1);
5415 /* set 'to' to the next character in the sv's string */
5416 to = SvPVX(sv)+SvCUR(sv);
5418 /* if open delimiter is the close delimiter read unbridle */
5419 if (multi_open == multi_close) {
5420 for (; s < bufend; s++,to++) {
5421 /* embedded newlines increment the current line number */
5422 if (*s == '\n' && !rsfp)
5424 /* handle quoted delimiters */
5425 if (*s == '\\' && s+1 < bufend && term != '\\') {
5428 /* any other quotes are simply copied straight through */
5432 /* terminate when run out of buffer (the for() condition), or
5433 have found the terminator */
5434 else if (*s == term)
5440 /* if the terminator isn't the same as the start character (e.g.,
5441 matched brackets), we have to allow more in the quoting, and
5442 be prepared for nested brackets.
5445 /* read until we run out of string, or we find the terminator */
5446 for (; s < bufend; s++,to++) {
5447 /* embedded newlines increment the line count */
5448 if (*s == '\n' && !rsfp)
5450 /* backslashes can escape the open or closing characters */
5451 if (*s == '\\' && s+1 < bufend) {
5452 if ((s[1] == multi_open) || (s[1] == multi_close))
5457 /* allow nested opens and closes */
5458 else if (*s == multi_close && --brackets <= 0)
5460 else if (*s == multi_open)
5465 /* terminate the copied string and update the sv's end-of-string */
5467 SvCUR_set(sv, to - SvPVX(sv));
5470 * this next chunk reads more into the buffer if we're not done yet
5473 if (s < bufend) break; /* handle case where we are done yet :-) */
5475 /* if we're out of file, or a read fails, bail and reset the current
5476 line marker so we can report where the unterminated string began
5479 !(oldoldbufptr = oldbufptr = s = linestart = filter_gets(linestr, rsfp, 0))) {
5481 curcop->cop_line = multi_start;
5484 /* we read a line, so increment our line counter */
5487 /* update debugger info */
5488 if (PERLDB_LINE && curstash != debstash) {
5489 SV *sv = NEWSV(88,0);
5491 sv_upgrade(sv, SVt_PVMG);
5492 sv_setsv(sv,linestr);
5493 av_store(GvAV(curcop->cop_filegv),
5494 (I32)curcop->cop_line, sv);
5497 /* having changed the buffer, we must update bufend */
5498 bufend = SvPVX(linestr) + SvCUR(linestr);
5501 /* at this point, we have successfully read the delimited string */
5503 multi_end = curcop->cop_line;
5506 /* if we allocated too much space, give some back */
5507 if (SvCUR(sv) + 5 < SvLEN(sv)) {
5508 SvLEN_set(sv, SvCUR(sv) + 1);
5509 Renew(SvPVX(sv), SvLEN(sv), char);
5512 /* decide whether this is the first or second quoted string we've read
5525 takes: pointer to position in buffer
5526 returns: pointer to new position in buffer
5527 side-effects: builds ops for the constant in yylval.op
5529 Read a number in any of the formats that Perl accepts:
5531 0(x[0-7A-F]+)|([0-7]+)
5532 [\d_]+(\.[\d_]*)?[Ee](\d+)
5534 Underbars (_) are allowed in decimal numbers. If -w is on,
5535 underbars before a decimal point must be at three digit intervals.
5537 Like most scan_ routines, it uses the tokenbuf buffer to hold the
5540 If it reads a number without a decimal point or an exponent, it will
5541 try converting the number to an integer and see if it can do so
5542 without loss of precision.
5546 scan_num(char *start)
5548 register char *s = start; /* current position in buffer */
5549 register char *d; /* destination in temp buffer */
5550 register char *e; /* end of temp buffer */
5551 I32 tryiv; /* used to see if it can be an int */
5552 double value; /* number read, as a double */
5553 SV *sv; /* place to put the converted number */
5554 I32 floatit; /* boolean: int or float? */
5555 char *lastub = 0; /* position of last underbar */
5556 static char number_too_long[] = "Number too long";
5558 /* We use the first character to decide what type of number this is */
5562 croak("panic: scan_num");
5564 /* if it starts with a 0, it could be an octal number, a decimal in
5565 0.13 disguise, or a hexadecimal number.
5570 u holds the "number so far"
5571 shift the power of 2 of the base (hex == 4, octal == 3)
5572 overflowed was the number more than we can hold?
5574 Shift is used when we add a digit. It also serves as an "are
5575 we in octal or hex?" indicator to disallow hex characters when
5580 bool overflowed = FALSE;
5587 /* check for a decimal in disguise */
5588 else if (s[1] == '.')
5590 /* so it must be octal */
5595 /* read the rest of the octal number */
5597 UV n, b; /* n is used in the overflow test, b is the digit we're adding on */
5601 /* if we don't mention it, we're done */
5610 /* 8 and 9 are not octal */
5613 yyerror("Illegal octal digit");
5617 case '0': case '1': case '2': case '3': case '4':
5618 case '5': case '6': case '7':
5619 b = *s++ & 15; /* ASCII digit -> value of digit */
5623 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
5624 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
5625 /* make sure they said 0x */
5630 /* Prepare to put the digit we have onto the end
5631 of the number so far. We check for overflows.
5635 n = u << shift; /* make room for the digit */
5636 if (!overflowed && (n >> shift) != u
5637 && !(hints & HINT_NEW_BINARY)) {
5638 warn("Integer overflow in %s number",
5639 (shift == 4) ? "hex" : "octal");
5642 u = n | b; /* add the digit to the end */
5647 /* if we get here, we had success: make a scalar value from
5653 if ( hints & HINT_NEW_BINARY)
5654 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
5659 handle decimal numbers.
5660 we're also sent here when we read a 0 as the first digit
5662 case '1': case '2': case '3': case '4': case '5':
5663 case '6': case '7': case '8': case '9': case '.':
5666 e = tokenbuf + sizeof tokenbuf - 6; /* room for various punctuation */
5669 /* read next group of digits and _ and copy into d */
5670 while (isDIGIT(*s) || *s == '_') {
5671 /* skip underscores, checking for misplaced ones
5675 if (dowarn && lastub && s - lastub != 3)
5676 warn("Misplaced _ in number");
5680 /* check for end of fixed-length buffer */
5682 croak(number_too_long);
5683 /* if we're ok, copy the character */
5688 /* final misplaced underbar check */
5689 if (dowarn && lastub && s - lastub != 3)
5690 warn("Misplaced _ in number");
5692 /* read a decimal portion if there is one. avoid
5693 3..5 being interpreted as the number 3. followed
5696 if (*s == '.' && s[1] != '.') {
5700 /* copy, ignoring underbars, until we run out of
5701 digits. Note: no misplaced underbar checks!
5703 for (; isDIGIT(*s) || *s == '_'; s++) {
5704 /* fixed length buffer check */
5706 croak(number_too_long);
5712 /* read exponent part, if present */
5713 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
5717 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
5718 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
5720 /* allow positive or negative exponent */
5721 if (*s == '+' || *s == '-')
5724 /* read digits of exponent (no underbars :-) */
5725 while (isDIGIT(*s)) {
5727 croak(number_too_long);
5732 /* terminate the string */
5735 /* make an sv from the string */
5737 /* reset numeric locale in case we were earlier left in Swaziland */
5738 SET_NUMERIC_STANDARD();
5739 value = atof(tokenbuf);
5742 See if we can make do with an integer value without loss of
5743 precision. We use I_V to cast to an int, because some
5744 compilers have issues. Then we try casting it back and see
5745 if it was the same. We only do this if we know we
5746 specifically read an integer.
5748 Note: if floatit is true, then we don't need to do the
5752 if (!floatit && (double)tryiv == value)
5753 sv_setiv(sv, tryiv);
5755 sv_setnv(sv, value);
5756 if ( floatit ? (hints & HINT_NEW_FLOAT) : (hints & HINT_NEW_INTEGER) )
5757 sv = new_constant(tokenbuf, d - tokenbuf,
5758 (floatit ? "float" : "integer"), sv, Nullsv, NULL);
5762 /* make the op for the constant and return */
5764 yylval.opval = newSVOP(OP_CONST, 0, sv);
5770 scan_formline(register char *s)
5775 SV *stuff = newSVpv("",0);
5776 bool needargs = FALSE;
5779 if (*s == '.' || *s == '}') {
5781 for (t = s+1; *t == ' ' || *t == '\t'; t++) ;
5785 if (in_eval && !rsfp) {
5786 eol = strchr(s,'\n');
5791 eol = bufend = SvPVX(linestr) + SvCUR(linestr);
5793 for (t = s; t < eol; t++) {
5794 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
5796 goto enough; /* ~~ must be first line in formline */
5798 if (*t == '@' || *t == '^')
5801 sv_catpvn(stuff, s, eol-s);
5805 s = filter_gets(linestr, rsfp, 0);
5806 oldoldbufptr = oldbufptr = bufptr = linestart = SvPVX(linestr);
5807 bufend = bufptr + SvCUR(linestr);
5810 yyerror("Format not terminated");
5820 lex_state = LEX_NORMAL;
5821 nextval[nexttoke].ival = 0;
5825 lex_state = LEX_FORMLINE;
5826 nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
5828 nextval[nexttoke].ival = OP_FORMLINE;
5832 SvREFCNT_dec(stuff);
5844 cshlen = strlen(cshname);
5849 start_subparse(I32 is_format, U32 flags)
5852 I32 oldsavestack_ix = savestack_ix;
5853 CV* outsidecv = compcv;
5857 assert(SvTYPE(compcv) == SVt_PVCV);
5864 SAVESPTR(comppad_name);
5866 SAVEI32(comppad_name_fill);
5867 SAVEI32(min_intro_pending);
5868 SAVEI32(max_intro_pending);
5869 SAVEI32(pad_reset_pending);
5871 compcv = (CV*)NEWSV(1104,0);
5872 sv_upgrade((SV *)compcv, is_format ? SVt_PVFM : SVt_PVCV);
5873 CvFLAGS(compcv) |= flags;
5876 av_push(comppad, Nullsv);
5877 curpad = AvARRAY(comppad);
5878 comppad_name = newAV();
5879 comppad_name_fill = 0;
5880 min_intro_pending = 0;
5882 subline = curcop->cop_line;
5884 av_store(comppad_name, 0, newSVpv("@_", 2));
5885 curpad[0] = (SV*)newAV();
5886 SvPADMY_on(curpad[0]); /* XXX Needed? */
5887 CvOWNER(compcv) = 0;
5888 New(666, CvMUTEXP(compcv), 1, perl_mutex);
5889 MUTEX_INIT(CvMUTEXP(compcv));
5890 #endif /* USE_THREADS */
5892 comppadlist = newAV();
5893 AvREAL_off(comppadlist);
5894 av_store(comppadlist, 0, (SV*)comppad_name);
5895 av_store(comppadlist, 1, (SV*)comppad);
5897 CvPADLIST(compcv) = comppadlist;
5898 CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc(outsidecv);
5900 CvOWNER(compcv) = 0;
5901 New(666, CvMUTEXP(compcv), 1, perl_mutex);
5902 MUTEX_INIT(CvMUTEXP(compcv));
5903 #endif /* USE_THREADS */
5905 return oldsavestack_ix;
5924 char *context = NULL;
5928 if (!yychar || (yychar == ';' && !rsfp))
5930 else if (bufptr > oldoldbufptr && bufptr - oldoldbufptr < 200 &&
5931 oldoldbufptr != oldbufptr && oldbufptr != bufptr) {
5932 while (isSPACE(*oldoldbufptr))
5934 context = oldoldbufptr;
5935 contlen = bufptr - oldoldbufptr;
5937 else if (bufptr > oldbufptr && bufptr - oldbufptr < 200 &&
5938 oldbufptr != bufptr) {
5939 while (isSPACE(*oldbufptr))
5941 context = oldbufptr;
5942 contlen = bufptr - oldbufptr;
5944 else if (yychar > 255)
5945 where = "next token ???";
5946 else if ((yychar & 127) == 127) {
5947 if (lex_state == LEX_NORMAL ||
5948 (lex_state == LEX_KNOWNEXT && lex_defer == LEX_NORMAL))
5949 where = "at end of line";
5951 where = "within pattern";
5953 where = "within string";
5956 SV *where_sv = sv_2mortal(newSVpv("next char ", 0));
5958 sv_catpvf(where_sv, "^%c", toCTRL(yychar));
5959 else if (isPRINT_LC(yychar))
5960 sv_catpvf(where_sv, "%c", yychar);
5962 sv_catpvf(where_sv, "\\%03o", yychar & 255);
5963 where = SvPVX(where_sv);
5965 msg = sv_2mortal(newSVpv(s, 0));
5966 sv_catpvf(msg, " at %_ line %ld, ",
5967 GvSV(curcop->cop_filegv), (long)curcop->cop_line);
5969 sv_catpvf(msg, "near \"%.*s\"\n", contlen, context);
5971 sv_catpvf(msg, "%s\n", where);
5972 if (multi_start < multi_end && (U32)(curcop->cop_line - multi_end) <= 1) {
5974 " (Might be a runaway multi-line %c%c string starting on line %ld)\n",
5975 (int)multi_open,(int)multi_close,(long)multi_start);
5981 sv_catsv(ERRSV, msg);
5983 PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
5984 if (++error_count >= 10)
5985 croak("%_ has too many errors.\n", GvSV(curcop->cop_filegv));
5987 in_my_stash = Nullhv;