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)(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) )
2899 bool immediate_paren = *s == '(';
2901 /* (Now we can afford to cross potential line boundary.) */
2904 /* Two barewords in a row may indicate method call. */
2906 if ((isALPHA(*s) || *s == '$') && (tmp=intuit_method(s,gv)))
2909 /* If not a declared subroutine, it's an indirect object. */
2910 /* (But it's an indir obj regardless for sort.) */
2912 if ((last_lop_op == OP_SORT ||
2913 (!immediate_paren && (!gv || !GvCVu(gv))) ) &&
2914 (last_lop_op != OP_MAPSTART && last_lop_op != OP_GREPSTART)){
2915 expect = (last_lop == oldoldbufptr) ? XTERM : XOPERATOR;
2920 /* If followed by a paren, it's certainly a subroutine. */
2926 if (gv && GvCVu(gv)) {
2927 for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
2928 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
2933 nextval[nexttoke].opval = yylval.opval;
2940 /* If followed by var or block, call it a method (unless sub) */
2942 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
2943 last_lop = oldbufptr;
2944 last_lop_op = OP_METHOD;
2948 /* If followed by a bareword, see if it looks like indir obj. */
2950 if ((isALPHA(*s) || *s == '$') && (tmp = intuit_method(s,gv)))
2953 /* Not a method, so call it a subroutine (if defined) */
2955 if (gv && GvCVu(gv)) {
2957 if (lastchar == '-')
2958 warn("Ambiguous use of -%s resolved as -&%s()",
2959 tokenbuf, tokenbuf);
2960 last_lop = oldbufptr;
2961 last_lop_op = OP_ENTERSUB;
2962 /* Check for a constant sub */
2964 if ((sv = cv_const_sv(cv))) {
2966 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
2967 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
2968 yylval.opval->op_private = 0;
2972 /* Resolve to GV now. */
2973 op_free(yylval.opval);
2974 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
2975 /* Is there a prototype? */
2978 char *proto = SvPV((SV*)cv, len);
2981 if (strEQ(proto, "$"))
2983 if (*proto == '&' && *s == '{') {
2984 sv_setpv(subname,"__ANON__");
2988 nextval[nexttoke].opval = yylval.opval;
2994 if (hints & HINT_STRICT_SUBS &&
2997 last_lop_op != OP_TRUNCATE && /* S/F prototype in opcode.pl */
2998 last_lop_op != OP_ACCEPT &&
2999 last_lop_op != OP_PIPE_OP &&
3000 last_lop_op != OP_SOCKPAIR)
3003 "Bareword \"%s\" not allowed while \"strict subs\" in use",
3008 /* Call it a bare word */
3012 if (lastchar != '-') {
3013 for (d = tokenbuf; *d && isLOWER(*d); d++) ;
3015 warn(warn_reserved, tokenbuf);
3020 if (lastchar && strchr("*%&", lastchar)) {
3021 warn("Operator or semicolon missing before %c%s",
3022 lastchar, tokenbuf);
3023 warn("Ambiguous use of %c resolved as operator %c",
3024 lastchar, lastchar);
3030 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3031 newSVsv(GvSV(curcop->cop_filegv)));
3035 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3036 newSVpvf("%ld", (long)curcop->cop_line));
3039 case KEY___PACKAGE__:
3040 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3042 ? newSVsv(curstname)
3051 if (rsfp && (!in_eval || tokenbuf[2] == 'D')) {
3052 char *pname = "main";
3053 if (tokenbuf[2] == 'D')
3054 pname = HvNAME(curstash ? curstash : defstash);
3055 gv = gv_fetchpv(form("%s::DATA", pname), TRUE, SVt_PVIO);
3058 GvIOp(gv) = newIO();
3059 IoIFP(GvIOp(gv)) = rsfp;
3060 #if defined(HAS_FCNTL) && defined(F_SETFD)
3062 int fd = PerlIO_fileno(rsfp);
3063 fcntl(fd,F_SETFD,fd >= 3);
3066 /* Mark this internal pseudo-handle as clean */
3067 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3069 IoTYPE(GvIOp(gv)) = '|';
3070 else if ((PerlIO*)rsfp == PerlIO_stdin())
3071 IoTYPE(GvIOp(gv)) = '-';
3073 IoTYPE(GvIOp(gv)) = '<';
3084 if (expect == XSTATE) {
3091 if (*s == ':' && s[1] == ':') {
3094 s = scan_word(s, tokenbuf, sizeof tokenbuf, FALSE, &len);
3095 tmp = keyword(tokenbuf, len);
3109 LOP(OP_ACCEPT,XTERM);
3115 LOP(OP_ATAN2,XTERM);
3124 LOP(OP_BLESS,XTERM);
3133 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
3153 LOP(OP_CRYPT,XTERM);
3157 for (d = s; d < bufend && (isSPACE(*d) || *d == '('); d++) ;
3158 if (*d != '0' && isDIGIT(*d))
3159 yywarn("chmod: mode argument is missing initial 0");
3161 LOP(OP_CHMOD,XTERM);
3164 LOP(OP_CHOWN,XTERM);
3167 LOP(OP_CONNECT,XTERM);
3183 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3187 hints |= HINT_BLOCK_SCOPE;
3197 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3198 LOP(OP_DBMOPEN,XTERM);
3204 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3211 yylval.ival = curcop->cop_line;
3225 expect = (*s == '{') ? XTERMBLOCK : XTERM;
3226 UNIBRACK(OP_ENTEREVAL);
3241 case KEY_endhostent:
3247 case KEY_endservent:
3250 case KEY_endprotoent:
3261 yylval.ival = curcop->cop_line;
3263 if (expect == XSTATE && isIDFIRST(*s)) {
3265 if ((bufend - p) >= 3 &&
3266 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3270 croak("Missing $ on loop variable");
3275 LOP(OP_FORMLINE,XTERM);
3281 LOP(OP_FCNTL,XTERM);
3287 LOP(OP_FLOCK,XTERM);
3296 LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
3299 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3314 case KEY_getpriority:
3315 LOP(OP_GETPRIORITY,XTERM);
3317 case KEY_getprotobyname:
3320 case KEY_getprotobynumber:
3321 LOP(OP_GPBYNUMBER,XTERM);
3323 case KEY_getprotoent:
3335 case KEY_getpeername:
3336 UNI(OP_GETPEERNAME);
3338 case KEY_gethostbyname:
3341 case KEY_gethostbyaddr:
3342 LOP(OP_GHBYADDR,XTERM);
3344 case KEY_gethostent:
3347 case KEY_getnetbyname:
3350 case KEY_getnetbyaddr:
3351 LOP(OP_GNBYADDR,XTERM);
3356 case KEY_getservbyname:
3357 LOP(OP_GSBYNAME,XTERM);
3359 case KEY_getservbyport:
3360 LOP(OP_GSBYPORT,XTERM);
3362 case KEY_getservent:
3365 case KEY_getsockname:
3366 UNI(OP_GETSOCKNAME);
3368 case KEY_getsockopt:
3369 LOP(OP_GSOCKOPT,XTERM);
3391 yylval.ival = curcop->cop_line;
3395 LOP(OP_INDEX,XTERM);
3401 LOP(OP_IOCTL,XTERM);
3413 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3444 LOP(OP_LISTEN,XTERM);
3454 TERM(sublex_start());
3457 LOP(OP_MAPSTART,XREF);
3460 LOP(OP_MKDIR,XTERM);
3463 LOP(OP_MSGCTL,XTERM);
3466 LOP(OP_MSGGET,XTERM);
3469 LOP(OP_MSGRCV,XTERM);
3472 LOP(OP_MSGSND,XTERM);
3477 if (isIDFIRST(*s)) {
3478 s = scan_word(s, tokenbuf, sizeof tokenbuf, TRUE, &len);
3479 in_my_stash = gv_stashpv(tokenbuf, FALSE);
3483 sprintf(tmpbuf, "No such class %.1000s", tokenbuf);
3490 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3497 if (expect != XSTATE)
3498 yyerror("\"no\" not allowed in expression");
3499 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3500 s = force_version(s);
3509 if (isIDFIRST(*s)) {
3511 for (d = s; isALNUM(*d); d++) ;
3513 if (strchr("|&*+-=!?:.", *t))
3514 warn("Precedence problem: open %.*s should be open(%.*s)",
3520 yylval.ival = OP_OR;
3530 LOP(OP_OPEN_DIR,XTERM);
3533 checkcomma(s,tokenbuf,"filehandle");
3537 checkcomma(s,tokenbuf,"filehandle");
3556 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3560 LOP(OP_PIPE_OP,XTERM);
3565 missingterm((char*)0);
3566 yylval.ival = OP_CONST;
3567 TERM(sublex_start());
3575 missingterm((char*)0);
3576 if (dowarn && SvLEN(lex_stuff)) {
3577 d = SvPV_force(lex_stuff, len);
3578 for (; len; --len, ++d) {
3580 warn("Possible attempt to separate words with commas");
3584 warn("Possible attempt to put comments in qw() list");
3590 nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, tokeq(lex_stuff));
3594 nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(" ",1));
3597 yylval.ival = OP_SPLIT;
3601 last_lop = oldbufptr;
3602 last_lop_op = OP_SPLIT;
3608 missingterm((char*)0);
3609 yylval.ival = OP_STRINGIFY;
3610 if (SvIVX(lex_stuff) == '\'')
3611 SvIVX(lex_stuff) = 0; /* qq'$foo' should intepolate */
3612 TERM(sublex_start());
3617 missingterm((char*)0);
3618 yylval.ival = OP_BACKTICK;
3620 TERM(sublex_start());
3627 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3628 if (isIDFIRST(*tokenbuf))
3629 gv_stashpvn(tokenbuf, strlen(tokenbuf), TRUE);
3631 yyerror("<> should be quotes");
3638 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3642 LOP(OP_RENAME,XTERM);
3651 LOP(OP_RINDEX,XTERM);
3674 LOP(OP_REVERSE,XTERM);
3685 TERM(sublex_start());
3687 TOKEN(1); /* force error */
3696 LOP(OP_SELECT,XTERM);
3702 LOP(OP_SEMCTL,XTERM);
3705 LOP(OP_SEMGET,XTERM);
3708 LOP(OP_SEMOP,XTERM);
3714 LOP(OP_SETPGRP,XTERM);
3716 case KEY_setpriority:
3717 LOP(OP_SETPRIORITY,XTERM);
3719 case KEY_sethostent:
3725 case KEY_setservent:
3728 case KEY_setprotoent:
3738 LOP(OP_SEEKDIR,XTERM);
3740 case KEY_setsockopt:
3741 LOP(OP_SSOCKOPT,XTERM);
3747 LOP(OP_SHMCTL,XTERM);
3750 LOP(OP_SHMGET,XTERM);
3753 LOP(OP_SHMREAD,XTERM);
3756 LOP(OP_SHMWRITE,XTERM);
3759 LOP(OP_SHUTDOWN,XTERM);
3768 LOP(OP_SOCKET,XTERM);
3770 case KEY_socketpair:
3771 LOP(OP_SOCKPAIR,XTERM);
3774 checkcomma(s,tokenbuf,"subroutine name");
3776 if (*s == ';' || *s == ')') /* probably a close */
3777 croak("sort is now a reserved word");
3779 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3783 LOP(OP_SPLIT,XTERM);
3786 LOP(OP_SPRINTF,XTERM);
3789 LOP(OP_SPLICE,XTERM);
3805 LOP(OP_SUBSTR,XTERM);
3812 if (isIDFIRST(*s) || *s == '\'' || *s == ':') {
3813 char tmpbuf[sizeof tokenbuf];
3815 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3816 if (strchr(tmpbuf, ':'))
3817 sv_setpv(subname, tmpbuf);
3819 sv_setsv(subname,curstname);
3820 sv_catpvn(subname,"::",2);
3821 sv_catpvn(subname,tmpbuf,len);
3823 s = force_word(s,WORD,FALSE,TRUE,TRUE);
3827 expect = XTERMBLOCK;
3828 sv_setpv(subname,"?");
3831 if (tmp == KEY_format) {
3834 lex_formbrack = lex_brackets + 1;
3838 /* Look for a prototype */
3845 SvREFCNT_dec(lex_stuff);
3847 croak("Prototype not terminated");
3850 d = SvPVX(lex_stuff);
3852 for (p = d; *p; ++p) {
3857 SvCUR(lex_stuff) = tmp;
3860 nextval[1] = nextval[0];
3861 nexttype[1] = nexttype[0];
3862 nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, lex_stuff);
3863 nexttype[0] = THING;
3864 if (nexttoke == 1) {
3865 lex_defer = lex_state;
3866 lex_expect = expect;
3867 lex_state = LEX_KNOWNEXT;
3872 if (*SvPV(subname,na) == '?') {
3873 sv_setpv(subname,"__ANON__");
3880 LOP(OP_SYSTEM,XREF);
3883 LOP(OP_SYMLINK,XTERM);
3886 LOP(OP_SYSCALL,XTERM);
3889 LOP(OP_SYSOPEN,XTERM);
3892 LOP(OP_SYSSEEK,XTERM);
3895 LOP(OP_SYSREAD,XTERM);
3898 LOP(OP_SYSWRITE,XTERM);
3902 TERM(sublex_start());
3923 LOP(OP_TRUNCATE,XTERM);
3935 yylval.ival = curcop->cop_line;
3939 yylval.ival = curcop->cop_line;
3943 LOP(OP_UNLINK,XTERM);
3949 LOP(OP_UNPACK,XTERM);
3952 LOP(OP_UTIME,XTERM);
3956 for (d = s; d < bufend && (isSPACE(*d) || *d == '('); d++) ;
3957 if (*d != '0' && isDIGIT(*d))
3958 yywarn("umask: argument is missing initial 0");
3963 LOP(OP_UNSHIFT,XTERM);
3966 if (expect != XSTATE)
3967 yyerror("\"use\" not allowed in expression");
3970 s = force_version(s);
3971 if(*s == ';' || (s = skipspace(s), *s == ';')) {
3972 nextval[nexttoke].opval = Nullop;
3977 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3978 s = force_version(s);
3991 yylval.ival = curcop->cop_line;
3995 hints |= HINT_BLOCK_SCOPE;
4002 LOP(OP_WAITPID,XTERM);
4008 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
4012 if (expect == XOPERATOR)
4018 yylval.ival = OP_XOR;
4023 TERM(sublex_start());
4029 keyword(register char *d, I32 len)
4034 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
4035 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
4036 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
4037 if (strEQ(d,"__DATA__")) return KEY___DATA__;
4038 if (strEQ(d,"__END__")) return KEY___END__;
4042 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
4047 if (strEQ(d,"and")) return -KEY_and;
4048 if (strEQ(d,"abs")) return -KEY_abs;
4051 if (strEQ(d,"alarm")) return -KEY_alarm;
4052 if (strEQ(d,"atan2")) return -KEY_atan2;
4055 if (strEQ(d,"accept")) return -KEY_accept;
4060 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
4063 if (strEQ(d,"bless")) return -KEY_bless;
4064 if (strEQ(d,"bind")) return -KEY_bind;
4065 if (strEQ(d,"binmode")) return -KEY_binmode;
4068 if (strEQ(d,"CORE")) return -KEY_CORE;
4073 if (strEQ(d,"cmp")) return -KEY_cmp;
4074 if (strEQ(d,"chr")) return -KEY_chr;
4075 if (strEQ(d,"cos")) return -KEY_cos;
4078 if (strEQ(d,"chop")) return KEY_chop;
4081 if (strEQ(d,"close")) return -KEY_close;
4082 if (strEQ(d,"chdir")) return -KEY_chdir;
4083 if (strEQ(d,"chomp")) return KEY_chomp;
4084 if (strEQ(d,"chmod")) return -KEY_chmod;
4085 if (strEQ(d,"chown")) return -KEY_chown;
4086 if (strEQ(d,"crypt")) return -KEY_crypt;
4089 if (strEQ(d,"chroot")) return -KEY_chroot;
4090 if (strEQ(d,"caller")) return -KEY_caller;
4093 if (strEQ(d,"connect")) return -KEY_connect;
4096 if (strEQ(d,"closedir")) return -KEY_closedir;
4097 if (strEQ(d,"continue")) return -KEY_continue;
4102 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
4107 if (strEQ(d,"do")) return KEY_do;
4110 if (strEQ(d,"die")) return -KEY_die;
4113 if (strEQ(d,"dump")) return -KEY_dump;
4116 if (strEQ(d,"delete")) return KEY_delete;
4119 if (strEQ(d,"defined")) return KEY_defined;
4120 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
4123 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
4128 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
4129 if (strEQ(d,"END")) return KEY_END;
4134 if (strEQ(d,"eq")) return -KEY_eq;
4137 if (strEQ(d,"eof")) return -KEY_eof;
4138 if (strEQ(d,"exp")) return -KEY_exp;
4141 if (strEQ(d,"else")) return KEY_else;
4142 if (strEQ(d,"exit")) return -KEY_exit;
4143 if (strEQ(d,"eval")) return KEY_eval;
4144 if (strEQ(d,"exec")) return -KEY_exec;
4145 if (strEQ(d,"each")) return KEY_each;
4148 if (strEQ(d,"elsif")) return KEY_elsif;
4151 if (strEQ(d,"exists")) return KEY_exists;
4152 if (strEQ(d,"elseif")) warn("elseif should be elsif");
4155 if (strEQ(d,"endgrent")) return -KEY_endgrent;
4156 if (strEQ(d,"endpwent")) return -KEY_endpwent;
4159 if (strEQ(d,"endnetent")) return -KEY_endnetent;
4162 if (strEQ(d,"endhostent")) return -KEY_endhostent;
4163 if (strEQ(d,"endservent")) return -KEY_endservent;
4166 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
4173 if (strEQ(d,"for")) return KEY_for;
4176 if (strEQ(d,"fork")) return -KEY_fork;
4179 if (strEQ(d,"fcntl")) return -KEY_fcntl;
4180 if (strEQ(d,"flock")) return -KEY_flock;
4183 if (strEQ(d,"format")) return KEY_format;
4184 if (strEQ(d,"fileno")) return -KEY_fileno;
4187 if (strEQ(d,"foreach")) return KEY_foreach;
4190 if (strEQ(d,"formline")) return -KEY_formline;
4196 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
4197 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
4201 if (strnEQ(d,"get",3)) {
4206 if (strEQ(d,"ppid")) return -KEY_getppid;
4207 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
4210 if (strEQ(d,"pwent")) return -KEY_getpwent;
4211 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
4212 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
4215 if (strEQ(d,"peername")) return -KEY_getpeername;
4216 if (strEQ(d,"protoent")) return -KEY_getprotoent;
4217 if (strEQ(d,"priority")) return -KEY_getpriority;
4220 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
4223 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
4227 else if (*d == 'h') {
4228 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
4229 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
4230 if (strEQ(d,"hostent")) return -KEY_gethostent;
4232 else if (*d == 'n') {
4233 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
4234 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
4235 if (strEQ(d,"netent")) return -KEY_getnetent;
4237 else if (*d == 's') {
4238 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
4239 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
4240 if (strEQ(d,"servent")) return -KEY_getservent;
4241 if (strEQ(d,"sockname")) return -KEY_getsockname;
4242 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
4244 else if (*d == 'g') {
4245 if (strEQ(d,"grent")) return -KEY_getgrent;
4246 if (strEQ(d,"grnam")) return -KEY_getgrnam;
4247 if (strEQ(d,"grgid")) return -KEY_getgrgid;
4249 else if (*d == 'l') {
4250 if (strEQ(d,"login")) return -KEY_getlogin;
4252 else if (strEQ(d,"c")) return -KEY_getc;
4257 if (strEQ(d,"gt")) return -KEY_gt;
4258 if (strEQ(d,"ge")) return -KEY_ge;
4261 if (strEQ(d,"grep")) return KEY_grep;
4262 if (strEQ(d,"goto")) return KEY_goto;
4263 if (strEQ(d,"glob")) return KEY_glob;
4266 if (strEQ(d,"gmtime")) return -KEY_gmtime;
4271 if (strEQ(d,"hex")) return -KEY_hex;
4274 if (strEQ(d,"INIT")) return KEY_INIT;
4279 if (strEQ(d,"if")) return KEY_if;
4282 if (strEQ(d,"int")) return -KEY_int;
4285 if (strEQ(d,"index")) return -KEY_index;
4286 if (strEQ(d,"ioctl")) return -KEY_ioctl;
4291 if (strEQ(d,"join")) return -KEY_join;
4295 if (strEQ(d,"keys")) return KEY_keys;
4296 if (strEQ(d,"kill")) return -KEY_kill;
4301 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
4302 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
4308 if (strEQ(d,"lt")) return -KEY_lt;
4309 if (strEQ(d,"le")) return -KEY_le;
4310 if (strEQ(d,"lc")) return -KEY_lc;
4313 if (strEQ(d,"log")) return -KEY_log;
4316 if (strEQ(d,"last")) return KEY_last;
4317 if (strEQ(d,"link")) return -KEY_link;
4318 if (strEQ(d,"lock")) return -KEY_lock;
4321 if (strEQ(d,"local")) return KEY_local;
4322 if (strEQ(d,"lstat")) return -KEY_lstat;
4325 if (strEQ(d,"length")) return -KEY_length;
4326 if (strEQ(d,"listen")) return -KEY_listen;
4329 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
4332 if (strEQ(d,"localtime")) return -KEY_localtime;
4338 case 1: return KEY_m;
4340 if (strEQ(d,"my")) return KEY_my;
4343 if (strEQ(d,"map")) return KEY_map;
4346 if (strEQ(d,"mkdir")) return -KEY_mkdir;
4349 if (strEQ(d,"msgctl")) return -KEY_msgctl;
4350 if (strEQ(d,"msgget")) return -KEY_msgget;
4351 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
4352 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
4357 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
4360 if (strEQ(d,"next")) return KEY_next;
4361 if (strEQ(d,"ne")) return -KEY_ne;
4362 if (strEQ(d,"not")) return -KEY_not;
4363 if (strEQ(d,"no")) return KEY_no;
4368 if (strEQ(d,"or")) return -KEY_or;
4371 if (strEQ(d,"ord")) return -KEY_ord;
4372 if (strEQ(d,"oct")) return -KEY_oct;
4375 if (strEQ(d,"open")) return -KEY_open;
4378 if (strEQ(d,"opendir")) return -KEY_opendir;
4385 if (strEQ(d,"pop")) return KEY_pop;
4386 if (strEQ(d,"pos")) return KEY_pos;
4389 if (strEQ(d,"push")) return KEY_push;
4390 if (strEQ(d,"pack")) return -KEY_pack;
4391 if (strEQ(d,"pipe")) return -KEY_pipe;
4394 if (strEQ(d,"print")) return KEY_print;
4397 if (strEQ(d,"printf")) return KEY_printf;
4400 if (strEQ(d,"package")) return KEY_package;
4403 if (strEQ(d,"prototype")) return KEY_prototype;
4408 if (strEQ(d,"q")) return KEY_q;
4409 if (strEQ(d,"qq")) return KEY_qq;
4410 if (strEQ(d,"qw")) return KEY_qw;
4411 if (strEQ(d,"qx")) return KEY_qx;
4413 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
4418 if (strEQ(d,"ref")) return -KEY_ref;
4421 if (strEQ(d,"read")) return -KEY_read;
4422 if (strEQ(d,"rand")) return -KEY_rand;
4423 if (strEQ(d,"recv")) return -KEY_recv;
4424 if (strEQ(d,"redo")) return KEY_redo;
4427 if (strEQ(d,"rmdir")) return -KEY_rmdir;
4428 if (strEQ(d,"reset")) return -KEY_reset;
4431 if (strEQ(d,"return")) return KEY_return;
4432 if (strEQ(d,"rename")) return -KEY_rename;
4433 if (strEQ(d,"rindex")) return -KEY_rindex;
4436 if (strEQ(d,"require")) return -KEY_require;
4437 if (strEQ(d,"reverse")) return -KEY_reverse;
4438 if (strEQ(d,"readdir")) return -KEY_readdir;
4441 if (strEQ(d,"readlink")) return -KEY_readlink;
4442 if (strEQ(d,"readline")) return -KEY_readline;
4443 if (strEQ(d,"readpipe")) return -KEY_readpipe;
4446 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
4452 case 0: return KEY_s;
4454 if (strEQ(d,"scalar")) return KEY_scalar;
4459 if (strEQ(d,"seek")) return -KEY_seek;
4460 if (strEQ(d,"send")) return -KEY_send;
4463 if (strEQ(d,"semop")) return -KEY_semop;
4466 if (strEQ(d,"select")) return -KEY_select;
4467 if (strEQ(d,"semctl")) return -KEY_semctl;
4468 if (strEQ(d,"semget")) return -KEY_semget;
4471 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
4472 if (strEQ(d,"seekdir")) return -KEY_seekdir;
4475 if (strEQ(d,"setpwent")) return -KEY_setpwent;
4476 if (strEQ(d,"setgrent")) return -KEY_setgrent;
4479 if (strEQ(d,"setnetent")) return -KEY_setnetent;
4482 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
4483 if (strEQ(d,"sethostent")) return -KEY_sethostent;
4484 if (strEQ(d,"setservent")) return -KEY_setservent;
4487 if (strEQ(d,"setpriority")) return -KEY_setpriority;
4488 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
4495 if (strEQ(d,"shift")) return KEY_shift;
4498 if (strEQ(d,"shmctl")) return -KEY_shmctl;
4499 if (strEQ(d,"shmget")) return -KEY_shmget;
4502 if (strEQ(d,"shmread")) return -KEY_shmread;
4505 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
4506 if (strEQ(d,"shutdown")) return -KEY_shutdown;
4511 if (strEQ(d,"sin")) return -KEY_sin;
4514 if (strEQ(d,"sleep")) return -KEY_sleep;
4517 if (strEQ(d,"sort")) return KEY_sort;
4518 if (strEQ(d,"socket")) return -KEY_socket;
4519 if (strEQ(d,"socketpair")) return -KEY_socketpair;
4522 if (strEQ(d,"split")) return KEY_split;
4523 if (strEQ(d,"sprintf")) return -KEY_sprintf;
4524 if (strEQ(d,"splice")) return KEY_splice;
4527 if (strEQ(d,"sqrt")) return -KEY_sqrt;
4530 if (strEQ(d,"srand")) return -KEY_srand;
4533 if (strEQ(d,"stat")) return -KEY_stat;
4534 if (strEQ(d,"study")) return KEY_study;
4537 if (strEQ(d,"substr")) return -KEY_substr;
4538 if (strEQ(d,"sub")) return KEY_sub;
4543 if (strEQ(d,"system")) return -KEY_system;
4546 if (strEQ(d,"symlink")) return -KEY_symlink;
4547 if (strEQ(d,"syscall")) return -KEY_syscall;
4548 if (strEQ(d,"sysopen")) return -KEY_sysopen;
4549 if (strEQ(d,"sysread")) return -KEY_sysread;
4550 if (strEQ(d,"sysseek")) return -KEY_sysseek;
4553 if (strEQ(d,"syswrite")) return -KEY_syswrite;
4562 if (strEQ(d,"tr")) return KEY_tr;
4565 if (strEQ(d,"tie")) return KEY_tie;
4568 if (strEQ(d,"tell")) return -KEY_tell;
4569 if (strEQ(d,"tied")) return KEY_tied;
4570 if (strEQ(d,"time")) return -KEY_time;
4573 if (strEQ(d,"times")) return -KEY_times;
4576 if (strEQ(d,"telldir")) return -KEY_telldir;
4579 if (strEQ(d,"truncate")) return -KEY_truncate;
4586 if (strEQ(d,"uc")) return -KEY_uc;
4589 if (strEQ(d,"use")) return KEY_use;
4592 if (strEQ(d,"undef")) return KEY_undef;
4593 if (strEQ(d,"until")) return KEY_until;
4594 if (strEQ(d,"untie")) return KEY_untie;
4595 if (strEQ(d,"utime")) return -KEY_utime;
4596 if (strEQ(d,"umask")) return -KEY_umask;
4599 if (strEQ(d,"unless")) return KEY_unless;
4600 if (strEQ(d,"unpack")) return -KEY_unpack;
4601 if (strEQ(d,"unlink")) return -KEY_unlink;
4604 if (strEQ(d,"unshift")) return KEY_unshift;
4605 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
4610 if (strEQ(d,"values")) return -KEY_values;
4611 if (strEQ(d,"vec")) return -KEY_vec;
4616 if (strEQ(d,"warn")) return -KEY_warn;
4617 if (strEQ(d,"wait")) return -KEY_wait;
4620 if (strEQ(d,"while")) return KEY_while;
4621 if (strEQ(d,"write")) return -KEY_write;
4624 if (strEQ(d,"waitpid")) return -KEY_waitpid;
4627 if (strEQ(d,"wantarray")) return -KEY_wantarray;
4632 if (len == 1) return -KEY_x;
4633 if (strEQ(d,"xor")) return -KEY_xor;
4636 if (len == 1) return KEY_y;
4645 checkcomma(register char *s, char *name, char *what)
4649 if (dowarn && *s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
4651 for (w = s+2; *w && level; w++) {
4658 for (; *w && isSPACE(*w); w++) ;
4659 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
4660 warn("%s (...) interpreted as function",name);
4662 while (s < bufend && isSPACE(*s))
4666 while (s < bufend && isSPACE(*s))
4668 if (isIDFIRST(*s)) {
4672 while (s < bufend && isSPACE(*s))
4677 kw = keyword(w, s - w) || perl_get_cv(w, FALSE) != 0;
4681 croak("No comma allowed after %s", what);
4687 scan_word(register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
4689 register char *d = dest;
4690 register char *e = d + destlen - 3; /* two-character token, ending NUL */
4693 croak(ident_too_long);
4696 else if (*s == '\'' && allow_package && isIDFIRST(s[1])) {
4701 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
4714 scan_ident(register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
4721 if (lex_brackets == 0)
4726 e = d + destlen - 3; /* two-character token, ending NUL */
4728 while (isDIGIT(*s)) {
4730 croak(ident_too_long);
4737 croak(ident_too_long);
4740 else if (*s == '\'' && isIDFIRST(s[1])) {
4745 else if (*s == ':' && s[1] == ':') {
4756 if (lex_state != LEX_NORMAL)
4757 lex_state = LEX_INTERPENDMAYBE;
4760 if (*s == '$' && s[1] &&
4761 (isALNUM(s[1]) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
4763 if (isDIGIT(s[1]) && lex_state == LEX_INTERPNORMAL)
4764 deprecate("\"$$<digit>\" to mean \"${$}<digit>\"");
4777 if (*d == '^' && *s && (isUPPER(*s) || strchr("[\\]^_?", *s))) {
4782 if (isSPACE(s[-1])) {
4785 if (ch != ' ' && ch != '\t') {
4791 if (isIDFIRST(*d)) {
4793 while (isALNUM(*s) || *s == ':')
4796 while (s < send && (*s == ' ' || *s == '\t')) s++;
4797 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
4798 if (dowarn && keyword(dest, d - dest)) {
4799 char *brack = *s == '[' ? "[...]" : "{...}";
4800 warn("Ambiguous use of %c{%s%s} resolved to %c%s%s",
4801 funny, dest, brack, funny, dest, brack);
4803 lex_fakebrack = lex_brackets+1;
4805 lex_brackstack[lex_brackets++] = XOPERATOR;
4811 if (lex_state == LEX_INTERPNORMAL && !lex_brackets)
4812 lex_state = LEX_INTERPEND;
4815 if (dowarn && lex_state == LEX_NORMAL &&
4816 (keyword(dest, d - dest) || perl_get_cv(dest, FALSE)))
4817 warn("Ambiguous use of %c{%s} resolved to %c%s",
4818 funny, dest, funny, dest);
4821 s = bracket; /* let the parser handle it */
4825 else if (lex_state == LEX_INTERPNORMAL && !lex_brackets && !intuit_more(s))
4826 lex_state = LEX_INTERPEND;
4830 void pmflag(U16 *pmfl, int ch)
4835 *pmfl |= PMf_GLOBAL;
4837 *pmfl |= PMf_CONTINUE;
4841 *pmfl |= PMf_MULTILINE;
4843 *pmfl |= PMf_SINGLELINE;
4845 *pmfl |= PMf_TAINTMEM;
4847 *pmfl |= PMf_EXTENDED;
4851 scan_pat(char *start)
4856 s = scan_str(start);
4859 SvREFCNT_dec(lex_stuff);
4861 croak("Search pattern not terminated");
4864 pm = (PMOP*)newPMOP(OP_MATCH, 0);
4865 if (multi_open == '?')
4866 pm->op_pmflags |= PMf_ONCE;
4867 while (*s && strchr("iogcmstx", *s))
4868 pmflag(&pm->op_pmflags,*s++);
4869 pm->op_pmpermflags = pm->op_pmflags;
4872 yylval.ival = OP_MATCH;
4877 scan_subst(char *start)
4884 yylval.ival = OP_NULL;
4886 s = scan_str(start);
4890 SvREFCNT_dec(lex_stuff);
4892 croak("Substitution pattern not terminated");
4895 if (s[-1] == multi_open)
4898 first_start = multi_start;
4902 SvREFCNT_dec(lex_stuff);
4905 SvREFCNT_dec(lex_repl);
4907 croak("Substitution replacement not terminated");
4909 multi_start = first_start; /* so whole substitution is taken together */
4911 pm = (PMOP*)newPMOP(OP_SUBST, 0);
4917 else if (strchr("iogcmstx", *s))
4918 pmflag(&pm->op_pmflags,*s++);
4925 pm->op_pmflags |= PMf_EVAL;
4926 repl = newSVpv("",0);
4928 sv_catpv(repl, es ? "eval " : "do ");
4929 sv_catpvn(repl, "{ ", 2);
4930 sv_catsv(repl, lex_repl);
4931 sv_catpvn(repl, " };", 2);
4932 SvCOMPILED_on(repl);
4933 SvREFCNT_dec(lex_repl);
4937 pm->op_pmpermflags = pm->op_pmflags;
4939 yylval.ival = OP_SUBST;
4944 scan_trans(char *start)
4953 yylval.ival = OP_NULL;
4955 s = scan_str(start);
4958 SvREFCNT_dec(lex_stuff);
4960 croak("Transliteration pattern not terminated");
4962 if (s[-1] == multi_open)
4968 SvREFCNT_dec(lex_stuff);
4971 SvREFCNT_dec(lex_repl);
4973 croak("Transliteration replacement not terminated");
4976 New(803,tbl,256,short);
4977 o = newPVOP(OP_TRANS, 0, (char*)tbl);
4979 complement = Delete = squash = 0;
4980 while (*s == 'c' || *s == 'd' || *s == 's') {
4982 complement = OPpTRANS_COMPLEMENT;
4984 Delete = OPpTRANS_DELETE;
4986 squash = OPpTRANS_SQUASH;
4989 o->op_private = Delete|squash|complement;
4992 yylval.ival = OP_TRANS;
4997 scan_heredoc(register char *s)
5001 I32 op_type = OP_SCALAR;
5008 int outer = (rsfp && !(lex_inwhat == OP_SCALAR));
5012 e = tokenbuf + sizeof tokenbuf - 1;
5015 for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5016 if (*peek && strchr("`'\"",*peek)) {
5019 s = delimcpy(d, e, s, bufend, term, &len);
5030 deprecate("bare << to mean <<\"\"");
5031 for (; isALNUM(*s); s++) {
5036 if (d >= tokenbuf + sizeof tokenbuf - 1)
5037 croak("Delimiter for here document is too long");
5042 if (outer || !(d=ninstr(s,bufend,d,d+1)))
5043 herewas = newSVpv(s,bufend-s);
5045 s--, herewas = newSVpv(s,d-s);
5046 s += SvCUR(herewas);
5048 tmpstr = NEWSV(87,80);
5049 sv_upgrade(tmpstr, SVt_PVIV);
5054 else if (term == '`') {
5055 op_type = OP_BACKTICK;
5056 SvIVX(tmpstr) = '\\';
5060 multi_start = curcop->cop_line;
5061 multi_open = multi_close = '<';
5065 while (s < bufend &&
5066 (*s != term || memNE(s,tokenbuf,len)) ) {
5071 curcop->cop_line = multi_start;
5072 missingterm(tokenbuf);
5074 sv_setpvn(tmpstr,d+1,s-d);
5076 curcop->cop_line++; /* the preceding stmt passes a newline */
5078 sv_catpvn(herewas,s,bufend-s);
5079 sv_setsv(linestr,herewas);
5080 oldoldbufptr = oldbufptr = bufptr = s = linestart = SvPVX(linestr);
5081 bufend = SvPVX(linestr) + SvCUR(linestr);
5084 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
5085 while (s >= bufend) { /* multiple line string? */
5087 !(oldoldbufptr = oldbufptr = s = linestart = filter_gets(linestr, rsfp, 0))) {
5088 curcop->cop_line = multi_start;
5089 missingterm(tokenbuf);
5092 if (PERLDB_LINE && curstash != debstash) {
5093 SV *sv = NEWSV(88,0);
5095 sv_upgrade(sv, SVt_PVMG);
5096 sv_setsv(sv,linestr);
5097 av_store(GvAV(curcop->cop_filegv),
5098 (I32)curcop->cop_line,sv);
5100 bufend = SvPVX(linestr) + SvCUR(linestr);
5101 if (*s == term && memEQ(s,tokenbuf,len)) {
5104 sv_catsv(linestr,herewas);
5105 bufend = SvPVX(linestr) + SvCUR(linestr);
5109 sv_catsv(tmpstr,linestr);
5112 multi_end = curcop->cop_line;
5114 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
5115 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
5116 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
5118 SvREFCNT_dec(herewas);
5120 yylval.ival = op_type;
5125 takes: current position in input buffer
5126 returns: new position in input buffer
5127 side-effects: yylval and lex_op are set.
5132 <FH> read from filehandle
5133 <pkg::FH> read from package qualified filehandle
5134 <pkg'FH> read from package qualified filehandle
5135 <$fh> read from filehandle in $fh
5141 scan_inputsymbol(char *start)
5143 register char *s = start; /* current position in buffer */
5148 d = tokenbuf; /* start of temp holding space */
5149 e = tokenbuf + sizeof tokenbuf; /* end of temp holding space */
5150 s = delimcpy(d, e, s + 1, bufend, '>', &len); /* extract until > */
5152 /* die if we didn't have space for the contents of the <>,
5156 if (len >= sizeof tokenbuf)
5157 croak("Excessively long <> operator");
5159 croak("Unterminated <> operator");
5164 Remember, only scalar variables are interpreted as filehandles by
5165 this code. Anything more complex (e.g., <$fh{$num}>) will be
5166 treated as a glob() call.
5167 This code makes use of the fact that except for the $ at the front,
5168 a scalar variable and a filehandle look the same.
5170 if (*d == '$' && d[1]) d++;
5172 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
5173 while (*d && (isALNUM(*d) || *d == '\'' || *d == ':'))
5176 /* If we've tried to read what we allow filehandles to look like, and
5177 there's still text left, then it must be a glob() and not a getline.
5178 Use scan_str to pull out the stuff between the <> and treat it
5179 as nothing more than a string.
5182 if (d - tokenbuf != len) {
5183 yylval.ival = OP_GLOB;
5185 s = scan_str(start);
5187 croak("Glob not terminated");
5191 /* we're in a filehandle read situation */
5194 /* turn <> into <ARGV> */
5196 (void)strcpy(d,"ARGV");
5198 /* if <$fh>, create the ops to turn the variable into a
5204 /* try to find it in the pad for this block, otherwise find
5205 add symbol table ops
5207 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
5208 OP *o = newOP(OP_PADSV, 0);
5210 lex_op = (OP*)newUNOP(OP_READLINE, 0, newUNOP(OP_RV2GV, 0, o));
5213 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
5214 lex_op = (OP*)newUNOP(OP_READLINE, 0,
5215 newUNOP(OP_RV2GV, 0,
5216 newUNOP(OP_RV2SV, 0,
5217 newGVOP(OP_GV, 0, gv))));
5219 /* we created the ops in lex_op, so make yylval.ival a null op */
5220 yylval.ival = OP_NULL;
5223 /* If it's none of the above, it must be a literal filehandle
5224 (<Foo::BAR> or <FOO>) so build a simple readline OP */
5226 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
5227 lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
5228 yylval.ival = OP_NULL;
5237 takes: start position in buffer
5238 returns: position to continue reading from buffer
5239 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
5240 updates the read buffer.
5242 This subroutine pulls a string out of the input. It is called for:
5243 q single quotes q(literal text)
5244 ' single quotes 'literal text'
5245 qq double quotes qq(interpolate $here please)
5246 " double quotes "interpolate $here please"
5247 qx backticks qx(/bin/ls -l)
5248 ` backticks `/bin/ls -l`
5249 qw quote words @EXPORT_OK = qw( func() $spam )
5250 m// regexp match m/this/
5251 s/// regexp substitute s/this/that/
5252 tr/// string transliterate tr/this/that/
5253 y/// string transliterate y/this/that/
5254 ($*@) sub prototypes sub foo ($)
5255 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
5257 In most of these cases (all but <>, patterns and transliterate)
5258 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
5259 calls scan_str(). s/// makes yylex() call scan_subst() which calls
5260 scan_str(). tr/// and y/// make yylex() call scan_trans() which
5263 It skips whitespace before the string starts, and treats the first
5264 character as the delimiter. If the delimiter is one of ([{< then
5265 the corresponding "close" character )]}> is used as the closing
5266 delimiter. It allows quoting of delimiters, and if the string has
5267 balanced delimiters ([{<>}]) it allows nesting.
5269 The lexer always reads these strings into lex_stuff, except in the
5270 case of the operators which take *two* arguments (s/// and tr///)
5271 when it checks to see if lex_stuff is full (presumably with the 1st
5272 arg to s or tr) and if so puts the string into lex_repl.
5277 scan_str(char *start)
5280 SV *sv; /* scalar value: string */
5281 char *tmps; /* temp string, used for delimiter matching */
5282 register char *s = start; /* current position in the buffer */
5283 register char term; /* terminating character */
5284 register char *to; /* current position in the sv's data */
5285 I32 brackets = 1; /* bracket nesting level */
5287 /* skip space before the delimiter */
5291 /* mark where we are, in case we need to report errors */
5294 /* after skipping whitespace, the next character is the terminator */
5296 /* mark where we are */
5297 multi_start = curcop->cop_line;
5300 /* find corresponding closing delimiter */
5301 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5305 /* create a new SV to hold the contents. 87 is leak category, I'm
5306 assuming. 80 is the SV's initial length. What a random number. */
5308 sv_upgrade(sv, SVt_PVIV);
5310 (void)SvPOK_only(sv); /* validate pointer */
5312 /* move past delimiter and try to read a complete string */
5315 /* extend sv if need be */
5316 SvGROW(sv, SvCUR(sv) + (bufend - s) + 1);
5317 /* set 'to' to the next character in the sv's string */
5318 to = SvPVX(sv)+SvCUR(sv);
5320 /* if open delimiter is the close delimiter read unbridle */
5321 if (multi_open == multi_close) {
5322 for (; s < bufend; s++,to++) {
5323 /* embedded newlines increment the current line number */
5324 if (*s == '\n' && !rsfp)
5326 /* handle quoted delimiters */
5327 if (*s == '\\' && s+1 < bufend && term != '\\') {
5330 /* any other quotes are simply copied straight through */
5334 /* terminate when run out of buffer (the for() condition), or
5335 have found the terminator */
5336 else if (*s == term)
5342 /* if the terminator isn't the same as the start character (e.g.,
5343 matched brackets), we have to allow more in the quoting, and
5344 be prepared for nested brackets.
5347 /* read until we run out of string, or we find the terminator */
5348 for (; s < bufend; s++,to++) {
5349 /* embedded newlines increment the line count */
5350 if (*s == '\n' && !rsfp)
5352 /* backslashes can escape the open or closing characters */
5353 if (*s == '\\' && s+1 < bufend) {
5354 if ((s[1] == multi_open) || (s[1] == multi_close))
5359 /* allow nested opens and closes */
5360 else if (*s == multi_close && --brackets <= 0)
5362 else if (*s == multi_open)
5367 /* terminate the copied string and update the sv's end-of-string */
5369 SvCUR_set(sv, to - SvPVX(sv));
5372 * this next chunk reads more into the buffer if we're not done yet
5375 if (s < bufend) break; /* handle case where we are done yet :-) */
5377 /* if we're out of file, or a read fails, bail and reset the current
5378 line marker so we can report where the unterminated string began
5381 !(oldoldbufptr = oldbufptr = s = linestart = filter_gets(linestr, rsfp, 0))) {
5383 curcop->cop_line = multi_start;
5386 /* we read a line, so increment our line counter */
5389 /* update debugger info */
5390 if (PERLDB_LINE && curstash != debstash) {
5391 SV *sv = NEWSV(88,0);
5393 sv_upgrade(sv, SVt_PVMG);
5394 sv_setsv(sv,linestr);
5395 av_store(GvAV(curcop->cop_filegv),
5396 (I32)curcop->cop_line, sv);
5399 /* having changed the buffer, we must update bufend */
5400 bufend = SvPVX(linestr) + SvCUR(linestr);
5403 /* at this point, we have successfully read the delimited string */
5405 multi_end = curcop->cop_line;
5408 /* if we allocated too much space, give some back */
5409 if (SvCUR(sv) + 5 < SvLEN(sv)) {
5410 SvLEN_set(sv, SvCUR(sv) + 1);
5411 Renew(SvPVX(sv), SvLEN(sv), char);
5414 /* decide whether this is the first or second quoted string we've read
5427 takes: pointer to position in buffer
5428 returns: pointer to new position in buffer
5429 side-effects: builds ops for the constant in yylval.op
5431 Read a number in any of the formats that Perl accepts:
5433 0(x[0-7A-F]+)|([0-7]+)
5434 [\d_]+(\.[\d_]*)?[Ee](\d+)
5436 Underbars (_) are allowed in decimal numbers. If -w is on,
5437 underbars before a decimal point must be at three digit intervals.
5439 Like most scan_ routines, it uses the tokenbuf buffer to hold the
5442 If it reads a number without a decimal point or an exponent, it will
5443 try converting the number to an integer and see if it can do so
5444 without loss of precision.
5448 scan_num(char *start)
5450 register char *s = start; /* current position in buffer */
5451 register char *d; /* destination in temp buffer */
5452 register char *e; /* end of temp buffer */
5453 I32 tryiv; /* used to see if it can be an int */
5454 double value; /* number read, as a double */
5455 SV *sv; /* place to put the converted number */
5456 I32 floatit; /* boolean: int or float? */
5457 char *lastub = 0; /* position of last underbar */
5458 static char number_too_long[] = "Number too long";
5460 /* We use the first character to decide what type of number this is */
5464 croak("panic: scan_num");
5466 /* if it starts with a 0, it could be an octal number, a decimal in
5467 0.13 disguise, or a hexadecimal number.
5472 u holds the "number so far"
5473 shift the power of 2 of the base (hex == 4, octal == 3)
5474 overflowed was the number more than we can hold?
5476 Shift is used when we add a digit. It also serves as an "are
5477 we in octal or hex?" indicator to disallow hex characters when
5482 bool overflowed = FALSE;
5489 /* check for a decimal in disguise */
5490 else if (s[1] == '.')
5492 /* so it must be octal */
5497 /* read the rest of the octal number */
5499 UV n, b; /* n is used in the overflow test, b is the digit we're adding on */
5503 /* if we don't mention it, we're done */
5512 /* 8 and 9 are not octal */
5515 yyerror("Illegal octal digit");
5519 case '0': case '1': case '2': case '3': case '4':
5520 case '5': case '6': case '7':
5521 b = *s++ & 15; /* ASCII digit -> value of digit */
5525 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
5526 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
5527 /* make sure they said 0x */
5532 /* Prepare to put the digit we have onto the end
5533 of the number so far. We check for overflows.
5537 n = u << shift; /* make room for the digit */
5538 if (!overflowed && (n >> shift) != u) {
5539 warn("Integer overflow in %s number",
5540 (shift == 4) ? "hex" : "octal");
5543 u = n | b; /* add the digit to the end */
5548 /* if we get here, we had success: make a scalar value from
5558 handle decimal numbers.
5559 we're also sent here when we read a 0 as the first digit
5561 case '1': case '2': case '3': case '4': case '5':
5562 case '6': case '7': case '8': case '9': case '.':
5565 e = tokenbuf + sizeof tokenbuf - 6; /* room for various punctuation */
5568 /* read next group of digits and _ and copy into d */
5569 while (isDIGIT(*s) || *s == '_') {
5570 /* skip underscores, checking for misplaced ones
5574 if (dowarn && lastub && s - lastub != 3)
5575 warn("Misplaced _ in number");
5579 /* check for end of fixed-length buffer */
5581 croak(number_too_long);
5582 /* if we're ok, copy the character */
5587 /* final misplaced underbar check */
5588 if (dowarn && lastub && s - lastub != 3)
5589 warn("Misplaced _ in number");
5591 /* read a decimal portion if there is one. avoid
5592 3..5 being interpreted as the number 3. followed
5595 if (*s == '.' && s[1] != '.') {
5599 /* copy, ignoring underbars, until we run out of
5600 digits. Note: no misplaced underbar checks!
5602 for (; isDIGIT(*s) || *s == '_'; s++) {
5603 /* fixed length buffer check */
5605 croak(number_too_long);
5611 /* read exponent part, if present */
5612 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
5616 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
5617 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
5619 /* allow positive or negative exponent */
5620 if (*s == '+' || *s == '-')
5623 /* read digits of exponent (no underbars :-) */
5624 while (isDIGIT(*s)) {
5626 croak(number_too_long);
5631 /* terminate the string */
5634 /* make an sv from the string */
5636 /* reset numeric locale in case we were earlier left in Swaziland */
5637 SET_NUMERIC_STANDARD();
5638 value = atof(tokenbuf);
5641 See if we can make do with an integer value without loss of
5642 precision. We use I_V to cast to an int, because some
5643 compilers have issues. Then we try casting it back and see
5644 if it was the same. We only do this if we know we
5645 specifically read an integer.
5647 Note: if floatit is true, then we don't need to do the
5651 if (!floatit && (double)tryiv == value)
5652 sv_setiv(sv, tryiv);
5654 sv_setnv(sv, value);
5658 /* make the op for the constant and return */
5660 yylval.opval = newSVOP(OP_CONST, 0, sv);
5666 scan_formline(register char *s)
5671 SV *stuff = newSVpv("",0);
5672 bool needargs = FALSE;
5675 if (*s == '.' || *s == '}') {
5677 for (t = s+1; *t == ' ' || *t == '\t'; t++) ;
5681 if (in_eval && !rsfp) {
5682 eol = strchr(s,'\n');
5687 eol = bufend = SvPVX(linestr) + SvCUR(linestr);
5689 for (t = s; t < eol; t++) {
5690 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
5692 goto enough; /* ~~ must be first line in formline */
5694 if (*t == '@' || *t == '^')
5697 sv_catpvn(stuff, s, eol-s);
5701 s = filter_gets(linestr, rsfp, 0);
5702 oldoldbufptr = oldbufptr = bufptr = linestart = SvPVX(linestr);
5703 bufend = bufptr + SvCUR(linestr);
5706 yyerror("Format not terminated");
5716 lex_state = LEX_NORMAL;
5717 nextval[nexttoke].ival = 0;
5721 lex_state = LEX_FORMLINE;
5722 nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
5724 nextval[nexttoke].ival = OP_FORMLINE;
5728 SvREFCNT_dec(stuff);
5740 cshlen = strlen(cshname);
5745 start_subparse(I32 is_format, U32 flags)
5748 I32 oldsavestack_ix = savestack_ix;
5749 CV* outsidecv = compcv;
5753 assert(SvTYPE(compcv) == SVt_PVCV);
5760 SAVESPTR(comppad_name);
5762 SAVEI32(comppad_name_fill);
5763 SAVEI32(min_intro_pending);
5764 SAVEI32(max_intro_pending);
5765 SAVEI32(pad_reset_pending);
5767 compcv = (CV*)NEWSV(1104,0);
5768 sv_upgrade((SV *)compcv, is_format ? SVt_PVFM : SVt_PVCV);
5769 CvFLAGS(compcv) |= flags;
5772 av_push(comppad, Nullsv);
5773 curpad = AvARRAY(comppad);
5774 comppad_name = newAV();
5775 comppad_name_fill = 0;
5776 min_intro_pending = 0;
5778 subline = curcop->cop_line;
5780 av_store(comppad_name, 0, newSVpv("@_", 2));
5781 curpad[0] = (SV*)newAV();
5782 SvPADMY_on(curpad[0]); /* XXX Needed? */
5783 CvOWNER(compcv) = 0;
5784 New(666, CvMUTEXP(compcv), 1, perl_mutex);
5785 MUTEX_INIT(CvMUTEXP(compcv));
5786 #endif /* USE_THREADS */
5788 comppadlist = newAV();
5789 AvREAL_off(comppadlist);
5790 av_store(comppadlist, 0, (SV*)comppad_name);
5791 av_store(comppadlist, 1, (SV*)comppad);
5793 CvPADLIST(compcv) = comppadlist;
5794 CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc(outsidecv);
5796 CvOWNER(compcv) = 0;
5797 New(666, CvMUTEXP(compcv), 1, perl_mutex);
5798 MUTEX_INIT(CvMUTEXP(compcv));
5799 #endif /* USE_THREADS */
5801 return oldsavestack_ix;
5820 char *context = NULL;
5824 if (!yychar || (yychar == ';' && !rsfp))
5826 else if (bufptr > oldoldbufptr && bufptr - oldoldbufptr < 200 &&
5827 oldoldbufptr != oldbufptr && oldbufptr != bufptr) {
5828 while (isSPACE(*oldoldbufptr))
5830 context = oldoldbufptr;
5831 contlen = bufptr - oldoldbufptr;
5833 else if (bufptr > oldbufptr && bufptr - oldbufptr < 200 &&
5834 oldbufptr != bufptr) {
5835 while (isSPACE(*oldbufptr))
5837 context = oldbufptr;
5838 contlen = bufptr - oldbufptr;
5840 else if (yychar > 255)
5841 where = "next token ???";
5842 else if ((yychar & 127) == 127) {
5843 if (lex_state == LEX_NORMAL ||
5844 (lex_state == LEX_KNOWNEXT && lex_defer == LEX_NORMAL))
5845 where = "at end of line";
5847 where = "within pattern";
5849 where = "within string";
5852 SV *where_sv = sv_2mortal(newSVpv("next char ", 0));
5854 sv_catpvf(where_sv, "^%c", toCTRL(yychar));
5855 else if (isPRINT_LC(yychar))
5856 sv_catpvf(where_sv, "%c", yychar);
5858 sv_catpvf(where_sv, "\\%03o", yychar & 255);
5859 where = SvPVX(where_sv);
5861 msg = sv_2mortal(newSVpv(s, 0));
5862 sv_catpvf(msg, " at %_ line %ld, ",
5863 GvSV(curcop->cop_filegv), (long)curcop->cop_line);
5865 sv_catpvf(msg, "near \"%.*s\"\n", contlen, context);
5867 sv_catpvf(msg, "%s\n", where);
5868 if (multi_start < multi_end && (U32)(curcop->cop_line - multi_end) <= 1) {
5870 " (Might be a runaway multi-line %c%c string starting on line %ld)\n",
5871 (int)multi_open,(int)multi_close,(long)multi_start);
5877 sv_catsv(ERRSV, msg);
5879 PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
5880 if (++error_count >= 10)
5881 croak("%_ has too many errors.\n", GvSV(curcop->cop_filegv));
5883 in_my_stash = Nullhv;