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
17 static void check_uni _((void));
18 static void force_next _((I32 type));
19 static char *force_version _((char *start));
20 static char *force_word _((char *start, int token, int check_keyword, int allow_pack, int allow_tick));
21 static SV *q _((SV *sv));
22 static char *scan_const _((char *start));
23 static char *scan_formline _((char *s));
24 static char *scan_heredoc _((char *s));
25 static char *scan_ident _((char *s, char *send, char *dest, STRLEN destlen,
27 static char *scan_inputsymbol _((char *start));
28 static char *scan_pat _((char *start));
29 static char *scan_str _((char *start));
30 static char *scan_subst _((char *start));
31 static char *scan_trans _((char *start));
32 static char *scan_word _((char *s, char *dest, STRLEN destlen,
33 int allow_package, STRLEN *slp));
34 static char *skipspace _((char *s));
35 static void checkcomma _((char *s, char *name, char *what));
36 static void force_ident _((char *s, int kind));
37 static void incline _((char *s));
38 static int intuit_method _((char *s, GV *gv));
39 static int intuit_more _((char *s));
40 static I32 lop _((I32 f, expectation x, char *s));
41 static void missingterm _((char *s));
42 static void no_op _((char *what, char *s));
43 static void set_csh _((void));
44 static I32 sublex_done _((void));
45 static I32 sublex_push _((void));
46 static I32 sublex_start _((void));
48 static int uni _((I32 f, char *s));
50 static char * filter_gets _((SV *sv, PerlIO *fp, STRLEN append));
51 static void restore_rsfp _((void *f));
52 static void restore_expect _((void *e));
53 static void restore_lex_expect _((void *e));
55 static char ident_too_long[] = "Identifier too long";
57 static char *linestart; /* beg. of most recently read line */
59 static char pending_ident; /* pending identifier lookup */
62 I32 super_state; /* lexer state to save */
63 I32 sub_inwhat; /* "lex_inwhat" to use */
64 OP *sub_op; /* "lex_op" to use */
67 /* The following are arranged oddly so that the guard on the switch statement
68 * can get by with a single comparison (if the compiler is smart enough).
71 /* #define LEX_NOTPARSING 11 is done in perl.h. */
74 #define LEX_INTERPNORMAL 9
75 #define LEX_INTERPCASEMOD 8
76 #define LEX_INTERPPUSH 7
77 #define LEX_INTERPSTART 6
78 #define LEX_INTERPEND 5
79 #define LEX_INTERPENDMAYBE 4
80 #define LEX_INTERPCONCAT 3
81 #define LEX_INTERPCONST 2
82 #define LEX_FORMLINE 1
83 #define LEX_KNOWNEXT 0
92 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
94 # include <unistd.h> /* Needed for execv() */
102 #include "keywords.h"
107 #define CLINE (copline = (curcop->cop_line < copline ? curcop->cop_line : copline))
109 #define TOKEN(retval) return (bufptr = s,(int)retval)
110 #define OPERATOR(retval) return (expect = XTERM,bufptr = s,(int)retval)
111 #define AOPERATOR(retval) return ao((expect = XTERM,bufptr = s,(int)retval))
112 #define PREBLOCK(retval) return (expect = XBLOCK,bufptr = s,(int)retval)
113 #define PRETERMBLOCK(retval) return (expect = XTERMBLOCK,bufptr = s,(int)retval)
114 #define PREREF(retval) return (expect = XREF,bufptr = s,(int)retval)
115 #define TERM(retval) return (CLINE, expect = XOPERATOR,bufptr = s,(int)retval)
116 #define LOOPX(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)LOOPEX)
117 #define FTST(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)UNIOP)
118 #define FUN0(f) return(yylval.ival = f,expect = XOPERATOR,bufptr = s,(int)FUNC0)
119 #define FUN1(f) return(yylval.ival = f,expect = XOPERATOR,bufptr = s,(int)FUNC1)
120 #define BOop(f) return ao((yylval.ival=f,expect = XTERM,bufptr = s,(int)BITOROP))
121 #define BAop(f) return ao((yylval.ival=f,expect = XTERM,bufptr = s,(int)BITANDOP))
122 #define SHop(f) return ao((yylval.ival=f,expect = XTERM,bufptr = s,(int)SHIFTOP))
123 #define PWop(f) return ao((yylval.ival=f,expect = XTERM,bufptr = s,(int)POWOP))
124 #define PMop(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)MATCHOP)
125 #define Aop(f) return ao((yylval.ival=f,expect = XTERM,bufptr = s,(int)ADDOP))
126 #define Mop(f) return ao((yylval.ival=f,expect = XTERM,bufptr = s,(int)MULOP))
127 #define Eop(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)EQOP)
128 #define Rop(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)RELOP)
130 /* This bit of chicanery makes a unary function followed by
131 * a parenthesis into a function with one argument, highest precedence.
133 #define UNI(f) return(yylval.ival = f, \
136 last_uni = oldbufptr, \
138 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
140 #define UNIBRACK(f) return(yylval.ival = f, \
142 last_uni = oldbufptr, \
143 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
145 /* grandfather return to old style */
146 #define OLDLOP(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)LSTOP)
151 if (*bufptr == '=') {
153 if (toketype == ANDAND)
154 yylval.ival = OP_ANDASSIGN;
155 else if (toketype == OROR)
156 yylval.ival = OP_ORASSIGN;
163 no_op(char *what, char *s)
165 char *oldbp = bufptr;
166 bool is_first = (oldbufptr == linestart);
169 yywarn(form("%s found where operator expected", what));
171 warn("\t(Missing semicolon on previous line?)\n");
172 else if (oldoldbufptr && isIDFIRST(*oldoldbufptr)) {
174 for (t = oldoldbufptr; *t && (isALNUM(*t) || *t == ':'); t++) ;
175 if (t < bufptr && isSPACE(*t))
176 warn("\t(Do you need to predeclare %.*s?)\n",
177 t - oldoldbufptr, oldoldbufptr);
181 warn("\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
191 char *nl = strrchr(s,'\n');
195 else if (multi_close < 32 || multi_close == 127) {
197 tmpbuf[1] = toCTRL(multi_close);
203 *tmpbuf = multi_close;
207 q = strchr(s,'"') ? '\'' : '"';
208 croak("Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
215 warn("Use of %s is deprecated", s);
221 deprecate("comma-less variable list");
227 win32_textfilter(int idx, SV *sv, int maxlen)
229 I32 count = FILTER_READ(idx+1, sv, maxlen);
230 if (count > 0 && !maxlen)
231 win32_strip_return(sv);
245 SAVEI32(lex_brackets);
246 SAVEI32(lex_fakebrack);
247 SAVEI32(lex_casemods);
252 SAVEI16(curcop->cop_line);
256 SAVEPPTR(oldoldbufptr);
259 SAVEPPTR(lex_brackstack);
260 SAVEPPTR(lex_casestack);
261 SAVEDESTRUCTOR(restore_rsfp, rsfp);
265 SAVEDESTRUCTOR(restore_expect, tokenbuf + expect); /* encode as pointer */
266 SAVEDESTRUCTOR(restore_lex_expect, tokenbuf + expect);
268 lex_state = LEX_NORMAL;
273 New(899, lex_brackstack, 120, char);
274 New(899, lex_casestack, 12, char);
275 SAVEFREEPV(lex_brackstack);
276 SAVEFREEPV(lex_casestack);
278 *lex_casestack = '\0';
286 if (SvREADONLY(linestr))
287 linestr = sv_2mortal(newSVsv(linestr));
288 s = SvPV(linestr, len);
289 if (len && s[len-1] != ';') {
290 if (!(SvFLAGS(linestr) & SVs_TEMP))
291 linestr = sv_2mortal(newSVsv(linestr));
292 sv_catpvn(linestr, "\n;", 2);
295 oldoldbufptr = oldbufptr = bufptr = linestart = SvPVX(linestr);
296 bufend = bufptr + SvCUR(linestr);
298 rs = newSVpv("\n", 1);
309 restore_rsfp(void *f)
311 PerlIO *fp = (PerlIO*)f;
313 if (rsfp == PerlIO_stdin())
314 PerlIO_clearerr(rsfp);
315 else if (rsfp && (rsfp != fp))
321 restore_expect(void *e)
323 /* a safe way to store a small integer in a pointer */
324 expect = (expectation)((char *)e - tokenbuf);
328 restore_lex_expect(void *e)
330 /* a safe way to store a small integer in a pointer */
331 lex_expect = (expectation)((char *)e - tokenbuf);
346 while (*s == ' ' || *s == '\t') s++;
347 if (strnEQ(s, "line ", 5)) {
356 while (*s == ' ' || *s == '\t')
358 if (*s == '"' && (t = strchr(s+1, '"')))
362 return; /* false alarm */
363 for (t = s; !isSPACE(*t); t++) ;
368 curcop->cop_filegv = gv_fetchfile(s);
370 curcop->cop_filegv = gv_fetchfile(origfilename);
372 curcop->cop_line = atoi(n)-1;
376 skipspace(register char *s)
379 if (lex_formbrack && lex_brackets <= lex_formbrack) {
380 while (s < bufend && (*s == ' ' || *s == '\t'))
386 while (s < bufend && isSPACE(*s))
388 if (s < bufend && *s == '#') {
389 while (s < bufend && *s != '\n')
394 if (s < bufend || !rsfp || lex_state != LEX_NORMAL)
396 if ((s = filter_gets(linestr, rsfp, (prevlen = SvCUR(linestr)))) == Nullch) {
397 if (minus_n || minus_p) {
398 sv_setpv(linestr,minus_p ?
399 ";}continue{print or die qq(-p destination: $!\\n)" :
401 sv_catpv(linestr,";}");
402 minus_n = minus_p = 0;
405 sv_setpv(linestr,";");
406 oldoldbufptr = oldbufptr = bufptr = s = linestart = SvPVX(linestr);
407 bufend = SvPVX(linestr) + SvCUR(linestr);
408 if (preprocess && !in_eval)
409 (void)PerlProc_pclose(rsfp);
410 else if ((PerlIO*)rsfp == PerlIO_stdin())
411 PerlIO_clearerr(rsfp);
413 (void)PerlIO_close(rsfp);
419 linestart = bufptr = s + prevlen;
420 bufend = s + SvCUR(linestr);
423 if (PERLDB_LINE && curstash != debstash) {
424 SV *sv = NEWSV(85,0);
426 sv_upgrade(sv, SVt_PVMG);
427 sv_setpvn(sv,bufptr,bufend-bufptr);
428 av_store(GvAV(curcop->cop_filegv),(I32)curcop->cop_line,sv);
439 if (oldoldbufptr != last_uni)
441 while (isSPACE(*last_uni))
443 for (s = last_uni; isALNUM(*s) || *s == '-'; s++) ;
444 if ((t = strchr(s, '(')) && t < bufptr)
448 warn("Warning: Use of \"%s\" without parens is ambiguous", last_uni);
455 #define UNI(f) return uni(f,s)
463 last_uni = oldbufptr;
474 #endif /* CRIPPLED_CC */
476 #define LOP(f,x) return lop(f,x,s)
479 lop(I32 f, expectation x, char *s)
486 last_lop = oldbufptr;
502 nexttype[nexttoke] = type;
504 if (lex_state != LEX_KNOWNEXT) {
505 lex_defer = lex_state;
507 lex_state = LEX_KNOWNEXT;
512 force_word(register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
517 start = skipspace(start);
520 (allow_pack && *s == ':') ||
521 (allow_initial_tick && *s == '\'') )
523 s = scan_word(s, tokenbuf, sizeof tokenbuf, allow_pack, &len);
524 if (check_keyword && keyword(tokenbuf, len))
526 if (token == METHOD) {
536 nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(tokenbuf,0));
537 nextval[nexttoke].opval->op_private |= OPpCONST_BARE;
544 force_ident(register char *s, int kind)
547 OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
548 nextval[nexttoke].opval = o;
551 dTHR; /* just for in_eval */
552 o->op_private = OPpCONST_ENTERED;
553 /* XXX see note in pp_entereval() for why we forgo typo
554 warnings if the symbol must be introduced in an eval.
556 gv_fetchpv(s, in_eval ? (GV_ADDMULTI | 8) : TRUE,
557 kind == '$' ? SVt_PV :
558 kind == '@' ? SVt_PVAV :
559 kind == '%' ? SVt_PVHV :
567 force_version(char *s)
569 OP *version = Nullop;
573 /* default VERSION number -- GBARR */
578 for( d=s, c = 1; isDIGIT(*d) || *d == '_' || (*d == '.' && c--); d++);
579 if((*d == ';' || isSPACE(*d)) && *(skipspace(d)) != ',') {
581 /* real VERSION number -- GBARR */
582 version = yylval.opval;
586 /* NOTE: The parser sees the package name and the VERSION swapped */
587 nextval[nexttoke].opval = version;
604 s = SvPV_force(sv, len);
608 while (s < send && *s != '\\')
615 if (s + 1 < send && (s[1] == '\\'))
616 s++; /* all that, just for this */
621 SvCUR_set(sv, d - SvPVX(sv));
629 register I32 op_type = yylval.ival;
631 if (op_type == OP_NULL) {
632 yylval.opval = lex_op;
636 if (op_type == OP_CONST || op_type == OP_READLINE) {
637 SV *sv = q(lex_stuff);
639 char *p = SvPV(sv, len);
640 yylval.opval = (OP*)newSVOP(op_type, 0, newSVpv(p, len));
646 sublex_info.super_state = lex_state;
647 sublex_info.sub_inwhat = op_type;
648 sublex_info.sub_op = lex_op;
649 lex_state = LEX_INTERPPUSH;
653 yylval.opval = lex_op;
667 lex_state = sublex_info.super_state;
669 SAVEI32(lex_brackets);
670 SAVEI32(lex_fakebrack);
671 SAVEI32(lex_casemods);
676 SAVEI16(curcop->cop_line);
679 SAVEPPTR(oldoldbufptr);
682 SAVEPPTR(lex_brackstack);
683 SAVEPPTR(lex_casestack);
688 bufend = bufptr = oldbufptr = oldoldbufptr = linestart = SvPVX(linestr);
689 bufend += SvCUR(linestr);
695 New(899, lex_brackstack, 120, char);
696 New(899, lex_casestack, 12, char);
697 SAVEFREEPV(lex_brackstack);
698 SAVEFREEPV(lex_casestack);
700 *lex_casestack = '\0';
702 lex_state = LEX_INTERPCONCAT;
703 curcop->cop_line = multi_start;
705 lex_inwhat = sublex_info.sub_inwhat;
706 if (lex_inwhat == OP_MATCH || lex_inwhat == OP_SUBST)
707 lex_inpat = sublex_info.sub_op;
719 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv("",0));
723 if (lex_casemods) { /* oops, we've got some unbalanced parens */
724 lex_state = LEX_INTERPCASEMOD;
728 /* Is there a right-hand side to take care of? */
729 if (lex_repl && (lex_inwhat == OP_SUBST || lex_inwhat == OP_TRANS)) {
732 bufend = bufptr = oldbufptr = oldoldbufptr = linestart = SvPVX(linestr);
733 bufend += SvCUR(linestr);
739 *lex_casestack = '\0';
741 if (SvCOMPILED(lex_repl)) {
742 lex_state = LEX_INTERPNORMAL;
746 lex_state = LEX_INTERPCONCAT;
752 bufend = SvPVX(linestr);
753 bufend += SvCUR(linestr);
762 Extracts a pattern, double-quoted string, or transliteration. This
765 It looks at lex_inwhat and lex_inpat to find out whether it's
766 processing a pattern (lex_inpat is true), a transliteration
767 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
771 double-quoted style: \r and \n
772 regexp special ones: \D \s
774 backrefs: \1 (deprecated in substitution replacements)
775 case and quoting: \U \Q \E
776 stops on @ and $, but not for $ as tail anchor
779 characters are VERY literal, except for - not at the start or end
780 of the string, which indicates a range. scan_const expands the
781 range to the full set of intermediate characters.
783 In double-quoted strings:
785 double-quoted style: \r and \n
787 backrefs: \1 (deprecated)
788 case and quoting: \U \Q \E
791 scan_const does *not* construct ops to handle interpolated strings.
792 It stops processing as soon as it finds an embedded $ or @ variable
793 and leaves it to the caller to work out what's going on.
795 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
797 $ in pattern could be $foo or could be tail anchor. Assumption:
798 it's a tail anchor if $ is the last thing in the string, or if it's
799 followed by one of ")| \n\t"
801 \1 (backreferences) are turned into $1
803 The structure of the code is
804 while (there's a character to process) {
805 handle transliteration ranges
807 skip # initiated comments in //x patterns
808 check for embedded @foo
809 check for embedded scalars
811 leave intact backslashes from leave (below)
812 deprecate \1 in strings and sub replacements
813 handle string-changing backslashes \l \U \Q \E, etc.
814 switch (what was escaped) {
815 handle - in a transliteration (becomes a literal -)
816 handle \132 octal characters
817 handle 0x15 hex characters
818 handle \cV (control V)
819 handle printf backslashes (\f, \r, \n, etc)
822 } (end while character to read)
827 scan_const(char *start)
829 register char *send = bufend; /* end of the constant */
830 SV *sv = NEWSV(93, send - start); /* sv for the constant */
831 register char *s = start; /* start of the constant */
832 register char *d = SvPVX(sv); /* destination for copies */
833 bool dorange = FALSE; /* are we in a translit range? */
837 leave is the set of acceptably-backslashed characters.
839 I do *not* understand why there's the double hook here.
843 ? "\\.^$@AGZdDwWsSbB+*?|()-nrtfeaxc0123456789[{]} \t\n\r\f\v#"
844 : (lex_inwhat & OP_TRANS)
848 while (s < send || dorange) {
849 /* get transliterations out of the way (they're most literal) */
850 if (lex_inwhat == OP_TRANS) {
851 /* expand a range A-Z to the full set of characters. AIE! */
853 I32 i; /* current expanded character */
854 I32 max; /* last character in range */
856 i = d - SvPVX(sv); /* remember current offset */
857 SvGROW(sv, SvLEN(sv) + 256); /* expand the sv -- there'll never be more'n 256 chars in a range for it to grow by */
858 d = SvPVX(sv) + i; /* restore d after the grow potentially has changed the ptr */
859 d -= 2; /* eat the first char and the - */
861 max = (U8)d[1]; /* last char in range */
863 for (i = (U8)*d; i <= max; i++)
866 /* mark the range as done, and continue */
871 /* range begins (ignore - as first or last char) */
872 else if (*s == '-' && s+1 < send && s != start) {
878 /* if we get here, we're not doing a transliteration */
880 /* skip for regexp comments /(?#comment)/ */
881 else if (*s == '(' && lex_inpat && s[1] == '?') {
883 while (s < send && *s != ')')
885 } else if (s[2] == '{') { /* This should march regcomp.c */
887 char *regparse = s + 3;
890 while (count && (c = *regparse)) {
891 if (c == '\\' && regparse[1])
899 if (*regparse == ')')
902 yyerror("Sequence (?{...}) not terminated or not {}-balanced");
903 while (s < regparse && *s != ')')
908 /* likewise skip #-initiated comments in //x patterns */
909 else if (*s == '#' && lex_inpat &&
910 ((PMOP*)lex_inpat)->op_pmflags & PMf_EXTENDED) {
911 while (s+1 < send && *s != '\n')
915 /* check for embedded arrays (@foo, @:foo, @'foo, @{foo}, @$foo) */
916 else if (*s == '@' && s[1] && (isALNUM(s[1]) || strchr(":'{$", s[1])))
919 /* check for embedded scalars. only stop if we're sure it's a
922 else if (*s == '$') {
923 if (!lex_inpat) /* not a regexp, so $ must be var */
925 if (s + 1 < send && !strchr("()| \n\t", s[1]))
926 break; /* in regexp, $ might be tail anchor */
930 if (*s == '\\' && s+1 < send) {
933 /* some backslashes we leave behind */
934 if (*s && strchr(leaveit, *s)) {
940 /* deprecate \1 in strings and substitution replacements */
941 if (lex_inwhat == OP_SUBST && !lex_inpat &&
942 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
945 warn("\\%c better written as $%c", *s, *s);
950 /* string-change backslash escapes */
951 if (lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
956 /* if we get here, it's either a quoted -, or a digit */
959 /* quoted - in transliterations */
961 if (lex_inwhat == OP_TRANS) {
966 /* default action is to copy the quoted character */
971 /* \132 indicates an octal constant */
972 case '0': case '1': case '2': case '3':
973 case '4': case '5': case '6': case '7':
974 *d++ = scan_oct(s, 3, &len);
978 /* \x24 indicates a hex constant */
980 *d++ = scan_hex(++s, 2, &len);
984 /* \c is a control character */
991 /* printf-style backslashes, formfeeds, newlines, etc */
1017 } /* end if (backslash) */
1020 } /* while loop to process each character */
1022 /* terminate the string and set up the sv */
1024 SvCUR_set(sv, d - SvPVX(sv));
1027 /* shrink the sv if we allocated more than we used */
1028 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1029 SvLEN_set(sv, SvCUR(sv) + 1);
1030 Renew(SvPVX(sv), SvLEN(sv), char);
1035 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1041 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1043 intuit_more(register char *s)
1047 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1049 if (*s != '{' && *s != '[')
1054 /* In a pattern, so maybe we have {n,m}. */
1071 /* On the other hand, maybe we have a character class */
1074 if (*s == ']' || *s == '^')
1077 int weight = 2; /* let's weigh the evidence */
1079 unsigned char un_char = 0, last_un_char;
1080 char *send = strchr(s,']');
1081 char tmpbuf[sizeof tokenbuf * 4];
1083 if (!send) /* has to be an expression */
1086 Zero(seen,256,char);
1089 else if (isDIGIT(*s)) {
1091 if (isDIGIT(s[1]) && s[2] == ']')
1097 for (; s < send; s++) {
1098 last_un_char = un_char;
1099 un_char = (unsigned char)*s;
1104 weight -= seen[un_char] * 10;
1105 if (isALNUM(s[1])) {
1106 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1107 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1112 else if (*s == '$' && s[1] &&
1113 strchr("[#!%*<>()-=",s[1])) {
1114 if (/*{*/ strchr("])} =",s[2]))
1123 if (strchr("wds]",s[1]))
1125 else if (seen['\''] || seen['"'])
1127 else if (strchr("rnftbxcav",s[1]))
1129 else if (isDIGIT(s[1])) {
1131 while (s[1] && isDIGIT(s[1]))
1141 if (strchr("aA01! ",last_un_char))
1143 if (strchr("zZ79~",s[1]))
1147 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1148 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1153 if (keyword(tmpbuf, d - tmpbuf))
1156 if (un_char == last_un_char + 1)
1158 weight -= seen[un_char];
1163 if (weight >= 0) /* probably a character class */
1171 intuit_method(char *start, GV *gv)
1173 char *s = start + (*start == '$');
1174 char tmpbuf[sizeof tokenbuf];
1182 if ((cv = GvCVu(gv))) {
1183 char *proto = SvPVX(cv);
1193 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1194 if (*start == '$') {
1195 if (gv || last_lop_op == OP_PRINT || isUPPER(*tokenbuf))
1200 return *s == '(' ? FUNCMETH : METHOD;
1202 if (!keyword(tmpbuf, len)) {
1203 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1208 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1209 if (indirgv && GvCVu(indirgv))
1211 /* filehandle or package name makes it a method */
1212 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1214 if ((bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1215 return 0; /* no assumptions -- "=>" quotes bearword */
1217 nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1219 nextval[nexttoke].opval->op_private = OPpCONST_BARE;
1223 return *s == '(' ? FUNCMETH : METHOD;
1233 char *pdb = PerlEnv_getenv("PERL5DB");
1237 SETERRNO(0,SS$_NORMAL);
1238 return "BEGIN { require 'perl5db.pl' }";
1244 /* Encoded script support. filter_add() effectively inserts a
1245 * 'pre-processing' function into the current source input stream.
1246 * Note that the filter function only applies to the current source file
1247 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1249 * The datasv parameter (which may be NULL) can be used to pass
1250 * private data to this instance of the filter. The filter function
1251 * can recover the SV using the FILTER_DATA macro and use it to
1252 * store private buffers and state information.
1254 * The supplied datasv parameter is upgraded to a PVIO type
1255 * and the IoDIRP field is used to store the function pointer.
1256 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1257 * private use must be set using malloc'd pointers.
1259 static int filter_debug = 0;
1262 filter_add(filter_t funcp, SV *datasv)
1264 if (!funcp){ /* temporary handy debugging hack to be deleted */
1265 filter_debug = atoi((char*)datasv);
1269 rsfp_filters = newAV();
1271 datasv = NEWSV(255,0);
1272 if (!SvUPGRADE(datasv, SVt_PVIO))
1273 die("Can't upgrade filter_add data to SVt_PVIO");
1274 IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
1276 warn("filter_add func %p (%s)", funcp, SvPV(datasv,na));
1277 av_unshift(rsfp_filters, 1);
1278 av_store(rsfp_filters, 0, datasv) ;
1283 /* Delete most recently added instance of this filter function. */
1285 filter_del(filter_t funcp)
1288 warn("filter_del func %p", funcp);
1289 if (!rsfp_filters || AvFILLp(rsfp_filters)<0)
1291 /* if filter is on top of stack (usual case) just pop it off */
1292 if (IoDIRP(FILTER_DATA(AvFILLp(rsfp_filters))) == (void*)funcp){
1293 sv_free(av_pop(rsfp_filters));
1297 /* we need to search for the correct entry and clear it */
1298 die("filter_del can only delete in reverse order (currently)");
1302 /* Invoke the n'th filter function for the current rsfp. */
1304 filter_read(int idx, SV *buf_sv, int maxlen)
1307 /* 0 = read one text line */
1314 if (idx > AvFILLp(rsfp_filters)){ /* Any more filters? */
1315 /* Provide a default input filter to make life easy. */
1316 /* Note that we append to the line. This is handy. */
1318 warn("filter_read %d: from rsfp\n", idx);
1322 int old_len = SvCUR(buf_sv) ;
1324 /* ensure buf_sv is large enough */
1325 SvGROW(buf_sv, old_len + maxlen) ;
1326 if ((len = PerlIO_read(rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1327 if (PerlIO_error(rsfp))
1328 return -1; /* error */
1330 return 0 ; /* end of file */
1332 SvCUR_set(buf_sv, old_len + len) ;
1335 if (sv_gets(buf_sv, rsfp, SvCUR(buf_sv)) == NULL) {
1336 if (PerlIO_error(rsfp))
1337 return -1; /* error */
1339 return 0 ; /* end of file */
1342 return SvCUR(buf_sv);
1344 /* Skip this filter slot if filter has been deleted */
1345 if ( (datasv = FILTER_DATA(idx)) == &sv_undef){
1347 warn("filter_read %d: skipped (filter deleted)\n", idx);
1348 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1350 /* Get function pointer hidden within datasv */
1351 funcp = (filter_t)IoDIRP(datasv);
1353 warn("filter_read %d: via function %p (%s)\n",
1354 idx, funcp, SvPV(datasv,na));
1355 /* Call function. The function is expected to */
1356 /* call "FILTER_READ(idx+1, buf_sv)" first. */
1357 /* Return: <0:error, =0:eof, >0:not eof */
1358 return (*funcp)(idx, buf_sv, maxlen);
1362 filter_gets(register SV *sv, register PerlIO *fp, STRLEN append)
1365 if (!rsfp_filters) {
1366 filter_add(win32_textfilter,NULL);
1372 SvCUR_set(sv, 0); /* start with empty line */
1373 if (FILTER_READ(0, sv, 0) > 0)
1374 return ( SvPVX(sv) ) ;
1379 return (sv_gets(sv, fp, append));
1384 static char* exp_name[] =
1385 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "TERMBLOCK" };
1388 EXT int yychar; /* last token */
1393 Works out what to call the token just pulled out of the input
1394 stream. The yacc parser takes care of taking the ops we return and
1395 stitching them into a tree.
1401 if read an identifier
1402 if we're in a my declaration
1403 croak if they tried to say my($foo::bar)
1404 build the ops for a my() declaration
1405 if it's an access to a my() variable
1406 are we in a sort block?
1407 croak if my($a); $a <=> $b
1408 build ops for access to a my() variable
1409 if in a dq string, and they've said @foo and we can't find @foo
1411 build ops for a bareword
1412 if we already built the token before, use it.
1426 /* check if there's an identifier for us to look at */
1427 if (pending_ident) {
1428 /* pit holds the identifier we read and pending_ident is reset */
1429 char pit = pending_ident;
1432 /* if we're in a my(), we can't allow dynamics here.
1433 $foo'bar has already been turned into $foo::bar, so
1434 just check for colons.
1436 if it's a legal name, the OP is a PADANY.
1439 if (strchr(tokenbuf,':'))
1440 croak(no_myglob,tokenbuf);
1442 yylval.opval = newOP(OP_PADANY, 0);
1443 yylval.opval->op_targ = pad_allocmy(tokenbuf);
1448 build the ops for accesses to a my() variable.
1450 Deny my($a) or my($b) in a sort block, *if* $a or $b is
1451 then used in a comparison. This catches most, but not
1452 all cases. For instance, it catches
1453 sort { my($a); $a <=> $b }
1455 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
1456 (although why you'd do that is anyone's guess).
1459 if (!strchr(tokenbuf,':')) {
1461 /* Check for single character per-thread SVs */
1462 if (tokenbuf[0] == '$' && tokenbuf[2] == '\0'
1463 && !isALPHA(tokenbuf[1]) /* Rule out obvious non-threadsvs */
1464 && (tmp = find_threadsv(&tokenbuf[1])) != NOT_IN_PAD)
1466 yylval.opval = newOP(OP_THREADSV, 0);
1467 yylval.opval->op_targ = tmp;
1470 #endif /* USE_THREADS */
1471 if ((tmp = pad_findmy(tokenbuf)) != NOT_IN_PAD) {
1472 /* if it's a sort block and they're naming $a or $b */
1473 if (last_lop_op == OP_SORT &&
1474 tokenbuf[0] == '$' &&
1475 (tokenbuf[1] == 'a' || tokenbuf[1] == 'b')
1478 for (d = in_eval ? oldoldbufptr : linestart;
1479 d < bufend && *d != '\n';
1482 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
1483 croak("Can't use \"my %s\" in sort comparison",
1489 yylval.opval = newOP(OP_PADANY, 0);
1490 yylval.opval->op_targ = tmp;
1496 Whine if they've said @foo in a doublequoted string,
1497 and @foo isn't a variable we can find in the symbol
1500 if (pit == '@' && lex_state != LEX_NORMAL && !lex_brackets) {
1501 GV *gv = gv_fetchpv(tokenbuf+1, FALSE, SVt_PVAV);
1502 if (!gv || ((tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
1503 yyerror(form("In string, %s now must be written as \\%s",
1504 tokenbuf, tokenbuf));
1507 /* build ops for a bareword */
1508 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(tokenbuf+1, 0));
1509 yylval.opval->op_private = OPpCONST_ENTERED;
1510 gv_fetchpv(tokenbuf+1, in_eval ? (GV_ADDMULTI | 8) : TRUE,
1511 ((tokenbuf[0] == '$') ? SVt_PV
1512 : (tokenbuf[0] == '@') ? SVt_PVAV
1517 /* no identifier pending identification */
1519 switch (lex_state) {
1521 case LEX_NORMAL: /* Some compilers will produce faster */
1522 case LEX_INTERPNORMAL: /* code if we comment these out. */
1526 /* when we're already built the next token, just pull it out the queue */
1529 yylval = nextval[nexttoke];
1531 lex_state = lex_defer;
1532 expect = lex_expect;
1533 lex_defer = LEX_NORMAL;
1535 return(nexttype[nexttoke]);
1537 /* interpolated case modifiers like \L \U, including \Q and \E.
1538 when we get here, bufptr is at the \
1540 case LEX_INTERPCASEMOD:
1542 if (bufptr != bufend && *bufptr != '\\')
1543 croak("panic: INTERPCASEMOD");
1545 /* handle \E or end of string */
1546 if (bufptr == bufend || bufptr[1] == 'E') {
1551 oldmod = lex_casestack[--lex_casemods];
1552 lex_casestack[lex_casemods] = '\0';
1554 if (bufptr != bufend && strchr("LUQ", oldmod)) {
1556 lex_state = LEX_INTERPCONCAT;
1560 if (bufptr != bufend)
1562 lex_state = LEX_INTERPCONCAT;
1567 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
1568 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
1569 if (strchr("LU", *s) &&
1570 (strchr(lex_casestack, 'L') || strchr(lex_casestack, 'U')))
1572 lex_casestack[--lex_casemods] = '\0';
1575 if (lex_casemods > 10) {
1576 char* newlb = Renew(lex_casestack, lex_casemods + 2, char);
1577 if (newlb != lex_casestack) {
1579 lex_casestack = newlb;
1582 lex_casestack[lex_casemods++] = *s;
1583 lex_casestack[lex_casemods] = '\0';
1584 lex_state = LEX_INTERPCONCAT;
1585 nextval[nexttoke].ival = 0;
1588 nextval[nexttoke].ival = OP_LCFIRST;
1590 nextval[nexttoke].ival = OP_UCFIRST;
1592 nextval[nexttoke].ival = OP_LC;
1594 nextval[nexttoke].ival = OP_UC;
1596 nextval[nexttoke].ival = OP_QUOTEMETA;
1598 croak("panic: yylex");
1610 case LEX_INTERPPUSH:
1611 return sublex_push();
1613 case LEX_INTERPSTART:
1614 if (bufptr == bufend)
1615 return sublex_done();
1617 lex_dojoin = (*bufptr == '@');
1618 lex_state = LEX_INTERPNORMAL;
1620 nextval[nexttoke].ival = 0;
1623 nextval[nexttoke].opval = newOP(OP_THREADSV, 0);
1624 nextval[nexttoke].opval->op_targ = find_threadsv("\"");
1625 force_next(PRIVATEREF);
1627 force_ident("\"", '$');
1628 #endif /* USE_THREADS */
1629 nextval[nexttoke].ival = 0;
1631 nextval[nexttoke].ival = 0;
1633 nextval[nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
1642 case LEX_INTERPENDMAYBE:
1643 if (intuit_more(bufptr)) {
1644 lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
1652 lex_state = LEX_INTERPCONCAT;
1656 case LEX_INTERPCONCAT:
1659 croak("panic: INTERPCONCAT");
1661 if (bufptr == bufend)
1662 return sublex_done();
1664 if (SvIVX(linestr) == '\'') {
1665 SV *sv = newSVsv(linestr);
1668 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1672 s = scan_const(bufptr);
1674 lex_state = LEX_INTERPCASEMOD;
1676 lex_state = LEX_INTERPSTART;
1680 nextval[nexttoke] = yylval;
1693 lex_state = LEX_NORMAL;
1694 s = scan_formline(bufptr);
1701 oldoldbufptr = oldbufptr;
1704 PerlIO_printf(PerlIO_stderr(), "### Tokener expecting %s at %s\n", exp_name[expect], s);
1710 croak("Unrecognized character \\%03o", *s & 255);
1713 goto fake_eof; /* emulate EOF on ^D or ^Z */
1719 yyerror("Missing right bracket");
1723 goto retry; /* ignore stray nulls */
1726 if (!in_eval && !preambled) {
1728 sv_setpv(linestr,incl_perldb());
1730 sv_catpv(linestr,";");
1732 while(AvFILLp(preambleav) >= 0) {
1733 SV *tmpsv = av_shift(preambleav);
1734 sv_catsv(linestr, tmpsv);
1735 sv_catpv(linestr, ";");
1738 sv_free((SV*)preambleav);
1741 if (minus_n || minus_p) {
1742 sv_catpv(linestr, "LINE: while (<>) {");
1744 sv_catpv(linestr,"chomp;");
1746 GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
1748 GvIMPORTED_AV_on(gv);
1750 if (strchr("/'\"", *splitstr)
1751 && strchr(splitstr + 1, *splitstr))
1752 sv_catpvf(linestr, "@F=split(%s);", splitstr);
1755 s = "'~#\200\1'"; /* surely one char is unused...*/
1756 while (s[1] && strchr(splitstr, *s)) s++;
1758 sv_catpvf(linestr, "@F=split(%s%c",
1759 "q" + (delim == '\''), delim);
1760 for (s = splitstr; *s; s++) {
1762 sv_catpvn(linestr, "\\", 1);
1763 sv_catpvn(linestr, s, 1);
1765 sv_catpvf(linestr, "%c);", delim);
1769 sv_catpv(linestr,"@F=split(' ');");
1772 sv_catpv(linestr, "\n");
1773 oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr);
1774 bufend = SvPVX(linestr) + SvCUR(linestr);
1775 if (PERLDB_LINE && curstash != debstash) {
1776 SV *sv = NEWSV(85,0);
1778 sv_upgrade(sv, SVt_PVMG);
1779 sv_setsv(sv,linestr);
1780 av_store(GvAV(curcop->cop_filegv),(I32)curcop->cop_line,sv);
1785 if ((s = filter_gets(linestr, rsfp, 0)) == Nullch) {
1788 if (preprocess && !in_eval)
1789 (void)PerlProc_pclose(rsfp);
1790 else if ((PerlIO *)rsfp == PerlIO_stdin())
1791 PerlIO_clearerr(rsfp);
1793 (void)PerlIO_close(rsfp);
1798 if (!in_eval && (minus_n || minus_p)) {
1799 sv_setpv(linestr,minus_p ? ";}continue{print" : "");
1800 sv_catpv(linestr,";}");
1801 oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr);
1802 bufend = SvPVX(linestr) + SvCUR(linestr);
1803 minus_n = minus_p = 0;
1806 oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr);
1807 sv_setpv(linestr,"");
1808 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
1811 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
1814 /* Incest with pod. */
1815 if (*s == '=' && strnEQ(s, "=cut", 4)) {
1816 sv_setpv(linestr, "");
1817 oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr);
1818 bufend = SvPVX(linestr) + SvCUR(linestr);
1823 } while (doextract);
1824 oldoldbufptr = oldbufptr = bufptr = linestart = s;
1825 if (PERLDB_LINE && curstash != debstash) {
1826 SV *sv = NEWSV(85,0);
1828 sv_upgrade(sv, SVt_PVMG);
1829 sv_setsv(sv,linestr);
1830 av_store(GvAV(curcop->cop_filegv),(I32)curcop->cop_line,sv);
1832 bufend = SvPVX(linestr) + SvCUR(linestr);
1833 if (curcop->cop_line == 1) {
1834 while (s < bufend && isSPACE(*s))
1836 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
1840 if (*s == '#' && *(s+1) == '!')
1842 #ifdef ALTERNATE_SHEBANG
1844 static char as[] = ALTERNATE_SHEBANG;
1845 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
1846 d = s + (sizeof(as) - 1);
1848 #endif /* ALTERNATE_SHEBANG */
1857 while (*d && !isSPACE(*d))
1861 #ifdef ARG_ZERO_IS_SCRIPT
1862 if (ipathend > ipath) {
1864 * HP-UX (at least) sets argv[0] to the script name,
1865 * which makes $^X incorrect. And Digital UNIX and Linux,
1866 * at least, set argv[0] to the basename of the Perl
1867 * interpreter. So, having found "#!", we'll set it right.
1869 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
1870 assert(SvPOK(x) || SvGMAGICAL(x));
1871 if (sv_eq(x, GvSV(curcop->cop_filegv))) {
1872 sv_setpvn(x, ipath, ipathend - ipath);
1875 TAINT_NOT; /* $^X is always tainted, but that's OK */
1877 #endif /* ARG_ZERO_IS_SCRIPT */
1882 d = instr(s,"perl -");
1884 d = instr(s,"perl");
1885 #ifdef ALTERNATE_SHEBANG
1887 * If the ALTERNATE_SHEBANG on this system starts with a
1888 * character that can be part of a Perl expression, then if
1889 * we see it but not "perl", we're probably looking at the
1890 * start of Perl code, not a request to hand off to some
1891 * other interpreter. Similarly, if "perl" is there, but
1892 * not in the first 'word' of the line, we assume the line
1893 * contains the start of the Perl program.
1895 if (d && *s != '#') {
1897 while (*c && !strchr("; \t\r\n\f\v#", *c))
1900 d = Nullch; /* "perl" not in first word; ignore */
1902 *s = '#'; /* Don't try to parse shebang line */
1904 #endif /* ALTERNATE_SHEBANG */
1909 !instr(s,"indir") &&
1910 instr(origargv[0],"perl"))
1916 while (s < bufend && isSPACE(*s))
1919 Newz(899,newargv,origargc+3,char*);
1921 while (s < bufend && !isSPACE(*s))
1924 Copy(origargv+1, newargv+2, origargc+1, char*);
1929 execv(ipath, newargv);
1930 croak("Can't exec %s", ipath);
1933 U32 oldpdb = perldb;
1934 bool oldn = minus_n;
1935 bool oldp = minus_p;
1937 while (*d && !isSPACE(*d)) d++;
1938 while (*d == ' ' || *d == '\t') d++;
1942 if (*d == 'M' || *d == 'm') {
1944 while (*d && !isSPACE(*d)) d++;
1945 croak("Too late for \"-%.*s\" option",
1948 d = moreswitches(d);
1950 if (PERLDB_LINE && !oldpdb ||
1951 ( minus_n || minus_p ) && !(oldn || oldp) )
1952 /* if we have already added "LINE: while (<>) {",
1953 we must not do it again */
1955 sv_setpv(linestr, "");
1956 oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr);
1957 bufend = SvPVX(linestr) + SvCUR(linestr);
1960 (void)gv_fetchfile(origfilename);
1967 if (lex_formbrack && lex_brackets <= lex_formbrack) {
1969 lex_state = LEX_FORMLINE;
1975 warn("Illegal character \\%03o (carriage return)", '\r');
1977 "(Maybe you didn't strip carriage returns after a network transfer?)\n");
1979 case ' ': case '\t': case '\f': case 013:
1984 if (lex_state != LEX_NORMAL || (in_eval && !rsfp)) {
1986 while (s < d && *s != '\n')
1991 if (lex_formbrack && lex_brackets <= lex_formbrack) {
1993 lex_state = LEX_FORMLINE;
2003 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2008 while (s < bufend && (*s == ' ' || *s == '\t'))
2011 if (strnEQ(s,"=>",2)) {
2012 s = force_word(bufptr,WORD,FALSE,FALSE,FALSE);
2013 OPERATOR('-'); /* unary minus */
2015 last_uni = oldbufptr;
2016 last_lop_op = OP_FTEREAD; /* good enough */
2018 case 'r': FTST(OP_FTEREAD);
2019 case 'w': FTST(OP_FTEWRITE);
2020 case 'x': FTST(OP_FTEEXEC);
2021 case 'o': FTST(OP_FTEOWNED);
2022 case 'R': FTST(OP_FTRREAD);
2023 case 'W': FTST(OP_FTRWRITE);
2024 case 'X': FTST(OP_FTREXEC);
2025 case 'O': FTST(OP_FTROWNED);
2026 case 'e': FTST(OP_FTIS);
2027 case 'z': FTST(OP_FTZERO);
2028 case 's': FTST(OP_FTSIZE);
2029 case 'f': FTST(OP_FTFILE);
2030 case 'd': FTST(OP_FTDIR);
2031 case 'l': FTST(OP_FTLINK);
2032 case 'p': FTST(OP_FTPIPE);
2033 case 'S': FTST(OP_FTSOCK);
2034 case 'u': FTST(OP_FTSUID);
2035 case 'g': FTST(OP_FTSGID);
2036 case 'k': FTST(OP_FTSVTX);
2037 case 'b': FTST(OP_FTBLK);
2038 case 'c': FTST(OP_FTCHR);
2039 case 't': FTST(OP_FTTTY);
2040 case 'T': FTST(OP_FTTEXT);
2041 case 'B': FTST(OP_FTBINARY);
2042 case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2043 case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2044 case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
2046 croak("Unrecognized file test: -%c", (int)tmp);
2053 if (expect == XOPERATOR)
2058 else if (*s == '>') {
2061 if (isIDFIRST(*s)) {
2062 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2070 if (expect == XOPERATOR)
2073 if (isSPACE(*s) || !isSPACE(*bufptr))
2075 OPERATOR('-'); /* unary minus */
2082 if (expect == XOPERATOR)
2087 if (expect == XOPERATOR)
2090 if (isSPACE(*s) || !isSPACE(*bufptr))
2096 if (expect != XOPERATOR) {
2097 s = scan_ident(s, bufend, tokenbuf, sizeof tokenbuf, TRUE);
2099 force_ident(tokenbuf, '*');
2112 if (expect == XOPERATOR) {
2117 s = scan_ident(s, bufend, tokenbuf + 1, sizeof tokenbuf - 1, TRUE);
2120 yyerror("Final % should be \\% or %name");
2123 pending_ident = '%';
2145 if (last_lop == oldoldbufptr || last_uni == oldoldbufptr)
2146 oldbufptr = oldoldbufptr; /* allow print(STDOUT 123) */
2151 if (curcop->cop_line < copline)
2152 copline = curcop->cop_line;
2163 if (lex_brackets <= 0)
2164 yyerror("Unmatched right bracket");
2167 if (lex_state == LEX_INTERPNORMAL) {
2168 if (lex_brackets == 0) {
2169 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
2170 lex_state = LEX_INTERPEND;
2177 if (lex_brackets > 100) {
2178 char* newlb = Renew(lex_brackstack, lex_brackets + 1, char);
2179 if (newlb != lex_brackstack) {
2181 lex_brackstack = newlb;
2186 if (lex_formbrack) {
2190 if (oldoldbufptr == last_lop)
2191 lex_brackstack[lex_brackets++] = XTERM;
2193 lex_brackstack[lex_brackets++] = XOPERATOR;
2194 OPERATOR(HASHBRACK);
2196 while (s < bufend && (*s == ' ' || *s == '\t'))
2200 if (d < bufend && *d == '-') {
2203 while (d < bufend && (*d == ' ' || *d == '\t'))
2206 if (d < bufend && isIDFIRST(*d)) {
2207 d = scan_word(d, tokenbuf + 1, sizeof tokenbuf - 1,
2209 while (d < bufend && (*d == ' ' || *d == '\t'))
2212 char minus = (tokenbuf[0] == '-');
2213 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2220 lex_brackstack[lex_brackets++] = XSTATE;
2224 lex_brackstack[lex_brackets++] = XOPERATOR;
2229 if (oldoldbufptr == last_lop)
2230 lex_brackstack[lex_brackets++] = XTERM;
2232 lex_brackstack[lex_brackets++] = XOPERATOR;
2235 if (expect == XSTATE) {
2236 lex_brackstack[lex_brackets-1] = XSTATE;
2239 OPERATOR(HASHBRACK);
2241 /* This hack serves to disambiguate a pair of curlies
2242 * as being a block or an anon hash. Normally, expectation
2243 * determines that, but in cases where we're not in a
2244 * position to expect anything in particular (like inside
2245 * eval"") we have to resolve the ambiguity. This code
2246 * covers the case where the first term in the curlies is a
2247 * quoted string. Most other cases need to be explicitly
2248 * disambiguated by prepending a `+' before the opening
2249 * curly in order to force resolution as an anon hash.
2251 * XXX should probably propagate the outer expectation
2252 * into eval"" to rely less on this hack, but that could
2253 * potentially break current behavior of eval"".
2257 if (*s == '\'' || *s == '"' || *s == '`') {
2258 /* common case: get past first string, handling escapes */
2259 for (t++; t < bufend && *t != *s;)
2260 if (*t++ == '\\' && (*t == '\\' || *t == *s))
2264 else if (*s == 'q') {
2267 || ((*t == 'q' || *t == 'x') && ++t < bufend
2268 && !isALNUM(*t)))) {
2270 char open, close, term;
2273 while (t < bufend && isSPACE(*t))
2277 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
2281 for (t++; t < bufend; t++) {
2282 if (*t == '\\' && t+1 < bufend && open != '\\')
2284 else if (*t == open)
2288 for (t++; t < bufend; t++) {
2289 if (*t == '\\' && t+1 < bufend)
2291 else if (*t == close && --brackets <= 0)
2293 else if (*t == open)
2299 else if (isALPHA(*s)) {
2300 for (t++; t < bufend && isALNUM(*t); t++) ;
2302 while (t < bufend && isSPACE(*t))
2304 /* if comma follows first term, call it an anon hash */
2305 /* XXX it could be a comma expression with loop modifiers */
2306 if (t < bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
2307 || (*t == '=' && t[1] == '>')))
2308 OPERATOR(HASHBRACK);
2312 lex_brackstack[lex_brackets-1] = XSTATE;
2318 yylval.ival = curcop->cop_line;
2319 if (isSPACE(*s) || *s == '#')
2320 copline = NOLINE; /* invalidate current command line number */
2325 if (lex_brackets <= 0)
2326 yyerror("Unmatched right bracket");
2328 expect = (expectation)lex_brackstack[--lex_brackets];
2329 if (lex_brackets < lex_formbrack)
2331 if (lex_state == LEX_INTERPNORMAL) {
2332 if (lex_brackets == 0) {
2333 if (lex_fakebrack) {
2334 lex_state = LEX_INTERPEND;
2336 return yylex(); /* ignore fake brackets */
2338 if (*s == '-' && s[1] == '>')
2339 lex_state = LEX_INTERPENDMAYBE;
2340 else if (*s != '[' && *s != '{')
2341 lex_state = LEX_INTERPEND;
2344 if (lex_brackets < lex_fakebrack) {
2347 return yylex(); /* ignore fake brackets */
2357 if (expect == XOPERATOR) {
2358 if (dowarn && isALPHA(*s) && bufptr == linestart) {
2366 s = scan_ident(s - 1, bufend, tokenbuf, sizeof tokenbuf, TRUE);
2369 force_ident(tokenbuf, '&');
2373 yylval.ival = (OPpENTERSUB_AMPER<<8);
2392 if (dowarn && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
2393 warn("Reversed %c= operator",(int)tmp);
2395 if (expect == XSTATE && isALPHA(tmp) &&
2396 (s == linestart+1 || s[-2] == '\n') )
2398 if (in_eval && !rsfp) {
2403 if (strnEQ(s,"=cut",4)) {
2420 if (lex_brackets < lex_formbrack) {
2422 for (t = s; *t == ' ' || *t == '\t'; t++) ;
2423 if (*t == '\n' || *t == '#') {
2441 if (expect != XOPERATOR) {
2442 if (s[1] != '<' && !strchr(s,'>'))
2445 s = scan_heredoc(s);
2447 s = scan_inputsymbol(s);
2448 TERM(sublex_start());
2453 SHop(OP_LEFT_SHIFT);
2467 SHop(OP_RIGHT_SHIFT);
2476 if (expect == XOPERATOR) {
2477 if (lex_formbrack && lex_brackets == lex_formbrack) {
2480 return ','; /* grandfather non-comma-format format */
2484 if (s[1] == '#' && (isALPHA(s[2]) || strchr("_{$:", s[2]))) {
2485 if (expect == XOPERATOR)
2486 no_op("Array length", bufptr);
2488 s = scan_ident(s + 1, bufend, tokenbuf + 1, sizeof tokenbuf - 1,
2493 pending_ident = '#';
2497 if (expect == XOPERATOR)
2498 no_op("Scalar", bufptr);
2500 s = scan_ident(s, bufend, tokenbuf + 1, sizeof tokenbuf - 1, FALSE);
2503 yyerror("Final $ should be \\$ or $name");
2507 /* This kludge not intended to be bulletproof. */
2508 if (tokenbuf[1] == '[' && !tokenbuf[2]) {
2509 yylval.opval = newSVOP(OP_CONST, 0,
2510 newSViv((IV)compiling.cop_arybase));
2511 yylval.opval->op_private = OPpCONST_ARYBASE;
2516 if (lex_state == LEX_NORMAL)
2519 if ((expect != XREF || oldoldbufptr == last_lop) && intuit_more(s)) {
2525 isSPACE(*t) || isALNUM(*t) || *t == '$';
2528 bufptr = skipspace(bufptr);
2529 while (t < bufend && *t != ']')
2531 warn("Multidimensional syntax %.*s not supported",
2532 (t - bufptr) + 1, bufptr);
2536 else if (*s == '{') {
2538 if (dowarn && strEQ(tokenbuf+1, "SIG") &&
2539 (t = strchr(s, '}')) && (t = strchr(t, '=')))
2541 char tmpbuf[sizeof tokenbuf];
2543 for (t++; isSPACE(*t); t++) ;
2544 if (isIDFIRST(*t)) {
2545 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
2546 if (*t != '(' && perl_get_cv(tmpbuf, FALSE))
2547 warn("You need to quote \"%s\"", tmpbuf);
2554 if (lex_state == LEX_NORMAL && isSPACE(*d)) {
2555 bool islop = (last_lop == oldoldbufptr);
2556 if (!islop || last_lop_op == OP_GREPSTART)
2558 else if (strchr("$@\"'`q", *s))
2559 expect = XTERM; /* e.g. print $fh "foo" */
2560 else if (strchr("&*<%", *s) && isIDFIRST(s[1]))
2561 expect = XTERM; /* e.g. print $fh &sub */
2562 else if (isIDFIRST(*s)) {
2563 char tmpbuf[sizeof tokenbuf];
2564 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2565 if (tmp = keyword(tmpbuf, len)) {
2566 /* binary operators exclude handle interpretations */
2578 expect = XTERM; /* e.g. print $fh length() */
2583 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
2584 if (gv && GvCVu(gv))
2585 expect = XTERM; /* e.g. print $fh subr() */
2588 else if (isDIGIT(*s))
2589 expect = XTERM; /* e.g. print $fh 3 */
2590 else if (*s == '.' && isDIGIT(s[1]))
2591 expect = XTERM; /* e.g. print $fh .3 */
2592 else if (strchr("/?-+", *s) && !isSPACE(s[1]))
2593 expect = XTERM; /* e.g. print $fh -1 */
2594 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]))
2595 expect = XTERM; /* print $fh <<"EOF" */
2597 pending_ident = '$';
2601 if (expect == XOPERATOR)
2604 s = scan_ident(s, bufend, tokenbuf + 1, sizeof tokenbuf - 1, FALSE);
2607 yyerror("Final @ should be \\@ or @name");
2610 if (lex_state == LEX_NORMAL)
2612 if ((expect != XREF || oldoldbufptr == last_lop) && intuit_more(s)) {
2616 /* Warn about @ where they meant $. */
2618 if (*s == '[' || *s == '{') {
2620 while (*t && (isALNUM(*t) || strchr(" \t$#+-'\"", *t)))
2622 if (*t == '}' || *t == ']') {
2624 bufptr = skipspace(bufptr);
2625 warn("Scalar value %.*s better written as $%.*s",
2626 t-bufptr, bufptr, t-bufptr-1, bufptr+1);
2631 pending_ident = '@';
2634 case '/': /* may either be division or pattern */
2635 case '?': /* may either be conditional or pattern */
2636 if (expect != XOPERATOR) {
2637 /* Disable warning on "study /blah/" */
2638 if (oldoldbufptr == last_uni
2639 && (*last_uni != 's' || s - last_uni < 5
2640 || memNE(last_uni, "study", 5) || isALNUM(last_uni[5])))
2643 TERM(sublex_start());
2651 if (lex_formbrack && lex_brackets == lex_formbrack && s[1] == '\n' &&
2652 (s == linestart || s[-1] == '\n') ) {
2657 if (expect == XOPERATOR || !isDIGIT(s[1])) {
2663 yylval.ival = OPf_SPECIAL;
2669 if (expect != XOPERATOR)
2674 case '0': case '1': case '2': case '3': case '4':
2675 case '5': case '6': case '7': case '8': case '9':
2677 if (expect == XOPERATOR)
2683 if (expect == XOPERATOR) {
2684 if (lex_formbrack && lex_brackets == lex_formbrack) {
2687 return ','; /* grandfather non-comma-format format */
2693 missingterm((char*)0);
2694 yylval.ival = OP_CONST;
2695 TERM(sublex_start());
2699 if (expect == XOPERATOR) {
2700 if (lex_formbrack && lex_brackets == lex_formbrack) {
2703 return ','; /* grandfather non-comma-format format */
2709 missingterm((char*)0);
2710 yylval.ival = OP_CONST;
2711 for (d = SvPV(lex_stuff, len); len; len--, d++) {
2712 if (*d == '$' || *d == '@' || *d == '\\') {
2713 yylval.ival = OP_STRINGIFY;
2717 TERM(sublex_start());
2721 if (expect == XOPERATOR)
2722 no_op("Backticks",s);
2724 missingterm((char*)0);
2725 yylval.ival = OP_BACKTICK;
2727 TERM(sublex_start());
2731 if (dowarn && lex_inwhat && isDIGIT(*s))
2732 warn("Can't use \\%c to mean $%c in expression", *s, *s);
2733 if (expect == XOPERATOR)
2734 no_op("Backslash",s);
2738 if (isDIGIT(s[1]) && expect == XOPERATOR) {
2777 s = scan_word(s, tokenbuf, sizeof tokenbuf, FALSE, &len);
2779 /* Some keywords can be followed by any delimiter, including ':' */
2780 tmp = (len == 1 && strchr("msyq", tokenbuf[0]) ||
2781 len == 2 && ((tokenbuf[0] == 't' && tokenbuf[1] == 'r') ||
2782 (tokenbuf[0] == 'q' &&
2783 strchr("qwx", tokenbuf[1]))));
2785 /* x::* is just a word, unless x is "CORE" */
2786 if (!tmp && *s == ':' && s[1] == ':' && strNE(tokenbuf, "CORE"))
2790 while (d < bufend && isSPACE(*d))
2791 d++; /* no comments skipped here, or s### is misparsed */
2793 /* Is this a label? */
2794 if (!tmp && expect == XSTATE
2795 && d < bufend && *d == ':' && *(d + 1) != ':') {
2797 yylval.pval = savepv(tokenbuf);
2802 /* Check for keywords */
2803 tmp = keyword(tokenbuf, len);
2805 /* Is this a word before a => operator? */
2806 if (strnEQ(d,"=>",2)) {
2808 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(tokenbuf,0));
2809 yylval.opval->op_private = OPpCONST_BARE;
2813 if (tmp < 0) { /* second-class keyword? */
2814 if (expect != XOPERATOR && (*s != ':' || s[1] != ':') &&
2815 (((gv = gv_fetchpv(tokenbuf, FALSE, SVt_PVCV)) &&
2816 GvCVu(gv) && GvIMPORTED_CV(gv)) ||
2817 ((gvp = (GV**)hv_fetch(globalstash,tokenbuf,len,FALSE)) &&
2818 (gv = *gvp) != (GV*)&sv_undef &&
2819 GvCVu(gv) && GvIMPORTED_CV(gv))))
2821 tmp = 0; /* overridden by importation */
2824 && -tmp==KEY_lock /* XXX generalizable kludge */
2825 && !hv_fetch(GvHVn(incgv), "Thread.pm", 9, FALSE))
2827 tmp = 0; /* any sub overrides "weak" keyword */
2830 tmp = -tmp; gv = Nullgv; gvp = 0;
2837 default: /* not a keyword */
2840 char lastchar = (bufptr == oldoldbufptr ? 0 : bufptr[-1]);
2842 /* Get the rest if it looks like a package qualifier */
2844 if (*s == '\'' || *s == ':' && s[1] == ':') {
2846 s = scan_word(s, tokenbuf + len, sizeof tokenbuf - len,
2849 croak("Bad name after %s%s", tokenbuf,
2850 *s == '\'' ? "'" : "::");
2854 if (expect == XOPERATOR) {
2855 if (bufptr == linestart) {
2861 no_op("Bareword",s);
2864 /* Look for a subroutine with this name in current package,
2865 unless name is "Foo::", in which case Foo is a bearword
2866 (and a package name). */
2869 tokenbuf[len - 2] == ':' && tokenbuf[len - 1] == ':')
2871 if (dowarn && ! gv_fetchpv(tokenbuf, FALSE, SVt_PVHV))
2872 warn("Bareword \"%s\" refers to nonexistent package",
2875 tokenbuf[len] = '\0';
2882 gv = gv_fetchpv(tokenbuf, FALSE, SVt_PVCV);
2885 /* if we saw a global override before, get the right name */
2888 sv = newSVpv("CORE::GLOBAL::",14);
2889 sv_catpv(sv,tokenbuf);
2892 sv = newSVpv(tokenbuf,0);
2894 /* Presume this is going to be a bareword of some sort. */
2897 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2898 yylval.opval->op_private = OPpCONST_BARE;
2900 /* And if "Foo::", then that's what it certainly is. */
2905 /* See if it's the indirect object for a list operator. */
2908 oldoldbufptr < bufptr &&
2909 (oldoldbufptr == last_lop || oldoldbufptr == last_uni) &&
2910 /* NO SKIPSPACE BEFORE HERE! */
2912 ((opargs[last_lop_op] >> OASHIFT)& 7) == OA_FILEREF) )
2914 bool immediate_paren = *s == '(';
2916 /* (Now we can afford to cross potential line boundary.) */
2919 /* Two barewords in a row may indicate method call. */
2921 if ((isALPHA(*s) || *s == '$') && (tmp=intuit_method(s,gv)))
2924 /* If not a declared subroutine, it's an indirect object. */
2925 /* (But it's an indir obj regardless for sort.) */
2927 if ((last_lop_op == OP_SORT ||
2928 (!immediate_paren && (!gv || !GvCVu(gv))) ) &&
2929 (last_lop_op != OP_MAPSTART && last_lop_op != OP_GREPSTART)){
2930 expect = (last_lop == oldoldbufptr) ? XTERM : XOPERATOR;
2935 /* If followed by a paren, it's certainly a subroutine. */
2941 if (gv && GvCVu(gv)) {
2942 for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
2943 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
2948 nextval[nexttoke].opval = yylval.opval;
2955 /* If followed by var or block, call it a method (unless sub) */
2957 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
2958 last_lop = oldbufptr;
2959 last_lop_op = OP_METHOD;
2963 /* If followed by a bareword, see if it looks like indir obj. */
2965 if ((isALPHA(*s) || *s == '$') && (tmp = intuit_method(s,gv)))
2968 /* Not a method, so call it a subroutine (if defined) */
2970 if (gv && GvCVu(gv)) {
2972 if (lastchar == '-')
2973 warn("Ambiguous use of -%s resolved as -&%s()",
2974 tokenbuf, tokenbuf);
2975 last_lop = oldbufptr;
2976 last_lop_op = OP_ENTERSUB;
2977 /* Check for a constant sub */
2979 if ((sv = cv_const_sv(cv))) {
2981 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
2982 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
2983 yylval.opval->op_private = 0;
2987 /* Resolve to GV now. */
2988 op_free(yylval.opval);
2989 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
2990 /* Is there a prototype? */
2993 char *proto = SvPV((SV*)cv, len);
2996 if (strEQ(proto, "$"))
2998 if (*proto == '&' && *s == '{') {
2999 sv_setpv(subname,"__ANON__");
3003 nextval[nexttoke].opval = yylval.opval;
3009 if (hints & HINT_STRICT_SUBS &&
3012 last_lop_op != OP_TRUNCATE && /* S/F prototype in opcode.pl */
3013 last_lop_op != OP_ACCEPT &&
3014 last_lop_op != OP_PIPE_OP &&
3015 last_lop_op != OP_SOCKPAIR)
3018 "Bareword \"%s\" not allowed while \"strict subs\" in use",
3023 /* Call it a bare word */
3027 if (lastchar != '-') {
3028 for (d = tokenbuf; *d && isLOWER(*d); d++) ;
3030 warn(warn_reserved, tokenbuf);
3035 if (lastchar && strchr("*%&", lastchar)) {
3036 warn("Operator or semicolon missing before %c%s",
3037 lastchar, tokenbuf);
3038 warn("Ambiguous use of %c resolved as operator %c",
3039 lastchar, lastchar);
3045 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3046 newSVsv(GvSV(curcop->cop_filegv)));
3050 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3051 newSVpvf("%ld", (long)curcop->cop_line));
3054 case KEY___PACKAGE__:
3055 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3057 ? newSVsv(curstname)
3066 if (rsfp && (!in_eval || tokenbuf[2] == 'D')) {
3067 char *pname = "main";
3068 if (tokenbuf[2] == 'D')
3069 pname = HvNAME(curstash ? curstash : defstash);
3070 gv = gv_fetchpv(form("%s::DATA", pname), TRUE, SVt_PVIO);
3073 GvIOp(gv) = newIO();
3074 IoIFP(GvIOp(gv)) = rsfp;
3075 #if defined(HAS_FCNTL) && defined(F_SETFD)
3077 int fd = PerlIO_fileno(rsfp);
3078 fcntl(fd,F_SETFD,fd >= 3);
3081 /* Mark this internal pseudo-handle as clean */
3082 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3084 IoTYPE(GvIOp(gv)) = '|';
3085 else if ((PerlIO*)rsfp == PerlIO_stdin())
3086 IoTYPE(GvIOp(gv)) = '-';
3088 IoTYPE(GvIOp(gv)) = '<';
3099 if (expect == XSTATE) {
3106 if (*s == ':' && s[1] == ':') {
3109 s = scan_word(s, tokenbuf, sizeof tokenbuf, FALSE, &len);
3110 tmp = keyword(tokenbuf, len);
3124 LOP(OP_ACCEPT,XTERM);
3130 LOP(OP_ATAN2,XTERM);
3139 LOP(OP_BLESS,XTERM);
3148 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
3168 LOP(OP_CRYPT,XTERM);
3172 for (d = s; d < bufend && (isSPACE(*d) || *d == '('); d++) ;
3173 if (*d != '0' && isDIGIT(*d))
3174 yywarn("chmod: mode argument is missing initial 0");
3176 LOP(OP_CHMOD,XTERM);
3179 LOP(OP_CHOWN,XTERM);
3182 LOP(OP_CONNECT,XTERM);
3198 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3202 hints |= HINT_BLOCK_SCOPE;
3212 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3213 LOP(OP_DBMOPEN,XTERM);
3219 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3226 yylval.ival = curcop->cop_line;
3240 expect = (*s == '{') ? XTERMBLOCK : XTERM;
3241 UNIBRACK(OP_ENTEREVAL);
3256 case KEY_endhostent:
3262 case KEY_endservent:
3265 case KEY_endprotoent:
3276 yylval.ival = curcop->cop_line;
3278 if (expect == XSTATE && isIDFIRST(*s)) {
3280 if ((bufend - p) >= 3 &&
3281 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3285 croak("Missing $ on loop variable");
3290 LOP(OP_FORMLINE,XTERM);
3296 LOP(OP_FCNTL,XTERM);
3302 LOP(OP_FLOCK,XTERM);
3311 LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
3314 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3329 case KEY_getpriority:
3330 LOP(OP_GETPRIORITY,XTERM);
3332 case KEY_getprotobyname:
3335 case KEY_getprotobynumber:
3336 LOP(OP_GPBYNUMBER,XTERM);
3338 case KEY_getprotoent:
3350 case KEY_getpeername:
3351 UNI(OP_GETPEERNAME);
3353 case KEY_gethostbyname:
3356 case KEY_gethostbyaddr:
3357 LOP(OP_GHBYADDR,XTERM);
3359 case KEY_gethostent:
3362 case KEY_getnetbyname:
3365 case KEY_getnetbyaddr:
3366 LOP(OP_GNBYADDR,XTERM);
3371 case KEY_getservbyname:
3372 LOP(OP_GSBYNAME,XTERM);
3374 case KEY_getservbyport:
3375 LOP(OP_GSBYPORT,XTERM);
3377 case KEY_getservent:
3380 case KEY_getsockname:
3381 UNI(OP_GETSOCKNAME);
3383 case KEY_getsockopt:
3384 LOP(OP_GSOCKOPT,XTERM);
3406 yylval.ival = curcop->cop_line;
3410 LOP(OP_INDEX,XTERM);
3416 LOP(OP_IOCTL,XTERM);
3428 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3459 LOP(OP_LISTEN,XTERM);
3469 TERM(sublex_start());
3472 LOP(OP_MAPSTART,XREF);
3475 LOP(OP_MKDIR,XTERM);
3478 LOP(OP_MSGCTL,XTERM);
3481 LOP(OP_MSGGET,XTERM);
3484 LOP(OP_MSGRCV,XTERM);
3487 LOP(OP_MSGSND,XTERM);
3492 if (isIDFIRST(*s)) {
3493 s = scan_word(s, tokenbuf, sizeof tokenbuf, TRUE, &len);
3494 in_my_stash = gv_stashpv(tokenbuf, FALSE);
3498 sprintf(tmpbuf, "No such class %.1000s", tokenbuf);
3505 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3512 if (expect != XSTATE)
3513 yyerror("\"no\" not allowed in expression");
3514 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3515 s = force_version(s);
3524 if (isIDFIRST(*s)) {
3526 for (d = s; isALNUM(*d); d++) ;
3528 if (strchr("|&*+-=!?:.", *t))
3529 warn("Precedence problem: open %.*s should be open(%.*s)",
3535 yylval.ival = OP_OR;
3545 LOP(OP_OPEN_DIR,XTERM);
3548 checkcomma(s,tokenbuf,"filehandle");
3552 checkcomma(s,tokenbuf,"filehandle");
3571 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3575 LOP(OP_PIPE_OP,XTERM);
3580 missingterm((char*)0);
3581 yylval.ival = OP_CONST;
3582 TERM(sublex_start());
3590 missingterm((char*)0);
3591 if (dowarn && SvLEN(lex_stuff)) {
3592 d = SvPV_force(lex_stuff, len);
3593 for (; len; --len, ++d) {
3595 warn("Possible attempt to separate words with commas");
3599 warn("Possible attempt to put comments in qw() list");
3605 nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, q(lex_stuff));
3609 nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(" ",1));
3612 yylval.ival = OP_SPLIT;
3616 last_lop = oldbufptr;
3617 last_lop_op = OP_SPLIT;
3623 missingterm((char*)0);
3624 yylval.ival = OP_STRINGIFY;
3625 if (SvIVX(lex_stuff) == '\'')
3626 SvIVX(lex_stuff) = 0; /* qq'$foo' should intepolate */
3627 TERM(sublex_start());
3632 missingterm((char*)0);
3633 yylval.ival = OP_BACKTICK;
3635 TERM(sublex_start());
3642 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3643 if (isIDFIRST(*tokenbuf))
3644 gv_stashpvn(tokenbuf, strlen(tokenbuf), TRUE);
3646 yyerror("<> should be quotes");
3653 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3657 LOP(OP_RENAME,XTERM);
3666 LOP(OP_RINDEX,XTERM);
3689 LOP(OP_REVERSE,XTERM);
3700 TERM(sublex_start());
3702 TOKEN(1); /* force error */
3711 LOP(OP_SELECT,XTERM);
3717 LOP(OP_SEMCTL,XTERM);
3720 LOP(OP_SEMGET,XTERM);
3723 LOP(OP_SEMOP,XTERM);
3729 LOP(OP_SETPGRP,XTERM);
3731 case KEY_setpriority:
3732 LOP(OP_SETPRIORITY,XTERM);
3734 case KEY_sethostent:
3740 case KEY_setservent:
3743 case KEY_setprotoent:
3753 LOP(OP_SEEKDIR,XTERM);
3755 case KEY_setsockopt:
3756 LOP(OP_SSOCKOPT,XTERM);
3762 LOP(OP_SHMCTL,XTERM);
3765 LOP(OP_SHMGET,XTERM);
3768 LOP(OP_SHMREAD,XTERM);
3771 LOP(OP_SHMWRITE,XTERM);
3774 LOP(OP_SHUTDOWN,XTERM);
3783 LOP(OP_SOCKET,XTERM);
3785 case KEY_socketpair:
3786 LOP(OP_SOCKPAIR,XTERM);
3789 checkcomma(s,tokenbuf,"subroutine name");
3791 if (*s == ';' || *s == ')') /* probably a close */
3792 croak("sort is now a reserved word");
3794 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3798 LOP(OP_SPLIT,XTERM);
3801 LOP(OP_SPRINTF,XTERM);
3804 LOP(OP_SPLICE,XTERM);
3820 LOP(OP_SUBSTR,XTERM);
3827 if (isIDFIRST(*s) || *s == '\'' || *s == ':') {
3828 char tmpbuf[sizeof tokenbuf];
3830 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3831 if (strchr(tmpbuf, ':'))
3832 sv_setpv(subname, tmpbuf);
3834 sv_setsv(subname,curstname);
3835 sv_catpvn(subname,"::",2);
3836 sv_catpvn(subname,tmpbuf,len);
3838 s = force_word(s,WORD,FALSE,TRUE,TRUE);
3842 expect = XTERMBLOCK;
3843 sv_setpv(subname,"?");
3846 if (tmp == KEY_format) {
3849 lex_formbrack = lex_brackets + 1;
3853 /* Look for a prototype */
3860 SvREFCNT_dec(lex_stuff);
3862 croak("Prototype not terminated");
3865 d = SvPVX(lex_stuff);
3867 for (p = d; *p; ++p) {
3872 SvCUR(lex_stuff) = tmp;
3875 nextval[1] = nextval[0];
3876 nexttype[1] = nexttype[0];
3877 nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, lex_stuff);
3878 nexttype[0] = THING;
3879 if (nexttoke == 1) {
3880 lex_defer = lex_state;
3881 lex_expect = expect;
3882 lex_state = LEX_KNOWNEXT;
3887 if (*SvPV(subname,na) == '?') {
3888 sv_setpv(subname,"__ANON__");
3895 LOP(OP_SYSTEM,XREF);
3898 LOP(OP_SYMLINK,XTERM);
3901 LOP(OP_SYSCALL,XTERM);
3904 LOP(OP_SYSOPEN,XTERM);
3907 LOP(OP_SYSSEEK,XTERM);
3910 LOP(OP_SYSREAD,XTERM);
3913 LOP(OP_SYSWRITE,XTERM);
3917 TERM(sublex_start());
3938 LOP(OP_TRUNCATE,XTERM);
3950 yylval.ival = curcop->cop_line;
3954 yylval.ival = curcop->cop_line;
3958 LOP(OP_UNLINK,XTERM);
3964 LOP(OP_UNPACK,XTERM);
3967 LOP(OP_UTIME,XTERM);
3971 for (d = s; d < bufend && (isSPACE(*d) || *d == '('); d++) ;
3972 if (*d != '0' && isDIGIT(*d))
3973 yywarn("umask: argument is missing initial 0");
3978 LOP(OP_UNSHIFT,XTERM);
3981 if (expect != XSTATE)
3982 yyerror("\"use\" not allowed in expression");
3985 s = force_version(s);
3986 if(*s == ';' || (s = skipspace(s), *s == ';')) {
3987 nextval[nexttoke].opval = Nullop;
3992 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3993 s = force_version(s);
4006 yylval.ival = curcop->cop_line;
4010 hints |= HINT_BLOCK_SCOPE;
4017 LOP(OP_WAITPID,XTERM);
4023 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
4027 if (expect == XOPERATOR)
4033 yylval.ival = OP_XOR;
4038 TERM(sublex_start());
4044 keyword(register char *d, I32 len)
4049 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
4050 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
4051 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
4052 if (strEQ(d,"__DATA__")) return KEY___DATA__;
4053 if (strEQ(d,"__END__")) return KEY___END__;
4057 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
4062 if (strEQ(d,"and")) return -KEY_and;
4063 if (strEQ(d,"abs")) return -KEY_abs;
4066 if (strEQ(d,"alarm")) return -KEY_alarm;
4067 if (strEQ(d,"atan2")) return -KEY_atan2;
4070 if (strEQ(d,"accept")) return -KEY_accept;
4075 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
4078 if (strEQ(d,"bless")) return -KEY_bless;
4079 if (strEQ(d,"bind")) return -KEY_bind;
4080 if (strEQ(d,"binmode")) return -KEY_binmode;
4083 if (strEQ(d,"CORE")) return -KEY_CORE;
4088 if (strEQ(d,"cmp")) return -KEY_cmp;
4089 if (strEQ(d,"chr")) return -KEY_chr;
4090 if (strEQ(d,"cos")) return -KEY_cos;
4093 if (strEQ(d,"chop")) return KEY_chop;
4096 if (strEQ(d,"close")) return -KEY_close;
4097 if (strEQ(d,"chdir")) return -KEY_chdir;
4098 if (strEQ(d,"chomp")) return KEY_chomp;
4099 if (strEQ(d,"chmod")) return -KEY_chmod;
4100 if (strEQ(d,"chown")) return -KEY_chown;
4101 if (strEQ(d,"crypt")) return -KEY_crypt;
4104 if (strEQ(d,"chroot")) return -KEY_chroot;
4105 if (strEQ(d,"caller")) return -KEY_caller;
4108 if (strEQ(d,"connect")) return -KEY_connect;
4111 if (strEQ(d,"closedir")) return -KEY_closedir;
4112 if (strEQ(d,"continue")) return -KEY_continue;
4117 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
4122 if (strEQ(d,"do")) return KEY_do;
4125 if (strEQ(d,"die")) return -KEY_die;
4128 if (strEQ(d,"dump")) return -KEY_dump;
4131 if (strEQ(d,"delete")) return KEY_delete;
4134 if (strEQ(d,"defined")) return KEY_defined;
4135 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
4138 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
4143 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
4144 if (strEQ(d,"END")) return KEY_END;
4149 if (strEQ(d,"eq")) return -KEY_eq;
4152 if (strEQ(d,"eof")) return -KEY_eof;
4153 if (strEQ(d,"exp")) return -KEY_exp;
4156 if (strEQ(d,"else")) return KEY_else;
4157 if (strEQ(d,"exit")) return -KEY_exit;
4158 if (strEQ(d,"eval")) return KEY_eval;
4159 if (strEQ(d,"exec")) return -KEY_exec;
4160 if (strEQ(d,"each")) return KEY_each;
4163 if (strEQ(d,"elsif")) return KEY_elsif;
4166 if (strEQ(d,"exists")) return KEY_exists;
4167 if (strEQ(d,"elseif")) warn("elseif should be elsif");
4170 if (strEQ(d,"endgrent")) return -KEY_endgrent;
4171 if (strEQ(d,"endpwent")) return -KEY_endpwent;
4174 if (strEQ(d,"endnetent")) return -KEY_endnetent;
4177 if (strEQ(d,"endhostent")) return -KEY_endhostent;
4178 if (strEQ(d,"endservent")) return -KEY_endservent;
4181 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
4188 if (strEQ(d,"for")) return KEY_for;
4191 if (strEQ(d,"fork")) return -KEY_fork;
4194 if (strEQ(d,"fcntl")) return -KEY_fcntl;
4195 if (strEQ(d,"flock")) return -KEY_flock;
4198 if (strEQ(d,"format")) return KEY_format;
4199 if (strEQ(d,"fileno")) return -KEY_fileno;
4202 if (strEQ(d,"foreach")) return KEY_foreach;
4205 if (strEQ(d,"formline")) return -KEY_formline;
4211 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
4212 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
4216 if (strnEQ(d,"get",3)) {
4221 if (strEQ(d,"ppid")) return -KEY_getppid;
4222 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
4225 if (strEQ(d,"pwent")) return -KEY_getpwent;
4226 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
4227 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
4230 if (strEQ(d,"peername")) return -KEY_getpeername;
4231 if (strEQ(d,"protoent")) return -KEY_getprotoent;
4232 if (strEQ(d,"priority")) return -KEY_getpriority;
4235 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
4238 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
4242 else if (*d == 'h') {
4243 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
4244 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
4245 if (strEQ(d,"hostent")) return -KEY_gethostent;
4247 else if (*d == 'n') {
4248 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
4249 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
4250 if (strEQ(d,"netent")) return -KEY_getnetent;
4252 else if (*d == 's') {
4253 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
4254 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
4255 if (strEQ(d,"servent")) return -KEY_getservent;
4256 if (strEQ(d,"sockname")) return -KEY_getsockname;
4257 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
4259 else if (*d == 'g') {
4260 if (strEQ(d,"grent")) return -KEY_getgrent;
4261 if (strEQ(d,"grnam")) return -KEY_getgrnam;
4262 if (strEQ(d,"grgid")) return -KEY_getgrgid;
4264 else if (*d == 'l') {
4265 if (strEQ(d,"login")) return -KEY_getlogin;
4267 else if (strEQ(d,"c")) return -KEY_getc;
4272 if (strEQ(d,"gt")) return -KEY_gt;
4273 if (strEQ(d,"ge")) return -KEY_ge;
4276 if (strEQ(d,"grep")) return KEY_grep;
4277 if (strEQ(d,"goto")) return KEY_goto;
4278 if (strEQ(d,"glob")) return KEY_glob;
4281 if (strEQ(d,"gmtime")) return -KEY_gmtime;
4286 if (strEQ(d,"hex")) return -KEY_hex;
4289 if (strEQ(d,"INIT")) return KEY_INIT;
4294 if (strEQ(d,"if")) return KEY_if;
4297 if (strEQ(d,"int")) return -KEY_int;
4300 if (strEQ(d,"index")) return -KEY_index;
4301 if (strEQ(d,"ioctl")) return -KEY_ioctl;
4306 if (strEQ(d,"join")) return -KEY_join;
4310 if (strEQ(d,"keys")) return KEY_keys;
4311 if (strEQ(d,"kill")) return -KEY_kill;
4316 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
4317 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
4323 if (strEQ(d,"lt")) return -KEY_lt;
4324 if (strEQ(d,"le")) return -KEY_le;
4325 if (strEQ(d,"lc")) return -KEY_lc;
4328 if (strEQ(d,"log")) return -KEY_log;
4331 if (strEQ(d,"last")) return KEY_last;
4332 if (strEQ(d,"link")) return -KEY_link;
4333 if (strEQ(d,"lock")) return -KEY_lock;
4336 if (strEQ(d,"local")) return KEY_local;
4337 if (strEQ(d,"lstat")) return -KEY_lstat;
4340 if (strEQ(d,"length")) return -KEY_length;
4341 if (strEQ(d,"listen")) return -KEY_listen;
4344 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
4347 if (strEQ(d,"localtime")) return -KEY_localtime;
4353 case 1: return KEY_m;
4355 if (strEQ(d,"my")) return KEY_my;
4358 if (strEQ(d,"map")) return KEY_map;
4361 if (strEQ(d,"mkdir")) return -KEY_mkdir;
4364 if (strEQ(d,"msgctl")) return -KEY_msgctl;
4365 if (strEQ(d,"msgget")) return -KEY_msgget;
4366 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
4367 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
4372 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
4375 if (strEQ(d,"next")) return KEY_next;
4376 if (strEQ(d,"ne")) return -KEY_ne;
4377 if (strEQ(d,"not")) return -KEY_not;
4378 if (strEQ(d,"no")) return KEY_no;
4383 if (strEQ(d,"or")) return -KEY_or;
4386 if (strEQ(d,"ord")) return -KEY_ord;
4387 if (strEQ(d,"oct")) return -KEY_oct;
4390 if (strEQ(d,"open")) return -KEY_open;
4393 if (strEQ(d,"opendir")) return -KEY_opendir;
4400 if (strEQ(d,"pop")) return KEY_pop;
4401 if (strEQ(d,"pos")) return KEY_pos;
4404 if (strEQ(d,"push")) return KEY_push;
4405 if (strEQ(d,"pack")) return -KEY_pack;
4406 if (strEQ(d,"pipe")) return -KEY_pipe;
4409 if (strEQ(d,"print")) return KEY_print;
4412 if (strEQ(d,"printf")) return KEY_printf;
4415 if (strEQ(d,"package")) return KEY_package;
4418 if (strEQ(d,"prototype")) return KEY_prototype;
4423 if (strEQ(d,"q")) return KEY_q;
4424 if (strEQ(d,"qq")) return KEY_qq;
4425 if (strEQ(d,"qw")) return KEY_qw;
4426 if (strEQ(d,"qx")) return KEY_qx;
4428 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
4433 if (strEQ(d,"ref")) return -KEY_ref;
4436 if (strEQ(d,"read")) return -KEY_read;
4437 if (strEQ(d,"rand")) return -KEY_rand;
4438 if (strEQ(d,"recv")) return -KEY_recv;
4439 if (strEQ(d,"redo")) return KEY_redo;
4442 if (strEQ(d,"rmdir")) return -KEY_rmdir;
4443 if (strEQ(d,"reset")) return -KEY_reset;
4446 if (strEQ(d,"return")) return KEY_return;
4447 if (strEQ(d,"rename")) return -KEY_rename;
4448 if (strEQ(d,"rindex")) return -KEY_rindex;
4451 if (strEQ(d,"require")) return -KEY_require;
4452 if (strEQ(d,"reverse")) return -KEY_reverse;
4453 if (strEQ(d,"readdir")) return -KEY_readdir;
4456 if (strEQ(d,"readlink")) return -KEY_readlink;
4457 if (strEQ(d,"readline")) return -KEY_readline;
4458 if (strEQ(d,"readpipe")) return -KEY_readpipe;
4461 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
4467 case 0: return KEY_s;
4469 if (strEQ(d,"scalar")) return KEY_scalar;
4474 if (strEQ(d,"seek")) return -KEY_seek;
4475 if (strEQ(d,"send")) return -KEY_send;
4478 if (strEQ(d,"semop")) return -KEY_semop;
4481 if (strEQ(d,"select")) return -KEY_select;
4482 if (strEQ(d,"semctl")) return -KEY_semctl;
4483 if (strEQ(d,"semget")) return -KEY_semget;
4486 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
4487 if (strEQ(d,"seekdir")) return -KEY_seekdir;
4490 if (strEQ(d,"setpwent")) return -KEY_setpwent;
4491 if (strEQ(d,"setgrent")) return -KEY_setgrent;
4494 if (strEQ(d,"setnetent")) return -KEY_setnetent;
4497 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
4498 if (strEQ(d,"sethostent")) return -KEY_sethostent;
4499 if (strEQ(d,"setservent")) return -KEY_setservent;
4502 if (strEQ(d,"setpriority")) return -KEY_setpriority;
4503 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
4510 if (strEQ(d,"shift")) return KEY_shift;
4513 if (strEQ(d,"shmctl")) return -KEY_shmctl;
4514 if (strEQ(d,"shmget")) return -KEY_shmget;
4517 if (strEQ(d,"shmread")) return -KEY_shmread;
4520 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
4521 if (strEQ(d,"shutdown")) return -KEY_shutdown;
4526 if (strEQ(d,"sin")) return -KEY_sin;
4529 if (strEQ(d,"sleep")) return -KEY_sleep;
4532 if (strEQ(d,"sort")) return KEY_sort;
4533 if (strEQ(d,"socket")) return -KEY_socket;
4534 if (strEQ(d,"socketpair")) return -KEY_socketpair;
4537 if (strEQ(d,"split")) return KEY_split;
4538 if (strEQ(d,"sprintf")) return -KEY_sprintf;
4539 if (strEQ(d,"splice")) return KEY_splice;
4542 if (strEQ(d,"sqrt")) return -KEY_sqrt;
4545 if (strEQ(d,"srand")) return -KEY_srand;
4548 if (strEQ(d,"stat")) return -KEY_stat;
4549 if (strEQ(d,"study")) return KEY_study;
4552 if (strEQ(d,"substr")) return -KEY_substr;
4553 if (strEQ(d,"sub")) return KEY_sub;
4558 if (strEQ(d,"system")) return -KEY_system;
4561 if (strEQ(d,"symlink")) return -KEY_symlink;
4562 if (strEQ(d,"syscall")) return -KEY_syscall;
4563 if (strEQ(d,"sysopen")) return -KEY_sysopen;
4564 if (strEQ(d,"sysread")) return -KEY_sysread;
4565 if (strEQ(d,"sysseek")) return -KEY_sysseek;
4568 if (strEQ(d,"syswrite")) return -KEY_syswrite;
4577 if (strEQ(d,"tr")) return KEY_tr;
4580 if (strEQ(d,"tie")) return KEY_tie;
4583 if (strEQ(d,"tell")) return -KEY_tell;
4584 if (strEQ(d,"tied")) return KEY_tied;
4585 if (strEQ(d,"time")) return -KEY_time;
4588 if (strEQ(d,"times")) return -KEY_times;
4591 if (strEQ(d,"telldir")) return -KEY_telldir;
4594 if (strEQ(d,"truncate")) return -KEY_truncate;
4601 if (strEQ(d,"uc")) return -KEY_uc;
4604 if (strEQ(d,"use")) return KEY_use;
4607 if (strEQ(d,"undef")) return KEY_undef;
4608 if (strEQ(d,"until")) return KEY_until;
4609 if (strEQ(d,"untie")) return KEY_untie;
4610 if (strEQ(d,"utime")) return -KEY_utime;
4611 if (strEQ(d,"umask")) return -KEY_umask;
4614 if (strEQ(d,"unless")) return KEY_unless;
4615 if (strEQ(d,"unpack")) return -KEY_unpack;
4616 if (strEQ(d,"unlink")) return -KEY_unlink;
4619 if (strEQ(d,"unshift")) return KEY_unshift;
4620 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
4625 if (strEQ(d,"values")) return -KEY_values;
4626 if (strEQ(d,"vec")) return -KEY_vec;
4631 if (strEQ(d,"warn")) return -KEY_warn;
4632 if (strEQ(d,"wait")) return -KEY_wait;
4635 if (strEQ(d,"while")) return KEY_while;
4636 if (strEQ(d,"write")) return -KEY_write;
4639 if (strEQ(d,"waitpid")) return -KEY_waitpid;
4642 if (strEQ(d,"wantarray")) return -KEY_wantarray;
4647 if (len == 1) return -KEY_x;
4648 if (strEQ(d,"xor")) return -KEY_xor;
4651 if (len == 1) return KEY_y;
4660 checkcomma(register char *s, char *name, char *what)
4664 if (dowarn && *s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
4666 for (w = s+2; *w && level; w++) {
4673 for (; *w && isSPACE(*w); w++) ;
4674 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
4675 warn("%s (...) interpreted as function",name);
4677 while (s < bufend && isSPACE(*s))
4681 while (s < bufend && isSPACE(*s))
4683 if (isIDFIRST(*s)) {
4687 while (s < bufend && isSPACE(*s))
4692 kw = keyword(w, s - w) || perl_get_cv(w, FALSE) != 0;
4696 croak("No comma allowed after %s", what);
4702 scan_word(register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
4704 register char *d = dest;
4705 register char *e = d + destlen - 3; /* two-character token, ending NUL */
4708 croak(ident_too_long);
4711 else if (*s == '\'' && allow_package && isIDFIRST(s[1])) {
4716 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
4729 scan_ident(register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
4736 if (lex_brackets == 0)
4741 e = d + destlen - 3; /* two-character token, ending NUL */
4743 while (isDIGIT(*s)) {
4745 croak(ident_too_long);
4752 croak(ident_too_long);
4755 else if (*s == '\'' && isIDFIRST(s[1])) {
4760 else if (*s == ':' && s[1] == ':') {
4771 if (lex_state != LEX_NORMAL)
4772 lex_state = LEX_INTERPENDMAYBE;
4775 if (*s == '$' && s[1] &&
4776 (isALNUM(s[1]) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
4778 if (isDIGIT(s[1]) && lex_state == LEX_INTERPNORMAL)
4779 deprecate("\"$$<digit>\" to mean \"${$}<digit>\"");
4792 if (*d == '^' && *s && (isUPPER(*s) || strchr("[\\]^_?", *s))) {
4797 if (isSPACE(s[-1])) {
4800 if (ch != ' ' && ch != '\t') {
4806 if (isIDFIRST(*d)) {
4808 while (isALNUM(*s) || *s == ':')
4811 while (s < send && (*s == ' ' || *s == '\t')) s++;
4812 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
4813 if (dowarn && keyword(dest, d - dest)) {
4814 char *brack = *s == '[' ? "[...]" : "{...}";
4815 warn("Ambiguous use of %c{%s%s} resolved to %c%s%s",
4816 funny, dest, brack, funny, dest, brack);
4818 lex_fakebrack = lex_brackets+1;
4820 lex_brackstack[lex_brackets++] = XOPERATOR;
4826 if (lex_state == LEX_INTERPNORMAL && !lex_brackets)
4827 lex_state = LEX_INTERPEND;
4830 if (dowarn && lex_state == LEX_NORMAL &&
4831 (keyword(dest, d - dest) || perl_get_cv(dest, FALSE)))
4832 warn("Ambiguous use of %c{%s} resolved to %c%s",
4833 funny, dest, funny, dest);
4836 s = bracket; /* let the parser handle it */
4840 else if (lex_state == LEX_INTERPNORMAL && !lex_brackets && !intuit_more(s))
4841 lex_state = LEX_INTERPEND;
4845 void pmflag(U16 *pmfl, int ch)
4850 *pmfl |= PMf_GLOBAL;
4852 *pmfl |= PMf_CONTINUE;
4856 *pmfl |= PMf_MULTILINE;
4858 *pmfl |= PMf_SINGLELINE;
4860 *pmfl |= PMf_EXTENDED;
4864 scan_pat(char *start)
4869 s = scan_str(start);
4872 SvREFCNT_dec(lex_stuff);
4874 croak("Search pattern not terminated");
4877 pm = (PMOP*)newPMOP(OP_MATCH, 0);
4878 if (multi_open == '?')
4879 pm->op_pmflags |= PMf_ONCE;
4880 while (*s && strchr("iogcmsx", *s))
4881 pmflag(&pm->op_pmflags,*s++);
4882 pm->op_pmpermflags = pm->op_pmflags;
4885 yylval.ival = OP_MATCH;
4890 scan_subst(char *start)
4897 yylval.ival = OP_NULL;
4899 s = scan_str(start);
4903 SvREFCNT_dec(lex_stuff);
4905 croak("Substitution pattern not terminated");
4908 if (s[-1] == multi_open)
4911 first_start = multi_start;
4915 SvREFCNT_dec(lex_stuff);
4918 SvREFCNT_dec(lex_repl);
4920 croak("Substitution replacement not terminated");
4922 multi_start = first_start; /* so whole substitution is taken together */
4924 pm = (PMOP*)newPMOP(OP_SUBST, 0);
4925 while (*s && strchr("iogcmsex", *s)) {
4931 pmflag(&pm->op_pmflags,*s++);
4936 pm->op_pmflags |= PMf_EVAL;
4937 repl = newSVpv("",0);
4939 sv_catpv(repl, es ? "eval " : "do ");
4940 sv_catpvn(repl, "{ ", 2);
4941 sv_catsv(repl, lex_repl);
4942 sv_catpvn(repl, " };", 2);
4943 SvCOMPILED_on(repl);
4944 SvREFCNT_dec(lex_repl);
4948 pm->op_pmpermflags = pm->op_pmflags;
4950 yylval.ival = OP_SUBST;
4955 scan_trans(char *start)
4964 yylval.ival = OP_NULL;
4966 s = scan_str(start);
4969 SvREFCNT_dec(lex_stuff);
4971 croak("Transliteration pattern not terminated");
4973 if (s[-1] == multi_open)
4979 SvREFCNT_dec(lex_stuff);
4982 SvREFCNT_dec(lex_repl);
4984 croak("Transliteration replacement not terminated");
4987 New(803,tbl,256,short);
4988 o = newPVOP(OP_TRANS, 0, (char*)tbl);
4990 complement = Delete = squash = 0;
4991 while (*s == 'c' || *s == 'd' || *s == 's') {
4993 complement = OPpTRANS_COMPLEMENT;
4995 Delete = OPpTRANS_DELETE;
4997 squash = OPpTRANS_SQUASH;
5000 o->op_private = Delete|squash|complement;
5003 yylval.ival = OP_TRANS;
5008 scan_heredoc(register char *s)
5012 I32 op_type = OP_SCALAR;
5019 int outer = (rsfp && !(lex_inwhat == OP_SCALAR));
5023 e = tokenbuf + sizeof tokenbuf - 1;
5026 for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5027 if (*peek && strchr("`'\"",*peek)) {
5030 s = delimcpy(d, e, s, bufend, term, &len);
5041 deprecate("bare << to mean <<\"\"");
5042 for (; isALNUM(*s); s++) {
5047 if (d >= tokenbuf + sizeof tokenbuf - 1)
5048 croak("Delimiter for here document is too long");
5053 if (outer || !(d=ninstr(s,bufend,d,d+1)))
5054 herewas = newSVpv(s,bufend-s);
5056 s--, herewas = newSVpv(s,d-s);
5057 s += SvCUR(herewas);
5059 tmpstr = NEWSV(87,80);
5060 sv_upgrade(tmpstr, SVt_PVIV);
5065 else if (term == '`') {
5066 op_type = OP_BACKTICK;
5067 SvIVX(tmpstr) = '\\';
5071 multi_start = curcop->cop_line;
5072 multi_open = multi_close = '<';
5076 while (s < bufend &&
5077 (*s != term || memNE(s,tokenbuf,len)) ) {
5082 curcop->cop_line = multi_start;
5083 missingterm(tokenbuf);
5085 sv_setpvn(tmpstr,d+1,s-d);
5087 curcop->cop_line++; /* the preceding stmt passes a newline */
5089 sv_catpvn(herewas,s,bufend-s);
5090 sv_setsv(linestr,herewas);
5091 oldoldbufptr = oldbufptr = bufptr = s = linestart = SvPVX(linestr);
5092 bufend = SvPVX(linestr) + SvCUR(linestr);
5095 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
5096 while (s >= bufend) { /* multiple line string? */
5098 !(oldoldbufptr = oldbufptr = s = linestart = filter_gets(linestr, rsfp, 0))) {
5099 curcop->cop_line = multi_start;
5100 missingterm(tokenbuf);
5103 if (PERLDB_LINE && curstash != debstash) {
5104 SV *sv = NEWSV(88,0);
5106 sv_upgrade(sv, SVt_PVMG);
5107 sv_setsv(sv,linestr);
5108 av_store(GvAV(curcop->cop_filegv),
5109 (I32)curcop->cop_line,sv);
5111 bufend = SvPVX(linestr) + SvCUR(linestr);
5112 if (*s == term && memEQ(s,tokenbuf,len)) {
5115 sv_catsv(linestr,herewas);
5116 bufend = SvPVX(linestr) + SvCUR(linestr);
5120 sv_catsv(tmpstr,linestr);
5123 multi_end = curcop->cop_line;
5125 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
5126 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
5127 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
5129 SvREFCNT_dec(herewas);
5131 yylval.ival = op_type;
5136 takes: current position in input buffer
5137 returns: new position in input buffer
5138 side-effects: yylval and lex_op are set.
5143 <FH> read from filehandle
5144 <pkg::FH> read from package qualified filehandle
5145 <pkg'FH> read from package qualified filehandle
5146 <$fh> read from filehandle in $fh
5152 scan_inputsymbol(char *start)
5154 register char *s = start; /* current position in buffer */
5159 d = tokenbuf; /* start of temp holding space */
5160 e = tokenbuf + sizeof tokenbuf; /* end of temp holding space */
5161 s = delimcpy(d, e, s + 1, bufend, '>', &len); /* extract until > */
5163 /* die if we didn't have space for the contents of the <>,
5167 if (len >= sizeof tokenbuf)
5168 croak("Excessively long <> operator");
5170 croak("Unterminated <> operator");
5175 Remember, only scalar variables are interpreted as filehandles by
5176 this code. Anything more complex (e.g., <$fh{$num}>) will be
5177 treated as a glob() call.
5178 This code makes use of the fact that except for the $ at the front,
5179 a scalar variable and a filehandle look the same.
5181 if (*d == '$' && d[1]) d++;
5183 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
5184 while (*d && (isALNUM(*d) || *d == '\'' || *d == ':'))
5187 /* If we've tried to read what we allow filehandles to look like, and
5188 there's still text left, then it must be a glob() and not a getline.
5189 Use scan_str to pull out the stuff between the <> and treat it
5190 as nothing more than a string.
5193 if (d - tokenbuf != len) {
5194 yylval.ival = OP_GLOB;
5196 s = scan_str(start);
5198 croak("Glob not terminated");
5202 /* we're in a filehandle read situation */
5205 /* turn <> into <ARGV> */
5207 (void)strcpy(d,"ARGV");
5209 /* if <$fh>, create the ops to turn the variable into a
5215 /* try to find it in the pad for this block, otherwise find
5216 add symbol table ops
5218 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
5219 OP *o = newOP(OP_PADSV, 0);
5221 lex_op = (OP*)newUNOP(OP_READLINE, 0, newUNOP(OP_RV2GV, 0, o));
5224 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
5225 lex_op = (OP*)newUNOP(OP_READLINE, 0,
5226 newUNOP(OP_RV2GV, 0,
5227 newUNOP(OP_RV2SV, 0,
5228 newGVOP(OP_GV, 0, gv))));
5230 /* we created the ops in lex_op, so make yylval.ival a null op */
5231 yylval.ival = OP_NULL;
5234 /* If it's none of the above, it must be a literal filehandle
5235 (<Foo::BAR> or <FOO>) so build a simple readline OP */
5237 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
5238 lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
5239 yylval.ival = OP_NULL;
5248 takes: start position in buffer
5249 returns: position to continue reading from buffer
5250 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
5251 updates the read buffer.
5253 This subroutine pulls a string out of the input. It is called for:
5254 q single quotes q(literal text)
5255 ' single quotes 'literal text'
5256 qq double quotes qq(interpolate $here please)
5257 " double quotes "interpolate $here please"
5258 qx backticks qx(/bin/ls -l)
5259 ` backticks `/bin/ls -l`
5260 qw quote words @EXPORT_OK = qw( func() $spam )
5261 m// regexp match m/this/
5262 s/// regexp substitute s/this/that/
5263 tr/// string transliterate tr/this/that/
5264 y/// string transliterate y/this/that/
5265 ($*@) sub prototypes sub foo ($)
5266 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
5268 In most of these cases (all but <>, patterns and transliterate)
5269 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
5270 calls scan_str(). s/// makes yylex() call scan_subst() which calls
5271 scan_str(). tr/// and y/// make yylex() call scan_trans() which
5274 It skips whitespace before the string starts, and treats the first
5275 character as the delimiter. If the delimiter is one of ([{< then
5276 the corresponding "close" character )]}> is used as the closing
5277 delimiter. It allows quoting of delimiters, and if the string has
5278 balanced delimiters ([{<>}]) it allows nesting.
5280 The lexer always reads these strings into lex_stuff, except in the
5281 case of the operators which take *two* arguments (s/// and tr///)
5282 when it checks to see if lex_stuff is full (presumably with the 1st
5283 arg to s or tr) and if so puts the string into lex_repl.
5288 scan_str(char *start)
5291 SV *sv; /* scalar value: string */
5292 char *tmps; /* temp string, used for delimiter matching */
5293 register char *s = start; /* current position in the buffer */
5294 register char term; /* terminating character */
5295 register char *to; /* current position in the sv's data */
5296 I32 brackets = 1; /* bracket nesting level */
5298 /* skip space before the delimiter */
5302 /* mark where we are, in case we need to report errors */
5305 /* after skipping whitespace, the next character is the terminator */
5307 /* mark where we are */
5308 multi_start = curcop->cop_line;
5311 /* find corresponding closing delimiter */
5312 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5316 /* create a new SV to hold the contents. 87 is leak category, I'm
5317 assuming. 80 is the SV's initial length. What a random number. */
5319 sv_upgrade(sv, SVt_PVIV);
5321 (void)SvPOK_only(sv); /* validate pointer */
5323 /* move past delimiter and try to read a complete string */
5326 /* extend sv if need be */
5327 SvGROW(sv, SvCUR(sv) + (bufend - s) + 1);
5328 /* set 'to' to the next character in the sv's string */
5329 to = SvPVX(sv)+SvCUR(sv);
5331 /* if open delimiter is the close delimiter read unbridle */
5332 if (multi_open == multi_close) {
5333 for (; s < bufend; s++,to++) {
5334 /* embedded newlines increment the current line number */
5335 if (*s == '\n' && !rsfp)
5337 /* handle quoted delimiters */
5338 if (*s == '\\' && s+1 < bufend && term != '\\') {
5341 /* any other quotes are simply copied straight through */
5345 /* terminate when run out of buffer (the for() condition), or
5346 have found the terminator */
5347 else if (*s == term)
5353 /* if the terminator isn't the same as the start character (e.g.,
5354 matched brackets), we have to allow more in the quoting, and
5355 be prepared for nested brackets.
5358 /* read until we run out of string, or we find the terminator */
5359 for (; s < bufend; s++,to++) {
5360 /* embedded newlines increment the line count */
5361 if (*s == '\n' && !rsfp)
5363 /* backslashes can escape the open or closing characters */
5364 if (*s == '\\' && s+1 < bufend) {
5365 if ((s[1] == multi_open) || (s[1] == multi_close))
5370 /* allow nested opens and closes */
5371 else if (*s == multi_close && --brackets <= 0)
5373 else if (*s == multi_open)
5378 /* terminate the copied string and update the sv's end-of-string */
5380 SvCUR_set(sv, to - SvPVX(sv));
5383 * this next chunk reads more into the buffer if we're not done yet
5386 if (s < bufend) break; /* handle case where we are done yet :-) */
5388 /* if we're out of file, or a read fails, bail and reset the current
5389 line marker so we can report where the unterminated string began
5392 !(oldoldbufptr = oldbufptr = s = linestart = filter_gets(linestr, rsfp, 0))) {
5394 curcop->cop_line = multi_start;
5397 /* we read a line, so increment our line counter */
5400 /* update debugger info */
5401 if (PERLDB_LINE && curstash != debstash) {
5402 SV *sv = NEWSV(88,0);
5404 sv_upgrade(sv, SVt_PVMG);
5405 sv_setsv(sv,linestr);
5406 av_store(GvAV(curcop->cop_filegv),
5407 (I32)curcop->cop_line, sv);
5410 /* having changed the buffer, we must update bufend */
5411 bufend = SvPVX(linestr) + SvCUR(linestr);
5414 /* at this point, we have successfully read the delimited string */
5416 multi_end = curcop->cop_line;
5419 /* if we allocated too much space, give some back */
5420 if (SvCUR(sv) + 5 < SvLEN(sv)) {
5421 SvLEN_set(sv, SvCUR(sv) + 1);
5422 Renew(SvPVX(sv), SvLEN(sv), char);
5425 /* decide whether this is the first or second quoted string we've read
5438 takes: pointer to position in buffer
5439 returns: pointer to new position in buffer
5440 side-effects: builds ops for the constant in yylval.op
5442 Read a number in any of the formats that Perl accepts:
5444 0(x[0-7A-F]+)|([0-7]+)
5445 [\d_]+(\.[\d_]*)?[Ee](\d+)
5447 Underbars (_) are allowed in decimal numbers. If -w is on,
5448 underbars before a decimal point must be at three digit intervals.
5450 Like most scan_ routines, it uses the tokenbuf buffer to hold the
5453 If it reads a number without a decimal point or an exponent, it will
5454 try converting the number to an integer and see if it can do so
5455 without loss of precision.
5459 scan_num(char *start)
5461 register char *s = start; /* current position in buffer */
5462 register char *d; /* destination in temp buffer */
5463 register char *e; /* end of temp buffer */
5464 I32 tryiv; /* used to see if it can be an int */
5465 double value; /* number read, as a double */
5466 SV *sv; /* place to put the converted number */
5467 I32 floatit; /* boolean: int or float? */
5468 char *lastub = 0; /* position of last underbar */
5469 static char number_too_long[] = "Number too long";
5471 /* We use the first character to decide what type of number this is */
5475 croak("panic: scan_num");
5477 /* if it starts with a 0, it could be an octal number, a decimal in
5478 0.13 disguise, or a hexadecimal number.
5483 u holds the "number so far"
5484 shift the power of 2 of the base (hex == 4, octal == 3)
5485 overflowed was the number more than we can hold?
5487 Shift is used when we add a digit. It also serves as an "are
5488 we in octal or hex?" indicator to disallow hex characters when
5493 bool overflowed = FALSE;
5500 /* check for a decimal in disguise */
5501 else if (s[1] == '.')
5503 /* so it must be octal */
5508 /* read the rest of the octal number */
5510 UV n, b; /* n is used in the overflow test, b is the digit we're adding on */
5514 /* if we don't mention it, we're done */
5523 /* 8 and 9 are not octal */
5526 yyerror("Illegal octal digit");
5530 case '0': case '1': case '2': case '3': case '4':
5531 case '5': case '6': case '7':
5532 b = *s++ & 15; /* ASCII digit -> value of digit */
5536 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
5537 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
5538 /* make sure they said 0x */
5543 /* Prepare to put the digit we have onto the end
5544 of the number so far. We check for overflows.
5548 n = u << shift; /* make room for the digit */
5549 if (!overflowed && (n >> shift) != u) {
5550 warn("Integer overflow in %s number",
5551 (shift == 4) ? "hex" : "octal");
5554 u = n | b; /* add the digit to the end */
5559 /* if we get here, we had success: make a scalar value from
5569 handle decimal numbers.
5570 we're also sent here when we read a 0 as the first digit
5572 case '1': case '2': case '3': case '4': case '5':
5573 case '6': case '7': case '8': case '9': case '.':
5576 e = tokenbuf + sizeof tokenbuf - 6; /* room for various punctuation */
5579 /* read next group of digits and _ and copy into d */
5580 while (isDIGIT(*s) || *s == '_') {
5581 /* skip underscores, checking for misplaced ones
5585 if (dowarn && lastub && s - lastub != 3)
5586 warn("Misplaced _ in number");
5590 /* check for end of fixed-length buffer */
5592 croak(number_too_long);
5593 /* if we're ok, copy the character */
5598 /* final misplaced underbar check */
5599 if (dowarn && lastub && s - lastub != 3)
5600 warn("Misplaced _ in number");
5602 /* read a decimal portion if there is one. avoid
5603 3..5 being interpreted as the number 3. followed
5606 if (*s == '.' && s[1] != '.') {
5610 /* copy, ignoring underbars, until we run out of
5611 digits. Note: no misplaced underbar checks!
5613 for (; isDIGIT(*s) || *s == '_'; s++) {
5614 /* fixed length buffer check */
5616 croak(number_too_long);
5622 /* read exponent part, if present */
5623 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
5627 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
5628 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
5630 /* allow positive or negative exponent */
5631 if (*s == '+' || *s == '-')
5634 /* read digits of exponent (no underbars :-) */
5635 while (isDIGIT(*s)) {
5637 croak(number_too_long);
5642 /* terminate the string */
5645 /* make an sv from the string */
5647 /* reset numeric locale in case we were earlier left in Swaziland */
5648 SET_NUMERIC_STANDARD();
5649 value = atof(tokenbuf);
5652 See if we can make do with an integer value without loss of
5653 precision. We use I_V to cast to an int, because some
5654 compilers have issues. Then we try casting it back and see
5655 if it was the same. We only do this if we know we
5656 specifically read an integer.
5658 Note: if floatit is true, then we don't need to do the
5662 if (!floatit && (double)tryiv == value)
5663 sv_setiv(sv, tryiv);
5665 sv_setnv(sv, value);
5669 /* make the op for the constant and return */
5671 yylval.opval = newSVOP(OP_CONST, 0, sv);
5677 scan_formline(register char *s)
5682 SV *stuff = newSVpv("",0);
5683 bool needargs = FALSE;
5686 if (*s == '.' || *s == '}') {
5688 for (t = s+1; *t == ' ' || *t == '\t'; t++) ;
5692 if (in_eval && !rsfp) {
5693 eol = strchr(s,'\n');
5698 eol = bufend = SvPVX(linestr) + SvCUR(linestr);
5700 for (t = s; t < eol; t++) {
5701 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
5703 goto enough; /* ~~ must be first line in formline */
5705 if (*t == '@' || *t == '^')
5708 sv_catpvn(stuff, s, eol-s);
5712 s = filter_gets(linestr, rsfp, 0);
5713 oldoldbufptr = oldbufptr = bufptr = linestart = SvPVX(linestr);
5714 bufend = bufptr + SvCUR(linestr);
5717 yyerror("Format not terminated");
5727 lex_state = LEX_NORMAL;
5728 nextval[nexttoke].ival = 0;
5732 lex_state = LEX_FORMLINE;
5733 nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
5735 nextval[nexttoke].ival = OP_FORMLINE;
5739 SvREFCNT_dec(stuff);
5751 cshlen = strlen(cshname);
5756 start_subparse(I32 is_format, U32 flags)
5759 I32 oldsavestack_ix = savestack_ix;
5760 CV* outsidecv = compcv;
5764 assert(SvTYPE(compcv) == SVt_PVCV);
5771 SAVESPTR(comppad_name);
5773 SAVEI32(comppad_name_fill);
5774 SAVEI32(min_intro_pending);
5775 SAVEI32(max_intro_pending);
5776 SAVEI32(pad_reset_pending);
5778 compcv = (CV*)NEWSV(1104,0);
5779 sv_upgrade((SV *)compcv, is_format ? SVt_PVFM : SVt_PVCV);
5780 CvFLAGS(compcv) |= flags;
5783 av_push(comppad, Nullsv);
5784 curpad = AvARRAY(comppad);
5785 comppad_name = newAV();
5786 comppad_name_fill = 0;
5787 min_intro_pending = 0;
5789 subline = curcop->cop_line;
5791 av_store(comppad_name, 0, newSVpv("@_", 2));
5792 curpad[0] = (SV*)newAV();
5793 SvPADMY_on(curpad[0]); /* XXX Needed? */
5794 CvOWNER(compcv) = 0;
5795 New(666, CvMUTEXP(compcv), 1, perl_mutex);
5796 MUTEX_INIT(CvMUTEXP(compcv));
5797 #endif /* USE_THREADS */
5799 comppadlist = newAV();
5800 AvREAL_off(comppadlist);
5801 av_store(comppadlist, 0, (SV*)comppad_name);
5802 av_store(comppadlist, 1, (SV*)comppad);
5804 CvPADLIST(compcv) = comppadlist;
5805 CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc(outsidecv);
5807 CvOWNER(compcv) = 0;
5808 New(666, CvMUTEXP(compcv), 1, perl_mutex);
5809 MUTEX_INIT(CvMUTEXP(compcv));
5810 #endif /* USE_THREADS */
5812 return oldsavestack_ix;
5831 char *context = NULL;
5835 if (!yychar || (yychar == ';' && !rsfp))
5837 else if (bufptr > oldoldbufptr && bufptr - oldoldbufptr < 200 &&
5838 oldoldbufptr != oldbufptr && oldbufptr != bufptr) {
5839 while (isSPACE(*oldoldbufptr))
5841 context = oldoldbufptr;
5842 contlen = bufptr - oldoldbufptr;
5844 else if (bufptr > oldbufptr && bufptr - oldbufptr < 200 &&
5845 oldbufptr != bufptr) {
5846 while (isSPACE(*oldbufptr))
5848 context = oldbufptr;
5849 contlen = bufptr - oldbufptr;
5851 else if (yychar > 255)
5852 where = "next token ???";
5853 else if ((yychar & 127) == 127) {
5854 if (lex_state == LEX_NORMAL ||
5855 (lex_state == LEX_KNOWNEXT && lex_defer == LEX_NORMAL))
5856 where = "at end of line";
5858 where = "within pattern";
5860 where = "within string";
5863 SV *where_sv = sv_2mortal(newSVpv("next char ", 0));
5865 sv_catpvf(where_sv, "^%c", toCTRL(yychar));
5866 else if (isPRINT_LC(yychar))
5867 sv_catpvf(where_sv, "%c", yychar);
5869 sv_catpvf(where_sv, "\\%03o", yychar & 255);
5870 where = SvPVX(where_sv);
5872 msg = sv_2mortal(newSVpv(s, 0));
5873 sv_catpvf(msg, " at %_ line %ld, ",
5874 GvSV(curcop->cop_filegv), (long)curcop->cop_line);
5876 sv_catpvf(msg, "near \"%.*s\"\n", contlen, context);
5878 sv_catpvf(msg, "%s\n", where);
5879 if (multi_start < multi_end && (U32)(curcop->cop_line - multi_end) <= 1) {
5881 " (Might be a runaway multi-line %c%c string starting on line %ld)\n",
5882 (int)multi_open,(int)multi_close,(long)multi_start);
5888 sv_catsv(ERRSV, msg);
5890 PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
5891 if (++error_count >= 10)
5892 croak("%_ has too many errors.\n", GvSV(curcop->cop_filegv));
5894 in_my_stash = Nullhv;