3 * Copyright (c) 1991-1997, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "It all comes from here, the stench and the peril." --Frodo
18 static void check_uni _((void));
19 static void force_next _((I32 type));
20 static char *force_version _((char *start));
21 static char *force_word _((char *start, int token, int check_keyword, int allow_pack, int allow_tick));
22 static SV *tokeq _((SV *sv));
23 static char *scan_const _((char *start));
24 static char *scan_formline _((char *s));
25 static char *scan_heredoc _((char *s));
26 static char *scan_ident _((char *s, char *send, char *dest, STRLEN destlen,
28 static char *scan_inputsymbol _((char *start));
29 static char *scan_pat _((char *start, I32 type));
30 static char *scan_str _((char *start));
31 static char *scan_subst _((char *start));
32 static char *scan_trans _((char *start));
33 static char *scan_word _((char *s, char *dest, STRLEN destlen,
34 int allow_package, STRLEN *slp));
35 static char *skipspace _((char *s));
36 static void checkcomma _((char *s, char *name, char *what));
37 static void force_ident _((char *s, int kind));
38 static void incline _((char *s));
39 static int intuit_method _((char *s, GV *gv));
40 static int intuit_more _((char *s));
41 static I32 lop _((I32 f, expectation x, char *s));
42 static void missingterm _((char *s));
43 static void no_op _((char *what, char *s));
44 static void set_csh _((void));
45 static I32 sublex_done _((void));
46 static I32 sublex_push _((void));
47 static I32 sublex_start _((void));
49 static int uni _((I32 f, char *s));
51 static char * filter_gets _((SV *sv, PerlIO *fp, STRLEN append));
52 static void restore_rsfp _((void *f));
53 static SV *new_constant _((char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type));
54 static void restore_expect _((void *e));
55 static void restore_lex_expect _((void *e));
56 #endif /* PERL_OBJECT */
58 static char ident_too_long[] = "Identifier too long";
60 /* The following are arranged oddly so that the guard on the switch statement
61 * can get by with a single comparison (if the compiler is smart enough).
64 /* #define LEX_NOTPARSING 11 is done in perl.h. */
67 #define LEX_INTERPNORMAL 9
68 #define LEX_INTERPCASEMOD 8
69 #define LEX_INTERPPUSH 7
70 #define LEX_INTERPSTART 6
71 #define LEX_INTERPEND 5
72 #define LEX_INTERPENDMAYBE 4
73 #define LEX_INTERPCONCAT 3
74 #define LEX_INTERPCONST 2
75 #define LEX_FORMLINE 1
76 #define LEX_KNOWNEXT 0
85 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
87 # include <unistd.h> /* Needed for execv() */
100 #define CLINE (PL_copline = (PL_curcop->cop_line < PL_copline ? PL_curcop->cop_line : PL_copline))
102 #define TOKEN(retval) return (PL_bufptr = s,(int)retval)
103 #define OPERATOR(retval) return (PL_expect = XTERM,PL_bufptr = s,(int)retval)
104 #define AOPERATOR(retval) return ao((PL_expect = XTERM,PL_bufptr = s,(int)retval))
105 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s,(int)retval)
106 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval)
107 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s,(int)retval)
108 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR,PL_bufptr = s,(int)retval)
109 #define LOOPX(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX)
110 #define FTST(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)UNIOP)
111 #define FUN0(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0)
112 #define FUN1(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1)
113 #define BOop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITOROP))
114 #define BAop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP))
115 #define SHop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP))
116 #define PWop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)POWOP))
117 #define PMop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP)
118 #define Aop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)ADDOP))
119 #define Mop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MULOP))
120 #define Eop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)EQOP)
121 #define Rop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)RELOP)
123 /* This bit of chicanery makes a unary function followed by
124 * a parenthesis into a function with one argument, highest precedence.
126 #define UNI(f) return(yylval.ival = f, \
129 PL_last_uni = PL_oldbufptr, \
130 PL_last_lop_op = f, \
131 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
133 #define UNIBRACK(f) return(yylval.ival = f, \
135 PL_last_uni = PL_oldbufptr, \
136 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
138 /* grandfather return to old style */
139 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
144 if (*PL_bufptr == '=') {
146 if (toketype == ANDAND)
147 yylval.ival = OP_ANDASSIGN;
148 else if (toketype == OROR)
149 yylval.ival = OP_ORASSIGN;
156 no_op(char *what, char *s)
158 char *oldbp = PL_bufptr;
159 bool is_first = (PL_oldbufptr == PL_linestart);
162 yywarn(form("%s found where operator expected", what));
164 warn("\t(Missing semicolon on previous line?)\n");
165 else if (PL_oldoldbufptr && isIDFIRST(*PL_oldoldbufptr)) {
167 for (t = PL_oldoldbufptr; *t && (isALNUM(*t) || *t == ':'); t++) ;
168 if (t < PL_bufptr && isSPACE(*t))
169 warn("\t(Do you need to predeclare %.*s?)\n",
170 t - PL_oldoldbufptr, PL_oldoldbufptr);
174 warn("\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
184 char *nl = strrchr(s,'\n');
190 iscntrl(PL_multi_close)
192 PL_multi_close < 32 || PL_multi_close == 127
196 tmpbuf[1] = toCTRL(PL_multi_close);
202 *tmpbuf = PL_multi_close;
206 q = strchr(s,'"') ? '\'' : '"';
207 croak("Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
214 warn("Use of %s is deprecated", s);
220 deprecate("comma-less variable list");
226 win32_textfilter(int idx, SV *sv, int maxlen)
228 I32 count = FILTER_READ(idx+1, sv, maxlen);
229 if (count > 0 && !maxlen)
230 win32_strip_return(sv);
243 SAVEI32(PL_lex_dojoin);
244 SAVEI32(PL_lex_brackets);
245 SAVEI32(PL_lex_fakebrack);
246 SAVEI32(PL_lex_casemods);
247 SAVEI32(PL_lex_starts);
248 SAVEI32(PL_lex_state);
249 SAVESPTR(PL_lex_inpat);
250 SAVEI32(PL_lex_inwhat);
251 SAVEI16(PL_curcop->cop_line);
254 SAVEPPTR(PL_oldbufptr);
255 SAVEPPTR(PL_oldoldbufptr);
256 SAVEPPTR(PL_linestart);
257 SAVESPTR(PL_linestr);
258 SAVEPPTR(PL_lex_brackstack);
259 SAVEPPTR(PL_lex_casestack);
260 SAVEDESTRUCTOR(restore_rsfp, PL_rsfp);
261 SAVESPTR(PL_lex_stuff);
262 SAVEI32(PL_lex_defer);
263 SAVESPTR(PL_lex_repl);
264 SAVEDESTRUCTOR(restore_expect, PL_tokenbuf + PL_expect); /* encode as pointer */
265 SAVEDESTRUCTOR(restore_lex_expect, PL_tokenbuf + PL_expect);
267 PL_lex_state = LEX_NORMAL;
271 PL_lex_fakebrack = 0;
272 New(899, PL_lex_brackstack, 120, char);
273 New(899, PL_lex_casestack, 12, char);
274 SAVEFREEPV(PL_lex_brackstack);
275 SAVEFREEPV(PL_lex_casestack);
277 *PL_lex_casestack = '\0';
280 PL_lex_stuff = Nullsv;
281 PL_lex_repl = Nullsv;
285 if (SvREADONLY(PL_linestr))
286 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
287 s = SvPV(PL_linestr, len);
288 if (len && s[len-1] != ';') {
289 if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
290 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
291 sv_catpvn(PL_linestr, "\n;", 2);
293 SvTEMP_off(PL_linestr);
294 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
295 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
297 PL_rs = newSVpv("\n", 1);
304 PL_doextract = FALSE;
308 restore_rsfp(void *f)
310 PerlIO *fp = (PerlIO*)f;
312 if (PL_rsfp == PerlIO_stdin())
313 PerlIO_clearerr(PL_rsfp);
314 else if (PL_rsfp && (PL_rsfp != fp))
315 PerlIO_close(PL_rsfp);
320 restore_expect(void *e)
322 /* a safe way to store a small integer in a pointer */
323 PL_expect = (expectation)((char *)e - PL_tokenbuf);
327 restore_lex_expect(void *e)
329 /* a safe way to store a small integer in a pointer */
330 PL_lex_expect = (expectation)((char *)e - PL_tokenbuf);
342 PL_curcop->cop_line++;
345 while (*s == ' ' || *s == '\t') s++;
346 if (strnEQ(s, "line ", 5)) {
355 while (*s == ' ' || *s == '\t')
357 if (*s == '"' && (t = strchr(s+1, '"')))
361 return; /* false alarm */
362 for (t = s; !isSPACE(*t); t++) ;
367 PL_curcop->cop_filegv = gv_fetchfile(s);
369 PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
371 PL_curcop->cop_line = atoi(n)-1;
375 skipspace(register char *s)
378 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
379 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
385 while (s < PL_bufend && isSPACE(*s))
387 if (s < PL_bufend && *s == '#') {
388 while (s < PL_bufend && *s != '\n')
393 if (s < PL_bufend || !PL_rsfp || PL_lex_state != LEX_NORMAL)
395 if ((s = filter_gets(PL_linestr, PL_rsfp, (prevlen = SvCUR(PL_linestr)))) == Nullch) {
396 if (PL_minus_n || PL_minus_p) {
397 sv_setpv(PL_linestr,PL_minus_p ?
398 ";}continue{print or die qq(-p destination: $!\\n)" :
400 sv_catpv(PL_linestr,";}");
401 PL_minus_n = PL_minus_p = 0;
404 sv_setpv(PL_linestr,";");
405 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
406 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
407 if (PL_preprocess && !PL_in_eval)
408 (void)PerlProc_pclose(PL_rsfp);
409 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
410 PerlIO_clearerr(PL_rsfp);
412 (void)PerlIO_close(PL_rsfp);
416 PL_linestart = PL_bufptr = s + prevlen;
417 PL_bufend = s + SvCUR(PL_linestr);
420 if (PERLDB_LINE && PL_curstash != PL_debstash) {
421 SV *sv = NEWSV(85,0);
423 sv_upgrade(sv, SVt_PVMG);
424 sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
425 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
436 if (PL_oldoldbufptr != PL_last_uni)
438 while (isSPACE(*PL_last_uni))
440 for (s = PL_last_uni; isALNUM(*s) || *s == '-'; s++) ;
441 if ((t = strchr(s, '(')) && t < PL_bufptr)
445 warn("Warning: Use of \"%s\" without parens is ambiguous", PL_last_uni);
452 #define UNI(f) return uni(f,s)
460 PL_last_uni = PL_oldbufptr;
471 #endif /* CRIPPLED_CC */
473 #define LOP(f,x) return lop(f,x,s)
476 lop(I32 f, expectation x, char *s)
483 PL_last_lop = PL_oldbufptr;
499 PL_nexttype[PL_nexttoke] = type;
501 if (PL_lex_state != LEX_KNOWNEXT) {
502 PL_lex_defer = PL_lex_state;
503 PL_lex_expect = PL_expect;
504 PL_lex_state = LEX_KNOWNEXT;
509 force_word(register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
514 start = skipspace(start);
517 (allow_pack && *s == ':') ||
518 (allow_initial_tick && *s == '\'') )
520 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
521 if (check_keyword && keyword(PL_tokenbuf, len))
523 if (token == METHOD) {
528 PL_expect = XOPERATOR;
533 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(PL_tokenbuf,0));
534 PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
541 force_ident(register char *s, int kind)
544 OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
545 PL_nextval[PL_nexttoke].opval = o;
548 dTHR; /* just for in_eval */
549 o->op_private = OPpCONST_ENTERED;
550 /* XXX see note in pp_entereval() for why we forgo typo
551 warnings if the symbol must be introduced in an eval.
553 gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
554 kind == '$' ? SVt_PV :
555 kind == '@' ? SVt_PVAV :
556 kind == '%' ? SVt_PVHV :
564 force_version(char *s)
566 OP *version = Nullop;
570 /* default VERSION number -- GBARR */
575 for( d=s, c = 1; isDIGIT(*d) || *d == '_' || (*d == '.' && c--); d++);
576 if((*d == ';' || isSPACE(*d)) && *(skipspace(d)) != ',') {
578 /* real VERSION number -- GBARR */
579 version = yylval.opval;
583 /* NOTE: The parser sees the package name and the VERSION swapped */
584 PL_nextval[PL_nexttoke].opval = version;
602 s = SvPV_force(sv, len);
606 while (s < send && *s != '\\')
611 if ( PL_hints & HINT_NEW_STRING )
612 pv = sv_2mortal(newSVpv(SvPVX(pv), len));
615 if (s + 1 < send && (s[1] == '\\'))
616 s++; /* all that, just for this */
621 SvCUR_set(sv, d - SvPVX(sv));
623 if ( PL_hints & HINT_NEW_STRING )
624 return new_constant(NULL, 0, "q", sv, pv, "q");
631 register I32 op_type = yylval.ival;
633 if (op_type == OP_NULL) {
634 yylval.opval = PL_lex_op;
638 if (op_type == OP_CONST || op_type == OP_READLINE) {
639 SV *sv = tokeq(PL_lex_stuff);
641 if (SvTYPE(sv) == SVt_PVIV) {
642 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
648 nsv = newSVpv(p, len);
652 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
653 PL_lex_stuff = Nullsv;
657 PL_sublex_info.super_state = PL_lex_state;
658 PL_sublex_info.sub_inwhat = op_type;
659 PL_sublex_info.sub_op = PL_lex_op;
660 PL_lex_state = LEX_INTERPPUSH;
664 yylval.opval = PL_lex_op;
678 PL_lex_state = PL_sublex_info.super_state;
679 SAVEI32(PL_lex_dojoin);
680 SAVEI32(PL_lex_brackets);
681 SAVEI32(PL_lex_fakebrack);
682 SAVEI32(PL_lex_casemods);
683 SAVEI32(PL_lex_starts);
684 SAVEI32(PL_lex_state);
685 SAVESPTR(PL_lex_inpat);
686 SAVEI32(PL_lex_inwhat);
687 SAVEI16(PL_curcop->cop_line);
689 SAVEPPTR(PL_oldbufptr);
690 SAVEPPTR(PL_oldoldbufptr);
691 SAVEPPTR(PL_linestart);
692 SAVESPTR(PL_linestr);
693 SAVEPPTR(PL_lex_brackstack);
694 SAVEPPTR(PL_lex_casestack);
696 PL_linestr = PL_lex_stuff;
697 PL_lex_stuff = Nullsv;
699 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
700 PL_bufend += SvCUR(PL_linestr);
701 SAVEFREESV(PL_linestr);
703 PL_lex_dojoin = FALSE;
705 PL_lex_fakebrack = 0;
706 New(899, PL_lex_brackstack, 120, char);
707 New(899, PL_lex_casestack, 12, char);
708 SAVEFREEPV(PL_lex_brackstack);
709 SAVEFREEPV(PL_lex_casestack);
711 *PL_lex_casestack = '\0';
713 PL_lex_state = LEX_INTERPCONCAT;
714 PL_curcop->cop_line = PL_multi_start;
716 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
717 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
718 PL_lex_inpat = PL_sublex_info.sub_op;
720 PL_lex_inpat = Nullop;
728 if (!PL_lex_starts++) {
729 PL_expect = XOPERATOR;
730 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv("",0));
734 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
735 PL_lex_state = LEX_INTERPCASEMOD;
739 /* Is there a right-hand side to take care of? */
740 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
741 PL_linestr = PL_lex_repl;
743 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
744 PL_bufend += SvCUR(PL_linestr);
745 SAVEFREESV(PL_linestr);
746 PL_lex_dojoin = FALSE;
748 PL_lex_fakebrack = 0;
750 *PL_lex_casestack = '\0';
752 if (SvCOMPILED(PL_lex_repl)) {
753 PL_lex_state = LEX_INTERPNORMAL;
757 PL_lex_state = LEX_INTERPCONCAT;
758 PL_lex_repl = Nullsv;
763 PL_bufend = SvPVX(PL_linestr);
764 PL_bufend += SvCUR(PL_linestr);
765 PL_expect = XOPERATOR;
773 Extracts a pattern, double-quoted string, or transliteration. This
776 It looks at lex_inwhat and PL_lex_inpat to find out whether it's
777 processing a pattern (PL_lex_inpat is true), a transliteration
778 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
780 Returns a pointer to the character scanned up to. Iff this is
781 advanced from the start pointer supplied (ie if anything was
782 successfully parsed), will leave an OP for the substring scanned
783 in yylval. Caller must intuit reason for not parsing further
784 by looking at the next characters herself.
788 double-quoted style: \r and \n
789 regexp special ones: \D \s
791 backrefs: \1 (deprecated in substitution replacements)
792 case and quoting: \U \Q \E
793 stops on @ and $, but not for $ as tail anchor
796 characters are VERY literal, except for - not at the start or end
797 of the string, which indicates a range. scan_const expands the
798 range to the full set of intermediate characters.
800 In double-quoted strings:
802 double-quoted style: \r and \n
804 backrefs: \1 (deprecated)
805 case and quoting: \U \Q \E
808 scan_const does *not* construct ops to handle interpolated strings.
809 It stops processing as soon as it finds an embedded $ or @ variable
810 and leaves it to the caller to work out what's going on.
812 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
814 $ in pattern could be $foo or could be tail anchor. Assumption:
815 it's a tail anchor if $ is the last thing in the string, or if it's
816 followed by one of ")| \n\t"
818 \1 (backreferences) are turned into $1
820 The structure of the code is
821 while (there's a character to process) {
822 handle transliteration ranges
824 skip # initiated comments in //x patterns
825 check for embedded @foo
826 check for embedded scalars
828 leave intact backslashes from leave (below)
829 deprecate \1 in strings and sub replacements
830 handle string-changing backslashes \l \U \Q \E, etc.
831 switch (what was escaped) {
832 handle - in a transliteration (becomes a literal -)
833 handle \132 octal characters
834 handle 0x15 hex characters
835 handle \cV (control V)
836 handle printf backslashes (\f, \r, \n, etc)
839 } (end while character to read)
844 scan_const(char *start)
846 register char *send = PL_bufend; /* end of the constant */
847 SV *sv = NEWSV(93, send - start); /* sv for the constant */
848 register char *s = start; /* start of the constant */
849 register char *d = SvPVX(sv); /* destination for copies */
850 bool dorange = FALSE; /* are we in a translit range? */
853 /* leaveit is the set of acceptably-backslashed characters */
856 ? "\\.^$@AGZdDwWsSbB+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
859 while (s < send || dorange) {
860 /* get transliterations out of the way (they're most literal) */
861 if (PL_lex_inwhat == OP_TRANS) {
862 /* expand a range A-Z to the full set of characters. AIE! */
864 I32 i; /* current expanded character */
865 I32 max; /* last character in range */
867 i = d - SvPVX(sv); /* remember current offset */
868 SvGROW(sv, SvLEN(sv) + 256); /* expand the sv -- there'll never be more'n 256 chars in a range for it to grow by */
869 d = SvPVX(sv) + i; /* restore d after the grow potentially has changed the ptr */
870 d -= 2; /* eat the first char and the - */
872 max = (U8)d[1]; /* last char in range */
874 for (i = (U8)*d; i <= max; i++)
877 /* mark the range as done, and continue */
882 /* range begins (ignore - as first or last char) */
883 else if (*s == '-' && s+1 < send && s != start) {
889 /* if we get here, we're not doing a transliteration */
891 /* skip for regexp comments /(?#comment)/ */
892 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
894 while (s < send && *s != ')')
896 } else if (s[2] == '{') { /* This should march regcomp.c */
898 char *regparse = s + 3;
901 while (count && (c = *regparse)) {
902 if (c == '\\' && regparse[1])
910 if (*regparse == ')')
913 yyerror("Sequence (?{...}) not terminated or not {}-balanced");
914 while (s < regparse && *s != ')')
919 /* likewise skip #-initiated comments in //x patterns */
920 else if (*s == '#' && PL_lex_inpat &&
921 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
922 while (s+1 < send && *s != '\n')
926 /* check for embedded arrays (@foo, @:foo, @'foo, @{foo}, @$foo) */
927 else if (*s == '@' && s[1] && (isALNUM(s[1]) || strchr(":'{$", s[1])))
930 /* check for embedded scalars. only stop if we're sure it's a
933 else if (*s == '$') {
934 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
936 if (s + 1 < send && !strchr("()| \n\t", s[1]))
937 break; /* in regexp, $ might be tail anchor */
941 if (*s == '\\' && s+1 < send) {
944 /* some backslashes we leave behind */
945 if (*s && strchr(leaveit, *s)) {
951 /* deprecate \1 in strings and substitution replacements */
952 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
953 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
956 warn("\\%c better written as $%c", *s, *s);
961 /* string-change backslash escapes */
962 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
967 /* if we get here, it's either a quoted -, or a digit */
970 /* quoted - in transliterations */
972 if (PL_lex_inwhat == OP_TRANS) {
977 /* default action is to copy the quoted character */
982 /* \132 indicates an octal constant */
983 case '0': case '1': case '2': case '3':
984 case '4': case '5': case '6': case '7':
985 *d++ = scan_oct(s, 3, &len);
989 /* \x24 indicates a hex constant */
991 *d++ = scan_hex(++s, 2, &len);
995 /* \c is a control character */
1009 /* printf-style backslashes, formfeeds, newlines, etc */
1035 } /* end if (backslash) */
1038 } /* while loop to process each character */
1040 /* terminate the string and set up the sv */
1042 SvCUR_set(sv, d - SvPVX(sv));
1045 /* shrink the sv if we allocated more than we used */
1046 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1047 SvLEN_set(sv, SvCUR(sv) + 1);
1048 Renew(SvPVX(sv), SvLEN(sv), char);
1051 /* return the substring (via yylval) only if we parsed anything */
1052 if (s > PL_bufptr) {
1053 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1054 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1056 ( PL_lex_inwhat == OP_TRANS
1058 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1061 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1067 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1069 intuit_more(register char *s)
1071 if (PL_lex_brackets)
1073 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1075 if (*s != '{' && *s != '[')
1080 /* In a pattern, so maybe we have {n,m}. */
1097 /* On the other hand, maybe we have a character class */
1100 if (*s == ']' || *s == '^')
1103 int weight = 2; /* let's weigh the evidence */
1105 unsigned char un_char = 255, last_un_char;
1106 char *send = strchr(s,']');
1107 char tmpbuf[sizeof PL_tokenbuf * 4];
1109 if (!send) /* has to be an expression */
1112 Zero(seen,256,char);
1115 else if (isDIGIT(*s)) {
1117 if (isDIGIT(s[1]) && s[2] == ']')
1123 for (; s < send; s++) {
1124 last_un_char = un_char;
1125 un_char = (unsigned char)*s;
1130 weight -= seen[un_char] * 10;
1131 if (isALNUM(s[1])) {
1132 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1133 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1138 else if (*s == '$' && s[1] &&
1139 strchr("[#!%*<>()-=",s[1])) {
1140 if (/*{*/ strchr("])} =",s[2]))
1149 if (strchr("wds]",s[1]))
1151 else if (seen['\''] || seen['"'])
1153 else if (strchr("rnftbxcav",s[1]))
1155 else if (isDIGIT(s[1])) {
1157 while (s[1] && isDIGIT(s[1]))
1167 if (strchr("aA01! ",last_un_char))
1169 if (strchr("zZ79~",s[1]))
1171 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1172 weight -= 5; /* cope with negative subscript */
1175 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1176 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1181 if (keyword(tmpbuf, d - tmpbuf))
1184 if (un_char == last_un_char + 1)
1186 weight -= seen[un_char];
1191 if (weight >= 0) /* probably a character class */
1199 intuit_method(char *start, GV *gv)
1201 char *s = start + (*start == '$');
1202 char tmpbuf[sizeof PL_tokenbuf];
1210 if ((cv = GvCVu(gv))) {
1211 char *proto = SvPVX(cv);
1221 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1222 if (*start == '$') {
1223 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1228 return *s == '(' ? FUNCMETH : METHOD;
1230 if (!keyword(tmpbuf, len)) {
1231 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1236 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1237 if (indirgv && GvCVu(indirgv))
1239 /* filehandle or package name makes it a method */
1240 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1242 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1243 return 0; /* no assumptions -- "=>" quotes bearword */
1245 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1247 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1251 return *s == '(' ? FUNCMETH : METHOD;
1261 char *pdb = PerlEnv_getenv("PERL5DB");
1265 SETERRNO(0,SS$_NORMAL);
1266 return "BEGIN { require 'perl5db.pl' }";
1272 /* Encoded script support. filter_add() effectively inserts a
1273 * 'pre-processing' function into the current source input stream.
1274 * Note that the filter function only applies to the current source file
1275 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1277 * The datasv parameter (which may be NULL) can be used to pass
1278 * private data to this instance of the filter. The filter function
1279 * can recover the SV using the FILTER_DATA macro and use it to
1280 * store private buffers and state information.
1282 * The supplied datasv parameter is upgraded to a PVIO type
1283 * and the IoDIRP field is used to store the function pointer.
1284 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1285 * private use must be set using malloc'd pointers.
1287 static int filter_debug = 0;
1290 filter_add(filter_t funcp, SV *datasv)
1292 if (!funcp){ /* temporary handy debugging hack to be deleted */
1293 filter_debug = atoi((char*)datasv);
1296 if (!PL_rsfp_filters)
1297 PL_rsfp_filters = newAV();
1299 datasv = NEWSV(255,0);
1300 if (!SvUPGRADE(datasv, SVt_PVIO))
1301 die("Can't upgrade filter_add data to SVt_PVIO");
1302 IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
1304 warn("filter_add func %p (%s)", funcp, SvPV(datasv,PL_na));
1305 av_unshift(PL_rsfp_filters, 1);
1306 av_store(PL_rsfp_filters, 0, datasv) ;
1311 /* Delete most recently added instance of this filter function. */
1313 filter_del(filter_t funcp)
1316 warn("filter_del func %p", funcp);
1317 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
1319 /* if filter is on top of stack (usual case) just pop it off */
1320 if (IoDIRP(FILTER_DATA(AvFILLp(PL_rsfp_filters))) == (void*)funcp){
1321 sv_free(av_pop(PL_rsfp_filters));
1325 /* we need to search for the correct entry and clear it */
1326 die("filter_del can only delete in reverse order (currently)");
1330 /* Invoke the n'th filter function for the current rsfp. */
1332 filter_read(int idx, SV *buf_sv, int maxlen)
1335 /* 0 = read one text line */
1340 if (!PL_rsfp_filters)
1342 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
1343 /* Provide a default input filter to make life easy. */
1344 /* Note that we append to the line. This is handy. */
1346 warn("filter_read %d: from rsfp\n", idx);
1350 int old_len = SvCUR(buf_sv) ;
1352 /* ensure buf_sv is large enough */
1353 SvGROW(buf_sv, old_len + maxlen) ;
1354 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1355 if (PerlIO_error(PL_rsfp))
1356 return -1; /* error */
1358 return 0 ; /* end of file */
1360 SvCUR_set(buf_sv, old_len + len) ;
1363 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
1364 if (PerlIO_error(PL_rsfp))
1365 return -1; /* error */
1367 return 0 ; /* end of file */
1370 return SvCUR(buf_sv);
1372 /* Skip this filter slot if filter has been deleted */
1373 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
1375 warn("filter_read %d: skipped (filter deleted)\n", idx);
1376 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1378 /* Get function pointer hidden within datasv */
1379 funcp = (filter_t)IoDIRP(datasv);
1381 warn("filter_read %d: via function %p (%s)\n",
1382 idx, funcp, SvPV(datasv,PL_na));
1383 /* Call function. The function is expected to */
1384 /* call "FILTER_READ(idx+1, buf_sv)" first. */
1385 /* Return: <0:error, =0:eof, >0:not eof */
1386 return (*funcp)(PERL_OBJECT_THIS_ idx, buf_sv, maxlen);
1390 filter_gets(register SV *sv, register PerlIO *fp, STRLEN append)
1393 if (!PL_rsfp_filters) {
1394 filter_add(win32_textfilter,NULL);
1397 if (PL_rsfp_filters) {
1400 SvCUR_set(sv, 0); /* start with empty line */
1401 if (FILTER_READ(0, sv, 0) > 0)
1402 return ( SvPVX(sv) ) ;
1407 return (sv_gets(sv, fp, append));
1412 static char* exp_name[] =
1413 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "TERMBLOCK" };
1416 EXT int yychar; /* last token */
1421 Works out what to call the token just pulled out of the input
1422 stream. The yacc parser takes care of taking the ops we return and
1423 stitching them into a tree.
1429 if read an identifier
1430 if we're in a my declaration
1431 croak if they tried to say my($foo::bar)
1432 build the ops for a my() declaration
1433 if it's an access to a my() variable
1434 are we in a sort block?
1435 croak if my($a); $a <=> $b
1436 build ops for access to a my() variable
1437 if in a dq string, and they've said @foo and we can't find @foo
1439 build ops for a bareword
1440 if we already built the token before, use it.
1454 /* check if there's an identifier for us to look at */
1455 if (PL_pending_ident) {
1456 /* pit holds the identifier we read and pending_ident is reset */
1457 char pit = PL_pending_ident;
1458 PL_pending_ident = 0;
1460 /* if we're in a my(), we can't allow dynamics here.
1461 $foo'bar has already been turned into $foo::bar, so
1462 just check for colons.
1464 if it's a legal name, the OP is a PADANY.
1467 if (strchr(PL_tokenbuf,':'))
1468 croak(no_myglob,PL_tokenbuf);
1470 yylval.opval = newOP(OP_PADANY, 0);
1471 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
1476 build the ops for accesses to a my() variable.
1478 Deny my($a) or my($b) in a sort block, *if* $a or $b is
1479 then used in a comparison. This catches most, but not
1480 all cases. For instance, it catches
1481 sort { my($a); $a <=> $b }
1483 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
1484 (although why you'd do that is anyone's guess).
1487 if (!strchr(PL_tokenbuf,':')) {
1489 /* Check for single character per-thread SVs */
1490 if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
1491 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
1492 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
1494 yylval.opval = newOP(OP_THREADSV, 0);
1495 yylval.opval->op_targ = tmp;
1498 #endif /* USE_THREADS */
1499 if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
1500 /* if it's a sort block and they're naming $a or $b */
1501 if (PL_last_lop_op == OP_SORT &&
1502 PL_tokenbuf[0] == '$' &&
1503 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
1506 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
1507 d < PL_bufend && *d != '\n';
1510 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
1511 croak("Can't use \"my %s\" in sort comparison",
1517 yylval.opval = newOP(OP_PADANY, 0);
1518 yylval.opval->op_targ = tmp;
1524 Whine if they've said @foo in a doublequoted string,
1525 and @foo isn't a variable we can find in the symbol
1528 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
1529 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
1530 if (!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
1531 yyerror(form("In string, %s now must be written as \\%s",
1532 PL_tokenbuf, PL_tokenbuf));
1535 /* build ops for a bareword */
1536 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
1537 yylval.opval->op_private = OPpCONST_ENTERED;
1538 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
1539 ((PL_tokenbuf[0] == '$') ? SVt_PV
1540 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
1545 /* no identifier pending identification */
1547 switch (PL_lex_state) {
1549 case LEX_NORMAL: /* Some compilers will produce faster */
1550 case LEX_INTERPNORMAL: /* code if we comment these out. */
1554 /* when we're already built the next token, just pull it out the queue */
1557 yylval = PL_nextval[PL_nexttoke];
1559 PL_lex_state = PL_lex_defer;
1560 PL_expect = PL_lex_expect;
1561 PL_lex_defer = LEX_NORMAL;
1563 return(PL_nexttype[PL_nexttoke]);
1565 /* interpolated case modifiers like \L \U, including \Q and \E.
1566 when we get here, PL_bufptr is at the \
1568 case LEX_INTERPCASEMOD:
1570 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
1571 croak("panic: INTERPCASEMOD");
1573 /* handle \E or end of string */
1574 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
1578 if (PL_lex_casemods) {
1579 oldmod = PL_lex_casestack[--PL_lex_casemods];
1580 PL_lex_casestack[PL_lex_casemods] = '\0';
1582 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
1584 PL_lex_state = LEX_INTERPCONCAT;
1588 if (PL_bufptr != PL_bufend)
1590 PL_lex_state = LEX_INTERPCONCAT;
1595 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
1596 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
1597 if (strchr("LU", *s) &&
1598 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
1600 PL_lex_casestack[--PL_lex_casemods] = '\0';
1603 if (PL_lex_casemods > 10) {
1604 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
1605 if (newlb != PL_lex_casestack) {
1607 PL_lex_casestack = newlb;
1610 PL_lex_casestack[PL_lex_casemods++] = *s;
1611 PL_lex_casestack[PL_lex_casemods] = '\0';
1612 PL_lex_state = LEX_INTERPCONCAT;
1613 PL_nextval[PL_nexttoke].ival = 0;
1616 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
1618 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
1620 PL_nextval[PL_nexttoke].ival = OP_LC;
1622 PL_nextval[PL_nexttoke].ival = OP_UC;
1624 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
1626 croak("panic: yylex");
1629 if (PL_lex_starts) {
1638 case LEX_INTERPPUSH:
1639 return sublex_push();
1641 case LEX_INTERPSTART:
1642 if (PL_bufptr == PL_bufend)
1643 return sublex_done();
1645 PL_lex_dojoin = (*PL_bufptr == '@');
1646 PL_lex_state = LEX_INTERPNORMAL;
1647 if (PL_lex_dojoin) {
1648 PL_nextval[PL_nexttoke].ival = 0;
1651 PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
1652 PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
1653 force_next(PRIVATEREF);
1655 force_ident("\"", '$');
1656 #endif /* USE_THREADS */
1657 PL_nextval[PL_nexttoke].ival = 0;
1659 PL_nextval[PL_nexttoke].ival = 0;
1661 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
1664 if (PL_lex_starts++) {
1670 case LEX_INTERPENDMAYBE:
1671 if (intuit_more(PL_bufptr)) {
1672 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
1678 if (PL_lex_dojoin) {
1679 PL_lex_dojoin = FALSE;
1680 PL_lex_state = LEX_INTERPCONCAT;
1684 case LEX_INTERPCONCAT:
1686 if (PL_lex_brackets)
1687 croak("panic: INTERPCONCAT");
1689 if (PL_bufptr == PL_bufend)
1690 return sublex_done();
1692 if (SvIVX(PL_linestr) == '\'') {
1693 SV *sv = newSVsv(PL_linestr);
1696 else if ( PL_hints & HINT_NEW_RE )
1697 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
1698 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1702 s = scan_const(PL_bufptr);
1704 PL_lex_state = LEX_INTERPCASEMOD;
1706 PL_lex_state = LEX_INTERPSTART;
1709 if (s != PL_bufptr) {
1710 PL_nextval[PL_nexttoke] = yylval;
1713 if (PL_lex_starts++)
1723 PL_lex_state = LEX_NORMAL;
1724 s = scan_formline(PL_bufptr);
1725 if (!PL_lex_formbrack)
1731 PL_oldoldbufptr = PL_oldbufptr;
1734 PerlIO_printf(PerlIO_stderr(), "### Tokener expecting %s at %s\n", exp_name[PL_expect], s);
1740 croak("Unrecognized character \\%03o", *s & 255);
1743 goto fake_eof; /* emulate EOF on ^D or ^Z */
1748 if (PL_lex_brackets)
1749 yyerror("Missing right bracket");
1752 if (s++ < PL_bufend)
1753 goto retry; /* ignore stray nulls */
1756 if (!PL_in_eval && !PL_preambled) {
1757 PL_preambled = TRUE;
1758 sv_setpv(PL_linestr,incl_perldb());
1759 if (SvCUR(PL_linestr))
1760 sv_catpv(PL_linestr,";");
1762 while(AvFILLp(PL_preambleav) >= 0) {
1763 SV *tmpsv = av_shift(PL_preambleav);
1764 sv_catsv(PL_linestr, tmpsv);
1765 sv_catpv(PL_linestr, ";");
1768 sv_free((SV*)PL_preambleav);
1769 PL_preambleav = NULL;
1771 if (PL_minus_n || PL_minus_p) {
1772 sv_catpv(PL_linestr, "LINE: while (<>) {");
1774 sv_catpv(PL_linestr,"chomp;");
1776 GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
1778 GvIMPORTED_AV_on(gv);
1780 if (strchr("/'\"", *PL_splitstr)
1781 && strchr(PL_splitstr + 1, *PL_splitstr))
1782 sv_catpvf(PL_linestr, "@F=split(%s);", PL_splitstr);
1785 s = "'~#\200\1'"; /* surely one char is unused...*/
1786 while (s[1] && strchr(PL_splitstr, *s)) s++;
1788 sv_catpvf(PL_linestr, "@F=split(%s%c",
1789 "q" + (delim == '\''), delim);
1790 for (s = PL_splitstr; *s; s++) {
1792 sv_catpvn(PL_linestr, "\\", 1);
1793 sv_catpvn(PL_linestr, s, 1);
1795 sv_catpvf(PL_linestr, "%c);", delim);
1799 sv_catpv(PL_linestr,"@F=split(' ');");
1802 sv_catpv(PL_linestr, "\n");
1803 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1804 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1805 if (PERLDB_LINE && PL_curstash != PL_debstash) {
1806 SV *sv = NEWSV(85,0);
1808 sv_upgrade(sv, SVt_PVMG);
1809 sv_setsv(sv,PL_linestr);
1810 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
1815 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
1818 if (PL_preprocess && !PL_in_eval)
1819 (void)PerlProc_pclose(PL_rsfp);
1820 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
1821 PerlIO_clearerr(PL_rsfp);
1823 (void)PerlIO_close(PL_rsfp);
1826 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
1827 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
1828 sv_catpv(PL_linestr,";}");
1829 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1830 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1831 PL_minus_n = PL_minus_p = 0;
1834 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1835 sv_setpv(PL_linestr,"");
1836 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
1839 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
1840 PL_doextract = FALSE;
1842 /* Incest with pod. */
1843 if (*s == '=' && strnEQ(s, "=cut", 4)) {
1844 sv_setpv(PL_linestr, "");
1845 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1846 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1847 PL_doextract = FALSE;
1851 } while (PL_doextract);
1852 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
1853 if (PERLDB_LINE && PL_curstash != PL_debstash) {
1854 SV *sv = NEWSV(85,0);
1856 sv_upgrade(sv, SVt_PVMG);
1857 sv_setsv(sv,PL_linestr);
1858 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
1860 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1861 if (PL_curcop->cop_line == 1) {
1862 while (s < PL_bufend && isSPACE(*s))
1864 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
1868 if (*s == '#' && *(s+1) == '!')
1870 #ifdef ALTERNATE_SHEBANG
1872 static char as[] = ALTERNATE_SHEBANG;
1873 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
1874 d = s + (sizeof(as) - 1);
1876 #endif /* ALTERNATE_SHEBANG */
1885 while (*d && !isSPACE(*d))
1889 #ifdef ARG_ZERO_IS_SCRIPT
1890 if (ipathend > ipath) {
1892 * HP-UX (at least) sets argv[0] to the script name,
1893 * which makes $^X incorrect. And Digital UNIX and Linux,
1894 * at least, set argv[0] to the basename of the Perl
1895 * interpreter. So, having found "#!", we'll set it right.
1897 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
1898 assert(SvPOK(x) || SvGMAGICAL(x));
1899 if (sv_eq(x, GvSV(PL_curcop->cop_filegv))) {
1900 sv_setpvn(x, ipath, ipathend - ipath);
1903 TAINT_NOT; /* $^X is always tainted, but that's OK */
1905 #endif /* ARG_ZERO_IS_SCRIPT */
1910 d = instr(s,"perl -");
1912 d = instr(s,"perl");
1913 #ifdef ALTERNATE_SHEBANG
1915 * If the ALTERNATE_SHEBANG on this system starts with a
1916 * character that can be part of a Perl expression, then if
1917 * we see it but not "perl", we're probably looking at the
1918 * start of Perl code, not a request to hand off to some
1919 * other interpreter. Similarly, if "perl" is there, but
1920 * not in the first 'word' of the line, we assume the line
1921 * contains the start of the Perl program.
1923 if (d && *s != '#') {
1925 while (*c && !strchr("; \t\r\n\f\v#", *c))
1928 d = Nullch; /* "perl" not in first word; ignore */
1930 *s = '#'; /* Don't try to parse shebang line */
1932 #endif /* ALTERNATE_SHEBANG */
1937 !instr(s,"indir") &&
1938 instr(PL_origargv[0],"perl"))
1944 while (s < PL_bufend && isSPACE(*s))
1946 if (s < PL_bufend) {
1947 Newz(899,newargv,PL_origargc+3,char*);
1949 while (s < PL_bufend && !isSPACE(*s))
1952 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
1955 newargv = PL_origargv;
1957 execv(ipath, newargv);
1958 croak("Can't exec %s", ipath);
1961 U32 oldpdb = PL_perldb;
1962 bool oldn = PL_minus_n;
1963 bool oldp = PL_minus_p;
1965 while (*d && !isSPACE(*d)) d++;
1966 while (*d == ' ' || *d == '\t') d++;
1970 if (*d == 'M' || *d == 'm') {
1972 while (*d && !isSPACE(*d)) d++;
1973 croak("Too late for \"-%.*s\" option",
1976 d = moreswitches(d);
1978 if (PERLDB_LINE && !oldpdb ||
1979 ( PL_minus_n || PL_minus_p ) && !(oldn || oldp) )
1980 /* if we have already added "LINE: while (<>) {",
1981 we must not do it again */
1983 sv_setpv(PL_linestr, "");
1984 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1985 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1986 PL_preambled = FALSE;
1988 (void)gv_fetchfile(PL_origfilename);
1995 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
1997 PL_lex_state = LEX_FORMLINE;
2002 #ifdef PERL_STRICT_CR
2003 warn("Illegal character \\%03o (carriage return)", '\r');
2005 "(Maybe you didn't strip carriage returns after a network transfer?)\n");
2007 case ' ': case '\t': case '\f': case 013:
2012 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2014 while (s < d && *s != '\n')
2019 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2021 PL_lex_state = LEX_FORMLINE;
2031 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2036 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2039 if (strnEQ(s,"=>",2)) {
2040 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2041 OPERATOR('-'); /* unary minus */
2043 PL_last_uni = PL_oldbufptr;
2044 PL_last_lop_op = OP_FTEREAD; /* good enough */
2046 case 'r': FTST(OP_FTEREAD);
2047 case 'w': FTST(OP_FTEWRITE);
2048 case 'x': FTST(OP_FTEEXEC);
2049 case 'o': FTST(OP_FTEOWNED);
2050 case 'R': FTST(OP_FTRREAD);
2051 case 'W': FTST(OP_FTRWRITE);
2052 case 'X': FTST(OP_FTREXEC);
2053 case 'O': FTST(OP_FTROWNED);
2054 case 'e': FTST(OP_FTIS);
2055 case 'z': FTST(OP_FTZERO);
2056 case 's': FTST(OP_FTSIZE);
2057 case 'f': FTST(OP_FTFILE);
2058 case 'd': FTST(OP_FTDIR);
2059 case 'l': FTST(OP_FTLINK);
2060 case 'p': FTST(OP_FTPIPE);
2061 case 'S': FTST(OP_FTSOCK);
2062 case 'u': FTST(OP_FTSUID);
2063 case 'g': FTST(OP_FTSGID);
2064 case 'k': FTST(OP_FTSVTX);
2065 case 'b': FTST(OP_FTBLK);
2066 case 'c': FTST(OP_FTCHR);
2067 case 't': FTST(OP_FTTTY);
2068 case 'T': FTST(OP_FTTEXT);
2069 case 'B': FTST(OP_FTBINARY);
2070 case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2071 case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2072 case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
2074 croak("Unrecognized file test: -%c", (int)tmp);
2081 if (PL_expect == XOPERATOR)
2086 else if (*s == '>') {
2089 if (isIDFIRST(*s)) {
2090 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2098 if (PL_expect == XOPERATOR)
2101 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2103 OPERATOR('-'); /* unary minus */
2110 if (PL_expect == XOPERATOR)
2115 if (PL_expect == XOPERATOR)
2118 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2124 if (PL_expect != XOPERATOR) {
2125 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2126 PL_expect = XOPERATOR;
2127 force_ident(PL_tokenbuf, '*');
2140 if (PL_expect == XOPERATOR) {
2144 PL_tokenbuf[0] = '%';
2145 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2146 if (!PL_tokenbuf[1]) {
2148 yyerror("Final % should be \\% or %name");
2151 PL_pending_ident = '%';
2173 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
2174 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
2179 if (PL_curcop->cop_line < PL_copline)
2180 PL_copline = PL_curcop->cop_line;
2191 if (PL_lex_brackets <= 0)
2192 yyerror("Unmatched right bracket");
2195 if (PL_lex_state == LEX_INTERPNORMAL) {
2196 if (PL_lex_brackets == 0) {
2197 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
2198 PL_lex_state = LEX_INTERPEND;
2205 if (PL_lex_brackets > 100) {
2206 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
2207 if (newlb != PL_lex_brackstack) {
2209 PL_lex_brackstack = newlb;
2212 switch (PL_expect) {
2214 if (PL_lex_formbrack) {
2218 if (PL_oldoldbufptr == PL_last_lop)
2219 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2221 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2222 OPERATOR(HASHBRACK);
2224 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2227 PL_tokenbuf[0] = '\0';
2228 if (d < PL_bufend && *d == '-') {
2229 PL_tokenbuf[0] = '-';
2231 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2234 if (d < PL_bufend && isIDFIRST(*d)) {
2235 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2237 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2240 char minus = (PL_tokenbuf[0] == '-');
2241 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2248 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
2252 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2257 if (PL_oldoldbufptr == PL_last_lop)
2258 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2260 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2263 OPERATOR(HASHBRACK);
2264 /* This hack serves to disambiguate a pair of curlies
2265 * as being a block or an anon hash. Normally, expectation
2266 * determines that, but in cases where we're not in a
2267 * position to expect anything in particular (like inside
2268 * eval"") we have to resolve the ambiguity. This code
2269 * covers the case where the first term in the curlies is a
2270 * quoted string. Most other cases need to be explicitly
2271 * disambiguated by prepending a `+' before the opening
2272 * curly in order to force resolution as an anon hash.
2274 * XXX should probably propagate the outer expectation
2275 * into eval"" to rely less on this hack, but that could
2276 * potentially break current behavior of eval"".
2280 if (*s == '\'' || *s == '"' || *s == '`') {
2281 /* common case: get past first string, handling escapes */
2282 for (t++; t < PL_bufend && *t != *s;)
2283 if (*t++ == '\\' && (*t == '\\' || *t == *s))
2287 else if (*s == 'q') {
2290 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
2291 && !isALNUM(*t)))) {
2293 char open, close, term;
2296 while (t < PL_bufend && isSPACE(*t))
2300 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
2304 for (t++; t < PL_bufend; t++) {
2305 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
2307 else if (*t == open)
2311 for (t++; t < PL_bufend; t++) {
2312 if (*t == '\\' && t+1 < PL_bufend)
2314 else if (*t == close && --brackets <= 0)
2316 else if (*t == open)
2322 else if (isALPHA(*s)) {
2323 for (t++; t < PL_bufend && isALNUM(*t); t++) ;
2325 while (t < PL_bufend && isSPACE(*t))
2327 /* if comma follows first term, call it an anon hash */
2328 /* XXX it could be a comma expression with loop modifiers */
2329 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
2330 || (*t == '=' && t[1] == '>')))
2331 OPERATOR(HASHBRACK);
2332 if (PL_expect == XREF)
2335 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
2341 yylval.ival = PL_curcop->cop_line;
2342 if (isSPACE(*s) || *s == '#')
2343 PL_copline = NOLINE; /* invalidate current command line number */
2348 if (PL_lex_brackets <= 0)
2349 yyerror("Unmatched right bracket");
2351 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
2352 if (PL_lex_brackets < PL_lex_formbrack)
2353 PL_lex_formbrack = 0;
2354 if (PL_lex_state == LEX_INTERPNORMAL) {
2355 if (PL_lex_brackets == 0) {
2356 if (PL_lex_fakebrack) {
2357 PL_lex_state = LEX_INTERPEND;
2359 return yylex(); /* ignore fake brackets */
2361 if (*s == '-' && s[1] == '>')
2362 PL_lex_state = LEX_INTERPENDMAYBE;
2363 else if (*s != '[' && *s != '{')
2364 PL_lex_state = LEX_INTERPEND;
2367 if (PL_lex_brackets < PL_lex_fakebrack) {
2369 PL_lex_fakebrack = 0;
2370 return yylex(); /* ignore fake brackets */
2380 if (PL_expect == XOPERATOR) {
2381 if (PL_dowarn && isALPHA(*s) && PL_bufptr == PL_linestart) {
2382 PL_curcop->cop_line--;
2384 PL_curcop->cop_line++;
2389 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2391 PL_expect = XOPERATOR;
2392 force_ident(PL_tokenbuf, '&');
2396 yylval.ival = (OPpENTERSUB_AMPER<<8);
2415 if (PL_dowarn && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
2416 warn("Reversed %c= operator",(int)tmp);
2418 if (PL_expect == XSTATE && isALPHA(tmp) &&
2419 (s == PL_linestart+1 || s[-2] == '\n') )
2421 if (PL_in_eval && !PL_rsfp) {
2426 if (strnEQ(s,"=cut",4)) {
2440 PL_doextract = TRUE;
2443 if (PL_lex_brackets < PL_lex_formbrack) {
2445 for (t = s; *t == ' ' || *t == '\t'; t++) ;
2446 if (*t == '\n' || *t == '#') {
2464 if (PL_expect != XOPERATOR) {
2465 if (s[1] != '<' && !strchr(s,'>'))
2468 s = scan_heredoc(s);
2470 s = scan_inputsymbol(s);
2471 TERM(sublex_start());
2476 SHop(OP_LEFT_SHIFT);
2490 SHop(OP_RIGHT_SHIFT);
2499 if (PL_expect == XOPERATOR) {
2500 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2503 return ','; /* grandfather non-comma-format format */
2507 if (s[1] == '#' && (isALPHA(s[2]) || strchr("_{$:", s[2]))) {
2508 if (PL_expect == XOPERATOR)
2509 no_op("Array length", PL_bufptr);
2510 PL_tokenbuf[0] = '@';
2511 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2513 if (!PL_tokenbuf[1])
2515 PL_expect = XOPERATOR;
2516 PL_pending_ident = '#';
2520 if (PL_expect == XOPERATOR)
2521 no_op("Scalar", PL_bufptr);
2522 PL_tokenbuf[0] = '$';
2523 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2524 if (!PL_tokenbuf[1]) {
2526 yyerror("Final $ should be \\$ or $name");
2530 /* This kludge not intended to be bulletproof. */
2531 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
2532 yylval.opval = newSVOP(OP_CONST, 0,
2533 newSViv((IV)PL_compiling.cop_arybase));
2534 yylval.opval->op_private = OPpCONST_ARYBASE;
2539 if (PL_lex_state == LEX_NORMAL)
2542 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2545 PL_tokenbuf[0] = '@';
2548 isSPACE(*t) || isALNUM(*t) || *t == '$';
2551 PL_bufptr = skipspace(PL_bufptr);
2552 while (t < PL_bufend && *t != ']')
2554 warn("Multidimensional syntax %.*s not supported",
2555 (t - PL_bufptr) + 1, PL_bufptr);
2559 else if (*s == '{') {
2560 PL_tokenbuf[0] = '%';
2561 if (PL_dowarn && strEQ(PL_tokenbuf+1, "SIG") &&
2562 (t = strchr(s, '}')) && (t = strchr(t, '=')))
2564 char tmpbuf[sizeof PL_tokenbuf];
2566 for (t++; isSPACE(*t); t++) ;
2567 if (isIDFIRST(*t)) {
2568 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
2569 if (*t != '(' && perl_get_cv(tmpbuf, FALSE))
2570 warn("You need to quote \"%s\"", tmpbuf);
2576 PL_expect = XOPERATOR;
2577 if (PL_lex_state == LEX_NORMAL && isSPACE(*d)) {
2578 bool islop = (PL_last_lop == PL_oldoldbufptr);
2579 if (!islop || PL_last_lop_op == OP_GREPSTART)
2580 PL_expect = XOPERATOR;
2581 else if (strchr("$@\"'`q", *s))
2582 PL_expect = XTERM; /* e.g. print $fh "foo" */
2583 else if (strchr("&*<%", *s) && isIDFIRST(s[1]))
2584 PL_expect = XTERM; /* e.g. print $fh &sub */
2585 else if (isIDFIRST(*s)) {
2586 char tmpbuf[sizeof PL_tokenbuf];
2587 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2588 if (tmp = keyword(tmpbuf, len)) {
2589 /* binary operators exclude handle interpretations */
2601 PL_expect = XTERM; /* e.g. print $fh length() */
2606 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
2607 if (gv && GvCVu(gv))
2608 PL_expect = XTERM; /* e.g. print $fh subr() */
2611 else if (isDIGIT(*s))
2612 PL_expect = XTERM; /* e.g. print $fh 3 */
2613 else if (*s == '.' && isDIGIT(s[1]))
2614 PL_expect = XTERM; /* e.g. print $fh .3 */
2615 else if (strchr("/?-+", *s) && !isSPACE(s[1]))
2616 PL_expect = XTERM; /* e.g. print $fh -1 */
2617 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]))
2618 PL_expect = XTERM; /* print $fh <<"EOF" */
2620 PL_pending_ident = '$';
2624 if (PL_expect == XOPERATOR)
2626 PL_tokenbuf[0] = '@';
2627 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2628 if (!PL_tokenbuf[1]) {
2630 yyerror("Final @ should be \\@ or @name");
2633 if (PL_lex_state == LEX_NORMAL)
2635 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2637 PL_tokenbuf[0] = '%';
2639 /* Warn about @ where they meant $. */
2641 if (*s == '[' || *s == '{') {
2643 while (*t && (isALNUM(*t) || strchr(" \t$#+-'\"", *t)))
2645 if (*t == '}' || *t == ']') {
2647 PL_bufptr = skipspace(PL_bufptr);
2648 warn("Scalar value %.*s better written as $%.*s",
2649 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
2654 PL_pending_ident = '@';
2657 case '/': /* may either be division or pattern */
2658 case '?': /* may either be conditional or pattern */
2659 if (PL_expect != XOPERATOR) {
2660 /* Disable warning on "study /blah/" */
2661 if (PL_oldoldbufptr == PL_last_uni
2662 && (*PL_last_uni != 's' || s - PL_last_uni < 5
2663 || memNE(PL_last_uni, "study", 5) || isALNUM(PL_last_uni[5])))
2665 s = scan_pat(s,OP_MATCH);
2666 TERM(sublex_start());
2674 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack && s[1] == '\n' &&
2675 (s == PL_linestart || s[-1] == '\n') ) {
2676 PL_lex_formbrack = 0;
2680 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
2686 yylval.ival = OPf_SPECIAL;
2692 if (PL_expect != XOPERATOR)
2697 case '0': case '1': case '2': case '3': case '4':
2698 case '5': case '6': case '7': case '8': case '9':
2700 if (PL_expect == XOPERATOR)
2706 if (PL_expect == XOPERATOR) {
2707 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2710 return ','; /* grandfather non-comma-format format */
2716 missingterm((char*)0);
2717 yylval.ival = OP_CONST;
2718 TERM(sublex_start());
2722 if (PL_expect == XOPERATOR) {
2723 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2726 return ','; /* grandfather non-comma-format format */
2732 missingterm((char*)0);
2733 yylval.ival = OP_CONST;
2734 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
2735 if (*d == '$' || *d == '@' || *d == '\\') {
2736 yylval.ival = OP_STRINGIFY;
2740 TERM(sublex_start());
2744 if (PL_expect == XOPERATOR)
2745 no_op("Backticks",s);
2747 missingterm((char*)0);
2748 yylval.ival = OP_BACKTICK;
2750 TERM(sublex_start());
2754 if (PL_dowarn && PL_lex_inwhat && isDIGIT(*s))
2755 warn("Can't use \\%c to mean $%c in expression", *s, *s);
2756 if (PL_expect == XOPERATOR)
2757 no_op("Backslash",s);
2761 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
2800 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2802 /* Some keywords can be followed by any delimiter, including ':' */
2803 tmp = (len == 1 && strchr("msyq", PL_tokenbuf[0]) ||
2804 len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
2805 (PL_tokenbuf[0] == 'q' &&
2806 strchr("qwxr", PL_tokenbuf[1]))));
2808 /* x::* is just a word, unless x is "CORE" */
2809 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
2813 while (d < PL_bufend && isSPACE(*d))
2814 d++; /* no comments skipped here, or s### is misparsed */
2816 /* Is this a label? */
2817 if (!tmp && PL_expect == XSTATE
2818 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
2820 yylval.pval = savepv(PL_tokenbuf);
2825 /* Check for keywords */
2826 tmp = keyword(PL_tokenbuf, len);
2828 /* Is this a word before a => operator? */
2829 if (strnEQ(d,"=>",2)) {
2831 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
2832 yylval.opval->op_private = OPpCONST_BARE;
2836 if (tmp < 0) { /* second-class keyword? */
2837 GV *ogv = Nullgv; /* override (winner) */
2838 GV *hgv = Nullgv; /* hidden (loser) */
2839 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
2841 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
2844 if (GvIMPORTED_CV(gv))
2846 else if (! CvMETHOD(cv))
2850 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
2851 (gv = *gvp) != (GV*)&PL_sv_undef &&
2852 GvCVu(gv) && GvIMPORTED_CV(gv))
2858 tmp = 0; /* overridden by import or by GLOBAL */
2861 && -tmp==KEY_lock /* XXX generalizable kludge */
2862 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
2864 tmp = 0; /* any sub overrides "weak" keyword */
2866 else { /* no override */
2870 if (PL_dowarn && hgv)
2871 warn("Ambiguous call resolved as CORE::%s(), %s",
2872 GvENAME(hgv), "qualify as such or use &");
2879 default: /* not a keyword */
2882 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
2884 /* Get the rest if it looks like a package qualifier */
2886 if (*s == '\'' || *s == ':' && s[1] == ':') {
2888 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
2891 croak("Bad name after %s%s", PL_tokenbuf,
2892 *s == '\'' ? "'" : "::");
2896 if (PL_expect == XOPERATOR) {
2897 if (PL_bufptr == PL_linestart) {
2898 PL_curcop->cop_line--;
2900 PL_curcop->cop_line++;
2903 no_op("Bareword",s);
2906 /* Look for a subroutine with this name in current package,
2907 unless name is "Foo::", in which case Foo is a bearword
2908 (and a package name). */
2911 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
2913 if (PL_dowarn && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
2914 warn("Bareword \"%s\" refers to nonexistent package",
2917 PL_tokenbuf[len] = '\0';
2924 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
2927 /* if we saw a global override before, get the right name */
2930 sv = newSVpv("CORE::GLOBAL::",14);
2931 sv_catpv(sv,PL_tokenbuf);
2934 sv = newSVpv(PL_tokenbuf,0);
2936 /* Presume this is going to be a bareword of some sort. */
2939 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2940 yylval.opval->op_private = OPpCONST_BARE;
2942 /* And if "Foo::", then that's what it certainly is. */
2947 /* See if it's the indirect object for a list operator. */
2949 if (PL_oldoldbufptr &&
2950 PL_oldoldbufptr < PL_bufptr &&
2951 (PL_oldoldbufptr == PL_last_lop || PL_oldoldbufptr == PL_last_uni) &&
2952 /* NO SKIPSPACE BEFORE HERE! */
2954 || ((opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF
2955 || (PL_last_lop_op == OP_ENTERSUB
2957 && PL_last_proto[PL_last_proto[0] == ';' ? 1 : 0] == '*')) )
2959 bool immediate_paren = *s == '(';
2961 /* (Now we can afford to cross potential line boundary.) */
2964 /* Two barewords in a row may indicate method call. */
2966 if ((isALPHA(*s) || *s == '$') && (tmp=intuit_method(s,gv)))
2969 /* If not a declared subroutine, it's an indirect object. */
2970 /* (But it's an indir obj regardless for sort.) */
2972 if ((PL_last_lop_op == OP_SORT ||
2973 (!immediate_paren && (!gv || !GvCVu(gv))) ) &&
2974 (PL_last_lop_op != OP_MAPSTART && PL_last_lop_op != OP_GREPSTART)){
2975 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
2980 /* If followed by a paren, it's certainly a subroutine. */
2982 PL_expect = XOPERATOR;
2986 if (gv && GvCVu(gv)) {
2987 for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
2988 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
2993 PL_nextval[PL_nexttoke].opval = yylval.opval;
2994 PL_expect = XOPERATOR;
3000 /* If followed by var or block, call it a method (unless sub) */
3002 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3003 PL_last_lop = PL_oldbufptr;
3004 PL_last_lop_op = OP_METHOD;
3008 /* If followed by a bareword, see if it looks like indir obj. */
3010 if ((isALPHA(*s) || *s == '$') && (tmp = intuit_method(s,gv)))
3013 /* Not a method, so call it a subroutine (if defined) */
3015 if (gv && GvCVu(gv)) {
3017 if (lastchar == '-')
3018 warn("Ambiguous use of -%s resolved as -&%s()",
3019 PL_tokenbuf, PL_tokenbuf);
3020 PL_last_lop = PL_oldbufptr;
3021 PL_last_lop_op = OP_ENTERSUB;
3022 /* Check for a constant sub */
3024 if ((sv = cv_const_sv(cv))) {
3026 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3027 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3028 yylval.opval->op_private = 0;
3032 /* Resolve to GV now. */
3033 op_free(yylval.opval);
3034 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3035 /* Is there a prototype? */
3038 PL_last_proto = SvPV((SV*)cv, len);
3041 if (strEQ(PL_last_proto, "$"))
3043 if (*PL_last_proto == '&' && *s == '{') {
3044 sv_setpv(PL_subname,"__ANON__");
3048 PL_last_proto = NULL;
3049 PL_nextval[PL_nexttoke].opval = yylval.opval;
3055 if (PL_hints & HINT_STRICT_SUBS &&
3058 PL_last_lop_op != OP_TRUNCATE && /* S/F prototype in opcode.pl */
3059 PL_last_lop_op != OP_ACCEPT &&
3060 PL_last_lop_op != OP_PIPE_OP &&
3061 PL_last_lop_op != OP_SOCKPAIR)
3064 "Bareword \"%s\" not allowed while \"strict subs\" in use",
3069 /* Call it a bare word */
3073 if (lastchar != '-') {
3074 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3076 warn(warn_reserved, PL_tokenbuf);
3081 if (lastchar && strchr("*%&", lastchar)) {
3082 warn("Operator or semicolon missing before %c%s",
3083 lastchar, PL_tokenbuf);
3084 warn("Ambiguous use of %c resolved as operator %c",
3085 lastchar, lastchar);
3091 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3092 newSVsv(GvSV(PL_curcop->cop_filegv)));
3096 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3097 newSVpvf("%ld", (long)PL_curcop->cop_line));
3100 case KEY___PACKAGE__:
3101 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3103 ? newSVsv(PL_curstname)
3112 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3113 char *pname = "main";
3114 if (PL_tokenbuf[2] == 'D')
3115 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3116 gv = gv_fetchpv(form("%s::DATA", pname), TRUE, SVt_PVIO);
3119 GvIOp(gv) = newIO();
3120 IoIFP(GvIOp(gv)) = PL_rsfp;
3121 #if defined(HAS_FCNTL) && defined(F_SETFD)
3123 int fd = PerlIO_fileno(PL_rsfp);
3124 fcntl(fd,F_SETFD,fd >= 3);
3127 /* Mark this internal pseudo-handle as clean */
3128 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3130 IoTYPE(GvIOp(gv)) = '|';
3131 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
3132 IoTYPE(GvIOp(gv)) = '-';
3134 IoTYPE(GvIOp(gv)) = '<';
3145 if (PL_expect == XSTATE) {
3152 if (*s == ':' && s[1] == ':') {
3155 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3156 tmp = keyword(PL_tokenbuf, len);
3170 LOP(OP_ACCEPT,XTERM);
3176 LOP(OP_ATAN2,XTERM);
3185 LOP(OP_BLESS,XTERM);
3194 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
3211 if (!PL_cryptseen++)
3214 LOP(OP_CRYPT,XTERM);
3218 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
3219 if (*d != '0' && isDIGIT(*d))
3220 yywarn("chmod: mode argument is missing initial 0");
3222 LOP(OP_CHMOD,XTERM);
3225 LOP(OP_CHOWN,XTERM);
3228 LOP(OP_CONNECT,XTERM);
3244 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3248 PL_hints |= HINT_BLOCK_SCOPE;
3258 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3259 LOP(OP_DBMOPEN,XTERM);
3265 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3272 yylval.ival = PL_curcop->cop_line;
3286 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
3287 UNIBRACK(OP_ENTEREVAL);
3302 case KEY_endhostent:
3308 case KEY_endservent:
3311 case KEY_endprotoent:
3322 yylval.ival = PL_curcop->cop_line;
3324 if (PL_expect == XSTATE && isIDFIRST(*s)) {
3326 if ((PL_bufend - p) >= 3 &&
3327 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3331 croak("Missing $ on loop variable");
3336 LOP(OP_FORMLINE,XTERM);
3342 LOP(OP_FCNTL,XTERM);
3348 LOP(OP_FLOCK,XTERM);
3357 LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
3360 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3375 case KEY_getpriority:
3376 LOP(OP_GETPRIORITY,XTERM);
3378 case KEY_getprotobyname:
3381 case KEY_getprotobynumber:
3382 LOP(OP_GPBYNUMBER,XTERM);
3384 case KEY_getprotoent:
3396 case KEY_getpeername:
3397 UNI(OP_GETPEERNAME);
3399 case KEY_gethostbyname:
3402 case KEY_gethostbyaddr:
3403 LOP(OP_GHBYADDR,XTERM);
3405 case KEY_gethostent:
3408 case KEY_getnetbyname:
3411 case KEY_getnetbyaddr:
3412 LOP(OP_GNBYADDR,XTERM);
3417 case KEY_getservbyname:
3418 LOP(OP_GSBYNAME,XTERM);
3420 case KEY_getservbyport:
3421 LOP(OP_GSBYPORT,XTERM);
3423 case KEY_getservent:
3426 case KEY_getsockname:
3427 UNI(OP_GETSOCKNAME);
3429 case KEY_getsockopt:
3430 LOP(OP_GSOCKOPT,XTERM);
3452 yylval.ival = PL_curcop->cop_line;
3456 LOP(OP_INDEX,XTERM);
3462 LOP(OP_IOCTL,XTERM);
3474 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3505 LOP(OP_LISTEN,XTERM);
3514 s = scan_pat(s,OP_MATCH);
3515 TERM(sublex_start());
3518 LOP(OP_MAPSTART,XREF);
3521 LOP(OP_MKDIR,XTERM);
3524 LOP(OP_MSGCTL,XTERM);
3527 LOP(OP_MSGGET,XTERM);
3530 LOP(OP_MSGRCV,XTERM);
3533 LOP(OP_MSGSND,XTERM);
3538 if (isIDFIRST(*s)) {
3539 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
3540 PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
3541 if (!PL_in_my_stash) {
3544 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
3551 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3558 if (PL_expect != XSTATE)
3559 yyerror("\"no\" not allowed in expression");
3560 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3561 s = force_version(s);
3570 if (isIDFIRST(*s)) {
3572 for (d = s; isALNUM(*d); d++) ;
3574 if (strchr("|&*+-=!?:.", *t))
3575 warn("Precedence problem: open %.*s should be open(%.*s)",
3581 yylval.ival = OP_OR;
3591 LOP(OP_OPEN_DIR,XTERM);
3594 checkcomma(s,PL_tokenbuf,"filehandle");
3598 checkcomma(s,PL_tokenbuf,"filehandle");
3617 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3621 LOP(OP_PIPE_OP,XTERM);
3626 missingterm((char*)0);
3627 yylval.ival = OP_CONST;
3628 TERM(sublex_start());
3636 missingterm((char*)0);
3637 if (PL_dowarn && SvLEN(PL_lex_stuff)) {
3638 d = SvPV_force(PL_lex_stuff, len);
3639 for (; len; --len, ++d) {
3641 warn("Possible attempt to separate words with commas");
3645 warn("Possible attempt to put comments in qw() list");
3651 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, tokeq(PL_lex_stuff));
3652 PL_lex_stuff = Nullsv;
3655 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(" ",1));
3658 yylval.ival = OP_SPLIT;
3662 PL_last_lop = PL_oldbufptr;
3663 PL_last_lop_op = OP_SPLIT;
3669 missingterm((char*)0);
3670 yylval.ival = OP_STRINGIFY;
3671 if (SvIVX(PL_lex_stuff) == '\'')
3672 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
3673 TERM(sublex_start());
3676 s = scan_pat(s,OP_QR);
3677 TERM(sublex_start());
3682 missingterm((char*)0);
3683 yylval.ival = OP_BACKTICK;
3685 TERM(sublex_start());
3691 *PL_tokenbuf = '\0';
3692 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3693 if (isIDFIRST(*PL_tokenbuf))
3694 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
3696 yyerror("<> should be quotes");
3703 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3707 LOP(OP_RENAME,XTERM);
3716 LOP(OP_RINDEX,XTERM);
3739 LOP(OP_REVERSE,XTERM);
3750 TERM(sublex_start());
3752 TOKEN(1); /* force error */
3761 LOP(OP_SELECT,XTERM);
3767 LOP(OP_SEMCTL,XTERM);
3770 LOP(OP_SEMGET,XTERM);
3773 LOP(OP_SEMOP,XTERM);
3779 LOP(OP_SETPGRP,XTERM);
3781 case KEY_setpriority:
3782 LOP(OP_SETPRIORITY,XTERM);
3784 case KEY_sethostent:
3790 case KEY_setservent:
3793 case KEY_setprotoent:
3803 LOP(OP_SEEKDIR,XTERM);
3805 case KEY_setsockopt:
3806 LOP(OP_SSOCKOPT,XTERM);
3812 LOP(OP_SHMCTL,XTERM);
3815 LOP(OP_SHMGET,XTERM);
3818 LOP(OP_SHMREAD,XTERM);
3821 LOP(OP_SHMWRITE,XTERM);
3824 LOP(OP_SHUTDOWN,XTERM);
3833 LOP(OP_SOCKET,XTERM);
3835 case KEY_socketpair:
3836 LOP(OP_SOCKPAIR,XTERM);
3839 checkcomma(s,PL_tokenbuf,"subroutine name");
3841 if (*s == ';' || *s == ')') /* probably a close */
3842 croak("sort is now a reserved word");
3844 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3848 LOP(OP_SPLIT,XTERM);
3851 LOP(OP_SPRINTF,XTERM);
3854 LOP(OP_SPLICE,XTERM);
3870 LOP(OP_SUBSTR,XTERM);
3877 if (isIDFIRST(*s) || *s == '\'' || *s == ':') {
3878 char tmpbuf[sizeof PL_tokenbuf];
3880 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3881 if (strchr(tmpbuf, ':'))
3882 sv_setpv(PL_subname, tmpbuf);
3884 sv_setsv(PL_subname,PL_curstname);
3885 sv_catpvn(PL_subname,"::",2);
3886 sv_catpvn(PL_subname,tmpbuf,len);
3888 s = force_word(s,WORD,FALSE,TRUE,TRUE);
3892 PL_expect = XTERMBLOCK;
3893 sv_setpv(PL_subname,"?");
3896 if (tmp == KEY_format) {
3899 PL_lex_formbrack = PL_lex_brackets + 1;
3903 /* Look for a prototype */
3910 SvREFCNT_dec(PL_lex_stuff);
3911 PL_lex_stuff = Nullsv;
3912 croak("Prototype not terminated");
3915 d = SvPVX(PL_lex_stuff);
3917 for (p = d; *p; ++p) {
3922 SvCUR(PL_lex_stuff) = tmp;
3925 PL_nextval[1] = PL_nextval[0];
3926 PL_nexttype[1] = PL_nexttype[0];
3927 PL_nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
3928 PL_nexttype[0] = THING;
3929 if (PL_nexttoke == 1) {
3930 PL_lex_defer = PL_lex_state;
3931 PL_lex_expect = PL_expect;
3932 PL_lex_state = LEX_KNOWNEXT;
3934 PL_lex_stuff = Nullsv;
3937 if (*SvPV(PL_subname,PL_na) == '?') {
3938 sv_setpv(PL_subname,"__ANON__");
3945 LOP(OP_SYSTEM,XREF);
3948 LOP(OP_SYMLINK,XTERM);
3951 LOP(OP_SYSCALL,XTERM);
3954 LOP(OP_SYSOPEN,XTERM);
3957 LOP(OP_SYSSEEK,XTERM);
3960 LOP(OP_SYSREAD,XTERM);
3963 LOP(OP_SYSWRITE,XTERM);
3967 TERM(sublex_start());
3988 LOP(OP_TRUNCATE,XTERM);
4000 yylval.ival = PL_curcop->cop_line;
4004 yylval.ival = PL_curcop->cop_line;
4008 LOP(OP_UNLINK,XTERM);
4014 LOP(OP_UNPACK,XTERM);
4017 LOP(OP_UTIME,XTERM);
4021 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4022 if (*d != '0' && isDIGIT(*d))
4023 yywarn("umask: argument is missing initial 0");
4028 LOP(OP_UNSHIFT,XTERM);
4031 if (PL_expect != XSTATE)
4032 yyerror("\"use\" not allowed in expression");
4035 s = force_version(s);
4036 if(*s == ';' || (s = skipspace(s), *s == ';')) {
4037 PL_nextval[PL_nexttoke].opval = Nullop;
4042 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4043 s = force_version(s);
4056 yylval.ival = PL_curcop->cop_line;
4060 PL_hints |= HINT_BLOCK_SCOPE;
4067 LOP(OP_WAITPID,XTERM);
4075 static char ctl_l[2];
4077 if (ctl_l[0] == '\0')
4078 ctl_l[0] = toCTRL('L');
4079 gv_fetchpv(ctl_l,TRUE, SVt_PV);
4082 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
4087 if (PL_expect == XOPERATOR)
4093 yylval.ival = OP_XOR;
4098 TERM(sublex_start());
4104 keyword(register char *d, I32 len)
4109 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
4110 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
4111 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
4112 if (strEQ(d,"__DATA__")) return KEY___DATA__;
4113 if (strEQ(d,"__END__")) return KEY___END__;
4117 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
4122 if (strEQ(d,"and")) return -KEY_and;
4123 if (strEQ(d,"abs")) return -KEY_abs;
4126 if (strEQ(d,"alarm")) return -KEY_alarm;
4127 if (strEQ(d,"atan2")) return -KEY_atan2;
4130 if (strEQ(d,"accept")) return -KEY_accept;
4135 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
4138 if (strEQ(d,"bless")) return -KEY_bless;
4139 if (strEQ(d,"bind")) return -KEY_bind;
4140 if (strEQ(d,"binmode")) return -KEY_binmode;
4143 if (strEQ(d,"CORE")) return -KEY_CORE;
4148 if (strEQ(d,"cmp")) return -KEY_cmp;
4149 if (strEQ(d,"chr")) return -KEY_chr;
4150 if (strEQ(d,"cos")) return -KEY_cos;
4153 if (strEQ(d,"chop")) return KEY_chop;
4156 if (strEQ(d,"close")) return -KEY_close;
4157 if (strEQ(d,"chdir")) return -KEY_chdir;
4158 if (strEQ(d,"chomp")) return KEY_chomp;
4159 if (strEQ(d,"chmod")) return -KEY_chmod;
4160 if (strEQ(d,"chown")) return -KEY_chown;
4161 if (strEQ(d,"crypt")) return -KEY_crypt;
4164 if (strEQ(d,"chroot")) return -KEY_chroot;
4165 if (strEQ(d,"caller")) return -KEY_caller;
4168 if (strEQ(d,"connect")) return -KEY_connect;
4171 if (strEQ(d,"closedir")) return -KEY_closedir;
4172 if (strEQ(d,"continue")) return -KEY_continue;
4177 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
4182 if (strEQ(d,"do")) return KEY_do;
4185 if (strEQ(d,"die")) return -KEY_die;
4188 if (strEQ(d,"dump")) return -KEY_dump;
4191 if (strEQ(d,"delete")) return KEY_delete;
4194 if (strEQ(d,"defined")) return KEY_defined;
4195 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
4198 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
4203 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
4204 if (strEQ(d,"END")) return KEY_END;
4209 if (strEQ(d,"eq")) return -KEY_eq;
4212 if (strEQ(d,"eof")) return -KEY_eof;
4213 if (strEQ(d,"exp")) return -KEY_exp;
4216 if (strEQ(d,"else")) return KEY_else;
4217 if (strEQ(d,"exit")) return -KEY_exit;
4218 if (strEQ(d,"eval")) return KEY_eval;
4219 if (strEQ(d,"exec")) return -KEY_exec;
4220 if (strEQ(d,"each")) return KEY_each;
4223 if (strEQ(d,"elsif")) return KEY_elsif;
4226 if (strEQ(d,"exists")) return KEY_exists;
4227 if (strEQ(d,"elseif")) warn("elseif should be elsif");
4230 if (strEQ(d,"endgrent")) return -KEY_endgrent;
4231 if (strEQ(d,"endpwent")) return -KEY_endpwent;
4234 if (strEQ(d,"endnetent")) return -KEY_endnetent;
4237 if (strEQ(d,"endhostent")) return -KEY_endhostent;
4238 if (strEQ(d,"endservent")) return -KEY_endservent;
4241 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
4248 if (strEQ(d,"for")) return KEY_for;
4251 if (strEQ(d,"fork")) return -KEY_fork;
4254 if (strEQ(d,"fcntl")) return -KEY_fcntl;
4255 if (strEQ(d,"flock")) return -KEY_flock;
4258 if (strEQ(d,"format")) return KEY_format;
4259 if (strEQ(d,"fileno")) return -KEY_fileno;
4262 if (strEQ(d,"foreach")) return KEY_foreach;
4265 if (strEQ(d,"formline")) return -KEY_formline;
4271 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
4272 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
4276 if (strnEQ(d,"get",3)) {
4281 if (strEQ(d,"ppid")) return -KEY_getppid;
4282 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
4285 if (strEQ(d,"pwent")) return -KEY_getpwent;
4286 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
4287 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
4290 if (strEQ(d,"peername")) return -KEY_getpeername;
4291 if (strEQ(d,"protoent")) return -KEY_getprotoent;
4292 if (strEQ(d,"priority")) return -KEY_getpriority;
4295 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
4298 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
4302 else if (*d == 'h') {
4303 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
4304 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
4305 if (strEQ(d,"hostent")) return -KEY_gethostent;
4307 else if (*d == 'n') {
4308 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
4309 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
4310 if (strEQ(d,"netent")) return -KEY_getnetent;
4312 else if (*d == 's') {
4313 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
4314 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
4315 if (strEQ(d,"servent")) return -KEY_getservent;
4316 if (strEQ(d,"sockname")) return -KEY_getsockname;
4317 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
4319 else if (*d == 'g') {
4320 if (strEQ(d,"grent")) return -KEY_getgrent;
4321 if (strEQ(d,"grnam")) return -KEY_getgrnam;
4322 if (strEQ(d,"grgid")) return -KEY_getgrgid;
4324 else if (*d == 'l') {
4325 if (strEQ(d,"login")) return -KEY_getlogin;
4327 else if (strEQ(d,"c")) return -KEY_getc;
4332 if (strEQ(d,"gt")) return -KEY_gt;
4333 if (strEQ(d,"ge")) return -KEY_ge;
4336 if (strEQ(d,"grep")) return KEY_grep;
4337 if (strEQ(d,"goto")) return KEY_goto;
4338 if (strEQ(d,"glob")) return KEY_glob;
4341 if (strEQ(d,"gmtime")) return -KEY_gmtime;
4346 if (strEQ(d,"hex")) return -KEY_hex;
4349 if (strEQ(d,"INIT")) return KEY_INIT;
4354 if (strEQ(d,"if")) return KEY_if;
4357 if (strEQ(d,"int")) return -KEY_int;
4360 if (strEQ(d,"index")) return -KEY_index;
4361 if (strEQ(d,"ioctl")) return -KEY_ioctl;
4366 if (strEQ(d,"join")) return -KEY_join;
4370 if (strEQ(d,"keys")) return KEY_keys;
4371 if (strEQ(d,"kill")) return -KEY_kill;
4376 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
4377 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
4383 if (strEQ(d,"lt")) return -KEY_lt;
4384 if (strEQ(d,"le")) return -KEY_le;
4385 if (strEQ(d,"lc")) return -KEY_lc;
4388 if (strEQ(d,"log")) return -KEY_log;
4391 if (strEQ(d,"last")) return KEY_last;
4392 if (strEQ(d,"link")) return -KEY_link;
4393 if (strEQ(d,"lock")) return -KEY_lock;
4396 if (strEQ(d,"local")) return KEY_local;
4397 if (strEQ(d,"lstat")) return -KEY_lstat;
4400 if (strEQ(d,"length")) return -KEY_length;
4401 if (strEQ(d,"listen")) return -KEY_listen;
4404 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
4407 if (strEQ(d,"localtime")) return -KEY_localtime;
4413 case 1: return KEY_m;
4415 if (strEQ(d,"my")) return KEY_my;
4418 if (strEQ(d,"map")) return KEY_map;
4421 if (strEQ(d,"mkdir")) return -KEY_mkdir;
4424 if (strEQ(d,"msgctl")) return -KEY_msgctl;
4425 if (strEQ(d,"msgget")) return -KEY_msgget;
4426 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
4427 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
4432 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
4435 if (strEQ(d,"next")) return KEY_next;
4436 if (strEQ(d,"ne")) return -KEY_ne;
4437 if (strEQ(d,"not")) return -KEY_not;
4438 if (strEQ(d,"no")) return KEY_no;
4443 if (strEQ(d,"or")) return -KEY_or;
4446 if (strEQ(d,"ord")) return -KEY_ord;
4447 if (strEQ(d,"oct")) return -KEY_oct;
4448 if (strEQ(d,"our")) { deprecate("reserved word \"our\"");
4452 if (strEQ(d,"open")) return -KEY_open;
4455 if (strEQ(d,"opendir")) return -KEY_opendir;
4462 if (strEQ(d,"pop")) return KEY_pop;
4463 if (strEQ(d,"pos")) return KEY_pos;
4466 if (strEQ(d,"push")) return KEY_push;
4467 if (strEQ(d,"pack")) return -KEY_pack;
4468 if (strEQ(d,"pipe")) return -KEY_pipe;
4471 if (strEQ(d,"print")) return KEY_print;
4474 if (strEQ(d,"printf")) return KEY_printf;
4477 if (strEQ(d,"package")) return KEY_package;
4480 if (strEQ(d,"prototype")) return KEY_prototype;
4485 if (strEQ(d,"q")) return KEY_q;
4486 if (strEQ(d,"qr")) return KEY_qr;
4487 if (strEQ(d,"qq")) return KEY_qq;
4488 if (strEQ(d,"qw")) return KEY_qw;
4489 if (strEQ(d,"qx")) return KEY_qx;
4491 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
4496 if (strEQ(d,"ref")) return -KEY_ref;
4499 if (strEQ(d,"read")) return -KEY_read;
4500 if (strEQ(d,"rand")) return -KEY_rand;
4501 if (strEQ(d,"recv")) return -KEY_recv;
4502 if (strEQ(d,"redo")) return KEY_redo;
4505 if (strEQ(d,"rmdir")) return -KEY_rmdir;
4506 if (strEQ(d,"reset")) return -KEY_reset;
4509 if (strEQ(d,"return")) return KEY_return;
4510 if (strEQ(d,"rename")) return -KEY_rename;
4511 if (strEQ(d,"rindex")) return -KEY_rindex;
4514 if (strEQ(d,"require")) return -KEY_require;
4515 if (strEQ(d,"reverse")) return -KEY_reverse;
4516 if (strEQ(d,"readdir")) return -KEY_readdir;
4519 if (strEQ(d,"readlink")) return -KEY_readlink;
4520 if (strEQ(d,"readline")) return -KEY_readline;
4521 if (strEQ(d,"readpipe")) return -KEY_readpipe;
4524 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
4530 case 0: return KEY_s;
4532 if (strEQ(d,"scalar")) return KEY_scalar;
4537 if (strEQ(d,"seek")) return -KEY_seek;
4538 if (strEQ(d,"send")) return -KEY_send;
4541 if (strEQ(d,"semop")) return -KEY_semop;
4544 if (strEQ(d,"select")) return -KEY_select;
4545 if (strEQ(d,"semctl")) return -KEY_semctl;
4546 if (strEQ(d,"semget")) return -KEY_semget;
4549 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
4550 if (strEQ(d,"seekdir")) return -KEY_seekdir;
4553 if (strEQ(d,"setpwent")) return -KEY_setpwent;
4554 if (strEQ(d,"setgrent")) return -KEY_setgrent;
4557 if (strEQ(d,"setnetent")) return -KEY_setnetent;
4560 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
4561 if (strEQ(d,"sethostent")) return -KEY_sethostent;
4562 if (strEQ(d,"setservent")) return -KEY_setservent;
4565 if (strEQ(d,"setpriority")) return -KEY_setpriority;
4566 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
4573 if (strEQ(d,"shift")) return KEY_shift;
4576 if (strEQ(d,"shmctl")) return -KEY_shmctl;
4577 if (strEQ(d,"shmget")) return -KEY_shmget;
4580 if (strEQ(d,"shmread")) return -KEY_shmread;
4583 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
4584 if (strEQ(d,"shutdown")) return -KEY_shutdown;
4589 if (strEQ(d,"sin")) return -KEY_sin;
4592 if (strEQ(d,"sleep")) return -KEY_sleep;
4595 if (strEQ(d,"sort")) return KEY_sort;
4596 if (strEQ(d,"socket")) return -KEY_socket;
4597 if (strEQ(d,"socketpair")) return -KEY_socketpair;
4600 if (strEQ(d,"split")) return KEY_split;
4601 if (strEQ(d,"sprintf")) return -KEY_sprintf;
4602 if (strEQ(d,"splice")) return KEY_splice;
4605 if (strEQ(d,"sqrt")) return -KEY_sqrt;
4608 if (strEQ(d,"srand")) return -KEY_srand;
4611 if (strEQ(d,"stat")) return -KEY_stat;
4612 if (strEQ(d,"study")) return KEY_study;
4615 if (strEQ(d,"substr")) return -KEY_substr;
4616 if (strEQ(d,"sub")) return KEY_sub;
4621 if (strEQ(d,"system")) return -KEY_system;
4624 if (strEQ(d,"symlink")) return -KEY_symlink;
4625 if (strEQ(d,"syscall")) return -KEY_syscall;
4626 if (strEQ(d,"sysopen")) return -KEY_sysopen;
4627 if (strEQ(d,"sysread")) return -KEY_sysread;
4628 if (strEQ(d,"sysseek")) return -KEY_sysseek;
4631 if (strEQ(d,"syswrite")) return -KEY_syswrite;
4640 if (strEQ(d,"tr")) return KEY_tr;
4643 if (strEQ(d,"tie")) return KEY_tie;
4646 if (strEQ(d,"tell")) return -KEY_tell;
4647 if (strEQ(d,"tied")) return KEY_tied;
4648 if (strEQ(d,"time")) return -KEY_time;
4651 if (strEQ(d,"times")) return -KEY_times;
4654 if (strEQ(d,"telldir")) return -KEY_telldir;
4657 if (strEQ(d,"truncate")) return -KEY_truncate;
4664 if (strEQ(d,"uc")) return -KEY_uc;
4667 if (strEQ(d,"use")) return KEY_use;
4670 if (strEQ(d,"undef")) return KEY_undef;
4671 if (strEQ(d,"until")) return KEY_until;
4672 if (strEQ(d,"untie")) return KEY_untie;
4673 if (strEQ(d,"utime")) return -KEY_utime;
4674 if (strEQ(d,"umask")) return -KEY_umask;
4677 if (strEQ(d,"unless")) return KEY_unless;
4678 if (strEQ(d,"unpack")) return -KEY_unpack;
4679 if (strEQ(d,"unlink")) return -KEY_unlink;
4682 if (strEQ(d,"unshift")) return KEY_unshift;
4683 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
4688 if (strEQ(d,"values")) return -KEY_values;
4689 if (strEQ(d,"vec")) return -KEY_vec;
4694 if (strEQ(d,"warn")) return -KEY_warn;
4695 if (strEQ(d,"wait")) return -KEY_wait;
4698 if (strEQ(d,"while")) return KEY_while;
4699 if (strEQ(d,"write")) return -KEY_write;
4702 if (strEQ(d,"waitpid")) return -KEY_waitpid;
4705 if (strEQ(d,"wantarray")) return -KEY_wantarray;
4710 if (len == 1) return -KEY_x;
4711 if (strEQ(d,"xor")) return -KEY_xor;
4714 if (len == 1) return KEY_y;
4723 checkcomma(register char *s, char *name, char *what)
4727 if (PL_dowarn && *s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
4729 for (w = s+2; *w && level; w++) {
4736 for (; *w && isSPACE(*w); w++) ;
4737 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
4738 warn("%s (...) interpreted as function",name);
4740 while (s < PL_bufend && isSPACE(*s))
4744 while (s < PL_bufend && isSPACE(*s))
4746 if (isIDFIRST(*s)) {
4750 while (s < PL_bufend && isSPACE(*s))
4755 kw = keyword(w, s - w) || perl_get_cv(w, FALSE) != 0;
4759 croak("No comma allowed after %s", what);
4765 new_constant(char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)
4768 HV *table = GvHV(PL_hintgv); /* ^H */
4771 bool oldcatch = CATCH_GET;
4777 yyerror("%^H is not defined");
4780 cvp = hv_fetch(table, key, strlen(key), FALSE);
4781 if (!cvp || !SvOK(*cvp)) {
4782 sprintf(buf,"$^H{%s} is not defined", key);
4786 sv_2mortal(sv); /* Parent created it permanently */
4789 pv = sv_2mortal(newSVpv(s, len));
4791 typesv = sv_2mortal(newSVpv(type, 0));
4793 typesv = &PL_sv_undef;
4795 Zero(&myop, 1, BINOP);
4796 myop.op_last = (OP *) &myop;
4797 myop.op_next = Nullop;
4798 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
4800 PUSHSTACKi(PERLSI_OVERLOAD);
4803 PL_op = (OP *) &myop;
4804 if (PERLDB_SUB && PL_curstash != PL_debstash)
4805 PL_op->op_private |= OPpENTERSUB_DB;
4816 if (PL_op = pp_entersub(ARGS))
4823 CATCH_SET(oldcatch);
4827 sprintf(buf,"Call to &{$^H{%s}} did not return a defined value", key);
4830 return SvREFCNT_inc(res);
4834 scan_word(register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
4836 register char *d = dest;
4837 register char *e = d + destlen - 3; /* two-character token, ending NUL */
4840 croak(ident_too_long);
4843 else if (*s == '\'' && allow_package && isIDFIRST(s[1])) {
4848 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
4861 scan_ident(register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
4868 if (PL_lex_brackets == 0)
4869 PL_lex_fakebrack = 0;
4873 e = d + destlen - 3; /* two-character token, ending NUL */
4875 while (isDIGIT(*s)) {
4877 croak(ident_too_long);
4884 croak(ident_too_long);
4887 else if (*s == '\'' && isIDFIRST(s[1])) {
4892 else if (*s == ':' && s[1] == ':') {
4903 if (PL_lex_state != LEX_NORMAL)
4904 PL_lex_state = LEX_INTERPENDMAYBE;
4907 if (*s == '$' && s[1] &&
4908 (isALNUM(s[1]) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
4910 if (isDIGIT(s[1]) && PL_lex_state == LEX_INTERPNORMAL)
4911 deprecate("\"$$<digit>\" to mean \"${$}<digit>\"");
4924 if (*d == '^' && *s && (isUPPER(*s) || strchr("[\\]^_?", *s))) {
4929 if (isSPACE(s[-1])) {
4932 if (ch != ' ' && ch != '\t') {
4938 if (isIDFIRST(*d)) {
4940 while (isALNUM(*s) || *s == ':')
4943 while (s < send && (*s == ' ' || *s == '\t')) s++;
4944 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
4945 if (PL_dowarn && keyword(dest, d - dest)) {
4946 char *brack = *s == '[' ? "[...]" : "{...}";
4947 warn("Ambiguous use of %c{%s%s} resolved to %c%s%s",
4948 funny, dest, brack, funny, dest, brack);
4950 PL_lex_fakebrack = PL_lex_brackets+1;
4952 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4958 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
4959 PL_lex_state = LEX_INTERPEND;
4962 if (PL_dowarn && PL_lex_state == LEX_NORMAL &&
4963 (keyword(dest, d - dest) || perl_get_cv(dest, FALSE)))
4964 warn("Ambiguous use of %c{%s} resolved to %c%s",
4965 funny, dest, funny, dest);
4968 s = bracket; /* let the parser handle it */
4972 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
4973 PL_lex_state = LEX_INTERPEND;
4977 void pmflag(U16 *pmfl, int ch)
4982 *pmfl |= PMf_GLOBAL;
4984 *pmfl |= PMf_CONTINUE;
4988 *pmfl |= PMf_MULTILINE;
4990 *pmfl |= PMf_SINGLELINE;
4992 *pmfl |= PMf_EXTENDED;
4996 scan_pat(char *start, I32 type)
5001 s = scan_str(start);
5004 SvREFCNT_dec(PL_lex_stuff);
5005 PL_lex_stuff = Nullsv;
5006 croak("Search pattern not terminated");
5009 pm = (PMOP*)newPMOP(type, 0);
5010 if (PL_multi_open == '?')
5011 pm->op_pmflags |= PMf_ONCE;
5013 while (*s && strchr("iomsx", *s))
5014 pmflag(&pm->op_pmflags,*s++);
5017 while (*s && strchr("iogcmsx", *s))
5018 pmflag(&pm->op_pmflags,*s++);
5020 pm->op_pmpermflags = pm->op_pmflags;
5022 PL_lex_op = (OP*)pm;
5023 yylval.ival = OP_MATCH;
5028 scan_subst(char *start)
5035 yylval.ival = OP_NULL;
5037 s = scan_str(start);
5041 SvREFCNT_dec(PL_lex_stuff);
5042 PL_lex_stuff = Nullsv;
5043 croak("Substitution pattern not terminated");
5046 if (s[-1] == PL_multi_open)
5049 first_start = PL_multi_start;
5053 SvREFCNT_dec(PL_lex_stuff);
5054 PL_lex_stuff = Nullsv;
5056 SvREFCNT_dec(PL_lex_repl);
5057 PL_lex_repl = Nullsv;
5058 croak("Substitution replacement not terminated");
5060 PL_multi_start = first_start; /* so whole substitution is taken together */
5062 pm = (PMOP*)newPMOP(OP_SUBST, 0);
5068 else if (strchr("iogcmsx", *s))
5069 pmflag(&pm->op_pmflags,*s++);
5076 pm->op_pmflags |= PMf_EVAL;
5077 repl = newSVpv("",0);
5079 sv_catpv(repl, es ? "eval " : "do ");
5080 sv_catpvn(repl, "{ ", 2);
5081 sv_catsv(repl, PL_lex_repl);
5082 sv_catpvn(repl, " };", 2);
5083 SvCOMPILED_on(repl);
5084 SvREFCNT_dec(PL_lex_repl);
5088 pm->op_pmpermflags = pm->op_pmflags;
5089 PL_lex_op = (OP*)pm;
5090 yylval.ival = OP_SUBST;
5095 scan_trans(char *start)
5104 yylval.ival = OP_NULL;
5106 s = scan_str(start);
5109 SvREFCNT_dec(PL_lex_stuff);
5110 PL_lex_stuff = Nullsv;
5111 croak("Transliteration pattern not terminated");
5113 if (s[-1] == PL_multi_open)
5119 SvREFCNT_dec(PL_lex_stuff);
5120 PL_lex_stuff = Nullsv;
5122 SvREFCNT_dec(PL_lex_repl);
5123 PL_lex_repl = Nullsv;
5124 croak("Transliteration replacement not terminated");
5127 New(803,tbl,256,short);
5128 o = newPVOP(OP_TRANS, 0, (char*)tbl);
5130 complement = Delete = squash = 0;
5131 while (*s == 'c' || *s == 'd' || *s == 's') {
5133 complement = OPpTRANS_COMPLEMENT;
5135 Delete = OPpTRANS_DELETE;
5137 squash = OPpTRANS_SQUASH;
5140 o->op_private = Delete|squash|complement;
5143 yylval.ival = OP_TRANS;
5148 scan_heredoc(register char *s)
5152 I32 op_type = OP_SCALAR;
5159 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
5163 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
5166 for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5167 if (*peek && strchr("`'\"",*peek)) {
5170 s = delimcpy(d, e, s, PL_bufend, term, &len);
5181 deprecate("bare << to mean <<\"\"");
5182 for (; isALNUM(*s); s++) {
5187 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
5188 croak("Delimiter for here document is too long");
5191 len = d - PL_tokenbuf;
5192 #ifndef PERL_STRICT_CR
5193 d = strchr(s, '\r');
5197 while (s < PL_bufend) {
5203 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
5212 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5217 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
5218 herewas = newSVpv(s,PL_bufend-s);
5220 s--, herewas = newSVpv(s,d-s);
5221 s += SvCUR(herewas);
5223 tmpstr = NEWSV(87,79);
5224 sv_upgrade(tmpstr, SVt_PVIV);
5229 else if (term == '`') {
5230 op_type = OP_BACKTICK;
5231 SvIVX(tmpstr) = '\\';
5235 PL_multi_start = PL_curcop->cop_line;
5236 PL_multi_open = PL_multi_close = '<';
5237 term = *PL_tokenbuf;
5240 while (s < PL_bufend &&
5241 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
5243 PL_curcop->cop_line++;
5245 if (s >= PL_bufend) {
5246 PL_curcop->cop_line = PL_multi_start;
5247 missingterm(PL_tokenbuf);
5249 sv_setpvn(tmpstr,d+1,s-d);
5251 PL_curcop->cop_line++; /* the preceding stmt passes a newline */
5253 sv_catpvn(herewas,s,PL_bufend-s);
5254 sv_setsv(PL_linestr,herewas);
5255 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
5256 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5259 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
5260 while (s >= PL_bufend) { /* multiple line string? */
5262 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5263 PL_curcop->cop_line = PL_multi_start;
5264 missingterm(PL_tokenbuf);
5266 PL_curcop->cop_line++;
5267 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5268 #ifndef PERL_STRICT_CR
5269 if (PL_bufend - PL_linestart >= 2) {
5270 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
5271 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
5273 PL_bufend[-2] = '\n';
5275 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5277 else if (PL_bufend[-1] == '\r')
5278 PL_bufend[-1] = '\n';
5280 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
5281 PL_bufend[-1] = '\n';
5283 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5284 SV *sv = NEWSV(88,0);
5286 sv_upgrade(sv, SVt_PVMG);
5287 sv_setsv(sv,PL_linestr);
5288 av_store(GvAV(PL_curcop->cop_filegv),
5289 (I32)PL_curcop->cop_line,sv);
5291 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
5294 sv_catsv(PL_linestr,herewas);
5295 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5299 sv_catsv(tmpstr,PL_linestr);
5302 PL_multi_end = PL_curcop->cop_line;
5304 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
5305 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
5306 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
5308 SvREFCNT_dec(herewas);
5309 PL_lex_stuff = tmpstr;
5310 yylval.ival = op_type;
5315 takes: current position in input buffer
5316 returns: new position in input buffer
5317 side-effects: yylval and lex_op are set.
5322 <FH> read from filehandle
5323 <pkg::FH> read from package qualified filehandle
5324 <pkg'FH> read from package qualified filehandle
5325 <$fh> read from filehandle in $fh
5331 scan_inputsymbol(char *start)
5333 register char *s = start; /* current position in buffer */
5338 d = PL_tokenbuf; /* start of temp holding space */
5339 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
5340 s = delimcpy(d, e, s + 1, PL_bufend, '>', &len); /* extract until > */
5342 /* die if we didn't have space for the contents of the <>,
5346 if (len >= sizeof PL_tokenbuf)
5347 croak("Excessively long <> operator");
5349 croak("Unterminated <> operator");
5354 Remember, only scalar variables are interpreted as filehandles by
5355 this code. Anything more complex (e.g., <$fh{$num}>) will be
5356 treated as a glob() call.
5357 This code makes use of the fact that except for the $ at the front,
5358 a scalar variable and a filehandle look the same.
5360 if (*d == '$' && d[1]) d++;
5362 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
5363 while (*d && (isALNUM(*d) || *d == '\'' || *d == ':'))
5366 /* If we've tried to read what we allow filehandles to look like, and
5367 there's still text left, then it must be a glob() and not a getline.
5368 Use scan_str to pull out the stuff between the <> and treat it
5369 as nothing more than a string.
5372 if (d - PL_tokenbuf != len) {
5373 yylval.ival = OP_GLOB;
5375 s = scan_str(start);
5377 croak("Glob not terminated");
5381 /* we're in a filehandle read situation */
5384 /* turn <> into <ARGV> */
5386 (void)strcpy(d,"ARGV");
5388 /* if <$fh>, create the ops to turn the variable into a
5394 /* try to find it in the pad for this block, otherwise find
5395 add symbol table ops
5397 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
5398 OP *o = newOP(OP_PADSV, 0);
5400 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newUNOP(OP_RV2GV, 0, o));
5403 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
5404 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
5405 newUNOP(OP_RV2GV, 0,
5406 newUNOP(OP_RV2SV, 0,
5407 newGVOP(OP_GV, 0, gv))));
5409 /* we created the ops in lex_op, so make yylval.ival a null op */
5410 yylval.ival = OP_NULL;
5413 /* If it's none of the above, it must be a literal filehandle
5414 (<Foo::BAR> or <FOO>) so build a simple readline OP */
5416 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
5417 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
5418 yylval.ival = OP_NULL;
5427 takes: start position in buffer
5428 returns: position to continue reading from buffer
5429 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
5430 updates the read buffer.
5432 This subroutine pulls a string out of the input. It is called for:
5433 q single quotes q(literal text)
5434 ' single quotes 'literal text'
5435 qq double quotes qq(interpolate $here please)
5436 " double quotes "interpolate $here please"
5437 qx backticks qx(/bin/ls -l)
5438 ` backticks `/bin/ls -l`
5439 qw quote words @EXPORT_OK = qw( func() $spam )
5440 m// regexp match m/this/
5441 s/// regexp substitute s/this/that/
5442 tr/// string transliterate tr/this/that/
5443 y/// string transliterate y/this/that/
5444 ($*@) sub prototypes sub foo ($)
5445 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
5447 In most of these cases (all but <>, patterns and transliterate)
5448 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
5449 calls scan_str(). s/// makes yylex() call scan_subst() which calls
5450 scan_str(). tr/// and y/// make yylex() call scan_trans() which
5453 It skips whitespace before the string starts, and treats the first
5454 character as the delimiter. If the delimiter is one of ([{< then
5455 the corresponding "close" character )]}> is used as the closing
5456 delimiter. It allows quoting of delimiters, and if the string has
5457 balanced delimiters ([{<>}]) it allows nesting.
5459 The lexer always reads these strings into lex_stuff, except in the
5460 case of the operators which take *two* arguments (s/// and tr///)
5461 when it checks to see if lex_stuff is full (presumably with the 1st
5462 arg to s or tr) and if so puts the string into lex_repl.
5467 scan_str(char *start)
5470 SV *sv; /* scalar value: string */
5471 char *tmps; /* temp string, used for delimiter matching */
5472 register char *s = start; /* current position in the buffer */
5473 register char term; /* terminating character */
5474 register char *to; /* current position in the sv's data */
5475 I32 brackets = 1; /* bracket nesting level */
5477 /* skip space before the delimiter */
5481 /* mark where we are, in case we need to report errors */
5484 /* after skipping whitespace, the next character is the terminator */
5486 /* mark where we are */
5487 PL_multi_start = PL_curcop->cop_line;
5488 PL_multi_open = term;
5490 /* find corresponding closing delimiter */
5491 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5493 PL_multi_close = term;
5495 /* create a new SV to hold the contents. 87 is leak category, I'm
5496 assuming. 79 is the SV's initial length. What a random number. */
5498 sv_upgrade(sv, SVt_PVIV);
5500 (void)SvPOK_only(sv); /* validate pointer */
5502 /* move past delimiter and try to read a complete string */
5505 /* extend sv if need be */
5506 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
5507 /* set 'to' to the next character in the sv's string */
5508 to = SvPVX(sv)+SvCUR(sv);
5510 /* if open delimiter is the close delimiter read unbridle */
5511 if (PL_multi_open == PL_multi_close) {
5512 for (; s < PL_bufend; s++,to++) {
5513 /* embedded newlines increment the current line number */
5514 if (*s == '\n' && !PL_rsfp)
5515 PL_curcop->cop_line++;
5516 /* handle quoted delimiters */
5517 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
5520 /* any other quotes are simply copied straight through */
5524 /* terminate when run out of buffer (the for() condition), or
5525 have found the terminator */
5526 else if (*s == term)
5532 /* if the terminator isn't the same as the start character (e.g.,
5533 matched brackets), we have to allow more in the quoting, and
5534 be prepared for nested brackets.
5537 /* read until we run out of string, or we find the terminator */
5538 for (; s < PL_bufend; s++,to++) {
5539 /* embedded newlines increment the line count */
5540 if (*s == '\n' && !PL_rsfp)
5541 PL_curcop->cop_line++;
5542 /* backslashes can escape the open or closing characters */
5543 if (*s == '\\' && s+1 < PL_bufend) {
5544 if ((s[1] == PL_multi_open) || (s[1] == PL_multi_close))
5549 /* allow nested opens and closes */
5550 else if (*s == PL_multi_close && --brackets <= 0)
5552 else if (*s == PL_multi_open)
5557 /* terminate the copied string and update the sv's end-of-string */
5559 SvCUR_set(sv, to - SvPVX(sv));
5562 * this next chunk reads more into the buffer if we're not done yet
5565 if (s < PL_bufend) break; /* handle case where we are done yet :-) */
5567 #ifndef PERL_STRICT_CR
5568 if (to - SvPVX(sv) >= 2) {
5569 if ((to[-2] == '\r' && to[-1] == '\n') ||
5570 (to[-2] == '\n' && to[-1] == '\r'))
5574 SvCUR_set(sv, to - SvPVX(sv));
5576 else if (to[-1] == '\r')
5579 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
5583 /* if we're out of file, or a read fails, bail and reset the current
5584 line marker so we can report where the unterminated string began
5587 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5589 PL_curcop->cop_line = PL_multi_start;
5592 /* we read a line, so increment our line counter */
5593 PL_curcop->cop_line++;
5595 /* update debugger info */
5596 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5597 SV *sv = NEWSV(88,0);
5599 sv_upgrade(sv, SVt_PVMG);
5600 sv_setsv(sv,PL_linestr);
5601 av_store(GvAV(PL_curcop->cop_filegv),
5602 (I32)PL_curcop->cop_line, sv);
5605 /* having changed the buffer, we must update PL_bufend */
5606 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5609 /* at this point, we have successfully read the delimited string */
5611 PL_multi_end = PL_curcop->cop_line;
5614 /* if we allocated too much space, give some back */
5615 if (SvCUR(sv) + 5 < SvLEN(sv)) {
5616 SvLEN_set(sv, SvCUR(sv) + 1);
5617 Renew(SvPVX(sv), SvLEN(sv), char);
5620 /* decide whether this is the first or second quoted string we've read
5633 takes: pointer to position in buffer
5634 returns: pointer to new position in buffer
5635 side-effects: builds ops for the constant in yylval.op
5637 Read a number in any of the formats that Perl accepts:
5639 0(x[0-7A-F]+)|([0-7]+)
5640 [\d_]+(\.[\d_]*)?[Ee](\d+)
5642 Underbars (_) are allowed in decimal numbers. If -w is on,
5643 underbars before a decimal point must be at three digit intervals.
5645 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
5648 If it reads a number without a decimal point or an exponent, it will
5649 try converting the number to an integer and see if it can do so
5650 without loss of precision.
5654 scan_num(char *start)
5656 register char *s = start; /* current position in buffer */
5657 register char *d; /* destination in temp buffer */
5658 register char *e; /* end of temp buffer */
5659 I32 tryiv; /* used to see if it can be an int */
5660 double value; /* number read, as a double */
5661 SV *sv; /* place to put the converted number */
5662 I32 floatit; /* boolean: int or float? */
5663 char *lastub = 0; /* position of last underbar */
5664 static char number_too_long[] = "Number too long";
5666 /* We use the first character to decide what type of number this is */
5670 croak("panic: scan_num");
5672 /* if it starts with a 0, it could be an octal number, a decimal in
5673 0.13 disguise, or a hexadecimal number.
5678 u holds the "number so far"
5679 shift the power of 2 of the base (hex == 4, octal == 3)
5680 overflowed was the number more than we can hold?
5682 Shift is used when we add a digit. It also serves as an "are
5683 we in octal or hex?" indicator to disallow hex characters when
5688 bool overflowed = FALSE;
5695 /* check for a decimal in disguise */
5696 else if (s[1] == '.')
5698 /* so it must be octal */
5703 /* read the rest of the octal number */
5705 UV n, b; /* n is used in the overflow test, b is the digit we're adding on */
5709 /* if we don't mention it, we're done */
5718 /* 8 and 9 are not octal */
5721 yyerror("Illegal octal digit");
5725 case '0': case '1': case '2': case '3': case '4':
5726 case '5': case '6': case '7':
5727 b = *s++ & 15; /* ASCII digit -> value of digit */
5731 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
5732 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
5733 /* make sure they said 0x */
5738 /* Prepare to put the digit we have onto the end
5739 of the number so far. We check for overflows.
5743 n = u << shift; /* make room for the digit */
5744 if (!overflowed && (n >> shift) != u
5745 && !(PL_hints & HINT_NEW_BINARY)) {
5746 warn("Integer overflow in %s number",
5747 (shift == 4) ? "hex" : "octal");
5750 u = n | b; /* add the digit to the end */
5755 /* if we get here, we had success: make a scalar value from
5761 if ( PL_hints & HINT_NEW_BINARY)
5762 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
5767 handle decimal numbers.
5768 we're also sent here when we read a 0 as the first digit
5770 case '1': case '2': case '3': case '4': case '5':
5771 case '6': case '7': case '8': case '9': case '.':
5774 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
5777 /* read next group of digits and _ and copy into d */
5778 while (isDIGIT(*s) || *s == '_') {
5779 /* skip underscores, checking for misplaced ones
5783 if (PL_dowarn && lastub && s - lastub != 3)
5784 warn("Misplaced _ in number");
5788 /* check for end of fixed-length buffer */
5790 croak(number_too_long);
5791 /* if we're ok, copy the character */
5796 /* final misplaced underbar check */
5797 if (PL_dowarn && lastub && s - lastub != 3)
5798 warn("Misplaced _ in number");
5800 /* read a decimal portion if there is one. avoid
5801 3..5 being interpreted as the number 3. followed
5804 if (*s == '.' && s[1] != '.') {
5808 /* copy, ignoring underbars, until we run out of
5809 digits. Note: no misplaced underbar checks!
5811 for (; isDIGIT(*s) || *s == '_'; s++) {
5812 /* fixed length buffer check */
5814 croak(number_too_long);
5820 /* read exponent part, if present */
5821 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
5825 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
5826 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
5828 /* allow positive or negative exponent */
5829 if (*s == '+' || *s == '-')
5832 /* read digits of exponent (no underbars :-) */
5833 while (isDIGIT(*s)) {
5835 croak(number_too_long);
5840 /* terminate the string */
5843 /* make an sv from the string */
5845 /* reset numeric locale in case we were earlier left in Swaziland */
5846 SET_NUMERIC_STANDARD();
5847 value = atof(PL_tokenbuf);
5850 See if we can make do with an integer value without loss of
5851 precision. We use I_V to cast to an int, because some
5852 compilers have issues. Then we try casting it back and see
5853 if it was the same. We only do this if we know we
5854 specifically read an integer.
5856 Note: if floatit is true, then we don't need to do the
5860 if (!floatit && (double)tryiv == value)
5861 sv_setiv(sv, tryiv);
5863 sv_setnv(sv, value);
5864 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) )
5865 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
5866 (floatit ? "float" : "integer"), sv, Nullsv, NULL);
5870 /* make the op for the constant and return */
5872 yylval.opval = newSVOP(OP_CONST, 0, sv);
5878 scan_formline(register char *s)
5883 SV *stuff = newSVpv("",0);
5884 bool needargs = FALSE;
5887 if (*s == '.' || *s == '}') {
5889 for (t = s+1; *t == ' ' || *t == '\t'; t++) ;
5893 if (PL_in_eval && !PL_rsfp) {
5894 eol = strchr(s,'\n');
5899 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5901 for (t = s; t < eol; t++) {
5902 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
5904 goto enough; /* ~~ must be first line in formline */
5906 if (*t == '@' || *t == '^')
5909 sv_catpvn(stuff, s, eol-s);
5913 s = filter_gets(PL_linestr, PL_rsfp, 0);
5914 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
5915 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
5918 yyerror("Format not terminated");
5928 PL_lex_state = LEX_NORMAL;
5929 PL_nextval[PL_nexttoke].ival = 0;
5933 PL_lex_state = LEX_FORMLINE;
5934 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
5936 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
5940 SvREFCNT_dec(stuff);
5941 PL_lex_formbrack = 0;
5952 PL_cshlen = strlen(PL_cshname);
5957 start_subparse(I32 is_format, U32 flags)
5960 I32 oldsavestack_ix = PL_savestack_ix;
5961 CV* outsidecv = PL_compcv;
5965 assert(SvTYPE(PL_compcv) == SVt_PVCV);
5967 save_I32(&PL_subline);
5968 save_item(PL_subname);
5970 SAVESPTR(PL_curpad);
5971 SAVESPTR(PL_comppad);
5972 SAVESPTR(PL_comppad_name);
5973 SAVESPTR(PL_compcv);
5974 SAVEI32(PL_comppad_name_fill);
5975 SAVEI32(PL_min_intro_pending);
5976 SAVEI32(PL_max_intro_pending);
5977 SAVEI32(PL_pad_reset_pending);
5979 PL_compcv = (CV*)NEWSV(1104,0);
5980 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
5981 CvFLAGS(PL_compcv) |= flags;
5983 PL_comppad = newAV();
5984 av_push(PL_comppad, Nullsv);
5985 PL_curpad = AvARRAY(PL_comppad);
5986 PL_comppad_name = newAV();
5987 PL_comppad_name_fill = 0;
5988 PL_min_intro_pending = 0;
5990 PL_subline = PL_curcop->cop_line;
5992 av_store(PL_comppad_name, 0, newSVpv("@_", 2));
5993 PL_curpad[0] = (SV*)newAV();
5994 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
5995 #endif /* USE_THREADS */
5997 comppadlist = newAV();
5998 AvREAL_off(comppadlist);
5999 av_store(comppadlist, 0, (SV*)PL_comppad_name);
6000 av_store(comppadlist, 1, (SV*)PL_comppad);
6002 CvPADLIST(PL_compcv) = comppadlist;
6003 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
6005 CvOWNER(PL_compcv) = 0;
6006 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
6007 MUTEX_INIT(CvMUTEXP(PL_compcv));
6008 #endif /* USE_THREADS */
6010 return oldsavestack_ix;
6029 char *context = NULL;
6033 if (!yychar || (yychar == ';' && !PL_rsfp))
6035 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
6036 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
6037 while (isSPACE(*PL_oldoldbufptr))
6039 context = PL_oldoldbufptr;
6040 contlen = PL_bufptr - PL_oldoldbufptr;
6042 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
6043 PL_oldbufptr != PL_bufptr) {
6044 while (isSPACE(*PL_oldbufptr))
6046 context = PL_oldbufptr;
6047 contlen = PL_bufptr - PL_oldbufptr;
6049 else if (yychar > 255)
6050 where = "next token ???";
6051 else if ((yychar & 127) == 127) {
6052 if (PL_lex_state == LEX_NORMAL ||
6053 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
6054 where = "at end of line";
6055 else if (PL_lex_inpat)
6056 where = "within pattern";
6058 where = "within string";
6061 SV *where_sv = sv_2mortal(newSVpv("next char ", 0));
6063 sv_catpvf(where_sv, "^%c", toCTRL(yychar));
6064 else if (isPRINT_LC(yychar))
6065 sv_catpvf(where_sv, "%c", yychar);
6067 sv_catpvf(where_sv, "\\%03o", yychar & 255);
6068 where = SvPVX(where_sv);
6070 msg = sv_2mortal(newSVpv(s, 0));
6071 sv_catpvf(msg, " at %_ line %ld, ",
6072 GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line);
6074 sv_catpvf(msg, "near \"%.*s\"\n", contlen, context);
6076 sv_catpvf(msg, "%s\n", where);
6077 if (PL_multi_start < PL_multi_end && (U32)(PL_curcop->cop_line - PL_multi_end) <= 1) {
6079 " (Might be a runaway multi-line %c%c string starting on line %ld)\n",
6080 (int)PL_multi_open,(int)PL_multi_close,(long)PL_multi_start);
6085 else if (PL_in_eval)
6086 sv_catsv(ERRSV, msg);
6088 PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
6089 if (++PL_error_count >= 10)
6090 croak("%_ has too many errors.\n", GvSV(PL_curcop->cop_filegv));
6092 PL_in_my_stash = Nullhv;