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))
324 /* a safe way to store a small integer in a pointer */
325 expect = (expectation)((char *)e - tokenbuf);
329 restore_lex_expect(e)
332 /* a safe way to store a small integer in a pointer */
333 lex_expect = (expectation)((char *)e - tokenbuf);
348 while (*s == ' ' || *s == '\t') s++;
349 if (strnEQ(s, "line ", 5)) {
358 while (*s == ' ' || *s == '\t')
360 if (*s == '"' && (t = strchr(s+1, '"')))
364 return; /* false alarm */
365 for (t = s; !isSPACE(*t); t++) ;
370 curcop->cop_filegv = gv_fetchfile(s);
372 curcop->cop_filegv = gv_fetchfile(origfilename);
374 curcop->cop_line = atoi(n)-1;
378 skipspace(register char *s)
381 if (lex_formbrack && lex_brackets <= lex_formbrack) {
382 while (s < bufend && (*s == ' ' || *s == '\t'))
388 while (s < bufend && isSPACE(*s))
390 if (s < bufend && *s == '#') {
391 while (s < bufend && *s != '\n')
396 if (s < bufend || !rsfp || lex_state != LEX_NORMAL)
398 if ((s = filter_gets(linestr, rsfp, (prevlen = SvCUR(linestr)))) == Nullch) {
399 if (minus_n || minus_p) {
400 sv_setpv(linestr,minus_p ?
401 ";}continue{print or die qq(-p destination: $!\\n)" :
403 sv_catpv(linestr,";}");
404 minus_n = minus_p = 0;
407 sv_setpv(linestr,";");
408 oldoldbufptr = oldbufptr = bufptr = s = linestart = SvPVX(linestr);
409 bufend = SvPVX(linestr) + SvCUR(linestr);
410 if (preprocess && !in_eval)
411 (void)PerlProc_pclose(rsfp);
412 else if ((PerlIO*)rsfp == PerlIO_stdin())
413 PerlIO_clearerr(rsfp);
415 (void)PerlIO_close(rsfp);
421 linestart = bufptr = s + prevlen;
422 bufend = s + SvCUR(linestr);
425 if (PERLDB_LINE && curstash != debstash) {
426 SV *sv = NEWSV(85,0);
428 sv_upgrade(sv, SVt_PVMG);
429 sv_setpvn(sv,bufptr,bufend-bufptr);
430 av_store(GvAV(curcop->cop_filegv),(I32)curcop->cop_line,sv);
441 if (oldoldbufptr != last_uni)
443 while (isSPACE(*last_uni))
445 for (s = last_uni; isALNUM(*s) || *s == '-'; s++) ;
446 if ((t = strchr(s, '(')) && t < bufptr)
450 warn("Warning: Use of \"%s\" without parens is ambiguous", last_uni);
457 #define UNI(f) return uni(f,s)
465 last_uni = oldbufptr;
476 #endif /* CRIPPLED_CC */
478 #define LOP(f,x) return lop(f,x,s)
481 lop(I32 f, expectation x, char *s)
488 last_lop = oldbufptr;
504 nexttype[nexttoke] = type;
506 if (lex_state != LEX_KNOWNEXT) {
507 lex_defer = lex_state;
509 lex_state = LEX_KNOWNEXT;
514 force_word(register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
519 start = skipspace(start);
522 (allow_pack && *s == ':') ||
523 (allow_initial_tick && *s == '\'') )
525 s = scan_word(s, tokenbuf, sizeof tokenbuf, allow_pack, &len);
526 if (check_keyword && keyword(tokenbuf, len))
528 if (token == METHOD) {
538 nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(tokenbuf,0));
539 nextval[nexttoke].opval->op_private |= OPpCONST_BARE;
546 force_ident(register char *s, int kind)
549 OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
550 nextval[nexttoke].opval = o;
553 dTHR; /* just for in_eval */
554 o->op_private = OPpCONST_ENTERED;
555 /* XXX see note in pp_entereval() for why we forgo typo
556 warnings if the symbol must be introduced in an eval.
558 gv_fetchpv(s, in_eval ? (GV_ADDMULTI | 8) : TRUE,
559 kind == '$' ? SVt_PV :
560 kind == '@' ? SVt_PVAV :
561 kind == '%' ? SVt_PVHV :
569 force_version(char *s)
571 OP *version = Nullop;
575 /* default VERSION number -- GBARR */
580 for( d=s, c = 1; isDIGIT(*d) || *d == '_' || (*d == '.' && c--); d++);
581 if((*d == ';' || isSPACE(*d)) && *(skipspace(d)) != ',') {
583 /* real VERSION number -- GBARR */
584 version = yylval.opval;
588 /* NOTE: The parser sees the package name and the VERSION swapped */
589 nextval[nexttoke].opval = version;
606 s = SvPV_force(sv, len);
610 while (s < send && *s != '\\')
617 if (s + 1 < send && (s[1] == '\\'))
618 s++; /* all that, just for this */
623 SvCUR_set(sv, d - SvPVX(sv));
631 register I32 op_type = yylval.ival;
633 if (op_type == OP_NULL) {
634 yylval.opval = lex_op;
638 if (op_type == OP_CONST || op_type == OP_READLINE) {
639 SV *sv = q(lex_stuff);
641 char *p = SvPV(sv, len);
642 yylval.opval = (OP*)newSVOP(op_type, 0, newSVpv(p, len));
648 sublex_info.super_state = lex_state;
649 sublex_info.sub_inwhat = op_type;
650 sublex_info.sub_op = lex_op;
651 lex_state = LEX_INTERPPUSH;
655 yylval.opval = lex_op;
669 lex_state = sublex_info.super_state;
671 SAVEI32(lex_brackets);
672 SAVEI32(lex_fakebrack);
673 SAVEI32(lex_casemods);
678 SAVEI16(curcop->cop_line);
681 SAVEPPTR(oldoldbufptr);
684 SAVEPPTR(lex_brackstack);
685 SAVEPPTR(lex_casestack);
690 bufend = bufptr = oldbufptr = oldoldbufptr = linestart = SvPVX(linestr);
691 bufend += SvCUR(linestr);
697 New(899, lex_brackstack, 120, char);
698 New(899, lex_casestack, 12, char);
699 SAVEFREEPV(lex_brackstack);
700 SAVEFREEPV(lex_casestack);
702 *lex_casestack = '\0';
704 lex_state = LEX_INTERPCONCAT;
705 curcop->cop_line = multi_start;
707 lex_inwhat = sublex_info.sub_inwhat;
708 if (lex_inwhat == OP_MATCH || lex_inwhat == OP_SUBST)
709 lex_inpat = sublex_info.sub_op;
721 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv("",0));
725 if (lex_casemods) { /* oops, we've got some unbalanced parens */
726 lex_state = LEX_INTERPCASEMOD;
730 /* Is there a right-hand side to take care of? */
731 if (lex_repl && (lex_inwhat == OP_SUBST || lex_inwhat == OP_TRANS)) {
734 bufend = bufptr = oldbufptr = oldoldbufptr = linestart = SvPVX(linestr);
735 bufend += SvCUR(linestr);
741 *lex_casestack = '\0';
743 if (SvCOMPILED(lex_repl)) {
744 lex_state = LEX_INTERPNORMAL;
748 lex_state = LEX_INTERPCONCAT;
754 bufend = SvPVX(linestr);
755 bufend += SvCUR(linestr);
764 Extracts a pattern, double-quoted string, or transliteration. This
767 It looks at lex_inwhat and lex_inpat to find out whether it's
768 processing a pattern (lex_inpat is true), a transliteration
769 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
773 double-quoted style: \r and \n
774 regexp special ones: \D \s
776 backrefs: \1 (deprecated in substitution replacements)
777 case and quoting: \U \Q \E
778 stops on @ and $, but not for $ as tail anchor
781 characters are VERY literal, except for - not at the start or end
782 of the string, which indicates a range. scan_const expands the
783 range to the full set of intermediate characters.
785 In double-quoted strings:
787 double-quoted style: \r and \n
789 backrefs: \1 (deprecated)
790 case and quoting: \U \Q \E
793 scan_const does *not* construct ops to handle interpolated strings.
794 It stops processing as soon as it finds an embedded $ or @ variable
795 and leaves it to the caller to work out what's going on.
797 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
799 $ in pattern could be $foo or could be tail anchor. Assumption:
800 it's a tail anchor if $ is the last thing in the string, or if it's
801 followed by one of ")| \n\t"
803 \1 (backreferences) are turned into $1
805 The structure of the code is
806 while (there's a character to process) {
807 handle transliteration ranges
809 skip # initiated comments in //x patterns
810 check for embedded @foo
811 check for embedded scalars
813 leave intact backslashes from leave (below)
814 deprecate \1 in strings and sub replacements
815 handle string-changing backslashes \l \U \Q \E, etc.
816 switch (what was escaped) {
817 handle - in a transliteration (becomes a literal -)
818 handle \132 octal characters
819 handle 0x15 hex characters
820 handle \cV (control V)
821 handle printf backslashes (\f, \r, \n, etc)
824 } (end while character to read)
829 scan_const(char *start)
831 register char *send = bufend; /* end of the constant */
832 SV *sv = NEWSV(93, send - start); /* sv for the constant */
833 register char *s = start; /* start of the constant */
834 register char *d = SvPVX(sv); /* destination for copies */
835 bool dorange = FALSE; /* are we in a translit range? */
839 leave is the set of acceptably-backslashed characters.
841 I do *not* understand why there's the double hook here.
845 ? "\\.^$@AGZdDwWsSbB+*?|()-nrtfeaxc0123456789[{]} \t\n\r\f\v#"
846 : (lex_inwhat & OP_TRANS)
850 while (s < send || dorange) {
851 /* get transliterations out of the way (they're most literal) */
852 if (lex_inwhat == OP_TRANS) {
853 /* expand a range A-Z to the full set of characters. AIE! */
855 I32 i; /* current expanded character */
856 I32 max; /* last character in range */
858 i = d - SvPVX(sv); /* remember current offset */
859 SvGROW(sv, SvLEN(sv) + 256); /* expand the sv -- there'll never be more'n 256 chars in a range for it to grow by */
860 d = SvPVX(sv) + i; /* restore d after the grow potentially has changed the ptr */
861 d -= 2; /* eat the first char and the - */
863 max = (U8)d[1]; /* last char in range */
865 for (i = (U8)*d; i <= max; i++)
868 /* mark the range as done, and continue */
873 /* range begins (ignore - as first or last char) */
874 else if (*s == '-' && s+1 < send && s != start) {
880 /* if we get here, we're not doing a transliteration */
882 /* skip for regexp comments /(?#comment)/ */
883 else if (*s == '(' && lex_inpat && s[1] == '?') {
885 while (s < send && *s != ')')
887 } else if (s[2] == '{') { /* This should march regcomp.c */
889 char *regparse = s + 3;
892 while (count && (c = *regparse)) {
893 if (c == '\\' && regparse[1])
901 if (*regparse == ')')
904 yyerror("Sequence (?{...}) not terminated or not {}-balanced");
905 while (s < regparse && *s != ')')
910 /* likewise skip #-initiated comments in //x patterns */
911 else if (*s == '#' && lex_inpat &&
912 ((PMOP*)lex_inpat)->op_pmflags & PMf_EXTENDED) {
913 while (s+1 < send && *s != '\n')
917 /* check for embedded arrays (@foo, @:foo, @'foo, @{foo}, @$foo) */
918 else if (*s == '@' && s[1] && (isALNUM(s[1]) || strchr(":'{$", s[1])))
921 /* check for embedded scalars. only stop if we're sure it's a
924 else if (*s == '$') {
925 if (!lex_inpat) /* not a regexp, so $ must be var */
927 if (s + 1 < send && !strchr("()| \n\t", s[1]))
928 break; /* in regexp, $ might be tail anchor */
932 if (*s == '\\' && s+1 < send) {
935 /* some backslashes we leave behind */
936 if (*s && strchr(leaveit, *s)) {
942 /* deprecate \1 in strings and substitution replacements */
943 if (lex_inwhat == OP_SUBST && !lex_inpat &&
944 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
947 warn("\\%c better written as $%c", *s, *s);
952 /* string-change backslash escapes */
953 if (lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
958 /* if we get here, it's either a quoted -, or a digit */
961 /* quoted - in transliterations */
963 if (lex_inwhat == OP_TRANS) {
968 /* default action is to copy the quoted character */
973 /* \132 indicates an octal constant */
974 case '0': case '1': case '2': case '3':
975 case '4': case '5': case '6': case '7':
976 *d++ = scan_oct(s, 3, &len);
980 /* \x24 indicates a hex constant */
982 *d++ = scan_hex(++s, 2, &len);
986 /* \c is a control character */
993 /* printf-style backslashes, formfeeds, newlines, etc */
1019 } /* end if (backslash) */
1022 } /* while loop to process each character */
1024 /* terminate the string and set up the sv */
1026 SvCUR_set(sv, d - SvPVX(sv));
1029 /* shrink the sv if we allocated more than we used */
1030 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1031 SvLEN_set(sv, SvCUR(sv) + 1);
1032 Renew(SvPVX(sv), SvLEN(sv), char);
1037 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1043 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1045 intuit_more(register char *s)
1049 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1051 if (*s != '{' && *s != '[')
1056 /* In a pattern, so maybe we have {n,m}. */
1073 /* On the other hand, maybe we have a character class */
1076 if (*s == ']' || *s == '^')
1079 int weight = 2; /* let's weigh the evidence */
1081 unsigned char un_char = 0, last_un_char;
1082 char *send = strchr(s,']');
1083 char tmpbuf[sizeof tokenbuf * 4];
1085 if (!send) /* has to be an expression */
1088 Zero(seen,256,char);
1091 else if (isDIGIT(*s)) {
1093 if (isDIGIT(s[1]) && s[2] == ']')
1099 for (; s < send; s++) {
1100 last_un_char = un_char;
1101 un_char = (unsigned char)*s;
1106 weight -= seen[un_char] * 10;
1107 if (isALNUM(s[1])) {
1108 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1109 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1114 else if (*s == '$' && s[1] &&
1115 strchr("[#!%*<>()-=",s[1])) {
1116 if (/*{*/ strchr("])} =",s[2]))
1125 if (strchr("wds]",s[1]))
1127 else if (seen['\''] || seen['"'])
1129 else if (strchr("rnftbxcav",s[1]))
1131 else if (isDIGIT(s[1])) {
1133 while (s[1] && isDIGIT(s[1]))
1143 if (strchr("aA01! ",last_un_char))
1145 if (strchr("zZ79~",s[1]))
1149 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1150 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1155 if (keyword(tmpbuf, d - tmpbuf))
1158 if (un_char == last_un_char + 1)
1160 weight -= seen[un_char];
1165 if (weight >= 0) /* probably a character class */
1173 intuit_method(char *start, GV *gv)
1175 char *s = start + (*start == '$');
1176 char tmpbuf[sizeof tokenbuf];
1184 if ((cv = GvCVu(gv))) {
1185 char *proto = SvPVX(cv);
1195 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1196 if (*start == '$') {
1197 if (gv || last_lop_op == OP_PRINT || isUPPER(*tokenbuf))
1202 return *s == '(' ? FUNCMETH : METHOD;
1204 if (!keyword(tmpbuf, len)) {
1205 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1210 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1211 if (indirgv && GvCVu(indirgv))
1213 /* filehandle or package name makes it a method */
1214 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1216 if ((bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1217 return 0; /* no assumptions -- "=>" quotes bearword */
1219 nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1221 nextval[nexttoke].opval->op_private = OPpCONST_BARE;
1225 return *s == '(' ? FUNCMETH : METHOD;
1235 char *pdb = PerlEnv_getenv("PERL5DB");
1239 SETERRNO(0,SS$_NORMAL);
1240 return "BEGIN { require 'perl5db.pl' }";
1246 /* Encoded script support. filter_add() effectively inserts a
1247 * 'pre-processing' function into the current source input stream.
1248 * Note that the filter function only applies to the current source file
1249 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1251 * The datasv parameter (which may be NULL) can be used to pass
1252 * private data to this instance of the filter. The filter function
1253 * can recover the SV using the FILTER_DATA macro and use it to
1254 * store private buffers and state information.
1256 * The supplied datasv parameter is upgraded to a PVIO type
1257 * and the IoDIRP field is used to store the function pointer.
1258 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1259 * private use must be set using malloc'd pointers.
1261 static int filter_debug = 0;
1264 filter_add(filter_t funcp, SV *datasv)
1266 if (!funcp){ /* temporary handy debugging hack to be deleted */
1267 filter_debug = atoi((char*)datasv);
1271 rsfp_filters = newAV();
1273 datasv = NEWSV(255,0);
1274 if (!SvUPGRADE(datasv, SVt_PVIO))
1275 die("Can't upgrade filter_add data to SVt_PVIO");
1276 IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
1278 warn("filter_add func %p (%s)", funcp, SvPV(datasv,na));
1279 av_unshift(rsfp_filters, 1);
1280 av_store(rsfp_filters, 0, datasv) ;
1285 /* Delete most recently added instance of this filter function. */
1287 filter_del(filter_t funcp)
1290 warn("filter_del func %p", funcp);
1291 if (!rsfp_filters || AvFILLp(rsfp_filters)<0)
1293 /* if filter is on top of stack (usual case) just pop it off */
1294 if (IoDIRP(FILTER_DATA(AvFILLp(rsfp_filters))) == (void*)funcp){
1295 sv_free(av_pop(rsfp_filters));
1299 /* we need to search for the correct entry and clear it */
1300 die("filter_del can only delete in reverse order (currently)");
1304 /* Invoke the n'th filter function for the current rsfp. */
1306 filter_read(int idx, SV *buf_sv, int maxlen)
1309 /* 0 = read one text line */
1316 if (idx > AvFILLp(rsfp_filters)){ /* Any more filters? */
1317 /* Provide a default input filter to make life easy. */
1318 /* Note that we append to the line. This is handy. */
1320 warn("filter_read %d: from rsfp\n", idx);
1324 int old_len = SvCUR(buf_sv) ;
1326 /* ensure buf_sv is large enough */
1327 SvGROW(buf_sv, old_len + maxlen) ;
1328 if ((len = PerlIO_read(rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1329 if (PerlIO_error(rsfp))
1330 return -1; /* error */
1332 return 0 ; /* end of file */
1334 SvCUR_set(buf_sv, old_len + len) ;
1337 if (sv_gets(buf_sv, rsfp, SvCUR(buf_sv)) == NULL) {
1338 if (PerlIO_error(rsfp))
1339 return -1; /* error */
1341 return 0 ; /* end of file */
1344 return SvCUR(buf_sv);
1346 /* Skip this filter slot if filter has been deleted */
1347 if ( (datasv = FILTER_DATA(idx)) == &sv_undef){
1349 warn("filter_read %d: skipped (filter deleted)\n", idx);
1350 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1352 /* Get function pointer hidden within datasv */
1353 funcp = (filter_t)IoDIRP(datasv);
1355 warn("filter_read %d: via function %p (%s)\n",
1356 idx, funcp, SvPV(datasv,na));
1357 /* Call function. The function is expected to */
1358 /* call "FILTER_READ(idx+1, buf_sv)" first. */
1359 /* Return: <0:error, =0:eof, >0:not eof */
1360 return (*funcp)(idx, buf_sv, maxlen);
1364 filter_gets(register SV *sv, register PerlIO *fp, STRLEN append)
1367 if (!rsfp_filters) {
1368 filter_add(win32_textfilter,NULL);
1374 SvCUR_set(sv, 0); /* start with empty line */
1375 if (FILTER_READ(0, sv, 0) > 0)
1376 return ( SvPVX(sv) ) ;
1381 return (sv_gets(sv, fp, append));
1386 static char* exp_name[] =
1387 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "TERMBLOCK" };
1390 EXT int yychar; /* last token */
1395 Works out what to call the token just pulled out of the input
1396 stream. The yacc parser takes care of taking the ops we return and
1397 stitching them into a tree.
1403 if read an identifier
1404 if we're in a my declaration
1405 croak if they tried to say my($foo::bar)
1406 build the ops for a my() declaration
1407 if it's an access to a my() variable
1408 are we in a sort block?
1409 croak if my($a); $a <=> $b
1410 build ops for access to a my() variable
1411 if in a dq string, and they've said @foo and we can't find @foo
1413 build ops for a bareword
1414 if we already built the token before, use it.
1428 /* check if there's an identifier for us to look at */
1429 if (pending_ident) {
1430 /* pit holds the identifier we read and pending_ident is reset */
1431 char pit = pending_ident;
1434 /* if we're in a my(), we can't allow dynamics here.
1435 $foo'bar has already been turned into $foo::bar, so
1436 just check for colons.
1438 if it's a legal name, the OP is a PADANY.
1441 if (strchr(tokenbuf,':'))
1442 croak(no_myglob,tokenbuf);
1444 yylval.opval = newOP(OP_PADANY, 0);
1445 yylval.opval->op_targ = pad_allocmy(tokenbuf);
1450 build the ops for accesses to a my() variable.
1452 Deny my($a) or my($b) in a sort block, *if* $a or $b is
1453 then used in a comparison. This catches most, but not
1454 all cases. For instance, it catches
1455 sort { my($a); $a <=> $b }
1457 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
1458 (although why you'd do that is anyone's guess).
1461 if (!strchr(tokenbuf,':')) {
1463 /* Check for single character per-thread SVs */
1464 if (tokenbuf[0] == '$' && tokenbuf[2] == '\0'
1465 && !isALPHA(tokenbuf[1]) /* Rule out obvious non-threadsvs */
1466 && (tmp = find_threadsv(&tokenbuf[1])) != NOT_IN_PAD)
1468 yylval.opval = newOP(OP_THREADSV, 0);
1469 yylval.opval->op_targ = tmp;
1472 #endif /* USE_THREADS */
1473 if ((tmp = pad_findmy(tokenbuf)) != NOT_IN_PAD) {
1474 /* if it's a sort block and they're naming $a or $b */
1475 if (last_lop_op == OP_SORT &&
1476 tokenbuf[0] == '$' &&
1477 (tokenbuf[1] == 'a' || tokenbuf[1] == 'b')
1480 for (d = in_eval ? oldoldbufptr : linestart;
1481 d < bufend && *d != '\n';
1484 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
1485 croak("Can't use \"my %s\" in sort comparison",
1491 yylval.opval = newOP(OP_PADANY, 0);
1492 yylval.opval->op_targ = tmp;
1498 Whine if they've said @foo in a doublequoted string,
1499 and @foo isn't a variable we can find in the symbol
1502 if (pit == '@' && lex_state != LEX_NORMAL && !lex_brackets) {
1503 GV *gv = gv_fetchpv(tokenbuf+1, FALSE, SVt_PVAV);
1504 if (!gv || ((tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
1505 yyerror(form("In string, %s now must be written as \\%s",
1506 tokenbuf, tokenbuf));
1509 /* build ops for a bareword */
1510 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(tokenbuf+1, 0));
1511 yylval.opval->op_private = OPpCONST_ENTERED;
1512 gv_fetchpv(tokenbuf+1, in_eval ? (GV_ADDMULTI | 8) : TRUE,
1513 ((tokenbuf[0] == '$') ? SVt_PV
1514 : (tokenbuf[0] == '@') ? SVt_PVAV
1519 /* no identifier pending identification */
1521 switch (lex_state) {
1523 case LEX_NORMAL: /* Some compilers will produce faster */
1524 case LEX_INTERPNORMAL: /* code if we comment these out. */
1528 /* when we're already built the next token, just pull it out the queue */
1531 yylval = nextval[nexttoke];
1533 lex_state = lex_defer;
1534 expect = lex_expect;
1535 lex_defer = LEX_NORMAL;
1537 return(nexttype[nexttoke]);
1539 /* interpolated case modifiers like \L \U, including \Q and \E.
1540 when we get here, bufptr is at the \
1542 case LEX_INTERPCASEMOD:
1544 if (bufptr != bufend && *bufptr != '\\')
1545 croak("panic: INTERPCASEMOD");
1547 /* handle \E or end of string */
1548 if (bufptr == bufend || bufptr[1] == 'E') {
1553 oldmod = lex_casestack[--lex_casemods];
1554 lex_casestack[lex_casemods] = '\0';
1556 if (bufptr != bufend && strchr("LUQ", oldmod)) {
1558 lex_state = LEX_INTERPCONCAT;
1562 if (bufptr != bufend)
1564 lex_state = LEX_INTERPCONCAT;
1569 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
1570 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
1571 if (strchr("LU", *s) &&
1572 (strchr(lex_casestack, 'L') || strchr(lex_casestack, 'U')))
1574 lex_casestack[--lex_casemods] = '\0';
1577 if (lex_casemods > 10) {
1578 char* newlb = Renew(lex_casestack, lex_casemods + 2, char);
1579 if (newlb != lex_casestack) {
1581 lex_casestack = newlb;
1584 lex_casestack[lex_casemods++] = *s;
1585 lex_casestack[lex_casemods] = '\0';
1586 lex_state = LEX_INTERPCONCAT;
1587 nextval[nexttoke].ival = 0;
1590 nextval[nexttoke].ival = OP_LCFIRST;
1592 nextval[nexttoke].ival = OP_UCFIRST;
1594 nextval[nexttoke].ival = OP_LC;
1596 nextval[nexttoke].ival = OP_UC;
1598 nextval[nexttoke].ival = OP_QUOTEMETA;
1600 croak("panic: yylex");
1612 case LEX_INTERPPUSH:
1613 return sublex_push();
1615 case LEX_INTERPSTART:
1616 if (bufptr == bufend)
1617 return sublex_done();
1619 lex_dojoin = (*bufptr == '@');
1620 lex_state = LEX_INTERPNORMAL;
1622 nextval[nexttoke].ival = 0;
1625 nextval[nexttoke].opval = newOP(OP_THREADSV, 0);
1626 nextval[nexttoke].opval->op_targ = find_threadsv("\"");
1627 force_next(PRIVATEREF);
1629 force_ident("\"", '$');
1630 #endif /* USE_THREADS */
1631 nextval[nexttoke].ival = 0;
1633 nextval[nexttoke].ival = 0;
1635 nextval[nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
1644 case LEX_INTERPENDMAYBE:
1645 if (intuit_more(bufptr)) {
1646 lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
1654 lex_state = LEX_INTERPCONCAT;
1658 case LEX_INTERPCONCAT:
1661 croak("panic: INTERPCONCAT");
1663 if (bufptr == bufend)
1664 return sublex_done();
1666 if (SvIVX(linestr) == '\'') {
1667 SV *sv = newSVsv(linestr);
1670 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1674 s = scan_const(bufptr);
1676 lex_state = LEX_INTERPCASEMOD;
1678 lex_state = LEX_INTERPSTART;
1682 nextval[nexttoke] = yylval;
1695 lex_state = LEX_NORMAL;
1696 s = scan_formline(bufptr);
1703 oldoldbufptr = oldbufptr;
1706 PerlIO_printf(PerlIO_stderr(), "### Tokener expecting %s at %s\n", exp_name[expect], s);
1712 croak("Unrecognized character \\%03o", *s & 255);
1715 goto fake_eof; /* emulate EOF on ^D or ^Z */
1721 yyerror("Missing right bracket");
1725 goto retry; /* ignore stray nulls */
1728 if (!in_eval && !preambled) {
1730 sv_setpv(linestr,incl_perldb());
1732 sv_catpv(linestr,";");
1734 while(AvFILLp(preambleav) >= 0) {
1735 SV *tmpsv = av_shift(preambleav);
1736 sv_catsv(linestr, tmpsv);
1737 sv_catpv(linestr, ";");
1740 sv_free((SV*)preambleav);
1743 if (minus_n || minus_p) {
1744 sv_catpv(linestr, "LINE: while (<>) {");
1746 sv_catpv(linestr,"chomp;");
1748 GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
1750 GvIMPORTED_AV_on(gv);
1752 if (strchr("/'\"", *splitstr)
1753 && strchr(splitstr + 1, *splitstr))
1754 sv_catpvf(linestr, "@F=split(%s);", splitstr);
1757 s = "'~#\200\1'"; /* surely one char is unused...*/
1758 while (s[1] && strchr(splitstr, *s)) s++;
1760 sv_catpvf(linestr, "@F=split(%s%c",
1761 "q" + (delim == '\''), delim);
1762 for (s = splitstr; *s; s++) {
1764 sv_catpvn(linestr, "\\", 1);
1765 sv_catpvn(linestr, s, 1);
1767 sv_catpvf(linestr, "%c);", delim);
1771 sv_catpv(linestr,"@F=split(' ');");
1774 sv_catpv(linestr, "\n");
1775 oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr);
1776 bufend = SvPVX(linestr) + SvCUR(linestr);
1777 if (PERLDB_LINE && curstash != debstash) {
1778 SV *sv = NEWSV(85,0);
1780 sv_upgrade(sv, SVt_PVMG);
1781 sv_setsv(sv,linestr);
1782 av_store(GvAV(curcop->cop_filegv),(I32)curcop->cop_line,sv);
1787 if ((s = filter_gets(linestr, rsfp, 0)) == Nullch) {
1790 if (preprocess && !in_eval)
1791 (void)PerlProc_pclose(rsfp);
1792 else if ((PerlIO *)rsfp == PerlIO_stdin())
1793 PerlIO_clearerr(rsfp);
1795 (void)PerlIO_close(rsfp);
1800 if (!in_eval && (minus_n || minus_p)) {
1801 sv_setpv(linestr,minus_p ? ";}continue{print" : "");
1802 sv_catpv(linestr,";}");
1803 oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr);
1804 bufend = SvPVX(linestr) + SvCUR(linestr);
1805 minus_n = minus_p = 0;
1808 oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr);
1809 sv_setpv(linestr,"");
1810 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
1813 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
1816 /* Incest with pod. */
1817 if (*s == '=' && strnEQ(s, "=cut", 4)) {
1818 sv_setpv(linestr, "");
1819 oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr);
1820 bufend = SvPVX(linestr) + SvCUR(linestr);
1825 } while (doextract);
1826 oldoldbufptr = oldbufptr = bufptr = linestart = s;
1827 if (PERLDB_LINE && curstash != debstash) {
1828 SV *sv = NEWSV(85,0);
1830 sv_upgrade(sv, SVt_PVMG);
1831 sv_setsv(sv,linestr);
1832 av_store(GvAV(curcop->cop_filegv),(I32)curcop->cop_line,sv);
1834 bufend = SvPVX(linestr) + SvCUR(linestr);
1835 if (curcop->cop_line == 1) {
1836 while (s < bufend && isSPACE(*s))
1838 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
1842 if (*s == '#' && *(s+1) == '!')
1844 #ifdef ALTERNATE_SHEBANG
1846 static char as[] = ALTERNATE_SHEBANG;
1847 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
1848 d = s + (sizeof(as) - 1);
1850 #endif /* ALTERNATE_SHEBANG */
1859 while (*d && !isSPACE(*d))
1863 #ifdef ARG_ZERO_IS_SCRIPT
1864 if (ipathend > ipath) {
1866 * HP-UX (at least) sets argv[0] to the script name,
1867 * which makes $^X incorrect. And Digital UNIX and Linux,
1868 * at least, set argv[0] to the basename of the Perl
1869 * interpreter. So, having found "#!", we'll set it right.
1871 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
1872 assert(SvPOK(x) || SvGMAGICAL(x));
1873 if (sv_eq(x, GvSV(curcop->cop_filegv))) {
1874 sv_setpvn(x, ipath, ipathend - ipath);
1877 TAINT_NOT; /* $^X is always tainted, but that's OK */
1879 #endif /* ARG_ZERO_IS_SCRIPT */
1884 d = instr(s,"perl -");
1886 d = instr(s,"perl");
1887 #ifdef ALTERNATE_SHEBANG
1889 * If the ALTERNATE_SHEBANG on this system starts with a
1890 * character that can be part of a Perl expression, then if
1891 * we see it but not "perl", we're probably looking at the
1892 * start of Perl code, not a request to hand off to some
1893 * other interpreter. Similarly, if "perl" is there, but
1894 * not in the first 'word' of the line, we assume the line
1895 * contains the start of the Perl program.
1897 if (d && *s != '#') {
1899 while (*c && !strchr("; \t\r\n\f\v#", *c))
1902 d = Nullch; /* "perl" not in first word; ignore */
1904 *s = '#'; /* Don't try to parse shebang line */
1906 #endif /* ALTERNATE_SHEBANG */
1911 !instr(s,"indir") &&
1912 instr(origargv[0],"perl"))
1918 while (s < bufend && isSPACE(*s))
1921 Newz(899,newargv,origargc+3,char*);
1923 while (s < bufend && !isSPACE(*s))
1926 Copy(origargv+1, newargv+2, origargc+1, char*);
1931 execv(ipath, newargv);
1932 croak("Can't exec %s", ipath);
1935 U32 oldpdb = perldb;
1936 bool oldn = minus_n;
1937 bool oldp = minus_p;
1939 while (*d && !isSPACE(*d)) d++;
1940 while (*d == ' ' || *d == '\t') d++;
1944 if (*d == 'M' || *d == 'm') {
1946 while (*d && !isSPACE(*d)) d++;
1947 croak("Too late for \"-%.*s\" option",
1950 d = moreswitches(d);
1952 if (PERLDB_LINE && !oldpdb ||
1953 ( minus_n || minus_p ) && !(oldn || oldp) )
1954 /* if we have already added "LINE: while (<>) {",
1955 we must not do it again */
1957 sv_setpv(linestr, "");
1958 oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr);
1959 bufend = SvPVX(linestr) + SvCUR(linestr);
1962 (void)gv_fetchfile(origfilename);
1969 if (lex_formbrack && lex_brackets <= lex_formbrack) {
1971 lex_state = LEX_FORMLINE;
1977 warn("Illegal character \\%03o (carriage return)", '\r');
1979 "(Maybe you didn't strip carriage returns after a network transfer?)\n");
1981 case ' ': case '\t': case '\f': case 013:
1986 if (lex_state != LEX_NORMAL || (in_eval && !rsfp)) {
1988 while (s < d && *s != '\n')
1993 if (lex_formbrack && lex_brackets <= lex_formbrack) {
1995 lex_state = LEX_FORMLINE;
2005 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2010 while (s < bufend && (*s == ' ' || *s == '\t'))
2013 if (strnEQ(s,"=>",2)) {
2014 s = force_word(bufptr,WORD,FALSE,FALSE,FALSE);
2015 OPERATOR('-'); /* unary minus */
2017 last_uni = oldbufptr;
2018 last_lop_op = OP_FTEREAD; /* good enough */
2020 case 'r': FTST(OP_FTEREAD);
2021 case 'w': FTST(OP_FTEWRITE);
2022 case 'x': FTST(OP_FTEEXEC);
2023 case 'o': FTST(OP_FTEOWNED);
2024 case 'R': FTST(OP_FTRREAD);
2025 case 'W': FTST(OP_FTRWRITE);
2026 case 'X': FTST(OP_FTREXEC);
2027 case 'O': FTST(OP_FTROWNED);
2028 case 'e': FTST(OP_FTIS);
2029 case 'z': FTST(OP_FTZERO);
2030 case 's': FTST(OP_FTSIZE);
2031 case 'f': FTST(OP_FTFILE);
2032 case 'd': FTST(OP_FTDIR);
2033 case 'l': FTST(OP_FTLINK);
2034 case 'p': FTST(OP_FTPIPE);
2035 case 'S': FTST(OP_FTSOCK);
2036 case 'u': FTST(OP_FTSUID);
2037 case 'g': FTST(OP_FTSGID);
2038 case 'k': FTST(OP_FTSVTX);
2039 case 'b': FTST(OP_FTBLK);
2040 case 'c': FTST(OP_FTCHR);
2041 case 't': FTST(OP_FTTTY);
2042 case 'T': FTST(OP_FTTEXT);
2043 case 'B': FTST(OP_FTBINARY);
2044 case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2045 case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2046 case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
2048 croak("Unrecognized file test: -%c", (int)tmp);
2055 if (expect == XOPERATOR)
2060 else if (*s == '>') {
2063 if (isIDFIRST(*s)) {
2064 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2072 if (expect == XOPERATOR)
2075 if (isSPACE(*s) || !isSPACE(*bufptr))
2077 OPERATOR('-'); /* unary minus */
2084 if (expect == XOPERATOR)
2089 if (expect == XOPERATOR)
2092 if (isSPACE(*s) || !isSPACE(*bufptr))
2098 if (expect != XOPERATOR) {
2099 s = scan_ident(s, bufend, tokenbuf, sizeof tokenbuf, TRUE);
2101 force_ident(tokenbuf, '*');
2114 if (expect == XOPERATOR) {
2119 s = scan_ident(s, bufend, tokenbuf + 1, sizeof tokenbuf - 1, TRUE);
2122 yyerror("Final % should be \\% or %name");
2125 pending_ident = '%';
2147 if (last_lop == oldoldbufptr || last_uni == oldoldbufptr)
2148 oldbufptr = oldoldbufptr; /* allow print(STDOUT 123) */
2153 if (curcop->cop_line < copline)
2154 copline = curcop->cop_line;
2165 if (lex_brackets <= 0)
2166 yyerror("Unmatched right bracket");
2169 if (lex_state == LEX_INTERPNORMAL) {
2170 if (lex_brackets == 0) {
2171 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
2172 lex_state = LEX_INTERPEND;
2179 if (lex_brackets > 100) {
2180 char* newlb = Renew(lex_brackstack, lex_brackets + 1, char);
2181 if (newlb != lex_brackstack) {
2183 lex_brackstack = newlb;
2188 if (lex_formbrack) {
2192 if (oldoldbufptr == last_lop)
2193 lex_brackstack[lex_brackets++] = XTERM;
2195 lex_brackstack[lex_brackets++] = XOPERATOR;
2196 OPERATOR(HASHBRACK);
2198 while (s < bufend && (*s == ' ' || *s == '\t'))
2202 if (d < bufend && *d == '-') {
2205 while (d < bufend && (*d == ' ' || *d == '\t'))
2208 if (d < bufend && isIDFIRST(*d)) {
2209 d = scan_word(d, tokenbuf + 1, sizeof tokenbuf - 1,
2211 while (d < bufend && (*d == ' ' || *d == '\t'))
2214 char minus = (tokenbuf[0] == '-');
2215 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2222 lex_brackstack[lex_brackets++] = XSTATE;
2226 lex_brackstack[lex_brackets++] = XOPERATOR;
2231 if (oldoldbufptr == last_lop)
2232 lex_brackstack[lex_brackets++] = XTERM;
2234 lex_brackstack[lex_brackets++] = XOPERATOR;
2237 if (expect == XSTATE) {
2238 lex_brackstack[lex_brackets-1] = XSTATE;
2241 OPERATOR(HASHBRACK);
2243 /* This hack serves to disambiguate a pair of curlies
2244 * as being a block or an anon hash. Normally, expectation
2245 * determines that, but in cases where we're not in a
2246 * position to expect anything in particular (like inside
2247 * eval"") we have to resolve the ambiguity. This code
2248 * covers the case where the first term in the curlies is a
2249 * quoted string. Most other cases need to be explicitly
2250 * disambiguated by prepending a `+' before the opening
2251 * curly in order to force resolution as an anon hash.
2253 * XXX should probably propagate the outer expectation
2254 * into eval"" to rely less on this hack, but that could
2255 * potentially break current behavior of eval"".
2259 if (*s == '\'' || *s == '"' || *s == '`') {
2260 /* common case: get past first string, handling escapes */
2261 for (t++; t < bufend && *t != *s;)
2262 if (*t++ == '\\' && (*t == '\\' || *t == *s))
2266 else if (*s == 'q') {
2269 || ((*t == 'q' || *t == 'x') && ++t < bufend
2270 && !isALNUM(*t)))) {
2272 char open, close, term;
2275 while (t < bufend && isSPACE(*t))
2279 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
2283 for (t++; t < bufend; t++) {
2284 if (*t == '\\' && t+1 < bufend && open != '\\')
2286 else if (*t == open)
2290 for (t++; t < bufend; t++) {
2291 if (*t == '\\' && t+1 < bufend)
2293 else if (*t == close && --brackets <= 0)
2295 else if (*t == open)
2301 else if (isALPHA(*s)) {
2302 for (t++; t < bufend && isALNUM(*t); t++) ;
2304 while (t < bufend && isSPACE(*t))
2306 /* if comma follows first term, call it an anon hash */
2307 /* XXX it could be a comma expression with loop modifiers */
2308 if (t < bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
2309 || (*t == '=' && t[1] == '>')))
2310 OPERATOR(HASHBRACK);
2314 lex_brackstack[lex_brackets-1] = XSTATE;
2320 yylval.ival = curcop->cop_line;
2321 if (isSPACE(*s) || *s == '#')
2322 copline = NOLINE; /* invalidate current command line number */
2327 if (lex_brackets <= 0)
2328 yyerror("Unmatched right bracket");
2330 expect = (expectation)lex_brackstack[--lex_brackets];
2331 if (lex_brackets < lex_formbrack)
2333 if (lex_state == LEX_INTERPNORMAL) {
2334 if (lex_brackets == 0) {
2335 if (lex_fakebrack) {
2336 lex_state = LEX_INTERPEND;
2338 return yylex(); /* ignore fake brackets */
2340 if (*s == '-' && s[1] == '>')
2341 lex_state = LEX_INTERPENDMAYBE;
2342 else if (*s != '[' && *s != '{')
2343 lex_state = LEX_INTERPEND;
2346 if (lex_brackets < lex_fakebrack) {
2349 return yylex(); /* ignore fake brackets */
2359 if (expect == XOPERATOR) {
2360 if (dowarn && isALPHA(*s) && bufptr == linestart) {
2368 s = scan_ident(s - 1, bufend, tokenbuf, sizeof tokenbuf, TRUE);
2371 force_ident(tokenbuf, '&');
2375 yylval.ival = (OPpENTERSUB_AMPER<<8);
2394 if (dowarn && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
2395 warn("Reversed %c= operator",(int)tmp);
2397 if (expect == XSTATE && isALPHA(tmp) &&
2398 (s == linestart+1 || s[-2] == '\n') )
2400 if (in_eval && !rsfp) {
2405 if (strnEQ(s,"=cut",4)) {
2422 if (lex_brackets < lex_formbrack) {
2424 for (t = s; *t == ' ' || *t == '\t'; t++) ;
2425 if (*t == '\n' || *t == '#') {
2443 if (expect != XOPERATOR) {
2444 if (s[1] != '<' && !strchr(s,'>'))
2447 s = scan_heredoc(s);
2449 s = scan_inputsymbol(s);
2450 TERM(sublex_start());
2455 SHop(OP_LEFT_SHIFT);
2469 SHop(OP_RIGHT_SHIFT);
2478 if (expect == XOPERATOR) {
2479 if (lex_formbrack && lex_brackets == lex_formbrack) {
2482 return ','; /* grandfather non-comma-format format */
2486 if (s[1] == '#' && (isALPHA(s[2]) || strchr("_{$:", s[2]))) {
2487 if (expect == XOPERATOR)
2488 no_op("Array length", bufptr);
2490 s = scan_ident(s + 1, bufend, tokenbuf + 1, sizeof tokenbuf - 1,
2495 pending_ident = '#';
2499 if (expect == XOPERATOR)
2500 no_op("Scalar", bufptr);
2502 s = scan_ident(s, bufend, tokenbuf + 1, sizeof tokenbuf - 1, FALSE);
2505 yyerror("Final $ should be \\$ or $name");
2509 /* This kludge not intended to be bulletproof. */
2510 if (tokenbuf[1] == '[' && !tokenbuf[2]) {
2511 yylval.opval = newSVOP(OP_CONST, 0,
2512 newSViv((IV)compiling.cop_arybase));
2513 yylval.opval->op_private = OPpCONST_ARYBASE;
2518 if (lex_state == LEX_NORMAL)
2521 if ((expect != XREF || oldoldbufptr == last_lop) && intuit_more(s)) {
2527 isSPACE(*t) || isALNUM(*t) || *t == '$';
2530 bufptr = skipspace(bufptr);
2531 while (t < bufend && *t != ']')
2533 warn("Multidimensional syntax %.*s not supported",
2534 (t - bufptr) + 1, bufptr);
2538 else if (*s == '{') {
2540 if (dowarn && strEQ(tokenbuf+1, "SIG") &&
2541 (t = strchr(s, '}')) && (t = strchr(t, '=')))
2543 char tmpbuf[sizeof tokenbuf];
2545 for (t++; isSPACE(*t); t++) ;
2546 if (isIDFIRST(*t)) {
2547 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
2548 if (*t != '(' && perl_get_cv(tmpbuf, FALSE))
2549 warn("You need to quote \"%s\"", tmpbuf);
2556 if (lex_state == LEX_NORMAL && isSPACE(*d)) {
2557 bool islop = (last_lop == oldoldbufptr);
2558 if (!islop || last_lop_op == OP_GREPSTART)
2560 else if (strchr("$@\"'`q", *s))
2561 expect = XTERM; /* e.g. print $fh "foo" */
2562 else if (strchr("&*<%", *s) && isIDFIRST(s[1]))
2563 expect = XTERM; /* e.g. print $fh &sub */
2564 else if (isIDFIRST(*s)) {
2565 char tmpbuf[sizeof tokenbuf];
2566 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2567 if (tmp = keyword(tmpbuf, len)) {
2568 /* binary operators exclude handle interpretations */
2580 expect = XTERM; /* e.g. print $fh length() */
2585 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
2586 if (gv && GvCVu(gv))
2587 expect = XTERM; /* e.g. print $fh subr() */
2590 else if (isDIGIT(*s))
2591 expect = XTERM; /* e.g. print $fh 3 */
2592 else if (*s == '.' && isDIGIT(s[1]))
2593 expect = XTERM; /* e.g. print $fh .3 */
2594 else if (strchr("/?-+", *s) && !isSPACE(s[1]))
2595 expect = XTERM; /* e.g. print $fh -1 */
2596 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]))
2597 expect = XTERM; /* print $fh <<"EOF" */
2599 pending_ident = '$';
2603 if (expect == XOPERATOR)
2606 s = scan_ident(s, bufend, tokenbuf + 1, sizeof tokenbuf - 1, FALSE);
2609 yyerror("Final @ should be \\@ or @name");
2612 if (lex_state == LEX_NORMAL)
2614 if ((expect != XREF || oldoldbufptr == last_lop) && intuit_more(s)) {
2618 /* Warn about @ where they meant $. */
2620 if (*s == '[' || *s == '{') {
2622 while (*t && (isALNUM(*t) || strchr(" \t$#+-'\"", *t)))
2624 if (*t == '}' || *t == ']') {
2626 bufptr = skipspace(bufptr);
2627 warn("Scalar value %.*s better written as $%.*s",
2628 t-bufptr, bufptr, t-bufptr-1, bufptr+1);
2633 pending_ident = '@';
2636 case '/': /* may either be division or pattern */
2637 case '?': /* may either be conditional or pattern */
2638 if (expect != XOPERATOR) {
2639 /* Disable warning on "study /blah/" */
2640 if (oldoldbufptr == last_uni
2641 && (*last_uni != 's' || s - last_uni < 5
2642 || memNE(last_uni, "study", 5) || isALNUM(last_uni[5])))
2645 TERM(sublex_start());
2653 if (lex_formbrack && lex_brackets == lex_formbrack && s[1] == '\n' &&
2654 (s == linestart || s[-1] == '\n') ) {
2659 if (expect == XOPERATOR || !isDIGIT(s[1])) {
2665 yylval.ival = OPf_SPECIAL;
2671 if (expect != XOPERATOR)
2676 case '0': case '1': case '2': case '3': case '4':
2677 case '5': case '6': case '7': case '8': case '9':
2679 if (expect == XOPERATOR)
2685 if (expect == XOPERATOR) {
2686 if (lex_formbrack && lex_brackets == lex_formbrack) {
2689 return ','; /* grandfather non-comma-format format */
2695 missingterm((char*)0);
2696 yylval.ival = OP_CONST;
2697 TERM(sublex_start());
2701 if (expect == XOPERATOR) {
2702 if (lex_formbrack && lex_brackets == lex_formbrack) {
2705 return ','; /* grandfather non-comma-format format */
2711 missingterm((char*)0);
2712 yylval.ival = OP_CONST;
2713 for (d = SvPV(lex_stuff, len); len; len--, d++) {
2714 if (*d == '$' || *d == '@' || *d == '\\') {
2715 yylval.ival = OP_STRINGIFY;
2719 TERM(sublex_start());
2723 if (expect == XOPERATOR)
2724 no_op("Backticks",s);
2726 missingterm((char*)0);
2727 yylval.ival = OP_BACKTICK;
2729 TERM(sublex_start());
2733 if (dowarn && lex_inwhat && isDIGIT(*s))
2734 warn("Can't use \\%c to mean $%c in expression", *s, *s);
2735 if (expect == XOPERATOR)
2736 no_op("Backslash",s);
2740 if (isDIGIT(s[1]) && expect == XOPERATOR) {
2779 s = scan_word(s, tokenbuf, sizeof tokenbuf, FALSE, &len);
2781 /* Some keywords can be followed by any delimiter, including ':' */
2782 tmp = (len == 1 && strchr("msyq", tokenbuf[0]) ||
2783 len == 2 && ((tokenbuf[0] == 't' && tokenbuf[1] == 'r') ||
2784 (tokenbuf[0] == 'q' &&
2785 strchr("qwx", tokenbuf[1]))));
2787 /* x::* is just a word, unless x is "CORE" */
2788 if (!tmp && *s == ':' && s[1] == ':' && strNE(tokenbuf, "CORE"))
2792 while (d < bufend && isSPACE(*d))
2793 d++; /* no comments skipped here, or s### is misparsed */
2795 /* Is this a label? */
2796 if (!tmp && expect == XSTATE
2797 && d < bufend && *d == ':' && *(d + 1) != ':') {
2799 yylval.pval = savepv(tokenbuf);
2804 /* Check for keywords */
2805 tmp = keyword(tokenbuf, len);
2807 /* Is this a word before a => operator? */
2808 if (strnEQ(d,"=>",2)) {
2810 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(tokenbuf,0));
2811 yylval.opval->op_private = OPpCONST_BARE;
2815 if (tmp < 0) { /* second-class keyword? */
2816 if (expect != XOPERATOR && (*s != ':' || s[1] != ':') &&
2817 (((gv = gv_fetchpv(tokenbuf, FALSE, SVt_PVCV)) &&
2818 GvCVu(gv) && GvIMPORTED_CV(gv)) ||
2819 ((gvp = (GV**)hv_fetch(globalstash,tokenbuf,len,FALSE)) &&
2820 (gv = *gvp) != (GV*)&sv_undef &&
2821 GvCVu(gv) && GvIMPORTED_CV(gv))))
2823 tmp = 0; /* overridden by importation */
2826 && -tmp==KEY_lock /* XXX generalizable kludge */
2827 && !hv_fetch(GvHVn(incgv), "Thread.pm", 9, FALSE))
2829 tmp = 0; /* any sub overrides "weak" keyword */
2832 tmp = -tmp; gv = Nullgv; gvp = 0;
2839 default: /* not a keyword */
2842 char lastchar = (bufptr == oldoldbufptr ? 0 : bufptr[-1]);
2844 /* Get the rest if it looks like a package qualifier */
2846 if (*s == '\'' || *s == ':' && s[1] == ':') {
2848 s = scan_word(s, tokenbuf + len, sizeof tokenbuf - len,
2851 croak("Bad name after %s::", tokenbuf);
2855 if (expect == XOPERATOR) {
2856 if (bufptr == linestart) {
2862 no_op("Bareword",s);
2865 /* Look for a subroutine with this name in current package,
2866 unless name is "Foo::", in which case Foo is a bearword
2867 (and a package name). */
2870 tokenbuf[len - 2] == ':' && tokenbuf[len - 1] == ':')
2872 if (dowarn && ! gv_fetchpv(tokenbuf, FALSE, SVt_PVHV))
2873 warn("Bareword \"%s\" refers to nonexistent package",
2876 tokenbuf[len] = '\0';
2883 gv = gv_fetchpv(tokenbuf, FALSE, SVt_PVCV);
2886 /* if we saw a global override before, get the right name */
2889 sv = newSVpv("CORE::GLOBAL::",14);
2890 sv_catpv(sv,tokenbuf);
2893 sv = newSVpv(tokenbuf,0);
2895 /* Presume this is going to be a bareword of some sort. */
2898 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2899 yylval.opval->op_private = OPpCONST_BARE;
2901 /* And if "Foo::", then that's what it certainly is. */
2906 /* See if it's the indirect object for a list operator. */
2909 oldoldbufptr < bufptr &&
2910 (oldoldbufptr == last_lop || oldoldbufptr == last_uni) &&
2911 /* NO SKIPSPACE BEFORE HERE! */
2913 ((opargs[last_lop_op] >> OASHIFT)& 7) == OA_FILEREF) )
2915 bool immediate_paren = *s == '(';
2917 /* (Now we can afford to cross potential line boundary.) */
2920 /* Two barewords in a row may indicate method call. */
2922 if ((isALPHA(*s) || *s == '$') && (tmp=intuit_method(s,gv)))
2925 /* If not a declared subroutine, it's an indirect object. */
2926 /* (But it's an indir obj regardless for sort.) */
2928 if ((last_lop_op == OP_SORT ||
2929 (!immediate_paren && (!gv || !GvCVu(gv))) ) &&
2930 (last_lop_op != OP_MAPSTART && last_lop_op != OP_GREPSTART)){
2931 expect = (last_lop == oldoldbufptr) ? XTERM : XOPERATOR;
2936 /* If followed by a paren, it's certainly a subroutine. */
2942 if (gv && GvCVu(gv)) {
2943 for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
2944 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
2949 nextval[nexttoke].opval = yylval.opval;
2956 /* If followed by var or block, call it a method (unless sub) */
2958 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
2959 last_lop = oldbufptr;
2960 last_lop_op = OP_METHOD;
2964 /* If followed by a bareword, see if it looks like indir obj. */
2966 if ((isALPHA(*s) || *s == '$') && (tmp = intuit_method(s,gv)))
2969 /* Not a method, so call it a subroutine (if defined) */
2971 if (gv && GvCVu(gv)) {
2973 if (lastchar == '-')
2974 warn("Ambiguous use of -%s resolved as -&%s()",
2975 tokenbuf, tokenbuf);
2976 last_lop = oldbufptr;
2977 last_lop_op = OP_ENTERSUB;
2978 /* Check for a constant sub */
2980 if ((sv = cv_const_sv(cv))) {
2982 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
2983 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
2984 yylval.opval->op_private = 0;
2988 /* Resolve to GV now. */
2989 op_free(yylval.opval);
2990 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
2991 /* Is there a prototype? */
2994 char *proto = SvPV((SV*)cv, len);
2997 if (strEQ(proto, "$"))
2999 if (*proto == '&' && *s == '{') {
3000 sv_setpv(subname,"__ANON__");
3004 nextval[nexttoke].opval = yylval.opval;
3010 if (hints & HINT_STRICT_SUBS &&
3013 last_lop_op != OP_TRUNCATE && /* S/F prototype in opcode.pl */
3014 last_lop_op != OP_ACCEPT &&
3015 last_lop_op != OP_PIPE_OP &&
3016 last_lop_op != OP_SOCKPAIR)
3019 "Bareword \"%s\" not allowed while \"strict subs\" in use",
3024 /* Call it a bare word */
3028 if (lastchar != '-') {
3029 for (d = tokenbuf; *d && isLOWER(*d); d++) ;
3031 warn(warn_reserved, tokenbuf);
3036 if (lastchar && strchr("*%&", lastchar)) {
3037 warn("Operator or semicolon missing before %c%s",
3038 lastchar, tokenbuf);
3039 warn("Ambiguous use of %c resolved as operator %c",
3040 lastchar, lastchar);
3046 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3047 newSVsv(GvSV(curcop->cop_filegv)));
3051 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3052 newSVpvf("%ld", (long)curcop->cop_line));
3055 case KEY___PACKAGE__:
3056 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3058 ? newSVsv(curstname)
3067 if (rsfp && (!in_eval || tokenbuf[2] == 'D')) {
3068 char *pname = "main";
3069 if (tokenbuf[2] == 'D')
3070 pname = HvNAME(curstash ? curstash : defstash);
3071 gv = gv_fetchpv(form("%s::DATA", pname), TRUE, SVt_PVIO);
3074 GvIOp(gv) = newIO();
3075 IoIFP(GvIOp(gv)) = rsfp;
3076 #if defined(HAS_FCNTL) && defined(F_SETFD)
3078 int fd = PerlIO_fileno(rsfp);
3079 fcntl(fd,F_SETFD,fd >= 3);
3082 /* Mark this internal pseudo-handle as clean */
3083 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3085 IoTYPE(GvIOp(gv)) = '|';
3086 else if ((PerlIO*)rsfp == PerlIO_stdin())
3087 IoTYPE(GvIOp(gv)) = '-';
3089 IoTYPE(GvIOp(gv)) = '<';
3100 if (expect == XSTATE) {
3107 if (*s == ':' && s[1] == ':') {
3110 s = scan_word(s, tokenbuf, sizeof tokenbuf, FALSE, &len);
3111 tmp = keyword(tokenbuf, len);
3125 LOP(OP_ACCEPT,XTERM);
3131 LOP(OP_ATAN2,XTERM);
3140 LOP(OP_BLESS,XTERM);
3149 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
3169 LOP(OP_CRYPT,XTERM);
3173 for (d = s; d < bufend && (isSPACE(*d) || *d == '('); d++) ;
3174 if (*d != '0' && isDIGIT(*d))
3175 yywarn("chmod: mode argument is missing initial 0");
3177 LOP(OP_CHMOD,XTERM);
3180 LOP(OP_CHOWN,XTERM);
3183 LOP(OP_CONNECT,XTERM);
3199 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3203 hints |= HINT_BLOCK_SCOPE;
3213 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3214 LOP(OP_DBMOPEN,XTERM);
3220 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3227 yylval.ival = curcop->cop_line;
3241 expect = (*s == '{') ? XTERMBLOCK : XTERM;
3242 UNIBRACK(OP_ENTEREVAL);
3257 case KEY_endhostent:
3263 case KEY_endservent:
3266 case KEY_endprotoent:
3277 yylval.ival = curcop->cop_line;
3279 if (expect == XSTATE && isIDFIRST(*s)) {
3281 if ((bufend - p) >= 3 &&
3282 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3286 croak("Missing $ on loop variable");
3291 LOP(OP_FORMLINE,XTERM);
3297 LOP(OP_FCNTL,XTERM);
3303 LOP(OP_FLOCK,XTERM);
3312 LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
3315 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3330 case KEY_getpriority:
3331 LOP(OP_GETPRIORITY,XTERM);
3333 case KEY_getprotobyname:
3336 case KEY_getprotobynumber:
3337 LOP(OP_GPBYNUMBER,XTERM);
3339 case KEY_getprotoent:
3351 case KEY_getpeername:
3352 UNI(OP_GETPEERNAME);
3354 case KEY_gethostbyname:
3357 case KEY_gethostbyaddr:
3358 LOP(OP_GHBYADDR,XTERM);
3360 case KEY_gethostent:
3363 case KEY_getnetbyname:
3366 case KEY_getnetbyaddr:
3367 LOP(OP_GNBYADDR,XTERM);
3372 case KEY_getservbyname:
3373 LOP(OP_GSBYNAME,XTERM);
3375 case KEY_getservbyport:
3376 LOP(OP_GSBYPORT,XTERM);
3378 case KEY_getservent:
3381 case KEY_getsockname:
3382 UNI(OP_GETSOCKNAME);
3384 case KEY_getsockopt:
3385 LOP(OP_GSOCKOPT,XTERM);
3407 yylval.ival = curcop->cop_line;
3411 LOP(OP_INDEX,XTERM);
3417 LOP(OP_IOCTL,XTERM);
3429 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3460 LOP(OP_LISTEN,XTERM);
3470 TERM(sublex_start());
3473 LOP(OP_MAPSTART,XREF);
3476 LOP(OP_MKDIR,XTERM);
3479 LOP(OP_MSGCTL,XTERM);
3482 LOP(OP_MSGGET,XTERM);
3485 LOP(OP_MSGRCV,XTERM);
3488 LOP(OP_MSGSND,XTERM);
3493 if (isIDFIRST(*s)) {
3494 s = scan_word(s, tokenbuf, sizeof tokenbuf, TRUE, &len);
3495 in_my_stash = gv_stashpv(tokenbuf, FALSE);
3499 sprintf(tmpbuf, "No such class %.1000s", tokenbuf);
3506 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3513 if (expect != XSTATE)
3514 yyerror("\"no\" not allowed in expression");
3515 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3516 s = force_version(s);
3525 if (isIDFIRST(*s)) {
3527 for (d = s; isALNUM(*d); d++) ;
3529 if (strchr("|&*+-=!?:.", *t))
3530 warn("Precedence problem: open %.*s should be open(%.*s)",
3536 yylval.ival = OP_OR;
3546 LOP(OP_OPEN_DIR,XTERM);
3549 checkcomma(s,tokenbuf,"filehandle");
3553 checkcomma(s,tokenbuf,"filehandle");
3572 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3576 LOP(OP_PIPE_OP,XTERM);
3581 missingterm((char*)0);
3582 yylval.ival = OP_CONST;
3583 TERM(sublex_start());
3591 missingterm((char*)0);
3592 if (dowarn && SvLEN(lex_stuff)) {
3593 d = SvPV_force(lex_stuff, len);
3594 for (; len; --len, ++d) {
3596 warn("Possible attempt to separate words with commas");
3600 warn("Possible attempt to put comments in qw() list");
3606 nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, q(lex_stuff));
3610 nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(" ",1));
3613 yylval.ival = OP_SPLIT;
3617 last_lop = oldbufptr;
3618 last_lop_op = OP_SPLIT;
3624 missingterm((char*)0);
3625 yylval.ival = OP_STRINGIFY;
3626 if (SvIVX(lex_stuff) == '\'')
3627 SvIVX(lex_stuff) = 0; /* qq'$foo' should intepolate */
3628 TERM(sublex_start());
3633 missingterm((char*)0);
3634 yylval.ival = OP_BACKTICK;
3636 TERM(sublex_start());
3643 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3644 if (isIDFIRST(*tokenbuf))
3645 gv_stashpvn(tokenbuf, strlen(tokenbuf), TRUE);
3647 yyerror("<> should be quotes");
3654 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3658 LOP(OP_RENAME,XTERM);
3667 LOP(OP_RINDEX,XTERM);
3690 LOP(OP_REVERSE,XTERM);
3701 TERM(sublex_start());
3703 TOKEN(1); /* force error */
3712 LOP(OP_SELECT,XTERM);
3718 LOP(OP_SEMCTL,XTERM);
3721 LOP(OP_SEMGET,XTERM);
3724 LOP(OP_SEMOP,XTERM);
3730 LOP(OP_SETPGRP,XTERM);
3732 case KEY_setpriority:
3733 LOP(OP_SETPRIORITY,XTERM);
3735 case KEY_sethostent:
3741 case KEY_setservent:
3744 case KEY_setprotoent:
3754 LOP(OP_SEEKDIR,XTERM);
3756 case KEY_setsockopt:
3757 LOP(OP_SSOCKOPT,XTERM);
3763 LOP(OP_SHMCTL,XTERM);
3766 LOP(OP_SHMGET,XTERM);
3769 LOP(OP_SHMREAD,XTERM);
3772 LOP(OP_SHMWRITE,XTERM);
3775 LOP(OP_SHUTDOWN,XTERM);
3784 LOP(OP_SOCKET,XTERM);
3786 case KEY_socketpair:
3787 LOP(OP_SOCKPAIR,XTERM);
3790 checkcomma(s,tokenbuf,"subroutine name");
3792 if (*s == ';' || *s == ')') /* probably a close */
3793 croak("sort is now a reserved word");
3795 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3799 LOP(OP_SPLIT,XTERM);
3802 LOP(OP_SPRINTF,XTERM);
3805 LOP(OP_SPLICE,XTERM);
3821 LOP(OP_SUBSTR,XTERM);
3828 if (isIDFIRST(*s) || *s == '\'' || *s == ':') {
3829 char tmpbuf[sizeof tokenbuf];
3831 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3832 if (strchr(tmpbuf, ':'))
3833 sv_setpv(subname, tmpbuf);
3835 sv_setsv(subname,curstname);
3836 sv_catpvn(subname,"::",2);
3837 sv_catpvn(subname,tmpbuf,len);
3839 s = force_word(s,WORD,FALSE,TRUE,TRUE);
3843 expect = XTERMBLOCK;
3844 sv_setpv(subname,"?");
3847 if (tmp == KEY_format) {
3850 lex_formbrack = lex_brackets + 1;
3854 /* Look for a prototype */
3861 SvREFCNT_dec(lex_stuff);
3863 croak("Prototype not terminated");
3866 d = SvPVX(lex_stuff);
3868 for (p = d; *p; ++p) {
3873 SvCUR(lex_stuff) = tmp;
3876 nextval[1] = nextval[0];
3877 nexttype[1] = nexttype[0];
3878 nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, lex_stuff);
3879 nexttype[0] = THING;
3880 if (nexttoke == 1) {
3881 lex_defer = lex_state;
3882 lex_expect = expect;
3883 lex_state = LEX_KNOWNEXT;
3888 if (*SvPV(subname,na) == '?') {
3889 sv_setpv(subname,"__ANON__");
3896 LOP(OP_SYSTEM,XREF);
3899 LOP(OP_SYMLINK,XTERM);
3902 LOP(OP_SYSCALL,XTERM);
3905 LOP(OP_SYSOPEN,XTERM);
3908 LOP(OP_SYSSEEK,XTERM);
3911 LOP(OP_SYSREAD,XTERM);
3914 LOP(OP_SYSWRITE,XTERM);
3918 TERM(sublex_start());
3939 LOP(OP_TRUNCATE,XTERM);
3951 yylval.ival = curcop->cop_line;
3955 yylval.ival = curcop->cop_line;
3959 LOP(OP_UNLINK,XTERM);
3965 LOP(OP_UNPACK,XTERM);
3968 LOP(OP_UTIME,XTERM);
3972 for (d = s; d < bufend && (isSPACE(*d) || *d == '('); d++) ;
3973 if (*d != '0' && isDIGIT(*d))
3974 yywarn("umask: argument is missing initial 0");
3979 LOP(OP_UNSHIFT,XTERM);
3982 if (expect != XSTATE)
3983 yyerror("\"use\" not allowed in expression");
3986 s = force_version(s);
3987 if(*s == ';' || (s = skipspace(s), *s == ';')) {
3988 nextval[nexttoke].opval = Nullop;
3993 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3994 s = force_version(s);
4007 yylval.ival = curcop->cop_line;
4011 hints |= HINT_BLOCK_SCOPE;
4018 LOP(OP_WAITPID,XTERM);
4024 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
4028 if (expect == XOPERATOR)
4034 yylval.ival = OP_XOR;
4039 TERM(sublex_start());
4045 keyword(register char *d, I32 len)
4050 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
4051 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
4052 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
4053 if (strEQ(d,"__DATA__")) return KEY___DATA__;
4054 if (strEQ(d,"__END__")) return KEY___END__;
4058 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
4063 if (strEQ(d,"and")) return -KEY_and;
4064 if (strEQ(d,"abs")) return -KEY_abs;
4067 if (strEQ(d,"alarm")) return -KEY_alarm;
4068 if (strEQ(d,"atan2")) return -KEY_atan2;
4071 if (strEQ(d,"accept")) return -KEY_accept;
4076 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
4079 if (strEQ(d,"bless")) return -KEY_bless;
4080 if (strEQ(d,"bind")) return -KEY_bind;
4081 if (strEQ(d,"binmode")) return -KEY_binmode;
4084 if (strEQ(d,"CORE")) return -KEY_CORE;
4089 if (strEQ(d,"cmp")) return -KEY_cmp;
4090 if (strEQ(d,"chr")) return -KEY_chr;
4091 if (strEQ(d,"cos")) return -KEY_cos;
4094 if (strEQ(d,"chop")) return KEY_chop;
4097 if (strEQ(d,"close")) return -KEY_close;
4098 if (strEQ(d,"chdir")) return -KEY_chdir;
4099 if (strEQ(d,"chomp")) return KEY_chomp;
4100 if (strEQ(d,"chmod")) return -KEY_chmod;
4101 if (strEQ(d,"chown")) return -KEY_chown;
4102 if (strEQ(d,"crypt")) return -KEY_crypt;
4105 if (strEQ(d,"chroot")) return -KEY_chroot;
4106 if (strEQ(d,"caller")) return -KEY_caller;
4109 if (strEQ(d,"connect")) return -KEY_connect;
4112 if (strEQ(d,"closedir")) return -KEY_closedir;
4113 if (strEQ(d,"continue")) return -KEY_continue;
4118 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
4123 if (strEQ(d,"do")) return KEY_do;
4126 if (strEQ(d,"die")) return -KEY_die;
4129 if (strEQ(d,"dump")) return -KEY_dump;
4132 if (strEQ(d,"delete")) return KEY_delete;
4135 if (strEQ(d,"defined")) return KEY_defined;
4136 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
4139 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
4144 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
4145 if (strEQ(d,"END")) return KEY_END;
4150 if (strEQ(d,"eq")) return -KEY_eq;
4153 if (strEQ(d,"eof")) return -KEY_eof;
4154 if (strEQ(d,"exp")) return -KEY_exp;
4157 if (strEQ(d,"else")) return KEY_else;
4158 if (strEQ(d,"exit")) return -KEY_exit;
4159 if (strEQ(d,"eval")) return KEY_eval;
4160 if (strEQ(d,"exec")) return -KEY_exec;
4161 if (strEQ(d,"each")) return KEY_each;
4164 if (strEQ(d,"elsif")) return KEY_elsif;
4167 if (strEQ(d,"exists")) return KEY_exists;
4168 if (strEQ(d,"elseif")) warn("elseif should be elsif");
4171 if (strEQ(d,"endgrent")) return -KEY_endgrent;
4172 if (strEQ(d,"endpwent")) return -KEY_endpwent;
4175 if (strEQ(d,"endnetent")) return -KEY_endnetent;
4178 if (strEQ(d,"endhostent")) return -KEY_endhostent;
4179 if (strEQ(d,"endservent")) return -KEY_endservent;
4182 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
4189 if (strEQ(d,"for")) return KEY_for;
4192 if (strEQ(d,"fork")) return -KEY_fork;
4195 if (strEQ(d,"fcntl")) return -KEY_fcntl;
4196 if (strEQ(d,"flock")) return -KEY_flock;
4199 if (strEQ(d,"format")) return KEY_format;
4200 if (strEQ(d,"fileno")) return -KEY_fileno;
4203 if (strEQ(d,"foreach")) return KEY_foreach;
4206 if (strEQ(d,"formline")) return -KEY_formline;
4212 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
4213 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
4217 if (strnEQ(d,"get",3)) {
4222 if (strEQ(d,"ppid")) return -KEY_getppid;
4223 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
4226 if (strEQ(d,"pwent")) return -KEY_getpwent;
4227 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
4228 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
4231 if (strEQ(d,"peername")) return -KEY_getpeername;
4232 if (strEQ(d,"protoent")) return -KEY_getprotoent;
4233 if (strEQ(d,"priority")) return -KEY_getpriority;
4236 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
4239 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
4243 else if (*d == 'h') {
4244 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
4245 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
4246 if (strEQ(d,"hostent")) return -KEY_gethostent;
4248 else if (*d == 'n') {
4249 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
4250 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
4251 if (strEQ(d,"netent")) return -KEY_getnetent;
4253 else if (*d == 's') {
4254 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
4255 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
4256 if (strEQ(d,"servent")) return -KEY_getservent;
4257 if (strEQ(d,"sockname")) return -KEY_getsockname;
4258 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
4260 else if (*d == 'g') {
4261 if (strEQ(d,"grent")) return -KEY_getgrent;
4262 if (strEQ(d,"grnam")) return -KEY_getgrnam;
4263 if (strEQ(d,"grgid")) return -KEY_getgrgid;
4265 else if (*d == 'l') {
4266 if (strEQ(d,"login")) return -KEY_getlogin;
4268 else if (strEQ(d,"c")) return -KEY_getc;
4273 if (strEQ(d,"gt")) return -KEY_gt;
4274 if (strEQ(d,"ge")) return -KEY_ge;
4277 if (strEQ(d,"grep")) return KEY_grep;
4278 if (strEQ(d,"goto")) return KEY_goto;
4279 if (strEQ(d,"glob")) return KEY_glob;
4282 if (strEQ(d,"gmtime")) return -KEY_gmtime;
4287 if (strEQ(d,"hex")) return -KEY_hex;
4290 if (strEQ(d,"INIT")) return KEY_INIT;
4295 if (strEQ(d,"if")) return KEY_if;
4298 if (strEQ(d,"int")) return -KEY_int;
4301 if (strEQ(d,"index")) return -KEY_index;
4302 if (strEQ(d,"ioctl")) return -KEY_ioctl;
4307 if (strEQ(d,"join")) return -KEY_join;
4311 if (strEQ(d,"keys")) return KEY_keys;
4312 if (strEQ(d,"kill")) return -KEY_kill;
4317 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
4318 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
4324 if (strEQ(d,"lt")) return -KEY_lt;
4325 if (strEQ(d,"le")) return -KEY_le;
4326 if (strEQ(d,"lc")) return -KEY_lc;
4329 if (strEQ(d,"log")) return -KEY_log;
4332 if (strEQ(d,"last")) return KEY_last;
4333 if (strEQ(d,"link")) return -KEY_link;
4334 if (strEQ(d,"lock")) return -KEY_lock;
4337 if (strEQ(d,"local")) return KEY_local;
4338 if (strEQ(d,"lstat")) return -KEY_lstat;
4341 if (strEQ(d,"length")) return -KEY_length;
4342 if (strEQ(d,"listen")) return -KEY_listen;
4345 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
4348 if (strEQ(d,"localtime")) return -KEY_localtime;
4354 case 1: return KEY_m;
4356 if (strEQ(d,"my")) return KEY_my;
4359 if (strEQ(d,"map")) return KEY_map;
4362 if (strEQ(d,"mkdir")) return -KEY_mkdir;
4365 if (strEQ(d,"msgctl")) return -KEY_msgctl;
4366 if (strEQ(d,"msgget")) return -KEY_msgget;
4367 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
4368 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
4373 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
4376 if (strEQ(d,"next")) return KEY_next;
4377 if (strEQ(d,"ne")) return -KEY_ne;
4378 if (strEQ(d,"not")) return -KEY_not;
4379 if (strEQ(d,"no")) return KEY_no;
4384 if (strEQ(d,"or")) return -KEY_or;
4387 if (strEQ(d,"ord")) return -KEY_ord;
4388 if (strEQ(d,"oct")) return -KEY_oct;
4391 if (strEQ(d,"open")) return -KEY_open;
4394 if (strEQ(d,"opendir")) return -KEY_opendir;
4401 if (strEQ(d,"pop")) return KEY_pop;
4402 if (strEQ(d,"pos")) return KEY_pos;
4405 if (strEQ(d,"push")) return KEY_push;
4406 if (strEQ(d,"pack")) return -KEY_pack;
4407 if (strEQ(d,"pipe")) return -KEY_pipe;
4410 if (strEQ(d,"print")) return KEY_print;
4413 if (strEQ(d,"printf")) return KEY_printf;
4416 if (strEQ(d,"package")) return KEY_package;
4419 if (strEQ(d,"prototype")) return KEY_prototype;
4424 if (strEQ(d,"q")) return KEY_q;
4425 if (strEQ(d,"qq")) return KEY_qq;
4426 if (strEQ(d,"qw")) return KEY_qw;
4427 if (strEQ(d,"qx")) return KEY_qx;
4429 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
4434 if (strEQ(d,"ref")) return -KEY_ref;
4437 if (strEQ(d,"read")) return -KEY_read;
4438 if (strEQ(d,"rand")) return -KEY_rand;
4439 if (strEQ(d,"recv")) return -KEY_recv;
4440 if (strEQ(d,"redo")) return KEY_redo;
4443 if (strEQ(d,"rmdir")) return -KEY_rmdir;
4444 if (strEQ(d,"reset")) return -KEY_reset;
4447 if (strEQ(d,"return")) return KEY_return;
4448 if (strEQ(d,"rename")) return -KEY_rename;
4449 if (strEQ(d,"rindex")) return -KEY_rindex;
4452 if (strEQ(d,"require")) return -KEY_require;
4453 if (strEQ(d,"reverse")) return -KEY_reverse;
4454 if (strEQ(d,"readdir")) return -KEY_readdir;
4457 if (strEQ(d,"readlink")) return -KEY_readlink;
4458 if (strEQ(d,"readline")) return -KEY_readline;
4459 if (strEQ(d,"readpipe")) return -KEY_readpipe;
4462 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
4468 case 0: return KEY_s;
4470 if (strEQ(d,"scalar")) return KEY_scalar;
4475 if (strEQ(d,"seek")) return -KEY_seek;
4476 if (strEQ(d,"send")) return -KEY_send;
4479 if (strEQ(d,"semop")) return -KEY_semop;
4482 if (strEQ(d,"select")) return -KEY_select;
4483 if (strEQ(d,"semctl")) return -KEY_semctl;
4484 if (strEQ(d,"semget")) return -KEY_semget;
4487 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
4488 if (strEQ(d,"seekdir")) return -KEY_seekdir;
4491 if (strEQ(d,"setpwent")) return -KEY_setpwent;
4492 if (strEQ(d,"setgrent")) return -KEY_setgrent;
4495 if (strEQ(d,"setnetent")) return -KEY_setnetent;
4498 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
4499 if (strEQ(d,"sethostent")) return -KEY_sethostent;
4500 if (strEQ(d,"setservent")) return -KEY_setservent;
4503 if (strEQ(d,"setpriority")) return -KEY_setpriority;
4504 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
4511 if (strEQ(d,"shift")) return KEY_shift;
4514 if (strEQ(d,"shmctl")) return -KEY_shmctl;
4515 if (strEQ(d,"shmget")) return -KEY_shmget;
4518 if (strEQ(d,"shmread")) return -KEY_shmread;
4521 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
4522 if (strEQ(d,"shutdown")) return -KEY_shutdown;
4527 if (strEQ(d,"sin")) return -KEY_sin;
4530 if (strEQ(d,"sleep")) return -KEY_sleep;
4533 if (strEQ(d,"sort")) return KEY_sort;
4534 if (strEQ(d,"socket")) return -KEY_socket;
4535 if (strEQ(d,"socketpair")) return -KEY_socketpair;
4538 if (strEQ(d,"split")) return KEY_split;
4539 if (strEQ(d,"sprintf")) return -KEY_sprintf;
4540 if (strEQ(d,"splice")) return KEY_splice;
4543 if (strEQ(d,"sqrt")) return -KEY_sqrt;
4546 if (strEQ(d,"srand")) return -KEY_srand;
4549 if (strEQ(d,"stat")) return -KEY_stat;
4550 if (strEQ(d,"study")) return KEY_study;
4553 if (strEQ(d,"substr")) return -KEY_substr;
4554 if (strEQ(d,"sub")) return KEY_sub;
4559 if (strEQ(d,"system")) return -KEY_system;
4562 if (strEQ(d,"symlink")) return -KEY_symlink;
4563 if (strEQ(d,"syscall")) return -KEY_syscall;
4564 if (strEQ(d,"sysopen")) return -KEY_sysopen;
4565 if (strEQ(d,"sysread")) return -KEY_sysread;
4566 if (strEQ(d,"sysseek")) return -KEY_sysseek;
4569 if (strEQ(d,"syswrite")) return -KEY_syswrite;
4578 if (strEQ(d,"tr")) return KEY_tr;
4581 if (strEQ(d,"tie")) return KEY_tie;
4584 if (strEQ(d,"tell")) return -KEY_tell;
4585 if (strEQ(d,"tied")) return KEY_tied;
4586 if (strEQ(d,"time")) return -KEY_time;
4589 if (strEQ(d,"times")) return -KEY_times;
4592 if (strEQ(d,"telldir")) return -KEY_telldir;
4595 if (strEQ(d,"truncate")) return -KEY_truncate;
4602 if (strEQ(d,"uc")) return -KEY_uc;
4605 if (strEQ(d,"use")) return KEY_use;
4608 if (strEQ(d,"undef")) return KEY_undef;
4609 if (strEQ(d,"until")) return KEY_until;
4610 if (strEQ(d,"untie")) return KEY_untie;
4611 if (strEQ(d,"utime")) return -KEY_utime;
4612 if (strEQ(d,"umask")) return -KEY_umask;
4615 if (strEQ(d,"unless")) return KEY_unless;
4616 if (strEQ(d,"unpack")) return -KEY_unpack;
4617 if (strEQ(d,"unlink")) return -KEY_unlink;
4620 if (strEQ(d,"unshift")) return KEY_unshift;
4621 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
4626 if (strEQ(d,"values")) return -KEY_values;
4627 if (strEQ(d,"vec")) return -KEY_vec;
4632 if (strEQ(d,"warn")) return -KEY_warn;
4633 if (strEQ(d,"wait")) return -KEY_wait;
4636 if (strEQ(d,"while")) return KEY_while;
4637 if (strEQ(d,"write")) return -KEY_write;
4640 if (strEQ(d,"waitpid")) return -KEY_waitpid;
4643 if (strEQ(d,"wantarray")) return -KEY_wantarray;
4648 if (len == 1) return -KEY_x;
4649 if (strEQ(d,"xor")) return -KEY_xor;
4652 if (len == 1) return KEY_y;
4661 checkcomma(register char *s, char *name, char *what)
4665 if (dowarn && *s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
4667 for (w = s+2; *w && level; w++) {
4674 for (; *w && isSPACE(*w); w++) ;
4675 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
4676 warn("%s (...) interpreted as function",name);
4678 while (s < bufend && isSPACE(*s))
4682 while (s < bufend && isSPACE(*s))
4684 if (isIDFIRST(*s)) {
4688 while (s < bufend && isSPACE(*s))
4693 kw = keyword(w, s - w) || perl_get_cv(w, FALSE) != 0;
4697 croak("No comma allowed after %s", what);
4703 scan_word(register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
4705 register char *d = dest;
4706 register char *e = d + destlen - 3; /* two-character token, ending NUL */
4709 croak(ident_too_long);
4712 else if (*s == '\'' && allow_package && isIDFIRST(s[1])) {
4717 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
4730 scan_ident(register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
4737 if (lex_brackets == 0)
4742 e = d + destlen - 3; /* two-character token, ending NUL */
4744 while (isDIGIT(*s)) {
4746 croak(ident_too_long);
4753 croak(ident_too_long);
4756 else if (*s == '\'' && isIDFIRST(s[1])) {
4761 else if (*s == ':' && s[1] == ':') {
4772 if (lex_state != LEX_NORMAL)
4773 lex_state = LEX_INTERPENDMAYBE;
4776 if (*s == '$' && s[1] &&
4777 (isALNUM(s[1]) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
4779 if (isDIGIT(s[1]) && lex_state == LEX_INTERPNORMAL)
4780 deprecate("\"$$<digit>\" to mean \"${$}<digit>\"");
4793 if (*d == '^' && *s && (isUPPER(*s) || strchr("[\\]^_?", *s))) {
4798 if (isSPACE(s[-1])) {
4801 if (ch != ' ' && ch != '\t') {
4807 if (isIDFIRST(*d)) {
4809 while (isALNUM(*s) || *s == ':')
4812 while (s < send && (*s == ' ' || *s == '\t')) s++;
4813 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
4814 if (dowarn && keyword(dest, d - dest)) {
4815 char *brack = *s == '[' ? "[...]" : "{...}";
4816 warn("Ambiguous use of %c{%s%s} resolved to %c%s%s",
4817 funny, dest, brack, funny, dest, brack);
4819 lex_fakebrack = lex_brackets+1;
4821 lex_brackstack[lex_brackets++] = XOPERATOR;
4827 if (lex_state == LEX_INTERPNORMAL && !lex_brackets)
4828 lex_state = LEX_INTERPEND;
4831 if (dowarn && lex_state == LEX_NORMAL &&
4832 (keyword(dest, d - dest) || perl_get_cv(dest, FALSE)))
4833 warn("Ambiguous use of %c{%s} resolved to %c%s",
4834 funny, dest, funny, dest);
4837 s = bracket; /* let the parser handle it */
4841 else if (lex_state == LEX_INTERPNORMAL && !lex_brackets && !intuit_more(s))
4842 lex_state = LEX_INTERPEND;
4846 void pmflag(U16 *pmfl, int ch)
4851 *pmfl |= PMf_GLOBAL;
4853 *pmfl |= PMf_CONTINUE;
4857 *pmfl |= PMf_MULTILINE;
4859 *pmfl |= PMf_SINGLELINE;
4861 *pmfl |= PMf_EXTENDED;
4865 scan_pat(char *start)
4870 s = scan_str(start);
4873 SvREFCNT_dec(lex_stuff);
4875 croak("Search pattern not terminated");
4878 pm = (PMOP*)newPMOP(OP_MATCH, 0);
4879 if (multi_open == '?')
4880 pm->op_pmflags |= PMf_ONCE;
4881 while (*s && strchr("iogcmsx", *s))
4882 pmflag(&pm->op_pmflags,*s++);
4883 pm->op_pmpermflags = pm->op_pmflags;
4886 yylval.ival = OP_MATCH;
4891 scan_subst(char *start)
4898 yylval.ival = OP_NULL;
4900 s = scan_str(start);
4904 SvREFCNT_dec(lex_stuff);
4906 croak("Substitution pattern not terminated");
4909 if (s[-1] == multi_open)
4912 first_start = multi_start;
4916 SvREFCNT_dec(lex_stuff);
4919 SvREFCNT_dec(lex_repl);
4921 croak("Substitution replacement not terminated");
4923 multi_start = first_start; /* so whole substitution is taken together */
4925 pm = (PMOP*)newPMOP(OP_SUBST, 0);
4926 while (*s && strchr("iogcmsex", *s)) {
4932 pmflag(&pm->op_pmflags,*s++);
4937 pm->op_pmflags |= PMf_EVAL;
4938 repl = newSVpv("",0);
4940 sv_catpv(repl, es ? "eval " : "do ");
4941 sv_catpvn(repl, "{ ", 2);
4942 sv_catsv(repl, lex_repl);
4943 sv_catpvn(repl, " };", 2);
4944 SvCOMPILED_on(repl);
4945 SvREFCNT_dec(lex_repl);
4949 pm->op_pmpermflags = pm->op_pmflags;
4951 yylval.ival = OP_SUBST;
4956 scan_trans(char *start)
4965 yylval.ival = OP_NULL;
4967 s = scan_str(start);
4970 SvREFCNT_dec(lex_stuff);
4972 croak("Transliteration pattern not terminated");
4974 if (s[-1] == multi_open)
4980 SvREFCNT_dec(lex_stuff);
4983 SvREFCNT_dec(lex_repl);
4985 croak("Transliteration replacement not terminated");
4988 New(803,tbl,256,short);
4989 o = newPVOP(OP_TRANS, 0, (char*)tbl);
4991 complement = Delete = squash = 0;
4992 while (*s == 'c' || *s == 'd' || *s == 's') {
4994 complement = OPpTRANS_COMPLEMENT;
4996 Delete = OPpTRANS_DELETE;
4998 squash = OPpTRANS_SQUASH;
5001 o->op_private = Delete|squash|complement;
5004 yylval.ival = OP_TRANS;
5009 scan_heredoc(register char *s)
5013 I32 op_type = OP_SCALAR;
5020 int outer = (rsfp && !(lex_inwhat == OP_SCALAR));
5024 e = tokenbuf + sizeof tokenbuf - 1;
5027 for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5028 if (*peek && strchr("`'\"",*peek)) {
5031 s = delimcpy(d, e, s, bufend, term, &len);
5042 deprecate("bare << to mean <<\"\"");
5043 for (; isALNUM(*s); s++) {
5048 if (d >= tokenbuf + sizeof tokenbuf - 1)
5049 croak("Delimiter for here document is too long");
5054 if (outer || !(d=ninstr(s,bufend,d,d+1)))
5055 herewas = newSVpv(s,bufend-s);
5057 s--, herewas = newSVpv(s,d-s);
5058 s += SvCUR(herewas);
5060 tmpstr = NEWSV(87,80);
5061 sv_upgrade(tmpstr, SVt_PVIV);
5066 else if (term == '`') {
5067 op_type = OP_BACKTICK;
5068 SvIVX(tmpstr) = '\\';
5072 multi_start = curcop->cop_line;
5073 multi_open = multi_close = '<';
5077 while (s < bufend &&
5078 (*s != term || memNE(s,tokenbuf,len)) ) {
5083 curcop->cop_line = multi_start;
5084 missingterm(tokenbuf);
5086 sv_setpvn(tmpstr,d+1,s-d);
5088 curcop->cop_line++; /* the preceding stmt passes a newline */
5090 sv_catpvn(herewas,s,bufend-s);
5091 sv_setsv(linestr,herewas);
5092 oldoldbufptr = oldbufptr = bufptr = s = linestart = SvPVX(linestr);
5093 bufend = SvPVX(linestr) + SvCUR(linestr);
5096 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
5097 while (s >= bufend) { /* multiple line string? */
5099 !(oldoldbufptr = oldbufptr = s = linestart = filter_gets(linestr, rsfp, 0))) {
5100 curcop->cop_line = multi_start;
5101 missingterm(tokenbuf);
5104 if (PERLDB_LINE && curstash != debstash) {
5105 SV *sv = NEWSV(88,0);
5107 sv_upgrade(sv, SVt_PVMG);
5108 sv_setsv(sv,linestr);
5109 av_store(GvAV(curcop->cop_filegv),
5110 (I32)curcop->cop_line,sv);
5112 bufend = SvPVX(linestr) + SvCUR(linestr);
5113 if (*s == term && memEQ(s,tokenbuf,len)) {
5116 sv_catsv(linestr,herewas);
5117 bufend = SvPVX(linestr) + SvCUR(linestr);
5121 sv_catsv(tmpstr,linestr);
5124 multi_end = curcop->cop_line;
5126 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
5127 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
5128 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
5130 SvREFCNT_dec(herewas);
5132 yylval.ival = op_type;
5137 takes: current position in input buffer
5138 returns: new position in input buffer
5139 side-effects: yylval and lex_op are set.
5144 <FH> read from filehandle
5145 <pkg::FH> read from package qualified filehandle
5146 <pkg'FH> read from package qualified filehandle
5147 <$fh> read from filehandle in $fh
5153 scan_inputsymbol(char *start)
5155 register char *s = start; /* current position in buffer */
5160 d = tokenbuf; /* start of temp holding space */
5161 e = tokenbuf + sizeof tokenbuf; /* end of temp holding space */
5162 s = delimcpy(d, e, s + 1, bufend, '>', &len); /* extract until > */
5164 /* die if we didn't have space for the contents of the <>,
5168 if (len >= sizeof tokenbuf)
5169 croak("Excessively long <> operator");
5171 croak("Unterminated <> operator");
5176 Remember, only scalar variables are interpreted as filehandles by
5177 this code. Anything more complex (e.g., <$fh{$num}>) will be
5178 treated as a glob() call.
5179 This code makes use of the fact that except for the $ at the front,
5180 a scalar variable and a filehandle look the same.
5182 if (*d == '$' && d[1]) d++;
5184 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
5185 while (*d && (isALNUM(*d) || *d == '\'' || *d == ':'))
5188 /* If we've tried to read what we allow filehandles to look like, and
5189 there's still text left, then it must be a glob() and not a getline.
5190 Use scan_str to pull out the stuff between the <> and treat it
5191 as nothing more than a string.
5194 if (d - tokenbuf != len) {
5195 yylval.ival = OP_GLOB;
5197 s = scan_str(start);
5199 croak("Glob not terminated");
5203 /* we're in a filehandle read situation */
5206 /* turn <> into <ARGV> */
5208 (void)strcpy(d,"ARGV");
5210 /* if <$fh>, create the ops to turn the variable into a
5216 /* try to find it in the pad for this block, otherwise find
5217 add symbol table ops
5219 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
5220 OP *o = newOP(OP_PADSV, 0);
5222 lex_op = (OP*)newUNOP(OP_READLINE, 0, newUNOP(OP_RV2GV, 0, o));
5225 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
5226 lex_op = (OP*)newUNOP(OP_READLINE, 0,
5227 newUNOP(OP_RV2GV, 0,
5228 newUNOP(OP_RV2SV, 0,
5229 newGVOP(OP_GV, 0, gv))));
5231 /* we created the ops in lex_op, so make yylval.ival a null op */
5232 yylval.ival = OP_NULL;
5235 /* If it's none of the above, it must be a literal filehandle
5236 (<Foo::BAR> or <FOO>) so build a simple readline OP */
5238 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
5239 lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
5240 yylval.ival = OP_NULL;
5249 takes: start position in buffer
5250 returns: position to continue reading from buffer
5251 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
5252 updates the read buffer.
5254 This subroutine pulls a string out of the input. It is called for:
5255 q single quotes q(literal text)
5256 ' single quotes 'literal text'
5257 qq double quotes qq(interpolate $here please)
5258 " double quotes "interpolate $here please"
5259 qx backticks qx(/bin/ls -l)
5260 ` backticks `/bin/ls -l`
5261 qw quote words @EXPORT_OK = qw( func() $spam )
5262 m// regexp match m/this/
5263 s/// regexp substitute s/this/that/
5264 tr/// string transliterate tr/this/that/
5265 y/// string transliterate y/this/that/
5266 ($*@) sub prototypes sub foo ($)
5267 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
5269 In most of these cases (all but <>, patterns and transliterate)
5270 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
5271 calls scan_str(). s/// makes yylex() call scan_subst() which calls
5272 scan_str(). tr/// and y/// make yylex() call scan_trans() which
5275 It skips whitespace before the string starts, and treats the first
5276 character as the delimiter. If the delimiter is one of ([{< then
5277 the corresponding "close" character )]}> is used as the closing
5278 delimiter. It allows quoting of delimiters, and if the string has
5279 balanced delimiters ([{<>}]) it allows nesting.
5281 The lexer always reads these strings into lex_stuff, except in the
5282 case of the operators which take *two* arguments (s/// and tr///)
5283 when it checks to see if lex_stuff is full (presumably with the 1st
5284 arg to s or tr) and if so puts the string into lex_repl.
5289 scan_str(char *start)
5292 SV *sv; /* scalar value: string */
5293 char *tmps; /* temp string, used for delimiter matching */
5294 register char *s = start; /* current position in the buffer */
5295 register char term; /* terminating character */
5296 register char *to; /* current position in the sv's data */
5297 I32 brackets = 1; /* bracket nesting level */
5299 /* skip space before the delimiter */
5303 /* mark where we are, in case we need to report errors */
5306 /* after skipping whitespace, the next character is the terminator */
5308 /* mark where we are */
5309 multi_start = curcop->cop_line;
5312 /* find corresponding closing delimiter */
5313 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5317 /* create a new SV to hold the contents. 87 is leak category, I'm
5318 assuming. 80 is the SV's initial length. What a random number. */
5320 sv_upgrade(sv, SVt_PVIV);
5322 (void)SvPOK_only(sv); /* validate pointer */
5324 /* move past delimiter and try to read a complete string */
5327 /* extend sv if need be */
5328 SvGROW(sv, SvCUR(sv) + (bufend - s) + 1);
5329 /* set 'to' to the next character in the sv's string */
5330 to = SvPVX(sv)+SvCUR(sv);
5332 /* if open delimiter is the close delimiter read unbridle */
5333 if (multi_open == multi_close) {
5334 for (; s < bufend; s++,to++) {
5335 /* embedded newlines increment the current line number */
5336 if (*s == '\n' && !rsfp)
5338 /* handle quoted delimiters */
5339 if (*s == '\\' && s+1 < bufend && term != '\\') {
5342 /* any other quotes are simply copied straight through */
5346 /* terminate when run out of buffer (the for() condition), or
5347 have found the terminator */
5348 else if (*s == term)
5354 /* if the terminator isn't the same as the start character (e.g.,
5355 matched brackets), we have to allow more in the quoting, and
5356 be prepared for nested brackets.
5359 /* read until we run out of string, or we find the terminator */
5360 for (; s < bufend; s++,to++) {
5361 /* embedded newlines increment the line count */
5362 if (*s == '\n' && !rsfp)
5364 /* backslashes can escape the open or closing characters */
5365 if (*s == '\\' && s+1 < bufend) {
5366 if ((s[1] == multi_open) || (s[1] == multi_close))
5371 /* allow nested opens and closes */
5372 else if (*s == multi_close && --brackets <= 0)
5374 else if (*s == multi_open)
5379 /* terminate the copied string and update the sv's end-of-string */
5381 SvCUR_set(sv, to - SvPVX(sv));
5384 * this next chunk reads more into the buffer if we're not done yet
5387 if (s < bufend) break; /* handle case where we are done yet :-) */
5389 /* if we're out of file, or a read fails, bail and reset the current
5390 line marker so we can report where the unterminated string began
5393 !(oldoldbufptr = oldbufptr = s = linestart = filter_gets(linestr, rsfp, 0))) {
5395 curcop->cop_line = multi_start;
5398 /* we read a line, so increment our line counter */
5401 /* update debugger info */
5402 if (PERLDB_LINE && curstash != debstash) {
5403 SV *sv = NEWSV(88,0);
5405 sv_upgrade(sv, SVt_PVMG);
5406 sv_setsv(sv,linestr);
5407 av_store(GvAV(curcop->cop_filegv),
5408 (I32)curcop->cop_line, sv);
5411 /* having changed the buffer, we must update bufend */
5412 bufend = SvPVX(linestr) + SvCUR(linestr);
5415 /* at this point, we have successfully read the delimited string */
5417 multi_end = curcop->cop_line;
5420 /* if we allocated too much space, give some back */
5421 if (SvCUR(sv) + 5 < SvLEN(sv)) {
5422 SvLEN_set(sv, SvCUR(sv) + 1);
5423 Renew(SvPVX(sv), SvLEN(sv), char);
5426 /* decide whether this is the first or second quoted string we've read
5439 takes: pointer to position in buffer
5440 returns: pointer to new position in buffer
5441 side-effects: builds ops for the constant in yylval.op
5443 Read a number in any of the formats that Perl accepts:
5445 0(x[0-7A-F]+)|([0-7]+)
5446 [\d_]+(\.[\d_]*)?[Ee](\d+)
5448 Underbars (_) are allowed in decimal numbers. If -w is on,
5449 underbars before a decimal point must be at three digit intervals.
5451 Like most scan_ routines, it uses the tokenbuf buffer to hold the
5454 If it reads a number without a decimal point or an exponent, it will
5455 try converting the number to an integer and see if it can do so
5456 without loss of precision.
5460 scan_num(char *start)
5462 register char *s = start; /* current position in buffer */
5463 register char *d; /* destination in temp buffer */
5464 register char *e; /* end of temp buffer */
5465 I32 tryiv; /* used to see if it can be an int */
5466 double value; /* number read, as a double */
5467 SV *sv; /* place to put the converted number */
5468 I32 floatit; /* boolean: int or float? */
5469 char *lastub = 0; /* position of last underbar */
5470 static char number_too_long[] = "Number too long";
5472 /* We use the first character to decide what type of number this is */
5476 croak("panic: scan_num");
5478 /* if it starts with a 0, it could be an octal number, a decimal in
5479 0.13 disguise, or a hexadecimal number.
5484 u holds the "number so far"
5485 shift the power of 2 of the base (hex == 4, octal == 3)
5486 overflowed was the number more than we can hold?
5488 Shift is used when we add a digit. It also serves as an "are
5489 we in octal or hex?" indicator to disallow hex characters when
5494 bool overflowed = FALSE;
5501 /* check for a decimal in disguise */
5502 else if (s[1] == '.')
5504 /* so it must be octal */
5509 /* read the rest of the octal number */
5511 UV n, b; /* n is used in the overflow test, b is the digit we're adding on */
5515 /* if we don't mention it, we're done */
5524 /* 8 and 9 are not octal */
5527 yyerror("Illegal octal digit");
5531 case '0': case '1': case '2': case '3': case '4':
5532 case '5': case '6': case '7':
5533 b = *s++ & 15; /* ASCII digit -> value of digit */
5537 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
5538 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
5539 /* make sure they said 0x */
5544 /* Prepare to put the digit we have onto the end
5545 of the number so far. We check for overflows.
5549 n = u << shift; /* make room for the digit */
5550 if (!overflowed && (n >> shift) != u) {
5551 warn("Integer overflow in %s number",
5552 (shift == 4) ? "hex" : "octal");
5555 u = n | b; /* add the digit to the end */
5560 /* if we get here, we had success: make a scalar value from
5570 handle decimal numbers.
5571 we're also sent here when we read a 0 as the first digit
5573 case '1': case '2': case '3': case '4': case '5':
5574 case '6': case '7': case '8': case '9': case '.':
5577 e = tokenbuf + sizeof tokenbuf - 6; /* room for various punctuation */
5580 /* read next group of digits and _ and copy into d */
5581 while (isDIGIT(*s) || *s == '_') {
5582 /* skip underscores, checking for misplaced ones
5586 if (dowarn && lastub && s - lastub != 3)
5587 warn("Misplaced _ in number");
5591 /* check for end of fixed-length buffer */
5593 croak(number_too_long);
5594 /* if we're ok, copy the character */
5599 /* final misplaced underbar check */
5600 if (dowarn && lastub && s - lastub != 3)
5601 warn("Misplaced _ in number");
5603 /* read a decimal portion if there is one. avoid
5604 3..5 being interpreted as the number 3. followed
5607 if (*s == '.' && s[1] != '.') {
5611 /* copy, ignoring underbars, until we run out of
5612 digits. Note: no misplaced underbar checks!
5614 for (; isDIGIT(*s) || *s == '_'; s++) {
5615 /* fixed length buffer check */
5617 croak(number_too_long);
5623 /* read exponent part, if present */
5624 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
5628 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
5629 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
5631 /* allow positive or negative exponent */
5632 if (*s == '+' || *s == '-')
5635 /* read digits of exponent (no underbars :-) */
5636 while (isDIGIT(*s)) {
5638 croak(number_too_long);
5643 /* terminate the string */
5646 /* make an sv from the string */
5648 /* reset numeric locale in case we were earlier left in Swaziland */
5649 SET_NUMERIC_STANDARD();
5650 value = atof(tokenbuf);
5653 See if we can make do with an integer value without loss of
5654 precision. We use I_V to cast to an int, because some
5655 compilers have issues. Then we try casting it back and see
5656 if it was the same. We only do this if we know we
5657 specifically read an integer.
5659 Note: if floatit is true, then we don't need to do the
5663 if (!floatit && (double)tryiv == value)
5664 sv_setiv(sv, tryiv);
5666 sv_setnv(sv, value);
5670 /* make the op for the constant and return */
5672 yylval.opval = newSVOP(OP_CONST, 0, sv);
5678 scan_formline(register char *s)
5683 SV *stuff = newSVpv("",0);
5684 bool needargs = FALSE;
5687 if (*s == '.' || *s == '}') {
5689 for (t = s+1; *t == ' ' || *t == '\t'; t++) ;
5693 if (in_eval && !rsfp) {
5694 eol = strchr(s,'\n');
5699 eol = bufend = SvPVX(linestr) + SvCUR(linestr);
5701 for (t = s; t < eol; t++) {
5702 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
5704 goto enough; /* ~~ must be first line in formline */
5706 if (*t == '@' || *t == '^')
5709 sv_catpvn(stuff, s, eol-s);
5713 s = filter_gets(linestr, rsfp, 0);
5714 oldoldbufptr = oldbufptr = bufptr = linestart = SvPVX(linestr);
5715 bufend = bufptr + SvCUR(linestr);
5718 yyerror("Format not terminated");
5728 lex_state = LEX_NORMAL;
5729 nextval[nexttoke].ival = 0;
5733 lex_state = LEX_FORMLINE;
5734 nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
5736 nextval[nexttoke].ival = OP_FORMLINE;
5740 SvREFCNT_dec(stuff);
5752 cshlen = strlen(cshname);
5757 start_subparse(I32 is_format, U32 flags)
5760 I32 oldsavestack_ix = savestack_ix;
5761 CV* outsidecv = compcv;
5765 assert(SvTYPE(compcv) == SVt_PVCV);
5772 SAVESPTR(comppad_name);
5774 SAVEI32(comppad_name_fill);
5775 SAVEI32(min_intro_pending);
5776 SAVEI32(max_intro_pending);
5777 SAVEI32(pad_reset_pending);
5779 compcv = (CV*)NEWSV(1104,0);
5780 sv_upgrade((SV *)compcv, is_format ? SVt_PVFM : SVt_PVCV);
5781 CvFLAGS(compcv) |= flags;
5784 av_push(comppad, Nullsv);
5785 curpad = AvARRAY(comppad);
5786 comppad_name = newAV();
5787 comppad_name_fill = 0;
5788 min_intro_pending = 0;
5790 subline = curcop->cop_line;
5792 av_store(comppad_name, 0, newSVpv("@_", 2));
5793 curpad[0] = (SV*)newAV();
5794 SvPADMY_on(curpad[0]); /* XXX Needed? */
5795 CvOWNER(compcv) = 0;
5796 New(666, CvMUTEXP(compcv), 1, perl_mutex);
5797 MUTEX_INIT(CvMUTEXP(compcv));
5798 #endif /* USE_THREADS */
5800 comppadlist = newAV();
5801 AvREAL_off(comppadlist);
5802 av_store(comppadlist, 0, (SV*)comppad_name);
5803 av_store(comppadlist, 1, (SV*)comppad);
5805 CvPADLIST(compcv) = comppadlist;
5806 CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc(outsidecv);
5808 CvOWNER(compcv) = 0;
5809 New(666, CvMUTEXP(compcv), 1, perl_mutex);
5810 MUTEX_INIT(CvMUTEXP(compcv));
5811 #endif /* USE_THREADS */
5813 return oldsavestack_ix;
5832 char *context = NULL;
5836 if (!yychar || (yychar == ';' && !rsfp))
5838 else if (bufptr > oldoldbufptr && bufptr - oldoldbufptr < 200 &&
5839 oldoldbufptr != oldbufptr && oldbufptr != bufptr) {
5840 while (isSPACE(*oldoldbufptr))
5842 context = oldoldbufptr;
5843 contlen = bufptr - oldoldbufptr;
5845 else if (bufptr > oldbufptr && bufptr - oldbufptr < 200 &&
5846 oldbufptr != bufptr) {
5847 while (isSPACE(*oldbufptr))
5849 context = oldbufptr;
5850 contlen = bufptr - oldbufptr;
5852 else if (yychar > 255)
5853 where = "next token ???";
5854 else if ((yychar & 127) == 127) {
5855 if (lex_state == LEX_NORMAL ||
5856 (lex_state == LEX_KNOWNEXT && lex_defer == LEX_NORMAL))
5857 where = "at end of line";
5859 where = "within pattern";
5861 where = "within string";
5864 SV *where_sv = sv_2mortal(newSVpv("next char ", 0));
5866 sv_catpvf(where_sv, "^%c", toCTRL(yychar));
5867 else if (isPRINT_LC(yychar))
5868 sv_catpvf(where_sv, "%c", yychar);
5870 sv_catpvf(where_sv, "\\%03o", yychar & 255);
5871 where = SvPVX(where_sv);
5873 msg = sv_2mortal(newSVpv(s, 0));
5874 sv_catpvf(msg, " at %_ line %ld, ",
5875 GvSV(curcop->cop_filegv), (long)curcop->cop_line);
5877 sv_catpvf(msg, "near \"%.*s\"\n", contlen, context);
5879 sv_catpvf(msg, "%s\n", where);
5880 if (multi_start < multi_end && (U32)(curcop->cop_line - multi_end) <= 1) {
5882 " (Might be a runaway multi-line %c%c string starting on line %ld)\n",
5883 (int)multi_open,(int)multi_close,(long)multi_start);
5889 sv_catsv(ERRSV, msg);
5891 PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
5892 if (++error_count >= 10)
5893 croak("%_ has too many errors.\n", GvSV(curcop->cop_filegv));
5895 in_my_stash = Nullhv;