3 * Copyright (c) 1991-1997, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "It all comes from here, the stench and the peril." --Frodo
18 static void check_uni _((void));
19 static void force_next _((I32 type));
20 static char *force_version _((char *start));
21 static char *force_word _((char *start, int token, int check_keyword, int allow_pack, int allow_tick));
22 static SV *tokeq _((SV *sv));
23 static char *scan_const _((char *start));
24 static char *scan_formline _((char *s));
25 static char *scan_heredoc _((char *s));
26 static char *scan_ident _((char *s, char *send, char *dest, STRLEN destlen,
28 static char *scan_inputsymbol _((char *start));
29 static char *scan_pat _((char *start));
30 static char *scan_str _((char *start));
31 static char *scan_subst _((char *start));
32 static char *scan_trans _((char *start));
33 static char *scan_word _((char *s, char *dest, STRLEN destlen,
34 int allow_package, STRLEN *slp));
35 static char *skipspace _((char *s));
36 static void checkcomma _((char *s, char *name, char *what));
37 static void force_ident _((char *s, int kind));
38 static void incline _((char *s));
39 static int intuit_method _((char *s, GV *gv));
40 static int intuit_more _((char *s));
41 static I32 lop _((I32 f, expectation x, char *s));
42 static void missingterm _((char *s));
43 static void no_op _((char *what, char *s));
44 static void set_csh _((void));
45 static I32 sublex_done _((void));
46 static I32 sublex_push _((void));
47 static I32 sublex_start _((void));
49 static int uni _((I32 f, char *s));
51 static char * filter_gets _((SV *sv, PerlIO *fp, STRLEN append));
52 static void restore_rsfp _((void *f));
53 static void restore_expect _((void *e));
54 static void restore_lex_expect _((void *e));
55 #endif /* PERL_OBJECT */
57 static char ident_too_long[] = "Identifier too long";
59 /* The following are arranged oddly so that the guard on the switch statement
60 * can get by with a single comparison (if the compiler is smart enough).
63 /* #define LEX_NOTPARSING 11 is done in perl.h. */
66 #define LEX_INTERPNORMAL 9
67 #define LEX_INTERPCASEMOD 8
68 #define LEX_INTERPPUSH 7
69 #define LEX_INTERPSTART 6
70 #define LEX_INTERPEND 5
71 #define LEX_INTERPENDMAYBE 4
72 #define LEX_INTERPCONCAT 3
73 #define LEX_INTERPCONST 2
74 #define LEX_FORMLINE 1
75 #define LEX_KNOWNEXT 0
84 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
86 # include <unistd.h> /* Needed for execv() */
99 #define CLINE (copline = (curcop->cop_line < copline ? curcop->cop_line : copline))
101 #define TOKEN(retval) return (bufptr = s,(int)retval)
102 #define OPERATOR(retval) return (expect = XTERM,bufptr = s,(int)retval)
103 #define AOPERATOR(retval) return ao((expect = XTERM,bufptr = s,(int)retval))
104 #define PREBLOCK(retval) return (expect = XBLOCK,bufptr = s,(int)retval)
105 #define PRETERMBLOCK(retval) return (expect = XTERMBLOCK,bufptr = s,(int)retval)
106 #define PREREF(retval) return (expect = XREF,bufptr = s,(int)retval)
107 #define TERM(retval) return (CLINE, expect = XOPERATOR,bufptr = s,(int)retval)
108 #define LOOPX(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)LOOPEX)
109 #define FTST(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)UNIOP)
110 #define FUN0(f) return(yylval.ival = f,expect = XOPERATOR,bufptr = s,(int)FUNC0)
111 #define FUN1(f) return(yylval.ival = f,expect = XOPERATOR,bufptr = s,(int)FUNC1)
112 #define BOop(f) return ao((yylval.ival=f,expect = XTERM,bufptr = s,(int)BITOROP))
113 #define BAop(f) return ao((yylval.ival=f,expect = XTERM,bufptr = s,(int)BITANDOP))
114 #define SHop(f) return ao((yylval.ival=f,expect = XTERM,bufptr = s,(int)SHIFTOP))
115 #define PWop(f) return ao((yylval.ival=f,expect = XTERM,bufptr = s,(int)POWOP))
116 #define PMop(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)MATCHOP)
117 #define Aop(f) return ao((yylval.ival=f,expect = XTERM,bufptr = s,(int)ADDOP))
118 #define Mop(f) return ao((yylval.ival=f,expect = XTERM,bufptr = s,(int)MULOP))
119 #define Eop(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)EQOP)
120 #define Rop(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)RELOP)
122 /* This bit of chicanery makes a unary function followed by
123 * a parenthesis into a function with one argument, highest precedence.
125 #define UNI(f) return(yylval.ival = f, \
128 last_uni = oldbufptr, \
130 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
132 #define UNIBRACK(f) return(yylval.ival = f, \
134 last_uni = oldbufptr, \
135 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
137 /* grandfather return to old style */
138 #define OLDLOP(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)LSTOP)
143 if (*bufptr == '=') {
145 if (toketype == ANDAND)
146 yylval.ival = OP_ANDASSIGN;
147 else if (toketype == OROR)
148 yylval.ival = OP_ORASSIGN;
155 no_op(char *what, char *s)
157 char *oldbp = bufptr;
158 bool is_first = (oldbufptr == linestart);
161 yywarn(form("%s found where operator expected", what));
163 warn("\t(Missing semicolon on previous line?)\n");
164 else if (oldoldbufptr && isIDFIRST(*oldoldbufptr)) {
166 for (t = oldoldbufptr; *t && (isALNUM(*t) || *t == ':'); t++) ;
167 if (t < bufptr && isSPACE(*t))
168 warn("\t(Do you need to predeclare %.*s?)\n",
169 t - oldoldbufptr, oldoldbufptr);
173 warn("\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
183 char *nl = strrchr(s,'\n');
187 else if (multi_close < 32 || multi_close == 127) {
189 tmpbuf[1] = toCTRL(multi_close);
195 *tmpbuf = multi_close;
199 q = strchr(s,'"') ? '\'' : '"';
200 croak("Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
207 warn("Use of %s is deprecated", s);
213 deprecate("comma-less variable list");
219 win32_textfilter(int idx, SV *sv, int maxlen)
221 I32 count = FILTER_READ(idx+1, sv, maxlen);
222 if (count > 0 && !maxlen)
223 win32_strip_return(sv);
237 SAVEI32(lex_brackets);
238 SAVEI32(lex_fakebrack);
239 SAVEI32(lex_casemods);
244 SAVEI16(curcop->cop_line);
248 SAVEPPTR(oldoldbufptr);
251 SAVEPPTR(lex_brackstack);
252 SAVEPPTR(lex_casestack);
253 SAVEDESTRUCTOR(restore_rsfp, rsfp);
257 SAVEDESTRUCTOR(restore_expect, tokenbuf + expect); /* encode as pointer */
258 SAVEDESTRUCTOR(restore_lex_expect, tokenbuf + expect);
260 lex_state = LEX_NORMAL;
265 New(899, lex_brackstack, 120, char);
266 New(899, lex_casestack, 12, char);
267 SAVEFREEPV(lex_brackstack);
268 SAVEFREEPV(lex_casestack);
270 *lex_casestack = '\0';
278 if (SvREADONLY(linestr))
279 linestr = sv_2mortal(newSVsv(linestr));
280 s = SvPV(linestr, len);
281 if (len && s[len-1] != ';') {
282 if (!(SvFLAGS(linestr) & SVs_TEMP))
283 linestr = sv_2mortal(newSVsv(linestr));
284 sv_catpvn(linestr, "\n;", 2);
287 oldoldbufptr = oldbufptr = bufptr = linestart = SvPVX(linestr);
288 bufend = bufptr + SvCUR(linestr);
290 rs = newSVpv("\n", 1);
301 restore_rsfp(void *f)
303 PerlIO *fp = (PerlIO*)f;
305 if (rsfp == PerlIO_stdin())
306 PerlIO_clearerr(rsfp);
307 else if (rsfp && (rsfp != fp))
313 restore_expect(void *e)
315 /* a safe way to store a small integer in a pointer */
316 expect = (expectation)((char *)e - tokenbuf);
320 restore_lex_expect(void *e)
322 /* a safe way to store a small integer in a pointer */
323 lex_expect = (expectation)((char *)e - tokenbuf);
338 while (*s == ' ' || *s == '\t') s++;
339 if (strnEQ(s, "line ", 5)) {
348 while (*s == ' ' || *s == '\t')
350 if (*s == '"' && (t = strchr(s+1, '"')))
354 return; /* false alarm */
355 for (t = s; !isSPACE(*t); t++) ;
360 curcop->cop_filegv = gv_fetchfile(s);
362 curcop->cop_filegv = gv_fetchfile(origfilename);
364 curcop->cop_line = atoi(n)-1;
368 skipspace(register char *s)
371 if (lex_formbrack && lex_brackets <= lex_formbrack) {
372 while (s < bufend && (*s == ' ' || *s == '\t'))
378 while (s < bufend && isSPACE(*s))
380 if (s < bufend && *s == '#') {
381 while (s < bufend && *s != '\n')
386 if (s < bufend || !rsfp || lex_state != LEX_NORMAL)
388 if ((s = filter_gets(linestr, rsfp, (prevlen = SvCUR(linestr)))) == Nullch) {
389 if (minus_n || minus_p) {
390 sv_setpv(linestr,minus_p ?
391 ";}continue{print or die qq(-p destination: $!\\n)" :
393 sv_catpv(linestr,";}");
394 minus_n = minus_p = 0;
397 sv_setpv(linestr,";");
398 oldoldbufptr = oldbufptr = bufptr = s = linestart = SvPVX(linestr);
399 bufend = SvPVX(linestr) + SvCUR(linestr);
400 if (preprocess && !in_eval)
401 (void)PerlProc_pclose(rsfp);
402 else if ((PerlIO*)rsfp == PerlIO_stdin())
403 PerlIO_clearerr(rsfp);
405 (void)PerlIO_close(rsfp);
409 linestart = bufptr = s + prevlen;
410 bufend = s + SvCUR(linestr);
413 if (PERLDB_LINE && curstash != debstash) {
414 SV *sv = NEWSV(85,0);
416 sv_upgrade(sv, SVt_PVMG);
417 sv_setpvn(sv,bufptr,bufend-bufptr);
418 av_store(GvAV(curcop->cop_filegv),(I32)curcop->cop_line,sv);
429 if (oldoldbufptr != last_uni)
431 while (isSPACE(*last_uni))
433 for (s = last_uni; isALNUM(*s) || *s == '-'; s++) ;
434 if ((t = strchr(s, '(')) && t < bufptr)
438 warn("Warning: Use of \"%s\" without parens is ambiguous", last_uni);
445 #define UNI(f) return uni(f,s)
453 last_uni = oldbufptr;
464 #endif /* CRIPPLED_CC */
466 #define LOP(f,x) return lop(f,x,s)
469 lop(I32 f, expectation x, char *s)
476 last_lop = oldbufptr;
492 nexttype[nexttoke] = type;
494 if (lex_state != LEX_KNOWNEXT) {
495 lex_defer = lex_state;
497 lex_state = LEX_KNOWNEXT;
502 force_word(register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
507 start = skipspace(start);
510 (allow_pack && *s == ':') ||
511 (allow_initial_tick && *s == '\'') )
513 s = scan_word(s, tokenbuf, sizeof tokenbuf, allow_pack, &len);
514 if (check_keyword && keyword(tokenbuf, len))
516 if (token == METHOD) {
526 nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(tokenbuf,0));
527 nextval[nexttoke].opval->op_private |= OPpCONST_BARE;
534 force_ident(register char *s, int kind)
537 OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
538 nextval[nexttoke].opval = o;
541 dTHR; /* just for in_eval */
542 o->op_private = OPpCONST_ENTERED;
543 /* XXX see note in pp_entereval() for why we forgo typo
544 warnings if the symbol must be introduced in an eval.
546 gv_fetchpv(s, in_eval ? (GV_ADDMULTI | 8) : TRUE,
547 kind == '$' ? SVt_PV :
548 kind == '@' ? SVt_PVAV :
549 kind == '%' ? SVt_PVHV :
557 force_version(char *s)
559 OP *version = Nullop;
563 /* default VERSION number -- GBARR */
568 for( d=s, c = 1; isDIGIT(*d) || *d == '_' || (*d == '.' && c--); d++);
569 if((*d == ';' || isSPACE(*d)) && *(skipspace(d)) != ',') {
571 /* real VERSION number -- GBARR */
572 version = yylval.opval;
576 /* NOTE: The parser sees the package name and the VERSION swapped */
577 nextval[nexttoke].opval = version;
594 s = SvPV_force(sv, len);
598 while (s < send && *s != '\\')
605 if (s + 1 < send && (s[1] == '\\'))
606 s++; /* all that, just for this */
611 SvCUR_set(sv, d - SvPVX(sv));
619 register I32 op_type = yylval.ival;
621 if (op_type == OP_NULL) {
622 yylval.opval = lex_op;
626 if (op_type == OP_CONST || op_type == OP_READLINE) {
627 SV *sv = tokeq(lex_stuff);
629 char *p = SvPV(sv, len);
630 yylval.opval = (OP*)newSVOP(op_type, 0, newSVpv(p, len));
636 sublex_info.super_state = lex_state;
637 sublex_info.sub_inwhat = op_type;
638 sublex_info.sub_op = lex_op;
639 lex_state = LEX_INTERPPUSH;
643 yylval.opval = lex_op;
657 lex_state = sublex_info.super_state;
659 SAVEI32(lex_brackets);
660 SAVEI32(lex_fakebrack);
661 SAVEI32(lex_casemods);
666 SAVEI16(curcop->cop_line);
669 SAVEPPTR(oldoldbufptr);
672 SAVEPPTR(lex_brackstack);
673 SAVEPPTR(lex_casestack);
678 bufend = bufptr = oldbufptr = oldoldbufptr = linestart = SvPVX(linestr);
679 bufend += SvCUR(linestr);
685 New(899, lex_brackstack, 120, char);
686 New(899, lex_casestack, 12, char);
687 SAVEFREEPV(lex_brackstack);
688 SAVEFREEPV(lex_casestack);
690 *lex_casestack = '\0';
692 lex_state = LEX_INTERPCONCAT;
693 curcop->cop_line = multi_start;
695 lex_inwhat = sublex_info.sub_inwhat;
696 if (lex_inwhat == OP_MATCH || lex_inwhat == OP_SUBST)
697 lex_inpat = sublex_info.sub_op;
709 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv("",0));
713 if (lex_casemods) { /* oops, we've got some unbalanced parens */
714 lex_state = LEX_INTERPCASEMOD;
718 /* Is there a right-hand side to take care of? */
719 if (lex_repl && (lex_inwhat == OP_SUBST || lex_inwhat == OP_TRANS)) {
722 bufend = bufptr = oldbufptr = oldoldbufptr = linestart = SvPVX(linestr);
723 bufend += SvCUR(linestr);
729 *lex_casestack = '\0';
731 if (SvCOMPILED(lex_repl)) {
732 lex_state = LEX_INTERPNORMAL;
736 lex_state = LEX_INTERPCONCAT;
742 bufend = SvPVX(linestr);
743 bufend += SvCUR(linestr);
752 Extracts a pattern, double-quoted string, or transliteration. This
755 It looks at lex_inwhat and lex_inpat to find out whether it's
756 processing a pattern (lex_inpat is true), a transliteration
757 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
759 Returns a pointer to the character scanned up to. Iff this is
760 advanced from the start pointer supplied (ie if anything was
761 successfully parsed), will leave an OP for the substring scanned
762 in yylval. Caller must intuit reason for not parsing further
763 by looking at the next characters herself.
767 double-quoted style: \r and \n
768 regexp special ones: \D \s
770 backrefs: \1 (deprecated in substitution replacements)
771 case and quoting: \U \Q \E
772 stops on @ and $, but not for $ as tail anchor
775 characters are VERY literal, except for - not at the start or end
776 of the string, which indicates a range. scan_const expands the
777 range to the full set of intermediate characters.
779 In double-quoted strings:
781 double-quoted style: \r and \n
783 backrefs: \1 (deprecated)
784 case and quoting: \U \Q \E
787 scan_const does *not* construct ops to handle interpolated strings.
788 It stops processing as soon as it finds an embedded $ or @ variable
789 and leaves it to the caller to work out what's going on.
791 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
793 $ in pattern could be $foo or could be tail anchor. Assumption:
794 it's a tail anchor if $ is the last thing in the string, or if it's
795 followed by one of ")| \n\t"
797 \1 (backreferences) are turned into $1
799 The structure of the code is
800 while (there's a character to process) {
801 handle transliteration ranges
803 skip # initiated comments in //x patterns
804 check for embedded @foo
805 check for embedded scalars
807 leave intact backslashes from leave (below)
808 deprecate \1 in strings and sub replacements
809 handle string-changing backslashes \l \U \Q \E, etc.
810 switch (what was escaped) {
811 handle - in a transliteration (becomes a literal -)
812 handle \132 octal characters
813 handle 0x15 hex characters
814 handle \cV (control V)
815 handle printf backslashes (\f, \r, \n, etc)
818 } (end while character to read)
823 scan_const(char *start)
825 register char *send = bufend; /* end of the constant */
826 SV *sv = NEWSV(93, send - start); /* sv for the constant */
827 register char *s = start; /* start of the constant */
828 register char *d = SvPVX(sv); /* destination for copies */
829 bool dorange = FALSE; /* are we in a translit range? */
832 /* leaveit is the set of acceptably-backslashed characters */
835 ? "\\.^$@AGZdDwWsSbB+*?|()-nrtfeaxc0123456789[{]} \t\n\r\f\v#"
838 while (s < send || dorange) {
839 /* get transliterations out of the way (they're most literal) */
840 if (lex_inwhat == OP_TRANS) {
841 /* expand a range A-Z to the full set of characters. AIE! */
843 I32 i; /* current expanded character */
844 I32 max; /* last character in range */
846 i = d - SvPVX(sv); /* remember current offset */
847 SvGROW(sv, SvLEN(sv) + 256); /* expand the sv -- there'll never be more'n 256 chars in a range for it to grow by */
848 d = SvPVX(sv) + i; /* restore d after the grow potentially has changed the ptr */
849 d -= 2; /* eat the first char and the - */
851 max = (U8)d[1]; /* last char in range */
853 for (i = (U8)*d; i <= max; i++)
856 /* mark the range as done, and continue */
861 /* range begins (ignore - as first or last char) */
862 else if (*s == '-' && s+1 < send && s != start) {
868 /* if we get here, we're not doing a transliteration */
870 /* skip for regexp comments /(?#comment)/ */
871 else if (*s == '(' && lex_inpat && s[1] == '?') {
873 while (s < send && *s != ')')
875 } else if (s[2] == '{') { /* This should march regcomp.c */
877 char *regparse = s + 3;
880 while (count && (c = *regparse)) {
881 if (c == '\\' && regparse[1])
889 if (*regparse == ')')
892 yyerror("Sequence (?{...}) not terminated or not {}-balanced");
893 while (s < regparse && *s != ')')
898 /* likewise skip #-initiated comments in //x patterns */
899 else if (*s == '#' && lex_inpat &&
900 ((PMOP*)lex_inpat)->op_pmflags & PMf_EXTENDED) {
901 while (s+1 < send && *s != '\n')
905 /* check for embedded arrays (@foo, @:foo, @'foo, @{foo}, @$foo) */
906 else if (*s == '@' && s[1] && (isALNUM(s[1]) || strchr(":'{$", s[1])))
909 /* check for embedded scalars. only stop if we're sure it's a
912 else if (*s == '$') {
913 if (!lex_inpat) /* not a regexp, so $ must be var */
915 if (s + 1 < send && !strchr("()| \n\t", s[1]))
916 break; /* in regexp, $ might be tail anchor */
920 if (*s == '\\' && s+1 < send) {
923 /* some backslashes we leave behind */
924 if (*s && strchr(leaveit, *s)) {
930 /* deprecate \1 in strings and substitution replacements */
931 if (lex_inwhat == OP_SUBST && !lex_inpat &&
932 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
935 warn("\\%c better written as $%c", *s, *s);
940 /* string-change backslash escapes */
941 if (lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
946 /* if we get here, it's either a quoted -, or a digit */
949 /* quoted - in transliterations */
951 if (lex_inwhat == OP_TRANS) {
956 /* default action is to copy the quoted character */
961 /* \132 indicates an octal constant */
962 case '0': case '1': case '2': case '3':
963 case '4': case '5': case '6': case '7':
964 *d++ = scan_oct(s, 3, &len);
968 /* \x24 indicates a hex constant */
970 *d++ = scan_hex(++s, 2, &len);
974 /* \c is a control character */
981 /* printf-style backslashes, formfeeds, newlines, etc */
1007 } /* end if (backslash) */
1010 } /* while loop to process each character */
1012 /* terminate the string and set up the sv */
1014 SvCUR_set(sv, d - SvPVX(sv));
1017 /* shrink the sv if we allocated more than we used */
1018 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1019 SvLEN_set(sv, SvCUR(sv) + 1);
1020 Renew(SvPVX(sv), SvLEN(sv), char);
1023 /* return the substring (via yylval) only if we parsed anything */
1025 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1031 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1033 intuit_more(register char *s)
1037 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1039 if (*s != '{' && *s != '[')
1044 /* In a pattern, so maybe we have {n,m}. */
1061 /* On the other hand, maybe we have a character class */
1064 if (*s == ']' || *s == '^')
1067 int weight = 2; /* let's weigh the evidence */
1069 unsigned char un_char = 255, last_un_char;
1070 char *send = strchr(s,']');
1071 char tmpbuf[sizeof tokenbuf * 4];
1073 if (!send) /* has to be an expression */
1076 Zero(seen,256,char);
1079 else if (isDIGIT(*s)) {
1081 if (isDIGIT(s[1]) && s[2] == ']')
1087 for (; s < send; s++) {
1088 last_un_char = un_char;
1089 un_char = (unsigned char)*s;
1094 weight -= seen[un_char] * 10;
1095 if (isALNUM(s[1])) {
1096 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1097 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1102 else if (*s == '$' && s[1] &&
1103 strchr("[#!%*<>()-=",s[1])) {
1104 if (/*{*/ strchr("])} =",s[2]))
1113 if (strchr("wds]",s[1]))
1115 else if (seen['\''] || seen['"'])
1117 else if (strchr("rnftbxcav",s[1]))
1119 else if (isDIGIT(s[1])) {
1121 while (s[1] && isDIGIT(s[1]))
1131 if (strchr("aA01! ",last_un_char))
1133 if (strchr("zZ79~",s[1]))
1135 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1136 weight -= 5; /* cope with negative subscript */
1139 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1140 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1145 if (keyword(tmpbuf, d - tmpbuf))
1148 if (un_char == last_un_char + 1)
1150 weight -= seen[un_char];
1155 if (weight >= 0) /* probably a character class */
1163 intuit_method(char *start, GV *gv)
1165 char *s = start + (*start == '$');
1166 char tmpbuf[sizeof tokenbuf];
1174 if ((cv = GvCVu(gv))) {
1175 char *proto = SvPVX(cv);
1185 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1186 if (*start == '$') {
1187 if (gv || last_lop_op == OP_PRINT || isUPPER(*tokenbuf))
1192 return *s == '(' ? FUNCMETH : METHOD;
1194 if (!keyword(tmpbuf, len)) {
1195 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1200 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1201 if (indirgv && GvCVu(indirgv))
1203 /* filehandle or package name makes it a method */
1204 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1206 if ((bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1207 return 0; /* no assumptions -- "=>" quotes bearword */
1209 nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1211 nextval[nexttoke].opval->op_private = OPpCONST_BARE;
1215 return *s == '(' ? FUNCMETH : METHOD;
1225 char *pdb = PerlEnv_getenv("PERL5DB");
1229 SETERRNO(0,SS$_NORMAL);
1230 return "BEGIN { require 'perl5db.pl' }";
1236 /* Encoded script support. filter_add() effectively inserts a
1237 * 'pre-processing' function into the current source input stream.
1238 * Note that the filter function only applies to the current source file
1239 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1241 * The datasv parameter (which may be NULL) can be used to pass
1242 * private data to this instance of the filter. The filter function
1243 * can recover the SV using the FILTER_DATA macro and use it to
1244 * store private buffers and state information.
1246 * The supplied datasv parameter is upgraded to a PVIO type
1247 * and the IoDIRP field is used to store the function pointer.
1248 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1249 * private use must be set using malloc'd pointers.
1251 static int filter_debug = 0;
1254 filter_add(filter_t funcp, SV *datasv)
1256 if (!funcp){ /* temporary handy debugging hack to be deleted */
1257 filter_debug = atoi((char*)datasv);
1261 rsfp_filters = newAV();
1263 datasv = NEWSV(255,0);
1264 if (!SvUPGRADE(datasv, SVt_PVIO))
1265 die("Can't upgrade filter_add data to SVt_PVIO");
1266 IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
1268 warn("filter_add func %p (%s)", funcp, SvPV(datasv,na));
1269 av_unshift(rsfp_filters, 1);
1270 av_store(rsfp_filters, 0, datasv) ;
1275 /* Delete most recently added instance of this filter function. */
1277 filter_del(filter_t funcp)
1280 warn("filter_del func %p", funcp);
1281 if (!rsfp_filters || AvFILLp(rsfp_filters)<0)
1283 /* if filter is on top of stack (usual case) just pop it off */
1284 if (IoDIRP(FILTER_DATA(AvFILLp(rsfp_filters))) == (void*)funcp){
1285 sv_free(av_pop(rsfp_filters));
1289 /* we need to search for the correct entry and clear it */
1290 die("filter_del can only delete in reverse order (currently)");
1294 /* Invoke the n'th filter function for the current rsfp. */
1296 filter_read(int idx, SV *buf_sv, int maxlen)
1299 /* 0 = read one text line */
1306 if (idx > AvFILLp(rsfp_filters)){ /* Any more filters? */
1307 /* Provide a default input filter to make life easy. */
1308 /* Note that we append to the line. This is handy. */
1310 warn("filter_read %d: from rsfp\n", idx);
1314 int old_len = SvCUR(buf_sv) ;
1316 /* ensure buf_sv is large enough */
1317 SvGROW(buf_sv, old_len + maxlen) ;
1318 if ((len = PerlIO_read(rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1319 if (PerlIO_error(rsfp))
1320 return -1; /* error */
1322 return 0 ; /* end of file */
1324 SvCUR_set(buf_sv, old_len + len) ;
1327 if (sv_gets(buf_sv, rsfp, SvCUR(buf_sv)) == NULL) {
1328 if (PerlIO_error(rsfp))
1329 return -1; /* error */
1331 return 0 ; /* end of file */
1334 return SvCUR(buf_sv);
1336 /* Skip this filter slot if filter has been deleted */
1337 if ( (datasv = FILTER_DATA(idx)) == &sv_undef){
1339 warn("filter_read %d: skipped (filter deleted)\n", idx);
1340 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1342 /* Get function pointer hidden within datasv */
1343 funcp = (filter_t)IoDIRP(datasv);
1345 warn("filter_read %d: via function %p (%s)\n",
1346 idx, funcp, SvPV(datasv,na));
1347 /* Call function. The function is expected to */
1348 /* call "FILTER_READ(idx+1, buf_sv)" first. */
1349 /* Return: <0:error, =0:eof, >0:not eof */
1350 return (*funcp)(idx, buf_sv, maxlen);
1354 filter_gets(register SV *sv, register PerlIO *fp, STRLEN append)
1357 if (!rsfp_filters) {
1358 filter_add(win32_textfilter,NULL);
1364 SvCUR_set(sv, 0); /* start with empty line */
1365 if (FILTER_READ(0, sv, 0) > 0)
1366 return ( SvPVX(sv) ) ;
1371 return (sv_gets(sv, fp, append));
1376 static char* exp_name[] =
1377 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "TERMBLOCK" };
1380 EXT int yychar; /* last token */
1385 Works out what to call the token just pulled out of the input
1386 stream. The yacc parser takes care of taking the ops we return and
1387 stitching them into a tree.
1393 if read an identifier
1394 if we're in a my declaration
1395 croak if they tried to say my($foo::bar)
1396 build the ops for a my() declaration
1397 if it's an access to a my() variable
1398 are we in a sort block?
1399 croak if my($a); $a <=> $b
1400 build ops for access to a my() variable
1401 if in a dq string, and they've said @foo and we can't find @foo
1403 build ops for a bareword
1404 if we already built the token before, use it.
1418 /* check if there's an identifier for us to look at */
1419 if (pending_ident) {
1420 /* pit holds the identifier we read and pending_ident is reset */
1421 char pit = pending_ident;
1424 /* if we're in a my(), we can't allow dynamics here.
1425 $foo'bar has already been turned into $foo::bar, so
1426 just check for colons.
1428 if it's a legal name, the OP is a PADANY.
1431 if (strchr(tokenbuf,':'))
1432 croak(no_myglob,tokenbuf);
1434 yylval.opval = newOP(OP_PADANY, 0);
1435 yylval.opval->op_targ = pad_allocmy(tokenbuf);
1440 build the ops for accesses to a my() variable.
1442 Deny my($a) or my($b) in a sort block, *if* $a or $b is
1443 then used in a comparison. This catches most, but not
1444 all cases. For instance, it catches
1445 sort { my($a); $a <=> $b }
1447 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
1448 (although why you'd do that is anyone's guess).
1451 if (!strchr(tokenbuf,':')) {
1453 /* Check for single character per-thread SVs */
1454 if (tokenbuf[0] == '$' && tokenbuf[2] == '\0'
1455 && !isALPHA(tokenbuf[1]) /* Rule out obvious non-threadsvs */
1456 && (tmp = find_threadsv(&tokenbuf[1])) != NOT_IN_PAD)
1458 yylval.opval = newOP(OP_THREADSV, 0);
1459 yylval.opval->op_targ = tmp;
1462 #endif /* USE_THREADS */
1463 if ((tmp = pad_findmy(tokenbuf)) != NOT_IN_PAD) {
1464 /* if it's a sort block and they're naming $a or $b */
1465 if (last_lop_op == OP_SORT &&
1466 tokenbuf[0] == '$' &&
1467 (tokenbuf[1] == 'a' || tokenbuf[1] == 'b')
1470 for (d = in_eval ? oldoldbufptr : linestart;
1471 d < bufend && *d != '\n';
1474 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
1475 croak("Can't use \"my %s\" in sort comparison",
1481 yylval.opval = newOP(OP_PADANY, 0);
1482 yylval.opval->op_targ = tmp;
1488 Whine if they've said @foo in a doublequoted string,
1489 and @foo isn't a variable we can find in the symbol
1492 if (pit == '@' && lex_state != LEX_NORMAL && !lex_brackets) {
1493 GV *gv = gv_fetchpv(tokenbuf+1, FALSE, SVt_PVAV);
1494 if (!gv || ((tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
1495 yyerror(form("In string, %s now must be written as \\%s",
1496 tokenbuf, tokenbuf));
1499 /* build ops for a bareword */
1500 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(tokenbuf+1, 0));
1501 yylval.opval->op_private = OPpCONST_ENTERED;
1502 gv_fetchpv(tokenbuf+1, in_eval ? (GV_ADDMULTI | 8) : TRUE,
1503 ((tokenbuf[0] == '$') ? SVt_PV
1504 : (tokenbuf[0] == '@') ? SVt_PVAV
1509 /* no identifier pending identification */
1511 switch (lex_state) {
1513 case LEX_NORMAL: /* Some compilers will produce faster */
1514 case LEX_INTERPNORMAL: /* code if we comment these out. */
1518 /* when we're already built the next token, just pull it out the queue */
1521 yylval = nextval[nexttoke];
1523 lex_state = lex_defer;
1524 expect = lex_expect;
1525 lex_defer = LEX_NORMAL;
1527 return(nexttype[nexttoke]);
1529 /* interpolated case modifiers like \L \U, including \Q and \E.
1530 when we get here, bufptr is at the \
1532 case LEX_INTERPCASEMOD:
1534 if (bufptr != bufend && *bufptr != '\\')
1535 croak("panic: INTERPCASEMOD");
1537 /* handle \E or end of string */
1538 if (bufptr == bufend || bufptr[1] == 'E') {
1543 oldmod = lex_casestack[--lex_casemods];
1544 lex_casestack[lex_casemods] = '\0';
1546 if (bufptr != bufend && strchr("LUQ", oldmod)) {
1548 lex_state = LEX_INTERPCONCAT;
1552 if (bufptr != bufend)
1554 lex_state = LEX_INTERPCONCAT;
1559 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
1560 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
1561 if (strchr("LU", *s) &&
1562 (strchr(lex_casestack, 'L') || strchr(lex_casestack, 'U')))
1564 lex_casestack[--lex_casemods] = '\0';
1567 if (lex_casemods > 10) {
1568 char* newlb = Renew(lex_casestack, lex_casemods + 2, char);
1569 if (newlb != lex_casestack) {
1571 lex_casestack = newlb;
1574 lex_casestack[lex_casemods++] = *s;
1575 lex_casestack[lex_casemods] = '\0';
1576 lex_state = LEX_INTERPCONCAT;
1577 nextval[nexttoke].ival = 0;
1580 nextval[nexttoke].ival = OP_LCFIRST;
1582 nextval[nexttoke].ival = OP_UCFIRST;
1584 nextval[nexttoke].ival = OP_LC;
1586 nextval[nexttoke].ival = OP_UC;
1588 nextval[nexttoke].ival = OP_QUOTEMETA;
1590 croak("panic: yylex");
1602 case LEX_INTERPPUSH:
1603 return sublex_push();
1605 case LEX_INTERPSTART:
1606 if (bufptr == bufend)
1607 return sublex_done();
1609 lex_dojoin = (*bufptr == '@');
1610 lex_state = LEX_INTERPNORMAL;
1612 nextval[nexttoke].ival = 0;
1615 nextval[nexttoke].opval = newOP(OP_THREADSV, 0);
1616 nextval[nexttoke].opval->op_targ = find_threadsv("\"");
1617 force_next(PRIVATEREF);
1619 force_ident("\"", '$');
1620 #endif /* USE_THREADS */
1621 nextval[nexttoke].ival = 0;
1623 nextval[nexttoke].ival = 0;
1625 nextval[nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
1634 case LEX_INTERPENDMAYBE:
1635 if (intuit_more(bufptr)) {
1636 lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
1644 lex_state = LEX_INTERPCONCAT;
1648 case LEX_INTERPCONCAT:
1651 croak("panic: INTERPCONCAT");
1653 if (bufptr == bufend)
1654 return sublex_done();
1656 if (SvIVX(linestr) == '\'') {
1657 SV *sv = newSVsv(linestr);
1660 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1664 s = scan_const(bufptr);
1666 lex_state = LEX_INTERPCASEMOD;
1668 lex_state = LEX_INTERPSTART;
1672 nextval[nexttoke] = yylval;
1685 lex_state = LEX_NORMAL;
1686 s = scan_formline(bufptr);
1693 oldoldbufptr = oldbufptr;
1696 PerlIO_printf(PerlIO_stderr(), "### Tokener expecting %s at %s\n", exp_name[expect], s);
1702 croak("Unrecognized character \\%03o", *s & 255);
1705 goto fake_eof; /* emulate EOF on ^D or ^Z */
1711 yyerror("Missing right bracket");
1715 goto retry; /* ignore stray nulls */
1718 if (!in_eval && !preambled) {
1720 sv_setpv(linestr,incl_perldb());
1722 sv_catpv(linestr,";");
1724 while(AvFILLp(preambleav) >= 0) {
1725 SV *tmpsv = av_shift(preambleav);
1726 sv_catsv(linestr, tmpsv);
1727 sv_catpv(linestr, ";");
1730 sv_free((SV*)preambleav);
1733 if (minus_n || minus_p) {
1734 sv_catpv(linestr, "LINE: while (<>) {");
1736 sv_catpv(linestr,"chomp;");
1738 GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
1740 GvIMPORTED_AV_on(gv);
1742 if (strchr("/'\"", *splitstr)
1743 && strchr(splitstr + 1, *splitstr))
1744 sv_catpvf(linestr, "@F=split(%s);", splitstr);
1747 s = "'~#\200\1'"; /* surely one char is unused...*/
1748 while (s[1] && strchr(splitstr, *s)) s++;
1750 sv_catpvf(linestr, "@F=split(%s%c",
1751 "q" + (delim == '\''), delim);
1752 for (s = splitstr; *s; s++) {
1754 sv_catpvn(linestr, "\\", 1);
1755 sv_catpvn(linestr, s, 1);
1757 sv_catpvf(linestr, "%c);", delim);
1761 sv_catpv(linestr,"@F=split(' ');");
1764 sv_catpv(linestr, "\n");
1765 oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr);
1766 bufend = SvPVX(linestr) + SvCUR(linestr);
1767 if (PERLDB_LINE && curstash != debstash) {
1768 SV *sv = NEWSV(85,0);
1770 sv_upgrade(sv, SVt_PVMG);
1771 sv_setsv(sv,linestr);
1772 av_store(GvAV(curcop->cop_filegv),(I32)curcop->cop_line,sv);
1777 if ((s = filter_gets(linestr, rsfp, 0)) == Nullch) {
1780 if (preprocess && !in_eval)
1781 (void)PerlProc_pclose(rsfp);
1782 else if ((PerlIO *)rsfp == PerlIO_stdin())
1783 PerlIO_clearerr(rsfp);
1785 (void)PerlIO_close(rsfp);
1788 if (!in_eval && (minus_n || minus_p)) {
1789 sv_setpv(linestr,minus_p ? ";}continue{print" : "");
1790 sv_catpv(linestr,";}");
1791 oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr);
1792 bufend = SvPVX(linestr) + SvCUR(linestr);
1793 minus_n = minus_p = 0;
1796 oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr);
1797 sv_setpv(linestr,"");
1798 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
1801 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
1804 /* Incest with pod. */
1805 if (*s == '=' && strnEQ(s, "=cut", 4)) {
1806 sv_setpv(linestr, "");
1807 oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr);
1808 bufend = SvPVX(linestr) + SvCUR(linestr);
1813 } while (doextract);
1814 oldoldbufptr = oldbufptr = bufptr = linestart = s;
1815 if (PERLDB_LINE && curstash != debstash) {
1816 SV *sv = NEWSV(85,0);
1818 sv_upgrade(sv, SVt_PVMG);
1819 sv_setsv(sv,linestr);
1820 av_store(GvAV(curcop->cop_filegv),(I32)curcop->cop_line,sv);
1822 bufend = SvPVX(linestr) + SvCUR(linestr);
1823 if (curcop->cop_line == 1) {
1824 while (s < bufend && isSPACE(*s))
1826 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
1830 if (*s == '#' && *(s+1) == '!')
1832 #ifdef ALTERNATE_SHEBANG
1834 static char as[] = ALTERNATE_SHEBANG;
1835 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
1836 d = s + (sizeof(as) - 1);
1838 #endif /* ALTERNATE_SHEBANG */
1847 while (*d && !isSPACE(*d))
1851 #ifdef ARG_ZERO_IS_SCRIPT
1852 if (ipathend > ipath) {
1854 * HP-UX (at least) sets argv[0] to the script name,
1855 * which makes $^X incorrect. And Digital UNIX and Linux,
1856 * at least, set argv[0] to the basename of the Perl
1857 * interpreter. So, having found "#!", we'll set it right.
1859 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
1860 assert(SvPOK(x) || SvGMAGICAL(x));
1861 if (sv_eq(x, GvSV(curcop->cop_filegv))) {
1862 sv_setpvn(x, ipath, ipathend - ipath);
1865 TAINT_NOT; /* $^X is always tainted, but that's OK */
1867 #endif /* ARG_ZERO_IS_SCRIPT */
1872 d = instr(s,"perl -");
1874 d = instr(s,"perl");
1875 #ifdef ALTERNATE_SHEBANG
1877 * If the ALTERNATE_SHEBANG on this system starts with a
1878 * character that can be part of a Perl expression, then if
1879 * we see it but not "perl", we're probably looking at the
1880 * start of Perl code, not a request to hand off to some
1881 * other interpreter. Similarly, if "perl" is there, but
1882 * not in the first 'word' of the line, we assume the line
1883 * contains the start of the Perl program.
1885 if (d && *s != '#') {
1887 while (*c && !strchr("; \t\r\n\f\v#", *c))
1890 d = Nullch; /* "perl" not in first word; ignore */
1892 *s = '#'; /* Don't try to parse shebang line */
1894 #endif /* ALTERNATE_SHEBANG */
1899 !instr(s,"indir") &&
1900 instr(origargv[0],"perl"))
1906 while (s < bufend && isSPACE(*s))
1909 Newz(899,newargv,origargc+3,char*);
1911 while (s < bufend && !isSPACE(*s))
1914 Copy(origargv+1, newargv+2, origargc+1, char*);
1919 execv(ipath, newargv);
1920 croak("Can't exec %s", ipath);
1923 U32 oldpdb = perldb;
1924 bool oldn = minus_n;
1925 bool oldp = minus_p;
1927 while (*d && !isSPACE(*d)) d++;
1928 while (*d == ' ' || *d == '\t') d++;
1932 if (*d == 'M' || *d == 'm') {
1934 while (*d && !isSPACE(*d)) d++;
1935 croak("Too late for \"-%.*s\" option",
1938 d = moreswitches(d);
1940 if (PERLDB_LINE && !oldpdb ||
1941 ( minus_n || minus_p ) && !(oldn || oldp) )
1942 /* if we have already added "LINE: while (<>) {",
1943 we must not do it again */
1945 sv_setpv(linestr, "");
1946 oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr);
1947 bufend = SvPVX(linestr) + SvCUR(linestr);
1950 (void)gv_fetchfile(origfilename);
1957 if (lex_formbrack && lex_brackets <= lex_formbrack) {
1959 lex_state = LEX_FORMLINE;
1965 warn("Illegal character \\%03o (carriage return)", '\r');
1967 "(Maybe you didn't strip carriage returns after a network transfer?)\n");
1969 case ' ': case '\t': case '\f': case 013:
1974 if (lex_state != LEX_NORMAL || (in_eval && !rsfp)) {
1976 while (s < d && *s != '\n')
1981 if (lex_formbrack && lex_brackets <= lex_formbrack) {
1983 lex_state = LEX_FORMLINE;
1993 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
1998 while (s < bufend && (*s == ' ' || *s == '\t'))
2001 if (strnEQ(s,"=>",2)) {
2002 s = force_word(bufptr,WORD,FALSE,FALSE,FALSE);
2003 OPERATOR('-'); /* unary minus */
2005 last_uni = oldbufptr;
2006 last_lop_op = OP_FTEREAD; /* good enough */
2008 case 'r': FTST(OP_FTEREAD);
2009 case 'w': FTST(OP_FTEWRITE);
2010 case 'x': FTST(OP_FTEEXEC);
2011 case 'o': FTST(OP_FTEOWNED);
2012 case 'R': FTST(OP_FTRREAD);
2013 case 'W': FTST(OP_FTRWRITE);
2014 case 'X': FTST(OP_FTREXEC);
2015 case 'O': FTST(OP_FTROWNED);
2016 case 'e': FTST(OP_FTIS);
2017 case 'z': FTST(OP_FTZERO);
2018 case 's': FTST(OP_FTSIZE);
2019 case 'f': FTST(OP_FTFILE);
2020 case 'd': FTST(OP_FTDIR);
2021 case 'l': FTST(OP_FTLINK);
2022 case 'p': FTST(OP_FTPIPE);
2023 case 'S': FTST(OP_FTSOCK);
2024 case 'u': FTST(OP_FTSUID);
2025 case 'g': FTST(OP_FTSGID);
2026 case 'k': FTST(OP_FTSVTX);
2027 case 'b': FTST(OP_FTBLK);
2028 case 'c': FTST(OP_FTCHR);
2029 case 't': FTST(OP_FTTTY);
2030 case 'T': FTST(OP_FTTEXT);
2031 case 'B': FTST(OP_FTBINARY);
2032 case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2033 case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2034 case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
2036 croak("Unrecognized file test: -%c", (int)tmp);
2043 if (expect == XOPERATOR)
2048 else if (*s == '>') {
2051 if (isIDFIRST(*s)) {
2052 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2060 if (expect == XOPERATOR)
2063 if (isSPACE(*s) || !isSPACE(*bufptr))
2065 OPERATOR('-'); /* unary minus */
2072 if (expect == XOPERATOR)
2077 if (expect == XOPERATOR)
2080 if (isSPACE(*s) || !isSPACE(*bufptr))
2086 if (expect != XOPERATOR) {
2087 s = scan_ident(s, bufend, tokenbuf, sizeof tokenbuf, TRUE);
2089 force_ident(tokenbuf, '*');
2102 if (expect == XOPERATOR) {
2107 s = scan_ident(s, bufend, tokenbuf + 1, sizeof tokenbuf - 1, TRUE);
2110 yyerror("Final % should be \\% or %name");
2113 pending_ident = '%';
2135 if (last_lop == oldoldbufptr || last_uni == oldoldbufptr)
2136 oldbufptr = oldoldbufptr; /* allow print(STDOUT 123) */
2141 if (curcop->cop_line < copline)
2142 copline = curcop->cop_line;
2153 if (lex_brackets <= 0)
2154 yyerror("Unmatched right bracket");
2157 if (lex_state == LEX_INTERPNORMAL) {
2158 if (lex_brackets == 0) {
2159 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
2160 lex_state = LEX_INTERPEND;
2167 if (lex_brackets > 100) {
2168 char* newlb = Renew(lex_brackstack, lex_brackets + 1, char);
2169 if (newlb != lex_brackstack) {
2171 lex_brackstack = newlb;
2176 if (lex_formbrack) {
2180 if (oldoldbufptr == last_lop)
2181 lex_brackstack[lex_brackets++] = XTERM;
2183 lex_brackstack[lex_brackets++] = XOPERATOR;
2184 OPERATOR(HASHBRACK);
2186 while (s < bufend && (*s == ' ' || *s == '\t'))
2190 if (d < bufend && *d == '-') {
2193 while (d < bufend && (*d == ' ' || *d == '\t'))
2196 if (d < bufend && isIDFIRST(*d)) {
2197 d = scan_word(d, tokenbuf + 1, sizeof tokenbuf - 1,
2199 while (d < bufend && (*d == ' ' || *d == '\t'))
2202 char minus = (tokenbuf[0] == '-');
2203 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2210 lex_brackstack[lex_brackets++] = XSTATE;
2214 lex_brackstack[lex_brackets++] = XOPERATOR;
2219 if (oldoldbufptr == last_lop)
2220 lex_brackstack[lex_brackets++] = XTERM;
2222 lex_brackstack[lex_brackets++] = XOPERATOR;
2225 if (expect == XSTATE) {
2226 lex_brackstack[lex_brackets-1] = XSTATE;
2229 OPERATOR(HASHBRACK);
2231 /* This hack serves to disambiguate a pair of curlies
2232 * as being a block or an anon hash. Normally, expectation
2233 * determines that, but in cases where we're not in a
2234 * position to expect anything in particular (like inside
2235 * eval"") we have to resolve the ambiguity. This code
2236 * covers the case where the first term in the curlies is a
2237 * quoted string. Most other cases need to be explicitly
2238 * disambiguated by prepending a `+' before the opening
2239 * curly in order to force resolution as an anon hash.
2241 * XXX should probably propagate the outer expectation
2242 * into eval"" to rely less on this hack, but that could
2243 * potentially break current behavior of eval"".
2247 if (*s == '\'' || *s == '"' || *s == '`') {
2248 /* common case: get past first string, handling escapes */
2249 for (t++; t < bufend && *t != *s;)
2250 if (*t++ == '\\' && (*t == '\\' || *t == *s))
2254 else if (*s == 'q') {
2257 || ((*t == 'q' || *t == 'x') && ++t < bufend
2258 && !isALNUM(*t)))) {
2260 char open, close, term;
2263 while (t < bufend && isSPACE(*t))
2267 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
2271 for (t++; t < bufend; t++) {
2272 if (*t == '\\' && t+1 < bufend && open != '\\')
2274 else if (*t == open)
2278 for (t++; t < bufend; t++) {
2279 if (*t == '\\' && t+1 < bufend)
2281 else if (*t == close && --brackets <= 0)
2283 else if (*t == open)
2289 else if (isALPHA(*s)) {
2290 for (t++; t < bufend && isALNUM(*t); t++) ;
2292 while (t < bufend && isSPACE(*t))
2294 /* if comma follows first term, call it an anon hash */
2295 /* XXX it could be a comma expression with loop modifiers */
2296 if (t < bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
2297 || (*t == '=' && t[1] == '>')))
2298 OPERATOR(HASHBRACK);
2302 lex_brackstack[lex_brackets-1] = XSTATE;
2308 yylval.ival = curcop->cop_line;
2309 if (isSPACE(*s) || *s == '#')
2310 copline = NOLINE; /* invalidate current command line number */
2315 if (lex_brackets <= 0)
2316 yyerror("Unmatched right bracket");
2318 expect = (expectation)lex_brackstack[--lex_brackets];
2319 if (lex_brackets < lex_formbrack)
2321 if (lex_state == LEX_INTERPNORMAL) {
2322 if (lex_brackets == 0) {
2323 if (lex_fakebrack) {
2324 lex_state = LEX_INTERPEND;
2326 return yylex(); /* ignore fake brackets */
2328 if (*s == '-' && s[1] == '>')
2329 lex_state = LEX_INTERPENDMAYBE;
2330 else if (*s != '[' && *s != '{')
2331 lex_state = LEX_INTERPEND;
2334 if (lex_brackets < lex_fakebrack) {
2337 return yylex(); /* ignore fake brackets */
2347 if (expect == XOPERATOR) {
2348 if (dowarn && isALPHA(*s) && bufptr == linestart) {
2356 s = scan_ident(s - 1, bufend, tokenbuf, sizeof tokenbuf, TRUE);
2359 force_ident(tokenbuf, '&');
2363 yylval.ival = (OPpENTERSUB_AMPER<<8);
2382 if (dowarn && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
2383 warn("Reversed %c= operator",(int)tmp);
2385 if (expect == XSTATE && isALPHA(tmp) &&
2386 (s == linestart+1 || s[-2] == '\n') )
2388 if (in_eval && !rsfp) {
2393 if (strnEQ(s,"=cut",4)) {
2410 if (lex_brackets < lex_formbrack) {
2412 for (t = s; *t == ' ' || *t == '\t'; t++) ;
2413 if (*t == '\n' || *t == '#') {
2431 if (expect != XOPERATOR) {
2432 if (s[1] != '<' && !strchr(s,'>'))
2435 s = scan_heredoc(s);
2437 s = scan_inputsymbol(s);
2438 TERM(sublex_start());
2443 SHop(OP_LEFT_SHIFT);
2457 SHop(OP_RIGHT_SHIFT);
2466 if (expect == XOPERATOR) {
2467 if (lex_formbrack && lex_brackets == lex_formbrack) {
2470 return ','; /* grandfather non-comma-format format */
2474 if (s[1] == '#' && (isALPHA(s[2]) || strchr("_{$:", s[2]))) {
2475 if (expect == XOPERATOR)
2476 no_op("Array length", bufptr);
2478 s = scan_ident(s + 1, bufend, tokenbuf + 1, sizeof tokenbuf - 1,
2483 pending_ident = '#';
2487 if (expect == XOPERATOR)
2488 no_op("Scalar", bufptr);
2490 s = scan_ident(s, bufend, tokenbuf + 1, sizeof tokenbuf - 1, FALSE);
2493 yyerror("Final $ should be \\$ or $name");
2497 /* This kludge not intended to be bulletproof. */
2498 if (tokenbuf[1] == '[' && !tokenbuf[2]) {
2499 yylval.opval = newSVOP(OP_CONST, 0,
2500 newSViv((IV)compiling.cop_arybase));
2501 yylval.opval->op_private = OPpCONST_ARYBASE;
2506 if (lex_state == LEX_NORMAL)
2509 if ((expect != XREF || oldoldbufptr == last_lop) && intuit_more(s)) {
2515 isSPACE(*t) || isALNUM(*t) || *t == '$';
2518 bufptr = skipspace(bufptr);
2519 while (t < bufend && *t != ']')
2521 warn("Multidimensional syntax %.*s not supported",
2522 (t - bufptr) + 1, bufptr);
2526 else if (*s == '{') {
2528 if (dowarn && strEQ(tokenbuf+1, "SIG") &&
2529 (t = strchr(s, '}')) && (t = strchr(t, '=')))
2531 char tmpbuf[sizeof tokenbuf];
2533 for (t++; isSPACE(*t); t++) ;
2534 if (isIDFIRST(*t)) {
2535 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
2536 if (*t != '(' && perl_get_cv(tmpbuf, FALSE))
2537 warn("You need to quote \"%s\"", tmpbuf);
2544 if (lex_state == LEX_NORMAL && isSPACE(*d)) {
2545 bool islop = (last_lop == oldoldbufptr);
2546 if (!islop || last_lop_op == OP_GREPSTART)
2548 else if (strchr("$@\"'`q", *s))
2549 expect = XTERM; /* e.g. print $fh "foo" */
2550 else if (strchr("&*<%", *s) && isIDFIRST(s[1]))
2551 expect = XTERM; /* e.g. print $fh &sub */
2552 else if (isIDFIRST(*s)) {
2553 char tmpbuf[sizeof tokenbuf];
2554 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2555 if (tmp = keyword(tmpbuf, len)) {
2556 /* binary operators exclude handle interpretations */
2568 expect = XTERM; /* e.g. print $fh length() */
2573 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
2574 if (gv && GvCVu(gv))
2575 expect = XTERM; /* e.g. print $fh subr() */
2578 else if (isDIGIT(*s))
2579 expect = XTERM; /* e.g. print $fh 3 */
2580 else if (*s == '.' && isDIGIT(s[1]))
2581 expect = XTERM; /* e.g. print $fh .3 */
2582 else if (strchr("/?-+", *s) && !isSPACE(s[1]))
2583 expect = XTERM; /* e.g. print $fh -1 */
2584 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]))
2585 expect = XTERM; /* print $fh <<"EOF" */
2587 pending_ident = '$';
2591 if (expect == XOPERATOR)
2594 s = scan_ident(s, bufend, tokenbuf + 1, sizeof tokenbuf - 1, FALSE);
2597 yyerror("Final @ should be \\@ or @name");
2600 if (lex_state == LEX_NORMAL)
2602 if ((expect != XREF || oldoldbufptr == last_lop) && intuit_more(s)) {
2606 /* Warn about @ where they meant $. */
2608 if (*s == '[' || *s == '{') {
2610 while (*t && (isALNUM(*t) || strchr(" \t$#+-'\"", *t)))
2612 if (*t == '}' || *t == ']') {
2614 bufptr = skipspace(bufptr);
2615 warn("Scalar value %.*s better written as $%.*s",
2616 t-bufptr, bufptr, t-bufptr-1, bufptr+1);
2621 pending_ident = '@';
2624 case '/': /* may either be division or pattern */
2625 case '?': /* may either be conditional or pattern */
2626 if (expect != XOPERATOR) {
2627 /* Disable warning on "study /blah/" */
2628 if (oldoldbufptr == last_uni
2629 && (*last_uni != 's' || s - last_uni < 5
2630 || memNE(last_uni, "study", 5) || isALNUM(last_uni[5])))
2633 TERM(sublex_start());
2641 if (lex_formbrack && lex_brackets == lex_formbrack && s[1] == '\n' &&
2642 (s == linestart || s[-1] == '\n') ) {
2647 if (expect == XOPERATOR || !isDIGIT(s[1])) {
2653 yylval.ival = OPf_SPECIAL;
2659 if (expect != XOPERATOR)
2664 case '0': case '1': case '2': case '3': case '4':
2665 case '5': case '6': case '7': case '8': case '9':
2667 if (expect == XOPERATOR)
2673 if (expect == XOPERATOR) {
2674 if (lex_formbrack && lex_brackets == lex_formbrack) {
2677 return ','; /* grandfather non-comma-format format */
2683 missingterm((char*)0);
2684 yylval.ival = OP_CONST;
2685 TERM(sublex_start());
2689 if (expect == XOPERATOR) {
2690 if (lex_formbrack && lex_brackets == lex_formbrack) {
2693 return ','; /* grandfather non-comma-format format */
2699 missingterm((char*)0);
2700 yylval.ival = OP_CONST;
2701 for (d = SvPV(lex_stuff, len); len; len--, d++) {
2702 if (*d == '$' || *d == '@' || *d == '\\') {
2703 yylval.ival = OP_STRINGIFY;
2707 TERM(sublex_start());
2711 if (expect == XOPERATOR)
2712 no_op("Backticks",s);
2714 missingterm((char*)0);
2715 yylval.ival = OP_BACKTICK;
2717 TERM(sublex_start());
2721 if (dowarn && lex_inwhat && isDIGIT(*s))
2722 warn("Can't use \\%c to mean $%c in expression", *s, *s);
2723 if (expect == XOPERATOR)
2724 no_op("Backslash",s);
2728 if (isDIGIT(s[1]) && expect == XOPERATOR) {
2767 s = scan_word(s, tokenbuf, sizeof tokenbuf, FALSE, &len);
2769 /* Some keywords can be followed by any delimiter, including ':' */
2770 tmp = (len == 1 && strchr("msyq", tokenbuf[0]) ||
2771 len == 2 && ((tokenbuf[0] == 't' && tokenbuf[1] == 'r') ||
2772 (tokenbuf[0] == 'q' &&
2773 strchr("qwx", tokenbuf[1]))));
2775 /* x::* is just a word, unless x is "CORE" */
2776 if (!tmp && *s == ':' && s[1] == ':' && strNE(tokenbuf, "CORE"))
2780 while (d < bufend && isSPACE(*d))
2781 d++; /* no comments skipped here, or s### is misparsed */
2783 /* Is this a label? */
2784 if (!tmp && expect == XSTATE
2785 && d < bufend && *d == ':' && *(d + 1) != ':') {
2787 yylval.pval = savepv(tokenbuf);
2792 /* Check for keywords */
2793 tmp = keyword(tokenbuf, len);
2795 /* Is this a word before a => operator? */
2796 if (strnEQ(d,"=>",2)) {
2798 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(tokenbuf,0));
2799 yylval.opval->op_private = OPpCONST_BARE;
2803 if (tmp < 0) { /* second-class keyword? */
2804 if (expect != XOPERATOR && (*s != ':' || s[1] != ':') &&
2805 (((gv = gv_fetchpv(tokenbuf, FALSE, SVt_PVCV)) &&
2806 GvCVu(gv) && GvIMPORTED_CV(gv)) ||
2807 ((gvp = (GV**)hv_fetch(globalstash,tokenbuf,len,FALSE)) &&
2808 (gv = *gvp) != (GV*)&sv_undef &&
2809 GvCVu(gv) && GvIMPORTED_CV(gv))))
2811 tmp = 0; /* overridden by importation */
2814 && -tmp==KEY_lock /* XXX generalizable kludge */
2815 && !hv_fetch(GvHVn(incgv), "Thread.pm", 9, FALSE))
2817 tmp = 0; /* any sub overrides "weak" keyword */
2820 tmp = -tmp; gv = Nullgv; gvp = 0;
2827 default: /* not a keyword */
2830 char lastchar = (bufptr == oldoldbufptr ? 0 : bufptr[-1]);
2832 /* Get the rest if it looks like a package qualifier */
2834 if (*s == '\'' || *s == ':' && s[1] == ':') {
2836 s = scan_word(s, tokenbuf + len, sizeof tokenbuf - len,
2839 croak("Bad name after %s%s", tokenbuf,
2840 *s == '\'' ? "'" : "::");
2844 if (expect == XOPERATOR) {
2845 if (bufptr == linestart) {
2851 no_op("Bareword",s);
2854 /* Look for a subroutine with this name in current package,
2855 unless name is "Foo::", in which case Foo is a bearword
2856 (and a package name). */
2859 tokenbuf[len - 2] == ':' && tokenbuf[len - 1] == ':')
2861 if (dowarn && ! gv_fetchpv(tokenbuf, FALSE, SVt_PVHV))
2862 warn("Bareword \"%s\" refers to nonexistent package",
2865 tokenbuf[len] = '\0';
2872 gv = gv_fetchpv(tokenbuf, FALSE, SVt_PVCV);
2875 /* if we saw a global override before, get the right name */
2878 sv = newSVpv("CORE::GLOBAL::",14);
2879 sv_catpv(sv,tokenbuf);
2882 sv = newSVpv(tokenbuf,0);
2884 /* Presume this is going to be a bareword of some sort. */
2887 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2888 yylval.opval->op_private = OPpCONST_BARE;
2890 /* And if "Foo::", then that's what it certainly is. */
2895 /* See if it's the indirect object for a list operator. */
2898 oldoldbufptr < bufptr &&
2899 (oldoldbufptr == last_lop || oldoldbufptr == last_uni) &&
2900 /* NO SKIPSPACE BEFORE HERE! */
2902 ((opargs[last_lop_op] >> OASHIFT)& 7) == OA_FILEREF) )
2904 bool immediate_paren = *s == '(';
2906 /* (Now we can afford to cross potential line boundary.) */
2909 /* Two barewords in a row may indicate method call. */
2911 if ((isALPHA(*s) || *s == '$') && (tmp=intuit_method(s,gv)))
2914 /* If not a declared subroutine, it's an indirect object. */
2915 /* (But it's an indir obj regardless for sort.) */
2917 if ((last_lop_op == OP_SORT ||
2918 (!immediate_paren && (!gv || !GvCVu(gv))) ) &&
2919 (last_lop_op != OP_MAPSTART && last_lop_op != OP_GREPSTART)){
2920 expect = (last_lop == oldoldbufptr) ? XTERM : XOPERATOR;
2925 /* If followed by a paren, it's certainly a subroutine. */
2931 if (gv && GvCVu(gv)) {
2932 for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
2933 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
2938 nextval[nexttoke].opval = yylval.opval;
2945 /* If followed by var or block, call it a method (unless sub) */
2947 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
2948 last_lop = oldbufptr;
2949 last_lop_op = OP_METHOD;
2953 /* If followed by a bareword, see if it looks like indir obj. */
2955 if ((isALPHA(*s) || *s == '$') && (tmp = intuit_method(s,gv)))
2958 /* Not a method, so call it a subroutine (if defined) */
2960 if (gv && GvCVu(gv)) {
2962 if (lastchar == '-')
2963 warn("Ambiguous use of -%s resolved as -&%s()",
2964 tokenbuf, tokenbuf);
2965 last_lop = oldbufptr;
2966 last_lop_op = OP_ENTERSUB;
2967 /* Check for a constant sub */
2969 if ((sv = cv_const_sv(cv))) {
2971 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
2972 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
2973 yylval.opval->op_private = 0;
2977 /* Resolve to GV now. */
2978 op_free(yylval.opval);
2979 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
2980 /* Is there a prototype? */
2983 char *proto = SvPV((SV*)cv, len);
2986 if (strEQ(proto, "$"))
2988 if (*proto == '&' && *s == '{') {
2989 sv_setpv(subname,"__ANON__");
2993 nextval[nexttoke].opval = yylval.opval;
2999 if (hints & HINT_STRICT_SUBS &&
3002 last_lop_op != OP_TRUNCATE && /* S/F prototype in opcode.pl */
3003 last_lop_op != OP_ACCEPT &&
3004 last_lop_op != OP_PIPE_OP &&
3005 last_lop_op != OP_SOCKPAIR)
3008 "Bareword \"%s\" not allowed while \"strict subs\" in use",
3013 /* Call it a bare word */
3017 if (lastchar != '-') {
3018 for (d = tokenbuf; *d && isLOWER(*d); d++) ;
3020 warn(warn_reserved, tokenbuf);
3025 if (lastchar && strchr("*%&", lastchar)) {
3026 warn("Operator or semicolon missing before %c%s",
3027 lastchar, tokenbuf);
3028 warn("Ambiguous use of %c resolved as operator %c",
3029 lastchar, lastchar);
3035 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3036 newSVsv(GvSV(curcop->cop_filegv)));
3040 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3041 newSVpvf("%ld", (long)curcop->cop_line));
3044 case KEY___PACKAGE__:
3045 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3047 ? newSVsv(curstname)
3056 if (rsfp && (!in_eval || tokenbuf[2] == 'D')) {
3057 char *pname = "main";
3058 if (tokenbuf[2] == 'D')
3059 pname = HvNAME(curstash ? curstash : defstash);
3060 gv = gv_fetchpv(form("%s::DATA", pname), TRUE, SVt_PVIO);
3063 GvIOp(gv) = newIO();
3064 IoIFP(GvIOp(gv)) = rsfp;
3065 #if defined(HAS_FCNTL) && defined(F_SETFD)
3067 int fd = PerlIO_fileno(rsfp);
3068 fcntl(fd,F_SETFD,fd >= 3);
3071 /* Mark this internal pseudo-handle as clean */
3072 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3074 IoTYPE(GvIOp(gv)) = '|';
3075 else if ((PerlIO*)rsfp == PerlIO_stdin())
3076 IoTYPE(GvIOp(gv)) = '-';
3078 IoTYPE(GvIOp(gv)) = '<';
3089 if (expect == XSTATE) {
3096 if (*s == ':' && s[1] == ':') {
3099 s = scan_word(s, tokenbuf, sizeof tokenbuf, FALSE, &len);
3100 tmp = keyword(tokenbuf, len);
3114 LOP(OP_ACCEPT,XTERM);
3120 LOP(OP_ATAN2,XTERM);
3129 LOP(OP_BLESS,XTERM);
3138 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
3158 LOP(OP_CRYPT,XTERM);
3162 for (d = s; d < bufend && (isSPACE(*d) || *d == '('); d++) ;
3163 if (*d != '0' && isDIGIT(*d))
3164 yywarn("chmod: mode argument is missing initial 0");
3166 LOP(OP_CHMOD,XTERM);
3169 LOP(OP_CHOWN,XTERM);
3172 LOP(OP_CONNECT,XTERM);
3188 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3192 hints |= HINT_BLOCK_SCOPE;
3202 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3203 LOP(OP_DBMOPEN,XTERM);
3209 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3216 yylval.ival = curcop->cop_line;
3230 expect = (*s == '{') ? XTERMBLOCK : XTERM;
3231 UNIBRACK(OP_ENTEREVAL);
3246 case KEY_endhostent:
3252 case KEY_endservent:
3255 case KEY_endprotoent:
3266 yylval.ival = curcop->cop_line;
3268 if (expect == XSTATE && isIDFIRST(*s)) {
3270 if ((bufend - p) >= 3 &&
3271 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3275 croak("Missing $ on loop variable");
3280 LOP(OP_FORMLINE,XTERM);
3286 LOP(OP_FCNTL,XTERM);
3292 LOP(OP_FLOCK,XTERM);
3301 LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
3304 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3319 case KEY_getpriority:
3320 LOP(OP_GETPRIORITY,XTERM);
3322 case KEY_getprotobyname:
3325 case KEY_getprotobynumber:
3326 LOP(OP_GPBYNUMBER,XTERM);
3328 case KEY_getprotoent:
3340 case KEY_getpeername:
3341 UNI(OP_GETPEERNAME);
3343 case KEY_gethostbyname:
3346 case KEY_gethostbyaddr:
3347 LOP(OP_GHBYADDR,XTERM);
3349 case KEY_gethostent:
3352 case KEY_getnetbyname:
3355 case KEY_getnetbyaddr:
3356 LOP(OP_GNBYADDR,XTERM);
3361 case KEY_getservbyname:
3362 LOP(OP_GSBYNAME,XTERM);
3364 case KEY_getservbyport:
3365 LOP(OP_GSBYPORT,XTERM);
3367 case KEY_getservent:
3370 case KEY_getsockname:
3371 UNI(OP_GETSOCKNAME);
3373 case KEY_getsockopt:
3374 LOP(OP_GSOCKOPT,XTERM);
3396 yylval.ival = curcop->cop_line;
3400 LOP(OP_INDEX,XTERM);
3406 LOP(OP_IOCTL,XTERM);
3418 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3449 LOP(OP_LISTEN,XTERM);
3459 TERM(sublex_start());
3462 LOP(OP_MAPSTART,XREF);
3465 LOP(OP_MKDIR,XTERM);
3468 LOP(OP_MSGCTL,XTERM);
3471 LOP(OP_MSGGET,XTERM);
3474 LOP(OP_MSGRCV,XTERM);
3477 LOP(OP_MSGSND,XTERM);
3482 if (isIDFIRST(*s)) {
3483 s = scan_word(s, tokenbuf, sizeof tokenbuf, TRUE, &len);
3484 in_my_stash = gv_stashpv(tokenbuf, FALSE);
3488 sprintf(tmpbuf, "No such class %.1000s", tokenbuf);
3495 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3502 if (expect != XSTATE)
3503 yyerror("\"no\" not allowed in expression");
3504 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3505 s = force_version(s);
3514 if (isIDFIRST(*s)) {
3516 for (d = s; isALNUM(*d); d++) ;
3518 if (strchr("|&*+-=!?:.", *t))
3519 warn("Precedence problem: open %.*s should be open(%.*s)",
3525 yylval.ival = OP_OR;
3535 LOP(OP_OPEN_DIR,XTERM);
3538 checkcomma(s,tokenbuf,"filehandle");
3542 checkcomma(s,tokenbuf,"filehandle");
3561 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3565 LOP(OP_PIPE_OP,XTERM);
3570 missingterm((char*)0);
3571 yylval.ival = OP_CONST;
3572 TERM(sublex_start());
3580 missingterm((char*)0);
3581 if (dowarn && SvLEN(lex_stuff)) {
3582 d = SvPV_force(lex_stuff, len);
3583 for (; len; --len, ++d) {
3585 warn("Possible attempt to separate words with commas");
3589 warn("Possible attempt to put comments in qw() list");
3595 nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, tokeq(lex_stuff));
3599 nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(" ",1));
3602 yylval.ival = OP_SPLIT;
3606 last_lop = oldbufptr;
3607 last_lop_op = OP_SPLIT;
3613 missingterm((char*)0);
3614 yylval.ival = OP_STRINGIFY;
3615 if (SvIVX(lex_stuff) == '\'')
3616 SvIVX(lex_stuff) = 0; /* qq'$foo' should intepolate */
3617 TERM(sublex_start());
3622 missingterm((char*)0);
3623 yylval.ival = OP_BACKTICK;
3625 TERM(sublex_start());
3632 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3633 if (isIDFIRST(*tokenbuf))
3634 gv_stashpvn(tokenbuf, strlen(tokenbuf), TRUE);
3636 yyerror("<> should be quotes");
3643 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3647 LOP(OP_RENAME,XTERM);
3656 LOP(OP_RINDEX,XTERM);
3679 LOP(OP_REVERSE,XTERM);
3690 TERM(sublex_start());
3692 TOKEN(1); /* force error */
3701 LOP(OP_SELECT,XTERM);
3707 LOP(OP_SEMCTL,XTERM);
3710 LOP(OP_SEMGET,XTERM);
3713 LOP(OP_SEMOP,XTERM);
3719 LOP(OP_SETPGRP,XTERM);
3721 case KEY_setpriority:
3722 LOP(OP_SETPRIORITY,XTERM);
3724 case KEY_sethostent:
3730 case KEY_setservent:
3733 case KEY_setprotoent:
3743 LOP(OP_SEEKDIR,XTERM);
3745 case KEY_setsockopt:
3746 LOP(OP_SSOCKOPT,XTERM);
3752 LOP(OP_SHMCTL,XTERM);
3755 LOP(OP_SHMGET,XTERM);
3758 LOP(OP_SHMREAD,XTERM);
3761 LOP(OP_SHMWRITE,XTERM);
3764 LOP(OP_SHUTDOWN,XTERM);
3773 LOP(OP_SOCKET,XTERM);
3775 case KEY_socketpair:
3776 LOP(OP_SOCKPAIR,XTERM);
3779 checkcomma(s,tokenbuf,"subroutine name");
3781 if (*s == ';' || *s == ')') /* probably a close */
3782 croak("sort is now a reserved word");
3784 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3788 LOP(OP_SPLIT,XTERM);
3791 LOP(OP_SPRINTF,XTERM);
3794 LOP(OP_SPLICE,XTERM);
3810 LOP(OP_SUBSTR,XTERM);
3817 if (isIDFIRST(*s) || *s == '\'' || *s == ':') {
3818 char tmpbuf[sizeof tokenbuf];
3820 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3821 if (strchr(tmpbuf, ':'))
3822 sv_setpv(subname, tmpbuf);
3824 sv_setsv(subname,curstname);
3825 sv_catpvn(subname,"::",2);
3826 sv_catpvn(subname,tmpbuf,len);
3828 s = force_word(s,WORD,FALSE,TRUE,TRUE);
3832 expect = XTERMBLOCK;
3833 sv_setpv(subname,"?");
3836 if (tmp == KEY_format) {
3839 lex_formbrack = lex_brackets + 1;
3843 /* Look for a prototype */
3850 SvREFCNT_dec(lex_stuff);
3852 croak("Prototype not terminated");
3855 d = SvPVX(lex_stuff);
3857 for (p = d; *p; ++p) {
3862 SvCUR(lex_stuff) = tmp;
3865 nextval[1] = nextval[0];
3866 nexttype[1] = nexttype[0];
3867 nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, lex_stuff);
3868 nexttype[0] = THING;
3869 if (nexttoke == 1) {
3870 lex_defer = lex_state;
3871 lex_expect = expect;
3872 lex_state = LEX_KNOWNEXT;
3877 if (*SvPV(subname,na) == '?') {
3878 sv_setpv(subname,"__ANON__");
3885 LOP(OP_SYSTEM,XREF);
3888 LOP(OP_SYMLINK,XTERM);
3891 LOP(OP_SYSCALL,XTERM);
3894 LOP(OP_SYSOPEN,XTERM);
3897 LOP(OP_SYSSEEK,XTERM);
3900 LOP(OP_SYSREAD,XTERM);
3903 LOP(OP_SYSWRITE,XTERM);
3907 TERM(sublex_start());
3928 LOP(OP_TRUNCATE,XTERM);
3940 yylval.ival = curcop->cop_line;
3944 yylval.ival = curcop->cop_line;
3948 LOP(OP_UNLINK,XTERM);
3954 LOP(OP_UNPACK,XTERM);
3957 LOP(OP_UTIME,XTERM);
3961 for (d = s; d < bufend && (isSPACE(*d) || *d == '('); d++) ;
3962 if (*d != '0' && isDIGIT(*d))
3963 yywarn("umask: argument is missing initial 0");
3968 LOP(OP_UNSHIFT,XTERM);
3971 if (expect != XSTATE)
3972 yyerror("\"use\" not allowed in expression");
3975 s = force_version(s);
3976 if(*s == ';' || (s = skipspace(s), *s == ';')) {
3977 nextval[nexttoke].opval = Nullop;
3982 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3983 s = force_version(s);
3996 yylval.ival = curcop->cop_line;
4000 hints |= HINT_BLOCK_SCOPE;
4007 LOP(OP_WAITPID,XTERM);
4013 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
4017 if (expect == XOPERATOR)
4023 yylval.ival = OP_XOR;
4028 TERM(sublex_start());
4034 keyword(register char *d, I32 len)
4039 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
4040 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
4041 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
4042 if (strEQ(d,"__DATA__")) return KEY___DATA__;
4043 if (strEQ(d,"__END__")) return KEY___END__;
4047 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
4052 if (strEQ(d,"and")) return -KEY_and;
4053 if (strEQ(d,"abs")) return -KEY_abs;
4056 if (strEQ(d,"alarm")) return -KEY_alarm;
4057 if (strEQ(d,"atan2")) return -KEY_atan2;
4060 if (strEQ(d,"accept")) return -KEY_accept;
4065 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
4068 if (strEQ(d,"bless")) return -KEY_bless;
4069 if (strEQ(d,"bind")) return -KEY_bind;
4070 if (strEQ(d,"binmode")) return -KEY_binmode;
4073 if (strEQ(d,"CORE")) return -KEY_CORE;
4078 if (strEQ(d,"cmp")) return -KEY_cmp;
4079 if (strEQ(d,"chr")) return -KEY_chr;
4080 if (strEQ(d,"cos")) return -KEY_cos;
4083 if (strEQ(d,"chop")) return KEY_chop;
4086 if (strEQ(d,"close")) return -KEY_close;
4087 if (strEQ(d,"chdir")) return -KEY_chdir;
4088 if (strEQ(d,"chomp")) return KEY_chomp;
4089 if (strEQ(d,"chmod")) return -KEY_chmod;
4090 if (strEQ(d,"chown")) return -KEY_chown;
4091 if (strEQ(d,"crypt")) return -KEY_crypt;
4094 if (strEQ(d,"chroot")) return -KEY_chroot;
4095 if (strEQ(d,"caller")) return -KEY_caller;
4098 if (strEQ(d,"connect")) return -KEY_connect;
4101 if (strEQ(d,"closedir")) return -KEY_closedir;
4102 if (strEQ(d,"continue")) return -KEY_continue;
4107 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
4112 if (strEQ(d,"do")) return KEY_do;
4115 if (strEQ(d,"die")) return -KEY_die;
4118 if (strEQ(d,"dump")) return -KEY_dump;
4121 if (strEQ(d,"delete")) return KEY_delete;
4124 if (strEQ(d,"defined")) return KEY_defined;
4125 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
4128 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
4133 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
4134 if (strEQ(d,"END")) return KEY_END;
4139 if (strEQ(d,"eq")) return -KEY_eq;
4142 if (strEQ(d,"eof")) return -KEY_eof;
4143 if (strEQ(d,"exp")) return -KEY_exp;
4146 if (strEQ(d,"else")) return KEY_else;
4147 if (strEQ(d,"exit")) return -KEY_exit;
4148 if (strEQ(d,"eval")) return KEY_eval;
4149 if (strEQ(d,"exec")) return -KEY_exec;
4150 if (strEQ(d,"each")) return KEY_each;
4153 if (strEQ(d,"elsif")) return KEY_elsif;
4156 if (strEQ(d,"exists")) return KEY_exists;
4157 if (strEQ(d,"elseif")) warn("elseif should be elsif");
4160 if (strEQ(d,"endgrent")) return -KEY_endgrent;
4161 if (strEQ(d,"endpwent")) return -KEY_endpwent;
4164 if (strEQ(d,"endnetent")) return -KEY_endnetent;
4167 if (strEQ(d,"endhostent")) return -KEY_endhostent;
4168 if (strEQ(d,"endservent")) return -KEY_endservent;
4171 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
4178 if (strEQ(d,"for")) return KEY_for;
4181 if (strEQ(d,"fork")) return -KEY_fork;
4184 if (strEQ(d,"fcntl")) return -KEY_fcntl;
4185 if (strEQ(d,"flock")) return -KEY_flock;
4188 if (strEQ(d,"format")) return KEY_format;
4189 if (strEQ(d,"fileno")) return -KEY_fileno;
4192 if (strEQ(d,"foreach")) return KEY_foreach;
4195 if (strEQ(d,"formline")) return -KEY_formline;
4201 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
4202 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
4206 if (strnEQ(d,"get",3)) {
4211 if (strEQ(d,"ppid")) return -KEY_getppid;
4212 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
4215 if (strEQ(d,"pwent")) return -KEY_getpwent;
4216 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
4217 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
4220 if (strEQ(d,"peername")) return -KEY_getpeername;
4221 if (strEQ(d,"protoent")) return -KEY_getprotoent;
4222 if (strEQ(d,"priority")) return -KEY_getpriority;
4225 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
4228 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
4232 else if (*d == 'h') {
4233 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
4234 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
4235 if (strEQ(d,"hostent")) return -KEY_gethostent;
4237 else if (*d == 'n') {
4238 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
4239 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
4240 if (strEQ(d,"netent")) return -KEY_getnetent;
4242 else if (*d == 's') {
4243 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
4244 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
4245 if (strEQ(d,"servent")) return -KEY_getservent;
4246 if (strEQ(d,"sockname")) return -KEY_getsockname;
4247 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
4249 else if (*d == 'g') {
4250 if (strEQ(d,"grent")) return -KEY_getgrent;
4251 if (strEQ(d,"grnam")) return -KEY_getgrnam;
4252 if (strEQ(d,"grgid")) return -KEY_getgrgid;
4254 else if (*d == 'l') {
4255 if (strEQ(d,"login")) return -KEY_getlogin;
4257 else if (strEQ(d,"c")) return -KEY_getc;
4262 if (strEQ(d,"gt")) return -KEY_gt;
4263 if (strEQ(d,"ge")) return -KEY_ge;
4266 if (strEQ(d,"grep")) return KEY_grep;
4267 if (strEQ(d,"goto")) return KEY_goto;
4268 if (strEQ(d,"glob")) return KEY_glob;
4271 if (strEQ(d,"gmtime")) return -KEY_gmtime;
4276 if (strEQ(d,"hex")) return -KEY_hex;
4279 if (strEQ(d,"INIT")) return KEY_INIT;
4284 if (strEQ(d,"if")) return KEY_if;
4287 if (strEQ(d,"int")) return -KEY_int;
4290 if (strEQ(d,"index")) return -KEY_index;
4291 if (strEQ(d,"ioctl")) return -KEY_ioctl;
4296 if (strEQ(d,"join")) return -KEY_join;
4300 if (strEQ(d,"keys")) return KEY_keys;
4301 if (strEQ(d,"kill")) return -KEY_kill;
4306 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
4307 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
4313 if (strEQ(d,"lt")) return -KEY_lt;
4314 if (strEQ(d,"le")) return -KEY_le;
4315 if (strEQ(d,"lc")) return -KEY_lc;
4318 if (strEQ(d,"log")) return -KEY_log;
4321 if (strEQ(d,"last")) return KEY_last;
4322 if (strEQ(d,"link")) return -KEY_link;
4323 if (strEQ(d,"lock")) return -KEY_lock;
4326 if (strEQ(d,"local")) return KEY_local;
4327 if (strEQ(d,"lstat")) return -KEY_lstat;
4330 if (strEQ(d,"length")) return -KEY_length;
4331 if (strEQ(d,"listen")) return -KEY_listen;
4334 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
4337 if (strEQ(d,"localtime")) return -KEY_localtime;
4343 case 1: return KEY_m;
4345 if (strEQ(d,"my")) return KEY_my;
4348 if (strEQ(d,"map")) return KEY_map;
4351 if (strEQ(d,"mkdir")) return -KEY_mkdir;
4354 if (strEQ(d,"msgctl")) return -KEY_msgctl;
4355 if (strEQ(d,"msgget")) return -KEY_msgget;
4356 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
4357 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
4362 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
4365 if (strEQ(d,"next")) return KEY_next;
4366 if (strEQ(d,"ne")) return -KEY_ne;
4367 if (strEQ(d,"not")) return -KEY_not;
4368 if (strEQ(d,"no")) return KEY_no;
4373 if (strEQ(d,"or")) return -KEY_or;
4376 if (strEQ(d,"ord")) return -KEY_ord;
4377 if (strEQ(d,"oct")) return -KEY_oct;
4380 if (strEQ(d,"open")) return -KEY_open;
4383 if (strEQ(d,"opendir")) return -KEY_opendir;
4390 if (strEQ(d,"pop")) return KEY_pop;
4391 if (strEQ(d,"pos")) return KEY_pos;
4394 if (strEQ(d,"push")) return KEY_push;
4395 if (strEQ(d,"pack")) return -KEY_pack;
4396 if (strEQ(d,"pipe")) return -KEY_pipe;
4399 if (strEQ(d,"print")) return KEY_print;
4402 if (strEQ(d,"printf")) return KEY_printf;
4405 if (strEQ(d,"package")) return KEY_package;
4408 if (strEQ(d,"prototype")) return KEY_prototype;
4413 if (strEQ(d,"q")) return KEY_q;
4414 if (strEQ(d,"qq")) return KEY_qq;
4415 if (strEQ(d,"qw")) return KEY_qw;
4416 if (strEQ(d,"qx")) return KEY_qx;
4418 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
4423 if (strEQ(d,"ref")) return -KEY_ref;
4426 if (strEQ(d,"read")) return -KEY_read;
4427 if (strEQ(d,"rand")) return -KEY_rand;
4428 if (strEQ(d,"recv")) return -KEY_recv;
4429 if (strEQ(d,"redo")) return KEY_redo;
4432 if (strEQ(d,"rmdir")) return -KEY_rmdir;
4433 if (strEQ(d,"reset")) return -KEY_reset;
4436 if (strEQ(d,"return")) return KEY_return;
4437 if (strEQ(d,"rename")) return -KEY_rename;
4438 if (strEQ(d,"rindex")) return -KEY_rindex;
4441 if (strEQ(d,"require")) return -KEY_require;
4442 if (strEQ(d,"reverse")) return -KEY_reverse;
4443 if (strEQ(d,"readdir")) return -KEY_readdir;
4446 if (strEQ(d,"readlink")) return -KEY_readlink;
4447 if (strEQ(d,"readline")) return -KEY_readline;
4448 if (strEQ(d,"readpipe")) return -KEY_readpipe;
4451 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
4457 case 0: return KEY_s;
4459 if (strEQ(d,"scalar")) return KEY_scalar;
4464 if (strEQ(d,"seek")) return -KEY_seek;
4465 if (strEQ(d,"send")) return -KEY_send;
4468 if (strEQ(d,"semop")) return -KEY_semop;
4471 if (strEQ(d,"select")) return -KEY_select;
4472 if (strEQ(d,"semctl")) return -KEY_semctl;
4473 if (strEQ(d,"semget")) return -KEY_semget;
4476 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
4477 if (strEQ(d,"seekdir")) return -KEY_seekdir;
4480 if (strEQ(d,"setpwent")) return -KEY_setpwent;
4481 if (strEQ(d,"setgrent")) return -KEY_setgrent;
4484 if (strEQ(d,"setnetent")) return -KEY_setnetent;
4487 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
4488 if (strEQ(d,"sethostent")) return -KEY_sethostent;
4489 if (strEQ(d,"setservent")) return -KEY_setservent;
4492 if (strEQ(d,"setpriority")) return -KEY_setpriority;
4493 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
4500 if (strEQ(d,"shift")) return KEY_shift;
4503 if (strEQ(d,"shmctl")) return -KEY_shmctl;
4504 if (strEQ(d,"shmget")) return -KEY_shmget;
4507 if (strEQ(d,"shmread")) return -KEY_shmread;
4510 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
4511 if (strEQ(d,"shutdown")) return -KEY_shutdown;
4516 if (strEQ(d,"sin")) return -KEY_sin;
4519 if (strEQ(d,"sleep")) return -KEY_sleep;
4522 if (strEQ(d,"sort")) return KEY_sort;
4523 if (strEQ(d,"socket")) return -KEY_socket;
4524 if (strEQ(d,"socketpair")) return -KEY_socketpair;
4527 if (strEQ(d,"split")) return KEY_split;
4528 if (strEQ(d,"sprintf")) return -KEY_sprintf;
4529 if (strEQ(d,"splice")) return KEY_splice;
4532 if (strEQ(d,"sqrt")) return -KEY_sqrt;
4535 if (strEQ(d,"srand")) return -KEY_srand;
4538 if (strEQ(d,"stat")) return -KEY_stat;
4539 if (strEQ(d,"study")) return KEY_study;
4542 if (strEQ(d,"substr")) return -KEY_substr;
4543 if (strEQ(d,"sub")) return KEY_sub;
4548 if (strEQ(d,"system")) return -KEY_system;
4551 if (strEQ(d,"symlink")) return -KEY_symlink;
4552 if (strEQ(d,"syscall")) return -KEY_syscall;
4553 if (strEQ(d,"sysopen")) return -KEY_sysopen;
4554 if (strEQ(d,"sysread")) return -KEY_sysread;
4555 if (strEQ(d,"sysseek")) return -KEY_sysseek;
4558 if (strEQ(d,"syswrite")) return -KEY_syswrite;
4567 if (strEQ(d,"tr")) return KEY_tr;
4570 if (strEQ(d,"tie")) return KEY_tie;
4573 if (strEQ(d,"tell")) return -KEY_tell;
4574 if (strEQ(d,"tied")) return KEY_tied;
4575 if (strEQ(d,"time")) return -KEY_time;
4578 if (strEQ(d,"times")) return -KEY_times;
4581 if (strEQ(d,"telldir")) return -KEY_telldir;
4584 if (strEQ(d,"truncate")) return -KEY_truncate;
4591 if (strEQ(d,"uc")) return -KEY_uc;
4594 if (strEQ(d,"use")) return KEY_use;
4597 if (strEQ(d,"undef")) return KEY_undef;
4598 if (strEQ(d,"until")) return KEY_until;
4599 if (strEQ(d,"untie")) return KEY_untie;
4600 if (strEQ(d,"utime")) return -KEY_utime;
4601 if (strEQ(d,"umask")) return -KEY_umask;
4604 if (strEQ(d,"unless")) return KEY_unless;
4605 if (strEQ(d,"unpack")) return -KEY_unpack;
4606 if (strEQ(d,"unlink")) return -KEY_unlink;
4609 if (strEQ(d,"unshift")) return KEY_unshift;
4610 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
4615 if (strEQ(d,"values")) return -KEY_values;
4616 if (strEQ(d,"vec")) return -KEY_vec;
4621 if (strEQ(d,"warn")) return -KEY_warn;
4622 if (strEQ(d,"wait")) return -KEY_wait;
4625 if (strEQ(d,"while")) return KEY_while;
4626 if (strEQ(d,"write")) return -KEY_write;
4629 if (strEQ(d,"waitpid")) return -KEY_waitpid;
4632 if (strEQ(d,"wantarray")) return -KEY_wantarray;
4637 if (len == 1) return -KEY_x;
4638 if (strEQ(d,"xor")) return -KEY_xor;
4641 if (len == 1) return KEY_y;
4650 checkcomma(register char *s, char *name, char *what)
4654 if (dowarn && *s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
4656 for (w = s+2; *w && level; w++) {
4663 for (; *w && isSPACE(*w); w++) ;
4664 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
4665 warn("%s (...) interpreted as function",name);
4667 while (s < bufend && isSPACE(*s))
4671 while (s < bufend && isSPACE(*s))
4673 if (isIDFIRST(*s)) {
4677 while (s < bufend && isSPACE(*s))
4682 kw = keyword(w, s - w) || perl_get_cv(w, FALSE) != 0;
4686 croak("No comma allowed after %s", what);
4692 scan_word(register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
4694 register char *d = dest;
4695 register char *e = d + destlen - 3; /* two-character token, ending NUL */
4698 croak(ident_too_long);
4701 else if (*s == '\'' && allow_package && isIDFIRST(s[1])) {
4706 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
4719 scan_ident(register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
4726 if (lex_brackets == 0)
4731 e = d + destlen - 3; /* two-character token, ending NUL */
4733 while (isDIGIT(*s)) {
4735 croak(ident_too_long);
4742 croak(ident_too_long);
4745 else if (*s == '\'' && isIDFIRST(s[1])) {
4750 else if (*s == ':' && s[1] == ':') {
4761 if (lex_state != LEX_NORMAL)
4762 lex_state = LEX_INTERPENDMAYBE;
4765 if (*s == '$' && s[1] &&
4766 (isALNUM(s[1]) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
4768 if (isDIGIT(s[1]) && lex_state == LEX_INTERPNORMAL)
4769 deprecate("\"$$<digit>\" to mean \"${$}<digit>\"");
4782 if (*d == '^' && *s && (isUPPER(*s) || strchr("[\\]^_?", *s))) {
4787 if (isSPACE(s[-1])) {
4790 if (ch != ' ' && ch != '\t') {
4796 if (isIDFIRST(*d)) {
4798 while (isALNUM(*s) || *s == ':')
4801 while (s < send && (*s == ' ' || *s == '\t')) s++;
4802 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
4803 if (dowarn && keyword(dest, d - dest)) {
4804 char *brack = *s == '[' ? "[...]" : "{...}";
4805 warn("Ambiguous use of %c{%s%s} resolved to %c%s%s",
4806 funny, dest, brack, funny, dest, brack);
4808 lex_fakebrack = lex_brackets+1;
4810 lex_brackstack[lex_brackets++] = XOPERATOR;
4816 if (lex_state == LEX_INTERPNORMAL && !lex_brackets)
4817 lex_state = LEX_INTERPEND;
4820 if (dowarn && lex_state == LEX_NORMAL &&
4821 (keyword(dest, d - dest) || perl_get_cv(dest, FALSE)))
4822 warn("Ambiguous use of %c{%s} resolved to %c%s",
4823 funny, dest, funny, dest);
4826 s = bracket; /* let the parser handle it */
4830 else if (lex_state == LEX_INTERPNORMAL && !lex_brackets && !intuit_more(s))
4831 lex_state = LEX_INTERPEND;
4835 void pmflag(U16 *pmfl, int ch)
4840 *pmfl |= PMf_GLOBAL;
4842 *pmfl |= PMf_CONTINUE;
4846 *pmfl |= PMf_MULTILINE;
4848 *pmfl |= PMf_SINGLELINE;
4850 *pmfl |= PMf_TAINTMEM;
4852 *pmfl |= PMf_EXTENDED;
4856 scan_pat(char *start)
4861 s = scan_str(start);
4864 SvREFCNT_dec(lex_stuff);
4866 croak("Search pattern not terminated");
4869 pm = (PMOP*)newPMOP(OP_MATCH, 0);
4870 if (multi_open == '?')
4871 pm->op_pmflags |= PMf_ONCE;
4872 while (*s && strchr("iogcmstx", *s))
4873 pmflag(&pm->op_pmflags,*s++);
4874 pm->op_pmpermflags = pm->op_pmflags;
4877 yylval.ival = OP_MATCH;
4882 scan_subst(char *start)
4889 yylval.ival = OP_NULL;
4891 s = scan_str(start);
4895 SvREFCNT_dec(lex_stuff);
4897 croak("Substitution pattern not terminated");
4900 if (s[-1] == multi_open)
4903 first_start = multi_start;
4907 SvREFCNT_dec(lex_stuff);
4910 SvREFCNT_dec(lex_repl);
4912 croak("Substitution replacement not terminated");
4914 multi_start = first_start; /* so whole substitution is taken together */
4916 pm = (PMOP*)newPMOP(OP_SUBST, 0);
4922 else if (strchr("iogcmstx", *s))
4923 pmflag(&pm->op_pmflags,*s++);
4930 pm->op_pmflags |= PMf_EVAL;
4931 repl = newSVpv("",0);
4933 sv_catpv(repl, es ? "eval " : "do ");
4934 sv_catpvn(repl, "{ ", 2);
4935 sv_catsv(repl, lex_repl);
4936 sv_catpvn(repl, " };", 2);
4937 SvCOMPILED_on(repl);
4938 SvREFCNT_dec(lex_repl);
4942 pm->op_pmpermflags = pm->op_pmflags;
4944 yylval.ival = OP_SUBST;
4949 scan_trans(char *start)
4958 yylval.ival = OP_NULL;
4960 s = scan_str(start);
4963 SvREFCNT_dec(lex_stuff);
4965 croak("Transliteration pattern not terminated");
4967 if (s[-1] == multi_open)
4973 SvREFCNT_dec(lex_stuff);
4976 SvREFCNT_dec(lex_repl);
4978 croak("Transliteration replacement not terminated");
4981 New(803,tbl,256,short);
4982 o = newPVOP(OP_TRANS, 0, (char*)tbl);
4984 complement = Delete = squash = 0;
4985 while (*s == 'c' || *s == 'd' || *s == 's') {
4987 complement = OPpTRANS_COMPLEMENT;
4989 Delete = OPpTRANS_DELETE;
4991 squash = OPpTRANS_SQUASH;
4994 o->op_private = Delete|squash|complement;
4997 yylval.ival = OP_TRANS;
5002 scan_heredoc(register char *s)
5006 I32 op_type = OP_SCALAR;
5013 int outer = (rsfp && !(lex_inwhat == OP_SCALAR));
5017 e = tokenbuf + sizeof tokenbuf - 1;
5020 for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5021 if (*peek && strchr("`'\"",*peek)) {
5024 s = delimcpy(d, e, s, bufend, term, &len);
5035 deprecate("bare << to mean <<\"\"");
5036 for (; isALNUM(*s); s++) {
5041 if (d >= tokenbuf + sizeof tokenbuf - 1)
5042 croak("Delimiter for here document is too long");
5047 if (outer || !(d=ninstr(s,bufend,d,d+1)))
5048 herewas = newSVpv(s,bufend-s);
5050 s--, herewas = newSVpv(s,d-s);
5051 s += SvCUR(herewas);
5053 tmpstr = NEWSV(87,80);
5054 sv_upgrade(tmpstr, SVt_PVIV);
5059 else if (term == '`') {
5060 op_type = OP_BACKTICK;
5061 SvIVX(tmpstr) = '\\';
5065 multi_start = curcop->cop_line;
5066 multi_open = multi_close = '<';
5070 while (s < bufend &&
5071 (*s != term || memNE(s,tokenbuf,len)) ) {
5076 curcop->cop_line = multi_start;
5077 missingterm(tokenbuf);
5079 sv_setpvn(tmpstr,d+1,s-d);
5081 curcop->cop_line++; /* the preceding stmt passes a newline */
5083 sv_catpvn(herewas,s,bufend-s);
5084 sv_setsv(linestr,herewas);
5085 oldoldbufptr = oldbufptr = bufptr = s = linestart = SvPVX(linestr);
5086 bufend = SvPVX(linestr) + SvCUR(linestr);
5089 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
5090 while (s >= bufend) { /* multiple line string? */
5092 !(oldoldbufptr = oldbufptr = s = linestart = filter_gets(linestr, rsfp, 0))) {
5093 curcop->cop_line = multi_start;
5094 missingterm(tokenbuf);
5097 if (PERLDB_LINE && curstash != debstash) {
5098 SV *sv = NEWSV(88,0);
5100 sv_upgrade(sv, SVt_PVMG);
5101 sv_setsv(sv,linestr);
5102 av_store(GvAV(curcop->cop_filegv),
5103 (I32)curcop->cop_line,sv);
5105 bufend = SvPVX(linestr) + SvCUR(linestr);
5106 if (*s == term && memEQ(s,tokenbuf,len)) {
5109 sv_catsv(linestr,herewas);
5110 bufend = SvPVX(linestr) + SvCUR(linestr);
5114 sv_catsv(tmpstr,linestr);
5117 multi_end = curcop->cop_line;
5119 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
5120 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
5121 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
5123 SvREFCNT_dec(herewas);
5125 yylval.ival = op_type;
5130 takes: current position in input buffer
5131 returns: new position in input buffer
5132 side-effects: yylval and lex_op are set.
5137 <FH> read from filehandle
5138 <pkg::FH> read from package qualified filehandle
5139 <pkg'FH> read from package qualified filehandle
5140 <$fh> read from filehandle in $fh
5146 scan_inputsymbol(char *start)
5148 register char *s = start; /* current position in buffer */
5153 d = tokenbuf; /* start of temp holding space */
5154 e = tokenbuf + sizeof tokenbuf; /* end of temp holding space */
5155 s = delimcpy(d, e, s + 1, bufend, '>', &len); /* extract until > */
5157 /* die if we didn't have space for the contents of the <>,
5161 if (len >= sizeof tokenbuf)
5162 croak("Excessively long <> operator");
5164 croak("Unterminated <> operator");
5169 Remember, only scalar variables are interpreted as filehandles by
5170 this code. Anything more complex (e.g., <$fh{$num}>) will be
5171 treated as a glob() call.
5172 This code makes use of the fact that except for the $ at the front,
5173 a scalar variable and a filehandle look the same.
5175 if (*d == '$' && d[1]) d++;
5177 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
5178 while (*d && (isALNUM(*d) || *d == '\'' || *d == ':'))
5181 /* If we've tried to read what we allow filehandles to look like, and
5182 there's still text left, then it must be a glob() and not a getline.
5183 Use scan_str to pull out the stuff between the <> and treat it
5184 as nothing more than a string.
5187 if (d - tokenbuf != len) {
5188 yylval.ival = OP_GLOB;
5190 s = scan_str(start);
5192 croak("Glob not terminated");
5196 /* we're in a filehandle read situation */
5199 /* turn <> into <ARGV> */
5201 (void)strcpy(d,"ARGV");
5203 /* if <$fh>, create the ops to turn the variable into a
5209 /* try to find it in the pad for this block, otherwise find
5210 add symbol table ops
5212 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
5213 OP *o = newOP(OP_PADSV, 0);
5215 lex_op = (OP*)newUNOP(OP_READLINE, 0, newUNOP(OP_RV2GV, 0, o));
5218 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
5219 lex_op = (OP*)newUNOP(OP_READLINE, 0,
5220 newUNOP(OP_RV2GV, 0,
5221 newUNOP(OP_RV2SV, 0,
5222 newGVOP(OP_GV, 0, gv))));
5224 /* we created the ops in lex_op, so make yylval.ival a null op */
5225 yylval.ival = OP_NULL;
5228 /* If it's none of the above, it must be a literal filehandle
5229 (<Foo::BAR> or <FOO>) so build a simple readline OP */
5231 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
5232 lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
5233 yylval.ival = OP_NULL;
5242 takes: start position in buffer
5243 returns: position to continue reading from buffer
5244 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
5245 updates the read buffer.
5247 This subroutine pulls a string out of the input. It is called for:
5248 q single quotes q(literal text)
5249 ' single quotes 'literal text'
5250 qq double quotes qq(interpolate $here please)
5251 " double quotes "interpolate $here please"
5252 qx backticks qx(/bin/ls -l)
5253 ` backticks `/bin/ls -l`
5254 qw quote words @EXPORT_OK = qw( func() $spam )
5255 m// regexp match m/this/
5256 s/// regexp substitute s/this/that/
5257 tr/// string transliterate tr/this/that/
5258 y/// string transliterate y/this/that/
5259 ($*@) sub prototypes sub foo ($)
5260 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
5262 In most of these cases (all but <>, patterns and transliterate)
5263 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
5264 calls scan_str(). s/// makes yylex() call scan_subst() which calls
5265 scan_str(). tr/// and y/// make yylex() call scan_trans() which
5268 It skips whitespace before the string starts, and treats the first
5269 character as the delimiter. If the delimiter is one of ([{< then
5270 the corresponding "close" character )]}> is used as the closing
5271 delimiter. It allows quoting of delimiters, and if the string has
5272 balanced delimiters ([{<>}]) it allows nesting.
5274 The lexer always reads these strings into lex_stuff, except in the
5275 case of the operators which take *two* arguments (s/// and tr///)
5276 when it checks to see if lex_stuff is full (presumably with the 1st
5277 arg to s or tr) and if so puts the string into lex_repl.
5282 scan_str(char *start)
5285 SV *sv; /* scalar value: string */
5286 char *tmps; /* temp string, used for delimiter matching */
5287 register char *s = start; /* current position in the buffer */
5288 register char term; /* terminating character */
5289 register char *to; /* current position in the sv's data */
5290 I32 brackets = 1; /* bracket nesting level */
5292 /* skip space before the delimiter */
5296 /* mark where we are, in case we need to report errors */
5299 /* after skipping whitespace, the next character is the terminator */
5301 /* mark where we are */
5302 multi_start = curcop->cop_line;
5305 /* find corresponding closing delimiter */
5306 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5310 /* create a new SV to hold the contents. 87 is leak category, I'm
5311 assuming. 80 is the SV's initial length. What a random number. */
5313 sv_upgrade(sv, SVt_PVIV);
5315 (void)SvPOK_only(sv); /* validate pointer */
5317 /* move past delimiter and try to read a complete string */
5320 /* extend sv if need be */
5321 SvGROW(sv, SvCUR(sv) + (bufend - s) + 1);
5322 /* set 'to' to the next character in the sv's string */
5323 to = SvPVX(sv)+SvCUR(sv);
5325 /* if open delimiter is the close delimiter read unbridle */
5326 if (multi_open == multi_close) {
5327 for (; s < bufend; s++,to++) {
5328 /* embedded newlines increment the current line number */
5329 if (*s == '\n' && !rsfp)
5331 /* handle quoted delimiters */
5332 if (*s == '\\' && s+1 < bufend && term != '\\') {
5335 /* any other quotes are simply copied straight through */
5339 /* terminate when run out of buffer (the for() condition), or
5340 have found the terminator */
5341 else if (*s == term)
5347 /* if the terminator isn't the same as the start character (e.g.,
5348 matched brackets), we have to allow more in the quoting, and
5349 be prepared for nested brackets.
5352 /* read until we run out of string, or we find the terminator */
5353 for (; s < bufend; s++,to++) {
5354 /* embedded newlines increment the line count */
5355 if (*s == '\n' && !rsfp)
5357 /* backslashes can escape the open or closing characters */
5358 if (*s == '\\' && s+1 < bufend) {
5359 if ((s[1] == multi_open) || (s[1] == multi_close))
5364 /* allow nested opens and closes */
5365 else if (*s == multi_close && --brackets <= 0)
5367 else if (*s == multi_open)
5372 /* terminate the copied string and update the sv's end-of-string */
5374 SvCUR_set(sv, to - SvPVX(sv));
5377 * this next chunk reads more into the buffer if we're not done yet
5380 if (s < bufend) break; /* handle case where we are done yet :-) */
5382 /* if we're out of file, or a read fails, bail and reset the current
5383 line marker so we can report where the unterminated string began
5386 !(oldoldbufptr = oldbufptr = s = linestart = filter_gets(linestr, rsfp, 0))) {
5388 curcop->cop_line = multi_start;
5391 /* we read a line, so increment our line counter */
5394 /* update debugger info */
5395 if (PERLDB_LINE && curstash != debstash) {
5396 SV *sv = NEWSV(88,0);
5398 sv_upgrade(sv, SVt_PVMG);
5399 sv_setsv(sv,linestr);
5400 av_store(GvAV(curcop->cop_filegv),
5401 (I32)curcop->cop_line, sv);
5404 /* having changed the buffer, we must update bufend */
5405 bufend = SvPVX(linestr) + SvCUR(linestr);
5408 /* at this point, we have successfully read the delimited string */
5410 multi_end = curcop->cop_line;
5413 /* if we allocated too much space, give some back */
5414 if (SvCUR(sv) + 5 < SvLEN(sv)) {
5415 SvLEN_set(sv, SvCUR(sv) + 1);
5416 Renew(SvPVX(sv), SvLEN(sv), char);
5419 /* decide whether this is the first or second quoted string we've read
5432 takes: pointer to position in buffer
5433 returns: pointer to new position in buffer
5434 side-effects: builds ops for the constant in yylval.op
5436 Read a number in any of the formats that Perl accepts:
5438 0(x[0-7A-F]+)|([0-7]+)
5439 [\d_]+(\.[\d_]*)?[Ee](\d+)
5441 Underbars (_) are allowed in decimal numbers. If -w is on,
5442 underbars before a decimal point must be at three digit intervals.
5444 Like most scan_ routines, it uses the tokenbuf buffer to hold the
5447 If it reads a number without a decimal point or an exponent, it will
5448 try converting the number to an integer and see if it can do so
5449 without loss of precision.
5453 scan_num(char *start)
5455 register char *s = start; /* current position in buffer */
5456 register char *d; /* destination in temp buffer */
5457 register char *e; /* end of temp buffer */
5458 I32 tryiv; /* used to see if it can be an int */
5459 double value; /* number read, as a double */
5460 SV *sv; /* place to put the converted number */
5461 I32 floatit; /* boolean: int or float? */
5462 char *lastub = 0; /* position of last underbar */
5463 static char number_too_long[] = "Number too long";
5465 /* We use the first character to decide what type of number this is */
5469 croak("panic: scan_num");
5471 /* if it starts with a 0, it could be an octal number, a decimal in
5472 0.13 disguise, or a hexadecimal number.
5477 u holds the "number so far"
5478 shift the power of 2 of the base (hex == 4, octal == 3)
5479 overflowed was the number more than we can hold?
5481 Shift is used when we add a digit. It also serves as an "are
5482 we in octal or hex?" indicator to disallow hex characters when
5487 bool overflowed = FALSE;
5494 /* check for a decimal in disguise */
5495 else if (s[1] == '.')
5497 /* so it must be octal */
5502 /* read the rest of the octal number */
5504 UV n, b; /* n is used in the overflow test, b is the digit we're adding on */
5508 /* if we don't mention it, we're done */
5517 /* 8 and 9 are not octal */
5520 yyerror("Illegal octal digit");
5524 case '0': case '1': case '2': case '3': case '4':
5525 case '5': case '6': case '7':
5526 b = *s++ & 15; /* ASCII digit -> value of digit */
5530 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
5531 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
5532 /* make sure they said 0x */
5537 /* Prepare to put the digit we have onto the end
5538 of the number so far. We check for overflows.
5542 n = u << shift; /* make room for the digit */
5543 if (!overflowed && (n >> shift) != u) {
5544 warn("Integer overflow in %s number",
5545 (shift == 4) ? "hex" : "octal");
5548 u = n | b; /* add the digit to the end */
5553 /* if we get here, we had success: make a scalar value from
5563 handle decimal numbers.
5564 we're also sent here when we read a 0 as the first digit
5566 case '1': case '2': case '3': case '4': case '5':
5567 case '6': case '7': case '8': case '9': case '.':
5570 e = tokenbuf + sizeof tokenbuf - 6; /* room for various punctuation */
5573 /* read next group of digits and _ and copy into d */
5574 while (isDIGIT(*s) || *s == '_') {
5575 /* skip underscores, checking for misplaced ones
5579 if (dowarn && lastub && s - lastub != 3)
5580 warn("Misplaced _ in number");
5584 /* check for end of fixed-length buffer */
5586 croak(number_too_long);
5587 /* if we're ok, copy the character */
5592 /* final misplaced underbar check */
5593 if (dowarn && lastub && s - lastub != 3)
5594 warn("Misplaced _ in number");
5596 /* read a decimal portion if there is one. avoid
5597 3..5 being interpreted as the number 3. followed
5600 if (*s == '.' && s[1] != '.') {
5604 /* copy, ignoring underbars, until we run out of
5605 digits. Note: no misplaced underbar checks!
5607 for (; isDIGIT(*s) || *s == '_'; s++) {
5608 /* fixed length buffer check */
5610 croak(number_too_long);
5616 /* read exponent part, if present */
5617 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
5621 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
5622 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
5624 /* allow positive or negative exponent */
5625 if (*s == '+' || *s == '-')
5628 /* read digits of exponent (no underbars :-) */
5629 while (isDIGIT(*s)) {
5631 croak(number_too_long);
5636 /* terminate the string */
5639 /* make an sv from the string */
5641 /* reset numeric locale in case we were earlier left in Swaziland */
5642 SET_NUMERIC_STANDARD();
5643 value = atof(tokenbuf);
5646 See if we can make do with an integer value without loss of
5647 precision. We use I_V to cast to an int, because some
5648 compilers have issues. Then we try casting it back and see
5649 if it was the same. We only do this if we know we
5650 specifically read an integer.
5652 Note: if floatit is true, then we don't need to do the
5656 if (!floatit && (double)tryiv == value)
5657 sv_setiv(sv, tryiv);
5659 sv_setnv(sv, value);
5663 /* make the op for the constant and return */
5665 yylval.opval = newSVOP(OP_CONST, 0, sv);
5671 scan_formline(register char *s)
5676 SV *stuff = newSVpv("",0);
5677 bool needargs = FALSE;
5680 if (*s == '.' || *s == '}') {
5682 for (t = s+1; *t == ' ' || *t == '\t'; t++) ;
5686 if (in_eval && !rsfp) {
5687 eol = strchr(s,'\n');
5692 eol = bufend = SvPVX(linestr) + SvCUR(linestr);
5694 for (t = s; t < eol; t++) {
5695 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
5697 goto enough; /* ~~ must be first line in formline */
5699 if (*t == '@' || *t == '^')
5702 sv_catpvn(stuff, s, eol-s);
5706 s = filter_gets(linestr, rsfp, 0);
5707 oldoldbufptr = oldbufptr = bufptr = linestart = SvPVX(linestr);
5708 bufend = bufptr + SvCUR(linestr);
5711 yyerror("Format not terminated");
5721 lex_state = LEX_NORMAL;
5722 nextval[nexttoke].ival = 0;
5726 lex_state = LEX_FORMLINE;
5727 nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
5729 nextval[nexttoke].ival = OP_FORMLINE;
5733 SvREFCNT_dec(stuff);
5745 cshlen = strlen(cshname);
5750 start_subparse(I32 is_format, U32 flags)
5753 I32 oldsavestack_ix = savestack_ix;
5754 CV* outsidecv = compcv;
5758 assert(SvTYPE(compcv) == SVt_PVCV);
5765 SAVESPTR(comppad_name);
5767 SAVEI32(comppad_name_fill);
5768 SAVEI32(min_intro_pending);
5769 SAVEI32(max_intro_pending);
5770 SAVEI32(pad_reset_pending);
5772 compcv = (CV*)NEWSV(1104,0);
5773 sv_upgrade((SV *)compcv, is_format ? SVt_PVFM : SVt_PVCV);
5774 CvFLAGS(compcv) |= flags;
5777 av_push(comppad, Nullsv);
5778 curpad = AvARRAY(comppad);
5779 comppad_name = newAV();
5780 comppad_name_fill = 0;
5781 min_intro_pending = 0;
5783 subline = curcop->cop_line;
5785 av_store(comppad_name, 0, newSVpv("@_", 2));
5786 curpad[0] = (SV*)newAV();
5787 SvPADMY_on(curpad[0]); /* XXX Needed? */
5788 CvOWNER(compcv) = 0;
5789 New(666, CvMUTEXP(compcv), 1, perl_mutex);
5790 MUTEX_INIT(CvMUTEXP(compcv));
5791 #endif /* USE_THREADS */
5793 comppadlist = newAV();
5794 AvREAL_off(comppadlist);
5795 av_store(comppadlist, 0, (SV*)comppad_name);
5796 av_store(comppadlist, 1, (SV*)comppad);
5798 CvPADLIST(compcv) = comppadlist;
5799 CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc(outsidecv);
5801 CvOWNER(compcv) = 0;
5802 New(666, CvMUTEXP(compcv), 1, perl_mutex);
5803 MUTEX_INIT(CvMUTEXP(compcv));
5804 #endif /* USE_THREADS */
5806 return oldsavestack_ix;
5825 char *context = NULL;
5829 if (!yychar || (yychar == ';' && !rsfp))
5831 else if (bufptr > oldoldbufptr && bufptr - oldoldbufptr < 200 &&
5832 oldoldbufptr != oldbufptr && oldbufptr != bufptr) {
5833 while (isSPACE(*oldoldbufptr))
5835 context = oldoldbufptr;
5836 contlen = bufptr - oldoldbufptr;
5838 else if (bufptr > oldbufptr && bufptr - oldbufptr < 200 &&
5839 oldbufptr != bufptr) {
5840 while (isSPACE(*oldbufptr))
5842 context = oldbufptr;
5843 contlen = bufptr - oldbufptr;
5845 else if (yychar > 255)
5846 where = "next token ???";
5847 else if ((yychar & 127) == 127) {
5848 if (lex_state == LEX_NORMAL ||
5849 (lex_state == LEX_KNOWNEXT && lex_defer == LEX_NORMAL))
5850 where = "at end of line";
5852 where = "within pattern";
5854 where = "within string";
5857 SV *where_sv = sv_2mortal(newSVpv("next char ", 0));
5859 sv_catpvf(where_sv, "^%c", toCTRL(yychar));
5860 else if (isPRINT_LC(yychar))
5861 sv_catpvf(where_sv, "%c", yychar);
5863 sv_catpvf(where_sv, "\\%03o", yychar & 255);
5864 where = SvPVX(where_sv);
5866 msg = sv_2mortal(newSVpv(s, 0));
5867 sv_catpvf(msg, " at %_ line %ld, ",
5868 GvSV(curcop->cop_filegv), (long)curcop->cop_line);
5870 sv_catpvf(msg, "near \"%.*s\"\n", contlen, context);
5872 sv_catpvf(msg, "%s\n", where);
5873 if (multi_start < multi_end && (U32)(curcop->cop_line - multi_end) <= 1) {
5875 " (Might be a runaway multi-line %c%c string starting on line %ld)\n",
5876 (int)multi_open,(int)multi_close,(long)multi_start);
5882 sv_catsv(ERRSV, msg);
5884 PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
5885 if (++error_count >= 10)
5886 croak("%_ has too many errors.\n", GvSV(curcop->cop_filegv));
5888 in_my_stash = Nullhv;