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
14 #define TMP_CRLF_PATCH
20 static void check_uni _((void));
21 static void force_next _((I32 type));
22 static char *force_version _((char *start));
23 static char *force_word _((char *start, int token, int check_keyword, int allow_pack, int allow_tick));
24 static SV *tokeq _((SV *sv));
25 static char *scan_const _((char *start));
26 static char *scan_formline _((char *s));
27 static char *scan_heredoc _((char *s));
28 static char *scan_ident _((char *s, char *send, char *dest, STRLEN destlen,
30 static char *scan_inputsymbol _((char *start));
31 static char *scan_pat _((char *start, I32 type));
32 static char *scan_str _((char *start));
33 static char *scan_subst _((char *start));
34 static char *scan_trans _((char *start));
35 static char *scan_word _((char *s, char *dest, STRLEN destlen,
36 int allow_package, STRLEN *slp));
37 static char *skipspace _((char *s));
38 static void checkcomma _((char *s, char *name, char *what));
39 static void force_ident _((char *s, int kind));
40 static void incline _((char *s));
41 static int intuit_method _((char *s, GV *gv));
42 static int intuit_more _((char *s));
43 static I32 lop _((I32 f, expectation x, char *s));
44 static void missingterm _((char *s));
45 static void no_op _((char *what, char *s));
46 static void set_csh _((void));
47 static I32 sublex_done _((void));
48 static I32 sublex_push _((void));
49 static I32 sublex_start _((void));
51 static int uni _((I32 f, char *s));
53 static char * filter_gets _((SV *sv, PerlIO *fp, STRLEN append));
54 static void restore_rsfp _((void *f));
55 static SV *new_constant _((char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type));
56 static void restore_expect _((void *e));
57 static void restore_lex_expect _((void *e));
58 #endif /* PERL_OBJECT */
60 static char ident_too_long[] = "Identifier too long";
62 /* The following are arranged oddly so that the guard on the switch statement
63 * can get by with a single comparison (if the compiler is smart enough).
66 /* #define LEX_NOTPARSING 11 is done in perl.h. */
69 #define LEX_INTERPNORMAL 9
70 #define LEX_INTERPCASEMOD 8
71 #define LEX_INTERPPUSH 7
72 #define LEX_INTERPSTART 6
73 #define LEX_INTERPEND 5
74 #define LEX_INTERPENDMAYBE 4
75 #define LEX_INTERPCONCAT 3
76 #define LEX_INTERPCONST 2
77 #define LEX_FORMLINE 1
78 #define LEX_KNOWNEXT 0
87 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
89 # include <unistd.h> /* Needed for execv() */
102 #define CLINE (copline = (curcop->cop_line < copline ? curcop->cop_line : copline))
104 #define TOKEN(retval) return (bufptr = s,(int)retval)
105 #define OPERATOR(retval) return (expect = XTERM,bufptr = s,(int)retval)
106 #define AOPERATOR(retval) return ao((expect = XTERM,bufptr = s,(int)retval))
107 #define PREBLOCK(retval) return (expect = XBLOCK,bufptr = s,(int)retval)
108 #define PRETERMBLOCK(retval) return (expect = XTERMBLOCK,bufptr = s,(int)retval)
109 #define PREREF(retval) return (expect = XREF,bufptr = s,(int)retval)
110 #define TERM(retval) return (CLINE, expect = XOPERATOR,bufptr = s,(int)retval)
111 #define LOOPX(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)LOOPEX)
112 #define FTST(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)UNIOP)
113 #define FUN0(f) return(yylval.ival = f,expect = XOPERATOR,bufptr = s,(int)FUNC0)
114 #define FUN1(f) return(yylval.ival = f,expect = XOPERATOR,bufptr = s,(int)FUNC1)
115 #define BOop(f) return ao((yylval.ival=f,expect = XTERM,bufptr = s,(int)BITOROP))
116 #define BAop(f) return ao((yylval.ival=f,expect = XTERM,bufptr = s,(int)BITANDOP))
117 #define SHop(f) return ao((yylval.ival=f,expect = XTERM,bufptr = s,(int)SHIFTOP))
118 #define PWop(f) return ao((yylval.ival=f,expect = XTERM,bufptr = s,(int)POWOP))
119 #define PMop(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)MATCHOP)
120 #define Aop(f) return ao((yylval.ival=f,expect = XTERM,bufptr = s,(int)ADDOP))
121 #define Mop(f) return ao((yylval.ival=f,expect = XTERM,bufptr = s,(int)MULOP))
122 #define Eop(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)EQOP)
123 #define Rop(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)RELOP)
125 /* This bit of chicanery makes a unary function followed by
126 * a parenthesis into a function with one argument, highest precedence.
128 #define UNI(f) return(yylval.ival = f, \
131 last_uni = oldbufptr, \
133 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
135 #define UNIBRACK(f) return(yylval.ival = f, \
137 last_uni = oldbufptr, \
138 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
140 /* grandfather return to old style */
141 #define OLDLOP(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)LSTOP)
146 if (*bufptr == '=') {
148 if (toketype == ANDAND)
149 yylval.ival = OP_ANDASSIGN;
150 else if (toketype == OROR)
151 yylval.ival = OP_ORASSIGN;
158 no_op(char *what, char *s)
160 char *oldbp = bufptr;
161 bool is_first = (oldbufptr == linestart);
164 yywarn(form("%s found where operator expected", what));
166 warn("\t(Missing semicolon on previous line?)\n");
167 else if (oldoldbufptr && isIDFIRST(*oldoldbufptr)) {
169 for (t = oldoldbufptr; *t && (isALNUM(*t) || *t == ':'); t++) ;
170 if (t < bufptr && isSPACE(*t))
171 warn("\t(Do you need to predeclare %.*s?)\n",
172 t - oldoldbufptr, oldoldbufptr);
176 warn("\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
186 char *nl = strrchr(s,'\n');
190 else if (multi_close < 32 || multi_close == 127) {
192 tmpbuf[1] = toCTRL(multi_close);
198 *tmpbuf = multi_close;
202 q = strchr(s,'"') ? '\'' : '"';
203 croak("Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
210 warn("Use of %s is deprecated", s);
216 deprecate("comma-less variable list");
222 win32_textfilter(int idx, SV *sv, int maxlen)
224 I32 count = FILTER_READ(idx+1, sv, maxlen);
225 if (count > 0 && !maxlen)
226 win32_strip_return(sv);
240 SAVEI32(lex_brackets);
241 SAVEI32(lex_fakebrack);
242 SAVEI32(lex_casemods);
247 SAVEI16(curcop->cop_line);
251 SAVEPPTR(oldoldbufptr);
254 SAVEPPTR(lex_brackstack);
255 SAVEPPTR(lex_casestack);
256 SAVEDESTRUCTOR(restore_rsfp, rsfp);
260 SAVEDESTRUCTOR(restore_expect, tokenbuf + expect); /* encode as pointer */
261 SAVEDESTRUCTOR(restore_lex_expect, tokenbuf + expect);
263 lex_state = LEX_NORMAL;
268 New(899, lex_brackstack, 120, char);
269 New(899, lex_casestack, 12, char);
270 SAVEFREEPV(lex_brackstack);
271 SAVEFREEPV(lex_casestack);
273 *lex_casestack = '\0';
281 if (SvREADONLY(linestr))
282 linestr = sv_2mortal(newSVsv(linestr));
283 s = SvPV(linestr, len);
284 if (len && s[len-1] != ';') {
285 if (!(SvFLAGS(linestr) & SVs_TEMP))
286 linestr = sv_2mortal(newSVsv(linestr));
287 sv_catpvn(linestr, "\n;", 2);
290 oldoldbufptr = oldbufptr = bufptr = linestart = SvPVX(linestr);
291 bufend = bufptr + SvCUR(linestr);
293 rs = newSVpv("\n", 1);
304 restore_rsfp(void *f)
306 PerlIO *fp = (PerlIO*)f;
308 if (rsfp == PerlIO_stdin())
309 PerlIO_clearerr(rsfp);
310 else if (rsfp && (rsfp != fp))
316 restore_expect(void *e)
318 /* a safe way to store a small integer in a pointer */
319 expect = (expectation)((char *)e - tokenbuf);
323 restore_lex_expect(void *e)
325 /* a safe way to store a small integer in a pointer */
326 lex_expect = (expectation)((char *)e - tokenbuf);
341 while (*s == ' ' || *s == '\t') s++;
342 if (strnEQ(s, "line ", 5)) {
351 while (*s == ' ' || *s == '\t')
353 if (*s == '"' && (t = strchr(s+1, '"')))
357 return; /* false alarm */
358 for (t = s; !isSPACE(*t); t++) ;
363 curcop->cop_filegv = gv_fetchfile(s);
365 curcop->cop_filegv = gv_fetchfile(origfilename);
367 curcop->cop_line = atoi(n)-1;
371 skipspace(register char *s)
374 if (lex_formbrack && lex_brackets <= lex_formbrack) {
375 while (s < bufend && (*s == ' ' || *s == '\t'))
381 while (s < bufend && isSPACE(*s))
383 if (s < bufend && *s == '#') {
384 while (s < bufend && *s != '\n')
389 if (s < bufend || !rsfp || lex_state != LEX_NORMAL)
391 if ((s = filter_gets(linestr, rsfp, (prevlen = SvCUR(linestr)))) == Nullch) {
392 if (minus_n || minus_p) {
393 sv_setpv(linestr,minus_p ?
394 ";}continue{print or die qq(-p destination: $!\\n)" :
396 sv_catpv(linestr,";}");
397 minus_n = minus_p = 0;
400 sv_setpv(linestr,";");
401 oldoldbufptr = oldbufptr = bufptr = s = linestart = SvPVX(linestr);
402 bufend = SvPVX(linestr) + SvCUR(linestr);
403 if (preprocess && !in_eval)
404 (void)PerlProc_pclose(rsfp);
405 else if ((PerlIO*)rsfp == PerlIO_stdin())
406 PerlIO_clearerr(rsfp);
408 (void)PerlIO_close(rsfp);
412 linestart = bufptr = s + prevlen;
413 bufend = s + SvCUR(linestr);
416 if (PERLDB_LINE && curstash != debstash) {
417 SV *sv = NEWSV(85,0);
419 sv_upgrade(sv, SVt_PVMG);
420 sv_setpvn(sv,bufptr,bufend-bufptr);
421 av_store(GvAV(curcop->cop_filegv),(I32)curcop->cop_line,sv);
432 if (oldoldbufptr != last_uni)
434 while (isSPACE(*last_uni))
436 for (s = last_uni; isALNUM(*s) || *s == '-'; s++) ;
437 if ((t = strchr(s, '(')) && t < bufptr)
441 warn("Warning: Use of \"%s\" without parens is ambiguous", last_uni);
448 #define UNI(f) return uni(f,s)
456 last_uni = oldbufptr;
467 #endif /* CRIPPLED_CC */
469 #define LOP(f,x) return lop(f,x,s)
472 lop(I32 f, expectation x, char *s)
479 last_lop = oldbufptr;
495 nexttype[nexttoke] = type;
497 if (lex_state != LEX_KNOWNEXT) {
498 lex_defer = lex_state;
500 lex_state = LEX_KNOWNEXT;
505 force_word(register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
510 start = skipspace(start);
513 (allow_pack && *s == ':') ||
514 (allow_initial_tick && *s == '\'') )
516 s = scan_word(s, tokenbuf, sizeof tokenbuf, allow_pack, &len);
517 if (check_keyword && keyword(tokenbuf, len))
519 if (token == METHOD) {
529 nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(tokenbuf,0));
530 nextval[nexttoke].opval->op_private |= OPpCONST_BARE;
537 force_ident(register char *s, int kind)
540 OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
541 nextval[nexttoke].opval = o;
544 dTHR; /* just for in_eval */
545 o->op_private = OPpCONST_ENTERED;
546 /* XXX see note in pp_entereval() for why we forgo typo
547 warnings if the symbol must be introduced in an eval.
549 gv_fetchpv(s, in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
550 kind == '$' ? SVt_PV :
551 kind == '@' ? SVt_PVAV :
552 kind == '%' ? SVt_PVHV :
560 force_version(char *s)
562 OP *version = Nullop;
566 /* default VERSION number -- GBARR */
571 for( d=s, c = 1; isDIGIT(*d) || *d == '_' || (*d == '.' && c--); d++);
572 if((*d == ';' || isSPACE(*d)) && *(skipspace(d)) != ',') {
574 /* real VERSION number -- GBARR */
575 version = yylval.opval;
579 /* NOTE: The parser sees the package name and the VERSION swapped */
580 nextval[nexttoke].opval = version;
598 s = SvPV_force(sv, len);
602 while (s < send && *s != '\\')
607 if ( hints & HINT_NEW_STRING )
608 pv = sv_2mortal(newSVpv(SvPVX(pv), len));
611 if (s + 1 < send && (s[1] == '\\'))
612 s++; /* all that, just for this */
617 SvCUR_set(sv, d - SvPVX(sv));
619 if ( hints & HINT_NEW_STRING )
620 return new_constant(NULL, 0, "q", sv, pv, "q");
627 register I32 op_type = yylval.ival;
629 if (op_type == OP_NULL) {
630 yylval.opval = lex_op;
634 if (op_type == OP_CONST || op_type == OP_READLINE) {
635 SV *sv = tokeq(lex_stuff);
637 if (SvTYPE(sv) == SVt_PVIV) {
638 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
644 nsv = newSVpv(p, len);
648 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
653 sublex_info.super_state = lex_state;
654 sublex_info.sub_inwhat = op_type;
655 sublex_info.sub_op = lex_op;
656 lex_state = LEX_INTERPPUSH;
660 yylval.opval = lex_op;
674 lex_state = sublex_info.super_state;
676 SAVEI32(lex_brackets);
677 SAVEI32(lex_fakebrack);
678 SAVEI32(lex_casemods);
683 SAVEI16(curcop->cop_line);
686 SAVEPPTR(oldoldbufptr);
689 SAVEPPTR(lex_brackstack);
690 SAVEPPTR(lex_casestack);
695 bufend = bufptr = oldbufptr = oldoldbufptr = linestart = SvPVX(linestr);
696 bufend += SvCUR(linestr);
702 New(899, lex_brackstack, 120, char);
703 New(899, lex_casestack, 12, char);
704 SAVEFREEPV(lex_brackstack);
705 SAVEFREEPV(lex_casestack);
707 *lex_casestack = '\0';
709 lex_state = LEX_INTERPCONCAT;
710 curcop->cop_line = multi_start;
712 lex_inwhat = sublex_info.sub_inwhat;
713 if (lex_inwhat == OP_MATCH || lex_inwhat == OP_QR || lex_inwhat == OP_SUBST)
714 lex_inpat = sublex_info.sub_op;
726 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv("",0));
730 if (lex_casemods) { /* oops, we've got some unbalanced parens */
731 lex_state = LEX_INTERPCASEMOD;
735 /* Is there a right-hand side to take care of? */
736 if (lex_repl && (lex_inwhat == OP_SUBST || lex_inwhat == OP_TRANS)) {
739 bufend = bufptr = oldbufptr = oldoldbufptr = linestart = SvPVX(linestr);
740 bufend += SvCUR(linestr);
746 *lex_casestack = '\0';
748 if (SvCOMPILED(lex_repl)) {
749 lex_state = LEX_INTERPNORMAL;
753 lex_state = LEX_INTERPCONCAT;
759 bufend = SvPVX(linestr);
760 bufend += SvCUR(linestr);
769 Extracts a pattern, double-quoted string, or transliteration. This
772 It looks at lex_inwhat and lex_inpat to find out whether it's
773 processing a pattern (lex_inpat is true), a transliteration
774 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
776 Returns a pointer to the character scanned up to. Iff this is
777 advanced from the start pointer supplied (ie if anything was
778 successfully parsed), will leave an OP for the substring scanned
779 in yylval. Caller must intuit reason for not parsing further
780 by looking at the next characters herself.
784 double-quoted style: \r and \n
785 regexp special ones: \D \s
787 backrefs: \1 (deprecated in substitution replacements)
788 case and quoting: \U \Q \E
789 stops on @ and $, but not for $ as tail anchor
792 characters are VERY literal, except for - not at the start or end
793 of the string, which indicates a range. scan_const expands the
794 range to the full set of intermediate characters.
796 In double-quoted strings:
798 double-quoted style: \r and \n
800 backrefs: \1 (deprecated)
801 case and quoting: \U \Q \E
804 scan_const does *not* construct ops to handle interpolated strings.
805 It stops processing as soon as it finds an embedded $ or @ variable
806 and leaves it to the caller to work out what's going on.
808 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
810 $ in pattern could be $foo or could be tail anchor. Assumption:
811 it's a tail anchor if $ is the last thing in the string, or if it's
812 followed by one of ")| \n\t"
814 \1 (backreferences) are turned into $1
816 The structure of the code is
817 while (there's a character to process) {
818 handle transliteration ranges
820 skip # initiated comments in //x patterns
821 check for embedded @foo
822 check for embedded scalars
824 leave intact backslashes from leave (below)
825 deprecate \1 in strings and sub replacements
826 handle string-changing backslashes \l \U \Q \E, etc.
827 switch (what was escaped) {
828 handle - in a transliteration (becomes a literal -)
829 handle \132 octal characters
830 handle 0x15 hex characters
831 handle \cV (control V)
832 handle printf backslashes (\f, \r, \n, etc)
835 } (end while character to read)
840 scan_const(char *start)
842 register char *send = bufend; /* end of the constant */
843 SV *sv = NEWSV(93, send - start); /* sv for the constant */
844 register char *s = start; /* start of the constant */
845 register char *d = SvPVX(sv); /* destination for copies */
846 bool dorange = FALSE; /* are we in a translit range? */
849 /* leaveit is the set of acceptably-backslashed characters */
852 ? "\\.^$@AGZdDwWsSbB+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
855 while (s < send || dorange) {
856 /* get transliterations out of the way (they're most literal) */
857 if (lex_inwhat == OP_TRANS) {
858 /* expand a range A-Z to the full set of characters. AIE! */
860 I32 i; /* current expanded character */
861 I32 max; /* last character in range */
863 i = d - SvPVX(sv); /* remember current offset */
864 SvGROW(sv, SvLEN(sv) + 256); /* expand the sv -- there'll never be more'n 256 chars in a range for it to grow by */
865 d = SvPVX(sv) + i; /* restore d after the grow potentially has changed the ptr */
866 d -= 2; /* eat the first char and the - */
868 max = (U8)d[1]; /* last char in range */
870 for (i = (U8)*d; i <= max; i++)
873 /* mark the range as done, and continue */
878 /* range begins (ignore - as first or last char) */
879 else if (*s == '-' && s+1 < send && s != start) {
885 /* if we get here, we're not doing a transliteration */
887 /* skip for regexp comments /(?#comment)/ */
888 else if (*s == '(' && lex_inpat && s[1] == '?') {
890 while (s < send && *s != ')')
892 } else if (s[2] == '{') { /* This should march regcomp.c */
894 char *regparse = s + 3;
897 while (count && (c = *regparse)) {
898 if (c == '\\' && regparse[1])
906 if (*regparse == ')')
909 yyerror("Sequence (?{...}) not terminated or not {}-balanced");
910 while (s < regparse && *s != ')')
915 /* likewise skip #-initiated comments in //x patterns */
916 else if (*s == '#' && lex_inpat &&
917 ((PMOP*)lex_inpat)->op_pmflags & PMf_EXTENDED) {
918 while (s+1 < send && *s != '\n')
922 /* check for embedded arrays (@foo, @:foo, @'foo, @{foo}, @$foo) */
923 else if (*s == '@' && s[1] && (isALNUM(s[1]) || strchr(":'{$", s[1])))
926 /* check for embedded scalars. only stop if we're sure it's a
929 else if (*s == '$') {
930 if (!lex_inpat) /* not a regexp, so $ must be var */
932 if (s + 1 < send && !strchr("()| \n\t", s[1]))
933 break; /* in regexp, $ might be tail anchor */
937 if (*s == '\\' && s+1 < send) {
940 /* some backslashes we leave behind */
941 if (*s && strchr(leaveit, *s)) {
947 /* deprecate \1 in strings and substitution replacements */
948 if (lex_inwhat == OP_SUBST && !lex_inpat &&
949 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
952 warn("\\%c better written as $%c", *s, *s);
957 /* string-change backslash escapes */
958 if (lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
963 /* if we get here, it's either a quoted -, or a digit */
966 /* quoted - in transliterations */
968 if (lex_inwhat == OP_TRANS) {
973 /* default action is to copy the quoted character */
978 /* \132 indicates an octal constant */
979 case '0': case '1': case '2': case '3':
980 case '4': case '5': case '6': case '7':
981 *d++ = scan_oct(s, 3, &len);
985 /* \x24 indicates a hex constant */
987 *d++ = scan_hex(++s, 2, &len);
991 /* \c is a control character */
998 /* printf-style backslashes, formfeeds, newlines, etc */
1024 } /* end if (backslash) */
1027 } /* while loop to process each character */
1029 /* terminate the string and set up the sv */
1031 SvCUR_set(sv, d - SvPVX(sv));
1034 /* shrink the sv if we allocated more than we used */
1035 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1036 SvLEN_set(sv, SvCUR(sv) + 1);
1037 Renew(SvPVX(sv), SvLEN(sv), char);
1040 /* return the substring (via yylval) only if we parsed anything */
1042 if ( hints & ( lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1043 sv = new_constant(start, s - start, (lex_inpat ? "qr" : "q"),
1045 ( lex_inwhat == OP_TRANS
1047 : ( (lex_inwhat == OP_SUBST && !lex_inpat)
1050 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1056 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1058 intuit_more(register char *s)
1062 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1064 if (*s != '{' && *s != '[')
1069 /* In a pattern, so maybe we have {n,m}. */
1086 /* On the other hand, maybe we have a character class */
1089 if (*s == ']' || *s == '^')
1092 int weight = 2; /* let's weigh the evidence */
1094 unsigned char un_char = 255, last_un_char;
1095 char *send = strchr(s,']');
1096 char tmpbuf[sizeof tokenbuf * 4];
1098 if (!send) /* has to be an expression */
1101 Zero(seen,256,char);
1104 else if (isDIGIT(*s)) {
1106 if (isDIGIT(s[1]) && s[2] == ']')
1112 for (; s < send; s++) {
1113 last_un_char = un_char;
1114 un_char = (unsigned char)*s;
1119 weight -= seen[un_char] * 10;
1120 if (isALNUM(s[1])) {
1121 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1122 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1127 else if (*s == '$' && s[1] &&
1128 strchr("[#!%*<>()-=",s[1])) {
1129 if (/*{*/ strchr("])} =",s[2]))
1138 if (strchr("wds]",s[1]))
1140 else if (seen['\''] || seen['"'])
1142 else if (strchr("rnftbxcav",s[1]))
1144 else if (isDIGIT(s[1])) {
1146 while (s[1] && isDIGIT(s[1]))
1156 if (strchr("aA01! ",last_un_char))
1158 if (strchr("zZ79~",s[1]))
1160 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1161 weight -= 5; /* cope with negative subscript */
1164 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1165 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1170 if (keyword(tmpbuf, d - tmpbuf))
1173 if (un_char == last_un_char + 1)
1175 weight -= seen[un_char];
1180 if (weight >= 0) /* probably a character class */
1188 intuit_method(char *start, GV *gv)
1190 char *s = start + (*start == '$');
1191 char tmpbuf[sizeof tokenbuf];
1199 if ((cv = GvCVu(gv))) {
1200 char *proto = SvPVX(cv);
1210 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1211 if (*start == '$') {
1212 if (gv || last_lop_op == OP_PRINT || isUPPER(*tokenbuf))
1217 return *s == '(' ? FUNCMETH : METHOD;
1219 if (!keyword(tmpbuf, len)) {
1220 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1225 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1226 if (indirgv && GvCVu(indirgv))
1228 /* filehandle or package name makes it a method */
1229 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1231 if ((bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1232 return 0; /* no assumptions -- "=>" quotes bearword */
1234 nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1236 nextval[nexttoke].opval->op_private = OPpCONST_BARE;
1240 return *s == '(' ? FUNCMETH : METHOD;
1250 char *pdb = PerlEnv_getenv("PERL5DB");
1254 SETERRNO(0,SS$_NORMAL);
1255 return "BEGIN { require 'perl5db.pl' }";
1261 /* Encoded script support. filter_add() effectively inserts a
1262 * 'pre-processing' function into the current source input stream.
1263 * Note that the filter function only applies to the current source file
1264 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1266 * The datasv parameter (which may be NULL) can be used to pass
1267 * private data to this instance of the filter. The filter function
1268 * can recover the SV using the FILTER_DATA macro and use it to
1269 * store private buffers and state information.
1271 * The supplied datasv parameter is upgraded to a PVIO type
1272 * and the IoDIRP field is used to store the function pointer.
1273 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1274 * private use must be set using malloc'd pointers.
1276 static int filter_debug = 0;
1279 filter_add(filter_t funcp, SV *datasv)
1281 if (!funcp){ /* temporary handy debugging hack to be deleted */
1282 filter_debug = atoi((char*)datasv);
1286 rsfp_filters = newAV();
1288 datasv = NEWSV(255,0);
1289 if (!SvUPGRADE(datasv, SVt_PVIO))
1290 die("Can't upgrade filter_add data to SVt_PVIO");
1291 IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
1293 warn("filter_add func %p (%s)", funcp, SvPV(datasv,na));
1294 av_unshift(rsfp_filters, 1);
1295 av_store(rsfp_filters, 0, datasv) ;
1300 /* Delete most recently added instance of this filter function. */
1302 filter_del(filter_t funcp)
1305 warn("filter_del func %p", funcp);
1306 if (!rsfp_filters || AvFILLp(rsfp_filters)<0)
1308 /* if filter is on top of stack (usual case) just pop it off */
1309 if (IoDIRP(FILTER_DATA(AvFILLp(rsfp_filters))) == (void*)funcp){
1310 sv_free(av_pop(rsfp_filters));
1314 /* we need to search for the correct entry and clear it */
1315 die("filter_del can only delete in reverse order (currently)");
1319 /* Invoke the n'th filter function for the current rsfp. */
1321 filter_read(int idx, SV *buf_sv, int maxlen)
1324 /* 0 = read one text line */
1331 if (idx > AvFILLp(rsfp_filters)){ /* Any more filters? */
1332 /* Provide a default input filter to make life easy. */
1333 /* Note that we append to the line. This is handy. */
1335 warn("filter_read %d: from rsfp\n", idx);
1339 int old_len = SvCUR(buf_sv) ;
1341 /* ensure buf_sv is large enough */
1342 SvGROW(buf_sv, old_len + maxlen) ;
1343 if ((len = PerlIO_read(rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1344 if (PerlIO_error(rsfp))
1345 return -1; /* error */
1347 return 0 ; /* end of file */
1349 SvCUR_set(buf_sv, old_len + len) ;
1352 if (sv_gets(buf_sv, rsfp, SvCUR(buf_sv)) == NULL) {
1353 if (PerlIO_error(rsfp))
1354 return -1; /* error */
1356 return 0 ; /* end of file */
1359 return SvCUR(buf_sv);
1361 /* Skip this filter slot if filter has been deleted */
1362 if ( (datasv = FILTER_DATA(idx)) == &sv_undef){
1364 warn("filter_read %d: skipped (filter deleted)\n", idx);
1365 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1367 /* Get function pointer hidden within datasv */
1368 funcp = (filter_t)IoDIRP(datasv);
1370 warn("filter_read %d: via function %p (%s)\n",
1371 idx, funcp, SvPV(datasv,na));
1372 /* Call function. The function is expected to */
1373 /* call "FILTER_READ(idx+1, buf_sv)" first. */
1374 /* Return: <0:error, =0:eof, >0:not eof */
1375 return (*funcp)(PERL_OBJECT_THIS_ idx, buf_sv, maxlen);
1379 filter_gets(register SV *sv, register PerlIO *fp, STRLEN append)
1382 if (!rsfp_filters) {
1383 filter_add(win32_textfilter,NULL);
1389 SvCUR_set(sv, 0); /* start with empty line */
1390 if (FILTER_READ(0, sv, 0) > 0)
1391 return ( SvPVX(sv) ) ;
1396 return (sv_gets(sv, fp, append));
1401 static char* exp_name[] =
1402 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "TERMBLOCK" };
1405 EXT int yychar; /* last token */
1410 Works out what to call the token just pulled out of the input
1411 stream. The yacc parser takes care of taking the ops we return and
1412 stitching them into a tree.
1418 if read an identifier
1419 if we're in a my declaration
1420 croak if they tried to say my($foo::bar)
1421 build the ops for a my() declaration
1422 if it's an access to a my() variable
1423 are we in a sort block?
1424 croak if my($a); $a <=> $b
1425 build ops for access to a my() variable
1426 if in a dq string, and they've said @foo and we can't find @foo
1428 build ops for a bareword
1429 if we already built the token before, use it.
1443 /* check if there's an identifier for us to look at */
1444 if (pending_ident) {
1445 /* pit holds the identifier we read and pending_ident is reset */
1446 char pit = pending_ident;
1449 /* if we're in a my(), we can't allow dynamics here.
1450 $foo'bar has already been turned into $foo::bar, so
1451 just check for colons.
1453 if it's a legal name, the OP is a PADANY.
1456 if (strchr(tokenbuf,':'))
1457 croak(no_myglob,tokenbuf);
1459 yylval.opval = newOP(OP_PADANY, 0);
1460 yylval.opval->op_targ = pad_allocmy(tokenbuf);
1465 build the ops for accesses to a my() variable.
1467 Deny my($a) or my($b) in a sort block, *if* $a or $b is
1468 then used in a comparison. This catches most, but not
1469 all cases. For instance, it catches
1470 sort { my($a); $a <=> $b }
1472 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
1473 (although why you'd do that is anyone's guess).
1476 if (!strchr(tokenbuf,':')) {
1478 /* Check for single character per-thread SVs */
1479 if (tokenbuf[0] == '$' && tokenbuf[2] == '\0'
1480 && !isALPHA(tokenbuf[1]) /* Rule out obvious non-threadsvs */
1481 && (tmp = find_threadsv(&tokenbuf[1])) != NOT_IN_PAD)
1483 yylval.opval = newOP(OP_THREADSV, 0);
1484 yylval.opval->op_targ = tmp;
1487 #endif /* USE_THREADS */
1488 if ((tmp = pad_findmy(tokenbuf)) != NOT_IN_PAD) {
1489 /* if it's a sort block and they're naming $a or $b */
1490 if (last_lop_op == OP_SORT &&
1491 tokenbuf[0] == '$' &&
1492 (tokenbuf[1] == 'a' || tokenbuf[1] == 'b')
1495 for (d = in_eval ? oldoldbufptr : linestart;
1496 d < bufend && *d != '\n';
1499 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
1500 croak("Can't use \"my %s\" in sort comparison",
1506 yylval.opval = newOP(OP_PADANY, 0);
1507 yylval.opval->op_targ = tmp;
1513 Whine if they've said @foo in a doublequoted string,
1514 and @foo isn't a variable we can find in the symbol
1517 if (pit == '@' && lex_state != LEX_NORMAL && !lex_brackets) {
1518 GV *gv = gv_fetchpv(tokenbuf+1, FALSE, SVt_PVAV);
1519 if (!gv || ((tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
1520 yyerror(form("In string, %s now must be written as \\%s",
1521 tokenbuf, tokenbuf));
1524 /* build ops for a bareword */
1525 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(tokenbuf+1, 0));
1526 yylval.opval->op_private = OPpCONST_ENTERED;
1527 gv_fetchpv(tokenbuf+1, in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
1528 ((tokenbuf[0] == '$') ? SVt_PV
1529 : (tokenbuf[0] == '@') ? SVt_PVAV
1534 /* no identifier pending identification */
1536 switch (lex_state) {
1538 case LEX_NORMAL: /* Some compilers will produce faster */
1539 case LEX_INTERPNORMAL: /* code if we comment these out. */
1543 /* when we're already built the next token, just pull it out the queue */
1546 yylval = nextval[nexttoke];
1548 lex_state = lex_defer;
1549 expect = lex_expect;
1550 lex_defer = LEX_NORMAL;
1552 return(nexttype[nexttoke]);
1554 /* interpolated case modifiers like \L \U, including \Q and \E.
1555 when we get here, bufptr is at the \
1557 case LEX_INTERPCASEMOD:
1559 if (bufptr != bufend && *bufptr != '\\')
1560 croak("panic: INTERPCASEMOD");
1562 /* handle \E or end of string */
1563 if (bufptr == bufend || bufptr[1] == 'E') {
1568 oldmod = lex_casestack[--lex_casemods];
1569 lex_casestack[lex_casemods] = '\0';
1571 if (bufptr != bufend && strchr("LUQ", oldmod)) {
1573 lex_state = LEX_INTERPCONCAT;
1577 if (bufptr != bufend)
1579 lex_state = LEX_INTERPCONCAT;
1584 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
1585 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
1586 if (strchr("LU", *s) &&
1587 (strchr(lex_casestack, 'L') || strchr(lex_casestack, 'U')))
1589 lex_casestack[--lex_casemods] = '\0';
1592 if (lex_casemods > 10) {
1593 char* newlb = Renew(lex_casestack, lex_casemods + 2, char);
1594 if (newlb != lex_casestack) {
1596 lex_casestack = newlb;
1599 lex_casestack[lex_casemods++] = *s;
1600 lex_casestack[lex_casemods] = '\0';
1601 lex_state = LEX_INTERPCONCAT;
1602 nextval[nexttoke].ival = 0;
1605 nextval[nexttoke].ival = OP_LCFIRST;
1607 nextval[nexttoke].ival = OP_UCFIRST;
1609 nextval[nexttoke].ival = OP_LC;
1611 nextval[nexttoke].ival = OP_UC;
1613 nextval[nexttoke].ival = OP_QUOTEMETA;
1615 croak("panic: yylex");
1627 case LEX_INTERPPUSH:
1628 return sublex_push();
1630 case LEX_INTERPSTART:
1631 if (bufptr == bufend)
1632 return sublex_done();
1634 lex_dojoin = (*bufptr == '@');
1635 lex_state = LEX_INTERPNORMAL;
1637 nextval[nexttoke].ival = 0;
1640 nextval[nexttoke].opval = newOP(OP_THREADSV, 0);
1641 nextval[nexttoke].opval->op_targ = find_threadsv("\"");
1642 force_next(PRIVATEREF);
1644 force_ident("\"", '$');
1645 #endif /* USE_THREADS */
1646 nextval[nexttoke].ival = 0;
1648 nextval[nexttoke].ival = 0;
1650 nextval[nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
1659 case LEX_INTERPENDMAYBE:
1660 if (intuit_more(bufptr)) {
1661 lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
1669 lex_state = LEX_INTERPCONCAT;
1673 case LEX_INTERPCONCAT:
1676 croak("panic: INTERPCONCAT");
1678 if (bufptr == bufend)
1679 return sublex_done();
1681 if (SvIVX(linestr) == '\'') {
1682 SV *sv = newSVsv(linestr);
1685 else if ( hints & HINT_NEW_RE )
1686 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
1687 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1691 s = scan_const(bufptr);
1693 lex_state = LEX_INTERPCASEMOD;
1695 lex_state = LEX_INTERPSTART;
1699 nextval[nexttoke] = yylval;
1712 lex_state = LEX_NORMAL;
1713 s = scan_formline(bufptr);
1720 oldoldbufptr = oldbufptr;
1723 PerlIO_printf(PerlIO_stderr(), "### Tokener expecting %s at %s\n", exp_name[expect], s);
1729 croak("Unrecognized character \\%03o", *s & 255);
1732 goto fake_eof; /* emulate EOF on ^D or ^Z */
1738 yyerror("Missing right bracket");
1742 goto retry; /* ignore stray nulls */
1745 if (!in_eval && !preambled) {
1747 sv_setpv(linestr,incl_perldb());
1749 sv_catpv(linestr,";");
1751 while(AvFILLp(preambleav) >= 0) {
1752 SV *tmpsv = av_shift(preambleav);
1753 sv_catsv(linestr, tmpsv);
1754 sv_catpv(linestr, ";");
1757 sv_free((SV*)preambleav);
1760 if (minus_n || minus_p) {
1761 sv_catpv(linestr, "LINE: while (<>) {");
1763 sv_catpv(linestr,"chomp;");
1765 GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
1767 GvIMPORTED_AV_on(gv);
1769 if (strchr("/'\"", *splitstr)
1770 && strchr(splitstr + 1, *splitstr))
1771 sv_catpvf(linestr, "@F=split(%s);", splitstr);
1774 s = "'~#\200\1'"; /* surely one char is unused...*/
1775 while (s[1] && strchr(splitstr, *s)) s++;
1777 sv_catpvf(linestr, "@F=split(%s%c",
1778 "q" + (delim == '\''), delim);
1779 for (s = splitstr; *s; s++) {
1781 sv_catpvn(linestr, "\\", 1);
1782 sv_catpvn(linestr, s, 1);
1784 sv_catpvf(linestr, "%c);", delim);
1788 sv_catpv(linestr,"@F=split(' ');");
1791 sv_catpv(linestr, "\n");
1792 oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr);
1793 bufend = SvPVX(linestr) + SvCUR(linestr);
1794 if (PERLDB_LINE && curstash != debstash) {
1795 SV *sv = NEWSV(85,0);
1797 sv_upgrade(sv, SVt_PVMG);
1798 sv_setsv(sv,linestr);
1799 av_store(GvAV(curcop->cop_filegv),(I32)curcop->cop_line,sv);
1804 if ((s = filter_gets(linestr, rsfp, 0)) == Nullch) {
1807 if (preprocess && !in_eval)
1808 (void)PerlProc_pclose(rsfp);
1809 else if ((PerlIO *)rsfp == PerlIO_stdin())
1810 PerlIO_clearerr(rsfp);
1812 (void)PerlIO_close(rsfp);
1815 if (!in_eval && (minus_n || minus_p)) {
1816 sv_setpv(linestr,minus_p ? ";}continue{print" : "");
1817 sv_catpv(linestr,";}");
1818 oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr);
1819 bufend = SvPVX(linestr) + SvCUR(linestr);
1820 minus_n = minus_p = 0;
1823 oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr);
1824 sv_setpv(linestr,"");
1825 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
1828 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
1831 /* Incest with pod. */
1832 if (*s == '=' && strnEQ(s, "=cut", 4)) {
1833 sv_setpv(linestr, "");
1834 oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr);
1835 bufend = SvPVX(linestr) + SvCUR(linestr);
1840 } while (doextract);
1841 oldoldbufptr = oldbufptr = bufptr = linestart = s;
1842 if (PERLDB_LINE && curstash != debstash) {
1843 SV *sv = NEWSV(85,0);
1845 sv_upgrade(sv, SVt_PVMG);
1846 sv_setsv(sv,linestr);
1847 av_store(GvAV(curcop->cop_filegv),(I32)curcop->cop_line,sv);
1849 bufend = SvPVX(linestr) + SvCUR(linestr);
1850 if (curcop->cop_line == 1) {
1851 while (s < bufend && isSPACE(*s))
1853 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
1857 if (*s == '#' && *(s+1) == '!')
1859 #ifdef ALTERNATE_SHEBANG
1861 static char as[] = ALTERNATE_SHEBANG;
1862 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
1863 d = s + (sizeof(as) - 1);
1865 #endif /* ALTERNATE_SHEBANG */
1874 while (*d && !isSPACE(*d))
1878 #ifdef ARG_ZERO_IS_SCRIPT
1879 if (ipathend > ipath) {
1881 * HP-UX (at least) sets argv[0] to the script name,
1882 * which makes $^X incorrect. And Digital UNIX and Linux,
1883 * at least, set argv[0] to the basename of the Perl
1884 * interpreter. So, having found "#!", we'll set it right.
1886 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
1887 assert(SvPOK(x) || SvGMAGICAL(x));
1888 if (sv_eq(x, GvSV(curcop->cop_filegv))) {
1889 sv_setpvn(x, ipath, ipathend - ipath);
1892 TAINT_NOT; /* $^X is always tainted, but that's OK */
1894 #endif /* ARG_ZERO_IS_SCRIPT */
1899 d = instr(s,"perl -");
1901 d = instr(s,"perl");
1902 #ifdef ALTERNATE_SHEBANG
1904 * If the ALTERNATE_SHEBANG on this system starts with a
1905 * character that can be part of a Perl expression, then if
1906 * we see it but not "perl", we're probably looking at the
1907 * start of Perl code, not a request to hand off to some
1908 * other interpreter. Similarly, if "perl" is there, but
1909 * not in the first 'word' of the line, we assume the line
1910 * contains the start of the Perl program.
1912 if (d && *s != '#') {
1914 while (*c && !strchr("; \t\r\n\f\v#", *c))
1917 d = Nullch; /* "perl" not in first word; ignore */
1919 *s = '#'; /* Don't try to parse shebang line */
1921 #endif /* ALTERNATE_SHEBANG */
1926 !instr(s,"indir") &&
1927 instr(origargv[0],"perl"))
1933 while (s < bufend && isSPACE(*s))
1936 Newz(899,newargv,origargc+3,char*);
1938 while (s < bufend && !isSPACE(*s))
1941 Copy(origargv+1, newargv+2, origargc+1, char*);
1946 execv(ipath, newargv);
1947 croak("Can't exec %s", ipath);
1950 U32 oldpdb = perldb;
1951 bool oldn = minus_n;
1952 bool oldp = minus_p;
1954 while (*d && !isSPACE(*d)) d++;
1955 while (*d == ' ' || *d == '\t') d++;
1959 if (*d == 'M' || *d == 'm') {
1961 while (*d && !isSPACE(*d)) d++;
1962 croak("Too late for \"-%.*s\" option",
1965 d = moreswitches(d);
1967 if (PERLDB_LINE && !oldpdb ||
1968 ( minus_n || minus_p ) && !(oldn || oldp) )
1969 /* if we have already added "LINE: while (<>) {",
1970 we must not do it again */
1972 sv_setpv(linestr, "");
1973 oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr);
1974 bufend = SvPVX(linestr) + SvCUR(linestr);
1977 (void)gv_fetchfile(origfilename);
1984 if (lex_formbrack && lex_brackets <= lex_formbrack) {
1986 lex_state = LEX_FORMLINE;
1991 #ifndef TMP_CRLF_PATCH
1992 warn("Illegal character \\%03o (carriage return)", '\r');
1994 "(Maybe you didn't strip carriage returns after a network transfer?)\n");
1996 case ' ': case '\t': case '\f': case 013:
2001 if (lex_state != LEX_NORMAL || (in_eval && !rsfp)) {
2003 while (s < d && *s != '\n')
2008 if (lex_formbrack && lex_brackets <= lex_formbrack) {
2010 lex_state = LEX_FORMLINE;
2020 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2025 while (s < bufend && (*s == ' ' || *s == '\t'))
2028 if (strnEQ(s,"=>",2)) {
2029 s = force_word(bufptr,WORD,FALSE,FALSE,FALSE);
2030 OPERATOR('-'); /* unary minus */
2032 last_uni = oldbufptr;
2033 last_lop_op = OP_FTEREAD; /* good enough */
2035 case 'r': FTST(OP_FTEREAD);
2036 case 'w': FTST(OP_FTEWRITE);
2037 case 'x': FTST(OP_FTEEXEC);
2038 case 'o': FTST(OP_FTEOWNED);
2039 case 'R': FTST(OP_FTRREAD);
2040 case 'W': FTST(OP_FTRWRITE);
2041 case 'X': FTST(OP_FTREXEC);
2042 case 'O': FTST(OP_FTROWNED);
2043 case 'e': FTST(OP_FTIS);
2044 case 'z': FTST(OP_FTZERO);
2045 case 's': FTST(OP_FTSIZE);
2046 case 'f': FTST(OP_FTFILE);
2047 case 'd': FTST(OP_FTDIR);
2048 case 'l': FTST(OP_FTLINK);
2049 case 'p': FTST(OP_FTPIPE);
2050 case 'S': FTST(OP_FTSOCK);
2051 case 'u': FTST(OP_FTSUID);
2052 case 'g': FTST(OP_FTSGID);
2053 case 'k': FTST(OP_FTSVTX);
2054 case 'b': FTST(OP_FTBLK);
2055 case 'c': FTST(OP_FTCHR);
2056 case 't': FTST(OP_FTTTY);
2057 case 'T': FTST(OP_FTTEXT);
2058 case 'B': FTST(OP_FTBINARY);
2059 case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2060 case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2061 case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
2063 croak("Unrecognized file test: -%c", (int)tmp);
2070 if (expect == XOPERATOR)
2075 else if (*s == '>') {
2078 if (isIDFIRST(*s)) {
2079 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2087 if (expect == XOPERATOR)
2090 if (isSPACE(*s) || !isSPACE(*bufptr))
2092 OPERATOR('-'); /* unary minus */
2099 if (expect == XOPERATOR)
2104 if (expect == XOPERATOR)
2107 if (isSPACE(*s) || !isSPACE(*bufptr))
2113 if (expect != XOPERATOR) {
2114 s = scan_ident(s, bufend, tokenbuf, sizeof tokenbuf, TRUE);
2116 force_ident(tokenbuf, '*');
2129 if (expect == XOPERATOR) {
2134 s = scan_ident(s, bufend, tokenbuf + 1, sizeof tokenbuf - 1, TRUE);
2137 yyerror("Final % should be \\% or %name");
2140 pending_ident = '%';
2162 if (last_lop == oldoldbufptr || last_uni == oldoldbufptr)
2163 oldbufptr = oldoldbufptr; /* allow print(STDOUT 123) */
2168 if (curcop->cop_line < copline)
2169 copline = curcop->cop_line;
2180 if (lex_brackets <= 0)
2181 yyerror("Unmatched right bracket");
2184 if (lex_state == LEX_INTERPNORMAL) {
2185 if (lex_brackets == 0) {
2186 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
2187 lex_state = LEX_INTERPEND;
2194 if (lex_brackets > 100) {
2195 char* newlb = Renew(lex_brackstack, lex_brackets + 1, char);
2196 if (newlb != lex_brackstack) {
2198 lex_brackstack = newlb;
2203 if (lex_formbrack) {
2207 if (oldoldbufptr == last_lop)
2208 lex_brackstack[lex_brackets++] = XTERM;
2210 lex_brackstack[lex_brackets++] = XOPERATOR;
2211 OPERATOR(HASHBRACK);
2213 while (s < bufend && (*s == ' ' || *s == '\t'))
2217 if (d < bufend && *d == '-') {
2220 while (d < bufend && (*d == ' ' || *d == '\t'))
2223 if (d < bufend && isIDFIRST(*d)) {
2224 d = scan_word(d, tokenbuf + 1, sizeof tokenbuf - 1,
2226 while (d < bufend && (*d == ' ' || *d == '\t'))
2229 char minus = (tokenbuf[0] == '-');
2230 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2237 lex_brackstack[lex_brackets++] = XSTATE;
2241 lex_brackstack[lex_brackets++] = XOPERATOR;
2246 if (oldoldbufptr == last_lop)
2247 lex_brackstack[lex_brackets++] = XTERM;
2249 lex_brackstack[lex_brackets++] = XOPERATOR;
2252 OPERATOR(HASHBRACK);
2253 /* This hack serves to disambiguate a pair of curlies
2254 * as being a block or an anon hash. Normally, expectation
2255 * determines that, but in cases where we're not in a
2256 * position to expect anything in particular (like inside
2257 * eval"") we have to resolve the ambiguity. This code
2258 * covers the case where the first term in the curlies is a
2259 * quoted string. Most other cases need to be explicitly
2260 * disambiguated by prepending a `+' before the opening
2261 * curly in order to force resolution as an anon hash.
2263 * XXX should probably propagate the outer expectation
2264 * into eval"" to rely less on this hack, but that could
2265 * potentially break current behavior of eval"".
2269 if (*s == '\'' || *s == '"' || *s == '`') {
2270 /* common case: get past first string, handling escapes */
2271 for (t++; t < bufend && *t != *s;)
2272 if (*t++ == '\\' && (*t == '\\' || *t == *s))
2276 else if (*s == 'q') {
2279 || ((*t == 'q' || *t == 'x') && ++t < bufend
2280 && !isALNUM(*t)))) {
2282 char open, close, term;
2285 while (t < bufend && isSPACE(*t))
2289 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
2293 for (t++; t < bufend; t++) {
2294 if (*t == '\\' && t+1 < bufend && open != '\\')
2296 else if (*t == open)
2300 for (t++; t < bufend; t++) {
2301 if (*t == '\\' && t+1 < bufend)
2303 else if (*t == close && --brackets <= 0)
2305 else if (*t == open)
2311 else if (isALPHA(*s)) {
2312 for (t++; t < bufend && isALNUM(*t); t++) ;
2314 while (t < bufend && isSPACE(*t))
2316 /* if comma follows first term, call it an anon hash */
2317 /* XXX it could be a comma expression with loop modifiers */
2318 if (t < bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
2319 || (*t == '=' && t[1] == '>')))
2320 OPERATOR(HASHBRACK);
2324 lex_brackstack[lex_brackets-1] = XSTATE;
2330 yylval.ival = curcop->cop_line;
2331 if (isSPACE(*s) || *s == '#')
2332 copline = NOLINE; /* invalidate current command line number */
2337 if (lex_brackets <= 0)
2338 yyerror("Unmatched right bracket");
2340 expect = (expectation)lex_brackstack[--lex_brackets];
2341 if (lex_brackets < lex_formbrack)
2343 if (lex_state == LEX_INTERPNORMAL) {
2344 if (lex_brackets == 0) {
2345 if (lex_fakebrack) {
2346 lex_state = LEX_INTERPEND;
2348 return yylex(); /* ignore fake brackets */
2350 if (*s == '-' && s[1] == '>')
2351 lex_state = LEX_INTERPENDMAYBE;
2352 else if (*s != '[' && *s != '{')
2353 lex_state = LEX_INTERPEND;
2356 if (lex_brackets < lex_fakebrack) {
2359 return yylex(); /* ignore fake brackets */
2369 if (expect == XOPERATOR) {
2370 if (dowarn && isALPHA(*s) && bufptr == linestart) {
2378 s = scan_ident(s - 1, bufend, tokenbuf, sizeof tokenbuf, TRUE);
2381 force_ident(tokenbuf, '&');
2385 yylval.ival = (OPpENTERSUB_AMPER<<8);
2404 if (dowarn && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
2405 warn("Reversed %c= operator",(int)tmp);
2407 if (expect == XSTATE && isALPHA(tmp) &&
2408 (s == linestart+1 || s[-2] == '\n') )
2410 if (in_eval && !rsfp) {
2415 if (strnEQ(s,"=cut",4)) {
2432 if (lex_brackets < lex_formbrack) {
2434 for (t = s; *t == ' ' || *t == '\t'; t++) ;
2435 if (*t == '\n' || *t == '#') {
2453 if (expect != XOPERATOR) {
2454 if (s[1] != '<' && !strchr(s,'>'))
2457 s = scan_heredoc(s);
2459 s = scan_inputsymbol(s);
2460 TERM(sublex_start());
2465 SHop(OP_LEFT_SHIFT);
2479 SHop(OP_RIGHT_SHIFT);
2488 if (expect == XOPERATOR) {
2489 if (lex_formbrack && lex_brackets == lex_formbrack) {
2492 return ','; /* grandfather non-comma-format format */
2496 if (s[1] == '#' && (isALPHA(s[2]) || strchr("_{$:", s[2]))) {
2497 if (expect == XOPERATOR)
2498 no_op("Array length", bufptr);
2500 s = scan_ident(s + 1, bufend, tokenbuf + 1, sizeof tokenbuf - 1,
2505 pending_ident = '#';
2509 if (expect == XOPERATOR)
2510 no_op("Scalar", bufptr);
2512 s = scan_ident(s, bufend, tokenbuf + 1, sizeof tokenbuf - 1, FALSE);
2515 yyerror("Final $ should be \\$ or $name");
2519 /* This kludge not intended to be bulletproof. */
2520 if (tokenbuf[1] == '[' && !tokenbuf[2]) {
2521 yylval.opval = newSVOP(OP_CONST, 0,
2522 newSViv((IV)compiling.cop_arybase));
2523 yylval.opval->op_private = OPpCONST_ARYBASE;
2528 if (lex_state == LEX_NORMAL)
2531 if ((expect != XREF || oldoldbufptr == last_lop) && intuit_more(s)) {
2537 isSPACE(*t) || isALNUM(*t) || *t == '$';
2540 bufptr = skipspace(bufptr);
2541 while (t < bufend && *t != ']')
2543 warn("Multidimensional syntax %.*s not supported",
2544 (t - bufptr) + 1, bufptr);
2548 else if (*s == '{') {
2550 if (dowarn && strEQ(tokenbuf+1, "SIG") &&
2551 (t = strchr(s, '}')) && (t = strchr(t, '=')))
2553 char tmpbuf[sizeof tokenbuf];
2555 for (t++; isSPACE(*t); t++) ;
2556 if (isIDFIRST(*t)) {
2557 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
2558 if (*t != '(' && perl_get_cv(tmpbuf, FALSE))
2559 warn("You need to quote \"%s\"", tmpbuf);
2566 if (lex_state == LEX_NORMAL && isSPACE(*d)) {
2567 bool islop = (last_lop == oldoldbufptr);
2568 if (!islop || last_lop_op == OP_GREPSTART)
2570 else if (strchr("$@\"'`q", *s))
2571 expect = XTERM; /* e.g. print $fh "foo" */
2572 else if (strchr("&*<%", *s) && isIDFIRST(s[1]))
2573 expect = XTERM; /* e.g. print $fh &sub */
2574 else if (isIDFIRST(*s)) {
2575 char tmpbuf[sizeof tokenbuf];
2576 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2577 if (tmp = keyword(tmpbuf, len)) {
2578 /* binary operators exclude handle interpretations */
2590 expect = XTERM; /* e.g. print $fh length() */
2595 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
2596 if (gv && GvCVu(gv))
2597 expect = XTERM; /* e.g. print $fh subr() */
2600 else if (isDIGIT(*s))
2601 expect = XTERM; /* e.g. print $fh 3 */
2602 else if (*s == '.' && isDIGIT(s[1]))
2603 expect = XTERM; /* e.g. print $fh .3 */
2604 else if (strchr("/?-+", *s) && !isSPACE(s[1]))
2605 expect = XTERM; /* e.g. print $fh -1 */
2606 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]))
2607 expect = XTERM; /* print $fh <<"EOF" */
2609 pending_ident = '$';
2613 if (expect == XOPERATOR)
2616 s = scan_ident(s, bufend, tokenbuf + 1, sizeof tokenbuf - 1, FALSE);
2619 yyerror("Final @ should be \\@ or @name");
2622 if (lex_state == LEX_NORMAL)
2624 if ((expect != XREF || oldoldbufptr == last_lop) && intuit_more(s)) {
2628 /* Warn about @ where they meant $. */
2630 if (*s == '[' || *s == '{') {
2632 while (*t && (isALNUM(*t) || strchr(" \t$#+-'\"", *t)))
2634 if (*t == '}' || *t == ']') {
2636 bufptr = skipspace(bufptr);
2637 warn("Scalar value %.*s better written as $%.*s",
2638 t-bufptr, bufptr, t-bufptr-1, bufptr+1);
2643 pending_ident = '@';
2646 case '/': /* may either be division or pattern */
2647 case '?': /* may either be conditional or pattern */
2648 if (expect != XOPERATOR) {
2649 /* Disable warning on "study /blah/" */
2650 if (oldoldbufptr == last_uni
2651 && (*last_uni != 's' || s - last_uni < 5
2652 || memNE(last_uni, "study", 5) || isALNUM(last_uni[5])))
2654 s = scan_pat(s,OP_MATCH);
2655 TERM(sublex_start());
2663 if (lex_formbrack && lex_brackets == lex_formbrack && s[1] == '\n' &&
2664 (s == linestart || s[-1] == '\n') ) {
2669 if (expect == XOPERATOR || !isDIGIT(s[1])) {
2675 yylval.ival = OPf_SPECIAL;
2681 if (expect != XOPERATOR)
2686 case '0': case '1': case '2': case '3': case '4':
2687 case '5': case '6': case '7': case '8': case '9':
2689 if (expect == XOPERATOR)
2695 if (expect == XOPERATOR) {
2696 if (lex_formbrack && lex_brackets == lex_formbrack) {
2699 return ','; /* grandfather non-comma-format format */
2705 missingterm((char*)0);
2706 yylval.ival = OP_CONST;
2707 TERM(sublex_start());
2711 if (expect == XOPERATOR) {
2712 if (lex_formbrack && lex_brackets == lex_formbrack) {
2715 return ','; /* grandfather non-comma-format format */
2721 missingterm((char*)0);
2722 yylval.ival = OP_CONST;
2723 for (d = SvPV(lex_stuff, len); len; len--, d++) {
2724 if (*d == '$' || *d == '@' || *d == '\\') {
2725 yylval.ival = OP_STRINGIFY;
2729 TERM(sublex_start());
2733 if (expect == XOPERATOR)
2734 no_op("Backticks",s);
2736 missingterm((char*)0);
2737 yylval.ival = OP_BACKTICK;
2739 TERM(sublex_start());
2743 if (dowarn && lex_inwhat && isDIGIT(*s))
2744 warn("Can't use \\%c to mean $%c in expression", *s, *s);
2745 if (expect == XOPERATOR)
2746 no_op("Backslash",s);
2750 if (isDIGIT(s[1]) && expect == XOPERATOR) {
2789 s = scan_word(s, tokenbuf, sizeof tokenbuf, FALSE, &len);
2791 /* Some keywords can be followed by any delimiter, including ':' */
2792 tmp = (len == 1 && strchr("msyq", tokenbuf[0]) ||
2793 len == 2 && ((tokenbuf[0] == 't' && tokenbuf[1] == 'r') ||
2794 (tokenbuf[0] == 'q' &&
2795 strchr("qwxr", tokenbuf[1]))));
2797 /* x::* is just a word, unless x is "CORE" */
2798 if (!tmp && *s == ':' && s[1] == ':' && strNE(tokenbuf, "CORE"))
2802 while (d < bufend && isSPACE(*d))
2803 d++; /* no comments skipped here, or s### is misparsed */
2805 /* Is this a label? */
2806 if (!tmp && expect == XSTATE
2807 && d < bufend && *d == ':' && *(d + 1) != ':') {
2809 yylval.pval = savepv(tokenbuf);
2814 /* Check for keywords */
2815 tmp = keyword(tokenbuf, len);
2817 /* Is this a word before a => operator? */
2818 if (strnEQ(d,"=>",2)) {
2820 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(tokenbuf,0));
2821 yylval.opval->op_private = OPpCONST_BARE;
2825 if (tmp < 0) { /* second-class keyword? */
2826 GV *ogv = Nullgv; /* override (winner) */
2827 GV *hgv = Nullgv; /* hidden (loser) */
2828 if (expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
2830 if ((gv = gv_fetchpv(tokenbuf, FALSE, SVt_PVCV)) &&
2833 if (GvIMPORTED_CV(gv))
2835 else if (! CvMETHOD(cv))
2839 (gvp = (GV**)hv_fetch(globalstash,tokenbuf,len,FALSE)) &&
2840 (gv = *gvp) != (GV*)&sv_undef &&
2841 GvCVu(gv) && GvIMPORTED_CV(gv))
2847 tmp = 0; /* overridden by import or by GLOBAL */
2850 && -tmp==KEY_lock /* XXX generalizable kludge */
2851 && !hv_fetch(GvHVn(incgv), "Thread.pm", 9, FALSE))
2853 tmp = 0; /* any sub overrides "weak" keyword */
2855 else { /* no override */
2860 warn("Ambiguous call resolved as CORE::%s(), "
2861 "qualify as such or use &", GvENAME(hgv));
2868 default: /* not a keyword */
2871 char lastchar = (bufptr == oldoldbufptr ? 0 : bufptr[-1]);
2873 /* Get the rest if it looks like a package qualifier */
2875 if (*s == '\'' || *s == ':' && s[1] == ':') {
2877 s = scan_word(s, tokenbuf + len, sizeof tokenbuf - len,
2880 croak("Bad name after %s%s", tokenbuf,
2881 *s == '\'' ? "'" : "::");
2885 if (expect == XOPERATOR) {
2886 if (bufptr == linestart) {
2892 no_op("Bareword",s);
2895 /* Look for a subroutine with this name in current package,
2896 unless name is "Foo::", in which case Foo is a bearword
2897 (and a package name). */
2900 tokenbuf[len - 2] == ':' && tokenbuf[len - 1] == ':')
2902 if (dowarn && ! gv_fetchpv(tokenbuf, FALSE, SVt_PVHV))
2903 warn("Bareword \"%s\" refers to nonexistent package",
2906 tokenbuf[len] = '\0';
2913 gv = gv_fetchpv(tokenbuf, FALSE, SVt_PVCV);
2916 /* if we saw a global override before, get the right name */
2919 sv = newSVpv("CORE::GLOBAL::",14);
2920 sv_catpv(sv,tokenbuf);
2923 sv = newSVpv(tokenbuf,0);
2925 /* Presume this is going to be a bareword of some sort. */
2928 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2929 yylval.opval->op_private = OPpCONST_BARE;
2931 /* And if "Foo::", then that's what it certainly is. */
2936 /* See if it's the indirect object for a list operator. */
2939 oldoldbufptr < bufptr &&
2940 (oldoldbufptr == last_lop || oldoldbufptr == last_uni) &&
2941 /* NO SKIPSPACE BEFORE HERE! */
2943 || ((opargs[last_lop_op] >> OASHIFT)& 7) == OA_FILEREF
2944 || (last_lop_op == OP_ENTERSUB
2946 && last_proto[last_proto[0] == ';' ? 1 : 0] == '*')) )
2948 bool immediate_paren = *s == '(';
2950 /* (Now we can afford to cross potential line boundary.) */
2953 /* Two barewords in a row may indicate method call. */
2955 if ((isALPHA(*s) || *s == '$') && (tmp=intuit_method(s,gv)))
2958 /* If not a declared subroutine, it's an indirect object. */
2959 /* (But it's an indir obj regardless for sort.) */
2961 if ((last_lop_op == OP_SORT ||
2962 (!immediate_paren && (!gv || !GvCVu(gv))) ) &&
2963 (last_lop_op != OP_MAPSTART && last_lop_op != OP_GREPSTART)){
2964 expect = (last_lop == oldoldbufptr) ? XTERM : XOPERATOR;
2969 /* If followed by a paren, it's certainly a subroutine. */
2975 if (gv && GvCVu(gv)) {
2976 for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
2977 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
2982 nextval[nexttoke].opval = yylval.opval;
2989 /* If followed by var or block, call it a method (unless sub) */
2991 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
2992 last_lop = oldbufptr;
2993 last_lop_op = OP_METHOD;
2997 /* If followed by a bareword, see if it looks like indir obj. */
2999 if ((isALPHA(*s) || *s == '$') && (tmp = intuit_method(s,gv)))
3002 /* Not a method, so call it a subroutine (if defined) */
3004 if (gv && GvCVu(gv)) {
3006 if (lastchar == '-')
3007 warn("Ambiguous use of -%s resolved as -&%s()",
3008 tokenbuf, tokenbuf);
3009 last_lop = oldbufptr;
3010 last_lop_op = OP_ENTERSUB;
3011 /* Check for a constant sub */
3013 if ((sv = cv_const_sv(cv))) {
3015 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3016 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3017 yylval.opval->op_private = 0;
3021 /* Resolve to GV now. */
3022 op_free(yylval.opval);
3023 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3024 /* Is there a prototype? */
3027 last_proto = SvPV((SV*)cv, len);
3030 if (strEQ(last_proto, "$"))
3032 if (*last_proto == '&' && *s == '{') {
3033 sv_setpv(subname,"__ANON__");
3038 nextval[nexttoke].opval = yylval.opval;
3044 if (hints & HINT_STRICT_SUBS &&
3047 last_lop_op != OP_TRUNCATE && /* S/F prototype in opcode.pl */
3048 last_lop_op != OP_ACCEPT &&
3049 last_lop_op != OP_PIPE_OP &&
3050 last_lop_op != OP_SOCKPAIR)
3053 "Bareword \"%s\" not allowed while \"strict subs\" in use",
3058 /* Call it a bare word */
3062 if (lastchar != '-') {
3063 for (d = tokenbuf; *d && isLOWER(*d); d++) ;
3065 warn(warn_reserved, tokenbuf);
3070 if (lastchar && strchr("*%&", lastchar)) {
3071 warn("Operator or semicolon missing before %c%s",
3072 lastchar, tokenbuf);
3073 warn("Ambiguous use of %c resolved as operator %c",
3074 lastchar, lastchar);
3080 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3081 newSVsv(GvSV(curcop->cop_filegv)));
3085 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3086 newSVpvf("%ld", (long)curcop->cop_line));
3089 case KEY___PACKAGE__:
3090 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3092 ? newSVsv(curstname)
3101 if (rsfp && (!in_eval || tokenbuf[2] == 'D')) {
3102 char *pname = "main";
3103 if (tokenbuf[2] == 'D')
3104 pname = HvNAME(curstash ? curstash : defstash);
3105 gv = gv_fetchpv(form("%s::DATA", pname), TRUE, SVt_PVIO);
3108 GvIOp(gv) = newIO();
3109 IoIFP(GvIOp(gv)) = rsfp;
3110 #if defined(HAS_FCNTL) && defined(F_SETFD)
3112 int fd = PerlIO_fileno(rsfp);
3113 fcntl(fd,F_SETFD,fd >= 3);
3116 /* Mark this internal pseudo-handle as clean */
3117 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3119 IoTYPE(GvIOp(gv)) = '|';
3120 else if ((PerlIO*)rsfp == PerlIO_stdin())
3121 IoTYPE(GvIOp(gv)) = '-';
3123 IoTYPE(GvIOp(gv)) = '<';
3134 if (expect == XSTATE) {
3141 if (*s == ':' && s[1] == ':') {
3144 s = scan_word(s, tokenbuf, sizeof tokenbuf, FALSE, &len);
3145 tmp = keyword(tokenbuf, len);
3159 LOP(OP_ACCEPT,XTERM);
3165 LOP(OP_ATAN2,XTERM);
3174 LOP(OP_BLESS,XTERM);
3183 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
3203 LOP(OP_CRYPT,XTERM);
3207 for (d = s; d < bufend && (isSPACE(*d) || *d == '('); d++) ;
3208 if (*d != '0' && isDIGIT(*d))
3209 yywarn("chmod: mode argument is missing initial 0");
3211 LOP(OP_CHMOD,XTERM);
3214 LOP(OP_CHOWN,XTERM);
3217 LOP(OP_CONNECT,XTERM);
3233 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3237 hints |= HINT_BLOCK_SCOPE;
3247 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3248 LOP(OP_DBMOPEN,XTERM);
3254 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3261 yylval.ival = curcop->cop_line;
3275 expect = (*s == '{') ? XTERMBLOCK : XTERM;
3276 UNIBRACK(OP_ENTEREVAL);
3291 case KEY_endhostent:
3297 case KEY_endservent:
3300 case KEY_endprotoent:
3311 yylval.ival = curcop->cop_line;
3313 if (expect == XSTATE && isIDFIRST(*s)) {
3315 if ((bufend - p) >= 3 &&
3316 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3320 croak("Missing $ on loop variable");
3325 LOP(OP_FORMLINE,XTERM);
3331 LOP(OP_FCNTL,XTERM);
3337 LOP(OP_FLOCK,XTERM);
3346 LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
3349 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3364 case KEY_getpriority:
3365 LOP(OP_GETPRIORITY,XTERM);
3367 case KEY_getprotobyname:
3370 case KEY_getprotobynumber:
3371 LOP(OP_GPBYNUMBER,XTERM);
3373 case KEY_getprotoent:
3385 case KEY_getpeername:
3386 UNI(OP_GETPEERNAME);
3388 case KEY_gethostbyname:
3391 case KEY_gethostbyaddr:
3392 LOP(OP_GHBYADDR,XTERM);
3394 case KEY_gethostent:
3397 case KEY_getnetbyname:
3400 case KEY_getnetbyaddr:
3401 LOP(OP_GNBYADDR,XTERM);
3406 case KEY_getservbyname:
3407 LOP(OP_GSBYNAME,XTERM);
3409 case KEY_getservbyport:
3410 LOP(OP_GSBYPORT,XTERM);
3412 case KEY_getservent:
3415 case KEY_getsockname:
3416 UNI(OP_GETSOCKNAME);
3418 case KEY_getsockopt:
3419 LOP(OP_GSOCKOPT,XTERM);
3441 yylval.ival = curcop->cop_line;
3445 LOP(OP_INDEX,XTERM);
3451 LOP(OP_IOCTL,XTERM);
3463 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3494 LOP(OP_LISTEN,XTERM);
3503 s = scan_pat(s,OP_MATCH);
3504 TERM(sublex_start());
3507 LOP(OP_MAPSTART,XREF);
3510 LOP(OP_MKDIR,XTERM);
3513 LOP(OP_MSGCTL,XTERM);
3516 LOP(OP_MSGGET,XTERM);
3519 LOP(OP_MSGRCV,XTERM);
3522 LOP(OP_MSGSND,XTERM);
3527 if (isIDFIRST(*s)) {
3528 s = scan_word(s, tokenbuf, sizeof tokenbuf, TRUE, &len);
3529 in_my_stash = gv_stashpv(tokenbuf, FALSE);
3533 sprintf(tmpbuf, "No such class %.1000s", tokenbuf);
3540 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3547 if (expect != XSTATE)
3548 yyerror("\"no\" not allowed in expression");
3549 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3550 s = force_version(s);
3559 if (isIDFIRST(*s)) {
3561 for (d = s; isALNUM(*d); d++) ;
3563 if (strchr("|&*+-=!?:.", *t))
3564 warn("Precedence problem: open %.*s should be open(%.*s)",
3570 yylval.ival = OP_OR;
3580 LOP(OP_OPEN_DIR,XTERM);
3583 checkcomma(s,tokenbuf,"filehandle");
3587 checkcomma(s,tokenbuf,"filehandle");
3606 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3610 LOP(OP_PIPE_OP,XTERM);
3615 missingterm((char*)0);
3616 yylval.ival = OP_CONST;
3617 TERM(sublex_start());
3625 missingterm((char*)0);
3626 if (dowarn && SvLEN(lex_stuff)) {
3627 d = SvPV_force(lex_stuff, len);
3628 for (; len; --len, ++d) {
3630 warn("Possible attempt to separate words with commas");
3634 warn("Possible attempt to put comments in qw() list");
3640 nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, tokeq(lex_stuff));
3644 nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(" ",1));
3647 yylval.ival = OP_SPLIT;
3651 last_lop = oldbufptr;
3652 last_lop_op = OP_SPLIT;
3658 missingterm((char*)0);
3659 yylval.ival = OP_STRINGIFY;
3660 if (SvIVX(lex_stuff) == '\'')
3661 SvIVX(lex_stuff) = 0; /* qq'$foo' should intepolate */
3662 TERM(sublex_start());
3665 s = scan_pat(s,OP_QR);
3666 TERM(sublex_start());
3671 missingterm((char*)0);
3672 yylval.ival = OP_BACKTICK;
3674 TERM(sublex_start());
3681 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3682 if (isIDFIRST(*tokenbuf))
3683 gv_stashpvn(tokenbuf, strlen(tokenbuf), TRUE);
3685 yyerror("<> should be quotes");
3692 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3696 LOP(OP_RENAME,XTERM);
3705 LOP(OP_RINDEX,XTERM);
3728 LOP(OP_REVERSE,XTERM);
3739 TERM(sublex_start());
3741 TOKEN(1); /* force error */
3750 LOP(OP_SELECT,XTERM);
3756 LOP(OP_SEMCTL,XTERM);
3759 LOP(OP_SEMGET,XTERM);
3762 LOP(OP_SEMOP,XTERM);
3768 LOP(OP_SETPGRP,XTERM);
3770 case KEY_setpriority:
3771 LOP(OP_SETPRIORITY,XTERM);
3773 case KEY_sethostent:
3779 case KEY_setservent:
3782 case KEY_setprotoent:
3792 LOP(OP_SEEKDIR,XTERM);
3794 case KEY_setsockopt:
3795 LOP(OP_SSOCKOPT,XTERM);
3801 LOP(OP_SHMCTL,XTERM);
3804 LOP(OP_SHMGET,XTERM);
3807 LOP(OP_SHMREAD,XTERM);
3810 LOP(OP_SHMWRITE,XTERM);
3813 LOP(OP_SHUTDOWN,XTERM);
3822 LOP(OP_SOCKET,XTERM);
3824 case KEY_socketpair:
3825 LOP(OP_SOCKPAIR,XTERM);
3828 checkcomma(s,tokenbuf,"subroutine name");
3830 if (*s == ';' || *s == ')') /* probably a close */
3831 croak("sort is now a reserved word");
3833 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3837 LOP(OP_SPLIT,XTERM);
3840 LOP(OP_SPRINTF,XTERM);
3843 LOP(OP_SPLICE,XTERM);
3859 LOP(OP_SUBSTR,XTERM);
3866 if (isIDFIRST(*s) || *s == '\'' || *s == ':') {
3867 char tmpbuf[sizeof tokenbuf];
3869 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3870 if (strchr(tmpbuf, ':'))
3871 sv_setpv(subname, tmpbuf);
3873 sv_setsv(subname,curstname);
3874 sv_catpvn(subname,"::",2);
3875 sv_catpvn(subname,tmpbuf,len);
3877 s = force_word(s,WORD,FALSE,TRUE,TRUE);
3881 expect = XTERMBLOCK;
3882 sv_setpv(subname,"?");
3885 if (tmp == KEY_format) {
3888 lex_formbrack = lex_brackets + 1;
3892 /* Look for a prototype */
3899 SvREFCNT_dec(lex_stuff);
3901 croak("Prototype not terminated");
3904 d = SvPVX(lex_stuff);
3906 for (p = d; *p; ++p) {
3911 SvCUR(lex_stuff) = tmp;
3914 nextval[1] = nextval[0];
3915 nexttype[1] = nexttype[0];
3916 nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, lex_stuff);
3917 nexttype[0] = THING;
3918 if (nexttoke == 1) {
3919 lex_defer = lex_state;
3920 lex_expect = expect;
3921 lex_state = LEX_KNOWNEXT;
3926 if (*SvPV(subname,na) == '?') {
3927 sv_setpv(subname,"__ANON__");
3934 LOP(OP_SYSTEM,XREF);
3937 LOP(OP_SYMLINK,XTERM);
3940 LOP(OP_SYSCALL,XTERM);
3943 LOP(OP_SYSOPEN,XTERM);
3946 LOP(OP_SYSSEEK,XTERM);
3949 LOP(OP_SYSREAD,XTERM);
3952 LOP(OP_SYSWRITE,XTERM);
3956 TERM(sublex_start());
3977 LOP(OP_TRUNCATE,XTERM);
3989 yylval.ival = curcop->cop_line;
3993 yylval.ival = curcop->cop_line;
3997 LOP(OP_UNLINK,XTERM);
4003 LOP(OP_UNPACK,XTERM);
4006 LOP(OP_UTIME,XTERM);
4010 for (d = s; d < bufend && (isSPACE(*d) || *d == '('); d++) ;
4011 if (*d != '0' && isDIGIT(*d))
4012 yywarn("umask: argument is missing initial 0");
4017 LOP(OP_UNSHIFT,XTERM);
4020 if (expect != XSTATE)
4021 yyerror("\"use\" not allowed in expression");
4024 s = force_version(s);
4025 if(*s == ';' || (s = skipspace(s), *s == ';')) {
4026 nextval[nexttoke].opval = Nullop;
4031 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4032 s = force_version(s);
4045 yylval.ival = curcop->cop_line;
4049 hints |= HINT_BLOCK_SCOPE;
4056 LOP(OP_WAITPID,XTERM);
4062 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
4066 if (expect == XOPERATOR)
4072 yylval.ival = OP_XOR;
4077 TERM(sublex_start());
4083 keyword(register char *d, I32 len)
4088 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
4089 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
4090 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
4091 if (strEQ(d,"__DATA__")) return KEY___DATA__;
4092 if (strEQ(d,"__END__")) return KEY___END__;
4096 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
4101 if (strEQ(d,"and")) return -KEY_and;
4102 if (strEQ(d,"abs")) return -KEY_abs;
4105 if (strEQ(d,"alarm")) return -KEY_alarm;
4106 if (strEQ(d,"atan2")) return -KEY_atan2;
4109 if (strEQ(d,"accept")) return -KEY_accept;
4114 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
4117 if (strEQ(d,"bless")) return -KEY_bless;
4118 if (strEQ(d,"bind")) return -KEY_bind;
4119 if (strEQ(d,"binmode")) return -KEY_binmode;
4122 if (strEQ(d,"CORE")) return -KEY_CORE;
4127 if (strEQ(d,"cmp")) return -KEY_cmp;
4128 if (strEQ(d,"chr")) return -KEY_chr;
4129 if (strEQ(d,"cos")) return -KEY_cos;
4132 if (strEQ(d,"chop")) return KEY_chop;
4135 if (strEQ(d,"close")) return -KEY_close;
4136 if (strEQ(d,"chdir")) return -KEY_chdir;
4137 if (strEQ(d,"chomp")) return KEY_chomp;
4138 if (strEQ(d,"chmod")) return -KEY_chmod;
4139 if (strEQ(d,"chown")) return -KEY_chown;
4140 if (strEQ(d,"crypt")) return -KEY_crypt;
4143 if (strEQ(d,"chroot")) return -KEY_chroot;
4144 if (strEQ(d,"caller")) return -KEY_caller;
4147 if (strEQ(d,"connect")) return -KEY_connect;
4150 if (strEQ(d,"closedir")) return -KEY_closedir;
4151 if (strEQ(d,"continue")) return -KEY_continue;
4156 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
4161 if (strEQ(d,"do")) return KEY_do;
4164 if (strEQ(d,"die")) return -KEY_die;
4167 if (strEQ(d,"dump")) return -KEY_dump;
4170 if (strEQ(d,"delete")) return KEY_delete;
4173 if (strEQ(d,"defined")) return KEY_defined;
4174 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
4177 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
4182 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
4183 if (strEQ(d,"END")) return KEY_END;
4188 if (strEQ(d,"eq")) return -KEY_eq;
4191 if (strEQ(d,"eof")) return -KEY_eof;
4192 if (strEQ(d,"exp")) return -KEY_exp;
4195 if (strEQ(d,"else")) return KEY_else;
4196 if (strEQ(d,"exit")) return -KEY_exit;
4197 if (strEQ(d,"eval")) return KEY_eval;
4198 if (strEQ(d,"exec")) return -KEY_exec;
4199 if (strEQ(d,"each")) return KEY_each;
4202 if (strEQ(d,"elsif")) return KEY_elsif;
4205 if (strEQ(d,"exists")) return KEY_exists;
4206 if (strEQ(d,"elseif")) warn("elseif should be elsif");
4209 if (strEQ(d,"endgrent")) return -KEY_endgrent;
4210 if (strEQ(d,"endpwent")) return -KEY_endpwent;
4213 if (strEQ(d,"endnetent")) return -KEY_endnetent;
4216 if (strEQ(d,"endhostent")) return -KEY_endhostent;
4217 if (strEQ(d,"endservent")) return -KEY_endservent;
4220 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
4227 if (strEQ(d,"for")) return KEY_for;
4230 if (strEQ(d,"fork")) return -KEY_fork;
4233 if (strEQ(d,"fcntl")) return -KEY_fcntl;
4234 if (strEQ(d,"flock")) return -KEY_flock;
4237 if (strEQ(d,"format")) return KEY_format;
4238 if (strEQ(d,"fileno")) return -KEY_fileno;
4241 if (strEQ(d,"foreach")) return KEY_foreach;
4244 if (strEQ(d,"formline")) return -KEY_formline;
4250 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
4251 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
4255 if (strnEQ(d,"get",3)) {
4260 if (strEQ(d,"ppid")) return -KEY_getppid;
4261 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
4264 if (strEQ(d,"pwent")) return -KEY_getpwent;
4265 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
4266 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
4269 if (strEQ(d,"peername")) return -KEY_getpeername;
4270 if (strEQ(d,"protoent")) return -KEY_getprotoent;
4271 if (strEQ(d,"priority")) return -KEY_getpriority;
4274 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
4277 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
4281 else if (*d == 'h') {
4282 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
4283 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
4284 if (strEQ(d,"hostent")) return -KEY_gethostent;
4286 else if (*d == 'n') {
4287 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
4288 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
4289 if (strEQ(d,"netent")) return -KEY_getnetent;
4291 else if (*d == 's') {
4292 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
4293 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
4294 if (strEQ(d,"servent")) return -KEY_getservent;
4295 if (strEQ(d,"sockname")) return -KEY_getsockname;
4296 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
4298 else if (*d == 'g') {
4299 if (strEQ(d,"grent")) return -KEY_getgrent;
4300 if (strEQ(d,"grnam")) return -KEY_getgrnam;
4301 if (strEQ(d,"grgid")) return -KEY_getgrgid;
4303 else if (*d == 'l') {
4304 if (strEQ(d,"login")) return -KEY_getlogin;
4306 else if (strEQ(d,"c")) return -KEY_getc;
4311 if (strEQ(d,"gt")) return -KEY_gt;
4312 if (strEQ(d,"ge")) return -KEY_ge;
4315 if (strEQ(d,"grep")) return KEY_grep;
4316 if (strEQ(d,"goto")) return KEY_goto;
4317 if (strEQ(d,"glob")) return KEY_glob;
4320 if (strEQ(d,"gmtime")) return -KEY_gmtime;
4325 if (strEQ(d,"hex")) return -KEY_hex;
4328 if (strEQ(d,"INIT")) return KEY_INIT;
4333 if (strEQ(d,"if")) return KEY_if;
4336 if (strEQ(d,"int")) return -KEY_int;
4339 if (strEQ(d,"index")) return -KEY_index;
4340 if (strEQ(d,"ioctl")) return -KEY_ioctl;
4345 if (strEQ(d,"join")) return -KEY_join;
4349 if (strEQ(d,"keys")) return KEY_keys;
4350 if (strEQ(d,"kill")) return -KEY_kill;
4355 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
4356 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
4362 if (strEQ(d,"lt")) return -KEY_lt;
4363 if (strEQ(d,"le")) return -KEY_le;
4364 if (strEQ(d,"lc")) return -KEY_lc;
4367 if (strEQ(d,"log")) return -KEY_log;
4370 if (strEQ(d,"last")) return KEY_last;
4371 if (strEQ(d,"link")) return -KEY_link;
4372 if (strEQ(d,"lock")) return -KEY_lock;
4375 if (strEQ(d,"local")) return KEY_local;
4376 if (strEQ(d,"lstat")) return -KEY_lstat;
4379 if (strEQ(d,"length")) return -KEY_length;
4380 if (strEQ(d,"listen")) return -KEY_listen;
4383 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
4386 if (strEQ(d,"localtime")) return -KEY_localtime;
4392 case 1: return KEY_m;
4394 if (strEQ(d,"my")) return KEY_my;
4397 if (strEQ(d,"map")) return KEY_map;
4400 if (strEQ(d,"mkdir")) return -KEY_mkdir;
4403 if (strEQ(d,"msgctl")) return -KEY_msgctl;
4404 if (strEQ(d,"msgget")) return -KEY_msgget;
4405 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
4406 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
4411 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
4414 if (strEQ(d,"next")) return KEY_next;
4415 if (strEQ(d,"ne")) return -KEY_ne;
4416 if (strEQ(d,"not")) return -KEY_not;
4417 if (strEQ(d,"no")) return KEY_no;
4422 if (strEQ(d,"or")) return -KEY_or;
4425 if (strEQ(d,"ord")) return -KEY_ord;
4426 if (strEQ(d,"oct")) return -KEY_oct;
4427 if (strEQ(d,"our")) { deprecate("reserved word \"our\"");
4431 if (strEQ(d,"open")) return -KEY_open;
4434 if (strEQ(d,"opendir")) return -KEY_opendir;
4441 if (strEQ(d,"pop")) return KEY_pop;
4442 if (strEQ(d,"pos")) return KEY_pos;
4445 if (strEQ(d,"push")) return KEY_push;
4446 if (strEQ(d,"pack")) return -KEY_pack;
4447 if (strEQ(d,"pipe")) return -KEY_pipe;
4450 if (strEQ(d,"print")) return KEY_print;
4453 if (strEQ(d,"printf")) return KEY_printf;
4456 if (strEQ(d,"package")) return KEY_package;
4459 if (strEQ(d,"prototype")) return KEY_prototype;
4464 if (strEQ(d,"q")) return KEY_q;
4465 if (strEQ(d,"qr")) return KEY_qr;
4466 if (strEQ(d,"qq")) return KEY_qq;
4467 if (strEQ(d,"qw")) return KEY_qw;
4468 if (strEQ(d,"qx")) return KEY_qx;
4470 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
4475 if (strEQ(d,"ref")) return -KEY_ref;
4478 if (strEQ(d,"read")) return -KEY_read;
4479 if (strEQ(d,"rand")) return -KEY_rand;
4480 if (strEQ(d,"recv")) return -KEY_recv;
4481 if (strEQ(d,"redo")) return KEY_redo;
4484 if (strEQ(d,"rmdir")) return -KEY_rmdir;
4485 if (strEQ(d,"reset")) return -KEY_reset;
4488 if (strEQ(d,"return")) return KEY_return;
4489 if (strEQ(d,"rename")) return -KEY_rename;
4490 if (strEQ(d,"rindex")) return -KEY_rindex;
4493 if (strEQ(d,"require")) return -KEY_require;
4494 if (strEQ(d,"reverse")) return -KEY_reverse;
4495 if (strEQ(d,"readdir")) return -KEY_readdir;
4498 if (strEQ(d,"readlink")) return -KEY_readlink;
4499 if (strEQ(d,"readline")) return -KEY_readline;
4500 if (strEQ(d,"readpipe")) return -KEY_readpipe;
4503 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
4509 case 0: return KEY_s;
4511 if (strEQ(d,"scalar")) return KEY_scalar;
4516 if (strEQ(d,"seek")) return -KEY_seek;
4517 if (strEQ(d,"send")) return -KEY_send;
4520 if (strEQ(d,"semop")) return -KEY_semop;
4523 if (strEQ(d,"select")) return -KEY_select;
4524 if (strEQ(d,"semctl")) return -KEY_semctl;
4525 if (strEQ(d,"semget")) return -KEY_semget;
4528 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
4529 if (strEQ(d,"seekdir")) return -KEY_seekdir;
4532 if (strEQ(d,"setpwent")) return -KEY_setpwent;
4533 if (strEQ(d,"setgrent")) return -KEY_setgrent;
4536 if (strEQ(d,"setnetent")) return -KEY_setnetent;
4539 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
4540 if (strEQ(d,"sethostent")) return -KEY_sethostent;
4541 if (strEQ(d,"setservent")) return -KEY_setservent;
4544 if (strEQ(d,"setpriority")) return -KEY_setpriority;
4545 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
4552 if (strEQ(d,"shift")) return KEY_shift;
4555 if (strEQ(d,"shmctl")) return -KEY_shmctl;
4556 if (strEQ(d,"shmget")) return -KEY_shmget;
4559 if (strEQ(d,"shmread")) return -KEY_shmread;
4562 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
4563 if (strEQ(d,"shutdown")) return -KEY_shutdown;
4568 if (strEQ(d,"sin")) return -KEY_sin;
4571 if (strEQ(d,"sleep")) return -KEY_sleep;
4574 if (strEQ(d,"sort")) return KEY_sort;
4575 if (strEQ(d,"socket")) return -KEY_socket;
4576 if (strEQ(d,"socketpair")) return -KEY_socketpair;
4579 if (strEQ(d,"split")) return KEY_split;
4580 if (strEQ(d,"sprintf")) return -KEY_sprintf;
4581 if (strEQ(d,"splice")) return KEY_splice;
4584 if (strEQ(d,"sqrt")) return -KEY_sqrt;
4587 if (strEQ(d,"srand")) return -KEY_srand;
4590 if (strEQ(d,"stat")) return -KEY_stat;
4591 if (strEQ(d,"study")) return KEY_study;
4594 if (strEQ(d,"substr")) return -KEY_substr;
4595 if (strEQ(d,"sub")) return KEY_sub;
4600 if (strEQ(d,"system")) return -KEY_system;
4603 if (strEQ(d,"symlink")) return -KEY_symlink;
4604 if (strEQ(d,"syscall")) return -KEY_syscall;
4605 if (strEQ(d,"sysopen")) return -KEY_sysopen;
4606 if (strEQ(d,"sysread")) return -KEY_sysread;
4607 if (strEQ(d,"sysseek")) return -KEY_sysseek;
4610 if (strEQ(d,"syswrite")) return -KEY_syswrite;
4619 if (strEQ(d,"tr")) return KEY_tr;
4622 if (strEQ(d,"tie")) return KEY_tie;
4625 if (strEQ(d,"tell")) return -KEY_tell;
4626 if (strEQ(d,"tied")) return KEY_tied;
4627 if (strEQ(d,"time")) return -KEY_time;
4630 if (strEQ(d,"times")) return -KEY_times;
4633 if (strEQ(d,"telldir")) return -KEY_telldir;
4636 if (strEQ(d,"truncate")) return -KEY_truncate;
4643 if (strEQ(d,"uc")) return -KEY_uc;
4646 if (strEQ(d,"use")) return KEY_use;
4649 if (strEQ(d,"undef")) return KEY_undef;
4650 if (strEQ(d,"until")) return KEY_until;
4651 if (strEQ(d,"untie")) return KEY_untie;
4652 if (strEQ(d,"utime")) return -KEY_utime;
4653 if (strEQ(d,"umask")) return -KEY_umask;
4656 if (strEQ(d,"unless")) return KEY_unless;
4657 if (strEQ(d,"unpack")) return -KEY_unpack;
4658 if (strEQ(d,"unlink")) return -KEY_unlink;
4661 if (strEQ(d,"unshift")) return KEY_unshift;
4662 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
4667 if (strEQ(d,"values")) return -KEY_values;
4668 if (strEQ(d,"vec")) return -KEY_vec;
4673 if (strEQ(d,"warn")) return -KEY_warn;
4674 if (strEQ(d,"wait")) return -KEY_wait;
4677 if (strEQ(d,"while")) return KEY_while;
4678 if (strEQ(d,"write")) return -KEY_write;
4681 if (strEQ(d,"waitpid")) return -KEY_waitpid;
4684 if (strEQ(d,"wantarray")) return -KEY_wantarray;
4689 if (len == 1) return -KEY_x;
4690 if (strEQ(d,"xor")) return -KEY_xor;
4693 if (len == 1) return KEY_y;
4702 checkcomma(register char *s, char *name, char *what)
4706 if (dowarn && *s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
4708 for (w = s+2; *w && level; w++) {
4715 for (; *w && isSPACE(*w); w++) ;
4716 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
4717 warn("%s (...) interpreted as function",name);
4719 while (s < bufend && isSPACE(*s))
4723 while (s < bufend && isSPACE(*s))
4725 if (isIDFIRST(*s)) {
4729 while (s < bufend && isSPACE(*s))
4734 kw = keyword(w, s - w) || perl_get_cv(w, FALSE) != 0;
4738 croak("No comma allowed after %s", what);
4744 new_constant(char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)
4747 HV *table = GvHV(hintgv); /* ^H */
4750 bool oldcatch = CATCH_GET;
4756 yyerror("%^H is not defined");
4759 cvp = hv_fetch(table, key, strlen(key), FALSE);
4760 if (!cvp || !SvOK(*cvp)) {
4761 sprintf(buf,"$^H{%s} is not defined", key);
4765 sv_2mortal(sv); /* Parent created it permanently */
4768 pv = sv_2mortal(newSVpv(s, len));
4770 typesv = sv_2mortal(newSVpv(type, 0));
4774 Zero(&myop, 1, BINOP);
4775 myop.op_last = (OP *) &myop;
4776 myop.op_next = Nullop;
4777 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
4779 PUSHSTACKi(PERLSI_OVERLOAD);
4783 if (PERLDB_SUB && curstash != debstash)
4784 op->op_private |= OPpENTERSUB_DB;
4795 if (op = pp_entersub(ARGS))
4802 CATCH_SET(oldcatch);
4806 sprintf(buf,"Call to &{$^H{%s}} did not return a defined value", key);
4809 return SvREFCNT_inc(res);
4813 scan_word(register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
4815 register char *d = dest;
4816 register char *e = d + destlen - 3; /* two-character token, ending NUL */
4819 croak(ident_too_long);
4822 else if (*s == '\'' && allow_package && isIDFIRST(s[1])) {
4827 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
4840 scan_ident(register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
4847 if (lex_brackets == 0)
4852 e = d + destlen - 3; /* two-character token, ending NUL */
4854 while (isDIGIT(*s)) {
4856 croak(ident_too_long);
4863 croak(ident_too_long);
4866 else if (*s == '\'' && isIDFIRST(s[1])) {
4871 else if (*s == ':' && s[1] == ':') {
4882 if (lex_state != LEX_NORMAL)
4883 lex_state = LEX_INTERPENDMAYBE;
4886 if (*s == '$' && s[1] &&
4887 (isALNUM(s[1]) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
4889 if (isDIGIT(s[1]) && lex_state == LEX_INTERPNORMAL)
4890 deprecate("\"$$<digit>\" to mean \"${$}<digit>\"");
4903 if (*d == '^' && *s && (isUPPER(*s) || strchr("[\\]^_?", *s))) {
4908 if (isSPACE(s[-1])) {
4911 if (ch != ' ' && ch != '\t') {
4917 if (isIDFIRST(*d)) {
4919 while (isALNUM(*s) || *s == ':')
4922 while (s < send && (*s == ' ' || *s == '\t')) s++;
4923 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
4924 if (dowarn && keyword(dest, d - dest)) {
4925 char *brack = *s == '[' ? "[...]" : "{...}";
4926 warn("Ambiguous use of %c{%s%s} resolved to %c%s%s",
4927 funny, dest, brack, funny, dest, brack);
4929 lex_fakebrack = lex_brackets+1;
4931 lex_brackstack[lex_brackets++] = XOPERATOR;
4937 if (lex_state == LEX_INTERPNORMAL && !lex_brackets)
4938 lex_state = LEX_INTERPEND;
4941 if (dowarn && lex_state == LEX_NORMAL &&
4942 (keyword(dest, d - dest) || perl_get_cv(dest, FALSE)))
4943 warn("Ambiguous use of %c{%s} resolved to %c%s",
4944 funny, dest, funny, dest);
4947 s = bracket; /* let the parser handle it */
4951 else if (lex_state == LEX_INTERPNORMAL && !lex_brackets && !intuit_more(s))
4952 lex_state = LEX_INTERPEND;
4956 void pmflag(U16 *pmfl, int ch)
4961 *pmfl |= PMf_GLOBAL;
4963 *pmfl |= PMf_CONTINUE;
4967 *pmfl |= PMf_MULTILINE;
4969 *pmfl |= PMf_SINGLELINE;
4971 *pmfl |= PMf_EXTENDED;
4975 scan_pat(char *start, I32 type)
4980 s = scan_str(start);
4983 SvREFCNT_dec(lex_stuff);
4985 croak("Search pattern not terminated");
4988 pm = (PMOP*)newPMOP(type, 0);
4989 if (multi_open == '?')
4990 pm->op_pmflags |= PMf_ONCE;
4992 while (*s && strchr("iomsx", *s))
4993 pmflag(&pm->op_pmflags,*s++);
4996 while (*s && strchr("iogcmsx", *s))
4997 pmflag(&pm->op_pmflags,*s++);
4999 pm->op_pmpermflags = pm->op_pmflags;
5002 yylval.ival = OP_MATCH;
5007 scan_subst(char *start)
5014 yylval.ival = OP_NULL;
5016 s = scan_str(start);
5020 SvREFCNT_dec(lex_stuff);
5022 croak("Substitution pattern not terminated");
5025 if (s[-1] == multi_open)
5028 first_start = multi_start;
5032 SvREFCNT_dec(lex_stuff);
5035 SvREFCNT_dec(lex_repl);
5037 croak("Substitution replacement not terminated");
5039 multi_start = first_start; /* so whole substitution is taken together */
5041 pm = (PMOP*)newPMOP(OP_SUBST, 0);
5047 else if (strchr("iogcmsx", *s))
5048 pmflag(&pm->op_pmflags,*s++);
5055 pm->op_pmflags |= PMf_EVAL;
5056 repl = newSVpv("",0);
5058 sv_catpv(repl, es ? "eval " : "do ");
5059 sv_catpvn(repl, "{ ", 2);
5060 sv_catsv(repl, lex_repl);
5061 sv_catpvn(repl, " };", 2);
5062 SvCOMPILED_on(repl);
5063 SvREFCNT_dec(lex_repl);
5067 pm->op_pmpermflags = pm->op_pmflags;
5069 yylval.ival = OP_SUBST;
5074 scan_trans(char *start)
5083 yylval.ival = OP_NULL;
5085 s = scan_str(start);
5088 SvREFCNT_dec(lex_stuff);
5090 croak("Transliteration pattern not terminated");
5092 if (s[-1] == multi_open)
5098 SvREFCNT_dec(lex_stuff);
5101 SvREFCNT_dec(lex_repl);
5103 croak("Transliteration replacement not terminated");
5106 New(803,tbl,256,short);
5107 o = newPVOP(OP_TRANS, 0, (char*)tbl);
5109 complement = Delete = squash = 0;
5110 while (*s == 'c' || *s == 'd' || *s == 's') {
5112 complement = OPpTRANS_COMPLEMENT;
5114 Delete = OPpTRANS_DELETE;
5116 squash = OPpTRANS_SQUASH;
5119 o->op_private = Delete|squash|complement;
5122 yylval.ival = OP_TRANS;
5127 scan_heredoc(register char *s)
5131 I32 op_type = OP_SCALAR;
5138 int outer = (rsfp && !(lex_inwhat == OP_SCALAR));
5142 e = tokenbuf + sizeof tokenbuf - 1;
5145 for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5146 if (*peek && strchr("`'\"",*peek)) {
5149 s = delimcpy(d, e, s, bufend, term, &len);
5160 deprecate("bare << to mean <<\"\"");
5161 for (; isALNUM(*s); s++) {
5166 if (d >= tokenbuf + sizeof tokenbuf - 1)
5167 croak("Delimiter for here document is too long");
5171 #ifdef TMP_CRLF_PATCH
5172 d = strchr(s, '\r');
5176 while (s < bufend) {
5182 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
5191 SvCUR_set(linestr, bufend - SvPVX(linestr));
5196 if (outer || !(d=ninstr(s,bufend,d,d+1)))
5197 herewas = newSVpv(s,bufend-s);
5199 s--, herewas = newSVpv(s,d-s);
5200 s += SvCUR(herewas);
5202 tmpstr = NEWSV(87,79);
5203 sv_upgrade(tmpstr, SVt_PVIV);
5208 else if (term == '`') {
5209 op_type = OP_BACKTICK;
5210 SvIVX(tmpstr) = '\\';
5214 multi_start = curcop->cop_line;
5215 multi_open = multi_close = '<';
5219 while (s < bufend &&
5220 (*s != term || memNE(s,tokenbuf,len)) ) {
5225 curcop->cop_line = multi_start;
5226 missingterm(tokenbuf);
5228 sv_setpvn(tmpstr,d+1,s-d);
5230 curcop->cop_line++; /* the preceding stmt passes a newline */
5232 sv_catpvn(herewas,s,bufend-s);
5233 sv_setsv(linestr,herewas);
5234 oldoldbufptr = oldbufptr = bufptr = s = linestart = SvPVX(linestr);
5235 bufend = SvPVX(linestr) + SvCUR(linestr);
5238 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
5239 while (s >= bufend) { /* multiple line string? */
5241 !(oldoldbufptr = oldbufptr = s = linestart = filter_gets(linestr, rsfp, 0))) {
5242 curcop->cop_line = multi_start;
5243 missingterm(tokenbuf);
5246 bufend = SvPVX(linestr) + SvCUR(linestr);
5247 #ifdef TMP_CRLF_PATCH
5248 if (bufend - linestart >= 2) {
5249 if (bufend[-2] == '\r' || bufend[-2] == '\n') {
5252 SvCUR_set(linestr, bufend - SvPVX(linestr));
5254 else if (bufend[-1] == '\r')
5257 else if (bufend - linestart == 1 && bufend[-1] == '\r')
5260 if (PERLDB_LINE && curstash != debstash) {
5261 SV *sv = NEWSV(88,0);
5263 sv_upgrade(sv, SVt_PVMG);
5264 sv_setsv(sv,linestr);
5265 av_store(GvAV(curcop->cop_filegv),
5266 (I32)curcop->cop_line,sv);
5268 if (*s == term && memEQ(s,tokenbuf,len)) {
5271 sv_catsv(linestr,herewas);
5272 bufend = SvPVX(linestr) + SvCUR(linestr);
5276 sv_catsv(tmpstr,linestr);
5279 multi_end = curcop->cop_line;
5281 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
5282 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
5283 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
5285 SvREFCNT_dec(herewas);
5287 yylval.ival = op_type;
5292 takes: current position in input buffer
5293 returns: new position in input buffer
5294 side-effects: yylval and lex_op are set.
5299 <FH> read from filehandle
5300 <pkg::FH> read from package qualified filehandle
5301 <pkg'FH> read from package qualified filehandle
5302 <$fh> read from filehandle in $fh
5308 scan_inputsymbol(char *start)
5310 register char *s = start; /* current position in buffer */
5315 d = tokenbuf; /* start of temp holding space */
5316 e = tokenbuf + sizeof tokenbuf; /* end of temp holding space */
5317 s = delimcpy(d, e, s + 1, bufend, '>', &len); /* extract until > */
5319 /* die if we didn't have space for the contents of the <>,
5323 if (len >= sizeof tokenbuf)
5324 croak("Excessively long <> operator");
5326 croak("Unterminated <> operator");
5331 Remember, only scalar variables are interpreted as filehandles by
5332 this code. Anything more complex (e.g., <$fh{$num}>) will be
5333 treated as a glob() call.
5334 This code makes use of the fact that except for the $ at the front,
5335 a scalar variable and a filehandle look the same.
5337 if (*d == '$' && d[1]) d++;
5339 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
5340 while (*d && (isALNUM(*d) || *d == '\'' || *d == ':'))
5343 /* If we've tried to read what we allow filehandles to look like, and
5344 there's still text left, then it must be a glob() and not a getline.
5345 Use scan_str to pull out the stuff between the <> and treat it
5346 as nothing more than a string.
5349 if (d - tokenbuf != len) {
5350 yylval.ival = OP_GLOB;
5352 s = scan_str(start);
5354 croak("Glob not terminated");
5358 /* we're in a filehandle read situation */
5361 /* turn <> into <ARGV> */
5363 (void)strcpy(d,"ARGV");
5365 /* if <$fh>, create the ops to turn the variable into a
5371 /* try to find it in the pad for this block, otherwise find
5372 add symbol table ops
5374 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
5375 OP *o = newOP(OP_PADSV, 0);
5377 lex_op = (OP*)newUNOP(OP_READLINE, 0, newUNOP(OP_RV2GV, 0, o));
5380 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
5381 lex_op = (OP*)newUNOP(OP_READLINE, 0,
5382 newUNOP(OP_RV2GV, 0,
5383 newUNOP(OP_RV2SV, 0,
5384 newGVOP(OP_GV, 0, gv))));
5386 /* we created the ops in lex_op, so make yylval.ival a null op */
5387 yylval.ival = OP_NULL;
5390 /* If it's none of the above, it must be a literal filehandle
5391 (<Foo::BAR> or <FOO>) so build a simple readline OP */
5393 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
5394 lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
5395 yylval.ival = OP_NULL;
5404 takes: start position in buffer
5405 returns: position to continue reading from buffer
5406 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
5407 updates the read buffer.
5409 This subroutine pulls a string out of the input. It is called for:
5410 q single quotes q(literal text)
5411 ' single quotes 'literal text'
5412 qq double quotes qq(interpolate $here please)
5413 " double quotes "interpolate $here please"
5414 qx backticks qx(/bin/ls -l)
5415 ` backticks `/bin/ls -l`
5416 qw quote words @EXPORT_OK = qw( func() $spam )
5417 m// regexp match m/this/
5418 s/// regexp substitute s/this/that/
5419 tr/// string transliterate tr/this/that/
5420 y/// string transliterate y/this/that/
5421 ($*@) sub prototypes sub foo ($)
5422 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
5424 In most of these cases (all but <>, patterns and transliterate)
5425 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
5426 calls scan_str(). s/// makes yylex() call scan_subst() which calls
5427 scan_str(). tr/// and y/// make yylex() call scan_trans() which
5430 It skips whitespace before the string starts, and treats the first
5431 character as the delimiter. If the delimiter is one of ([{< then
5432 the corresponding "close" character )]}> is used as the closing
5433 delimiter. It allows quoting of delimiters, and if the string has
5434 balanced delimiters ([{<>}]) it allows nesting.
5436 The lexer always reads these strings into lex_stuff, except in the
5437 case of the operators which take *two* arguments (s/// and tr///)
5438 when it checks to see if lex_stuff is full (presumably with the 1st
5439 arg to s or tr) and if so puts the string into lex_repl.
5444 scan_str(char *start)
5447 SV *sv; /* scalar value: string */
5448 char *tmps; /* temp string, used for delimiter matching */
5449 register char *s = start; /* current position in the buffer */
5450 register char term; /* terminating character */
5451 register char *to; /* current position in the sv's data */
5452 I32 brackets = 1; /* bracket nesting level */
5454 /* skip space before the delimiter */
5458 /* mark where we are, in case we need to report errors */
5461 /* after skipping whitespace, the next character is the terminator */
5463 /* mark where we are */
5464 multi_start = curcop->cop_line;
5467 /* find corresponding closing delimiter */
5468 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5472 /* create a new SV to hold the contents. 87 is leak category, I'm
5473 assuming. 79 is the SV's initial length. What a random number. */
5475 sv_upgrade(sv, SVt_PVIV);
5477 (void)SvPOK_only(sv); /* validate pointer */
5479 /* move past delimiter and try to read a complete string */
5482 /* extend sv if need be */
5483 SvGROW(sv, SvCUR(sv) + (bufend - s) + 1);
5484 /* set 'to' to the next character in the sv's string */
5485 to = SvPVX(sv)+SvCUR(sv);
5487 /* if open delimiter is the close delimiter read unbridle */
5488 if (multi_open == multi_close) {
5489 for (; s < bufend; s++,to++) {
5490 /* embedded newlines increment the current line number */
5491 if (*s == '\n' && !rsfp)
5493 /* handle quoted delimiters */
5494 if (*s == '\\' && s+1 < bufend && term != '\\') {
5497 /* any other quotes are simply copied straight through */
5501 /* terminate when run out of buffer (the for() condition), or
5502 have found the terminator */
5503 else if (*s == term)
5509 /* if the terminator isn't the same as the start character (e.g.,
5510 matched brackets), we have to allow more in the quoting, and
5511 be prepared for nested brackets.
5514 /* read until we run out of string, or we find the terminator */
5515 for (; s < bufend; s++,to++) {
5516 /* embedded newlines increment the line count */
5517 if (*s == '\n' && !rsfp)
5519 /* backslashes can escape the open or closing characters */
5520 if (*s == '\\' && s+1 < bufend) {
5521 if ((s[1] == multi_open) || (s[1] == multi_close))
5526 /* allow nested opens and closes */
5527 else if (*s == multi_close && --brackets <= 0)
5529 else if (*s == multi_open)
5534 /* terminate the copied string and update the sv's end-of-string */
5536 SvCUR_set(sv, to - SvPVX(sv));
5539 * this next chunk reads more into the buffer if we're not done yet
5542 if (s < bufend) break; /* handle case where we are done yet :-) */
5544 #ifdef TMP_CRLF_PATCH
5545 if (to - SvPVX(sv) >= 2) {
5546 if (to[-2] == '\r' || to[-2] == '\n') {
5549 SvCUR_set(sv, to - SvPVX(sv));
5551 else if (to[-1] == '\r')
5554 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
5558 /* if we're out of file, or a read fails, bail and reset the current
5559 line marker so we can report where the unterminated string began
5562 !(oldoldbufptr = oldbufptr = s = linestart = filter_gets(linestr, rsfp, 0))) {
5564 curcop->cop_line = multi_start;
5567 /* we read a line, so increment our line counter */
5570 /* update debugger info */
5571 if (PERLDB_LINE && curstash != debstash) {
5572 SV *sv = NEWSV(88,0);
5574 sv_upgrade(sv, SVt_PVMG);
5575 sv_setsv(sv,linestr);
5576 av_store(GvAV(curcop->cop_filegv),
5577 (I32)curcop->cop_line, sv);
5580 /* having changed the buffer, we must update bufend */
5581 bufend = SvPVX(linestr) + SvCUR(linestr);
5584 /* at this point, we have successfully read the delimited string */
5586 multi_end = curcop->cop_line;
5589 /* if we allocated too much space, give some back */
5590 if (SvCUR(sv) + 5 < SvLEN(sv)) {
5591 SvLEN_set(sv, SvCUR(sv) + 1);
5592 Renew(SvPVX(sv), SvLEN(sv), char);
5595 /* decide whether this is the first or second quoted string we've read
5608 takes: pointer to position in buffer
5609 returns: pointer to new position in buffer
5610 side-effects: builds ops for the constant in yylval.op
5612 Read a number in any of the formats that Perl accepts:
5614 0(x[0-7A-F]+)|([0-7]+)
5615 [\d_]+(\.[\d_]*)?[Ee](\d+)
5617 Underbars (_) are allowed in decimal numbers. If -w is on,
5618 underbars before a decimal point must be at three digit intervals.
5620 Like most scan_ routines, it uses the tokenbuf buffer to hold the
5623 If it reads a number without a decimal point or an exponent, it will
5624 try converting the number to an integer and see if it can do so
5625 without loss of precision.
5629 scan_num(char *start)
5631 register char *s = start; /* current position in buffer */
5632 register char *d; /* destination in temp buffer */
5633 register char *e; /* end of temp buffer */
5634 I32 tryiv; /* used to see if it can be an int */
5635 double value; /* number read, as a double */
5636 SV *sv; /* place to put the converted number */
5637 I32 floatit; /* boolean: int or float? */
5638 char *lastub = 0; /* position of last underbar */
5639 static char number_too_long[] = "Number too long";
5641 /* We use the first character to decide what type of number this is */
5645 croak("panic: scan_num");
5647 /* if it starts with a 0, it could be an octal number, a decimal in
5648 0.13 disguise, or a hexadecimal number.
5653 u holds the "number so far"
5654 shift the power of 2 of the base (hex == 4, octal == 3)
5655 overflowed was the number more than we can hold?
5657 Shift is used when we add a digit. It also serves as an "are
5658 we in octal or hex?" indicator to disallow hex characters when
5663 bool overflowed = FALSE;
5670 /* check for a decimal in disguise */
5671 else if (s[1] == '.')
5673 /* so it must be octal */
5678 /* read the rest of the octal number */
5680 UV n, b; /* n is used in the overflow test, b is the digit we're adding on */
5684 /* if we don't mention it, we're done */
5693 /* 8 and 9 are not octal */
5696 yyerror("Illegal octal digit");
5700 case '0': case '1': case '2': case '3': case '4':
5701 case '5': case '6': case '7':
5702 b = *s++ & 15; /* ASCII digit -> value of digit */
5706 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
5707 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
5708 /* make sure they said 0x */
5713 /* Prepare to put the digit we have onto the end
5714 of the number so far. We check for overflows.
5718 n = u << shift; /* make room for the digit */
5719 if (!overflowed && (n >> shift) != u
5720 && !(hints & HINT_NEW_BINARY)) {
5721 warn("Integer overflow in %s number",
5722 (shift == 4) ? "hex" : "octal");
5725 u = n | b; /* add the digit to the end */
5730 /* if we get here, we had success: make a scalar value from
5736 if ( hints & HINT_NEW_BINARY)
5737 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
5742 handle decimal numbers.
5743 we're also sent here when we read a 0 as the first digit
5745 case '1': case '2': case '3': case '4': case '5':
5746 case '6': case '7': case '8': case '9': case '.':
5749 e = tokenbuf + sizeof tokenbuf - 6; /* room for various punctuation */
5752 /* read next group of digits and _ and copy into d */
5753 while (isDIGIT(*s) || *s == '_') {
5754 /* skip underscores, checking for misplaced ones
5758 if (dowarn && lastub && s - lastub != 3)
5759 warn("Misplaced _ in number");
5763 /* check for end of fixed-length buffer */
5765 croak(number_too_long);
5766 /* if we're ok, copy the character */
5771 /* final misplaced underbar check */
5772 if (dowarn && lastub && s - lastub != 3)
5773 warn("Misplaced _ in number");
5775 /* read a decimal portion if there is one. avoid
5776 3..5 being interpreted as the number 3. followed
5779 if (*s == '.' && s[1] != '.') {
5783 /* copy, ignoring underbars, until we run out of
5784 digits. Note: no misplaced underbar checks!
5786 for (; isDIGIT(*s) || *s == '_'; s++) {
5787 /* fixed length buffer check */
5789 croak(number_too_long);
5795 /* read exponent part, if present */
5796 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
5800 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
5801 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
5803 /* allow positive or negative exponent */
5804 if (*s == '+' || *s == '-')
5807 /* read digits of exponent (no underbars :-) */
5808 while (isDIGIT(*s)) {
5810 croak(number_too_long);
5815 /* terminate the string */
5818 /* make an sv from the string */
5820 /* reset numeric locale in case we were earlier left in Swaziland */
5821 SET_NUMERIC_STANDARD();
5822 value = atof(tokenbuf);
5825 See if we can make do with an integer value without loss of
5826 precision. We use I_V to cast to an int, because some
5827 compilers have issues. Then we try casting it back and see
5828 if it was the same. We only do this if we know we
5829 specifically read an integer.
5831 Note: if floatit is true, then we don't need to do the
5835 if (!floatit && (double)tryiv == value)
5836 sv_setiv(sv, tryiv);
5838 sv_setnv(sv, value);
5839 if ( floatit ? (hints & HINT_NEW_FLOAT) : (hints & HINT_NEW_INTEGER) )
5840 sv = new_constant(tokenbuf, d - tokenbuf,
5841 (floatit ? "float" : "integer"), sv, Nullsv, NULL);
5845 /* make the op for the constant and return */
5847 yylval.opval = newSVOP(OP_CONST, 0, sv);
5853 scan_formline(register char *s)
5858 SV *stuff = newSVpv("",0);
5859 bool needargs = FALSE;
5862 if (*s == '.' || *s == '}') {
5864 for (t = s+1; *t == ' ' || *t == '\t'; t++) ;
5868 if (in_eval && !rsfp) {
5869 eol = strchr(s,'\n');
5874 eol = bufend = SvPVX(linestr) + SvCUR(linestr);
5876 for (t = s; t < eol; t++) {
5877 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
5879 goto enough; /* ~~ must be first line in formline */
5881 if (*t == '@' || *t == '^')
5884 sv_catpvn(stuff, s, eol-s);
5888 s = filter_gets(linestr, rsfp, 0);
5889 oldoldbufptr = oldbufptr = bufptr = linestart = SvPVX(linestr);
5890 bufend = bufptr + SvCUR(linestr);
5893 yyerror("Format not terminated");
5903 lex_state = LEX_NORMAL;
5904 nextval[nexttoke].ival = 0;
5908 lex_state = LEX_FORMLINE;
5909 nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
5911 nextval[nexttoke].ival = OP_FORMLINE;
5915 SvREFCNT_dec(stuff);
5927 cshlen = strlen(cshname);
5932 start_subparse(I32 is_format, U32 flags)
5935 I32 oldsavestack_ix = savestack_ix;
5936 CV* outsidecv = compcv;
5940 assert(SvTYPE(compcv) == SVt_PVCV);
5947 SAVESPTR(comppad_name);
5949 SAVEI32(comppad_name_fill);
5950 SAVEI32(min_intro_pending);
5951 SAVEI32(max_intro_pending);
5952 SAVEI32(pad_reset_pending);
5954 compcv = (CV*)NEWSV(1104,0);
5955 sv_upgrade((SV *)compcv, is_format ? SVt_PVFM : SVt_PVCV);
5956 CvFLAGS(compcv) |= flags;
5959 av_push(comppad, Nullsv);
5960 curpad = AvARRAY(comppad);
5961 comppad_name = newAV();
5962 comppad_name_fill = 0;
5963 min_intro_pending = 0;
5965 subline = curcop->cop_line;
5967 av_store(comppad_name, 0, newSVpv("@_", 2));
5968 curpad[0] = (SV*)newAV();
5969 SvPADMY_on(curpad[0]); /* XXX Needed? */
5970 CvOWNER(compcv) = 0;
5971 New(666, CvMUTEXP(compcv), 1, perl_mutex);
5972 MUTEX_INIT(CvMUTEXP(compcv));
5973 #endif /* USE_THREADS */
5975 comppadlist = newAV();
5976 AvREAL_off(comppadlist);
5977 av_store(comppadlist, 0, (SV*)comppad_name);
5978 av_store(comppadlist, 1, (SV*)comppad);
5980 CvPADLIST(compcv) = comppadlist;
5981 CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc(outsidecv);
5983 CvOWNER(compcv) = 0;
5984 New(666, CvMUTEXP(compcv), 1, perl_mutex);
5985 MUTEX_INIT(CvMUTEXP(compcv));
5986 #endif /* USE_THREADS */
5988 return oldsavestack_ix;
6007 char *context = NULL;
6011 if (!yychar || (yychar == ';' && !rsfp))
6013 else if (bufptr > oldoldbufptr && bufptr - oldoldbufptr < 200 &&
6014 oldoldbufptr != oldbufptr && oldbufptr != bufptr) {
6015 while (isSPACE(*oldoldbufptr))
6017 context = oldoldbufptr;
6018 contlen = bufptr - oldoldbufptr;
6020 else if (bufptr > oldbufptr && bufptr - oldbufptr < 200 &&
6021 oldbufptr != bufptr) {
6022 while (isSPACE(*oldbufptr))
6024 context = oldbufptr;
6025 contlen = bufptr - oldbufptr;
6027 else if (yychar > 255)
6028 where = "next token ???";
6029 else if ((yychar & 127) == 127) {
6030 if (lex_state == LEX_NORMAL ||
6031 (lex_state == LEX_KNOWNEXT && lex_defer == LEX_NORMAL))
6032 where = "at end of line";
6034 where = "within pattern";
6036 where = "within string";
6039 SV *where_sv = sv_2mortal(newSVpv("next char ", 0));
6041 sv_catpvf(where_sv, "^%c", toCTRL(yychar));
6042 else if (isPRINT_LC(yychar))
6043 sv_catpvf(where_sv, "%c", yychar);
6045 sv_catpvf(where_sv, "\\%03o", yychar & 255);
6046 where = SvPVX(where_sv);
6048 msg = sv_2mortal(newSVpv(s, 0));
6049 sv_catpvf(msg, " at %_ line %ld, ",
6050 GvSV(curcop->cop_filegv), (long)curcop->cop_line);
6052 sv_catpvf(msg, "near \"%.*s\"\n", contlen, context);
6054 sv_catpvf(msg, "%s\n", where);
6055 if (multi_start < multi_end && (U32)(curcop->cop_line - multi_end) <= 1) {
6057 " (Might be a runaway multi-line %c%c string starting on line %ld)\n",
6058 (int)multi_open,(int)multi_close,(long)multi_start);
6064 sv_catsv(ERRSV, msg);
6066 PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
6067 if (++error_count >= 10)
6068 croak("%_ has too many errors.\n", GvSV(curcop->cop_filegv));
6070 in_my_stash = Nullhv;