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)(PERL_OBJECT_THIS_ 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 OPERATOR(HASHBRACK);
2226 /* This hack serves to disambiguate a pair of curlies
2227 * as being a block or an anon hash. Normally, expectation
2228 * determines that, but in cases where we're not in a
2229 * position to expect anything in particular (like inside
2230 * eval"") we have to resolve the ambiguity. This code
2231 * covers the case where the first term in the curlies is a
2232 * quoted string. Most other cases need to be explicitly
2233 * disambiguated by prepending a `+' before the opening
2234 * curly in order to force resolution as an anon hash.
2236 * XXX should probably propagate the outer expectation
2237 * into eval"" to rely less on this hack, but that could
2238 * potentially break current behavior of eval"".
2242 if (*s == '\'' || *s == '"' || *s == '`') {
2243 /* common case: get past first string, handling escapes */
2244 for (t++; t < bufend && *t != *s;)
2245 if (*t++ == '\\' && (*t == '\\' || *t == *s))
2249 else if (*s == 'q') {
2252 || ((*t == 'q' || *t == 'x') && ++t < bufend
2253 && !isALNUM(*t)))) {
2255 char open, close, term;
2258 while (t < bufend && isSPACE(*t))
2262 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
2266 for (t++; t < bufend; t++) {
2267 if (*t == '\\' && t+1 < bufend && open != '\\')
2269 else if (*t == open)
2273 for (t++; t < bufend; t++) {
2274 if (*t == '\\' && t+1 < bufend)
2276 else if (*t == close && --brackets <= 0)
2278 else if (*t == open)
2284 else if (isALPHA(*s)) {
2285 for (t++; t < bufend && isALNUM(*t); t++) ;
2287 while (t < bufend && isSPACE(*t))
2289 /* if comma follows first term, call it an anon hash */
2290 /* XXX it could be a comma expression with loop modifiers */
2291 if (t < bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
2292 || (*t == '=' && t[1] == '>')))
2293 OPERATOR(HASHBRACK);
2297 lex_brackstack[lex_brackets-1] = XSTATE;
2303 yylval.ival = curcop->cop_line;
2304 if (isSPACE(*s) || *s == '#')
2305 copline = NOLINE; /* invalidate current command line number */
2310 if (lex_brackets <= 0)
2311 yyerror("Unmatched right bracket");
2313 expect = (expectation)lex_brackstack[--lex_brackets];
2314 if (lex_brackets < lex_formbrack)
2316 if (lex_state == LEX_INTERPNORMAL) {
2317 if (lex_brackets == 0) {
2318 if (lex_fakebrack) {
2319 lex_state = LEX_INTERPEND;
2321 return yylex(); /* ignore fake brackets */
2323 if (*s == '-' && s[1] == '>')
2324 lex_state = LEX_INTERPENDMAYBE;
2325 else if (*s != '[' && *s != '{')
2326 lex_state = LEX_INTERPEND;
2329 if (lex_brackets < lex_fakebrack) {
2332 return yylex(); /* ignore fake brackets */
2342 if (expect == XOPERATOR) {
2343 if (dowarn && isALPHA(*s) && bufptr == linestart) {
2351 s = scan_ident(s - 1, bufend, tokenbuf, sizeof tokenbuf, TRUE);
2354 force_ident(tokenbuf, '&');
2358 yylval.ival = (OPpENTERSUB_AMPER<<8);
2377 if (dowarn && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
2378 warn("Reversed %c= operator",(int)tmp);
2380 if (expect == XSTATE && isALPHA(tmp) &&
2381 (s == linestart+1 || s[-2] == '\n') )
2383 if (in_eval && !rsfp) {
2388 if (strnEQ(s,"=cut",4)) {
2405 if (lex_brackets < lex_formbrack) {
2407 for (t = s; *t == ' ' || *t == '\t'; t++) ;
2408 if (*t == '\n' || *t == '#') {
2426 if (expect != XOPERATOR) {
2427 if (s[1] != '<' && !strchr(s,'>'))
2430 s = scan_heredoc(s);
2432 s = scan_inputsymbol(s);
2433 TERM(sublex_start());
2438 SHop(OP_LEFT_SHIFT);
2452 SHop(OP_RIGHT_SHIFT);
2461 if (expect == XOPERATOR) {
2462 if (lex_formbrack && lex_brackets == lex_formbrack) {
2465 return ','; /* grandfather non-comma-format format */
2469 if (s[1] == '#' && (isALPHA(s[2]) || strchr("_{$:", s[2]))) {
2470 if (expect == XOPERATOR)
2471 no_op("Array length", bufptr);
2473 s = scan_ident(s + 1, bufend, tokenbuf + 1, sizeof tokenbuf - 1,
2478 pending_ident = '#';
2482 if (expect == XOPERATOR)
2483 no_op("Scalar", bufptr);
2485 s = scan_ident(s, bufend, tokenbuf + 1, sizeof tokenbuf - 1, FALSE);
2488 yyerror("Final $ should be \\$ or $name");
2492 /* This kludge not intended to be bulletproof. */
2493 if (tokenbuf[1] == '[' && !tokenbuf[2]) {
2494 yylval.opval = newSVOP(OP_CONST, 0,
2495 newSViv((IV)compiling.cop_arybase));
2496 yylval.opval->op_private = OPpCONST_ARYBASE;
2501 if (lex_state == LEX_NORMAL)
2504 if ((expect != XREF || oldoldbufptr == last_lop) && intuit_more(s)) {
2510 isSPACE(*t) || isALNUM(*t) || *t == '$';
2513 bufptr = skipspace(bufptr);
2514 while (t < bufend && *t != ']')
2516 warn("Multidimensional syntax %.*s not supported",
2517 (t - bufptr) + 1, bufptr);
2521 else if (*s == '{') {
2523 if (dowarn && strEQ(tokenbuf+1, "SIG") &&
2524 (t = strchr(s, '}')) && (t = strchr(t, '=')))
2526 char tmpbuf[sizeof tokenbuf];
2528 for (t++; isSPACE(*t); t++) ;
2529 if (isIDFIRST(*t)) {
2530 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
2531 if (*t != '(' && perl_get_cv(tmpbuf, FALSE))
2532 warn("You need to quote \"%s\"", tmpbuf);
2539 if (lex_state == LEX_NORMAL && isSPACE(*d)) {
2540 bool islop = (last_lop == oldoldbufptr);
2541 if (!islop || last_lop_op == OP_GREPSTART)
2543 else if (strchr("$@\"'`q", *s))
2544 expect = XTERM; /* e.g. print $fh "foo" */
2545 else if (strchr("&*<%", *s) && isIDFIRST(s[1]))
2546 expect = XTERM; /* e.g. print $fh &sub */
2547 else if (isIDFIRST(*s)) {
2548 char tmpbuf[sizeof tokenbuf];
2549 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2550 if (tmp = keyword(tmpbuf, len)) {
2551 /* binary operators exclude handle interpretations */
2563 expect = XTERM; /* e.g. print $fh length() */
2568 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
2569 if (gv && GvCVu(gv))
2570 expect = XTERM; /* e.g. print $fh subr() */
2573 else if (isDIGIT(*s))
2574 expect = XTERM; /* e.g. print $fh 3 */
2575 else if (*s == '.' && isDIGIT(s[1]))
2576 expect = XTERM; /* e.g. print $fh .3 */
2577 else if (strchr("/?-+", *s) && !isSPACE(s[1]))
2578 expect = XTERM; /* e.g. print $fh -1 */
2579 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]))
2580 expect = XTERM; /* print $fh <<"EOF" */
2582 pending_ident = '$';
2586 if (expect == XOPERATOR)
2589 s = scan_ident(s, bufend, tokenbuf + 1, sizeof tokenbuf - 1, FALSE);
2592 yyerror("Final @ should be \\@ or @name");
2595 if (lex_state == LEX_NORMAL)
2597 if ((expect != XREF || oldoldbufptr == last_lop) && intuit_more(s)) {
2601 /* Warn about @ where they meant $. */
2603 if (*s == '[' || *s == '{') {
2605 while (*t && (isALNUM(*t) || strchr(" \t$#+-'\"", *t)))
2607 if (*t == '}' || *t == ']') {
2609 bufptr = skipspace(bufptr);
2610 warn("Scalar value %.*s better written as $%.*s",
2611 t-bufptr, bufptr, t-bufptr-1, bufptr+1);
2616 pending_ident = '@';
2619 case '/': /* may either be division or pattern */
2620 case '?': /* may either be conditional or pattern */
2621 if (expect != XOPERATOR) {
2622 /* Disable warning on "study /blah/" */
2623 if (oldoldbufptr == last_uni
2624 && (*last_uni != 's' || s - last_uni < 5
2625 || memNE(last_uni, "study", 5) || isALNUM(last_uni[5])))
2628 TERM(sublex_start());
2636 if (lex_formbrack && lex_brackets == lex_formbrack && s[1] == '\n' &&
2637 (s == linestart || s[-1] == '\n') ) {
2642 if (expect == XOPERATOR || !isDIGIT(s[1])) {
2648 yylval.ival = OPf_SPECIAL;
2654 if (expect != XOPERATOR)
2659 case '0': case '1': case '2': case '3': case '4':
2660 case '5': case '6': case '7': case '8': case '9':
2662 if (expect == XOPERATOR)
2668 if (expect == XOPERATOR) {
2669 if (lex_formbrack && lex_brackets == lex_formbrack) {
2672 return ','; /* grandfather non-comma-format format */
2678 missingterm((char*)0);
2679 yylval.ival = OP_CONST;
2680 TERM(sublex_start());
2684 if (expect == XOPERATOR) {
2685 if (lex_formbrack && lex_brackets == lex_formbrack) {
2688 return ','; /* grandfather non-comma-format format */
2694 missingterm((char*)0);
2695 yylval.ival = OP_CONST;
2696 for (d = SvPV(lex_stuff, len); len; len--, d++) {
2697 if (*d == '$' || *d == '@' || *d == '\\') {
2698 yylval.ival = OP_STRINGIFY;
2702 TERM(sublex_start());
2706 if (expect == XOPERATOR)
2707 no_op("Backticks",s);
2709 missingterm((char*)0);
2710 yylval.ival = OP_BACKTICK;
2712 TERM(sublex_start());
2716 if (dowarn && lex_inwhat && isDIGIT(*s))
2717 warn("Can't use \\%c to mean $%c in expression", *s, *s);
2718 if (expect == XOPERATOR)
2719 no_op("Backslash",s);
2723 if (isDIGIT(s[1]) && expect == XOPERATOR) {
2762 s = scan_word(s, tokenbuf, sizeof tokenbuf, FALSE, &len);
2764 /* Some keywords can be followed by any delimiter, including ':' */
2765 tmp = (len == 1 && strchr("msyq", tokenbuf[0]) ||
2766 len == 2 && ((tokenbuf[0] == 't' && tokenbuf[1] == 'r') ||
2767 (tokenbuf[0] == 'q' &&
2768 strchr("qwx", tokenbuf[1]))));
2770 /* x::* is just a word, unless x is "CORE" */
2771 if (!tmp && *s == ':' && s[1] == ':' && strNE(tokenbuf, "CORE"))
2775 while (d < bufend && isSPACE(*d))
2776 d++; /* no comments skipped here, or s### is misparsed */
2778 /* Is this a label? */
2779 if (!tmp && expect == XSTATE
2780 && d < bufend && *d == ':' && *(d + 1) != ':') {
2782 yylval.pval = savepv(tokenbuf);
2787 /* Check for keywords */
2788 tmp = keyword(tokenbuf, len);
2790 /* Is this a word before a => operator? */
2791 if (strnEQ(d,"=>",2)) {
2793 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(tokenbuf,0));
2794 yylval.opval->op_private = OPpCONST_BARE;
2798 if (tmp < 0) { /* second-class keyword? */
2799 if (expect != XOPERATOR && (*s != ':' || s[1] != ':') &&
2800 (((gv = gv_fetchpv(tokenbuf, FALSE, SVt_PVCV)) &&
2801 GvCVu(gv) && GvIMPORTED_CV(gv)) ||
2802 ((gvp = (GV**)hv_fetch(globalstash,tokenbuf,len,FALSE)) &&
2803 (gv = *gvp) != (GV*)&sv_undef &&
2804 GvCVu(gv) && GvIMPORTED_CV(gv))))
2806 tmp = 0; /* overridden by importation */
2809 && -tmp==KEY_lock /* XXX generalizable kludge */
2810 && !hv_fetch(GvHVn(incgv), "Thread.pm", 9, FALSE))
2812 tmp = 0; /* any sub overrides "weak" keyword */
2815 tmp = -tmp; gv = Nullgv; gvp = 0;
2822 default: /* not a keyword */
2825 char lastchar = (bufptr == oldoldbufptr ? 0 : bufptr[-1]);
2827 /* Get the rest if it looks like a package qualifier */
2829 if (*s == '\'' || *s == ':' && s[1] == ':') {
2831 s = scan_word(s, tokenbuf + len, sizeof tokenbuf - len,
2834 croak("Bad name after %s%s", tokenbuf,
2835 *s == '\'' ? "'" : "::");
2839 if (expect == XOPERATOR) {
2840 if (bufptr == linestart) {
2846 no_op("Bareword",s);
2849 /* Look for a subroutine with this name in current package,
2850 unless name is "Foo::", in which case Foo is a bearword
2851 (and a package name). */
2854 tokenbuf[len - 2] == ':' && tokenbuf[len - 1] == ':')
2856 if (dowarn && ! gv_fetchpv(tokenbuf, FALSE, SVt_PVHV))
2857 warn("Bareword \"%s\" refers to nonexistent package",
2860 tokenbuf[len] = '\0';
2867 gv = gv_fetchpv(tokenbuf, FALSE, SVt_PVCV);
2870 /* if we saw a global override before, get the right name */
2873 sv = newSVpv("CORE::GLOBAL::",14);
2874 sv_catpv(sv,tokenbuf);
2877 sv = newSVpv(tokenbuf,0);
2879 /* Presume this is going to be a bareword of some sort. */
2882 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2883 yylval.opval->op_private = OPpCONST_BARE;
2885 /* And if "Foo::", then that's what it certainly is. */
2890 /* See if it's the indirect object for a list operator. */
2893 oldoldbufptr < bufptr &&
2894 (oldoldbufptr == last_lop || oldoldbufptr == last_uni) &&
2895 /* NO SKIPSPACE BEFORE HERE! */
2897 || ((opargs[last_lop_op] >> OASHIFT)& 7) == OA_FILEREF
2898 || (last_lop_op == OP_ENTERSUB
2900 && last_proto[last_proto[0] == ';' ? 1 : 0] == '*')) )
2902 bool immediate_paren = *s == '(';
2904 /* (Now we can afford to cross potential line boundary.) */
2907 /* Two barewords in a row may indicate method call. */
2909 if ((isALPHA(*s) || *s == '$') && (tmp=intuit_method(s,gv)))
2912 /* If not a declared subroutine, it's an indirect object. */
2913 /* (But it's an indir obj regardless for sort.) */
2915 if ((last_lop_op == OP_SORT ||
2916 (!immediate_paren && (!gv || !GvCVu(gv))) ) &&
2917 (last_lop_op != OP_MAPSTART && last_lop_op != OP_GREPSTART)){
2918 expect = (last_lop == oldoldbufptr) ? XTERM : XOPERATOR;
2923 /* If followed by a paren, it's certainly a subroutine. */
2929 if (gv && GvCVu(gv)) {
2930 for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
2931 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
2936 nextval[nexttoke].opval = yylval.opval;
2943 /* If followed by var or block, call it a method (unless sub) */
2945 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
2946 last_lop = oldbufptr;
2947 last_lop_op = OP_METHOD;
2951 /* If followed by a bareword, see if it looks like indir obj. */
2953 if ((isALPHA(*s) || *s == '$') && (tmp = intuit_method(s,gv)))
2956 /* Not a method, so call it a subroutine (if defined) */
2958 if (gv && GvCVu(gv)) {
2960 if (lastchar == '-')
2961 warn("Ambiguous use of -%s resolved as -&%s()",
2962 tokenbuf, tokenbuf);
2963 last_lop = oldbufptr;
2964 last_lop_op = OP_ENTERSUB;
2965 /* Check for a constant sub */
2967 if ((sv = cv_const_sv(cv))) {
2969 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
2970 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
2971 yylval.opval->op_private = 0;
2975 /* Resolve to GV now. */
2976 op_free(yylval.opval);
2977 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
2978 /* Is there a prototype? */
2981 last_proto = SvPV((SV*)cv, len);
2984 if (strEQ(last_proto, "$"))
2986 if (*last_proto == '&' && *s == '{') {
2987 sv_setpv(subname,"__ANON__");
2992 nextval[nexttoke].opval = yylval.opval;
2998 if (hints & HINT_STRICT_SUBS &&
3001 last_lop_op != OP_TRUNCATE && /* S/F prototype in opcode.pl */
3002 last_lop_op != OP_ACCEPT &&
3003 last_lop_op != OP_PIPE_OP &&
3004 last_lop_op != OP_SOCKPAIR)
3007 "Bareword \"%s\" not allowed while \"strict subs\" in use",
3012 /* Call it a bare word */
3016 if (lastchar != '-') {
3017 for (d = tokenbuf; *d && isLOWER(*d); d++) ;
3019 warn(warn_reserved, tokenbuf);
3024 if (lastchar && strchr("*%&", lastchar)) {
3025 warn("Operator or semicolon missing before %c%s",
3026 lastchar, tokenbuf);
3027 warn("Ambiguous use of %c resolved as operator %c",
3028 lastchar, lastchar);
3034 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3035 newSVsv(GvSV(curcop->cop_filegv)));
3039 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3040 newSVpvf("%ld", (long)curcop->cop_line));
3043 case KEY___PACKAGE__:
3044 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3046 ? newSVsv(curstname)
3055 if (rsfp && (!in_eval || tokenbuf[2] == 'D')) {
3056 char *pname = "main";
3057 if (tokenbuf[2] == 'D')
3058 pname = HvNAME(curstash ? curstash : defstash);
3059 gv = gv_fetchpv(form("%s::DATA", pname), TRUE, SVt_PVIO);
3062 GvIOp(gv) = newIO();
3063 IoIFP(GvIOp(gv)) = rsfp;
3064 #if defined(HAS_FCNTL) && defined(F_SETFD)
3066 int fd = PerlIO_fileno(rsfp);
3067 fcntl(fd,F_SETFD,fd >= 3);
3070 /* Mark this internal pseudo-handle as clean */
3071 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3073 IoTYPE(GvIOp(gv)) = '|';
3074 else if ((PerlIO*)rsfp == PerlIO_stdin())
3075 IoTYPE(GvIOp(gv)) = '-';
3077 IoTYPE(GvIOp(gv)) = '<';
3088 if (expect == XSTATE) {
3095 if (*s == ':' && s[1] == ':') {
3098 s = scan_word(s, tokenbuf, sizeof tokenbuf, FALSE, &len);
3099 tmp = keyword(tokenbuf, len);
3113 LOP(OP_ACCEPT,XTERM);
3119 LOP(OP_ATAN2,XTERM);
3128 LOP(OP_BLESS,XTERM);
3137 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
3157 LOP(OP_CRYPT,XTERM);
3161 for (d = s; d < bufend && (isSPACE(*d) || *d == '('); d++) ;
3162 if (*d != '0' && isDIGIT(*d))
3163 yywarn("chmod: mode argument is missing initial 0");
3165 LOP(OP_CHMOD,XTERM);
3168 LOP(OP_CHOWN,XTERM);
3171 LOP(OP_CONNECT,XTERM);
3187 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3191 hints |= HINT_BLOCK_SCOPE;
3201 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3202 LOP(OP_DBMOPEN,XTERM);
3208 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3215 yylval.ival = curcop->cop_line;
3229 expect = (*s == '{') ? XTERMBLOCK : XTERM;
3230 UNIBRACK(OP_ENTEREVAL);
3245 case KEY_endhostent:
3251 case KEY_endservent:
3254 case KEY_endprotoent:
3265 yylval.ival = curcop->cop_line;
3267 if (expect == XSTATE && isIDFIRST(*s)) {
3269 if ((bufend - p) >= 3 &&
3270 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3274 croak("Missing $ on loop variable");
3279 LOP(OP_FORMLINE,XTERM);
3285 LOP(OP_FCNTL,XTERM);
3291 LOP(OP_FLOCK,XTERM);
3300 LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
3303 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3318 case KEY_getpriority:
3319 LOP(OP_GETPRIORITY,XTERM);
3321 case KEY_getprotobyname:
3324 case KEY_getprotobynumber:
3325 LOP(OP_GPBYNUMBER,XTERM);
3327 case KEY_getprotoent:
3339 case KEY_getpeername:
3340 UNI(OP_GETPEERNAME);
3342 case KEY_gethostbyname:
3345 case KEY_gethostbyaddr:
3346 LOP(OP_GHBYADDR,XTERM);
3348 case KEY_gethostent:
3351 case KEY_getnetbyname:
3354 case KEY_getnetbyaddr:
3355 LOP(OP_GNBYADDR,XTERM);
3360 case KEY_getservbyname:
3361 LOP(OP_GSBYNAME,XTERM);
3363 case KEY_getservbyport:
3364 LOP(OP_GSBYPORT,XTERM);
3366 case KEY_getservent:
3369 case KEY_getsockname:
3370 UNI(OP_GETSOCKNAME);
3372 case KEY_getsockopt:
3373 LOP(OP_GSOCKOPT,XTERM);
3395 yylval.ival = curcop->cop_line;
3399 LOP(OP_INDEX,XTERM);
3405 LOP(OP_IOCTL,XTERM);
3417 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3448 LOP(OP_LISTEN,XTERM);
3458 TERM(sublex_start());
3461 LOP(OP_MAPSTART,XREF);
3464 LOP(OP_MKDIR,XTERM);
3467 LOP(OP_MSGCTL,XTERM);
3470 LOP(OP_MSGGET,XTERM);
3473 LOP(OP_MSGRCV,XTERM);
3476 LOP(OP_MSGSND,XTERM);
3481 if (isIDFIRST(*s)) {
3482 s = scan_word(s, tokenbuf, sizeof tokenbuf, TRUE, &len);
3483 in_my_stash = gv_stashpv(tokenbuf, FALSE);
3487 sprintf(tmpbuf, "No such class %.1000s", tokenbuf);
3494 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3501 if (expect != XSTATE)
3502 yyerror("\"no\" not allowed in expression");
3503 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3504 s = force_version(s);
3513 if (isIDFIRST(*s)) {
3515 for (d = s; isALNUM(*d); d++) ;
3517 if (strchr("|&*+-=!?:.", *t))
3518 warn("Precedence problem: open %.*s should be open(%.*s)",
3524 yylval.ival = OP_OR;
3534 LOP(OP_OPEN_DIR,XTERM);
3537 checkcomma(s,tokenbuf,"filehandle");
3541 checkcomma(s,tokenbuf,"filehandle");
3560 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3564 LOP(OP_PIPE_OP,XTERM);
3569 missingterm((char*)0);
3570 yylval.ival = OP_CONST;
3571 TERM(sublex_start());
3579 missingterm((char*)0);
3580 if (dowarn && SvLEN(lex_stuff)) {
3581 d = SvPV_force(lex_stuff, len);
3582 for (; len; --len, ++d) {
3584 warn("Possible attempt to separate words with commas");
3588 warn("Possible attempt to put comments in qw() list");
3594 nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, tokeq(lex_stuff));
3598 nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(" ",1));
3601 yylval.ival = OP_SPLIT;
3605 last_lop = oldbufptr;
3606 last_lop_op = OP_SPLIT;
3612 missingterm((char*)0);
3613 yylval.ival = OP_STRINGIFY;
3614 if (SvIVX(lex_stuff) == '\'')
3615 SvIVX(lex_stuff) = 0; /* qq'$foo' should intepolate */
3616 TERM(sublex_start());
3621 missingterm((char*)0);
3622 yylval.ival = OP_BACKTICK;
3624 TERM(sublex_start());
3631 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3632 if (isIDFIRST(*tokenbuf))
3633 gv_stashpvn(tokenbuf, strlen(tokenbuf), TRUE);
3635 yyerror("<> should be quotes");
3642 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3646 LOP(OP_RENAME,XTERM);
3655 LOP(OP_RINDEX,XTERM);
3678 LOP(OP_REVERSE,XTERM);
3689 TERM(sublex_start());
3691 TOKEN(1); /* force error */
3700 LOP(OP_SELECT,XTERM);
3706 LOP(OP_SEMCTL,XTERM);
3709 LOP(OP_SEMGET,XTERM);
3712 LOP(OP_SEMOP,XTERM);
3718 LOP(OP_SETPGRP,XTERM);
3720 case KEY_setpriority:
3721 LOP(OP_SETPRIORITY,XTERM);
3723 case KEY_sethostent:
3729 case KEY_setservent:
3732 case KEY_setprotoent:
3742 LOP(OP_SEEKDIR,XTERM);
3744 case KEY_setsockopt:
3745 LOP(OP_SSOCKOPT,XTERM);
3751 LOP(OP_SHMCTL,XTERM);
3754 LOP(OP_SHMGET,XTERM);
3757 LOP(OP_SHMREAD,XTERM);
3760 LOP(OP_SHMWRITE,XTERM);
3763 LOP(OP_SHUTDOWN,XTERM);
3772 LOP(OP_SOCKET,XTERM);
3774 case KEY_socketpair:
3775 LOP(OP_SOCKPAIR,XTERM);
3778 checkcomma(s,tokenbuf,"subroutine name");
3780 if (*s == ';' || *s == ')') /* probably a close */
3781 croak("sort is now a reserved word");
3783 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3787 LOP(OP_SPLIT,XTERM);
3790 LOP(OP_SPRINTF,XTERM);
3793 LOP(OP_SPLICE,XTERM);
3809 LOP(OP_SUBSTR,XTERM);
3816 if (isIDFIRST(*s) || *s == '\'' || *s == ':') {
3817 char tmpbuf[sizeof tokenbuf];
3819 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3820 if (strchr(tmpbuf, ':'))
3821 sv_setpv(subname, tmpbuf);
3823 sv_setsv(subname,curstname);
3824 sv_catpvn(subname,"::",2);
3825 sv_catpvn(subname,tmpbuf,len);
3827 s = force_word(s,WORD,FALSE,TRUE,TRUE);
3831 expect = XTERMBLOCK;
3832 sv_setpv(subname,"?");
3835 if (tmp == KEY_format) {
3838 lex_formbrack = lex_brackets + 1;
3842 /* Look for a prototype */
3849 SvREFCNT_dec(lex_stuff);
3851 croak("Prototype not terminated");
3854 d = SvPVX(lex_stuff);
3856 for (p = d; *p; ++p) {
3861 SvCUR(lex_stuff) = tmp;
3864 nextval[1] = nextval[0];
3865 nexttype[1] = nexttype[0];
3866 nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, lex_stuff);
3867 nexttype[0] = THING;
3868 if (nexttoke == 1) {
3869 lex_defer = lex_state;
3870 lex_expect = expect;
3871 lex_state = LEX_KNOWNEXT;
3876 if (*SvPV(subname,na) == '?') {
3877 sv_setpv(subname,"__ANON__");
3884 LOP(OP_SYSTEM,XREF);
3887 LOP(OP_SYMLINK,XTERM);
3890 LOP(OP_SYSCALL,XTERM);
3893 LOP(OP_SYSOPEN,XTERM);
3896 LOP(OP_SYSSEEK,XTERM);
3899 LOP(OP_SYSREAD,XTERM);
3902 LOP(OP_SYSWRITE,XTERM);
3906 TERM(sublex_start());
3927 LOP(OP_TRUNCATE,XTERM);
3939 yylval.ival = curcop->cop_line;
3943 yylval.ival = curcop->cop_line;
3947 LOP(OP_UNLINK,XTERM);
3953 LOP(OP_UNPACK,XTERM);
3956 LOP(OP_UTIME,XTERM);
3960 for (d = s; d < bufend && (isSPACE(*d) || *d == '('); d++) ;
3961 if (*d != '0' && isDIGIT(*d))
3962 yywarn("umask: argument is missing initial 0");
3967 LOP(OP_UNSHIFT,XTERM);
3970 if (expect != XSTATE)
3971 yyerror("\"use\" not allowed in expression");
3974 s = force_version(s);
3975 if(*s == ';' || (s = skipspace(s), *s == ';')) {
3976 nextval[nexttoke].opval = Nullop;
3981 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3982 s = force_version(s);
3995 yylval.ival = curcop->cop_line;
3999 hints |= HINT_BLOCK_SCOPE;
4006 LOP(OP_WAITPID,XTERM);
4012 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
4016 if (expect == XOPERATOR)
4022 yylval.ival = OP_XOR;
4027 TERM(sublex_start());
4033 keyword(register char *d, I32 len)
4038 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
4039 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
4040 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
4041 if (strEQ(d,"__DATA__")) return KEY___DATA__;
4042 if (strEQ(d,"__END__")) return KEY___END__;
4046 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
4051 if (strEQ(d,"and")) return -KEY_and;
4052 if (strEQ(d,"abs")) return -KEY_abs;
4055 if (strEQ(d,"alarm")) return -KEY_alarm;
4056 if (strEQ(d,"atan2")) return -KEY_atan2;
4059 if (strEQ(d,"accept")) return -KEY_accept;
4064 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
4067 if (strEQ(d,"bless")) return -KEY_bless;
4068 if (strEQ(d,"bind")) return -KEY_bind;
4069 if (strEQ(d,"binmode")) return -KEY_binmode;
4072 if (strEQ(d,"CORE")) return -KEY_CORE;
4077 if (strEQ(d,"cmp")) return -KEY_cmp;
4078 if (strEQ(d,"chr")) return -KEY_chr;
4079 if (strEQ(d,"cos")) return -KEY_cos;
4082 if (strEQ(d,"chop")) return KEY_chop;
4085 if (strEQ(d,"close")) return -KEY_close;
4086 if (strEQ(d,"chdir")) return -KEY_chdir;
4087 if (strEQ(d,"chomp")) return KEY_chomp;
4088 if (strEQ(d,"chmod")) return -KEY_chmod;
4089 if (strEQ(d,"chown")) return -KEY_chown;
4090 if (strEQ(d,"crypt")) return -KEY_crypt;
4093 if (strEQ(d,"chroot")) return -KEY_chroot;
4094 if (strEQ(d,"caller")) return -KEY_caller;
4097 if (strEQ(d,"connect")) return -KEY_connect;
4100 if (strEQ(d,"closedir")) return -KEY_closedir;
4101 if (strEQ(d,"continue")) return -KEY_continue;
4106 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
4111 if (strEQ(d,"do")) return KEY_do;
4114 if (strEQ(d,"die")) return -KEY_die;
4117 if (strEQ(d,"dump")) return -KEY_dump;
4120 if (strEQ(d,"delete")) return KEY_delete;
4123 if (strEQ(d,"defined")) return KEY_defined;
4124 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
4127 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
4132 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
4133 if (strEQ(d,"END")) return KEY_END;
4138 if (strEQ(d,"eq")) return -KEY_eq;
4141 if (strEQ(d,"eof")) return -KEY_eof;
4142 if (strEQ(d,"exp")) return -KEY_exp;
4145 if (strEQ(d,"else")) return KEY_else;
4146 if (strEQ(d,"exit")) return -KEY_exit;
4147 if (strEQ(d,"eval")) return KEY_eval;
4148 if (strEQ(d,"exec")) return -KEY_exec;
4149 if (strEQ(d,"each")) return KEY_each;
4152 if (strEQ(d,"elsif")) return KEY_elsif;
4155 if (strEQ(d,"exists")) return KEY_exists;
4156 if (strEQ(d,"elseif")) warn("elseif should be elsif");
4159 if (strEQ(d,"endgrent")) return -KEY_endgrent;
4160 if (strEQ(d,"endpwent")) return -KEY_endpwent;
4163 if (strEQ(d,"endnetent")) return -KEY_endnetent;
4166 if (strEQ(d,"endhostent")) return -KEY_endhostent;
4167 if (strEQ(d,"endservent")) return -KEY_endservent;
4170 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
4177 if (strEQ(d,"for")) return KEY_for;
4180 if (strEQ(d,"fork")) return -KEY_fork;
4183 if (strEQ(d,"fcntl")) return -KEY_fcntl;
4184 if (strEQ(d,"flock")) return -KEY_flock;
4187 if (strEQ(d,"format")) return KEY_format;
4188 if (strEQ(d,"fileno")) return -KEY_fileno;
4191 if (strEQ(d,"foreach")) return KEY_foreach;
4194 if (strEQ(d,"formline")) return -KEY_formline;
4200 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
4201 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
4205 if (strnEQ(d,"get",3)) {
4210 if (strEQ(d,"ppid")) return -KEY_getppid;
4211 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
4214 if (strEQ(d,"pwent")) return -KEY_getpwent;
4215 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
4216 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
4219 if (strEQ(d,"peername")) return -KEY_getpeername;
4220 if (strEQ(d,"protoent")) return -KEY_getprotoent;
4221 if (strEQ(d,"priority")) return -KEY_getpriority;
4224 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
4227 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
4231 else if (*d == 'h') {
4232 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
4233 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
4234 if (strEQ(d,"hostent")) return -KEY_gethostent;
4236 else if (*d == 'n') {
4237 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
4238 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
4239 if (strEQ(d,"netent")) return -KEY_getnetent;
4241 else if (*d == 's') {
4242 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
4243 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
4244 if (strEQ(d,"servent")) return -KEY_getservent;
4245 if (strEQ(d,"sockname")) return -KEY_getsockname;
4246 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
4248 else if (*d == 'g') {
4249 if (strEQ(d,"grent")) return -KEY_getgrent;
4250 if (strEQ(d,"grnam")) return -KEY_getgrnam;
4251 if (strEQ(d,"grgid")) return -KEY_getgrgid;
4253 else if (*d == 'l') {
4254 if (strEQ(d,"login")) return -KEY_getlogin;
4256 else if (strEQ(d,"c")) return -KEY_getc;
4261 if (strEQ(d,"gt")) return -KEY_gt;
4262 if (strEQ(d,"ge")) return -KEY_ge;
4265 if (strEQ(d,"grep")) return KEY_grep;
4266 if (strEQ(d,"goto")) return KEY_goto;
4267 if (strEQ(d,"glob")) return KEY_glob;
4270 if (strEQ(d,"gmtime")) return -KEY_gmtime;
4275 if (strEQ(d,"hex")) return -KEY_hex;
4278 if (strEQ(d,"INIT")) return KEY_INIT;
4283 if (strEQ(d,"if")) return KEY_if;
4286 if (strEQ(d,"int")) return -KEY_int;
4289 if (strEQ(d,"index")) return -KEY_index;
4290 if (strEQ(d,"ioctl")) return -KEY_ioctl;
4295 if (strEQ(d,"join")) return -KEY_join;
4299 if (strEQ(d,"keys")) return KEY_keys;
4300 if (strEQ(d,"kill")) return -KEY_kill;
4305 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
4306 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
4312 if (strEQ(d,"lt")) return -KEY_lt;
4313 if (strEQ(d,"le")) return -KEY_le;
4314 if (strEQ(d,"lc")) return -KEY_lc;
4317 if (strEQ(d,"log")) return -KEY_log;
4320 if (strEQ(d,"last")) return KEY_last;
4321 if (strEQ(d,"link")) return -KEY_link;
4322 if (strEQ(d,"lock")) return -KEY_lock;
4325 if (strEQ(d,"local")) return KEY_local;
4326 if (strEQ(d,"lstat")) return -KEY_lstat;
4329 if (strEQ(d,"length")) return -KEY_length;
4330 if (strEQ(d,"listen")) return -KEY_listen;
4333 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
4336 if (strEQ(d,"localtime")) return -KEY_localtime;
4342 case 1: return KEY_m;
4344 if (strEQ(d,"my")) return KEY_my;
4347 if (strEQ(d,"map")) return KEY_map;
4350 if (strEQ(d,"mkdir")) return -KEY_mkdir;
4353 if (strEQ(d,"msgctl")) return -KEY_msgctl;
4354 if (strEQ(d,"msgget")) return -KEY_msgget;
4355 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
4356 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
4361 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
4364 if (strEQ(d,"next")) return KEY_next;
4365 if (strEQ(d,"ne")) return -KEY_ne;
4366 if (strEQ(d,"not")) return -KEY_not;
4367 if (strEQ(d,"no")) return KEY_no;
4372 if (strEQ(d,"or")) return -KEY_or;
4375 if (strEQ(d,"ord")) return -KEY_ord;
4376 if (strEQ(d,"oct")) return -KEY_oct;
4379 if (strEQ(d,"open")) return -KEY_open;
4382 if (strEQ(d,"opendir")) return -KEY_opendir;
4389 if (strEQ(d,"pop")) return KEY_pop;
4390 if (strEQ(d,"pos")) return KEY_pos;
4393 if (strEQ(d,"push")) return KEY_push;
4394 if (strEQ(d,"pack")) return -KEY_pack;
4395 if (strEQ(d,"pipe")) return -KEY_pipe;
4398 if (strEQ(d,"print")) return KEY_print;
4401 if (strEQ(d,"printf")) return KEY_printf;
4404 if (strEQ(d,"package")) return KEY_package;
4407 if (strEQ(d,"prototype")) return KEY_prototype;
4412 if (strEQ(d,"q")) return KEY_q;
4413 if (strEQ(d,"qq")) return KEY_qq;
4414 if (strEQ(d,"qw")) return KEY_qw;
4415 if (strEQ(d,"qx")) return KEY_qx;
4417 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
4422 if (strEQ(d,"ref")) return -KEY_ref;
4425 if (strEQ(d,"read")) return -KEY_read;
4426 if (strEQ(d,"rand")) return -KEY_rand;
4427 if (strEQ(d,"recv")) return -KEY_recv;
4428 if (strEQ(d,"redo")) return KEY_redo;
4431 if (strEQ(d,"rmdir")) return -KEY_rmdir;
4432 if (strEQ(d,"reset")) return -KEY_reset;
4435 if (strEQ(d,"return")) return KEY_return;
4436 if (strEQ(d,"rename")) return -KEY_rename;
4437 if (strEQ(d,"rindex")) return -KEY_rindex;
4440 if (strEQ(d,"require")) return -KEY_require;
4441 if (strEQ(d,"reverse")) return -KEY_reverse;
4442 if (strEQ(d,"readdir")) return -KEY_readdir;
4445 if (strEQ(d,"readlink")) return -KEY_readlink;
4446 if (strEQ(d,"readline")) return -KEY_readline;
4447 if (strEQ(d,"readpipe")) return -KEY_readpipe;
4450 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
4456 case 0: return KEY_s;
4458 if (strEQ(d,"scalar")) return KEY_scalar;
4463 if (strEQ(d,"seek")) return -KEY_seek;
4464 if (strEQ(d,"send")) return -KEY_send;
4467 if (strEQ(d,"semop")) return -KEY_semop;
4470 if (strEQ(d,"select")) return -KEY_select;
4471 if (strEQ(d,"semctl")) return -KEY_semctl;
4472 if (strEQ(d,"semget")) return -KEY_semget;
4475 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
4476 if (strEQ(d,"seekdir")) return -KEY_seekdir;
4479 if (strEQ(d,"setpwent")) return -KEY_setpwent;
4480 if (strEQ(d,"setgrent")) return -KEY_setgrent;
4483 if (strEQ(d,"setnetent")) return -KEY_setnetent;
4486 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
4487 if (strEQ(d,"sethostent")) return -KEY_sethostent;
4488 if (strEQ(d,"setservent")) return -KEY_setservent;
4491 if (strEQ(d,"setpriority")) return -KEY_setpriority;
4492 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
4499 if (strEQ(d,"shift")) return KEY_shift;
4502 if (strEQ(d,"shmctl")) return -KEY_shmctl;
4503 if (strEQ(d,"shmget")) return -KEY_shmget;
4506 if (strEQ(d,"shmread")) return -KEY_shmread;
4509 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
4510 if (strEQ(d,"shutdown")) return -KEY_shutdown;
4515 if (strEQ(d,"sin")) return -KEY_sin;
4518 if (strEQ(d,"sleep")) return -KEY_sleep;
4521 if (strEQ(d,"sort")) return KEY_sort;
4522 if (strEQ(d,"socket")) return -KEY_socket;
4523 if (strEQ(d,"socketpair")) return -KEY_socketpair;
4526 if (strEQ(d,"split")) return KEY_split;
4527 if (strEQ(d,"sprintf")) return -KEY_sprintf;
4528 if (strEQ(d,"splice")) return KEY_splice;
4531 if (strEQ(d,"sqrt")) return -KEY_sqrt;
4534 if (strEQ(d,"srand")) return -KEY_srand;
4537 if (strEQ(d,"stat")) return -KEY_stat;
4538 if (strEQ(d,"study")) return KEY_study;
4541 if (strEQ(d,"substr")) return -KEY_substr;
4542 if (strEQ(d,"sub")) return KEY_sub;
4547 if (strEQ(d,"system")) return -KEY_system;
4550 if (strEQ(d,"symlink")) return -KEY_symlink;
4551 if (strEQ(d,"syscall")) return -KEY_syscall;
4552 if (strEQ(d,"sysopen")) return -KEY_sysopen;
4553 if (strEQ(d,"sysread")) return -KEY_sysread;
4554 if (strEQ(d,"sysseek")) return -KEY_sysseek;
4557 if (strEQ(d,"syswrite")) return -KEY_syswrite;
4566 if (strEQ(d,"tr")) return KEY_tr;
4569 if (strEQ(d,"tie")) return KEY_tie;
4572 if (strEQ(d,"tell")) return -KEY_tell;
4573 if (strEQ(d,"tied")) return KEY_tied;
4574 if (strEQ(d,"time")) return -KEY_time;
4577 if (strEQ(d,"times")) return -KEY_times;
4580 if (strEQ(d,"telldir")) return -KEY_telldir;
4583 if (strEQ(d,"truncate")) return -KEY_truncate;
4590 if (strEQ(d,"uc")) return -KEY_uc;
4593 if (strEQ(d,"use")) return KEY_use;
4596 if (strEQ(d,"undef")) return KEY_undef;
4597 if (strEQ(d,"until")) return KEY_until;
4598 if (strEQ(d,"untie")) return KEY_untie;
4599 if (strEQ(d,"utime")) return -KEY_utime;
4600 if (strEQ(d,"umask")) return -KEY_umask;
4603 if (strEQ(d,"unless")) return KEY_unless;
4604 if (strEQ(d,"unpack")) return -KEY_unpack;
4605 if (strEQ(d,"unlink")) return -KEY_unlink;
4608 if (strEQ(d,"unshift")) return KEY_unshift;
4609 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
4614 if (strEQ(d,"values")) return -KEY_values;
4615 if (strEQ(d,"vec")) return -KEY_vec;
4620 if (strEQ(d,"warn")) return -KEY_warn;
4621 if (strEQ(d,"wait")) return -KEY_wait;
4624 if (strEQ(d,"while")) return KEY_while;
4625 if (strEQ(d,"write")) return -KEY_write;
4628 if (strEQ(d,"waitpid")) return -KEY_waitpid;
4631 if (strEQ(d,"wantarray")) return -KEY_wantarray;
4636 if (len == 1) return -KEY_x;
4637 if (strEQ(d,"xor")) return -KEY_xor;
4640 if (len == 1) return KEY_y;
4649 checkcomma(register char *s, char *name, char *what)
4653 if (dowarn && *s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
4655 for (w = s+2; *w && level; w++) {
4662 for (; *w && isSPACE(*w); w++) ;
4663 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
4664 warn("%s (...) interpreted as function",name);
4666 while (s < bufend && isSPACE(*s))
4670 while (s < bufend && isSPACE(*s))
4672 if (isIDFIRST(*s)) {
4676 while (s < bufend && isSPACE(*s))
4681 kw = keyword(w, s - w) || perl_get_cv(w, FALSE) != 0;
4685 croak("No comma allowed after %s", what);
4691 scan_word(register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
4693 register char *d = dest;
4694 register char *e = d + destlen - 3; /* two-character token, ending NUL */
4697 croak(ident_too_long);
4700 else if (*s == '\'' && allow_package && isIDFIRST(s[1])) {
4705 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
4718 scan_ident(register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
4725 if (lex_brackets == 0)
4730 e = d + destlen - 3; /* two-character token, ending NUL */
4732 while (isDIGIT(*s)) {
4734 croak(ident_too_long);
4741 croak(ident_too_long);
4744 else if (*s == '\'' && isIDFIRST(s[1])) {
4749 else if (*s == ':' && s[1] == ':') {
4760 if (lex_state != LEX_NORMAL)
4761 lex_state = LEX_INTERPENDMAYBE;
4764 if (*s == '$' && s[1] &&
4765 (isALNUM(s[1]) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
4767 if (isDIGIT(s[1]) && lex_state == LEX_INTERPNORMAL)
4768 deprecate("\"$$<digit>\" to mean \"${$}<digit>\"");
4781 if (*d == '^' && *s && (isUPPER(*s) || strchr("[\\]^_?", *s))) {
4786 if (isSPACE(s[-1])) {
4789 if (ch != ' ' && ch != '\t') {
4795 if (isIDFIRST(*d)) {
4797 while (isALNUM(*s) || *s == ':')
4800 while (s < send && (*s == ' ' || *s == '\t')) s++;
4801 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
4802 if (dowarn && keyword(dest, d - dest)) {
4803 char *brack = *s == '[' ? "[...]" : "{...}";
4804 warn("Ambiguous use of %c{%s%s} resolved to %c%s%s",
4805 funny, dest, brack, funny, dest, brack);
4807 lex_fakebrack = lex_brackets+1;
4809 lex_brackstack[lex_brackets++] = XOPERATOR;
4815 if (lex_state == LEX_INTERPNORMAL && !lex_brackets)
4816 lex_state = LEX_INTERPEND;
4819 if (dowarn && lex_state == LEX_NORMAL &&
4820 (keyword(dest, d - dest) || perl_get_cv(dest, FALSE)))
4821 warn("Ambiguous use of %c{%s} resolved to %c%s",
4822 funny, dest, funny, dest);
4825 s = bracket; /* let the parser handle it */
4829 else if (lex_state == LEX_INTERPNORMAL && !lex_brackets && !intuit_more(s))
4830 lex_state = LEX_INTERPEND;
4834 void pmflag(U16 *pmfl, int ch)
4839 *pmfl |= PMf_GLOBAL;
4841 *pmfl |= PMf_CONTINUE;
4845 *pmfl |= PMf_MULTILINE;
4847 *pmfl |= PMf_SINGLELINE;
4849 *pmfl |= PMf_TAINTMEM;
4851 *pmfl |= PMf_EXTENDED;
4855 scan_pat(char *start)
4860 s = scan_str(start);
4863 SvREFCNT_dec(lex_stuff);
4865 croak("Search pattern not terminated");
4868 pm = (PMOP*)newPMOP(OP_MATCH, 0);
4869 if (multi_open == '?')
4870 pm->op_pmflags |= PMf_ONCE;
4871 while (*s && strchr("iogcmstx", *s))
4872 pmflag(&pm->op_pmflags,*s++);
4873 pm->op_pmpermflags = pm->op_pmflags;
4876 yylval.ival = OP_MATCH;
4881 scan_subst(char *start)
4888 yylval.ival = OP_NULL;
4890 s = scan_str(start);
4894 SvREFCNT_dec(lex_stuff);
4896 croak("Substitution pattern not terminated");
4899 if (s[-1] == multi_open)
4902 first_start = multi_start;
4906 SvREFCNT_dec(lex_stuff);
4909 SvREFCNT_dec(lex_repl);
4911 croak("Substitution replacement not terminated");
4913 multi_start = first_start; /* so whole substitution is taken together */
4915 pm = (PMOP*)newPMOP(OP_SUBST, 0);
4921 else if (strchr("iogcmstx", *s))
4922 pmflag(&pm->op_pmflags,*s++);
4929 pm->op_pmflags |= PMf_EVAL;
4930 repl = newSVpv("",0);
4932 sv_catpv(repl, es ? "eval " : "do ");
4933 sv_catpvn(repl, "{ ", 2);
4934 sv_catsv(repl, lex_repl);
4935 sv_catpvn(repl, " };", 2);
4936 SvCOMPILED_on(repl);
4937 SvREFCNT_dec(lex_repl);
4941 pm->op_pmpermflags = pm->op_pmflags;
4943 yylval.ival = OP_SUBST;
4948 scan_trans(char *start)
4957 yylval.ival = OP_NULL;
4959 s = scan_str(start);
4962 SvREFCNT_dec(lex_stuff);
4964 croak("Transliteration pattern not terminated");
4966 if (s[-1] == multi_open)
4972 SvREFCNT_dec(lex_stuff);
4975 SvREFCNT_dec(lex_repl);
4977 croak("Transliteration replacement not terminated");
4980 New(803,tbl,256,short);
4981 o = newPVOP(OP_TRANS, 0, (char*)tbl);
4983 complement = Delete = squash = 0;
4984 while (*s == 'c' || *s == 'd' || *s == 's') {
4986 complement = OPpTRANS_COMPLEMENT;
4988 Delete = OPpTRANS_DELETE;
4990 squash = OPpTRANS_SQUASH;
4993 o->op_private = Delete|squash|complement;
4996 yylval.ival = OP_TRANS;
5001 scan_heredoc(register char *s)
5005 I32 op_type = OP_SCALAR;
5012 int outer = (rsfp && !(lex_inwhat == OP_SCALAR));
5016 e = tokenbuf + sizeof tokenbuf - 1;
5019 for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5020 if (*peek && strchr("`'\"",*peek)) {
5023 s = delimcpy(d, e, s, bufend, term, &len);
5034 deprecate("bare << to mean <<\"\"");
5035 for (; isALNUM(*s); s++) {
5040 if (d >= tokenbuf + sizeof tokenbuf - 1)
5041 croak("Delimiter for here document is too long");
5046 if (outer || !(d=ninstr(s,bufend,d,d+1)))
5047 herewas = newSVpv(s,bufend-s);
5049 s--, herewas = newSVpv(s,d-s);
5050 s += SvCUR(herewas);
5052 tmpstr = NEWSV(87,79);
5053 sv_upgrade(tmpstr, SVt_PVIV);
5058 else if (term == '`') {
5059 op_type = OP_BACKTICK;
5060 SvIVX(tmpstr) = '\\';
5064 multi_start = curcop->cop_line;
5065 multi_open = multi_close = '<';
5069 while (s < bufend &&
5070 (*s != term || memNE(s,tokenbuf,len)) ) {
5075 curcop->cop_line = multi_start;
5076 missingterm(tokenbuf);
5078 sv_setpvn(tmpstr,d+1,s-d);
5080 curcop->cop_line++; /* the preceding stmt passes a newline */
5082 sv_catpvn(herewas,s,bufend-s);
5083 sv_setsv(linestr,herewas);
5084 oldoldbufptr = oldbufptr = bufptr = s = linestart = SvPVX(linestr);
5085 bufend = SvPVX(linestr) + SvCUR(linestr);
5088 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
5089 while (s >= bufend) { /* multiple line string? */
5091 !(oldoldbufptr = oldbufptr = s = linestart = filter_gets(linestr, rsfp, 0))) {
5092 curcop->cop_line = multi_start;
5093 missingterm(tokenbuf);
5096 if (PERLDB_LINE && curstash != debstash) {
5097 SV *sv = NEWSV(88,0);
5099 sv_upgrade(sv, SVt_PVMG);
5100 sv_setsv(sv,linestr);
5101 av_store(GvAV(curcop->cop_filegv),
5102 (I32)curcop->cop_line,sv);
5104 bufend = SvPVX(linestr) + SvCUR(linestr);
5105 if (*s == term && memEQ(s,tokenbuf,len)) {
5108 sv_catsv(linestr,herewas);
5109 bufend = SvPVX(linestr) + SvCUR(linestr);
5113 sv_catsv(tmpstr,linestr);
5116 multi_end = curcop->cop_line;
5118 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
5119 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
5120 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
5122 SvREFCNT_dec(herewas);
5124 yylval.ival = op_type;
5129 takes: current position in input buffer
5130 returns: new position in input buffer
5131 side-effects: yylval and lex_op are set.
5136 <FH> read from filehandle
5137 <pkg::FH> read from package qualified filehandle
5138 <pkg'FH> read from package qualified filehandle
5139 <$fh> read from filehandle in $fh
5145 scan_inputsymbol(char *start)
5147 register char *s = start; /* current position in buffer */
5152 d = tokenbuf; /* start of temp holding space */
5153 e = tokenbuf + sizeof tokenbuf; /* end of temp holding space */
5154 s = delimcpy(d, e, s + 1, bufend, '>', &len); /* extract until > */
5156 /* die if we didn't have space for the contents of the <>,
5160 if (len >= sizeof tokenbuf)
5161 croak("Excessively long <> operator");
5163 croak("Unterminated <> operator");
5168 Remember, only scalar variables are interpreted as filehandles by
5169 this code. Anything more complex (e.g., <$fh{$num}>) will be
5170 treated as a glob() call.
5171 This code makes use of the fact that except for the $ at the front,
5172 a scalar variable and a filehandle look the same.
5174 if (*d == '$' && d[1]) d++;
5176 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
5177 while (*d && (isALNUM(*d) || *d == '\'' || *d == ':'))
5180 /* If we've tried to read what we allow filehandles to look like, and
5181 there's still text left, then it must be a glob() and not a getline.
5182 Use scan_str to pull out the stuff between the <> and treat it
5183 as nothing more than a string.
5186 if (d - tokenbuf != len) {
5187 yylval.ival = OP_GLOB;
5189 s = scan_str(start);
5191 croak("Glob not terminated");
5195 /* we're in a filehandle read situation */
5198 /* turn <> into <ARGV> */
5200 (void)strcpy(d,"ARGV");
5202 /* if <$fh>, create the ops to turn the variable into a
5208 /* try to find it in the pad for this block, otherwise find
5209 add symbol table ops
5211 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
5212 OP *o = newOP(OP_PADSV, 0);
5214 lex_op = (OP*)newUNOP(OP_READLINE, 0, newUNOP(OP_RV2GV, 0, o));
5217 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
5218 lex_op = (OP*)newUNOP(OP_READLINE, 0,
5219 newUNOP(OP_RV2GV, 0,
5220 newUNOP(OP_RV2SV, 0,
5221 newGVOP(OP_GV, 0, gv))));
5223 /* we created the ops in lex_op, so make yylval.ival a null op */
5224 yylval.ival = OP_NULL;
5227 /* If it's none of the above, it must be a literal filehandle
5228 (<Foo::BAR> or <FOO>) so build a simple readline OP */
5230 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
5231 lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
5232 yylval.ival = OP_NULL;
5241 takes: start position in buffer
5242 returns: position to continue reading from buffer
5243 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
5244 updates the read buffer.
5246 This subroutine pulls a string out of the input. It is called for:
5247 q single quotes q(literal text)
5248 ' single quotes 'literal text'
5249 qq double quotes qq(interpolate $here please)
5250 " double quotes "interpolate $here please"
5251 qx backticks qx(/bin/ls -l)
5252 ` backticks `/bin/ls -l`
5253 qw quote words @EXPORT_OK = qw( func() $spam )
5254 m// regexp match m/this/
5255 s/// regexp substitute s/this/that/
5256 tr/// string transliterate tr/this/that/
5257 y/// string transliterate y/this/that/
5258 ($*@) sub prototypes sub foo ($)
5259 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
5261 In most of these cases (all but <>, patterns and transliterate)
5262 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
5263 calls scan_str(). s/// makes yylex() call scan_subst() which calls
5264 scan_str(). tr/// and y/// make yylex() call scan_trans() which
5267 It skips whitespace before the string starts, and treats the first
5268 character as the delimiter. If the delimiter is one of ([{< then
5269 the corresponding "close" character )]}> is used as the closing
5270 delimiter. It allows quoting of delimiters, and if the string has
5271 balanced delimiters ([{<>}]) it allows nesting.
5273 The lexer always reads these strings into lex_stuff, except in the
5274 case of the operators which take *two* arguments (s/// and tr///)
5275 when it checks to see if lex_stuff is full (presumably with the 1st
5276 arg to s or tr) and if so puts the string into lex_repl.
5281 scan_str(char *start)
5284 SV *sv; /* scalar value: string */
5285 char *tmps; /* temp string, used for delimiter matching */
5286 register char *s = start; /* current position in the buffer */
5287 register char term; /* terminating character */
5288 register char *to; /* current position in the sv's data */
5289 I32 brackets = 1; /* bracket nesting level */
5291 /* skip space before the delimiter */
5295 /* mark where we are, in case we need to report errors */
5298 /* after skipping whitespace, the next character is the terminator */
5300 /* mark where we are */
5301 multi_start = curcop->cop_line;
5304 /* find corresponding closing delimiter */
5305 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5309 /* create a new SV to hold the contents. 87 is leak category, I'm
5310 assuming. 79 is the SV's initial length. What a random number. */
5312 sv_upgrade(sv, SVt_PVIV);
5314 (void)SvPOK_only(sv); /* validate pointer */
5316 /* move past delimiter and try to read a complete string */
5319 /* extend sv if need be */
5320 SvGROW(sv, SvCUR(sv) + (bufend - s) + 1);
5321 /* set 'to' to the next character in the sv's string */
5322 to = SvPVX(sv)+SvCUR(sv);
5324 /* if open delimiter is the close delimiter read unbridle */
5325 if (multi_open == multi_close) {
5326 for (; s < bufend; s++,to++) {
5327 /* embedded newlines increment the current line number */
5328 if (*s == '\n' && !rsfp)
5330 /* handle quoted delimiters */
5331 if (*s == '\\' && s+1 < bufend && term != '\\') {
5334 /* any other quotes are simply copied straight through */
5338 /* terminate when run out of buffer (the for() condition), or
5339 have found the terminator */
5340 else if (*s == term)
5346 /* if the terminator isn't the same as the start character (e.g.,
5347 matched brackets), we have to allow more in the quoting, and
5348 be prepared for nested brackets.
5351 /* read until we run out of string, or we find the terminator */
5352 for (; s < bufend; s++,to++) {
5353 /* embedded newlines increment the line count */
5354 if (*s == '\n' && !rsfp)
5356 /* backslashes can escape the open or closing characters */
5357 if (*s == '\\' && s+1 < bufend) {
5358 if ((s[1] == multi_open) || (s[1] == multi_close))
5363 /* allow nested opens and closes */
5364 else if (*s == multi_close && --brackets <= 0)
5366 else if (*s == multi_open)
5371 /* terminate the copied string and update the sv's end-of-string */
5373 SvCUR_set(sv, to - SvPVX(sv));
5376 * this next chunk reads more into the buffer if we're not done yet
5379 if (s < bufend) break; /* handle case where we are done yet :-) */
5381 /* if we're out of file, or a read fails, bail and reset the current
5382 line marker so we can report where the unterminated string began
5385 !(oldoldbufptr = oldbufptr = s = linestart = filter_gets(linestr, rsfp, 0))) {
5387 curcop->cop_line = multi_start;
5390 /* we read a line, so increment our line counter */
5393 /* update debugger info */
5394 if (PERLDB_LINE && curstash != debstash) {
5395 SV *sv = NEWSV(88,0);
5397 sv_upgrade(sv, SVt_PVMG);
5398 sv_setsv(sv,linestr);
5399 av_store(GvAV(curcop->cop_filegv),
5400 (I32)curcop->cop_line, sv);
5403 /* having changed the buffer, we must update bufend */
5404 bufend = SvPVX(linestr) + SvCUR(linestr);
5407 /* at this point, we have successfully read the delimited string */
5409 multi_end = curcop->cop_line;
5412 /* if we allocated too much space, give some back */
5413 if (SvCUR(sv) + 5 < SvLEN(sv)) {
5414 SvLEN_set(sv, SvCUR(sv) + 1);
5415 Renew(SvPVX(sv), SvLEN(sv), char);
5418 /* decide whether this is the first or second quoted string we've read
5431 takes: pointer to position in buffer
5432 returns: pointer to new position in buffer
5433 side-effects: builds ops for the constant in yylval.op
5435 Read a number in any of the formats that Perl accepts:
5437 0(x[0-7A-F]+)|([0-7]+)
5438 [\d_]+(\.[\d_]*)?[Ee](\d+)
5440 Underbars (_) are allowed in decimal numbers. If -w is on,
5441 underbars before a decimal point must be at three digit intervals.
5443 Like most scan_ routines, it uses the tokenbuf buffer to hold the
5446 If it reads a number without a decimal point or an exponent, it will
5447 try converting the number to an integer and see if it can do so
5448 without loss of precision.
5452 scan_num(char *start)
5454 register char *s = start; /* current position in buffer */
5455 register char *d; /* destination in temp buffer */
5456 register char *e; /* end of temp buffer */
5457 I32 tryiv; /* used to see if it can be an int */
5458 double value; /* number read, as a double */
5459 SV *sv; /* place to put the converted number */
5460 I32 floatit; /* boolean: int or float? */
5461 char *lastub = 0; /* position of last underbar */
5462 static char number_too_long[] = "Number too long";
5464 /* We use the first character to decide what type of number this is */
5468 croak("panic: scan_num");
5470 /* if it starts with a 0, it could be an octal number, a decimal in
5471 0.13 disguise, or a hexadecimal number.
5476 u holds the "number so far"
5477 shift the power of 2 of the base (hex == 4, octal == 3)
5478 overflowed was the number more than we can hold?
5480 Shift is used when we add a digit. It also serves as an "are
5481 we in octal or hex?" indicator to disallow hex characters when
5486 bool overflowed = FALSE;
5493 /* check for a decimal in disguise */
5494 else if (s[1] == '.')
5496 /* so it must be octal */
5501 /* read the rest of the octal number */
5503 UV n, b; /* n is used in the overflow test, b is the digit we're adding on */
5507 /* if we don't mention it, we're done */
5516 /* 8 and 9 are not octal */
5519 yyerror("Illegal octal digit");
5523 case '0': case '1': case '2': case '3': case '4':
5524 case '5': case '6': case '7':
5525 b = *s++ & 15; /* ASCII digit -> value of digit */
5529 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
5530 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
5531 /* make sure they said 0x */
5536 /* Prepare to put the digit we have onto the end
5537 of the number so far. We check for overflows.
5541 n = u << shift; /* make room for the digit */
5542 if (!overflowed && (n >> shift) != u) {
5543 warn("Integer overflow in %s number",
5544 (shift == 4) ? "hex" : "octal");
5547 u = n | b; /* add the digit to the end */
5552 /* if we get here, we had success: make a scalar value from
5562 handle decimal numbers.
5563 we're also sent here when we read a 0 as the first digit
5565 case '1': case '2': case '3': case '4': case '5':
5566 case '6': case '7': case '8': case '9': case '.':
5569 e = tokenbuf + sizeof tokenbuf - 6; /* room for various punctuation */
5572 /* read next group of digits and _ and copy into d */
5573 while (isDIGIT(*s) || *s == '_') {
5574 /* skip underscores, checking for misplaced ones
5578 if (dowarn && lastub && s - lastub != 3)
5579 warn("Misplaced _ in number");
5583 /* check for end of fixed-length buffer */
5585 croak(number_too_long);
5586 /* if we're ok, copy the character */
5591 /* final misplaced underbar check */
5592 if (dowarn && lastub && s - lastub != 3)
5593 warn("Misplaced _ in number");
5595 /* read a decimal portion if there is one. avoid
5596 3..5 being interpreted as the number 3. followed
5599 if (*s == '.' && s[1] != '.') {
5603 /* copy, ignoring underbars, until we run out of
5604 digits. Note: no misplaced underbar checks!
5606 for (; isDIGIT(*s) || *s == '_'; s++) {
5607 /* fixed length buffer check */
5609 croak(number_too_long);
5615 /* read exponent part, if present */
5616 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
5620 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
5621 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
5623 /* allow positive or negative exponent */
5624 if (*s == '+' || *s == '-')
5627 /* read digits of exponent (no underbars :-) */
5628 while (isDIGIT(*s)) {
5630 croak(number_too_long);
5635 /* terminate the string */
5638 /* make an sv from the string */
5640 /* reset numeric locale in case we were earlier left in Swaziland */
5641 SET_NUMERIC_STANDARD();
5642 value = atof(tokenbuf);
5645 See if we can make do with an integer value without loss of
5646 precision. We use I_V to cast to an int, because some
5647 compilers have issues. Then we try casting it back and see
5648 if it was the same. We only do this if we know we
5649 specifically read an integer.
5651 Note: if floatit is true, then we don't need to do the
5655 if (!floatit && (double)tryiv == value)
5656 sv_setiv(sv, tryiv);
5658 sv_setnv(sv, value);
5662 /* make the op for the constant and return */
5664 yylval.opval = newSVOP(OP_CONST, 0, sv);
5670 scan_formline(register char *s)
5675 SV *stuff = newSVpv("",0);
5676 bool needargs = FALSE;
5679 if (*s == '.' || *s == '}') {
5681 for (t = s+1; *t == ' ' || *t == '\t'; t++) ;
5685 if (in_eval && !rsfp) {
5686 eol = strchr(s,'\n');
5691 eol = bufend = SvPVX(linestr) + SvCUR(linestr);
5693 for (t = s; t < eol; t++) {
5694 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
5696 goto enough; /* ~~ must be first line in formline */
5698 if (*t == '@' || *t == '^')
5701 sv_catpvn(stuff, s, eol-s);
5705 s = filter_gets(linestr, rsfp, 0);
5706 oldoldbufptr = oldbufptr = bufptr = linestart = SvPVX(linestr);
5707 bufend = bufptr + SvCUR(linestr);
5710 yyerror("Format not terminated");
5720 lex_state = LEX_NORMAL;
5721 nextval[nexttoke].ival = 0;
5725 lex_state = LEX_FORMLINE;
5726 nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
5728 nextval[nexttoke].ival = OP_FORMLINE;
5732 SvREFCNT_dec(stuff);
5744 cshlen = strlen(cshname);
5749 start_subparse(I32 is_format, U32 flags)
5752 I32 oldsavestack_ix = savestack_ix;
5753 CV* outsidecv = compcv;
5757 assert(SvTYPE(compcv) == SVt_PVCV);
5764 SAVESPTR(comppad_name);
5766 SAVEI32(comppad_name_fill);
5767 SAVEI32(min_intro_pending);
5768 SAVEI32(max_intro_pending);
5769 SAVEI32(pad_reset_pending);
5771 compcv = (CV*)NEWSV(1104,0);
5772 sv_upgrade((SV *)compcv, is_format ? SVt_PVFM : SVt_PVCV);
5773 CvFLAGS(compcv) |= flags;
5776 av_push(comppad, Nullsv);
5777 curpad = AvARRAY(comppad);
5778 comppad_name = newAV();
5779 comppad_name_fill = 0;
5780 min_intro_pending = 0;
5782 subline = curcop->cop_line;
5784 av_store(comppad_name, 0, newSVpv("@_", 2));
5785 curpad[0] = (SV*)newAV();
5786 SvPADMY_on(curpad[0]); /* XXX Needed? */
5787 CvOWNER(compcv) = 0;
5788 New(666, CvMUTEXP(compcv), 1, perl_mutex);
5789 MUTEX_INIT(CvMUTEXP(compcv));
5790 #endif /* USE_THREADS */
5792 comppadlist = newAV();
5793 AvREAL_off(comppadlist);
5794 av_store(comppadlist, 0, (SV*)comppad_name);
5795 av_store(comppadlist, 1, (SV*)comppad);
5797 CvPADLIST(compcv) = comppadlist;
5798 CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc(outsidecv);
5800 CvOWNER(compcv) = 0;
5801 New(666, CvMUTEXP(compcv), 1, perl_mutex);
5802 MUTEX_INIT(CvMUTEXP(compcv));
5803 #endif /* USE_THREADS */
5805 return oldsavestack_ix;
5824 char *context = NULL;
5828 if (!yychar || (yychar == ';' && !rsfp))
5830 else if (bufptr > oldoldbufptr && bufptr - oldoldbufptr < 200 &&
5831 oldoldbufptr != oldbufptr && oldbufptr != bufptr) {
5832 while (isSPACE(*oldoldbufptr))
5834 context = oldoldbufptr;
5835 contlen = bufptr - oldoldbufptr;
5837 else if (bufptr > oldbufptr && bufptr - oldbufptr < 200 &&
5838 oldbufptr != bufptr) {
5839 while (isSPACE(*oldbufptr))
5841 context = oldbufptr;
5842 contlen = bufptr - oldbufptr;
5844 else if (yychar > 255)
5845 where = "next token ???";
5846 else if ((yychar & 127) == 127) {
5847 if (lex_state == LEX_NORMAL ||
5848 (lex_state == LEX_KNOWNEXT && lex_defer == LEX_NORMAL))
5849 where = "at end of line";
5851 where = "within pattern";
5853 where = "within string";
5856 SV *where_sv = sv_2mortal(newSVpv("next char ", 0));
5858 sv_catpvf(where_sv, "^%c", toCTRL(yychar));
5859 else if (isPRINT_LC(yychar))
5860 sv_catpvf(where_sv, "%c", yychar);
5862 sv_catpvf(where_sv, "\\%03o", yychar & 255);
5863 where = SvPVX(where_sv);
5865 msg = sv_2mortal(newSVpv(s, 0));
5866 sv_catpvf(msg, " at %_ line %ld, ",
5867 GvSV(curcop->cop_filegv), (long)curcop->cop_line);
5869 sv_catpvf(msg, "near \"%.*s\"\n", contlen, context);
5871 sv_catpvf(msg, "%s\n", where);
5872 if (multi_start < multi_end && (U32)(curcop->cop_line - multi_end) <= 1) {
5874 " (Might be a runaway multi-line %c%c string starting on line %ld)\n",
5875 (int)multi_open,(int)multi_close,(long)multi_start);
5881 sv_catsv(ERRSV, msg);
5883 PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
5884 if (++error_count >= 10)
5885 croak("%_ has too many errors.\n", GvSV(curcop->cop_filegv));
5887 in_my_stash = Nullhv;