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.
771 Returns a pointer to the character scanned up to. Iff this is
772 advanced from the start pointer supplied (ie if anything was
773 successfully parsed), will leave an OP for the substring scanned
774 in yylval. Caller must intuit reason for not parsing further
775 by looking at the next characters herself.
779 double-quoted style: \r and \n
780 regexp special ones: \D \s
782 backrefs: \1 (deprecated in substitution replacements)
783 case and quoting: \U \Q \E
784 stops on @ and $, but not for $ as tail anchor
787 characters are VERY literal, except for - not at the start or end
788 of the string, which indicates a range. scan_const expands the
789 range to the full set of intermediate characters.
791 In double-quoted strings:
793 double-quoted style: \r and \n
795 backrefs: \1 (deprecated)
796 case and quoting: \U \Q \E
799 scan_const does *not* construct ops to handle interpolated strings.
800 It stops processing as soon as it finds an embedded $ or @ variable
801 and leaves it to the caller to work out what's going on.
803 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
805 $ in pattern could be $foo or could be tail anchor. Assumption:
806 it's a tail anchor if $ is the last thing in the string, or if it's
807 followed by one of ")| \n\t"
809 \1 (backreferences) are turned into $1
811 The structure of the code is
812 while (there's a character to process) {
813 handle transliteration ranges
815 skip # initiated comments in //x patterns
816 check for embedded @foo
817 check for embedded scalars
819 leave intact backslashes from leave (below)
820 deprecate \1 in strings and sub replacements
821 handle string-changing backslashes \l \U \Q \E, etc.
822 switch (what was escaped) {
823 handle - in a transliteration (becomes a literal -)
824 handle \132 octal characters
825 handle 0x15 hex characters
826 handle \cV (control V)
827 handle printf backslashes (\f, \r, \n, etc)
830 } (end while character to read)
835 scan_const(char *start)
837 register char *send = bufend; /* end of the constant */
838 SV *sv = NEWSV(93, send - start); /* sv for the constant */
839 register char *s = start; /* start of the constant */
840 register char *d = SvPVX(sv); /* destination for copies */
841 bool dorange = FALSE; /* are we in a translit range? */
844 /* leaveit is the set of acceptably-backslashed characters */
847 ? "\\.^$@AGZdDwWsSbB+*?|()-nrtfeaxc0123456789[{]} \t\n\r\f\v#"
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);
1035 /* return the substring (via yylval) only if we parsed anything */
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%s", tokenbuf,
2852 *s == '\'' ? "'" : "::");
2856 if (expect == XOPERATOR) {
2857 if (bufptr == linestart) {
2863 no_op("Bareword",s);
2866 /* Look for a subroutine with this name in current package,
2867 unless name is "Foo::", in which case Foo is a bearword
2868 (and a package name). */
2871 tokenbuf[len - 2] == ':' && tokenbuf[len - 1] == ':')
2873 if (dowarn && ! gv_fetchpv(tokenbuf, FALSE, SVt_PVHV))
2874 warn("Bareword \"%s\" refers to nonexistent package",
2877 tokenbuf[len] = '\0';
2884 gv = gv_fetchpv(tokenbuf, FALSE, SVt_PVCV);
2887 /* if we saw a global override before, get the right name */
2890 sv = newSVpv("CORE::GLOBAL::",14);
2891 sv_catpv(sv,tokenbuf);
2894 sv = newSVpv(tokenbuf,0);
2896 /* Presume this is going to be a bareword of some sort. */
2899 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2900 yylval.opval->op_private = OPpCONST_BARE;
2902 /* And if "Foo::", then that's what it certainly is. */
2907 /* See if it's the indirect object for a list operator. */
2910 oldoldbufptr < bufptr &&
2911 (oldoldbufptr == last_lop || oldoldbufptr == last_uni) &&
2912 /* NO SKIPSPACE BEFORE HERE! */
2914 ((opargs[last_lop_op] >> OASHIFT)& 7) == OA_FILEREF) )
2916 bool immediate_paren = *s == '(';
2918 /* (Now we can afford to cross potential line boundary.) */
2921 /* Two barewords in a row may indicate method call. */
2923 if ((isALPHA(*s) || *s == '$') && (tmp=intuit_method(s,gv)))
2926 /* If not a declared subroutine, it's an indirect object. */
2927 /* (But it's an indir obj regardless for sort.) */
2929 if ((last_lop_op == OP_SORT ||
2930 (!immediate_paren && (!gv || !GvCVu(gv))) ) &&
2931 (last_lop_op != OP_MAPSTART && last_lop_op != OP_GREPSTART)){
2932 expect = (last_lop == oldoldbufptr) ? XTERM : XOPERATOR;
2937 /* If followed by a paren, it's certainly a subroutine. */
2943 if (gv && GvCVu(gv)) {
2944 for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
2945 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
2950 nextval[nexttoke].opval = yylval.opval;
2957 /* If followed by var or block, call it a method (unless sub) */
2959 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
2960 last_lop = oldbufptr;
2961 last_lop_op = OP_METHOD;
2965 /* If followed by a bareword, see if it looks like indir obj. */
2967 if ((isALPHA(*s) || *s == '$') && (tmp = intuit_method(s,gv)))
2970 /* Not a method, so call it a subroutine (if defined) */
2972 if (gv && GvCVu(gv)) {
2974 if (lastchar == '-')
2975 warn("Ambiguous use of -%s resolved as -&%s()",
2976 tokenbuf, tokenbuf);
2977 last_lop = oldbufptr;
2978 last_lop_op = OP_ENTERSUB;
2979 /* Check for a constant sub */
2981 if ((sv = cv_const_sv(cv))) {
2983 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
2984 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
2985 yylval.opval->op_private = 0;
2989 /* Resolve to GV now. */
2990 op_free(yylval.opval);
2991 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
2992 /* Is there a prototype? */
2995 char *proto = SvPV((SV*)cv, len);
2998 if (strEQ(proto, "$"))
3000 if (*proto == '&' && *s == '{') {
3001 sv_setpv(subname,"__ANON__");
3005 nextval[nexttoke].opval = yylval.opval;
3011 if (hints & HINT_STRICT_SUBS &&
3014 last_lop_op != OP_TRUNCATE && /* S/F prototype in opcode.pl */
3015 last_lop_op != OP_ACCEPT &&
3016 last_lop_op != OP_PIPE_OP &&
3017 last_lop_op != OP_SOCKPAIR)
3020 "Bareword \"%s\" not allowed while \"strict subs\" in use",
3025 /* Call it a bare word */
3029 if (lastchar != '-') {
3030 for (d = tokenbuf; *d && isLOWER(*d); d++) ;
3032 warn(warn_reserved, tokenbuf);
3037 if (lastchar && strchr("*%&", lastchar)) {
3038 warn("Operator or semicolon missing before %c%s",
3039 lastchar, tokenbuf);
3040 warn("Ambiguous use of %c resolved as operator %c",
3041 lastchar, lastchar);
3047 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3048 newSVsv(GvSV(curcop->cop_filegv)));
3052 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3053 newSVpvf("%ld", (long)curcop->cop_line));
3056 case KEY___PACKAGE__:
3057 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3059 ? newSVsv(curstname)
3068 if (rsfp && (!in_eval || tokenbuf[2] == 'D')) {
3069 char *pname = "main";
3070 if (tokenbuf[2] == 'D')
3071 pname = HvNAME(curstash ? curstash : defstash);
3072 gv = gv_fetchpv(form("%s::DATA", pname), TRUE, SVt_PVIO);
3075 GvIOp(gv) = newIO();
3076 IoIFP(GvIOp(gv)) = rsfp;
3077 #if defined(HAS_FCNTL) && defined(F_SETFD)
3079 int fd = PerlIO_fileno(rsfp);
3080 fcntl(fd,F_SETFD,fd >= 3);
3083 /* Mark this internal pseudo-handle as clean */
3084 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3086 IoTYPE(GvIOp(gv)) = '|';
3087 else if ((PerlIO*)rsfp == PerlIO_stdin())
3088 IoTYPE(GvIOp(gv)) = '-';
3090 IoTYPE(GvIOp(gv)) = '<';
3101 if (expect == XSTATE) {
3108 if (*s == ':' && s[1] == ':') {
3111 s = scan_word(s, tokenbuf, sizeof tokenbuf, FALSE, &len);
3112 tmp = keyword(tokenbuf, len);
3126 LOP(OP_ACCEPT,XTERM);
3132 LOP(OP_ATAN2,XTERM);
3141 LOP(OP_BLESS,XTERM);
3150 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
3170 LOP(OP_CRYPT,XTERM);
3174 for (d = s; d < bufend && (isSPACE(*d) || *d == '('); d++) ;
3175 if (*d != '0' && isDIGIT(*d))
3176 yywarn("chmod: mode argument is missing initial 0");
3178 LOP(OP_CHMOD,XTERM);
3181 LOP(OP_CHOWN,XTERM);
3184 LOP(OP_CONNECT,XTERM);
3200 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3204 hints |= HINT_BLOCK_SCOPE;
3214 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3215 LOP(OP_DBMOPEN,XTERM);
3221 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3228 yylval.ival = curcop->cop_line;
3242 expect = (*s == '{') ? XTERMBLOCK : XTERM;
3243 UNIBRACK(OP_ENTEREVAL);
3258 case KEY_endhostent:
3264 case KEY_endservent:
3267 case KEY_endprotoent:
3278 yylval.ival = curcop->cop_line;
3280 if (expect == XSTATE && isIDFIRST(*s)) {
3282 if ((bufend - p) >= 3 &&
3283 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3287 croak("Missing $ on loop variable");
3292 LOP(OP_FORMLINE,XTERM);
3298 LOP(OP_FCNTL,XTERM);
3304 LOP(OP_FLOCK,XTERM);
3313 LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
3316 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3331 case KEY_getpriority:
3332 LOP(OP_GETPRIORITY,XTERM);
3334 case KEY_getprotobyname:
3337 case KEY_getprotobynumber:
3338 LOP(OP_GPBYNUMBER,XTERM);
3340 case KEY_getprotoent:
3352 case KEY_getpeername:
3353 UNI(OP_GETPEERNAME);
3355 case KEY_gethostbyname:
3358 case KEY_gethostbyaddr:
3359 LOP(OP_GHBYADDR,XTERM);
3361 case KEY_gethostent:
3364 case KEY_getnetbyname:
3367 case KEY_getnetbyaddr:
3368 LOP(OP_GNBYADDR,XTERM);
3373 case KEY_getservbyname:
3374 LOP(OP_GSBYNAME,XTERM);
3376 case KEY_getservbyport:
3377 LOP(OP_GSBYPORT,XTERM);
3379 case KEY_getservent:
3382 case KEY_getsockname:
3383 UNI(OP_GETSOCKNAME);
3385 case KEY_getsockopt:
3386 LOP(OP_GSOCKOPT,XTERM);
3408 yylval.ival = curcop->cop_line;
3412 LOP(OP_INDEX,XTERM);
3418 LOP(OP_IOCTL,XTERM);
3430 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3461 LOP(OP_LISTEN,XTERM);
3471 TERM(sublex_start());
3474 LOP(OP_MAPSTART,XREF);
3477 LOP(OP_MKDIR,XTERM);
3480 LOP(OP_MSGCTL,XTERM);
3483 LOP(OP_MSGGET,XTERM);
3486 LOP(OP_MSGRCV,XTERM);
3489 LOP(OP_MSGSND,XTERM);
3494 if (isIDFIRST(*s)) {
3495 s = scan_word(s, tokenbuf, sizeof tokenbuf, TRUE, &len);
3496 in_my_stash = gv_stashpv(tokenbuf, FALSE);
3500 sprintf(tmpbuf, "No such class %.1000s", tokenbuf);
3507 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3514 if (expect != XSTATE)
3515 yyerror("\"no\" not allowed in expression");
3516 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3517 s = force_version(s);
3526 if (isIDFIRST(*s)) {
3528 for (d = s; isALNUM(*d); d++) ;
3530 if (strchr("|&*+-=!?:.", *t))
3531 warn("Precedence problem: open %.*s should be open(%.*s)",
3537 yylval.ival = OP_OR;
3547 LOP(OP_OPEN_DIR,XTERM);
3550 checkcomma(s,tokenbuf,"filehandle");
3554 checkcomma(s,tokenbuf,"filehandle");
3573 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3577 LOP(OP_PIPE_OP,XTERM);
3582 missingterm((char*)0);
3583 yylval.ival = OP_CONST;
3584 TERM(sublex_start());
3592 missingterm((char*)0);
3593 if (dowarn && SvLEN(lex_stuff)) {
3594 d = SvPV_force(lex_stuff, len);
3595 for (; len; --len, ++d) {
3597 warn("Possible attempt to separate words with commas");
3601 warn("Possible attempt to put comments in qw() list");
3607 nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, q(lex_stuff));
3611 nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(" ",1));
3614 yylval.ival = OP_SPLIT;
3618 last_lop = oldbufptr;
3619 last_lop_op = OP_SPLIT;
3625 missingterm((char*)0);
3626 yylval.ival = OP_STRINGIFY;
3627 if (SvIVX(lex_stuff) == '\'')
3628 SvIVX(lex_stuff) = 0; /* qq'$foo' should intepolate */
3629 TERM(sublex_start());
3634 missingterm((char*)0);
3635 yylval.ival = OP_BACKTICK;
3637 TERM(sublex_start());
3644 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3645 if (isIDFIRST(*tokenbuf))
3646 gv_stashpvn(tokenbuf, strlen(tokenbuf), TRUE);
3648 yyerror("<> should be quotes");
3655 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3659 LOP(OP_RENAME,XTERM);
3668 LOP(OP_RINDEX,XTERM);
3691 LOP(OP_REVERSE,XTERM);
3702 TERM(sublex_start());
3704 TOKEN(1); /* force error */
3713 LOP(OP_SELECT,XTERM);
3719 LOP(OP_SEMCTL,XTERM);
3722 LOP(OP_SEMGET,XTERM);
3725 LOP(OP_SEMOP,XTERM);
3731 LOP(OP_SETPGRP,XTERM);
3733 case KEY_setpriority:
3734 LOP(OP_SETPRIORITY,XTERM);
3736 case KEY_sethostent:
3742 case KEY_setservent:
3745 case KEY_setprotoent:
3755 LOP(OP_SEEKDIR,XTERM);
3757 case KEY_setsockopt:
3758 LOP(OP_SSOCKOPT,XTERM);
3764 LOP(OP_SHMCTL,XTERM);
3767 LOP(OP_SHMGET,XTERM);
3770 LOP(OP_SHMREAD,XTERM);
3773 LOP(OP_SHMWRITE,XTERM);
3776 LOP(OP_SHUTDOWN,XTERM);
3785 LOP(OP_SOCKET,XTERM);
3787 case KEY_socketpair:
3788 LOP(OP_SOCKPAIR,XTERM);
3791 checkcomma(s,tokenbuf,"subroutine name");
3793 if (*s == ';' || *s == ')') /* probably a close */
3794 croak("sort is now a reserved word");
3796 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3800 LOP(OP_SPLIT,XTERM);
3803 LOP(OP_SPRINTF,XTERM);
3806 LOP(OP_SPLICE,XTERM);
3822 LOP(OP_SUBSTR,XTERM);
3829 if (isIDFIRST(*s) || *s == '\'' || *s == ':') {
3830 char tmpbuf[sizeof tokenbuf];
3832 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3833 if (strchr(tmpbuf, ':'))
3834 sv_setpv(subname, tmpbuf);
3836 sv_setsv(subname,curstname);
3837 sv_catpvn(subname,"::",2);
3838 sv_catpvn(subname,tmpbuf,len);
3840 s = force_word(s,WORD,FALSE,TRUE,TRUE);
3844 expect = XTERMBLOCK;
3845 sv_setpv(subname,"?");
3848 if (tmp == KEY_format) {
3851 lex_formbrack = lex_brackets + 1;
3855 /* Look for a prototype */
3862 SvREFCNT_dec(lex_stuff);
3864 croak("Prototype not terminated");
3867 d = SvPVX(lex_stuff);
3869 for (p = d; *p; ++p) {
3874 SvCUR(lex_stuff) = tmp;
3877 nextval[1] = nextval[0];
3878 nexttype[1] = nexttype[0];
3879 nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, lex_stuff);
3880 nexttype[0] = THING;
3881 if (nexttoke == 1) {
3882 lex_defer = lex_state;
3883 lex_expect = expect;
3884 lex_state = LEX_KNOWNEXT;
3889 if (*SvPV(subname,na) == '?') {
3890 sv_setpv(subname,"__ANON__");
3897 LOP(OP_SYSTEM,XREF);
3900 LOP(OP_SYMLINK,XTERM);
3903 LOP(OP_SYSCALL,XTERM);
3906 LOP(OP_SYSOPEN,XTERM);
3909 LOP(OP_SYSSEEK,XTERM);
3912 LOP(OP_SYSREAD,XTERM);
3915 LOP(OP_SYSWRITE,XTERM);
3919 TERM(sublex_start());
3940 LOP(OP_TRUNCATE,XTERM);
3952 yylval.ival = curcop->cop_line;
3956 yylval.ival = curcop->cop_line;
3960 LOP(OP_UNLINK,XTERM);
3966 LOP(OP_UNPACK,XTERM);
3969 LOP(OP_UTIME,XTERM);
3973 for (d = s; d < bufend && (isSPACE(*d) || *d == '('); d++) ;
3974 if (*d != '0' && isDIGIT(*d))
3975 yywarn("umask: argument is missing initial 0");
3980 LOP(OP_UNSHIFT,XTERM);
3983 if (expect != XSTATE)
3984 yyerror("\"use\" not allowed in expression");
3987 s = force_version(s);
3988 if(*s == ';' || (s = skipspace(s), *s == ';')) {
3989 nextval[nexttoke].opval = Nullop;
3994 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3995 s = force_version(s);
4008 yylval.ival = curcop->cop_line;
4012 hints |= HINT_BLOCK_SCOPE;
4019 LOP(OP_WAITPID,XTERM);
4025 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
4029 if (expect == XOPERATOR)
4035 yylval.ival = OP_XOR;
4040 TERM(sublex_start());
4046 keyword(register char *d, I32 len)
4051 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
4052 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
4053 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
4054 if (strEQ(d,"__DATA__")) return KEY___DATA__;
4055 if (strEQ(d,"__END__")) return KEY___END__;
4059 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
4064 if (strEQ(d,"and")) return -KEY_and;
4065 if (strEQ(d,"abs")) return -KEY_abs;
4068 if (strEQ(d,"alarm")) return -KEY_alarm;
4069 if (strEQ(d,"atan2")) return -KEY_atan2;
4072 if (strEQ(d,"accept")) return -KEY_accept;
4077 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
4080 if (strEQ(d,"bless")) return -KEY_bless;
4081 if (strEQ(d,"bind")) return -KEY_bind;
4082 if (strEQ(d,"binmode")) return -KEY_binmode;
4085 if (strEQ(d,"CORE")) return -KEY_CORE;
4090 if (strEQ(d,"cmp")) return -KEY_cmp;
4091 if (strEQ(d,"chr")) return -KEY_chr;
4092 if (strEQ(d,"cos")) return -KEY_cos;
4095 if (strEQ(d,"chop")) return KEY_chop;
4098 if (strEQ(d,"close")) return -KEY_close;
4099 if (strEQ(d,"chdir")) return -KEY_chdir;
4100 if (strEQ(d,"chomp")) return KEY_chomp;
4101 if (strEQ(d,"chmod")) return -KEY_chmod;
4102 if (strEQ(d,"chown")) return -KEY_chown;
4103 if (strEQ(d,"crypt")) return -KEY_crypt;
4106 if (strEQ(d,"chroot")) return -KEY_chroot;
4107 if (strEQ(d,"caller")) return -KEY_caller;
4110 if (strEQ(d,"connect")) return -KEY_connect;
4113 if (strEQ(d,"closedir")) return -KEY_closedir;
4114 if (strEQ(d,"continue")) return -KEY_continue;
4119 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
4124 if (strEQ(d,"do")) return KEY_do;
4127 if (strEQ(d,"die")) return -KEY_die;
4130 if (strEQ(d,"dump")) return -KEY_dump;
4133 if (strEQ(d,"delete")) return KEY_delete;
4136 if (strEQ(d,"defined")) return KEY_defined;
4137 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
4140 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
4145 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
4146 if (strEQ(d,"END")) return KEY_END;
4151 if (strEQ(d,"eq")) return -KEY_eq;
4154 if (strEQ(d,"eof")) return -KEY_eof;
4155 if (strEQ(d,"exp")) return -KEY_exp;
4158 if (strEQ(d,"else")) return KEY_else;
4159 if (strEQ(d,"exit")) return -KEY_exit;
4160 if (strEQ(d,"eval")) return KEY_eval;
4161 if (strEQ(d,"exec")) return -KEY_exec;
4162 if (strEQ(d,"each")) return KEY_each;
4165 if (strEQ(d,"elsif")) return KEY_elsif;
4168 if (strEQ(d,"exists")) return KEY_exists;
4169 if (strEQ(d,"elseif")) warn("elseif should be elsif");
4172 if (strEQ(d,"endgrent")) return -KEY_endgrent;
4173 if (strEQ(d,"endpwent")) return -KEY_endpwent;
4176 if (strEQ(d,"endnetent")) return -KEY_endnetent;
4179 if (strEQ(d,"endhostent")) return -KEY_endhostent;
4180 if (strEQ(d,"endservent")) return -KEY_endservent;
4183 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
4190 if (strEQ(d,"for")) return KEY_for;
4193 if (strEQ(d,"fork")) return -KEY_fork;
4196 if (strEQ(d,"fcntl")) return -KEY_fcntl;
4197 if (strEQ(d,"flock")) return -KEY_flock;
4200 if (strEQ(d,"format")) return KEY_format;
4201 if (strEQ(d,"fileno")) return -KEY_fileno;
4204 if (strEQ(d,"foreach")) return KEY_foreach;
4207 if (strEQ(d,"formline")) return -KEY_formline;
4213 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
4214 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
4218 if (strnEQ(d,"get",3)) {
4223 if (strEQ(d,"ppid")) return -KEY_getppid;
4224 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
4227 if (strEQ(d,"pwent")) return -KEY_getpwent;
4228 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
4229 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
4232 if (strEQ(d,"peername")) return -KEY_getpeername;
4233 if (strEQ(d,"protoent")) return -KEY_getprotoent;
4234 if (strEQ(d,"priority")) return -KEY_getpriority;
4237 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
4240 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
4244 else if (*d == 'h') {
4245 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
4246 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
4247 if (strEQ(d,"hostent")) return -KEY_gethostent;
4249 else if (*d == 'n') {
4250 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
4251 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
4252 if (strEQ(d,"netent")) return -KEY_getnetent;
4254 else if (*d == 's') {
4255 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
4256 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
4257 if (strEQ(d,"servent")) return -KEY_getservent;
4258 if (strEQ(d,"sockname")) return -KEY_getsockname;
4259 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
4261 else if (*d == 'g') {
4262 if (strEQ(d,"grent")) return -KEY_getgrent;
4263 if (strEQ(d,"grnam")) return -KEY_getgrnam;
4264 if (strEQ(d,"grgid")) return -KEY_getgrgid;
4266 else if (*d == 'l') {
4267 if (strEQ(d,"login")) return -KEY_getlogin;
4269 else if (strEQ(d,"c")) return -KEY_getc;
4274 if (strEQ(d,"gt")) return -KEY_gt;
4275 if (strEQ(d,"ge")) return -KEY_ge;
4278 if (strEQ(d,"grep")) return KEY_grep;
4279 if (strEQ(d,"goto")) return KEY_goto;
4280 if (strEQ(d,"glob")) return KEY_glob;
4283 if (strEQ(d,"gmtime")) return -KEY_gmtime;
4288 if (strEQ(d,"hex")) return -KEY_hex;
4291 if (strEQ(d,"INIT")) return KEY_INIT;
4296 if (strEQ(d,"if")) return KEY_if;
4299 if (strEQ(d,"int")) return -KEY_int;
4302 if (strEQ(d,"index")) return -KEY_index;
4303 if (strEQ(d,"ioctl")) return -KEY_ioctl;
4308 if (strEQ(d,"join")) return -KEY_join;
4312 if (strEQ(d,"keys")) return KEY_keys;
4313 if (strEQ(d,"kill")) return -KEY_kill;
4318 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
4319 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
4325 if (strEQ(d,"lt")) return -KEY_lt;
4326 if (strEQ(d,"le")) return -KEY_le;
4327 if (strEQ(d,"lc")) return -KEY_lc;
4330 if (strEQ(d,"log")) return -KEY_log;
4333 if (strEQ(d,"last")) return KEY_last;
4334 if (strEQ(d,"link")) return -KEY_link;
4335 if (strEQ(d,"lock")) return -KEY_lock;
4338 if (strEQ(d,"local")) return KEY_local;
4339 if (strEQ(d,"lstat")) return -KEY_lstat;
4342 if (strEQ(d,"length")) return -KEY_length;
4343 if (strEQ(d,"listen")) return -KEY_listen;
4346 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
4349 if (strEQ(d,"localtime")) return -KEY_localtime;
4355 case 1: return KEY_m;
4357 if (strEQ(d,"my")) return KEY_my;
4360 if (strEQ(d,"map")) return KEY_map;
4363 if (strEQ(d,"mkdir")) return -KEY_mkdir;
4366 if (strEQ(d,"msgctl")) return -KEY_msgctl;
4367 if (strEQ(d,"msgget")) return -KEY_msgget;
4368 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
4369 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
4374 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
4377 if (strEQ(d,"next")) return KEY_next;
4378 if (strEQ(d,"ne")) return -KEY_ne;
4379 if (strEQ(d,"not")) return -KEY_not;
4380 if (strEQ(d,"no")) return KEY_no;
4385 if (strEQ(d,"or")) return -KEY_or;
4388 if (strEQ(d,"ord")) return -KEY_ord;
4389 if (strEQ(d,"oct")) return -KEY_oct;
4392 if (strEQ(d,"open")) return -KEY_open;
4395 if (strEQ(d,"opendir")) return -KEY_opendir;
4402 if (strEQ(d,"pop")) return KEY_pop;
4403 if (strEQ(d,"pos")) return KEY_pos;
4406 if (strEQ(d,"push")) return KEY_push;
4407 if (strEQ(d,"pack")) return -KEY_pack;
4408 if (strEQ(d,"pipe")) return -KEY_pipe;
4411 if (strEQ(d,"print")) return KEY_print;
4414 if (strEQ(d,"printf")) return KEY_printf;
4417 if (strEQ(d,"package")) return KEY_package;
4420 if (strEQ(d,"prototype")) return KEY_prototype;
4425 if (strEQ(d,"q")) return KEY_q;
4426 if (strEQ(d,"qq")) return KEY_qq;
4427 if (strEQ(d,"qw")) return KEY_qw;
4428 if (strEQ(d,"qx")) return KEY_qx;
4430 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
4435 if (strEQ(d,"ref")) return -KEY_ref;
4438 if (strEQ(d,"read")) return -KEY_read;
4439 if (strEQ(d,"rand")) return -KEY_rand;
4440 if (strEQ(d,"recv")) return -KEY_recv;
4441 if (strEQ(d,"redo")) return KEY_redo;
4444 if (strEQ(d,"rmdir")) return -KEY_rmdir;
4445 if (strEQ(d,"reset")) return -KEY_reset;
4448 if (strEQ(d,"return")) return KEY_return;
4449 if (strEQ(d,"rename")) return -KEY_rename;
4450 if (strEQ(d,"rindex")) return -KEY_rindex;
4453 if (strEQ(d,"require")) return -KEY_require;
4454 if (strEQ(d,"reverse")) return -KEY_reverse;
4455 if (strEQ(d,"readdir")) return -KEY_readdir;
4458 if (strEQ(d,"readlink")) return -KEY_readlink;
4459 if (strEQ(d,"readline")) return -KEY_readline;
4460 if (strEQ(d,"readpipe")) return -KEY_readpipe;
4463 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
4469 case 0: return KEY_s;
4471 if (strEQ(d,"scalar")) return KEY_scalar;
4476 if (strEQ(d,"seek")) return -KEY_seek;
4477 if (strEQ(d,"send")) return -KEY_send;
4480 if (strEQ(d,"semop")) return -KEY_semop;
4483 if (strEQ(d,"select")) return -KEY_select;
4484 if (strEQ(d,"semctl")) return -KEY_semctl;
4485 if (strEQ(d,"semget")) return -KEY_semget;
4488 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
4489 if (strEQ(d,"seekdir")) return -KEY_seekdir;
4492 if (strEQ(d,"setpwent")) return -KEY_setpwent;
4493 if (strEQ(d,"setgrent")) return -KEY_setgrent;
4496 if (strEQ(d,"setnetent")) return -KEY_setnetent;
4499 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
4500 if (strEQ(d,"sethostent")) return -KEY_sethostent;
4501 if (strEQ(d,"setservent")) return -KEY_setservent;
4504 if (strEQ(d,"setpriority")) return -KEY_setpriority;
4505 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
4512 if (strEQ(d,"shift")) return KEY_shift;
4515 if (strEQ(d,"shmctl")) return -KEY_shmctl;
4516 if (strEQ(d,"shmget")) return -KEY_shmget;
4519 if (strEQ(d,"shmread")) return -KEY_shmread;
4522 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
4523 if (strEQ(d,"shutdown")) return -KEY_shutdown;
4528 if (strEQ(d,"sin")) return -KEY_sin;
4531 if (strEQ(d,"sleep")) return -KEY_sleep;
4534 if (strEQ(d,"sort")) return KEY_sort;
4535 if (strEQ(d,"socket")) return -KEY_socket;
4536 if (strEQ(d,"socketpair")) return -KEY_socketpair;
4539 if (strEQ(d,"split")) return KEY_split;
4540 if (strEQ(d,"sprintf")) return -KEY_sprintf;
4541 if (strEQ(d,"splice")) return KEY_splice;
4544 if (strEQ(d,"sqrt")) return -KEY_sqrt;
4547 if (strEQ(d,"srand")) return -KEY_srand;
4550 if (strEQ(d,"stat")) return -KEY_stat;
4551 if (strEQ(d,"study")) return KEY_study;
4554 if (strEQ(d,"substr")) return -KEY_substr;
4555 if (strEQ(d,"sub")) return KEY_sub;
4560 if (strEQ(d,"system")) return -KEY_system;
4563 if (strEQ(d,"symlink")) return -KEY_symlink;
4564 if (strEQ(d,"syscall")) return -KEY_syscall;
4565 if (strEQ(d,"sysopen")) return -KEY_sysopen;
4566 if (strEQ(d,"sysread")) return -KEY_sysread;
4567 if (strEQ(d,"sysseek")) return -KEY_sysseek;
4570 if (strEQ(d,"syswrite")) return -KEY_syswrite;
4579 if (strEQ(d,"tr")) return KEY_tr;
4582 if (strEQ(d,"tie")) return KEY_tie;
4585 if (strEQ(d,"tell")) return -KEY_tell;
4586 if (strEQ(d,"tied")) return KEY_tied;
4587 if (strEQ(d,"time")) return -KEY_time;
4590 if (strEQ(d,"times")) return -KEY_times;
4593 if (strEQ(d,"telldir")) return -KEY_telldir;
4596 if (strEQ(d,"truncate")) return -KEY_truncate;
4603 if (strEQ(d,"uc")) return -KEY_uc;
4606 if (strEQ(d,"use")) return KEY_use;
4609 if (strEQ(d,"undef")) return KEY_undef;
4610 if (strEQ(d,"until")) return KEY_until;
4611 if (strEQ(d,"untie")) return KEY_untie;
4612 if (strEQ(d,"utime")) return -KEY_utime;
4613 if (strEQ(d,"umask")) return -KEY_umask;
4616 if (strEQ(d,"unless")) return KEY_unless;
4617 if (strEQ(d,"unpack")) return -KEY_unpack;
4618 if (strEQ(d,"unlink")) return -KEY_unlink;
4621 if (strEQ(d,"unshift")) return KEY_unshift;
4622 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
4627 if (strEQ(d,"values")) return -KEY_values;
4628 if (strEQ(d,"vec")) return -KEY_vec;
4633 if (strEQ(d,"warn")) return -KEY_warn;
4634 if (strEQ(d,"wait")) return -KEY_wait;
4637 if (strEQ(d,"while")) return KEY_while;
4638 if (strEQ(d,"write")) return -KEY_write;
4641 if (strEQ(d,"waitpid")) return -KEY_waitpid;
4644 if (strEQ(d,"wantarray")) return -KEY_wantarray;
4649 if (len == 1) return -KEY_x;
4650 if (strEQ(d,"xor")) return -KEY_xor;
4653 if (len == 1) return KEY_y;
4662 checkcomma(register char *s, char *name, char *what)
4666 if (dowarn && *s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
4668 for (w = s+2; *w && level; w++) {
4675 for (; *w && isSPACE(*w); w++) ;
4676 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
4677 warn("%s (...) interpreted as function",name);
4679 while (s < bufend && isSPACE(*s))
4683 while (s < bufend && isSPACE(*s))
4685 if (isIDFIRST(*s)) {
4689 while (s < bufend && isSPACE(*s))
4694 kw = keyword(w, s - w) || perl_get_cv(w, FALSE) != 0;
4698 croak("No comma allowed after %s", what);
4704 scan_word(register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
4706 register char *d = dest;
4707 register char *e = d + destlen - 3; /* two-character token, ending NUL */
4710 croak(ident_too_long);
4713 else if (*s == '\'' && allow_package && isIDFIRST(s[1])) {
4718 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
4731 scan_ident(register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
4738 if (lex_brackets == 0)
4743 e = d + destlen - 3; /* two-character token, ending NUL */
4745 while (isDIGIT(*s)) {
4747 croak(ident_too_long);
4754 croak(ident_too_long);
4757 else if (*s == '\'' && isIDFIRST(s[1])) {
4762 else if (*s == ':' && s[1] == ':') {
4773 if (lex_state != LEX_NORMAL)
4774 lex_state = LEX_INTERPENDMAYBE;
4777 if (*s == '$' && s[1] &&
4778 (isALNUM(s[1]) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
4780 if (isDIGIT(s[1]) && lex_state == LEX_INTERPNORMAL)
4781 deprecate("\"$$<digit>\" to mean \"${$}<digit>\"");
4794 if (*d == '^' && *s && (isUPPER(*s) || strchr("[\\]^_?", *s))) {
4799 if (isSPACE(s[-1])) {
4802 if (ch != ' ' && ch != '\t') {
4808 if (isIDFIRST(*d)) {
4810 while (isALNUM(*s) || *s == ':')
4813 while (s < send && (*s == ' ' || *s == '\t')) s++;
4814 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
4815 if (dowarn && keyword(dest, d - dest)) {
4816 char *brack = *s == '[' ? "[...]" : "{...}";
4817 warn("Ambiguous use of %c{%s%s} resolved to %c%s%s",
4818 funny, dest, brack, funny, dest, brack);
4820 lex_fakebrack = lex_brackets+1;
4822 lex_brackstack[lex_brackets++] = XOPERATOR;
4828 if (lex_state == LEX_INTERPNORMAL && !lex_brackets)
4829 lex_state = LEX_INTERPEND;
4832 if (dowarn && lex_state == LEX_NORMAL &&
4833 (keyword(dest, d - dest) || perl_get_cv(dest, FALSE)))
4834 warn("Ambiguous use of %c{%s} resolved to %c%s",
4835 funny, dest, funny, dest);
4838 s = bracket; /* let the parser handle it */
4842 else if (lex_state == LEX_INTERPNORMAL && !lex_brackets && !intuit_more(s))
4843 lex_state = LEX_INTERPEND;
4847 void pmflag(U16 *pmfl, int ch)
4852 *pmfl |= PMf_GLOBAL;
4854 *pmfl |= PMf_CONTINUE;
4858 *pmfl |= PMf_MULTILINE;
4860 *pmfl |= PMf_SINGLELINE;
4862 *pmfl |= PMf_EXTENDED;
4866 scan_pat(char *start)
4871 s = scan_str(start);
4874 SvREFCNT_dec(lex_stuff);
4876 croak("Search pattern not terminated");
4879 pm = (PMOP*)newPMOP(OP_MATCH, 0);
4880 if (multi_open == '?')
4881 pm->op_pmflags |= PMf_ONCE;
4882 while (*s && strchr("iogcmsx", *s))
4883 pmflag(&pm->op_pmflags,*s++);
4884 pm->op_pmpermflags = pm->op_pmflags;
4887 yylval.ival = OP_MATCH;
4892 scan_subst(char *start)
4899 yylval.ival = OP_NULL;
4901 s = scan_str(start);
4905 SvREFCNT_dec(lex_stuff);
4907 croak("Substitution pattern not terminated");
4910 if (s[-1] == multi_open)
4913 first_start = multi_start;
4917 SvREFCNT_dec(lex_stuff);
4920 SvREFCNT_dec(lex_repl);
4922 croak("Substitution replacement not terminated");
4924 multi_start = first_start; /* so whole substitution is taken together */
4926 pm = (PMOP*)newPMOP(OP_SUBST, 0);
4927 while (*s && strchr("iogcmsex", *s)) {
4933 pmflag(&pm->op_pmflags,*s++);
4938 pm->op_pmflags |= PMf_EVAL;
4939 repl = newSVpv("",0);
4941 sv_catpv(repl, es ? "eval " : "do ");
4942 sv_catpvn(repl, "{ ", 2);
4943 sv_catsv(repl, lex_repl);
4944 sv_catpvn(repl, " };", 2);
4945 SvCOMPILED_on(repl);
4946 SvREFCNT_dec(lex_repl);
4950 pm->op_pmpermflags = pm->op_pmflags;
4952 yylval.ival = OP_SUBST;
4957 scan_trans(char *start)
4966 yylval.ival = OP_NULL;
4968 s = scan_str(start);
4971 SvREFCNT_dec(lex_stuff);
4973 croak("Transliteration pattern not terminated");
4975 if (s[-1] == multi_open)
4981 SvREFCNT_dec(lex_stuff);
4984 SvREFCNT_dec(lex_repl);
4986 croak("Transliteration replacement not terminated");
4989 New(803,tbl,256,short);
4990 o = newPVOP(OP_TRANS, 0, (char*)tbl);
4992 complement = Delete = squash = 0;
4993 while (*s == 'c' || *s == 'd' || *s == 's') {
4995 complement = OPpTRANS_COMPLEMENT;
4997 Delete = OPpTRANS_DELETE;
4999 squash = OPpTRANS_SQUASH;
5002 o->op_private = Delete|squash|complement;
5005 yylval.ival = OP_TRANS;
5010 scan_heredoc(register char *s)
5014 I32 op_type = OP_SCALAR;
5021 int outer = (rsfp && !(lex_inwhat == OP_SCALAR));
5025 e = tokenbuf + sizeof tokenbuf - 1;
5028 for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5029 if (*peek && strchr("`'\"",*peek)) {
5032 s = delimcpy(d, e, s, bufend, term, &len);
5043 deprecate("bare << to mean <<\"\"");
5044 for (; isALNUM(*s); s++) {
5049 if (d >= tokenbuf + sizeof tokenbuf - 1)
5050 croak("Delimiter for here document is too long");
5055 if (outer || !(d=ninstr(s,bufend,d,d+1)))
5056 herewas = newSVpv(s,bufend-s);
5058 s--, herewas = newSVpv(s,d-s);
5059 s += SvCUR(herewas);
5061 tmpstr = NEWSV(87,80);
5062 sv_upgrade(tmpstr, SVt_PVIV);
5067 else if (term == '`') {
5068 op_type = OP_BACKTICK;
5069 SvIVX(tmpstr) = '\\';
5073 multi_start = curcop->cop_line;
5074 multi_open = multi_close = '<';
5078 while (s < bufend &&
5079 (*s != term || memNE(s,tokenbuf,len)) ) {
5084 curcop->cop_line = multi_start;
5085 missingterm(tokenbuf);
5087 sv_setpvn(tmpstr,d+1,s-d);
5089 curcop->cop_line++; /* the preceding stmt passes a newline */
5091 sv_catpvn(herewas,s,bufend-s);
5092 sv_setsv(linestr,herewas);
5093 oldoldbufptr = oldbufptr = bufptr = s = linestart = SvPVX(linestr);
5094 bufend = SvPVX(linestr) + SvCUR(linestr);
5097 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
5098 while (s >= bufend) { /* multiple line string? */
5100 !(oldoldbufptr = oldbufptr = s = linestart = filter_gets(linestr, rsfp, 0))) {
5101 curcop->cop_line = multi_start;
5102 missingterm(tokenbuf);
5105 if (PERLDB_LINE && curstash != debstash) {
5106 SV *sv = NEWSV(88,0);
5108 sv_upgrade(sv, SVt_PVMG);
5109 sv_setsv(sv,linestr);
5110 av_store(GvAV(curcop->cop_filegv),
5111 (I32)curcop->cop_line,sv);
5113 bufend = SvPVX(linestr) + SvCUR(linestr);
5114 if (*s == term && memEQ(s,tokenbuf,len)) {
5117 sv_catsv(linestr,herewas);
5118 bufend = SvPVX(linestr) + SvCUR(linestr);
5122 sv_catsv(tmpstr,linestr);
5125 multi_end = curcop->cop_line;
5127 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
5128 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
5129 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
5131 SvREFCNT_dec(herewas);
5133 yylval.ival = op_type;
5138 takes: current position in input buffer
5139 returns: new position in input buffer
5140 side-effects: yylval and lex_op are set.
5145 <FH> read from filehandle
5146 <pkg::FH> read from package qualified filehandle
5147 <pkg'FH> read from package qualified filehandle
5148 <$fh> read from filehandle in $fh
5154 scan_inputsymbol(char *start)
5156 register char *s = start; /* current position in buffer */
5161 d = tokenbuf; /* start of temp holding space */
5162 e = tokenbuf + sizeof tokenbuf; /* end of temp holding space */
5163 s = delimcpy(d, e, s + 1, bufend, '>', &len); /* extract until > */
5165 /* die if we didn't have space for the contents of the <>,
5169 if (len >= sizeof tokenbuf)
5170 croak("Excessively long <> operator");
5172 croak("Unterminated <> operator");
5177 Remember, only scalar variables are interpreted as filehandles by
5178 this code. Anything more complex (e.g., <$fh{$num}>) will be
5179 treated as a glob() call.
5180 This code makes use of the fact that except for the $ at the front,
5181 a scalar variable and a filehandle look the same.
5183 if (*d == '$' && d[1]) d++;
5185 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
5186 while (*d && (isALNUM(*d) || *d == '\'' || *d == ':'))
5189 /* If we've tried to read what we allow filehandles to look like, and
5190 there's still text left, then it must be a glob() and not a getline.
5191 Use scan_str to pull out the stuff between the <> and treat it
5192 as nothing more than a string.
5195 if (d - tokenbuf != len) {
5196 yylval.ival = OP_GLOB;
5198 s = scan_str(start);
5200 croak("Glob not terminated");
5204 /* we're in a filehandle read situation */
5207 /* turn <> into <ARGV> */
5209 (void)strcpy(d,"ARGV");
5211 /* if <$fh>, create the ops to turn the variable into a
5217 /* try to find it in the pad for this block, otherwise find
5218 add symbol table ops
5220 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
5221 OP *o = newOP(OP_PADSV, 0);
5223 lex_op = (OP*)newUNOP(OP_READLINE, 0, newUNOP(OP_RV2GV, 0, o));
5226 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
5227 lex_op = (OP*)newUNOP(OP_READLINE, 0,
5228 newUNOP(OP_RV2GV, 0,
5229 newUNOP(OP_RV2SV, 0,
5230 newGVOP(OP_GV, 0, gv))));
5232 /* we created the ops in lex_op, so make yylval.ival a null op */
5233 yylval.ival = OP_NULL;
5236 /* If it's none of the above, it must be a literal filehandle
5237 (<Foo::BAR> or <FOO>) so build a simple readline OP */
5239 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
5240 lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
5241 yylval.ival = OP_NULL;
5250 takes: start position in buffer
5251 returns: position to continue reading from buffer
5252 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
5253 updates the read buffer.
5255 This subroutine pulls a string out of the input. It is called for:
5256 q single quotes q(literal text)
5257 ' single quotes 'literal text'
5258 qq double quotes qq(interpolate $here please)
5259 " double quotes "interpolate $here please"
5260 qx backticks qx(/bin/ls -l)
5261 ` backticks `/bin/ls -l`
5262 qw quote words @EXPORT_OK = qw( func() $spam )
5263 m// regexp match m/this/
5264 s/// regexp substitute s/this/that/
5265 tr/// string transliterate tr/this/that/
5266 y/// string transliterate y/this/that/
5267 ($*@) sub prototypes sub foo ($)
5268 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
5270 In most of these cases (all but <>, patterns and transliterate)
5271 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
5272 calls scan_str(). s/// makes yylex() call scan_subst() which calls
5273 scan_str(). tr/// and y/// make yylex() call scan_trans() which
5276 It skips whitespace before the string starts, and treats the first
5277 character as the delimiter. If the delimiter is one of ([{< then
5278 the corresponding "close" character )]}> is used as the closing
5279 delimiter. It allows quoting of delimiters, and if the string has
5280 balanced delimiters ([{<>}]) it allows nesting.
5282 The lexer always reads these strings into lex_stuff, except in the
5283 case of the operators which take *two* arguments (s/// and tr///)
5284 when it checks to see if lex_stuff is full (presumably with the 1st
5285 arg to s or tr) and if so puts the string into lex_repl.
5290 scan_str(char *start)
5293 SV *sv; /* scalar value: string */
5294 char *tmps; /* temp string, used for delimiter matching */
5295 register char *s = start; /* current position in the buffer */
5296 register char term; /* terminating character */
5297 register char *to; /* current position in the sv's data */
5298 I32 brackets = 1; /* bracket nesting level */
5300 /* skip space before the delimiter */
5304 /* mark where we are, in case we need to report errors */
5307 /* after skipping whitespace, the next character is the terminator */
5309 /* mark where we are */
5310 multi_start = curcop->cop_line;
5313 /* find corresponding closing delimiter */
5314 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5318 /* create a new SV to hold the contents. 87 is leak category, I'm
5319 assuming. 80 is the SV's initial length. What a random number. */
5321 sv_upgrade(sv, SVt_PVIV);
5323 (void)SvPOK_only(sv); /* validate pointer */
5325 /* move past delimiter and try to read a complete string */
5328 /* extend sv if need be */
5329 SvGROW(sv, SvCUR(sv) + (bufend - s) + 1);
5330 /* set 'to' to the next character in the sv's string */
5331 to = SvPVX(sv)+SvCUR(sv);
5333 /* if open delimiter is the close delimiter read unbridle */
5334 if (multi_open == multi_close) {
5335 for (; s < bufend; s++,to++) {
5336 /* embedded newlines increment the current line number */
5337 if (*s == '\n' && !rsfp)
5339 /* handle quoted delimiters */
5340 if (*s == '\\' && s+1 < bufend && term != '\\') {
5343 /* any other quotes are simply copied straight through */
5347 /* terminate when run out of buffer (the for() condition), or
5348 have found the terminator */
5349 else if (*s == term)
5355 /* if the terminator isn't the same as the start character (e.g.,
5356 matched brackets), we have to allow more in the quoting, and
5357 be prepared for nested brackets.
5360 /* read until we run out of string, or we find the terminator */
5361 for (; s < bufend; s++,to++) {
5362 /* embedded newlines increment the line count */
5363 if (*s == '\n' && !rsfp)
5365 /* backslashes can escape the open or closing characters */
5366 if (*s == '\\' && s+1 < bufend) {
5367 if ((s[1] == multi_open) || (s[1] == multi_close))
5372 /* allow nested opens and closes */
5373 else if (*s == multi_close && --brackets <= 0)
5375 else if (*s == multi_open)
5380 /* terminate the copied string and update the sv's end-of-string */
5382 SvCUR_set(sv, to - SvPVX(sv));
5385 * this next chunk reads more into the buffer if we're not done yet
5388 if (s < bufend) break; /* handle case where we are done yet :-) */
5390 /* if we're out of file, or a read fails, bail and reset the current
5391 line marker so we can report where the unterminated string began
5394 !(oldoldbufptr = oldbufptr = s = linestart = filter_gets(linestr, rsfp, 0))) {
5396 curcop->cop_line = multi_start;
5399 /* we read a line, so increment our line counter */
5402 /* update debugger info */
5403 if (PERLDB_LINE && curstash != debstash) {
5404 SV *sv = NEWSV(88,0);
5406 sv_upgrade(sv, SVt_PVMG);
5407 sv_setsv(sv,linestr);
5408 av_store(GvAV(curcop->cop_filegv),
5409 (I32)curcop->cop_line, sv);
5412 /* having changed the buffer, we must update bufend */
5413 bufend = SvPVX(linestr) + SvCUR(linestr);
5416 /* at this point, we have successfully read the delimited string */
5418 multi_end = curcop->cop_line;
5421 /* if we allocated too much space, give some back */
5422 if (SvCUR(sv) + 5 < SvLEN(sv)) {
5423 SvLEN_set(sv, SvCUR(sv) + 1);
5424 Renew(SvPVX(sv), SvLEN(sv), char);
5427 /* decide whether this is the first or second quoted string we've read
5440 takes: pointer to position in buffer
5441 returns: pointer to new position in buffer
5442 side-effects: builds ops for the constant in yylval.op
5444 Read a number in any of the formats that Perl accepts:
5446 0(x[0-7A-F]+)|([0-7]+)
5447 [\d_]+(\.[\d_]*)?[Ee](\d+)
5449 Underbars (_) are allowed in decimal numbers. If -w is on,
5450 underbars before a decimal point must be at three digit intervals.
5452 Like most scan_ routines, it uses the tokenbuf buffer to hold the
5455 If it reads a number without a decimal point or an exponent, it will
5456 try converting the number to an integer and see if it can do so
5457 without loss of precision.
5461 scan_num(char *start)
5463 register char *s = start; /* current position in buffer */
5464 register char *d; /* destination in temp buffer */
5465 register char *e; /* end of temp buffer */
5466 I32 tryiv; /* used to see if it can be an int */
5467 double value; /* number read, as a double */
5468 SV *sv; /* place to put the converted number */
5469 I32 floatit; /* boolean: int or float? */
5470 char *lastub = 0; /* position of last underbar */
5471 static char number_too_long[] = "Number too long";
5473 /* We use the first character to decide what type of number this is */
5477 croak("panic: scan_num");
5479 /* if it starts with a 0, it could be an octal number, a decimal in
5480 0.13 disguise, or a hexadecimal number.
5485 u holds the "number so far"
5486 shift the power of 2 of the base (hex == 4, octal == 3)
5487 overflowed was the number more than we can hold?
5489 Shift is used when we add a digit. It also serves as an "are
5490 we in octal or hex?" indicator to disallow hex characters when
5495 bool overflowed = FALSE;
5502 /* check for a decimal in disguise */
5503 else if (s[1] == '.')
5505 /* so it must be octal */
5510 /* read the rest of the octal number */
5512 UV n, b; /* n is used in the overflow test, b is the digit we're adding on */
5516 /* if we don't mention it, we're done */
5525 /* 8 and 9 are not octal */
5528 yyerror("Illegal octal digit");
5532 case '0': case '1': case '2': case '3': case '4':
5533 case '5': case '6': case '7':
5534 b = *s++ & 15; /* ASCII digit -> value of digit */
5538 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
5539 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
5540 /* make sure they said 0x */
5545 /* Prepare to put the digit we have onto the end
5546 of the number so far. We check for overflows.
5550 n = u << shift; /* make room for the digit */
5551 if (!overflowed && (n >> shift) != u) {
5552 warn("Integer overflow in %s number",
5553 (shift == 4) ? "hex" : "octal");
5556 u = n | b; /* add the digit to the end */
5561 /* if we get here, we had success: make a scalar value from
5571 handle decimal numbers.
5572 we're also sent here when we read a 0 as the first digit
5574 case '1': case '2': case '3': case '4': case '5':
5575 case '6': case '7': case '8': case '9': case '.':
5578 e = tokenbuf + sizeof tokenbuf - 6; /* room for various punctuation */
5581 /* read next group of digits and _ and copy into d */
5582 while (isDIGIT(*s) || *s == '_') {
5583 /* skip underscores, checking for misplaced ones
5587 if (dowarn && lastub && s - lastub != 3)
5588 warn("Misplaced _ in number");
5592 /* check for end of fixed-length buffer */
5594 croak(number_too_long);
5595 /* if we're ok, copy the character */
5600 /* final misplaced underbar check */
5601 if (dowarn && lastub && s - lastub != 3)
5602 warn("Misplaced _ in number");
5604 /* read a decimal portion if there is one. avoid
5605 3..5 being interpreted as the number 3. followed
5608 if (*s == '.' && s[1] != '.') {
5612 /* copy, ignoring underbars, until we run out of
5613 digits. Note: no misplaced underbar checks!
5615 for (; isDIGIT(*s) || *s == '_'; s++) {
5616 /* fixed length buffer check */
5618 croak(number_too_long);
5624 /* read exponent part, if present */
5625 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
5629 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
5630 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
5632 /* allow positive or negative exponent */
5633 if (*s == '+' || *s == '-')
5636 /* read digits of exponent (no underbars :-) */
5637 while (isDIGIT(*s)) {
5639 croak(number_too_long);
5644 /* terminate the string */
5647 /* make an sv from the string */
5649 /* reset numeric locale in case we were earlier left in Swaziland */
5650 SET_NUMERIC_STANDARD();
5651 value = atof(tokenbuf);
5654 See if we can make do with an integer value without loss of
5655 precision. We use I_V to cast to an int, because some
5656 compilers have issues. Then we try casting it back and see
5657 if it was the same. We only do this if we know we
5658 specifically read an integer.
5660 Note: if floatit is true, then we don't need to do the
5664 if (!floatit && (double)tryiv == value)
5665 sv_setiv(sv, tryiv);
5667 sv_setnv(sv, value);
5671 /* make the op for the constant and return */
5673 yylval.opval = newSVOP(OP_CONST, 0, sv);
5679 scan_formline(register char *s)
5684 SV *stuff = newSVpv("",0);
5685 bool needargs = FALSE;
5688 if (*s == '.' || *s == '}') {
5690 for (t = s+1; *t == ' ' || *t == '\t'; t++) ;
5694 if (in_eval && !rsfp) {
5695 eol = strchr(s,'\n');
5700 eol = bufend = SvPVX(linestr) + SvCUR(linestr);
5702 for (t = s; t < eol; t++) {
5703 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
5705 goto enough; /* ~~ must be first line in formline */
5707 if (*t == '@' || *t == '^')
5710 sv_catpvn(stuff, s, eol-s);
5714 s = filter_gets(linestr, rsfp, 0);
5715 oldoldbufptr = oldbufptr = bufptr = linestart = SvPVX(linestr);
5716 bufend = bufptr + SvCUR(linestr);
5719 yyerror("Format not terminated");
5729 lex_state = LEX_NORMAL;
5730 nextval[nexttoke].ival = 0;
5734 lex_state = LEX_FORMLINE;
5735 nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
5737 nextval[nexttoke].ival = OP_FORMLINE;
5741 SvREFCNT_dec(stuff);
5753 cshlen = strlen(cshname);
5758 start_subparse(I32 is_format, U32 flags)
5761 I32 oldsavestack_ix = savestack_ix;
5762 CV* outsidecv = compcv;
5766 assert(SvTYPE(compcv) == SVt_PVCV);
5773 SAVESPTR(comppad_name);
5775 SAVEI32(comppad_name_fill);
5776 SAVEI32(min_intro_pending);
5777 SAVEI32(max_intro_pending);
5778 SAVEI32(pad_reset_pending);
5780 compcv = (CV*)NEWSV(1104,0);
5781 sv_upgrade((SV *)compcv, is_format ? SVt_PVFM : SVt_PVCV);
5782 CvFLAGS(compcv) |= flags;
5785 av_push(comppad, Nullsv);
5786 curpad = AvARRAY(comppad);
5787 comppad_name = newAV();
5788 comppad_name_fill = 0;
5789 min_intro_pending = 0;
5791 subline = curcop->cop_line;
5793 av_store(comppad_name, 0, newSVpv("@_", 2));
5794 curpad[0] = (SV*)newAV();
5795 SvPADMY_on(curpad[0]); /* XXX Needed? */
5796 CvOWNER(compcv) = 0;
5797 New(666, CvMUTEXP(compcv), 1, perl_mutex);
5798 MUTEX_INIT(CvMUTEXP(compcv));
5799 #endif /* USE_THREADS */
5801 comppadlist = newAV();
5802 AvREAL_off(comppadlist);
5803 av_store(comppadlist, 0, (SV*)comppad_name);
5804 av_store(comppadlist, 1, (SV*)comppad);
5806 CvPADLIST(compcv) = comppadlist;
5807 CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc(outsidecv);
5809 CvOWNER(compcv) = 0;
5810 New(666, CvMUTEXP(compcv), 1, perl_mutex);
5811 MUTEX_INIT(CvMUTEXP(compcv));
5812 #endif /* USE_THREADS */
5814 return oldsavestack_ix;
5833 char *context = NULL;
5837 if (!yychar || (yychar == ';' && !rsfp))
5839 else if (bufptr > oldoldbufptr && bufptr - oldoldbufptr < 200 &&
5840 oldoldbufptr != oldbufptr && oldbufptr != bufptr) {
5841 while (isSPACE(*oldoldbufptr))
5843 context = oldoldbufptr;
5844 contlen = bufptr - oldoldbufptr;
5846 else if (bufptr > oldbufptr && bufptr - oldbufptr < 200 &&
5847 oldbufptr != bufptr) {
5848 while (isSPACE(*oldbufptr))
5850 context = oldbufptr;
5851 contlen = bufptr - oldbufptr;
5853 else if (yychar > 255)
5854 where = "next token ???";
5855 else if ((yychar & 127) == 127) {
5856 if (lex_state == LEX_NORMAL ||
5857 (lex_state == LEX_KNOWNEXT && lex_defer == LEX_NORMAL))
5858 where = "at end of line";
5860 where = "within pattern";
5862 where = "within string";
5865 SV *where_sv = sv_2mortal(newSVpv("next char ", 0));
5867 sv_catpvf(where_sv, "^%c", toCTRL(yychar));
5868 else if (isPRINT_LC(yychar))
5869 sv_catpvf(where_sv, "%c", yychar);
5871 sv_catpvf(where_sv, "\\%03o", yychar & 255);
5872 where = SvPVX(where_sv);
5874 msg = sv_2mortal(newSVpv(s, 0));
5875 sv_catpvf(msg, " at %_ line %ld, ",
5876 GvSV(curcop->cop_filegv), (long)curcop->cop_line);
5878 sv_catpvf(msg, "near \"%.*s\"\n", contlen, context);
5880 sv_catpvf(msg, "%s\n", where);
5881 if (multi_start < multi_end && (U32)(curcop->cop_line - multi_end) <= 1) {
5883 " (Might be a runaway multi-line %c%c string starting on line %ld)\n",
5884 (int)multi_open,(int)multi_close,(long)multi_start);
5890 sv_catsv(ERRSV, msg);
5892 PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
5893 if (++error_count >= 10)
5894 croak("%_ has too many errors.\n", GvSV(curcop->cop_filegv));
5896 in_my_stash = Nullhv;