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 void restore_expect _((void *e));
54 static void restore_lex_expect _((void *e));
55 #endif /* PERL_OBJECT */
57 static char ident_too_long[] = "Identifier too long";
59 /* The following are arranged oddly so that the guard on the switch statement
60 * can get by with a single comparison (if the compiler is smart enough).
63 /* #define LEX_NOTPARSING 11 is done in perl.h. */
66 #define LEX_INTERPNORMAL 9
67 #define LEX_INTERPCASEMOD 8
68 #define LEX_INTERPPUSH 7
69 #define LEX_INTERPSTART 6
70 #define LEX_INTERPEND 5
71 #define LEX_INTERPENDMAYBE 4
72 #define LEX_INTERPCONCAT 3
73 #define LEX_INTERPCONST 2
74 #define LEX_FORMLINE 1
75 #define LEX_KNOWNEXT 0
84 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
86 # include <unistd.h> /* Needed for execv() */
99 #define CLINE (copline = (curcop->cop_line < copline ? curcop->cop_line : copline))
101 #define TOKEN(retval) return (bufptr = s,(int)retval)
102 #define OPERATOR(retval) return (expect = XTERM,bufptr = s,(int)retval)
103 #define AOPERATOR(retval) return ao((expect = XTERM,bufptr = s,(int)retval))
104 #define PREBLOCK(retval) return (expect = XBLOCK,bufptr = s,(int)retval)
105 #define PRETERMBLOCK(retval) return (expect = XTERMBLOCK,bufptr = s,(int)retval)
106 #define PREREF(retval) return (expect = XREF,bufptr = s,(int)retval)
107 #define TERM(retval) return (CLINE, expect = XOPERATOR,bufptr = s,(int)retval)
108 #define LOOPX(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)LOOPEX)
109 #define FTST(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)UNIOP)
110 #define FUN0(f) return(yylval.ival = f,expect = XOPERATOR,bufptr = s,(int)FUNC0)
111 #define FUN1(f) return(yylval.ival = f,expect = XOPERATOR,bufptr = s,(int)FUNC1)
112 #define BOop(f) return ao((yylval.ival=f,expect = XTERM,bufptr = s,(int)BITOROP))
113 #define BAop(f) return ao((yylval.ival=f,expect = XTERM,bufptr = s,(int)BITANDOP))
114 #define SHop(f) return ao((yylval.ival=f,expect = XTERM,bufptr = s,(int)SHIFTOP))
115 #define PWop(f) return ao((yylval.ival=f,expect = XTERM,bufptr = s,(int)POWOP))
116 #define PMop(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)MATCHOP)
117 #define Aop(f) return ao((yylval.ival=f,expect = XTERM,bufptr = s,(int)ADDOP))
118 #define Mop(f) return ao((yylval.ival=f,expect = XTERM,bufptr = s,(int)MULOP))
119 #define Eop(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)EQOP)
120 #define Rop(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)RELOP)
122 /* This bit of chicanery makes a unary function followed by
123 * a parenthesis into a function with one argument, highest precedence.
125 #define UNI(f) return(yylval.ival = f, \
128 last_uni = oldbufptr, \
130 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
132 #define UNIBRACK(f) return(yylval.ival = f, \
134 last_uni = oldbufptr, \
135 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
137 /* grandfather return to old style */
138 #define OLDLOP(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)LSTOP)
143 if (*bufptr == '=') {
145 if (toketype == ANDAND)
146 yylval.ival = OP_ANDASSIGN;
147 else if (toketype == OROR)
148 yylval.ival = OP_ORASSIGN;
155 no_op(char *what, char *s)
157 char *oldbp = bufptr;
158 bool is_first = (oldbufptr == linestart);
161 yywarn(form("%s found where operator expected", what));
163 warn("\t(Missing semicolon on previous line?)\n");
164 else if (oldoldbufptr && isIDFIRST(*oldoldbufptr)) {
166 for (t = oldoldbufptr; *t && (isALNUM(*t) || *t == ':'); t++) ;
167 if (t < bufptr && isSPACE(*t))
168 warn("\t(Do you need to predeclare %.*s?)\n",
169 t - oldoldbufptr, oldoldbufptr);
173 warn("\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
183 char *nl = strrchr(s,'\n');
187 else if (multi_close < 32 || multi_close == 127) {
189 tmpbuf[1] = toCTRL(multi_close);
195 *tmpbuf = multi_close;
199 q = strchr(s,'"') ? '\'' : '"';
200 croak("Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
207 warn("Use of %s is deprecated", s);
213 deprecate("comma-less variable list");
219 win32_textfilter(int idx, SV *sv, int maxlen)
221 I32 count = FILTER_READ(idx+1, sv, maxlen);
222 if (count > 0 && !maxlen)
223 win32_strip_return(sv);
237 SAVEI32(lex_brackets);
238 SAVEI32(lex_fakebrack);
239 SAVEI32(lex_casemods);
244 SAVEI16(curcop->cop_line);
248 SAVEPPTR(oldoldbufptr);
251 SAVEPPTR(lex_brackstack);
252 SAVEPPTR(lex_casestack);
253 SAVEDESTRUCTOR(restore_rsfp, rsfp);
257 SAVEDESTRUCTOR(restore_expect, tokenbuf + expect); /* encode as pointer */
258 SAVEDESTRUCTOR(restore_lex_expect, tokenbuf + expect);
260 lex_state = LEX_NORMAL;
265 New(899, lex_brackstack, 120, char);
266 New(899, lex_casestack, 12, char);
267 SAVEFREEPV(lex_brackstack);
268 SAVEFREEPV(lex_casestack);
270 *lex_casestack = '\0';
278 if (SvREADONLY(linestr))
279 linestr = sv_2mortal(newSVsv(linestr));
280 s = SvPV(linestr, len);
281 if (len && s[len-1] != ';') {
282 if (!(SvFLAGS(linestr) & SVs_TEMP))
283 linestr = sv_2mortal(newSVsv(linestr));
284 sv_catpvn(linestr, "\n;", 2);
287 oldoldbufptr = oldbufptr = bufptr = linestart = SvPVX(linestr);
288 bufend = bufptr + SvCUR(linestr);
290 rs = newSVpv("\n", 1);
301 restore_rsfp(void *f)
303 PerlIO *fp = (PerlIO*)f;
305 if (rsfp == PerlIO_stdin())
306 PerlIO_clearerr(rsfp);
307 else if (rsfp && (rsfp != fp))
313 restore_expect(void *e)
315 /* a safe way to store a small integer in a pointer */
316 expect = (expectation)((char *)e - tokenbuf);
320 restore_lex_expect(void *e)
322 /* a safe way to store a small integer in a pointer */
323 lex_expect = (expectation)((char *)e - tokenbuf);
338 while (*s == ' ' || *s == '\t') s++;
339 if (strnEQ(s, "line ", 5)) {
348 while (*s == ' ' || *s == '\t')
350 if (*s == '"' && (t = strchr(s+1, '"')))
354 return; /* false alarm */
355 for (t = s; !isSPACE(*t); t++) ;
360 curcop->cop_filegv = gv_fetchfile(s);
362 curcop->cop_filegv = gv_fetchfile(origfilename);
364 curcop->cop_line = atoi(n)-1;
368 skipspace(register char *s)
371 if (lex_formbrack && lex_brackets <= lex_formbrack) {
372 while (s < bufend && (*s == ' ' || *s == '\t'))
378 while (s < bufend && isSPACE(*s))
380 if (s < bufend && *s == '#') {
381 while (s < bufend && *s != '\n')
386 if (s < bufend || !rsfp || lex_state != LEX_NORMAL)
388 if ((s = filter_gets(linestr, rsfp, (prevlen = SvCUR(linestr)))) == Nullch) {
389 if (minus_n || minus_p) {
390 sv_setpv(linestr,minus_p ?
391 ";}continue{print or die qq(-p destination: $!\\n)" :
393 sv_catpv(linestr,";}");
394 minus_n = minus_p = 0;
397 sv_setpv(linestr,";");
398 oldoldbufptr = oldbufptr = bufptr = s = linestart = SvPVX(linestr);
399 bufend = SvPVX(linestr) + SvCUR(linestr);
400 if (preprocess && !in_eval)
401 (void)PerlProc_pclose(rsfp);
402 else if ((PerlIO*)rsfp == PerlIO_stdin())
403 PerlIO_clearerr(rsfp);
405 (void)PerlIO_close(rsfp);
411 linestart = bufptr = s + prevlen;
412 bufend = s + SvCUR(linestr);
415 if (PERLDB_LINE && curstash != debstash) {
416 SV *sv = NEWSV(85,0);
418 sv_upgrade(sv, SVt_PVMG);
419 sv_setpvn(sv,bufptr,bufend-bufptr);
420 av_store(GvAV(curcop->cop_filegv),(I32)curcop->cop_line,sv);
431 if (oldoldbufptr != last_uni)
433 while (isSPACE(*last_uni))
435 for (s = last_uni; isALNUM(*s) || *s == '-'; s++) ;
436 if ((t = strchr(s, '(')) && t < bufptr)
440 warn("Warning: Use of \"%s\" without parens is ambiguous", last_uni);
447 #define UNI(f) return uni(f,s)
455 last_uni = oldbufptr;
466 #endif /* CRIPPLED_CC */
468 #define LOP(f,x) return lop(f,x,s)
471 lop(I32 f, expectation x, char *s)
478 last_lop = oldbufptr;
494 nexttype[nexttoke] = type;
496 if (lex_state != LEX_KNOWNEXT) {
497 lex_defer = lex_state;
499 lex_state = LEX_KNOWNEXT;
504 force_word(register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
509 start = skipspace(start);
512 (allow_pack && *s == ':') ||
513 (allow_initial_tick && *s == '\'') )
515 s = scan_word(s, tokenbuf, sizeof tokenbuf, allow_pack, &len);
516 if (check_keyword && keyword(tokenbuf, len))
518 if (token == METHOD) {
528 nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(tokenbuf,0));
529 nextval[nexttoke].opval->op_private |= OPpCONST_BARE;
536 force_ident(register char *s, int kind)
539 OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
540 nextval[nexttoke].opval = o;
543 dTHR; /* just for in_eval */
544 o->op_private = OPpCONST_ENTERED;
545 /* XXX see note in pp_entereval() for why we forgo typo
546 warnings if the symbol must be introduced in an eval.
548 gv_fetchpv(s, in_eval ? (GV_ADDMULTI | 8) : TRUE,
549 kind == '$' ? SVt_PV :
550 kind == '@' ? SVt_PVAV :
551 kind == '%' ? SVt_PVHV :
559 force_version(char *s)
561 OP *version = Nullop;
565 /* default VERSION number -- GBARR */
570 for( d=s, c = 1; isDIGIT(*d) || *d == '_' || (*d == '.' && c--); d++);
571 if((*d == ';' || isSPACE(*d)) && *(skipspace(d)) != ',') {
573 /* real VERSION number -- GBARR */
574 version = yylval.opval;
578 /* NOTE: The parser sees the package name and the VERSION swapped */
579 nextval[nexttoke].opval = version;
596 s = SvPV_force(sv, len);
600 while (s < send && *s != '\\')
607 if (s + 1 < send && (s[1] == '\\'))
608 s++; /* all that, just for this */
613 SvCUR_set(sv, d - SvPVX(sv));
621 register I32 op_type = yylval.ival;
623 if (op_type == OP_NULL) {
624 yylval.opval = lex_op;
628 if (op_type == OP_CONST || op_type == OP_READLINE) {
629 SV *sv = tokeq(lex_stuff);
631 char *p = SvPV(sv, len);
632 yylval.opval = (OP*)newSVOP(op_type, 0, newSVpv(p, len));
638 sublex_info.super_state = lex_state;
639 sublex_info.sub_inwhat = op_type;
640 sublex_info.sub_op = lex_op;
641 lex_state = LEX_INTERPPUSH;
645 yylval.opval = lex_op;
659 lex_state = sublex_info.super_state;
661 SAVEI32(lex_brackets);
662 SAVEI32(lex_fakebrack);
663 SAVEI32(lex_casemods);
668 SAVEI16(curcop->cop_line);
671 SAVEPPTR(oldoldbufptr);
674 SAVEPPTR(lex_brackstack);
675 SAVEPPTR(lex_casestack);
680 bufend = bufptr = oldbufptr = oldoldbufptr = linestart = SvPVX(linestr);
681 bufend += SvCUR(linestr);
687 New(899, lex_brackstack, 120, char);
688 New(899, lex_casestack, 12, char);
689 SAVEFREEPV(lex_brackstack);
690 SAVEFREEPV(lex_casestack);
692 *lex_casestack = '\0';
694 lex_state = LEX_INTERPCONCAT;
695 curcop->cop_line = multi_start;
697 lex_inwhat = sublex_info.sub_inwhat;
698 if (lex_inwhat == OP_MATCH || lex_inwhat == OP_SUBST)
699 lex_inpat = sublex_info.sub_op;
711 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv("",0));
715 if (lex_casemods) { /* oops, we've got some unbalanced parens */
716 lex_state = LEX_INTERPCASEMOD;
720 /* Is there a right-hand side to take care of? */
721 if (lex_repl && (lex_inwhat == OP_SUBST || lex_inwhat == OP_TRANS)) {
724 bufend = bufptr = oldbufptr = oldoldbufptr = linestart = SvPVX(linestr);
725 bufend += SvCUR(linestr);
731 *lex_casestack = '\0';
733 if (SvCOMPILED(lex_repl)) {
734 lex_state = LEX_INTERPNORMAL;
738 lex_state = LEX_INTERPCONCAT;
744 bufend = SvPVX(linestr);
745 bufend += SvCUR(linestr);
754 Extracts a pattern, double-quoted string, or transliteration. This
757 It looks at lex_inwhat and lex_inpat to find out whether it's
758 processing a pattern (lex_inpat is true), a transliteration
759 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
763 double-quoted style: \r and \n
764 regexp special ones: \D \s
766 backrefs: \1 (deprecated in substitution replacements)
767 case and quoting: \U \Q \E
768 stops on @ and $, but not for $ as tail anchor
771 characters are VERY literal, except for - not at the start or end
772 of the string, which indicates a range. scan_const expands the
773 range to the full set of intermediate characters.
775 In double-quoted strings:
777 double-quoted style: \r and \n
779 backrefs: \1 (deprecated)
780 case and quoting: \U \Q \E
783 scan_const does *not* construct ops to handle interpolated strings.
784 It stops processing as soon as it finds an embedded $ or @ variable
785 and leaves it to the caller to work out what's going on.
787 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
789 $ in pattern could be $foo or could be tail anchor. Assumption:
790 it's a tail anchor if $ is the last thing in the string, or if it's
791 followed by one of ")| \n\t"
793 \1 (backreferences) are turned into $1
795 The structure of the code is
796 while (there's a character to process) {
797 handle transliteration ranges
799 skip # initiated comments in //x patterns
800 check for embedded @foo
801 check for embedded scalars
803 leave intact backslashes from leave (below)
804 deprecate \1 in strings and sub replacements
805 handle string-changing backslashes \l \U \Q \E, etc.
806 switch (what was escaped) {
807 handle - in a transliteration (becomes a literal -)
808 handle \132 octal characters
809 handle 0x15 hex characters
810 handle \cV (control V)
811 handle printf backslashes (\f, \r, \n, etc)
814 } (end while character to read)
819 scan_const(char *start)
821 register char *send = bufend; /* end of the constant */
822 SV *sv = NEWSV(93, send - start); /* sv for the constant */
823 register char *s = start; /* start of the constant */
824 register char *d = SvPVX(sv); /* destination for copies */
825 bool dorange = FALSE; /* are we in a translit range? */
829 leave is the set of acceptably-backslashed characters.
831 I do *not* understand why there's the double hook here.
835 ? "\\.^$@AGZdDwWsSbB+*?|()-nrtfeaxc0123456789[{]} \t\n\r\f\v#"
836 : (lex_inwhat & OP_TRANS)
840 while (s < send || dorange) {
841 /* get transliterations out of the way (they're most literal) */
842 if (lex_inwhat == OP_TRANS) {
843 /* expand a range A-Z to the full set of characters. AIE! */
845 I32 i; /* current expanded character */
846 I32 max; /* last character in range */
848 i = d - SvPVX(sv); /* remember current offset */
849 SvGROW(sv, SvLEN(sv) + 256); /* expand the sv -- there'll never be more'n 256 chars in a range for it to grow by */
850 d = SvPVX(sv) + i; /* restore d after the grow potentially has changed the ptr */
851 d -= 2; /* eat the first char and the - */
853 max = (U8)d[1]; /* last char in range */
855 for (i = (U8)*d; i <= max; i++)
858 /* mark the range as done, and continue */
863 /* range begins (ignore - as first or last char) */
864 else if (*s == '-' && s+1 < send && s != start) {
870 /* if we get here, we're not doing a transliteration */
872 /* skip for regexp comments /(?#comment)/ */
873 else if (*s == '(' && lex_inpat && s[1] == '?') {
875 while (s < send && *s != ')')
877 } else if (s[2] == '{') { /* This should march regcomp.c */
879 char *regparse = s + 3;
882 while (count && (c = *regparse)) {
883 if (c == '\\' && regparse[1])
891 if (*regparse == ')')
894 yyerror("Sequence (?{...}) not terminated or not {}-balanced");
895 while (s < regparse && *s != ')')
900 /* likewise skip #-initiated comments in //x patterns */
901 else if (*s == '#' && lex_inpat &&
902 ((PMOP*)lex_inpat)->op_pmflags & PMf_EXTENDED) {
903 while (s+1 < send && *s != '\n')
907 /* check for embedded arrays (@foo, @:foo, @'foo, @{foo}, @$foo) */
908 else if (*s == '@' && s[1] && (isALNUM(s[1]) || strchr(":'{$", s[1])))
911 /* check for embedded scalars. only stop if we're sure it's a
914 else if (*s == '$') {
915 if (!lex_inpat) /* not a regexp, so $ must be var */
917 if (s + 1 < send && !strchr("()| \n\t", s[1]))
918 break; /* in regexp, $ might be tail anchor */
922 if (*s == '\\' && s+1 < send) {
925 /* some backslashes we leave behind */
926 if (*s && strchr(leaveit, *s)) {
932 /* deprecate \1 in strings and substitution replacements */
933 if (lex_inwhat == OP_SUBST && !lex_inpat &&
934 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
937 warn("\\%c better written as $%c", *s, *s);
942 /* string-change backslash escapes */
943 if (lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
948 /* if we get here, it's either a quoted -, or a digit */
951 /* quoted - in transliterations */
953 if (lex_inwhat == OP_TRANS) {
958 /* default action is to copy the quoted character */
963 /* \132 indicates an octal constant */
964 case '0': case '1': case '2': case '3':
965 case '4': case '5': case '6': case '7':
966 *d++ = scan_oct(s, 3, &len);
970 /* \x24 indicates a hex constant */
972 *d++ = scan_hex(++s, 2, &len);
976 /* \c is a control character */
983 /* printf-style backslashes, formfeeds, newlines, etc */
1009 } /* end if (backslash) */
1012 } /* while loop to process each character */
1014 /* terminate the string and set up the sv */
1016 SvCUR_set(sv, d - SvPVX(sv));
1019 /* shrink the sv if we allocated more than we used */
1020 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1021 SvLEN_set(sv, SvCUR(sv) + 1);
1022 Renew(SvPVX(sv), SvLEN(sv), char);
1027 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1033 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1035 intuit_more(register char *s)
1039 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1041 if (*s != '{' && *s != '[')
1046 /* In a pattern, so maybe we have {n,m}. */
1063 /* On the other hand, maybe we have a character class */
1066 if (*s == ']' || *s == '^')
1069 int weight = 2; /* let's weigh the evidence */
1071 unsigned char un_char = 0, last_un_char;
1072 char *send = strchr(s,']');
1073 char tmpbuf[sizeof tokenbuf * 4];
1075 if (!send) /* has to be an expression */
1078 Zero(seen,256,char);
1081 else if (isDIGIT(*s)) {
1083 if (isDIGIT(s[1]) && s[2] == ']')
1089 for (; s < send; s++) {
1090 last_un_char = un_char;
1091 un_char = (unsigned char)*s;
1096 weight -= seen[un_char] * 10;
1097 if (isALNUM(s[1])) {
1098 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1099 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1104 else if (*s == '$' && s[1] &&
1105 strchr("[#!%*<>()-=",s[1])) {
1106 if (/*{*/ strchr("])} =",s[2]))
1115 if (strchr("wds]",s[1]))
1117 else if (seen['\''] || seen['"'])
1119 else if (strchr("rnftbxcav",s[1]))
1121 else if (isDIGIT(s[1])) {
1123 while (s[1] && isDIGIT(s[1]))
1133 if (strchr("aA01! ",last_un_char))
1135 if (strchr("zZ79~",s[1]))
1139 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1140 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1145 if (keyword(tmpbuf, d - tmpbuf))
1148 if (un_char == last_un_char + 1)
1150 weight -= seen[un_char];
1155 if (weight >= 0) /* probably a character class */
1163 intuit_method(char *start, GV *gv)
1165 char *s = start + (*start == '$');
1166 char tmpbuf[sizeof tokenbuf];
1174 if ((cv = GvCVu(gv))) {
1175 char *proto = SvPVX(cv);
1185 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1186 if (*start == '$') {
1187 if (gv || last_lop_op == OP_PRINT || isUPPER(*tokenbuf))
1192 return *s == '(' ? FUNCMETH : METHOD;
1194 if (!keyword(tmpbuf, len)) {
1195 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1200 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1201 if (indirgv && GvCVu(indirgv))
1203 /* filehandle or package name makes it a method */
1204 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1206 if ((bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1207 return 0; /* no assumptions -- "=>" quotes bearword */
1209 nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1211 nextval[nexttoke].opval->op_private = OPpCONST_BARE;
1215 return *s == '(' ? FUNCMETH : METHOD;
1225 char *pdb = PerlEnv_getenv("PERL5DB");
1229 SETERRNO(0,SS$_NORMAL);
1230 return "BEGIN { require 'perl5db.pl' }";
1236 /* Encoded script support. filter_add() effectively inserts a
1237 * 'pre-processing' function into the current source input stream.
1238 * Note that the filter function only applies to the current source file
1239 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1241 * The datasv parameter (which may be NULL) can be used to pass
1242 * private data to this instance of the filter. The filter function
1243 * can recover the SV using the FILTER_DATA macro and use it to
1244 * store private buffers and state information.
1246 * The supplied datasv parameter is upgraded to a PVIO type
1247 * and the IoDIRP field is used to store the function pointer.
1248 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1249 * private use must be set using malloc'd pointers.
1251 static int filter_debug = 0;
1254 filter_add(filter_t funcp, SV *datasv)
1256 if (!funcp){ /* temporary handy debugging hack to be deleted */
1257 filter_debug = atoi((char*)datasv);
1261 rsfp_filters = newAV();
1263 datasv = NEWSV(255,0);
1264 if (!SvUPGRADE(datasv, SVt_PVIO))
1265 die("Can't upgrade filter_add data to SVt_PVIO");
1266 IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
1268 warn("filter_add func %p (%s)", funcp, SvPV(datasv,na));
1269 av_unshift(rsfp_filters, 1);
1270 av_store(rsfp_filters, 0, datasv) ;
1275 /* Delete most recently added instance of this filter function. */
1277 filter_del(filter_t funcp)
1280 warn("filter_del func %p", funcp);
1281 if (!rsfp_filters || AvFILLp(rsfp_filters)<0)
1283 /* if filter is on top of stack (usual case) just pop it off */
1284 if (IoDIRP(FILTER_DATA(AvFILLp(rsfp_filters))) == (void*)funcp){
1285 sv_free(av_pop(rsfp_filters));
1289 /* we need to search for the correct entry and clear it */
1290 die("filter_del can only delete in reverse order (currently)");
1294 /* Invoke the n'th filter function for the current rsfp. */
1296 filter_read(int idx, SV *buf_sv, int maxlen)
1299 /* 0 = read one text line */
1306 if (idx > AvFILLp(rsfp_filters)){ /* Any more filters? */
1307 /* Provide a default input filter to make life easy. */
1308 /* Note that we append to the line. This is handy. */
1310 warn("filter_read %d: from rsfp\n", idx);
1314 int old_len = SvCUR(buf_sv) ;
1316 /* ensure buf_sv is large enough */
1317 SvGROW(buf_sv, old_len + maxlen) ;
1318 if ((len = PerlIO_read(rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1319 if (PerlIO_error(rsfp))
1320 return -1; /* error */
1322 return 0 ; /* end of file */
1324 SvCUR_set(buf_sv, old_len + len) ;
1327 if (sv_gets(buf_sv, rsfp, SvCUR(buf_sv)) == NULL) {
1328 if (PerlIO_error(rsfp))
1329 return -1; /* error */
1331 return 0 ; /* end of file */
1334 return SvCUR(buf_sv);
1336 /* Skip this filter slot if filter has been deleted */
1337 if ( (datasv = FILTER_DATA(idx)) == &sv_undef){
1339 warn("filter_read %d: skipped (filter deleted)\n", idx);
1340 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1342 /* Get function pointer hidden within datasv */
1343 funcp = (filter_t)IoDIRP(datasv);
1345 warn("filter_read %d: via function %p (%s)\n",
1346 idx, funcp, SvPV(datasv,na));
1347 /* Call function. The function is expected to */
1348 /* call "FILTER_READ(idx+1, buf_sv)" first. */
1349 /* Return: <0:error, =0:eof, >0:not eof */
1350 return (*funcp)(idx, buf_sv, maxlen);
1354 filter_gets(register SV *sv, register PerlIO *fp, STRLEN append)
1357 if (!rsfp_filters) {
1358 filter_add(win32_textfilter,NULL);
1364 SvCUR_set(sv, 0); /* start with empty line */
1365 if (FILTER_READ(0, sv, 0) > 0)
1366 return ( SvPVX(sv) ) ;
1371 return (sv_gets(sv, fp, append));
1376 static char* exp_name[] =
1377 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "TERMBLOCK" };
1380 EXT int yychar; /* last token */
1385 Works out what to call the token just pulled out of the input
1386 stream. The yacc parser takes care of taking the ops we return and
1387 stitching them into a tree.
1393 if read an identifier
1394 if we're in a my declaration
1395 croak if they tried to say my($foo::bar)
1396 build the ops for a my() declaration
1397 if it's an access to a my() variable
1398 are we in a sort block?
1399 croak if my($a); $a <=> $b
1400 build ops for access to a my() variable
1401 if in a dq string, and they've said @foo and we can't find @foo
1403 build ops for a bareword
1404 if we already built the token before, use it.
1418 /* check if there's an identifier for us to look at */
1419 if (pending_ident) {
1420 /* pit holds the identifier we read and pending_ident is reset */
1421 char pit = pending_ident;
1424 /* if we're in a my(), we can't allow dynamics here.
1425 $foo'bar has already been turned into $foo::bar, so
1426 just check for colons.
1428 if it's a legal name, the OP is a PADANY.
1431 if (strchr(tokenbuf,':'))
1432 croak(no_myglob,tokenbuf);
1434 yylval.opval = newOP(OP_PADANY, 0);
1435 yylval.opval->op_targ = pad_allocmy(tokenbuf);
1440 build the ops for accesses to a my() variable.
1442 Deny my($a) or my($b) in a sort block, *if* $a or $b is
1443 then used in a comparison. This catches most, but not
1444 all cases. For instance, it catches
1445 sort { my($a); $a <=> $b }
1447 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
1448 (although why you'd do that is anyone's guess).
1451 if (!strchr(tokenbuf,':')) {
1453 /* Check for single character per-thread SVs */
1454 if (tokenbuf[0] == '$' && tokenbuf[2] == '\0'
1455 && !isALPHA(tokenbuf[1]) /* Rule out obvious non-threadsvs */
1456 && (tmp = find_threadsv(&tokenbuf[1])) != NOT_IN_PAD)
1458 yylval.opval = newOP(OP_THREADSV, 0);
1459 yylval.opval->op_targ = tmp;
1462 #endif /* USE_THREADS */
1463 if ((tmp = pad_findmy(tokenbuf)) != NOT_IN_PAD) {
1464 /* if it's a sort block and they're naming $a or $b */
1465 if (last_lop_op == OP_SORT &&
1466 tokenbuf[0] == '$' &&
1467 (tokenbuf[1] == 'a' || tokenbuf[1] == 'b')
1470 for (d = in_eval ? oldoldbufptr : linestart;
1471 d < bufend && *d != '\n';
1474 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
1475 croak("Can't use \"my %s\" in sort comparison",
1481 yylval.opval = newOP(OP_PADANY, 0);
1482 yylval.opval->op_targ = tmp;
1488 Whine if they've said @foo in a doublequoted string,
1489 and @foo isn't a variable we can find in the symbol
1492 if (pit == '@' && lex_state != LEX_NORMAL && !lex_brackets) {
1493 GV *gv = gv_fetchpv(tokenbuf+1, FALSE, SVt_PVAV);
1494 if (!gv || ((tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
1495 yyerror(form("In string, %s now must be written as \\%s",
1496 tokenbuf, tokenbuf));
1499 /* build ops for a bareword */
1500 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(tokenbuf+1, 0));
1501 yylval.opval->op_private = OPpCONST_ENTERED;
1502 gv_fetchpv(tokenbuf+1, in_eval ? (GV_ADDMULTI | 8) : TRUE,
1503 ((tokenbuf[0] == '$') ? SVt_PV
1504 : (tokenbuf[0] == '@') ? SVt_PVAV
1509 /* no identifier pending identification */
1511 switch (lex_state) {
1513 case LEX_NORMAL: /* Some compilers will produce faster */
1514 case LEX_INTERPNORMAL: /* code if we comment these out. */
1518 /* when we're already built the next token, just pull it out the queue */
1521 yylval = nextval[nexttoke];
1523 lex_state = lex_defer;
1524 expect = lex_expect;
1525 lex_defer = LEX_NORMAL;
1527 return(nexttype[nexttoke]);
1529 /* interpolated case modifiers like \L \U, including \Q and \E.
1530 when we get here, bufptr is at the \
1532 case LEX_INTERPCASEMOD:
1534 if (bufptr != bufend && *bufptr != '\\')
1535 croak("panic: INTERPCASEMOD");
1537 /* handle \E or end of string */
1538 if (bufptr == bufend || bufptr[1] == 'E') {
1543 oldmod = lex_casestack[--lex_casemods];
1544 lex_casestack[lex_casemods] = '\0';
1546 if (bufptr != bufend && strchr("LUQ", oldmod)) {
1548 lex_state = LEX_INTERPCONCAT;
1552 if (bufptr != bufend)
1554 lex_state = LEX_INTERPCONCAT;
1559 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
1560 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
1561 if (strchr("LU", *s) &&
1562 (strchr(lex_casestack, 'L') || strchr(lex_casestack, 'U')))
1564 lex_casestack[--lex_casemods] = '\0';
1567 if (lex_casemods > 10) {
1568 char* newlb = Renew(lex_casestack, lex_casemods + 2, char);
1569 if (newlb != lex_casestack) {
1571 lex_casestack = newlb;
1574 lex_casestack[lex_casemods++] = *s;
1575 lex_casestack[lex_casemods] = '\0';
1576 lex_state = LEX_INTERPCONCAT;
1577 nextval[nexttoke].ival = 0;
1580 nextval[nexttoke].ival = OP_LCFIRST;
1582 nextval[nexttoke].ival = OP_UCFIRST;
1584 nextval[nexttoke].ival = OP_LC;
1586 nextval[nexttoke].ival = OP_UC;
1588 nextval[nexttoke].ival = OP_QUOTEMETA;
1590 croak("panic: yylex");
1602 case LEX_INTERPPUSH:
1603 return sublex_push();
1605 case LEX_INTERPSTART:
1606 if (bufptr == bufend)
1607 return sublex_done();
1609 lex_dojoin = (*bufptr == '@');
1610 lex_state = LEX_INTERPNORMAL;
1612 nextval[nexttoke].ival = 0;
1615 nextval[nexttoke].opval = newOP(OP_THREADSV, 0);
1616 nextval[nexttoke].opval->op_targ = find_threadsv("\"");
1617 force_next(PRIVATEREF);
1619 force_ident("\"", '$');
1620 #endif /* USE_THREADS */
1621 nextval[nexttoke].ival = 0;
1623 nextval[nexttoke].ival = 0;
1625 nextval[nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
1634 case LEX_INTERPENDMAYBE:
1635 if (intuit_more(bufptr)) {
1636 lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
1644 lex_state = LEX_INTERPCONCAT;
1648 case LEX_INTERPCONCAT:
1651 croak("panic: INTERPCONCAT");
1653 if (bufptr == bufend)
1654 return sublex_done();
1656 if (SvIVX(linestr) == '\'') {
1657 SV *sv = newSVsv(linestr);
1660 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1664 s = scan_const(bufptr);
1666 lex_state = LEX_INTERPCASEMOD;
1668 lex_state = LEX_INTERPSTART;
1672 nextval[nexttoke] = yylval;
1685 lex_state = LEX_NORMAL;
1686 s = scan_formline(bufptr);
1693 oldoldbufptr = oldbufptr;
1696 PerlIO_printf(PerlIO_stderr(), "### Tokener expecting %s at %s\n", exp_name[expect], s);
1702 croak("Unrecognized character \\%03o", *s & 255);
1705 goto fake_eof; /* emulate EOF on ^D or ^Z */
1711 yyerror("Missing right bracket");
1715 goto retry; /* ignore stray nulls */
1718 if (!in_eval && !preambled) {
1720 sv_setpv(linestr,incl_perldb());
1722 sv_catpv(linestr,";");
1724 while(AvFILLp(preambleav) >= 0) {
1725 SV *tmpsv = av_shift(preambleav);
1726 sv_catsv(linestr, tmpsv);
1727 sv_catpv(linestr, ";");
1730 sv_free((SV*)preambleav);
1733 if (minus_n || minus_p) {
1734 sv_catpv(linestr, "LINE: while (<>) {");
1736 sv_catpv(linestr,"chomp;");
1738 GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
1740 GvIMPORTED_AV_on(gv);
1742 if (strchr("/'\"", *splitstr)
1743 && strchr(splitstr + 1, *splitstr))
1744 sv_catpvf(linestr, "@F=split(%s);", splitstr);
1747 s = "'~#\200\1'"; /* surely one char is unused...*/
1748 while (s[1] && strchr(splitstr, *s)) s++;
1750 sv_catpvf(linestr, "@F=split(%s%c",
1751 "q" + (delim == '\''), delim);
1752 for (s = splitstr; *s; s++) {
1754 sv_catpvn(linestr, "\\", 1);
1755 sv_catpvn(linestr, s, 1);
1757 sv_catpvf(linestr, "%c);", delim);
1761 sv_catpv(linestr,"@F=split(' ');");
1764 sv_catpv(linestr, "\n");
1765 oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr);
1766 bufend = SvPVX(linestr) + SvCUR(linestr);
1767 if (PERLDB_LINE && curstash != debstash) {
1768 SV *sv = NEWSV(85,0);
1770 sv_upgrade(sv, SVt_PVMG);
1771 sv_setsv(sv,linestr);
1772 av_store(GvAV(curcop->cop_filegv),(I32)curcop->cop_line,sv);
1777 if ((s = filter_gets(linestr, rsfp, 0)) == Nullch) {
1780 if (preprocess && !in_eval)
1781 (void)PerlProc_pclose(rsfp);
1782 else if ((PerlIO *)rsfp == PerlIO_stdin())
1783 PerlIO_clearerr(rsfp);
1785 (void)PerlIO_close(rsfp);
1790 if (!in_eval && (minus_n || minus_p)) {
1791 sv_setpv(linestr,minus_p ? ";}continue{print" : "");
1792 sv_catpv(linestr,";}");
1793 oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr);
1794 bufend = SvPVX(linestr) + SvCUR(linestr);
1795 minus_n = minus_p = 0;
1798 oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr);
1799 sv_setpv(linestr,"");
1800 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
1803 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
1806 /* Incest with pod. */
1807 if (*s == '=' && strnEQ(s, "=cut", 4)) {
1808 sv_setpv(linestr, "");
1809 oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr);
1810 bufend = SvPVX(linestr) + SvCUR(linestr);
1815 } while (doextract);
1816 oldoldbufptr = oldbufptr = bufptr = linestart = s;
1817 if (PERLDB_LINE && curstash != debstash) {
1818 SV *sv = NEWSV(85,0);
1820 sv_upgrade(sv, SVt_PVMG);
1821 sv_setsv(sv,linestr);
1822 av_store(GvAV(curcop->cop_filegv),(I32)curcop->cop_line,sv);
1824 bufend = SvPVX(linestr) + SvCUR(linestr);
1825 if (curcop->cop_line == 1) {
1826 while (s < bufend && isSPACE(*s))
1828 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
1832 if (*s == '#' && *(s+1) == '!')
1834 #ifdef ALTERNATE_SHEBANG
1836 static char as[] = ALTERNATE_SHEBANG;
1837 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
1838 d = s + (sizeof(as) - 1);
1840 #endif /* ALTERNATE_SHEBANG */
1849 while (*d && !isSPACE(*d))
1853 #ifdef ARG_ZERO_IS_SCRIPT
1854 if (ipathend > ipath) {
1856 * HP-UX (at least) sets argv[0] to the script name,
1857 * which makes $^X incorrect. And Digital UNIX and Linux,
1858 * at least, set argv[0] to the basename of the Perl
1859 * interpreter. So, having found "#!", we'll set it right.
1861 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
1862 assert(SvPOK(x) || SvGMAGICAL(x));
1863 if (sv_eq(x, GvSV(curcop->cop_filegv))) {
1864 sv_setpvn(x, ipath, ipathend - ipath);
1867 TAINT_NOT; /* $^X is always tainted, but that's OK */
1869 #endif /* ARG_ZERO_IS_SCRIPT */
1874 d = instr(s,"perl -");
1876 d = instr(s,"perl");
1877 #ifdef ALTERNATE_SHEBANG
1879 * If the ALTERNATE_SHEBANG on this system starts with a
1880 * character that can be part of a Perl expression, then if
1881 * we see it but not "perl", we're probably looking at the
1882 * start of Perl code, not a request to hand off to some
1883 * other interpreter. Similarly, if "perl" is there, but
1884 * not in the first 'word' of the line, we assume the line
1885 * contains the start of the Perl program.
1887 if (d && *s != '#') {
1889 while (*c && !strchr("; \t\r\n\f\v#", *c))
1892 d = Nullch; /* "perl" not in first word; ignore */
1894 *s = '#'; /* Don't try to parse shebang line */
1896 #endif /* ALTERNATE_SHEBANG */
1901 !instr(s,"indir") &&
1902 instr(origargv[0],"perl"))
1908 while (s < bufend && isSPACE(*s))
1911 Newz(899,newargv,origargc+3,char*);
1913 while (s < bufend && !isSPACE(*s))
1916 Copy(origargv+1, newargv+2, origargc+1, char*);
1921 execv(ipath, newargv);
1922 croak("Can't exec %s", ipath);
1925 U32 oldpdb = perldb;
1926 bool oldn = minus_n;
1927 bool oldp = minus_p;
1929 while (*d && !isSPACE(*d)) d++;
1930 while (*d == ' ' || *d == '\t') d++;
1934 if (*d == 'M' || *d == 'm') {
1936 while (*d && !isSPACE(*d)) d++;
1937 croak("Too late for \"-%.*s\" option",
1940 d = moreswitches(d);
1942 if (PERLDB_LINE && !oldpdb ||
1943 ( minus_n || minus_p ) && !(oldn || oldp) )
1944 /* if we have already added "LINE: while (<>) {",
1945 we must not do it again */
1947 sv_setpv(linestr, "");
1948 oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr);
1949 bufend = SvPVX(linestr) + SvCUR(linestr);
1952 (void)gv_fetchfile(origfilename);
1959 if (lex_formbrack && lex_brackets <= lex_formbrack) {
1961 lex_state = LEX_FORMLINE;
1967 warn("Illegal character \\%03o (carriage return)", '\r');
1969 "(Maybe you didn't strip carriage returns after a network transfer?)\n");
1971 case ' ': case '\t': case '\f': case 013:
1976 if (lex_state != LEX_NORMAL || (in_eval && !rsfp)) {
1978 while (s < d && *s != '\n')
1983 if (lex_formbrack && lex_brackets <= lex_formbrack) {
1985 lex_state = LEX_FORMLINE;
1995 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2000 while (s < bufend && (*s == ' ' || *s == '\t'))
2003 if (strnEQ(s,"=>",2)) {
2004 s = force_word(bufptr,WORD,FALSE,FALSE,FALSE);
2005 OPERATOR('-'); /* unary minus */
2007 last_uni = oldbufptr;
2008 last_lop_op = OP_FTEREAD; /* good enough */
2010 case 'r': FTST(OP_FTEREAD);
2011 case 'w': FTST(OP_FTEWRITE);
2012 case 'x': FTST(OP_FTEEXEC);
2013 case 'o': FTST(OP_FTEOWNED);
2014 case 'R': FTST(OP_FTRREAD);
2015 case 'W': FTST(OP_FTRWRITE);
2016 case 'X': FTST(OP_FTREXEC);
2017 case 'O': FTST(OP_FTROWNED);
2018 case 'e': FTST(OP_FTIS);
2019 case 'z': FTST(OP_FTZERO);
2020 case 's': FTST(OP_FTSIZE);
2021 case 'f': FTST(OP_FTFILE);
2022 case 'd': FTST(OP_FTDIR);
2023 case 'l': FTST(OP_FTLINK);
2024 case 'p': FTST(OP_FTPIPE);
2025 case 'S': FTST(OP_FTSOCK);
2026 case 'u': FTST(OP_FTSUID);
2027 case 'g': FTST(OP_FTSGID);
2028 case 'k': FTST(OP_FTSVTX);
2029 case 'b': FTST(OP_FTBLK);
2030 case 'c': FTST(OP_FTCHR);
2031 case 't': FTST(OP_FTTTY);
2032 case 'T': FTST(OP_FTTEXT);
2033 case 'B': FTST(OP_FTBINARY);
2034 case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2035 case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2036 case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
2038 croak("Unrecognized file test: -%c", (int)tmp);
2045 if (expect == XOPERATOR)
2050 else if (*s == '>') {
2053 if (isIDFIRST(*s)) {
2054 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2062 if (expect == XOPERATOR)
2065 if (isSPACE(*s) || !isSPACE(*bufptr))
2067 OPERATOR('-'); /* unary minus */
2074 if (expect == XOPERATOR)
2079 if (expect == XOPERATOR)
2082 if (isSPACE(*s) || !isSPACE(*bufptr))
2088 if (expect != XOPERATOR) {
2089 s = scan_ident(s, bufend, tokenbuf, sizeof tokenbuf, TRUE);
2091 force_ident(tokenbuf, '*');
2104 if (expect == XOPERATOR) {
2109 s = scan_ident(s, bufend, tokenbuf + 1, sizeof tokenbuf - 1, TRUE);
2112 yyerror("Final % should be \\% or %name");
2115 pending_ident = '%';
2137 if (last_lop == oldoldbufptr || last_uni == oldoldbufptr)
2138 oldbufptr = oldoldbufptr; /* allow print(STDOUT 123) */
2143 if (curcop->cop_line < copline)
2144 copline = curcop->cop_line;
2155 if (lex_brackets <= 0)
2156 yyerror("Unmatched right bracket");
2159 if (lex_state == LEX_INTERPNORMAL) {
2160 if (lex_brackets == 0) {
2161 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
2162 lex_state = LEX_INTERPEND;
2169 if (lex_brackets > 100) {
2170 char* newlb = Renew(lex_brackstack, lex_brackets + 1, char);
2171 if (newlb != lex_brackstack) {
2173 lex_brackstack = newlb;
2178 if (lex_formbrack) {
2182 if (oldoldbufptr == last_lop)
2183 lex_brackstack[lex_brackets++] = XTERM;
2185 lex_brackstack[lex_brackets++] = XOPERATOR;
2186 OPERATOR(HASHBRACK);
2188 while (s < bufend && (*s == ' ' || *s == '\t'))
2192 if (d < bufend && *d == '-') {
2195 while (d < bufend && (*d == ' ' || *d == '\t'))
2198 if (d < bufend && isIDFIRST(*d)) {
2199 d = scan_word(d, tokenbuf + 1, sizeof tokenbuf - 1,
2201 while (d < bufend && (*d == ' ' || *d == '\t'))
2204 char minus = (tokenbuf[0] == '-');
2205 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2212 lex_brackstack[lex_brackets++] = XSTATE;
2216 lex_brackstack[lex_brackets++] = XOPERATOR;
2221 if (oldoldbufptr == last_lop)
2222 lex_brackstack[lex_brackets++] = XTERM;
2224 lex_brackstack[lex_brackets++] = XOPERATOR;
2227 if (expect == XSTATE) {
2228 lex_brackstack[lex_brackets-1] = XSTATE;
2231 OPERATOR(HASHBRACK);
2233 /* This hack serves to disambiguate a pair of curlies
2234 * as being a block or an anon hash. Normally, expectation
2235 * determines that, but in cases where we're not in a
2236 * position to expect anything in particular (like inside
2237 * eval"") we have to resolve the ambiguity. This code
2238 * covers the case where the first term in the curlies is a
2239 * quoted string. Most other cases need to be explicitly
2240 * disambiguated by prepending a `+' before the opening
2241 * curly in order to force resolution as an anon hash.
2243 * XXX should probably propagate the outer expectation
2244 * into eval"" to rely less on this hack, but that could
2245 * potentially break current behavior of eval"".
2249 if (*s == '\'' || *s == '"' || *s == '`') {
2250 /* common case: get past first string, handling escapes */
2251 for (t++; t < bufend && *t != *s;)
2252 if (*t++ == '\\' && (*t == '\\' || *t == *s))
2256 else if (*s == 'q') {
2259 || ((*t == 'q' || *t == 'x') && ++t < bufend
2260 && !isALNUM(*t)))) {
2262 char open, close, term;
2265 while (t < bufend && isSPACE(*t))
2269 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
2273 for (t++; t < bufend; t++) {
2274 if (*t == '\\' && t+1 < bufend && open != '\\')
2276 else if (*t == open)
2280 for (t++; t < bufend; t++) {
2281 if (*t == '\\' && t+1 < bufend)
2283 else if (*t == close && --brackets <= 0)
2285 else if (*t == open)
2291 else if (isALPHA(*s)) {
2292 for (t++; t < bufend && isALNUM(*t); t++) ;
2294 while (t < bufend && isSPACE(*t))
2296 /* if comma follows first term, call it an anon hash */
2297 /* XXX it could be a comma expression with loop modifiers */
2298 if (t < bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
2299 || (*t == '=' && t[1] == '>')))
2300 OPERATOR(HASHBRACK);
2304 lex_brackstack[lex_brackets-1] = XSTATE;
2310 yylval.ival = curcop->cop_line;
2311 if (isSPACE(*s) || *s == '#')
2312 copline = NOLINE; /* invalidate current command line number */
2317 if (lex_brackets <= 0)
2318 yyerror("Unmatched right bracket");
2320 expect = (expectation)lex_brackstack[--lex_brackets];
2321 if (lex_brackets < lex_formbrack)
2323 if (lex_state == LEX_INTERPNORMAL) {
2324 if (lex_brackets == 0) {
2325 if (lex_fakebrack) {
2326 lex_state = LEX_INTERPEND;
2328 return yylex(); /* ignore fake brackets */
2330 if (*s == '-' && s[1] == '>')
2331 lex_state = LEX_INTERPENDMAYBE;
2332 else if (*s != '[' && *s != '{')
2333 lex_state = LEX_INTERPEND;
2336 if (lex_brackets < lex_fakebrack) {
2339 return yylex(); /* ignore fake brackets */
2349 if (expect == XOPERATOR) {
2350 if (dowarn && isALPHA(*s) && bufptr == linestart) {
2358 s = scan_ident(s - 1, bufend, tokenbuf, sizeof tokenbuf, TRUE);
2361 force_ident(tokenbuf, '&');
2365 yylval.ival = (OPpENTERSUB_AMPER<<8);
2384 if (dowarn && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
2385 warn("Reversed %c= operator",(int)tmp);
2387 if (expect == XSTATE && isALPHA(tmp) &&
2388 (s == linestart+1 || s[-2] == '\n') )
2390 if (in_eval && !rsfp) {
2395 if (strnEQ(s,"=cut",4)) {
2412 if (lex_brackets < lex_formbrack) {
2414 for (t = s; *t == ' ' || *t == '\t'; t++) ;
2415 if (*t == '\n' || *t == '#') {
2433 if (expect != XOPERATOR) {
2434 if (s[1] != '<' && !strchr(s,'>'))
2437 s = scan_heredoc(s);
2439 s = scan_inputsymbol(s);
2440 TERM(sublex_start());
2445 SHop(OP_LEFT_SHIFT);
2459 SHop(OP_RIGHT_SHIFT);
2468 if (expect == XOPERATOR) {
2469 if (lex_formbrack && lex_brackets == lex_formbrack) {
2472 return ','; /* grandfather non-comma-format format */
2476 if (s[1] == '#' && (isALPHA(s[2]) || strchr("_{$:", s[2]))) {
2477 if (expect == XOPERATOR)
2478 no_op("Array length", bufptr);
2480 s = scan_ident(s + 1, bufend, tokenbuf + 1, sizeof tokenbuf - 1,
2485 pending_ident = '#';
2489 if (expect == XOPERATOR)
2490 no_op("Scalar", bufptr);
2492 s = scan_ident(s, bufend, tokenbuf + 1, sizeof tokenbuf - 1, FALSE);
2495 yyerror("Final $ should be \\$ or $name");
2499 /* This kludge not intended to be bulletproof. */
2500 if (tokenbuf[1] == '[' && !tokenbuf[2]) {
2501 yylval.opval = newSVOP(OP_CONST, 0,
2502 newSViv((IV)compiling.cop_arybase));
2503 yylval.opval->op_private = OPpCONST_ARYBASE;
2508 if (lex_state == LEX_NORMAL)
2511 if ((expect != XREF || oldoldbufptr == last_lop) && intuit_more(s)) {
2517 isSPACE(*t) || isALNUM(*t) || *t == '$';
2520 bufptr = skipspace(bufptr);
2521 while (t < bufend && *t != ']')
2523 warn("Multidimensional syntax %.*s not supported",
2524 (t - bufptr) + 1, bufptr);
2528 else if (*s == '{') {
2530 if (dowarn && strEQ(tokenbuf+1, "SIG") &&
2531 (t = strchr(s, '}')) && (t = strchr(t, '=')))
2533 char tmpbuf[sizeof tokenbuf];
2535 for (t++; isSPACE(*t); t++) ;
2536 if (isIDFIRST(*t)) {
2537 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
2538 if (*t != '(' && perl_get_cv(tmpbuf, FALSE))
2539 warn("You need to quote \"%s\"", tmpbuf);
2546 if (lex_state == LEX_NORMAL && isSPACE(*d)) {
2547 bool islop = (last_lop == oldoldbufptr);
2548 if (!islop || last_lop_op == OP_GREPSTART)
2550 else if (strchr("$@\"'`q", *s))
2551 expect = XTERM; /* e.g. print $fh "foo" */
2552 else if (strchr("&*<%", *s) && isIDFIRST(s[1]))
2553 expect = XTERM; /* e.g. print $fh &sub */
2554 else if (isIDFIRST(*s)) {
2555 char tmpbuf[sizeof tokenbuf];
2556 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2557 if (tmp = keyword(tmpbuf, len)) {
2558 /* binary operators exclude handle interpretations */
2570 expect = XTERM; /* e.g. print $fh length() */
2575 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
2576 if (gv && GvCVu(gv))
2577 expect = XTERM; /* e.g. print $fh subr() */
2580 else if (isDIGIT(*s))
2581 expect = XTERM; /* e.g. print $fh 3 */
2582 else if (*s == '.' && isDIGIT(s[1]))
2583 expect = XTERM; /* e.g. print $fh .3 */
2584 else if (strchr("/?-+", *s) && !isSPACE(s[1]))
2585 expect = XTERM; /* e.g. print $fh -1 */
2586 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]))
2587 expect = XTERM; /* print $fh <<"EOF" */
2589 pending_ident = '$';
2593 if (expect == XOPERATOR)
2596 s = scan_ident(s, bufend, tokenbuf + 1, sizeof tokenbuf - 1, FALSE);
2599 yyerror("Final @ should be \\@ or @name");
2602 if (lex_state == LEX_NORMAL)
2604 if ((expect != XREF || oldoldbufptr == last_lop) && intuit_more(s)) {
2608 /* Warn about @ where they meant $. */
2610 if (*s == '[' || *s == '{') {
2612 while (*t && (isALNUM(*t) || strchr(" \t$#+-'\"", *t)))
2614 if (*t == '}' || *t == ']') {
2616 bufptr = skipspace(bufptr);
2617 warn("Scalar value %.*s better written as $%.*s",
2618 t-bufptr, bufptr, t-bufptr-1, bufptr+1);
2623 pending_ident = '@';
2626 case '/': /* may either be division or pattern */
2627 case '?': /* may either be conditional or pattern */
2628 if (expect != XOPERATOR) {
2629 /* Disable warning on "study /blah/" */
2630 if (oldoldbufptr == last_uni
2631 && (*last_uni != 's' || s - last_uni < 5
2632 || memNE(last_uni, "study", 5) || isALNUM(last_uni[5])))
2635 TERM(sublex_start());
2643 if (lex_formbrack && lex_brackets == lex_formbrack && s[1] == '\n' &&
2644 (s == linestart || s[-1] == '\n') ) {
2649 if (expect == XOPERATOR || !isDIGIT(s[1])) {
2655 yylval.ival = OPf_SPECIAL;
2661 if (expect != XOPERATOR)
2666 case '0': case '1': case '2': case '3': case '4':
2667 case '5': case '6': case '7': case '8': case '9':
2669 if (expect == XOPERATOR)
2675 if (expect == XOPERATOR) {
2676 if (lex_formbrack && lex_brackets == lex_formbrack) {
2679 return ','; /* grandfather non-comma-format format */
2685 missingterm((char*)0);
2686 yylval.ival = OP_CONST;
2687 TERM(sublex_start());
2691 if (expect == XOPERATOR) {
2692 if (lex_formbrack && lex_brackets == lex_formbrack) {
2695 return ','; /* grandfather non-comma-format format */
2701 missingterm((char*)0);
2702 yylval.ival = OP_CONST;
2703 for (d = SvPV(lex_stuff, len); len; len--, d++) {
2704 if (*d == '$' || *d == '@' || *d == '\\') {
2705 yylval.ival = OP_STRINGIFY;
2709 TERM(sublex_start());
2713 if (expect == XOPERATOR)
2714 no_op("Backticks",s);
2716 missingterm((char*)0);
2717 yylval.ival = OP_BACKTICK;
2719 TERM(sublex_start());
2723 if (dowarn && lex_inwhat && isDIGIT(*s))
2724 warn("Can't use \\%c to mean $%c in expression", *s, *s);
2725 if (expect == XOPERATOR)
2726 no_op("Backslash",s);
2730 if (isDIGIT(s[1]) && expect == XOPERATOR) {
2769 s = scan_word(s, tokenbuf, sizeof tokenbuf, FALSE, &len);
2771 /* Some keywords can be followed by any delimiter, including ':' */
2772 tmp = (len == 1 && strchr("msyq", tokenbuf[0]) ||
2773 len == 2 && ((tokenbuf[0] == 't' && tokenbuf[1] == 'r') ||
2774 (tokenbuf[0] == 'q' &&
2775 strchr("qwx", tokenbuf[1]))));
2777 /* x::* is just a word, unless x is "CORE" */
2778 if (!tmp && *s == ':' && s[1] == ':' && strNE(tokenbuf, "CORE"))
2782 while (d < bufend && isSPACE(*d))
2783 d++; /* no comments skipped here, or s### is misparsed */
2785 /* Is this a label? */
2786 if (!tmp && expect == XSTATE
2787 && d < bufend && *d == ':' && *(d + 1) != ':') {
2789 yylval.pval = savepv(tokenbuf);
2794 /* Check for keywords */
2795 tmp = keyword(tokenbuf, len);
2797 /* Is this a word before a => operator? */
2798 if (strnEQ(d,"=>",2)) {
2800 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(tokenbuf,0));
2801 yylval.opval->op_private = OPpCONST_BARE;
2805 if (tmp < 0) { /* second-class keyword? */
2806 if (expect != XOPERATOR && (*s != ':' || s[1] != ':') &&
2807 (((gv = gv_fetchpv(tokenbuf, FALSE, SVt_PVCV)) &&
2808 GvCVu(gv) && GvIMPORTED_CV(gv)) ||
2809 ((gvp = (GV**)hv_fetch(globalstash,tokenbuf,len,FALSE)) &&
2810 (gv = *gvp) != (GV*)&sv_undef &&
2811 GvCVu(gv) && GvIMPORTED_CV(gv))))
2813 tmp = 0; /* overridden by importation */
2816 && -tmp==KEY_lock /* XXX generalizable kludge */
2817 && !hv_fetch(GvHVn(incgv), "Thread.pm", 9, FALSE))
2819 tmp = 0; /* any sub overrides "weak" keyword */
2822 tmp = -tmp; gv = Nullgv; gvp = 0;
2829 default: /* not a keyword */
2832 char lastchar = (bufptr == oldoldbufptr ? 0 : bufptr[-1]);
2834 /* Get the rest if it looks like a package qualifier */
2836 if (*s == '\'' || *s == ':' && s[1] == ':') {
2838 s = scan_word(s, tokenbuf + len, sizeof tokenbuf - len,
2841 croak("Bad name after %s::", tokenbuf);
2845 if (expect == XOPERATOR) {
2846 if (bufptr == linestart) {
2852 no_op("Bareword",s);
2855 /* Look for a subroutine with this name in current package,
2856 unless name is "Foo::", in which case Foo is a bearword
2857 (and a package name). */
2860 tokenbuf[len - 2] == ':' && tokenbuf[len - 1] == ':')
2862 if (dowarn && ! gv_fetchpv(tokenbuf, FALSE, SVt_PVHV))
2863 warn("Bareword \"%s\" refers to nonexistent package",
2866 tokenbuf[len] = '\0';
2873 gv = gv_fetchpv(tokenbuf, FALSE, SVt_PVCV);
2876 /* if we saw a global override before, get the right name */
2879 sv = newSVpv("CORE::GLOBAL::",14);
2880 sv_catpv(sv,tokenbuf);
2883 sv = newSVpv(tokenbuf,0);
2885 /* Presume this is going to be a bareword of some sort. */
2888 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2889 yylval.opval->op_private = OPpCONST_BARE;
2891 /* And if "Foo::", then that's what it certainly is. */
2896 /* See if it's the indirect object for a list operator. */
2899 oldoldbufptr < bufptr &&
2900 (oldoldbufptr == last_lop || oldoldbufptr == last_uni) &&
2901 /* NO SKIPSPACE BEFORE HERE! */
2903 ((opargs[last_lop_op] >> OASHIFT)& 7) == OA_FILEREF) )
2905 bool immediate_paren = *s == '(';
2907 /* (Now we can afford to cross potential line boundary.) */
2910 /* Two barewords in a row may indicate method call. */
2912 if ((isALPHA(*s) || *s == '$') && (tmp=intuit_method(s,gv)))
2915 /* If not a declared subroutine, it's an indirect object. */
2916 /* (But it's an indir obj regardless for sort.) */
2918 if ((last_lop_op == OP_SORT ||
2919 (!immediate_paren && (!gv || !GvCVu(gv))) ) &&
2920 (last_lop_op != OP_MAPSTART && last_lop_op != OP_GREPSTART)){
2921 expect = (last_lop == oldoldbufptr) ? XTERM : XOPERATOR;
2926 /* If followed by a paren, it's certainly a subroutine. */
2932 if (gv && GvCVu(gv)) {
2933 for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
2934 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
2939 nextval[nexttoke].opval = yylval.opval;
2946 /* If followed by var or block, call it a method (unless sub) */
2948 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
2949 last_lop = oldbufptr;
2950 last_lop_op = OP_METHOD;
2954 /* If followed by a bareword, see if it looks like indir obj. */
2956 if ((isALPHA(*s) || *s == '$') && (tmp = intuit_method(s,gv)))
2959 /* Not a method, so call it a subroutine (if defined) */
2961 if (gv && GvCVu(gv)) {
2963 if (lastchar == '-')
2964 warn("Ambiguous use of -%s resolved as -&%s()",
2965 tokenbuf, tokenbuf);
2966 last_lop = oldbufptr;
2967 last_lop_op = OP_ENTERSUB;
2968 /* Check for a constant sub */
2970 if ((sv = cv_const_sv(cv))) {
2972 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
2973 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
2974 yylval.opval->op_private = 0;
2978 /* Resolve to GV now. */
2979 op_free(yylval.opval);
2980 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
2981 /* Is there a prototype? */
2984 char *proto = SvPV((SV*)cv, len);
2987 if (strEQ(proto, "$"))
2989 if (*proto == '&' && *s == '{') {
2990 sv_setpv(subname,"__ANON__");
2994 nextval[nexttoke].opval = yylval.opval;
3000 if (hints & HINT_STRICT_SUBS &&
3003 last_lop_op != OP_TRUNCATE && /* S/F prototype in opcode.pl */
3004 last_lop_op != OP_ACCEPT &&
3005 last_lop_op != OP_PIPE_OP &&
3006 last_lop_op != OP_SOCKPAIR)
3009 "Bareword \"%s\" not allowed while \"strict subs\" in use",
3014 /* Call it a bare word */
3018 if (lastchar != '-') {
3019 for (d = tokenbuf; *d && isLOWER(*d); d++) ;
3021 warn(warn_reserved, tokenbuf);
3026 if (lastchar && strchr("*%&", lastchar)) {
3027 warn("Operator or semicolon missing before %c%s",
3028 lastchar, tokenbuf);
3029 warn("Ambiguous use of %c resolved as operator %c",
3030 lastchar, lastchar);
3036 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3037 newSVsv(GvSV(curcop->cop_filegv)));
3041 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3042 newSVpvf("%ld", (long)curcop->cop_line));
3045 case KEY___PACKAGE__:
3046 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3048 ? newSVsv(curstname)
3057 if (rsfp && (!in_eval || tokenbuf[2] == 'D')) {
3058 char *pname = "main";
3059 if (tokenbuf[2] == 'D')
3060 pname = HvNAME(curstash ? curstash : defstash);
3061 gv = gv_fetchpv(form("%s::DATA", pname), TRUE, SVt_PVIO);
3064 GvIOp(gv) = newIO();
3065 IoIFP(GvIOp(gv)) = rsfp;
3066 #if defined(HAS_FCNTL) && defined(F_SETFD)
3068 int fd = PerlIO_fileno(rsfp);
3069 fcntl(fd,F_SETFD,fd >= 3);
3072 /* Mark this internal pseudo-handle as clean */
3073 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3075 IoTYPE(GvIOp(gv)) = '|';
3076 else if ((PerlIO*)rsfp == PerlIO_stdin())
3077 IoTYPE(GvIOp(gv)) = '-';
3079 IoTYPE(GvIOp(gv)) = '<';
3090 if (expect == XSTATE) {
3097 if (*s == ':' && s[1] == ':') {
3100 s = scan_word(s, tokenbuf, sizeof tokenbuf, FALSE, &len);
3101 tmp = keyword(tokenbuf, len);
3115 LOP(OP_ACCEPT,XTERM);
3121 LOP(OP_ATAN2,XTERM);
3130 LOP(OP_BLESS,XTERM);
3139 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
3159 LOP(OP_CRYPT,XTERM);
3163 for (d = s; d < bufend && (isSPACE(*d) || *d == '('); d++) ;
3164 if (*d != '0' && isDIGIT(*d))
3165 yywarn("chmod: mode argument is missing initial 0");
3167 LOP(OP_CHMOD,XTERM);
3170 LOP(OP_CHOWN,XTERM);
3173 LOP(OP_CONNECT,XTERM);
3189 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3193 hints |= HINT_BLOCK_SCOPE;
3203 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3204 LOP(OP_DBMOPEN,XTERM);
3210 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3217 yylval.ival = curcop->cop_line;
3231 expect = (*s == '{') ? XTERMBLOCK : XTERM;
3232 UNIBRACK(OP_ENTEREVAL);
3247 case KEY_endhostent:
3253 case KEY_endservent:
3256 case KEY_endprotoent:
3267 yylval.ival = curcop->cop_line;
3269 if (expect == XSTATE && isIDFIRST(*s)) {
3271 if ((bufend - p) >= 3 &&
3272 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3276 croak("Missing $ on loop variable");
3281 LOP(OP_FORMLINE,XTERM);
3287 LOP(OP_FCNTL,XTERM);
3293 LOP(OP_FLOCK,XTERM);
3302 LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
3305 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3320 case KEY_getpriority:
3321 LOP(OP_GETPRIORITY,XTERM);
3323 case KEY_getprotobyname:
3326 case KEY_getprotobynumber:
3327 LOP(OP_GPBYNUMBER,XTERM);
3329 case KEY_getprotoent:
3341 case KEY_getpeername:
3342 UNI(OP_GETPEERNAME);
3344 case KEY_gethostbyname:
3347 case KEY_gethostbyaddr:
3348 LOP(OP_GHBYADDR,XTERM);
3350 case KEY_gethostent:
3353 case KEY_getnetbyname:
3356 case KEY_getnetbyaddr:
3357 LOP(OP_GNBYADDR,XTERM);
3362 case KEY_getservbyname:
3363 LOP(OP_GSBYNAME,XTERM);
3365 case KEY_getservbyport:
3366 LOP(OP_GSBYPORT,XTERM);
3368 case KEY_getservent:
3371 case KEY_getsockname:
3372 UNI(OP_GETSOCKNAME);
3374 case KEY_getsockopt:
3375 LOP(OP_GSOCKOPT,XTERM);
3397 yylval.ival = curcop->cop_line;
3401 LOP(OP_INDEX,XTERM);
3407 LOP(OP_IOCTL,XTERM);
3419 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3450 LOP(OP_LISTEN,XTERM);
3460 TERM(sublex_start());
3463 LOP(OP_MAPSTART,XREF);
3466 LOP(OP_MKDIR,XTERM);
3469 LOP(OP_MSGCTL,XTERM);
3472 LOP(OP_MSGGET,XTERM);
3475 LOP(OP_MSGRCV,XTERM);
3478 LOP(OP_MSGSND,XTERM);
3483 if (isIDFIRST(*s)) {
3484 s = scan_word(s, tokenbuf, sizeof tokenbuf, TRUE, &len);
3485 in_my_stash = gv_stashpv(tokenbuf, FALSE);
3489 sprintf(tmpbuf, "No such class %.1000s", tokenbuf);
3496 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3503 if (expect != XSTATE)
3504 yyerror("\"no\" not allowed in expression");
3505 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3506 s = force_version(s);
3515 if (isIDFIRST(*s)) {
3517 for (d = s; isALNUM(*d); d++) ;
3519 if (strchr("|&*+-=!?:.", *t))
3520 warn("Precedence problem: open %.*s should be open(%.*s)",
3526 yylval.ival = OP_OR;
3536 LOP(OP_OPEN_DIR,XTERM);
3539 checkcomma(s,tokenbuf,"filehandle");
3543 checkcomma(s,tokenbuf,"filehandle");
3562 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3566 LOP(OP_PIPE_OP,XTERM);
3571 missingterm((char*)0);
3572 yylval.ival = OP_CONST;
3573 TERM(sublex_start());
3581 missingterm((char*)0);
3582 if (dowarn && SvLEN(lex_stuff)) {
3583 d = SvPV_force(lex_stuff, len);
3584 for (; len; --len, ++d) {
3586 warn("Possible attempt to separate words with commas");
3590 warn("Possible attempt to put comments in qw() list");
3596 nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, tokeq(lex_stuff));
3600 nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(" ",1));
3603 yylval.ival = OP_SPLIT;
3607 last_lop = oldbufptr;
3608 last_lop_op = OP_SPLIT;
3614 missingterm((char*)0);
3615 yylval.ival = OP_STRINGIFY;
3616 if (SvIVX(lex_stuff) == '\'')
3617 SvIVX(lex_stuff) = 0; /* qq'$foo' should intepolate */
3618 TERM(sublex_start());
3623 missingterm((char*)0);
3624 yylval.ival = OP_BACKTICK;
3626 TERM(sublex_start());
3633 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3634 if (isIDFIRST(*tokenbuf))
3635 gv_stashpvn(tokenbuf, strlen(tokenbuf), TRUE);
3637 yyerror("<> should be quotes");
3644 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3648 LOP(OP_RENAME,XTERM);
3657 LOP(OP_RINDEX,XTERM);
3680 LOP(OP_REVERSE,XTERM);
3691 TERM(sublex_start());
3693 TOKEN(1); /* force error */
3702 LOP(OP_SELECT,XTERM);
3708 LOP(OP_SEMCTL,XTERM);
3711 LOP(OP_SEMGET,XTERM);
3714 LOP(OP_SEMOP,XTERM);
3720 LOP(OP_SETPGRP,XTERM);
3722 case KEY_setpriority:
3723 LOP(OP_SETPRIORITY,XTERM);
3725 case KEY_sethostent:
3731 case KEY_setservent:
3734 case KEY_setprotoent:
3744 LOP(OP_SEEKDIR,XTERM);
3746 case KEY_setsockopt:
3747 LOP(OP_SSOCKOPT,XTERM);
3753 LOP(OP_SHMCTL,XTERM);
3756 LOP(OP_SHMGET,XTERM);
3759 LOP(OP_SHMREAD,XTERM);
3762 LOP(OP_SHMWRITE,XTERM);
3765 LOP(OP_SHUTDOWN,XTERM);
3774 LOP(OP_SOCKET,XTERM);
3776 case KEY_socketpair:
3777 LOP(OP_SOCKPAIR,XTERM);
3780 checkcomma(s,tokenbuf,"subroutine name");
3782 if (*s == ';' || *s == ')') /* probably a close */
3783 croak("sort is now a reserved word");
3785 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3789 LOP(OP_SPLIT,XTERM);
3792 LOP(OP_SPRINTF,XTERM);
3795 LOP(OP_SPLICE,XTERM);
3811 LOP(OP_SUBSTR,XTERM);
3818 if (isIDFIRST(*s) || *s == '\'' || *s == ':') {
3819 char tmpbuf[sizeof tokenbuf];
3821 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3822 if (strchr(tmpbuf, ':'))
3823 sv_setpv(subname, tmpbuf);
3825 sv_setsv(subname,curstname);
3826 sv_catpvn(subname,"::",2);
3827 sv_catpvn(subname,tmpbuf,len);
3829 s = force_word(s,WORD,FALSE,TRUE,TRUE);
3833 expect = XTERMBLOCK;
3834 sv_setpv(subname,"?");
3837 if (tmp == KEY_format) {
3840 lex_formbrack = lex_brackets + 1;
3844 /* Look for a prototype */
3851 SvREFCNT_dec(lex_stuff);
3853 croak("Prototype not terminated");
3856 d = SvPVX(lex_stuff);
3858 for (p = d; *p; ++p) {
3863 SvCUR(lex_stuff) = tmp;
3866 nextval[1] = nextval[0];
3867 nexttype[1] = nexttype[0];
3868 nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, lex_stuff);
3869 nexttype[0] = THING;
3870 if (nexttoke == 1) {
3871 lex_defer = lex_state;
3872 lex_expect = expect;
3873 lex_state = LEX_KNOWNEXT;
3878 if (*SvPV(subname,na) == '?') {
3879 sv_setpv(subname,"__ANON__");
3886 LOP(OP_SYSTEM,XREF);
3889 LOP(OP_SYMLINK,XTERM);
3892 LOP(OP_SYSCALL,XTERM);
3895 LOP(OP_SYSOPEN,XTERM);
3898 LOP(OP_SYSSEEK,XTERM);
3901 LOP(OP_SYSREAD,XTERM);
3904 LOP(OP_SYSWRITE,XTERM);
3908 TERM(sublex_start());
3929 LOP(OP_TRUNCATE,XTERM);
3941 yylval.ival = curcop->cop_line;
3945 yylval.ival = curcop->cop_line;
3949 LOP(OP_UNLINK,XTERM);
3955 LOP(OP_UNPACK,XTERM);
3958 LOP(OP_UTIME,XTERM);
3962 for (d = s; d < bufend && (isSPACE(*d) || *d == '('); d++) ;
3963 if (*d != '0' && isDIGIT(*d))
3964 yywarn("umask: argument is missing initial 0");
3969 LOP(OP_UNSHIFT,XTERM);
3972 if (expect != XSTATE)
3973 yyerror("\"use\" not allowed in expression");
3976 s = force_version(s);
3977 if(*s == ';' || (s = skipspace(s), *s == ';')) {
3978 nextval[nexttoke].opval = Nullop;
3983 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3984 s = force_version(s);
3997 yylval.ival = curcop->cop_line;
4001 hints |= HINT_BLOCK_SCOPE;
4008 LOP(OP_WAITPID,XTERM);
4014 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
4018 if (expect == XOPERATOR)
4024 yylval.ival = OP_XOR;
4029 TERM(sublex_start());
4035 keyword(register char *d, I32 len)
4040 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
4041 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
4042 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
4043 if (strEQ(d,"__DATA__")) return KEY___DATA__;
4044 if (strEQ(d,"__END__")) return KEY___END__;
4048 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
4053 if (strEQ(d,"and")) return -KEY_and;
4054 if (strEQ(d,"abs")) return -KEY_abs;
4057 if (strEQ(d,"alarm")) return -KEY_alarm;
4058 if (strEQ(d,"atan2")) return -KEY_atan2;
4061 if (strEQ(d,"accept")) return -KEY_accept;
4066 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
4069 if (strEQ(d,"bless")) return -KEY_bless;
4070 if (strEQ(d,"bind")) return -KEY_bind;
4071 if (strEQ(d,"binmode")) return -KEY_binmode;
4074 if (strEQ(d,"CORE")) return -KEY_CORE;
4079 if (strEQ(d,"cmp")) return -KEY_cmp;
4080 if (strEQ(d,"chr")) return -KEY_chr;
4081 if (strEQ(d,"cos")) return -KEY_cos;
4084 if (strEQ(d,"chop")) return KEY_chop;
4087 if (strEQ(d,"close")) return -KEY_close;
4088 if (strEQ(d,"chdir")) return -KEY_chdir;
4089 if (strEQ(d,"chomp")) return KEY_chomp;
4090 if (strEQ(d,"chmod")) return -KEY_chmod;
4091 if (strEQ(d,"chown")) return -KEY_chown;
4092 if (strEQ(d,"crypt")) return -KEY_crypt;
4095 if (strEQ(d,"chroot")) return -KEY_chroot;
4096 if (strEQ(d,"caller")) return -KEY_caller;
4099 if (strEQ(d,"connect")) return -KEY_connect;
4102 if (strEQ(d,"closedir")) return -KEY_closedir;
4103 if (strEQ(d,"continue")) return -KEY_continue;
4108 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
4113 if (strEQ(d,"do")) return KEY_do;
4116 if (strEQ(d,"die")) return -KEY_die;
4119 if (strEQ(d,"dump")) return -KEY_dump;
4122 if (strEQ(d,"delete")) return KEY_delete;
4125 if (strEQ(d,"defined")) return KEY_defined;
4126 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
4129 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
4134 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
4135 if (strEQ(d,"END")) return KEY_END;
4140 if (strEQ(d,"eq")) return -KEY_eq;
4143 if (strEQ(d,"eof")) return -KEY_eof;
4144 if (strEQ(d,"exp")) return -KEY_exp;
4147 if (strEQ(d,"else")) return KEY_else;
4148 if (strEQ(d,"exit")) return -KEY_exit;
4149 if (strEQ(d,"eval")) return KEY_eval;
4150 if (strEQ(d,"exec")) return -KEY_exec;
4151 if (strEQ(d,"each")) return KEY_each;
4154 if (strEQ(d,"elsif")) return KEY_elsif;
4157 if (strEQ(d,"exists")) return KEY_exists;
4158 if (strEQ(d,"elseif")) warn("elseif should be elsif");
4161 if (strEQ(d,"endgrent")) return -KEY_endgrent;
4162 if (strEQ(d,"endpwent")) return -KEY_endpwent;
4165 if (strEQ(d,"endnetent")) return -KEY_endnetent;
4168 if (strEQ(d,"endhostent")) return -KEY_endhostent;
4169 if (strEQ(d,"endservent")) return -KEY_endservent;
4172 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
4179 if (strEQ(d,"for")) return KEY_for;
4182 if (strEQ(d,"fork")) return -KEY_fork;
4185 if (strEQ(d,"fcntl")) return -KEY_fcntl;
4186 if (strEQ(d,"flock")) return -KEY_flock;
4189 if (strEQ(d,"format")) return KEY_format;
4190 if (strEQ(d,"fileno")) return -KEY_fileno;
4193 if (strEQ(d,"foreach")) return KEY_foreach;
4196 if (strEQ(d,"formline")) return -KEY_formline;
4202 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
4203 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
4207 if (strnEQ(d,"get",3)) {
4212 if (strEQ(d,"ppid")) return -KEY_getppid;
4213 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
4216 if (strEQ(d,"pwent")) return -KEY_getpwent;
4217 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
4218 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
4221 if (strEQ(d,"peername")) return -KEY_getpeername;
4222 if (strEQ(d,"protoent")) return -KEY_getprotoent;
4223 if (strEQ(d,"priority")) return -KEY_getpriority;
4226 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
4229 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
4233 else if (*d == 'h') {
4234 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
4235 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
4236 if (strEQ(d,"hostent")) return -KEY_gethostent;
4238 else if (*d == 'n') {
4239 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
4240 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
4241 if (strEQ(d,"netent")) return -KEY_getnetent;
4243 else if (*d == 's') {
4244 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
4245 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
4246 if (strEQ(d,"servent")) return -KEY_getservent;
4247 if (strEQ(d,"sockname")) return -KEY_getsockname;
4248 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
4250 else if (*d == 'g') {
4251 if (strEQ(d,"grent")) return -KEY_getgrent;
4252 if (strEQ(d,"grnam")) return -KEY_getgrnam;
4253 if (strEQ(d,"grgid")) return -KEY_getgrgid;
4255 else if (*d == 'l') {
4256 if (strEQ(d,"login")) return -KEY_getlogin;
4258 else if (strEQ(d,"c")) return -KEY_getc;
4263 if (strEQ(d,"gt")) return -KEY_gt;
4264 if (strEQ(d,"ge")) return -KEY_ge;
4267 if (strEQ(d,"grep")) return KEY_grep;
4268 if (strEQ(d,"goto")) return KEY_goto;
4269 if (strEQ(d,"glob")) return KEY_glob;
4272 if (strEQ(d,"gmtime")) return -KEY_gmtime;
4277 if (strEQ(d,"hex")) return -KEY_hex;
4280 if (strEQ(d,"INIT")) return KEY_INIT;
4285 if (strEQ(d,"if")) return KEY_if;
4288 if (strEQ(d,"int")) return -KEY_int;
4291 if (strEQ(d,"index")) return -KEY_index;
4292 if (strEQ(d,"ioctl")) return -KEY_ioctl;
4297 if (strEQ(d,"join")) return -KEY_join;
4301 if (strEQ(d,"keys")) return KEY_keys;
4302 if (strEQ(d,"kill")) return -KEY_kill;
4307 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
4308 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
4314 if (strEQ(d,"lt")) return -KEY_lt;
4315 if (strEQ(d,"le")) return -KEY_le;
4316 if (strEQ(d,"lc")) return -KEY_lc;
4319 if (strEQ(d,"log")) return -KEY_log;
4322 if (strEQ(d,"last")) return KEY_last;
4323 if (strEQ(d,"link")) return -KEY_link;
4324 if (strEQ(d,"lock")) return -KEY_lock;
4327 if (strEQ(d,"local")) return KEY_local;
4328 if (strEQ(d,"lstat")) return -KEY_lstat;
4331 if (strEQ(d,"length")) return -KEY_length;
4332 if (strEQ(d,"listen")) return -KEY_listen;
4335 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
4338 if (strEQ(d,"localtime")) return -KEY_localtime;
4344 case 1: return KEY_m;
4346 if (strEQ(d,"my")) return KEY_my;
4349 if (strEQ(d,"map")) return KEY_map;
4352 if (strEQ(d,"mkdir")) return -KEY_mkdir;
4355 if (strEQ(d,"msgctl")) return -KEY_msgctl;
4356 if (strEQ(d,"msgget")) return -KEY_msgget;
4357 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
4358 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
4363 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
4366 if (strEQ(d,"next")) return KEY_next;
4367 if (strEQ(d,"ne")) return -KEY_ne;
4368 if (strEQ(d,"not")) return -KEY_not;
4369 if (strEQ(d,"no")) return KEY_no;
4374 if (strEQ(d,"or")) return -KEY_or;
4377 if (strEQ(d,"ord")) return -KEY_ord;
4378 if (strEQ(d,"oct")) return -KEY_oct;
4381 if (strEQ(d,"open")) return -KEY_open;
4384 if (strEQ(d,"opendir")) return -KEY_opendir;
4391 if (strEQ(d,"pop")) return KEY_pop;
4392 if (strEQ(d,"pos")) return KEY_pos;
4395 if (strEQ(d,"push")) return KEY_push;
4396 if (strEQ(d,"pack")) return -KEY_pack;
4397 if (strEQ(d,"pipe")) return -KEY_pipe;
4400 if (strEQ(d,"print")) return KEY_print;
4403 if (strEQ(d,"printf")) return KEY_printf;
4406 if (strEQ(d,"package")) return KEY_package;
4409 if (strEQ(d,"prototype")) return KEY_prototype;
4414 if (strEQ(d,"q")) return KEY_q;
4415 if (strEQ(d,"qq")) return KEY_qq;
4416 if (strEQ(d,"qw")) return KEY_qw;
4417 if (strEQ(d,"qx")) return KEY_qx;
4419 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
4424 if (strEQ(d,"ref")) return -KEY_ref;
4427 if (strEQ(d,"read")) return -KEY_read;
4428 if (strEQ(d,"rand")) return -KEY_rand;
4429 if (strEQ(d,"recv")) return -KEY_recv;
4430 if (strEQ(d,"redo")) return KEY_redo;
4433 if (strEQ(d,"rmdir")) return -KEY_rmdir;
4434 if (strEQ(d,"reset")) return -KEY_reset;
4437 if (strEQ(d,"return")) return KEY_return;
4438 if (strEQ(d,"rename")) return -KEY_rename;
4439 if (strEQ(d,"rindex")) return -KEY_rindex;
4442 if (strEQ(d,"require")) return -KEY_require;
4443 if (strEQ(d,"reverse")) return -KEY_reverse;
4444 if (strEQ(d,"readdir")) return -KEY_readdir;
4447 if (strEQ(d,"readlink")) return -KEY_readlink;
4448 if (strEQ(d,"readline")) return -KEY_readline;
4449 if (strEQ(d,"readpipe")) return -KEY_readpipe;
4452 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
4458 case 0: return KEY_s;
4460 if (strEQ(d,"scalar")) return KEY_scalar;
4465 if (strEQ(d,"seek")) return -KEY_seek;
4466 if (strEQ(d,"send")) return -KEY_send;
4469 if (strEQ(d,"semop")) return -KEY_semop;
4472 if (strEQ(d,"select")) return -KEY_select;
4473 if (strEQ(d,"semctl")) return -KEY_semctl;
4474 if (strEQ(d,"semget")) return -KEY_semget;
4477 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
4478 if (strEQ(d,"seekdir")) return -KEY_seekdir;
4481 if (strEQ(d,"setpwent")) return -KEY_setpwent;
4482 if (strEQ(d,"setgrent")) return -KEY_setgrent;
4485 if (strEQ(d,"setnetent")) return -KEY_setnetent;
4488 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
4489 if (strEQ(d,"sethostent")) return -KEY_sethostent;
4490 if (strEQ(d,"setservent")) return -KEY_setservent;
4493 if (strEQ(d,"setpriority")) return -KEY_setpriority;
4494 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
4501 if (strEQ(d,"shift")) return KEY_shift;
4504 if (strEQ(d,"shmctl")) return -KEY_shmctl;
4505 if (strEQ(d,"shmget")) return -KEY_shmget;
4508 if (strEQ(d,"shmread")) return -KEY_shmread;
4511 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
4512 if (strEQ(d,"shutdown")) return -KEY_shutdown;
4517 if (strEQ(d,"sin")) return -KEY_sin;
4520 if (strEQ(d,"sleep")) return -KEY_sleep;
4523 if (strEQ(d,"sort")) return KEY_sort;
4524 if (strEQ(d,"socket")) return -KEY_socket;
4525 if (strEQ(d,"socketpair")) return -KEY_socketpair;
4528 if (strEQ(d,"split")) return KEY_split;
4529 if (strEQ(d,"sprintf")) return -KEY_sprintf;
4530 if (strEQ(d,"splice")) return KEY_splice;
4533 if (strEQ(d,"sqrt")) return -KEY_sqrt;
4536 if (strEQ(d,"srand")) return -KEY_srand;
4539 if (strEQ(d,"stat")) return -KEY_stat;
4540 if (strEQ(d,"study")) return KEY_study;
4543 if (strEQ(d,"substr")) return -KEY_substr;
4544 if (strEQ(d,"sub")) return KEY_sub;
4549 if (strEQ(d,"system")) return -KEY_system;
4552 if (strEQ(d,"symlink")) return -KEY_symlink;
4553 if (strEQ(d,"syscall")) return -KEY_syscall;
4554 if (strEQ(d,"sysopen")) return -KEY_sysopen;
4555 if (strEQ(d,"sysread")) return -KEY_sysread;
4556 if (strEQ(d,"sysseek")) return -KEY_sysseek;
4559 if (strEQ(d,"syswrite")) return -KEY_syswrite;
4568 if (strEQ(d,"tr")) return KEY_tr;
4571 if (strEQ(d,"tie")) return KEY_tie;
4574 if (strEQ(d,"tell")) return -KEY_tell;
4575 if (strEQ(d,"tied")) return KEY_tied;
4576 if (strEQ(d,"time")) return -KEY_time;
4579 if (strEQ(d,"times")) return -KEY_times;
4582 if (strEQ(d,"telldir")) return -KEY_telldir;
4585 if (strEQ(d,"truncate")) return -KEY_truncate;
4592 if (strEQ(d,"uc")) return -KEY_uc;
4595 if (strEQ(d,"use")) return KEY_use;
4598 if (strEQ(d,"undef")) return KEY_undef;
4599 if (strEQ(d,"until")) return KEY_until;
4600 if (strEQ(d,"untie")) return KEY_untie;
4601 if (strEQ(d,"utime")) return -KEY_utime;
4602 if (strEQ(d,"umask")) return -KEY_umask;
4605 if (strEQ(d,"unless")) return KEY_unless;
4606 if (strEQ(d,"unpack")) return -KEY_unpack;
4607 if (strEQ(d,"unlink")) return -KEY_unlink;
4610 if (strEQ(d,"unshift")) return KEY_unshift;
4611 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
4616 if (strEQ(d,"values")) return -KEY_values;
4617 if (strEQ(d,"vec")) return -KEY_vec;
4622 if (strEQ(d,"warn")) return -KEY_warn;
4623 if (strEQ(d,"wait")) return -KEY_wait;
4626 if (strEQ(d,"while")) return KEY_while;
4627 if (strEQ(d,"write")) return -KEY_write;
4630 if (strEQ(d,"waitpid")) return -KEY_waitpid;
4633 if (strEQ(d,"wantarray")) return -KEY_wantarray;
4638 if (len == 1) return -KEY_x;
4639 if (strEQ(d,"xor")) return -KEY_xor;
4642 if (len == 1) return KEY_y;
4651 checkcomma(register char *s, char *name, char *what)
4655 if (dowarn && *s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
4657 for (w = s+2; *w && level; w++) {
4664 for (; *w && isSPACE(*w); w++) ;
4665 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
4666 warn("%s (...) interpreted as function",name);
4668 while (s < bufend && isSPACE(*s))
4672 while (s < bufend && isSPACE(*s))
4674 if (isIDFIRST(*s)) {
4678 while (s < bufend && isSPACE(*s))
4683 kw = keyword(w, s - w) || perl_get_cv(w, FALSE) != 0;
4687 croak("No comma allowed after %s", what);
4693 scan_word(register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
4695 register char *d = dest;
4696 register char *e = d + destlen - 3; /* two-character token, ending NUL */
4699 croak(ident_too_long);
4702 else if (*s == '\'' && allow_package && isIDFIRST(s[1])) {
4707 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
4720 scan_ident(register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
4727 if (lex_brackets == 0)
4732 e = d + destlen - 3; /* two-character token, ending NUL */
4734 while (isDIGIT(*s)) {
4736 croak(ident_too_long);
4743 croak(ident_too_long);
4746 else if (*s == '\'' && isIDFIRST(s[1])) {
4751 else if (*s == ':' && s[1] == ':') {
4762 if (lex_state != LEX_NORMAL)
4763 lex_state = LEX_INTERPENDMAYBE;
4766 if (*s == '$' && s[1] &&
4767 (isALNUM(s[1]) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
4769 if (isDIGIT(s[1]) && lex_state == LEX_INTERPNORMAL)
4770 deprecate("\"$$<digit>\" to mean \"${$}<digit>\"");
4783 if (*d == '^' && *s && (isUPPER(*s) || strchr("[\\]^_?", *s))) {
4788 if (isSPACE(s[-1])) {
4791 if (ch != ' ' && ch != '\t') {
4797 if (isIDFIRST(*d)) {
4799 while (isALNUM(*s) || *s == ':')
4802 while (s < send && (*s == ' ' || *s == '\t')) s++;
4803 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
4804 if (dowarn && keyword(dest, d - dest)) {
4805 char *brack = *s == '[' ? "[...]" : "{...}";
4806 warn("Ambiguous use of %c{%s%s} resolved to %c%s%s",
4807 funny, dest, brack, funny, dest, brack);
4809 lex_fakebrack = lex_brackets+1;
4811 lex_brackstack[lex_brackets++] = XOPERATOR;
4817 if (lex_state == LEX_INTERPNORMAL && !lex_brackets)
4818 lex_state = LEX_INTERPEND;
4821 if (dowarn && lex_state == LEX_NORMAL &&
4822 (keyword(dest, d - dest) || perl_get_cv(dest, FALSE)))
4823 warn("Ambiguous use of %c{%s} resolved to %c%s",
4824 funny, dest, funny, dest);
4827 s = bracket; /* let the parser handle it */
4831 else if (lex_state == LEX_INTERPNORMAL && !lex_brackets && !intuit_more(s))
4832 lex_state = LEX_INTERPEND;
4836 void pmflag(U16 *pmfl, int ch)
4841 *pmfl |= PMf_GLOBAL;
4843 *pmfl |= PMf_CONTINUE;
4847 *pmfl |= PMf_MULTILINE;
4849 *pmfl |= PMf_SINGLELINE;
4851 *pmfl |= PMf_EXTENDED;
4855 scan_pat(char *start)
4860 s = scan_str(start);
4863 SvREFCNT_dec(lex_stuff);
4865 croak("Search pattern not terminated");
4868 pm = (PMOP*)newPMOP(OP_MATCH, 0);
4869 if (multi_open == '?')
4870 pm->op_pmflags |= PMf_ONCE;
4871 while (*s && strchr("iogcmsx", *s))
4872 pmflag(&pm->op_pmflags,*s++);
4873 pm->op_pmpermflags = pm->op_pmflags;
4876 yylval.ival = OP_MATCH;
4881 scan_subst(char *start)
4888 yylval.ival = OP_NULL;
4890 s = scan_str(start);
4894 SvREFCNT_dec(lex_stuff);
4896 croak("Substitution pattern not terminated");
4899 if (s[-1] == multi_open)
4902 first_start = multi_start;
4906 SvREFCNT_dec(lex_stuff);
4909 SvREFCNT_dec(lex_repl);
4911 croak("Substitution replacement not terminated");
4913 multi_start = first_start; /* so whole substitution is taken together */
4915 pm = (PMOP*)newPMOP(OP_SUBST, 0);
4916 while (*s && strchr("iogcmsex", *s)) {
4922 pmflag(&pm->op_pmflags,*s++);
4927 pm->op_pmflags |= PMf_EVAL;
4928 repl = newSVpv("",0);
4930 sv_catpv(repl, es ? "eval " : "do ");
4931 sv_catpvn(repl, "{ ", 2);
4932 sv_catsv(repl, lex_repl);
4933 sv_catpvn(repl, " };", 2);
4934 SvCOMPILED_on(repl);
4935 SvREFCNT_dec(lex_repl);
4939 pm->op_pmpermflags = pm->op_pmflags;
4941 yylval.ival = OP_SUBST;
4946 scan_trans(char *start)
4955 yylval.ival = OP_NULL;
4957 s = scan_str(start);
4960 SvREFCNT_dec(lex_stuff);
4962 croak("Transliteration pattern not terminated");
4964 if (s[-1] == multi_open)
4970 SvREFCNT_dec(lex_stuff);
4973 SvREFCNT_dec(lex_repl);
4975 croak("Transliteration replacement not terminated");
4978 New(803,tbl,256,short);
4979 o = newPVOP(OP_TRANS, 0, (char*)tbl);
4981 complement = Delete = squash = 0;
4982 while (*s == 'c' || *s == 'd' || *s == 's') {
4984 complement = OPpTRANS_COMPLEMENT;
4986 Delete = OPpTRANS_DELETE;
4988 squash = OPpTRANS_SQUASH;
4991 o->op_private = Delete|squash|complement;
4994 yylval.ival = OP_TRANS;
4999 scan_heredoc(register char *s)
5003 I32 op_type = OP_SCALAR;
5010 int outer = (rsfp && !(lex_inwhat == OP_SCALAR));
5014 e = tokenbuf + sizeof tokenbuf - 1;
5017 for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5018 if (*peek && strchr("`'\"",*peek)) {
5021 s = delimcpy(d, e, s, bufend, term, &len);
5032 deprecate("bare << to mean <<\"\"");
5033 for (; isALNUM(*s); s++) {
5038 if (d >= tokenbuf + sizeof tokenbuf - 1)
5039 croak("Delimiter for here document is too long");
5044 if (outer || !(d=ninstr(s,bufend,d,d+1)))
5045 herewas = newSVpv(s,bufend-s);
5047 s--, herewas = newSVpv(s,d-s);
5048 s += SvCUR(herewas);
5050 tmpstr = NEWSV(87,80);
5051 sv_upgrade(tmpstr, SVt_PVIV);
5056 else if (term == '`') {
5057 op_type = OP_BACKTICK;
5058 SvIVX(tmpstr) = '\\';
5062 multi_start = curcop->cop_line;
5063 multi_open = multi_close = '<';
5067 while (s < bufend &&
5068 (*s != term || memNE(s,tokenbuf,len)) ) {
5073 curcop->cop_line = multi_start;
5074 missingterm(tokenbuf);
5076 sv_setpvn(tmpstr,d+1,s-d);
5078 curcop->cop_line++; /* the preceding stmt passes a newline */
5080 sv_catpvn(herewas,s,bufend-s);
5081 sv_setsv(linestr,herewas);
5082 oldoldbufptr = oldbufptr = bufptr = s = linestart = SvPVX(linestr);
5083 bufend = SvPVX(linestr) + SvCUR(linestr);
5086 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
5087 while (s >= bufend) { /* multiple line string? */
5089 !(oldoldbufptr = oldbufptr = s = linestart = filter_gets(linestr, rsfp, 0))) {
5090 curcop->cop_line = multi_start;
5091 missingterm(tokenbuf);
5094 if (PERLDB_LINE && curstash != debstash) {
5095 SV *sv = NEWSV(88,0);
5097 sv_upgrade(sv, SVt_PVMG);
5098 sv_setsv(sv,linestr);
5099 av_store(GvAV(curcop->cop_filegv),
5100 (I32)curcop->cop_line,sv);
5102 bufend = SvPVX(linestr) + SvCUR(linestr);
5103 if (*s == term && memEQ(s,tokenbuf,len)) {
5106 sv_catsv(linestr,herewas);
5107 bufend = SvPVX(linestr) + SvCUR(linestr);
5111 sv_catsv(tmpstr,linestr);
5114 multi_end = curcop->cop_line;
5116 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
5117 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
5118 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
5120 SvREFCNT_dec(herewas);
5122 yylval.ival = op_type;
5127 takes: current position in input buffer
5128 returns: new position in input buffer
5129 side-effects: yylval and lex_op are set.
5134 <FH> read from filehandle
5135 <pkg::FH> read from package qualified filehandle
5136 <pkg'FH> read from package qualified filehandle
5137 <$fh> read from filehandle in $fh
5143 scan_inputsymbol(char *start)
5145 register char *s = start; /* current position in buffer */
5150 d = tokenbuf; /* start of temp holding space */
5151 e = tokenbuf + sizeof tokenbuf; /* end of temp holding space */
5152 s = delimcpy(d, e, s + 1, bufend, '>', &len); /* extract until > */
5154 /* die if we didn't have space for the contents of the <>,
5158 if (len >= sizeof tokenbuf)
5159 croak("Excessively long <> operator");
5161 croak("Unterminated <> operator");
5166 Remember, only scalar variables are interpreted as filehandles by
5167 this code. Anything more complex (e.g., <$fh{$num}>) will be
5168 treated as a glob() call.
5169 This code makes use of the fact that except for the $ at the front,
5170 a scalar variable and a filehandle look the same.
5172 if (*d == '$' && d[1]) d++;
5174 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
5175 while (*d && (isALNUM(*d) || *d == '\'' || *d == ':'))
5178 /* If we've tried to read what we allow filehandles to look like, and
5179 there's still text left, then it must be a glob() and not a getline.
5180 Use scan_str to pull out the stuff between the <> and treat it
5181 as nothing more than a string.
5184 if (d - tokenbuf != len) {
5185 yylval.ival = OP_GLOB;
5187 s = scan_str(start);
5189 croak("Glob not terminated");
5193 /* we're in a filehandle read situation */
5196 /* turn <> into <ARGV> */
5198 (void)strcpy(d,"ARGV");
5200 /* if <$fh>, create the ops to turn the variable into a
5206 /* try to find it in the pad for this block, otherwise find
5207 add symbol table ops
5209 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
5210 OP *o = newOP(OP_PADSV, 0);
5212 lex_op = (OP*)newUNOP(OP_READLINE, 0, newUNOP(OP_RV2GV, 0, o));
5215 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
5216 lex_op = (OP*)newUNOP(OP_READLINE, 0,
5217 newUNOP(OP_RV2GV, 0,
5218 newUNOP(OP_RV2SV, 0,
5219 newGVOP(OP_GV, 0, gv))));
5221 /* we created the ops in lex_op, so make yylval.ival a null op */
5222 yylval.ival = OP_NULL;
5225 /* If it's none of the above, it must be a literal filehandle
5226 (<Foo::BAR> or <FOO>) so build a simple readline OP */
5228 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
5229 lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
5230 yylval.ival = OP_NULL;
5239 takes: start position in buffer
5240 returns: position to continue reading from buffer
5241 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
5242 updates the read buffer.
5244 This subroutine pulls a string out of the input. It is called for:
5245 q single quotes q(literal text)
5246 ' single quotes 'literal text'
5247 qq double quotes qq(interpolate $here please)
5248 " double quotes "interpolate $here please"
5249 qx backticks qx(/bin/ls -l)
5250 ` backticks `/bin/ls -l`
5251 qw quote words @EXPORT_OK = qw( func() $spam )
5252 m// regexp match m/this/
5253 s/// regexp substitute s/this/that/
5254 tr/// string transliterate tr/this/that/
5255 y/// string transliterate y/this/that/
5256 ($*@) sub prototypes sub foo ($)
5257 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
5259 In most of these cases (all but <>, patterns and transliterate)
5260 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
5261 calls scan_str(). s/// makes yylex() call scan_subst() which calls
5262 scan_str(). tr/// and y/// make yylex() call scan_trans() which
5265 It skips whitespace before the string starts, and treats the first
5266 character as the delimiter. If the delimiter is one of ([{< then
5267 the corresponding "close" character )]}> is used as the closing
5268 delimiter. It allows quoting of delimiters, and if the string has
5269 balanced delimiters ([{<>}]) it allows nesting.
5271 The lexer always reads these strings into lex_stuff, except in the
5272 case of the operators which take *two* arguments (s/// and tr///)
5273 when it checks to see if lex_stuff is full (presumably with the 1st
5274 arg to s or tr) and if so puts the string into lex_repl.
5279 scan_str(char *start)
5282 SV *sv; /* scalar value: string */
5283 char *tmps; /* temp string, used for delimiter matching */
5284 register char *s = start; /* current position in the buffer */
5285 register char term; /* terminating character */
5286 register char *to; /* current position in the sv's data */
5287 I32 brackets = 1; /* bracket nesting level */
5289 /* skip space before the delimiter */
5293 /* mark where we are, in case we need to report errors */
5296 /* after skipping whitespace, the next character is the terminator */
5298 /* mark where we are */
5299 multi_start = curcop->cop_line;
5302 /* find corresponding closing delimiter */
5303 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5307 /* create a new SV to hold the contents. 87 is leak category, I'm
5308 assuming. 80 is the SV's initial length. What a random number. */
5310 sv_upgrade(sv, SVt_PVIV);
5312 (void)SvPOK_only(sv); /* validate pointer */
5314 /* move past delimiter and try to read a complete string */
5317 /* extend sv if need be */
5318 SvGROW(sv, SvCUR(sv) + (bufend - s) + 1);
5319 /* set 'to' to the next character in the sv's string */
5320 to = SvPVX(sv)+SvCUR(sv);
5322 /* if open delimiter is the close delimiter read unbridle */
5323 if (multi_open == multi_close) {
5324 for (; s < bufend; s++,to++) {
5325 /* embedded newlines increment the current line number */
5326 if (*s == '\n' && !rsfp)
5328 /* handle quoted delimiters */
5329 if (*s == '\\' && s+1 < bufend && term != '\\') {
5332 /* any other quotes are simply copied straight through */
5336 /* terminate when run out of buffer (the for() condition), or
5337 have found the terminator */
5338 else if (*s == term)
5344 /* if the terminator isn't the same as the start character (e.g.,
5345 matched brackets), we have to allow more in the quoting, and
5346 be prepared for nested brackets.
5349 /* read until we run out of string, or we find the terminator */
5350 for (; s < bufend; s++,to++) {
5351 /* embedded newlines increment the line count */
5352 if (*s == '\n' && !rsfp)
5354 /* backslashes can escape the open or closing characters */
5355 if (*s == '\\' && s+1 < bufend) {
5356 if ((s[1] == multi_open) || (s[1] == multi_close))
5361 /* allow nested opens and closes */
5362 else if (*s == multi_close && --brackets <= 0)
5364 else if (*s == multi_open)
5369 /* terminate the copied string and update the sv's end-of-string */
5371 SvCUR_set(sv, to - SvPVX(sv));
5374 * this next chunk reads more into the buffer if we're not done yet
5377 if (s < bufend) break; /* handle case where we are done yet :-) */
5379 /* if we're out of file, or a read fails, bail and reset the current
5380 line marker so we can report where the unterminated string began
5383 !(oldoldbufptr = oldbufptr = s = linestart = filter_gets(linestr, rsfp, 0))) {
5385 curcop->cop_line = multi_start;
5388 /* we read a line, so increment our line counter */
5391 /* update debugger info */
5392 if (PERLDB_LINE && curstash != debstash) {
5393 SV *sv = NEWSV(88,0);
5395 sv_upgrade(sv, SVt_PVMG);
5396 sv_setsv(sv,linestr);
5397 av_store(GvAV(curcop->cop_filegv),
5398 (I32)curcop->cop_line, sv);
5401 /* having changed the buffer, we must update bufend */
5402 bufend = SvPVX(linestr) + SvCUR(linestr);
5405 /* at this point, we have successfully read the delimited string */
5407 multi_end = curcop->cop_line;
5410 /* if we allocated too much space, give some back */
5411 if (SvCUR(sv) + 5 < SvLEN(sv)) {
5412 SvLEN_set(sv, SvCUR(sv) + 1);
5413 Renew(SvPVX(sv), SvLEN(sv), char);
5416 /* decide whether this is the first or second quoted string we've read
5429 takes: pointer to position in buffer
5430 returns: pointer to new position in buffer
5431 side-effects: builds ops for the constant in yylval.op
5433 Read a number in any of the formats that Perl accepts:
5435 0(x[0-7A-F]+)|([0-7]+)
5436 [\d_]+(\.[\d_]*)?[Ee](\d+)
5438 Underbars (_) are allowed in decimal numbers. If -w is on,
5439 underbars before a decimal point must be at three digit intervals.
5441 Like most scan_ routines, it uses the tokenbuf buffer to hold the
5444 If it reads a number without a decimal point or an exponent, it will
5445 try converting the number to an integer and see if it can do so
5446 without loss of precision.
5450 scan_num(char *start)
5452 register char *s = start; /* current position in buffer */
5453 register char *d; /* destination in temp buffer */
5454 register char *e; /* end of temp buffer */
5455 I32 tryiv; /* used to see if it can be an int */
5456 double value; /* number read, as a double */
5457 SV *sv; /* place to put the converted number */
5458 I32 floatit; /* boolean: int or float? */
5459 char *lastub = 0; /* position of last underbar */
5460 static char number_too_long[] = "Number too long";
5462 /* We use the first character to decide what type of number this is */
5466 croak("panic: scan_num");
5468 /* if it starts with a 0, it could be an octal number, a decimal in
5469 0.13 disguise, or a hexadecimal number.
5474 u holds the "number so far"
5475 shift the power of 2 of the base (hex == 4, octal == 3)
5476 overflowed was the number more than we can hold?
5478 Shift is used when we add a digit. It also serves as an "are
5479 we in octal or hex?" indicator to disallow hex characters when
5484 bool overflowed = FALSE;
5491 /* check for a decimal in disguise */
5492 else if (s[1] == '.')
5494 /* so it must be octal */
5499 /* read the rest of the octal number */
5501 UV n, b; /* n is used in the overflow test, b is the digit we're adding on */
5505 /* if we don't mention it, we're done */
5514 /* 8 and 9 are not octal */
5517 yyerror("Illegal octal digit");
5521 case '0': case '1': case '2': case '3': case '4':
5522 case '5': case '6': case '7':
5523 b = *s++ & 15; /* ASCII digit -> value of digit */
5527 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
5528 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
5529 /* make sure they said 0x */
5534 /* Prepare to put the digit we have onto the end
5535 of the number so far. We check for overflows.
5539 n = u << shift; /* make room for the digit */
5540 if (!overflowed && (n >> shift) != u) {
5541 warn("Integer overflow in %s number",
5542 (shift == 4) ? "hex" : "octal");
5545 u = n | b; /* add the digit to the end */
5550 /* if we get here, we had success: make a scalar value from
5560 handle decimal numbers.
5561 we're also sent here when we read a 0 as the first digit
5563 case '1': case '2': case '3': case '4': case '5':
5564 case '6': case '7': case '8': case '9': case '.':
5567 e = tokenbuf + sizeof tokenbuf - 6; /* room for various punctuation */
5570 /* read next group of digits and _ and copy into d */
5571 while (isDIGIT(*s) || *s == '_') {
5572 /* skip underscores, checking for misplaced ones
5576 if (dowarn && lastub && s - lastub != 3)
5577 warn("Misplaced _ in number");
5581 /* check for end of fixed-length buffer */
5583 croak(number_too_long);
5584 /* if we're ok, copy the character */
5589 /* final misplaced underbar check */
5590 if (dowarn && lastub && s - lastub != 3)
5591 warn("Misplaced _ in number");
5593 /* read a decimal portion if there is one. avoid
5594 3..5 being interpreted as the number 3. followed
5597 if (*s == '.' && s[1] != '.') {
5601 /* copy, ignoring underbars, until we run out of
5602 digits. Note: no misplaced underbar checks!
5604 for (; isDIGIT(*s) || *s == '_'; s++) {
5605 /* fixed length buffer check */
5607 croak(number_too_long);
5613 /* read exponent part, if present */
5614 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
5618 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
5619 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
5621 /* allow positive or negative exponent */
5622 if (*s == '+' || *s == '-')
5625 /* read digits of exponent (no underbars :-) */
5626 while (isDIGIT(*s)) {
5628 croak(number_too_long);
5633 /* terminate the string */
5636 /* make an sv from the string */
5638 /* reset numeric locale in case we were earlier left in Swaziland */
5639 SET_NUMERIC_STANDARD();
5640 value = atof(tokenbuf);
5643 See if we can make do with an integer value without loss of
5644 precision. We use I_V to cast to an int, because some
5645 compilers have issues. Then we try casting it back and see
5646 if it was the same. We only do this if we know we
5647 specifically read an integer.
5649 Note: if floatit is true, then we don't need to do the
5653 if (!floatit && (double)tryiv == value)
5654 sv_setiv(sv, tryiv);
5656 sv_setnv(sv, value);
5660 /* make the op for the constant and return */
5662 yylval.opval = newSVOP(OP_CONST, 0, sv);
5668 scan_formline(register char *s)
5673 SV *stuff = newSVpv("",0);
5674 bool needargs = FALSE;
5677 if (*s == '.' || *s == '}') {
5679 for (t = s+1; *t == ' ' || *t == '\t'; t++) ;
5683 if (in_eval && !rsfp) {
5684 eol = strchr(s,'\n');
5689 eol = bufend = SvPVX(linestr) + SvCUR(linestr);
5691 for (t = s; t < eol; t++) {
5692 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
5694 goto enough; /* ~~ must be first line in formline */
5696 if (*t == '@' || *t == '^')
5699 sv_catpvn(stuff, s, eol-s);
5703 s = filter_gets(linestr, rsfp, 0);
5704 oldoldbufptr = oldbufptr = bufptr = linestart = SvPVX(linestr);
5705 bufend = bufptr + SvCUR(linestr);
5708 yyerror("Format not terminated");
5718 lex_state = LEX_NORMAL;
5719 nextval[nexttoke].ival = 0;
5723 lex_state = LEX_FORMLINE;
5724 nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
5726 nextval[nexttoke].ival = OP_FORMLINE;
5730 SvREFCNT_dec(stuff);
5742 cshlen = strlen(cshname);
5747 start_subparse(I32 is_format, U32 flags)
5750 I32 oldsavestack_ix = savestack_ix;
5751 CV* outsidecv = compcv;
5755 assert(SvTYPE(compcv) == SVt_PVCV);
5762 SAVESPTR(comppad_name);
5764 SAVEI32(comppad_name_fill);
5765 SAVEI32(min_intro_pending);
5766 SAVEI32(max_intro_pending);
5767 SAVEI32(pad_reset_pending);
5769 compcv = (CV*)NEWSV(1104,0);
5770 sv_upgrade((SV *)compcv, is_format ? SVt_PVFM : SVt_PVCV);
5771 CvFLAGS(compcv) |= flags;
5774 av_push(comppad, Nullsv);
5775 curpad = AvARRAY(comppad);
5776 comppad_name = newAV();
5777 comppad_name_fill = 0;
5778 min_intro_pending = 0;
5780 subline = curcop->cop_line;
5782 av_store(comppad_name, 0, newSVpv("@_", 2));
5783 curpad[0] = (SV*)newAV();
5784 SvPADMY_on(curpad[0]); /* XXX Needed? */
5785 CvOWNER(compcv) = 0;
5786 New(666, CvMUTEXP(compcv), 1, perl_mutex);
5787 MUTEX_INIT(CvMUTEXP(compcv));
5788 #endif /* USE_THREADS */
5790 comppadlist = newAV();
5791 AvREAL_off(comppadlist);
5792 av_store(comppadlist, 0, (SV*)comppad_name);
5793 av_store(comppadlist, 1, (SV*)comppad);
5795 CvPADLIST(compcv) = comppadlist;
5796 CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc(outsidecv);
5798 CvOWNER(compcv) = 0;
5799 New(666, CvMUTEXP(compcv), 1, perl_mutex);
5800 MUTEX_INIT(CvMUTEXP(compcv));
5801 #endif /* USE_THREADS */
5803 return oldsavestack_ix;
5822 char *context = NULL;
5826 if (!yychar || (yychar == ';' && !rsfp))
5828 else if (bufptr > oldoldbufptr && bufptr - oldoldbufptr < 200 &&
5829 oldoldbufptr != oldbufptr && oldbufptr != bufptr) {
5830 while (isSPACE(*oldoldbufptr))
5832 context = oldoldbufptr;
5833 contlen = bufptr - oldoldbufptr;
5835 else if (bufptr > oldbufptr && bufptr - oldbufptr < 200 &&
5836 oldbufptr != bufptr) {
5837 while (isSPACE(*oldbufptr))
5839 context = oldbufptr;
5840 contlen = bufptr - oldbufptr;
5842 else if (yychar > 255)
5843 where = "next token ???";
5844 else if ((yychar & 127) == 127) {
5845 if (lex_state == LEX_NORMAL ||
5846 (lex_state == LEX_KNOWNEXT && lex_defer == LEX_NORMAL))
5847 where = "at end of line";
5849 where = "within pattern";
5851 where = "within string";
5854 SV *where_sv = sv_2mortal(newSVpv("next char ", 0));
5856 sv_catpvf(where_sv, "^%c", toCTRL(yychar));
5857 else if (isPRINT_LC(yychar))
5858 sv_catpvf(where_sv, "%c", yychar);
5860 sv_catpvf(where_sv, "\\%03o", yychar & 255);
5861 where = SvPVX(where_sv);
5863 msg = sv_2mortal(newSVpv(s, 0));
5864 sv_catpvf(msg, " at %_ line %ld, ",
5865 GvSV(curcop->cop_filegv), (long)curcop->cop_line);
5867 sv_catpvf(msg, "near \"%.*s\"\n", contlen, context);
5869 sv_catpvf(msg, "%s\n", where);
5870 if (multi_start < multi_end && (U32)(curcop->cop_line - multi_end) <= 1) {
5872 " (Might be a runaway multi-line %c%c string starting on line %ld)\n",
5873 (int)multi_open,(int)multi_close,(long)multi_start);
5879 sv_catsv(ERRSV, msg);
5881 PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
5882 if (++error_count >= 10)
5883 croak("%_ has too many errors.\n", GvSV(curcop->cop_filegv));
5885 in_my_stash = Nullhv;