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);
1825 PL_doextract = FALSE;
1827 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
1828 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
1829 sv_catpv(PL_linestr,";}");
1830 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1831 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1832 PL_minus_n = PL_minus_p = 0;
1835 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1836 sv_setpv(PL_linestr,"");
1837 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
1840 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
1841 PL_doextract = FALSE;
1843 /* Incest with pod. */
1844 if (*s == '=' && strnEQ(s, "=cut", 4)) {
1845 sv_setpv(PL_linestr, "");
1846 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1847 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1848 PL_doextract = FALSE;
1852 } while (PL_doextract);
1853 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
1854 if (PERLDB_LINE && PL_curstash != PL_debstash) {
1855 SV *sv = NEWSV(85,0);
1857 sv_upgrade(sv, SVt_PVMG);
1858 sv_setsv(sv,PL_linestr);
1859 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
1861 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1862 if (PL_curcop->cop_line == 1) {
1863 while (s < PL_bufend && isSPACE(*s))
1865 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
1869 if (*s == '#' && *(s+1) == '!')
1871 #ifdef ALTERNATE_SHEBANG
1873 static char as[] = ALTERNATE_SHEBANG;
1874 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
1875 d = s + (sizeof(as) - 1);
1877 #endif /* ALTERNATE_SHEBANG */
1886 while (*d && !isSPACE(*d))
1890 #ifdef ARG_ZERO_IS_SCRIPT
1891 if (ipathend > ipath) {
1893 * HP-UX (at least) sets argv[0] to the script name,
1894 * which makes $^X incorrect. And Digital UNIX and Linux,
1895 * at least, set argv[0] to the basename of the Perl
1896 * interpreter. So, having found "#!", we'll set it right.
1898 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
1899 assert(SvPOK(x) || SvGMAGICAL(x));
1900 if (sv_eq(x, GvSV(PL_curcop->cop_filegv))) {
1901 sv_setpvn(x, ipath, ipathend - ipath);
1904 TAINT_NOT; /* $^X is always tainted, but that's OK */
1906 #endif /* ARG_ZERO_IS_SCRIPT */
1911 d = instr(s,"perl -");
1913 d = instr(s,"perl");
1914 #ifdef ALTERNATE_SHEBANG
1916 * If the ALTERNATE_SHEBANG on this system starts with a
1917 * character that can be part of a Perl expression, then if
1918 * we see it but not "perl", we're probably looking at the
1919 * start of Perl code, not a request to hand off to some
1920 * other interpreter. Similarly, if "perl" is there, but
1921 * not in the first 'word' of the line, we assume the line
1922 * contains the start of the Perl program.
1924 if (d && *s != '#') {
1926 while (*c && !strchr("; \t\r\n\f\v#", *c))
1929 d = Nullch; /* "perl" not in first word; ignore */
1931 *s = '#'; /* Don't try to parse shebang line */
1933 #endif /* ALTERNATE_SHEBANG */
1938 !instr(s,"indir") &&
1939 instr(PL_origargv[0],"perl"))
1945 while (s < PL_bufend && isSPACE(*s))
1947 if (s < PL_bufend) {
1948 Newz(899,newargv,PL_origargc+3,char*);
1950 while (s < PL_bufend && !isSPACE(*s))
1953 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
1956 newargv = PL_origargv;
1958 execv(ipath, newargv);
1959 croak("Can't exec %s", ipath);
1962 U32 oldpdb = PL_perldb;
1963 bool oldn = PL_minus_n;
1964 bool oldp = PL_minus_p;
1966 while (*d && !isSPACE(*d)) d++;
1967 while (*d == ' ' || *d == '\t') d++;
1971 if (*d == 'M' || *d == 'm') {
1973 while (*d && !isSPACE(*d)) d++;
1974 croak("Too late for \"-%.*s\" option",
1977 d = moreswitches(d);
1979 if (PERLDB_LINE && !oldpdb ||
1980 ( PL_minus_n || PL_minus_p ) && !(oldn || oldp) )
1981 /* if we have already added "LINE: while (<>) {",
1982 we must not do it again */
1984 sv_setpv(PL_linestr, "");
1985 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1986 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1987 PL_preambled = FALSE;
1989 (void)gv_fetchfile(PL_origfilename);
1996 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
1998 PL_lex_state = LEX_FORMLINE;
2003 #ifdef PERL_STRICT_CR
2004 warn("Illegal character \\%03o (carriage return)", '\r');
2006 "(Maybe you didn't strip carriage returns after a network transfer?)\n");
2008 case ' ': case '\t': case '\f': case 013:
2013 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2015 while (s < d && *s != '\n')
2020 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2022 PL_lex_state = LEX_FORMLINE;
2032 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2037 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2040 if (strnEQ(s,"=>",2)) {
2041 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2042 OPERATOR('-'); /* unary minus */
2044 PL_last_uni = PL_oldbufptr;
2045 PL_last_lop_op = OP_FTEREAD; /* good enough */
2047 case 'r': FTST(OP_FTEREAD);
2048 case 'w': FTST(OP_FTEWRITE);
2049 case 'x': FTST(OP_FTEEXEC);
2050 case 'o': FTST(OP_FTEOWNED);
2051 case 'R': FTST(OP_FTRREAD);
2052 case 'W': FTST(OP_FTRWRITE);
2053 case 'X': FTST(OP_FTREXEC);
2054 case 'O': FTST(OP_FTROWNED);
2055 case 'e': FTST(OP_FTIS);
2056 case 'z': FTST(OP_FTZERO);
2057 case 's': FTST(OP_FTSIZE);
2058 case 'f': FTST(OP_FTFILE);
2059 case 'd': FTST(OP_FTDIR);
2060 case 'l': FTST(OP_FTLINK);
2061 case 'p': FTST(OP_FTPIPE);
2062 case 'S': FTST(OP_FTSOCK);
2063 case 'u': FTST(OP_FTSUID);
2064 case 'g': FTST(OP_FTSGID);
2065 case 'k': FTST(OP_FTSVTX);
2066 case 'b': FTST(OP_FTBLK);
2067 case 'c': FTST(OP_FTCHR);
2068 case 't': FTST(OP_FTTTY);
2069 case 'T': FTST(OP_FTTEXT);
2070 case 'B': FTST(OP_FTBINARY);
2071 case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2072 case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2073 case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
2075 croak("Unrecognized file test: -%c", (int)tmp);
2082 if (PL_expect == XOPERATOR)
2087 else if (*s == '>') {
2090 if (isIDFIRST(*s)) {
2091 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2099 if (PL_expect == XOPERATOR)
2102 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2104 OPERATOR('-'); /* unary minus */
2111 if (PL_expect == XOPERATOR)
2116 if (PL_expect == XOPERATOR)
2119 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2125 if (PL_expect != XOPERATOR) {
2126 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2127 PL_expect = XOPERATOR;
2128 force_ident(PL_tokenbuf, '*');
2141 if (PL_expect == XOPERATOR) {
2145 PL_tokenbuf[0] = '%';
2146 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2147 if (!PL_tokenbuf[1]) {
2149 yyerror("Final % should be \\% or %name");
2152 PL_pending_ident = '%';
2174 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
2175 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
2180 if (PL_curcop->cop_line < PL_copline)
2181 PL_copline = PL_curcop->cop_line;
2192 if (PL_lex_brackets <= 0)
2193 yyerror("Unmatched right bracket");
2196 if (PL_lex_state == LEX_INTERPNORMAL) {
2197 if (PL_lex_brackets == 0) {
2198 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
2199 PL_lex_state = LEX_INTERPEND;
2206 if (PL_lex_brackets > 100) {
2207 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
2208 if (newlb != PL_lex_brackstack) {
2210 PL_lex_brackstack = newlb;
2213 switch (PL_expect) {
2215 if (PL_lex_formbrack) {
2219 if (PL_oldoldbufptr == PL_last_lop)
2220 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2222 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2223 OPERATOR(HASHBRACK);
2225 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2228 PL_tokenbuf[0] = '\0';
2229 if (d < PL_bufend && *d == '-') {
2230 PL_tokenbuf[0] = '-';
2232 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2235 if (d < PL_bufend && isIDFIRST(*d)) {
2236 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2238 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2241 char minus = (PL_tokenbuf[0] == '-');
2242 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2249 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
2253 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2258 if (PL_oldoldbufptr == PL_last_lop)
2259 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2261 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2264 OPERATOR(HASHBRACK);
2265 /* This hack serves to disambiguate a pair of curlies
2266 * as being a block or an anon hash. Normally, expectation
2267 * determines that, but in cases where we're not in a
2268 * position to expect anything in particular (like inside
2269 * eval"") we have to resolve the ambiguity. This code
2270 * covers the case where the first term in the curlies is a
2271 * quoted string. Most other cases need to be explicitly
2272 * disambiguated by prepending a `+' before the opening
2273 * curly in order to force resolution as an anon hash.
2275 * XXX should probably propagate the outer expectation
2276 * into eval"" to rely less on this hack, but that could
2277 * potentially break current behavior of eval"".
2281 if (*s == '\'' || *s == '"' || *s == '`') {
2282 /* common case: get past first string, handling escapes */
2283 for (t++; t < PL_bufend && *t != *s;)
2284 if (*t++ == '\\' && (*t == '\\' || *t == *s))
2288 else if (*s == 'q') {
2291 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
2292 && !isALNUM(*t)))) {
2294 char open, close, term;
2297 while (t < PL_bufend && isSPACE(*t))
2301 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
2305 for (t++; t < PL_bufend; t++) {
2306 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
2308 else if (*t == open)
2312 for (t++; t < PL_bufend; t++) {
2313 if (*t == '\\' && t+1 < PL_bufend)
2315 else if (*t == close && --brackets <= 0)
2317 else if (*t == open)
2323 else if (isALPHA(*s)) {
2324 for (t++; t < PL_bufend && isALNUM(*t); t++) ;
2326 while (t < PL_bufend && isSPACE(*t))
2328 /* if comma follows first term, call it an anon hash */
2329 /* XXX it could be a comma expression with loop modifiers */
2330 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
2331 || (*t == '=' && t[1] == '>')))
2332 OPERATOR(HASHBRACK);
2333 if (PL_expect == XREF)
2336 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
2342 yylval.ival = PL_curcop->cop_line;
2343 if (isSPACE(*s) || *s == '#')
2344 PL_copline = NOLINE; /* invalidate current command line number */
2349 if (PL_lex_brackets <= 0)
2350 yyerror("Unmatched right bracket");
2352 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
2353 if (PL_lex_brackets < PL_lex_formbrack)
2354 PL_lex_formbrack = 0;
2355 if (PL_lex_state == LEX_INTERPNORMAL) {
2356 if (PL_lex_brackets == 0) {
2357 if (PL_lex_fakebrack) {
2358 PL_lex_state = LEX_INTERPEND;
2360 return yylex(); /* ignore fake brackets */
2362 if (*s == '-' && s[1] == '>')
2363 PL_lex_state = LEX_INTERPENDMAYBE;
2364 else if (*s != '[' && *s != '{')
2365 PL_lex_state = LEX_INTERPEND;
2368 if (PL_lex_brackets < PL_lex_fakebrack) {
2370 PL_lex_fakebrack = 0;
2371 return yylex(); /* ignore fake brackets */
2381 if (PL_expect == XOPERATOR) {
2382 if (PL_dowarn && isALPHA(*s) && PL_bufptr == PL_linestart) {
2383 PL_curcop->cop_line--;
2385 PL_curcop->cop_line++;
2390 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2392 PL_expect = XOPERATOR;
2393 force_ident(PL_tokenbuf, '&');
2397 yylval.ival = (OPpENTERSUB_AMPER<<8);
2416 if (PL_dowarn && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
2417 warn("Reversed %c= operator",(int)tmp);
2419 if (PL_expect == XSTATE && isALPHA(tmp) &&
2420 (s == PL_linestart+1 || s[-2] == '\n') )
2422 if (PL_in_eval && !PL_rsfp) {
2427 if (strnEQ(s,"=cut",4)) {
2441 PL_doextract = TRUE;
2444 if (PL_lex_brackets < PL_lex_formbrack) {
2446 for (t = s; *t == ' ' || *t == '\t'; t++) ;
2447 if (*t == '\n' || *t == '#') {
2465 if (PL_expect != XOPERATOR) {
2466 if (s[1] != '<' && !strchr(s,'>'))
2469 s = scan_heredoc(s);
2471 s = scan_inputsymbol(s);
2472 TERM(sublex_start());
2477 SHop(OP_LEFT_SHIFT);
2491 SHop(OP_RIGHT_SHIFT);
2500 if (PL_expect == XOPERATOR) {
2501 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2504 return ','; /* grandfather non-comma-format format */
2508 if (s[1] == '#' && (isALPHA(s[2]) || strchr("_{$:", s[2]))) {
2509 if (PL_expect == XOPERATOR)
2510 no_op("Array length", PL_bufptr);
2511 PL_tokenbuf[0] = '@';
2512 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2514 if (!PL_tokenbuf[1])
2516 PL_expect = XOPERATOR;
2517 PL_pending_ident = '#';
2521 if (PL_expect == XOPERATOR)
2522 no_op("Scalar", PL_bufptr);
2523 PL_tokenbuf[0] = '$';
2524 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2525 if (!PL_tokenbuf[1]) {
2527 yyerror("Final $ should be \\$ or $name");
2531 /* This kludge not intended to be bulletproof. */
2532 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
2533 yylval.opval = newSVOP(OP_CONST, 0,
2534 newSViv((IV)PL_compiling.cop_arybase));
2535 yylval.opval->op_private = OPpCONST_ARYBASE;
2540 if (PL_lex_state == LEX_NORMAL)
2543 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2546 PL_tokenbuf[0] = '@';
2549 isSPACE(*t) || isALNUM(*t) || *t == '$';
2552 PL_bufptr = skipspace(PL_bufptr);
2553 while (t < PL_bufend && *t != ']')
2555 warn("Multidimensional syntax %.*s not supported",
2556 (t - PL_bufptr) + 1, PL_bufptr);
2560 else if (*s == '{') {
2561 PL_tokenbuf[0] = '%';
2562 if (PL_dowarn && strEQ(PL_tokenbuf+1, "SIG") &&
2563 (t = strchr(s, '}')) && (t = strchr(t, '=')))
2565 char tmpbuf[sizeof PL_tokenbuf];
2567 for (t++; isSPACE(*t); t++) ;
2568 if (isIDFIRST(*t)) {
2569 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
2570 if (*t != '(' && perl_get_cv(tmpbuf, FALSE))
2571 warn("You need to quote \"%s\"", tmpbuf);
2577 PL_expect = XOPERATOR;
2578 if (PL_lex_state == LEX_NORMAL && isSPACE(*d)) {
2579 bool islop = (PL_last_lop == PL_oldoldbufptr);
2580 if (!islop || PL_last_lop_op == OP_GREPSTART)
2581 PL_expect = XOPERATOR;
2582 else if (strchr("$@\"'`q", *s))
2583 PL_expect = XTERM; /* e.g. print $fh "foo" */
2584 else if (strchr("&*<%", *s) && isIDFIRST(s[1]))
2585 PL_expect = XTERM; /* e.g. print $fh &sub */
2586 else if (isIDFIRST(*s)) {
2587 char tmpbuf[sizeof PL_tokenbuf];
2588 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2589 if (tmp = keyword(tmpbuf, len)) {
2590 /* binary operators exclude handle interpretations */
2602 PL_expect = XTERM; /* e.g. print $fh length() */
2607 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
2608 if (gv && GvCVu(gv))
2609 PL_expect = XTERM; /* e.g. print $fh subr() */
2612 else if (isDIGIT(*s))
2613 PL_expect = XTERM; /* e.g. print $fh 3 */
2614 else if (*s == '.' && isDIGIT(s[1]))
2615 PL_expect = XTERM; /* e.g. print $fh .3 */
2616 else if (strchr("/?-+", *s) && !isSPACE(s[1]))
2617 PL_expect = XTERM; /* e.g. print $fh -1 */
2618 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]))
2619 PL_expect = XTERM; /* print $fh <<"EOF" */
2621 PL_pending_ident = '$';
2625 if (PL_expect == XOPERATOR)
2627 PL_tokenbuf[0] = '@';
2628 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2629 if (!PL_tokenbuf[1]) {
2631 yyerror("Final @ should be \\@ or @name");
2634 if (PL_lex_state == LEX_NORMAL)
2636 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2638 PL_tokenbuf[0] = '%';
2640 /* Warn about @ where they meant $. */
2642 if (*s == '[' || *s == '{') {
2644 while (*t && (isALNUM(*t) || strchr(" \t$#+-'\"", *t)))
2646 if (*t == '}' || *t == ']') {
2648 PL_bufptr = skipspace(PL_bufptr);
2649 warn("Scalar value %.*s better written as $%.*s",
2650 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
2655 PL_pending_ident = '@';
2658 case '/': /* may either be division or pattern */
2659 case '?': /* may either be conditional or pattern */
2660 if (PL_expect != XOPERATOR) {
2661 /* Disable warning on "study /blah/" */
2662 if (PL_oldoldbufptr == PL_last_uni
2663 && (*PL_last_uni != 's' || s - PL_last_uni < 5
2664 || memNE(PL_last_uni, "study", 5) || isALNUM(PL_last_uni[5])))
2666 s = scan_pat(s,OP_MATCH);
2667 TERM(sublex_start());
2675 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack && s[1] == '\n' &&
2676 (s == PL_linestart || s[-1] == '\n') ) {
2677 PL_lex_formbrack = 0;
2681 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
2687 yylval.ival = OPf_SPECIAL;
2693 if (PL_expect != XOPERATOR)
2698 case '0': case '1': case '2': case '3': case '4':
2699 case '5': case '6': case '7': case '8': case '9':
2701 if (PL_expect == XOPERATOR)
2707 if (PL_expect == XOPERATOR) {
2708 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2711 return ','; /* grandfather non-comma-format format */
2717 missingterm((char*)0);
2718 yylval.ival = OP_CONST;
2719 TERM(sublex_start());
2723 if (PL_expect == XOPERATOR) {
2724 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2727 return ','; /* grandfather non-comma-format format */
2733 missingterm((char*)0);
2734 yylval.ival = OP_CONST;
2735 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
2736 if (*d == '$' || *d == '@' || *d == '\\') {
2737 yylval.ival = OP_STRINGIFY;
2741 TERM(sublex_start());
2745 if (PL_expect == XOPERATOR)
2746 no_op("Backticks",s);
2748 missingterm((char*)0);
2749 yylval.ival = OP_BACKTICK;
2751 TERM(sublex_start());
2755 if (PL_dowarn && PL_lex_inwhat && isDIGIT(*s))
2756 warn("Can't use \\%c to mean $%c in expression", *s, *s);
2757 if (PL_expect == XOPERATOR)
2758 no_op("Backslash",s);
2762 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
2801 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2803 /* Some keywords can be followed by any delimiter, including ':' */
2804 tmp = (len == 1 && strchr("msyq", PL_tokenbuf[0]) ||
2805 len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
2806 (PL_tokenbuf[0] == 'q' &&
2807 strchr("qwxr", PL_tokenbuf[1]))));
2809 /* x::* is just a word, unless x is "CORE" */
2810 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
2814 while (d < PL_bufend && isSPACE(*d))
2815 d++; /* no comments skipped here, or s### is misparsed */
2817 /* Is this a label? */
2818 if (!tmp && PL_expect == XSTATE
2819 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
2821 yylval.pval = savepv(PL_tokenbuf);
2826 /* Check for keywords */
2827 tmp = keyword(PL_tokenbuf, len);
2829 /* Is this a word before a => operator? */
2830 if (strnEQ(d,"=>",2)) {
2832 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
2833 yylval.opval->op_private = OPpCONST_BARE;
2837 if (tmp < 0) { /* second-class keyword? */
2838 GV *ogv = Nullgv; /* override (winner) */
2839 GV *hgv = Nullgv; /* hidden (loser) */
2840 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
2842 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
2845 if (GvIMPORTED_CV(gv))
2847 else if (! CvMETHOD(cv))
2851 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
2852 (gv = *gvp) != (GV*)&PL_sv_undef &&
2853 GvCVu(gv) && GvIMPORTED_CV(gv))
2859 tmp = 0; /* overridden by import or by GLOBAL */
2862 && -tmp==KEY_lock /* XXX generalizable kludge */
2863 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
2865 tmp = 0; /* any sub overrides "weak" keyword */
2867 else { /* no override */
2871 if (PL_dowarn && hgv)
2872 warn("Ambiguous call resolved as CORE::%s(), %s",
2873 GvENAME(hgv), "qualify as such or use &");
2880 default: /* not a keyword */
2883 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
2885 /* Get the rest if it looks like a package qualifier */
2887 if (*s == '\'' || *s == ':' && s[1] == ':') {
2889 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
2892 croak("Bad name after %s%s", PL_tokenbuf,
2893 *s == '\'' ? "'" : "::");
2897 if (PL_expect == XOPERATOR) {
2898 if (PL_bufptr == PL_linestart) {
2899 PL_curcop->cop_line--;
2901 PL_curcop->cop_line++;
2904 no_op("Bareword",s);
2907 /* Look for a subroutine with this name in current package,
2908 unless name is "Foo::", in which case Foo is a bearword
2909 (and a package name). */
2912 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
2914 if (PL_dowarn && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
2915 warn("Bareword \"%s\" refers to nonexistent package",
2918 PL_tokenbuf[len] = '\0';
2925 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
2928 /* if we saw a global override before, get the right name */
2931 sv = newSVpv("CORE::GLOBAL::",14);
2932 sv_catpv(sv,PL_tokenbuf);
2935 sv = newSVpv(PL_tokenbuf,0);
2937 /* Presume this is going to be a bareword of some sort. */
2940 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2941 yylval.opval->op_private = OPpCONST_BARE;
2943 /* And if "Foo::", then that's what it certainly is. */
2948 /* See if it's the indirect object for a list operator. */
2950 if (PL_oldoldbufptr &&
2951 PL_oldoldbufptr < PL_bufptr &&
2952 (PL_oldoldbufptr == PL_last_lop || PL_oldoldbufptr == PL_last_uni) &&
2953 /* NO SKIPSPACE BEFORE HERE! */
2955 || ((opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF
2956 || (PL_last_lop_op == OP_ENTERSUB
2958 && PL_last_proto[PL_last_proto[0] == ';' ? 1 : 0] == '*')) )
2960 bool immediate_paren = *s == '(';
2962 /* (Now we can afford to cross potential line boundary.) */
2965 /* Two barewords in a row may indicate method call. */
2967 if ((isALPHA(*s) || *s == '$') && (tmp=intuit_method(s,gv)))
2970 /* If not a declared subroutine, it's an indirect object. */
2971 /* (But it's an indir obj regardless for sort.) */
2973 if ((PL_last_lop_op == OP_SORT ||
2974 (!immediate_paren && (!gv || !GvCVu(gv))) ) &&
2975 (PL_last_lop_op != OP_MAPSTART && PL_last_lop_op != OP_GREPSTART)){
2976 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
2981 /* If followed by a paren, it's certainly a subroutine. */
2983 PL_expect = XOPERATOR;
2987 if (gv && GvCVu(gv)) {
2988 for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
2989 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
2994 PL_nextval[PL_nexttoke].opval = yylval.opval;
2995 PL_expect = XOPERATOR;
3001 /* If followed by var or block, call it a method (unless sub) */
3003 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3004 PL_last_lop = PL_oldbufptr;
3005 PL_last_lop_op = OP_METHOD;
3009 /* If followed by a bareword, see if it looks like indir obj. */
3011 if ((isALPHA(*s) || *s == '$') && (tmp = intuit_method(s,gv)))
3014 /* Not a method, so call it a subroutine (if defined) */
3016 if (gv && GvCVu(gv)) {
3018 if (lastchar == '-')
3019 warn("Ambiguous use of -%s resolved as -&%s()",
3020 PL_tokenbuf, PL_tokenbuf);
3021 PL_last_lop = PL_oldbufptr;
3022 PL_last_lop_op = OP_ENTERSUB;
3023 /* Check for a constant sub */
3025 if ((sv = cv_const_sv(cv))) {
3027 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3028 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3029 yylval.opval->op_private = 0;
3033 /* Resolve to GV now. */
3034 op_free(yylval.opval);
3035 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3036 /* Is there a prototype? */
3039 PL_last_proto = SvPV((SV*)cv, len);
3042 if (strEQ(PL_last_proto, "$"))
3044 if (*PL_last_proto == '&' && *s == '{') {
3045 sv_setpv(PL_subname,"__ANON__");
3049 PL_last_proto = NULL;
3050 PL_nextval[PL_nexttoke].opval = yylval.opval;
3056 if (PL_hints & HINT_STRICT_SUBS &&
3059 PL_last_lop_op != OP_TRUNCATE && /* S/F prototype in opcode.pl */
3060 PL_last_lop_op != OP_ACCEPT &&
3061 PL_last_lop_op != OP_PIPE_OP &&
3062 PL_last_lop_op != OP_SOCKPAIR)
3065 "Bareword \"%s\" not allowed while \"strict subs\" in use",
3070 /* Call it a bare word */
3074 if (lastchar != '-') {
3075 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3077 warn(warn_reserved, PL_tokenbuf);
3082 if (lastchar && strchr("*%&", lastchar)) {
3083 warn("Operator or semicolon missing before %c%s",
3084 lastchar, PL_tokenbuf);
3085 warn("Ambiguous use of %c resolved as operator %c",
3086 lastchar, lastchar);
3092 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3093 newSVsv(GvSV(PL_curcop->cop_filegv)));
3097 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3098 newSVpvf("%ld", (long)PL_curcop->cop_line));
3101 case KEY___PACKAGE__:
3102 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3104 ? newSVsv(PL_curstname)
3113 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3114 char *pname = "main";
3115 if (PL_tokenbuf[2] == 'D')
3116 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3117 gv = gv_fetchpv(form("%s::DATA", pname), TRUE, SVt_PVIO);
3120 GvIOp(gv) = newIO();
3121 IoIFP(GvIOp(gv)) = PL_rsfp;
3122 #if defined(HAS_FCNTL) && defined(F_SETFD)
3124 int fd = PerlIO_fileno(PL_rsfp);
3125 fcntl(fd,F_SETFD,fd >= 3);
3128 /* Mark this internal pseudo-handle as clean */
3129 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3131 IoTYPE(GvIOp(gv)) = '|';
3132 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
3133 IoTYPE(GvIOp(gv)) = '-';
3135 IoTYPE(GvIOp(gv)) = '<';
3146 if (PL_expect == XSTATE) {
3153 if (*s == ':' && s[1] == ':') {
3156 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3157 tmp = keyword(PL_tokenbuf, len);
3171 LOP(OP_ACCEPT,XTERM);
3177 LOP(OP_ATAN2,XTERM);
3186 LOP(OP_BLESS,XTERM);
3195 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
3212 if (!PL_cryptseen++)
3215 LOP(OP_CRYPT,XTERM);
3219 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
3220 if (*d != '0' && isDIGIT(*d))
3221 yywarn("chmod: mode argument is missing initial 0");
3223 LOP(OP_CHMOD,XTERM);
3226 LOP(OP_CHOWN,XTERM);
3229 LOP(OP_CONNECT,XTERM);
3245 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3249 PL_hints |= HINT_BLOCK_SCOPE;
3259 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3260 LOP(OP_DBMOPEN,XTERM);
3266 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3273 yylval.ival = PL_curcop->cop_line;
3287 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
3288 UNIBRACK(OP_ENTEREVAL);
3303 case KEY_endhostent:
3309 case KEY_endservent:
3312 case KEY_endprotoent:
3323 yylval.ival = PL_curcop->cop_line;
3325 if (PL_expect == XSTATE && isIDFIRST(*s)) {
3327 if ((PL_bufend - p) >= 3 &&
3328 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3332 croak("Missing $ on loop variable");
3337 LOP(OP_FORMLINE,XTERM);
3343 LOP(OP_FCNTL,XTERM);
3349 LOP(OP_FLOCK,XTERM);
3358 LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
3361 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3376 case KEY_getpriority:
3377 LOP(OP_GETPRIORITY,XTERM);
3379 case KEY_getprotobyname:
3382 case KEY_getprotobynumber:
3383 LOP(OP_GPBYNUMBER,XTERM);
3385 case KEY_getprotoent:
3397 case KEY_getpeername:
3398 UNI(OP_GETPEERNAME);
3400 case KEY_gethostbyname:
3403 case KEY_gethostbyaddr:
3404 LOP(OP_GHBYADDR,XTERM);
3406 case KEY_gethostent:
3409 case KEY_getnetbyname:
3412 case KEY_getnetbyaddr:
3413 LOP(OP_GNBYADDR,XTERM);
3418 case KEY_getservbyname:
3419 LOP(OP_GSBYNAME,XTERM);
3421 case KEY_getservbyport:
3422 LOP(OP_GSBYPORT,XTERM);
3424 case KEY_getservent:
3427 case KEY_getsockname:
3428 UNI(OP_GETSOCKNAME);
3430 case KEY_getsockopt:
3431 LOP(OP_GSOCKOPT,XTERM);
3453 yylval.ival = PL_curcop->cop_line;
3457 LOP(OP_INDEX,XTERM);
3463 LOP(OP_IOCTL,XTERM);
3475 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3506 LOP(OP_LISTEN,XTERM);
3515 s = scan_pat(s,OP_MATCH);
3516 TERM(sublex_start());
3519 LOP(OP_MAPSTART,XREF);
3522 LOP(OP_MKDIR,XTERM);
3525 LOP(OP_MSGCTL,XTERM);
3528 LOP(OP_MSGGET,XTERM);
3531 LOP(OP_MSGRCV,XTERM);
3534 LOP(OP_MSGSND,XTERM);
3539 if (isIDFIRST(*s)) {
3540 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
3541 PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
3542 if (!PL_in_my_stash) {
3545 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
3552 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3559 if (PL_expect != XSTATE)
3560 yyerror("\"no\" not allowed in expression");
3561 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3562 s = force_version(s);
3571 if (isIDFIRST(*s)) {
3573 for (d = s; isALNUM(*d); d++) ;
3575 if (strchr("|&*+-=!?:.", *t))
3576 warn("Precedence problem: open %.*s should be open(%.*s)",
3582 yylval.ival = OP_OR;
3592 LOP(OP_OPEN_DIR,XTERM);
3595 checkcomma(s,PL_tokenbuf,"filehandle");
3599 checkcomma(s,PL_tokenbuf,"filehandle");
3618 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3622 LOP(OP_PIPE_OP,XTERM);
3627 missingterm((char*)0);
3628 yylval.ival = OP_CONST;
3629 TERM(sublex_start());
3637 missingterm((char*)0);
3638 if (PL_dowarn && SvLEN(PL_lex_stuff)) {
3639 d = SvPV_force(PL_lex_stuff, len);
3640 for (; len; --len, ++d) {
3642 warn("Possible attempt to separate words with commas");
3646 warn("Possible attempt to put comments in qw() list");
3652 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, tokeq(PL_lex_stuff));
3653 PL_lex_stuff = Nullsv;
3656 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(" ",1));
3659 yylval.ival = OP_SPLIT;
3663 PL_last_lop = PL_oldbufptr;
3664 PL_last_lop_op = OP_SPLIT;
3670 missingterm((char*)0);
3671 yylval.ival = OP_STRINGIFY;
3672 if (SvIVX(PL_lex_stuff) == '\'')
3673 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
3674 TERM(sublex_start());
3677 s = scan_pat(s,OP_QR);
3678 TERM(sublex_start());
3683 missingterm((char*)0);
3684 yylval.ival = OP_BACKTICK;
3686 TERM(sublex_start());
3692 *PL_tokenbuf = '\0';
3693 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3694 if (isIDFIRST(*PL_tokenbuf))
3695 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
3697 yyerror("<> should be quotes");
3704 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3708 LOP(OP_RENAME,XTERM);
3717 LOP(OP_RINDEX,XTERM);
3740 LOP(OP_REVERSE,XTERM);
3751 TERM(sublex_start());
3753 TOKEN(1); /* force error */
3762 LOP(OP_SELECT,XTERM);
3768 LOP(OP_SEMCTL,XTERM);
3771 LOP(OP_SEMGET,XTERM);
3774 LOP(OP_SEMOP,XTERM);
3780 LOP(OP_SETPGRP,XTERM);
3782 case KEY_setpriority:
3783 LOP(OP_SETPRIORITY,XTERM);
3785 case KEY_sethostent:
3791 case KEY_setservent:
3794 case KEY_setprotoent:
3804 LOP(OP_SEEKDIR,XTERM);
3806 case KEY_setsockopt:
3807 LOP(OP_SSOCKOPT,XTERM);
3813 LOP(OP_SHMCTL,XTERM);
3816 LOP(OP_SHMGET,XTERM);
3819 LOP(OP_SHMREAD,XTERM);
3822 LOP(OP_SHMWRITE,XTERM);
3825 LOP(OP_SHUTDOWN,XTERM);
3834 LOP(OP_SOCKET,XTERM);
3836 case KEY_socketpair:
3837 LOP(OP_SOCKPAIR,XTERM);
3840 checkcomma(s,PL_tokenbuf,"subroutine name");
3842 if (*s == ';' || *s == ')') /* probably a close */
3843 croak("sort is now a reserved word");
3845 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3849 LOP(OP_SPLIT,XTERM);
3852 LOP(OP_SPRINTF,XTERM);
3855 LOP(OP_SPLICE,XTERM);
3871 LOP(OP_SUBSTR,XTERM);
3878 if (isIDFIRST(*s) || *s == '\'' || *s == ':') {
3879 char tmpbuf[sizeof PL_tokenbuf];
3881 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3882 if (strchr(tmpbuf, ':'))
3883 sv_setpv(PL_subname, tmpbuf);
3885 sv_setsv(PL_subname,PL_curstname);
3886 sv_catpvn(PL_subname,"::",2);
3887 sv_catpvn(PL_subname,tmpbuf,len);
3889 s = force_word(s,WORD,FALSE,TRUE,TRUE);
3893 PL_expect = XTERMBLOCK;
3894 sv_setpv(PL_subname,"?");
3897 if (tmp == KEY_format) {
3900 PL_lex_formbrack = PL_lex_brackets + 1;
3904 /* Look for a prototype */
3911 SvREFCNT_dec(PL_lex_stuff);
3912 PL_lex_stuff = Nullsv;
3913 croak("Prototype not terminated");
3916 d = SvPVX(PL_lex_stuff);
3918 for (p = d; *p; ++p) {
3923 SvCUR(PL_lex_stuff) = tmp;
3926 PL_nextval[1] = PL_nextval[0];
3927 PL_nexttype[1] = PL_nexttype[0];
3928 PL_nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
3929 PL_nexttype[0] = THING;
3930 if (PL_nexttoke == 1) {
3931 PL_lex_defer = PL_lex_state;
3932 PL_lex_expect = PL_expect;
3933 PL_lex_state = LEX_KNOWNEXT;
3935 PL_lex_stuff = Nullsv;
3938 if (*SvPV(PL_subname,PL_na) == '?') {
3939 sv_setpv(PL_subname,"__ANON__");
3946 LOP(OP_SYSTEM,XREF);
3949 LOP(OP_SYMLINK,XTERM);
3952 LOP(OP_SYSCALL,XTERM);
3955 LOP(OP_SYSOPEN,XTERM);
3958 LOP(OP_SYSSEEK,XTERM);
3961 LOP(OP_SYSREAD,XTERM);
3964 LOP(OP_SYSWRITE,XTERM);
3968 TERM(sublex_start());
3989 LOP(OP_TRUNCATE,XTERM);
4001 yylval.ival = PL_curcop->cop_line;
4005 yylval.ival = PL_curcop->cop_line;
4009 LOP(OP_UNLINK,XTERM);
4015 LOP(OP_UNPACK,XTERM);
4018 LOP(OP_UTIME,XTERM);
4022 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4023 if (*d != '0' && isDIGIT(*d))
4024 yywarn("umask: argument is missing initial 0");
4029 LOP(OP_UNSHIFT,XTERM);
4032 if (PL_expect != XSTATE)
4033 yyerror("\"use\" not allowed in expression");
4036 s = force_version(s);
4037 if(*s == ';' || (s = skipspace(s), *s == ';')) {
4038 PL_nextval[PL_nexttoke].opval = Nullop;
4043 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4044 s = force_version(s);
4057 yylval.ival = PL_curcop->cop_line;
4061 PL_hints |= HINT_BLOCK_SCOPE;
4068 LOP(OP_WAITPID,XTERM);
4076 static char ctl_l[2];
4078 if (ctl_l[0] == '\0')
4079 ctl_l[0] = toCTRL('L');
4080 gv_fetchpv(ctl_l,TRUE, SVt_PV);
4083 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
4088 if (PL_expect == XOPERATOR)
4094 yylval.ival = OP_XOR;
4099 TERM(sublex_start());
4105 keyword(register char *d, I32 len)
4110 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
4111 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
4112 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
4113 if (strEQ(d,"__DATA__")) return KEY___DATA__;
4114 if (strEQ(d,"__END__")) return KEY___END__;
4118 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
4123 if (strEQ(d,"and")) return -KEY_and;
4124 if (strEQ(d,"abs")) return -KEY_abs;
4127 if (strEQ(d,"alarm")) return -KEY_alarm;
4128 if (strEQ(d,"atan2")) return -KEY_atan2;
4131 if (strEQ(d,"accept")) return -KEY_accept;
4136 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
4139 if (strEQ(d,"bless")) return -KEY_bless;
4140 if (strEQ(d,"bind")) return -KEY_bind;
4141 if (strEQ(d,"binmode")) return -KEY_binmode;
4144 if (strEQ(d,"CORE")) return -KEY_CORE;
4149 if (strEQ(d,"cmp")) return -KEY_cmp;
4150 if (strEQ(d,"chr")) return -KEY_chr;
4151 if (strEQ(d,"cos")) return -KEY_cos;
4154 if (strEQ(d,"chop")) return KEY_chop;
4157 if (strEQ(d,"close")) return -KEY_close;
4158 if (strEQ(d,"chdir")) return -KEY_chdir;
4159 if (strEQ(d,"chomp")) return KEY_chomp;
4160 if (strEQ(d,"chmod")) return -KEY_chmod;
4161 if (strEQ(d,"chown")) return -KEY_chown;
4162 if (strEQ(d,"crypt")) return -KEY_crypt;
4165 if (strEQ(d,"chroot")) return -KEY_chroot;
4166 if (strEQ(d,"caller")) return -KEY_caller;
4169 if (strEQ(d,"connect")) return -KEY_connect;
4172 if (strEQ(d,"closedir")) return -KEY_closedir;
4173 if (strEQ(d,"continue")) return -KEY_continue;
4178 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
4183 if (strEQ(d,"do")) return KEY_do;
4186 if (strEQ(d,"die")) return -KEY_die;
4189 if (strEQ(d,"dump")) return -KEY_dump;
4192 if (strEQ(d,"delete")) return KEY_delete;
4195 if (strEQ(d,"defined")) return KEY_defined;
4196 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
4199 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
4204 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
4205 if (strEQ(d,"END")) return KEY_END;
4210 if (strEQ(d,"eq")) return -KEY_eq;
4213 if (strEQ(d,"eof")) return -KEY_eof;
4214 if (strEQ(d,"exp")) return -KEY_exp;
4217 if (strEQ(d,"else")) return KEY_else;
4218 if (strEQ(d,"exit")) return -KEY_exit;
4219 if (strEQ(d,"eval")) return KEY_eval;
4220 if (strEQ(d,"exec")) return -KEY_exec;
4221 if (strEQ(d,"each")) return KEY_each;
4224 if (strEQ(d,"elsif")) return KEY_elsif;
4227 if (strEQ(d,"exists")) return KEY_exists;
4228 if (strEQ(d,"elseif")) warn("elseif should be elsif");
4231 if (strEQ(d,"endgrent")) return -KEY_endgrent;
4232 if (strEQ(d,"endpwent")) return -KEY_endpwent;
4235 if (strEQ(d,"endnetent")) return -KEY_endnetent;
4238 if (strEQ(d,"endhostent")) return -KEY_endhostent;
4239 if (strEQ(d,"endservent")) return -KEY_endservent;
4242 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
4249 if (strEQ(d,"for")) return KEY_for;
4252 if (strEQ(d,"fork")) return -KEY_fork;
4255 if (strEQ(d,"fcntl")) return -KEY_fcntl;
4256 if (strEQ(d,"flock")) return -KEY_flock;
4259 if (strEQ(d,"format")) return KEY_format;
4260 if (strEQ(d,"fileno")) return -KEY_fileno;
4263 if (strEQ(d,"foreach")) return KEY_foreach;
4266 if (strEQ(d,"formline")) return -KEY_formline;
4272 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
4273 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
4277 if (strnEQ(d,"get",3)) {
4282 if (strEQ(d,"ppid")) return -KEY_getppid;
4283 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
4286 if (strEQ(d,"pwent")) return -KEY_getpwent;
4287 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
4288 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
4291 if (strEQ(d,"peername")) return -KEY_getpeername;
4292 if (strEQ(d,"protoent")) return -KEY_getprotoent;
4293 if (strEQ(d,"priority")) return -KEY_getpriority;
4296 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
4299 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
4303 else if (*d == 'h') {
4304 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
4305 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
4306 if (strEQ(d,"hostent")) return -KEY_gethostent;
4308 else if (*d == 'n') {
4309 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
4310 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
4311 if (strEQ(d,"netent")) return -KEY_getnetent;
4313 else if (*d == 's') {
4314 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
4315 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
4316 if (strEQ(d,"servent")) return -KEY_getservent;
4317 if (strEQ(d,"sockname")) return -KEY_getsockname;
4318 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
4320 else if (*d == 'g') {
4321 if (strEQ(d,"grent")) return -KEY_getgrent;
4322 if (strEQ(d,"grnam")) return -KEY_getgrnam;
4323 if (strEQ(d,"grgid")) return -KEY_getgrgid;
4325 else if (*d == 'l') {
4326 if (strEQ(d,"login")) return -KEY_getlogin;
4328 else if (strEQ(d,"c")) return -KEY_getc;
4333 if (strEQ(d,"gt")) return -KEY_gt;
4334 if (strEQ(d,"ge")) return -KEY_ge;
4337 if (strEQ(d,"grep")) return KEY_grep;
4338 if (strEQ(d,"goto")) return KEY_goto;
4339 if (strEQ(d,"glob")) return KEY_glob;
4342 if (strEQ(d,"gmtime")) return -KEY_gmtime;
4347 if (strEQ(d,"hex")) return -KEY_hex;
4350 if (strEQ(d,"INIT")) return KEY_INIT;
4355 if (strEQ(d,"if")) return KEY_if;
4358 if (strEQ(d,"int")) return -KEY_int;
4361 if (strEQ(d,"index")) return -KEY_index;
4362 if (strEQ(d,"ioctl")) return -KEY_ioctl;
4367 if (strEQ(d,"join")) return -KEY_join;
4371 if (strEQ(d,"keys")) return KEY_keys;
4372 if (strEQ(d,"kill")) return -KEY_kill;
4377 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
4378 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
4384 if (strEQ(d,"lt")) return -KEY_lt;
4385 if (strEQ(d,"le")) return -KEY_le;
4386 if (strEQ(d,"lc")) return -KEY_lc;
4389 if (strEQ(d,"log")) return -KEY_log;
4392 if (strEQ(d,"last")) return KEY_last;
4393 if (strEQ(d,"link")) return -KEY_link;
4394 if (strEQ(d,"lock")) return -KEY_lock;
4397 if (strEQ(d,"local")) return KEY_local;
4398 if (strEQ(d,"lstat")) return -KEY_lstat;
4401 if (strEQ(d,"length")) return -KEY_length;
4402 if (strEQ(d,"listen")) return -KEY_listen;
4405 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
4408 if (strEQ(d,"localtime")) return -KEY_localtime;
4414 case 1: return KEY_m;
4416 if (strEQ(d,"my")) return KEY_my;
4419 if (strEQ(d,"map")) return KEY_map;
4422 if (strEQ(d,"mkdir")) return -KEY_mkdir;
4425 if (strEQ(d,"msgctl")) return -KEY_msgctl;
4426 if (strEQ(d,"msgget")) return -KEY_msgget;
4427 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
4428 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
4433 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
4436 if (strEQ(d,"next")) return KEY_next;
4437 if (strEQ(d,"ne")) return -KEY_ne;
4438 if (strEQ(d,"not")) return -KEY_not;
4439 if (strEQ(d,"no")) return KEY_no;
4444 if (strEQ(d,"or")) return -KEY_or;
4447 if (strEQ(d,"ord")) return -KEY_ord;
4448 if (strEQ(d,"oct")) return -KEY_oct;
4449 if (strEQ(d,"our")) { deprecate("reserved word \"our\"");
4453 if (strEQ(d,"open")) return -KEY_open;
4456 if (strEQ(d,"opendir")) return -KEY_opendir;
4463 if (strEQ(d,"pop")) return KEY_pop;
4464 if (strEQ(d,"pos")) return KEY_pos;
4467 if (strEQ(d,"push")) return KEY_push;
4468 if (strEQ(d,"pack")) return -KEY_pack;
4469 if (strEQ(d,"pipe")) return -KEY_pipe;
4472 if (strEQ(d,"print")) return KEY_print;
4475 if (strEQ(d,"printf")) return KEY_printf;
4478 if (strEQ(d,"package")) return KEY_package;
4481 if (strEQ(d,"prototype")) return KEY_prototype;
4486 if (strEQ(d,"q")) return KEY_q;
4487 if (strEQ(d,"qr")) return KEY_qr;
4488 if (strEQ(d,"qq")) return KEY_qq;
4489 if (strEQ(d,"qw")) return KEY_qw;
4490 if (strEQ(d,"qx")) return KEY_qx;
4492 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
4497 if (strEQ(d,"ref")) return -KEY_ref;
4500 if (strEQ(d,"read")) return -KEY_read;
4501 if (strEQ(d,"rand")) return -KEY_rand;
4502 if (strEQ(d,"recv")) return -KEY_recv;
4503 if (strEQ(d,"redo")) return KEY_redo;
4506 if (strEQ(d,"rmdir")) return -KEY_rmdir;
4507 if (strEQ(d,"reset")) return -KEY_reset;
4510 if (strEQ(d,"return")) return KEY_return;
4511 if (strEQ(d,"rename")) return -KEY_rename;
4512 if (strEQ(d,"rindex")) return -KEY_rindex;
4515 if (strEQ(d,"require")) return -KEY_require;
4516 if (strEQ(d,"reverse")) return -KEY_reverse;
4517 if (strEQ(d,"readdir")) return -KEY_readdir;
4520 if (strEQ(d,"readlink")) return -KEY_readlink;
4521 if (strEQ(d,"readline")) return -KEY_readline;
4522 if (strEQ(d,"readpipe")) return -KEY_readpipe;
4525 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
4531 case 0: return KEY_s;
4533 if (strEQ(d,"scalar")) return KEY_scalar;
4538 if (strEQ(d,"seek")) return -KEY_seek;
4539 if (strEQ(d,"send")) return -KEY_send;
4542 if (strEQ(d,"semop")) return -KEY_semop;
4545 if (strEQ(d,"select")) return -KEY_select;
4546 if (strEQ(d,"semctl")) return -KEY_semctl;
4547 if (strEQ(d,"semget")) return -KEY_semget;
4550 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
4551 if (strEQ(d,"seekdir")) return -KEY_seekdir;
4554 if (strEQ(d,"setpwent")) return -KEY_setpwent;
4555 if (strEQ(d,"setgrent")) return -KEY_setgrent;
4558 if (strEQ(d,"setnetent")) return -KEY_setnetent;
4561 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
4562 if (strEQ(d,"sethostent")) return -KEY_sethostent;
4563 if (strEQ(d,"setservent")) return -KEY_setservent;
4566 if (strEQ(d,"setpriority")) return -KEY_setpriority;
4567 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
4574 if (strEQ(d,"shift")) return KEY_shift;
4577 if (strEQ(d,"shmctl")) return -KEY_shmctl;
4578 if (strEQ(d,"shmget")) return -KEY_shmget;
4581 if (strEQ(d,"shmread")) return -KEY_shmread;
4584 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
4585 if (strEQ(d,"shutdown")) return -KEY_shutdown;
4590 if (strEQ(d,"sin")) return -KEY_sin;
4593 if (strEQ(d,"sleep")) return -KEY_sleep;
4596 if (strEQ(d,"sort")) return KEY_sort;
4597 if (strEQ(d,"socket")) return -KEY_socket;
4598 if (strEQ(d,"socketpair")) return -KEY_socketpair;
4601 if (strEQ(d,"split")) return KEY_split;
4602 if (strEQ(d,"sprintf")) return -KEY_sprintf;
4603 if (strEQ(d,"splice")) return KEY_splice;
4606 if (strEQ(d,"sqrt")) return -KEY_sqrt;
4609 if (strEQ(d,"srand")) return -KEY_srand;
4612 if (strEQ(d,"stat")) return -KEY_stat;
4613 if (strEQ(d,"study")) return KEY_study;
4616 if (strEQ(d,"substr")) return -KEY_substr;
4617 if (strEQ(d,"sub")) return KEY_sub;
4622 if (strEQ(d,"system")) return -KEY_system;
4625 if (strEQ(d,"symlink")) return -KEY_symlink;
4626 if (strEQ(d,"syscall")) return -KEY_syscall;
4627 if (strEQ(d,"sysopen")) return -KEY_sysopen;
4628 if (strEQ(d,"sysread")) return -KEY_sysread;
4629 if (strEQ(d,"sysseek")) return -KEY_sysseek;
4632 if (strEQ(d,"syswrite")) return -KEY_syswrite;
4641 if (strEQ(d,"tr")) return KEY_tr;
4644 if (strEQ(d,"tie")) return KEY_tie;
4647 if (strEQ(d,"tell")) return -KEY_tell;
4648 if (strEQ(d,"tied")) return KEY_tied;
4649 if (strEQ(d,"time")) return -KEY_time;
4652 if (strEQ(d,"times")) return -KEY_times;
4655 if (strEQ(d,"telldir")) return -KEY_telldir;
4658 if (strEQ(d,"truncate")) return -KEY_truncate;
4665 if (strEQ(d,"uc")) return -KEY_uc;
4668 if (strEQ(d,"use")) return KEY_use;
4671 if (strEQ(d,"undef")) return KEY_undef;
4672 if (strEQ(d,"until")) return KEY_until;
4673 if (strEQ(d,"untie")) return KEY_untie;
4674 if (strEQ(d,"utime")) return -KEY_utime;
4675 if (strEQ(d,"umask")) return -KEY_umask;
4678 if (strEQ(d,"unless")) return KEY_unless;
4679 if (strEQ(d,"unpack")) return -KEY_unpack;
4680 if (strEQ(d,"unlink")) return -KEY_unlink;
4683 if (strEQ(d,"unshift")) return KEY_unshift;
4684 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
4689 if (strEQ(d,"values")) return -KEY_values;
4690 if (strEQ(d,"vec")) return -KEY_vec;
4695 if (strEQ(d,"warn")) return -KEY_warn;
4696 if (strEQ(d,"wait")) return -KEY_wait;
4699 if (strEQ(d,"while")) return KEY_while;
4700 if (strEQ(d,"write")) return -KEY_write;
4703 if (strEQ(d,"waitpid")) return -KEY_waitpid;
4706 if (strEQ(d,"wantarray")) return -KEY_wantarray;
4711 if (len == 1) return -KEY_x;
4712 if (strEQ(d,"xor")) return -KEY_xor;
4715 if (len == 1) return KEY_y;
4724 checkcomma(register char *s, char *name, char *what)
4728 if (PL_dowarn && *s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
4730 for (w = s+2; *w && level; w++) {
4737 for (; *w && isSPACE(*w); w++) ;
4738 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
4739 warn("%s (...) interpreted as function",name);
4741 while (s < PL_bufend && isSPACE(*s))
4745 while (s < PL_bufend && isSPACE(*s))
4747 if (isIDFIRST(*s)) {
4751 while (s < PL_bufend && isSPACE(*s))
4756 kw = keyword(w, s - w) || perl_get_cv(w, FALSE) != 0;
4760 croak("No comma allowed after %s", what);
4766 new_constant(char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)
4769 HV *table = GvHV(PL_hintgv); /* ^H */
4772 bool oldcatch = CATCH_GET;
4778 yyerror("%^H is not defined");
4781 cvp = hv_fetch(table, key, strlen(key), FALSE);
4782 if (!cvp || !SvOK(*cvp)) {
4783 sprintf(buf,"$^H{%s} is not defined", key);
4787 sv_2mortal(sv); /* Parent created it permanently */
4790 pv = sv_2mortal(newSVpv(s, len));
4792 typesv = sv_2mortal(newSVpv(type, 0));
4794 typesv = &PL_sv_undef;
4796 Zero(&myop, 1, BINOP);
4797 myop.op_last = (OP *) &myop;
4798 myop.op_next = Nullop;
4799 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
4801 PUSHSTACKi(PERLSI_OVERLOAD);
4804 PL_op = (OP *) &myop;
4805 if (PERLDB_SUB && PL_curstash != PL_debstash)
4806 PL_op->op_private |= OPpENTERSUB_DB;
4817 if (PL_op = pp_entersub(ARGS))
4824 CATCH_SET(oldcatch);
4828 sprintf(buf,"Call to &{$^H{%s}} did not return a defined value", key);
4831 return SvREFCNT_inc(res);
4835 scan_word(register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
4837 register char *d = dest;
4838 register char *e = d + destlen - 3; /* two-character token, ending NUL */
4841 croak(ident_too_long);
4844 else if (*s == '\'' && allow_package && isIDFIRST(s[1])) {
4849 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
4862 scan_ident(register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
4869 if (PL_lex_brackets == 0)
4870 PL_lex_fakebrack = 0;
4874 e = d + destlen - 3; /* two-character token, ending NUL */
4876 while (isDIGIT(*s)) {
4878 croak(ident_too_long);
4885 croak(ident_too_long);
4888 else if (*s == '\'' && isIDFIRST(s[1])) {
4893 else if (*s == ':' && s[1] == ':') {
4904 if (PL_lex_state != LEX_NORMAL)
4905 PL_lex_state = LEX_INTERPENDMAYBE;
4908 if (*s == '$' && s[1] &&
4909 (isALNUM(s[1]) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
4911 if (isDIGIT(s[1]) && PL_lex_state == LEX_INTERPNORMAL)
4912 deprecate("\"$$<digit>\" to mean \"${$}<digit>\"");
4925 if (*d == '^' && *s && (isUPPER(*s) || strchr("[\\]^_?", *s))) {
4930 if (isSPACE(s[-1])) {
4933 if (ch != ' ' && ch != '\t') {
4939 if (isIDFIRST(*d)) {
4941 while (isALNUM(*s) || *s == ':')
4944 while (s < send && (*s == ' ' || *s == '\t')) s++;
4945 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
4946 if (PL_dowarn && keyword(dest, d - dest)) {
4947 char *brack = *s == '[' ? "[...]" : "{...}";
4948 warn("Ambiguous use of %c{%s%s} resolved to %c%s%s",
4949 funny, dest, brack, funny, dest, brack);
4951 PL_lex_fakebrack = PL_lex_brackets+1;
4953 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4959 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
4960 PL_lex_state = LEX_INTERPEND;
4963 if (PL_dowarn && PL_lex_state == LEX_NORMAL &&
4964 (keyword(dest, d - dest) || perl_get_cv(dest, FALSE)))
4965 warn("Ambiguous use of %c{%s} resolved to %c%s",
4966 funny, dest, funny, dest);
4969 s = bracket; /* let the parser handle it */
4973 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
4974 PL_lex_state = LEX_INTERPEND;
4978 void pmflag(U16 *pmfl, int ch)
4983 *pmfl |= PMf_GLOBAL;
4985 *pmfl |= PMf_CONTINUE;
4989 *pmfl |= PMf_MULTILINE;
4991 *pmfl |= PMf_SINGLELINE;
4993 *pmfl |= PMf_EXTENDED;
4997 scan_pat(char *start, I32 type)
5002 s = scan_str(start);
5005 SvREFCNT_dec(PL_lex_stuff);
5006 PL_lex_stuff = Nullsv;
5007 croak("Search pattern not terminated");
5010 pm = (PMOP*)newPMOP(type, 0);
5011 if (PL_multi_open == '?')
5012 pm->op_pmflags |= PMf_ONCE;
5014 while (*s && strchr("iomsx", *s))
5015 pmflag(&pm->op_pmflags,*s++);
5018 while (*s && strchr("iogcmsx", *s))
5019 pmflag(&pm->op_pmflags,*s++);
5021 pm->op_pmpermflags = pm->op_pmflags;
5023 PL_lex_op = (OP*)pm;
5024 yylval.ival = OP_MATCH;
5029 scan_subst(char *start)
5036 yylval.ival = OP_NULL;
5038 s = scan_str(start);
5042 SvREFCNT_dec(PL_lex_stuff);
5043 PL_lex_stuff = Nullsv;
5044 croak("Substitution pattern not terminated");
5047 if (s[-1] == PL_multi_open)
5050 first_start = PL_multi_start;
5054 SvREFCNT_dec(PL_lex_stuff);
5055 PL_lex_stuff = Nullsv;
5057 SvREFCNT_dec(PL_lex_repl);
5058 PL_lex_repl = Nullsv;
5059 croak("Substitution replacement not terminated");
5061 PL_multi_start = first_start; /* so whole substitution is taken together */
5063 pm = (PMOP*)newPMOP(OP_SUBST, 0);
5069 else if (strchr("iogcmsx", *s))
5070 pmflag(&pm->op_pmflags,*s++);
5077 pm->op_pmflags |= PMf_EVAL;
5078 repl = newSVpv("",0);
5080 sv_catpv(repl, es ? "eval " : "do ");
5081 sv_catpvn(repl, "{ ", 2);
5082 sv_catsv(repl, PL_lex_repl);
5083 sv_catpvn(repl, " };", 2);
5084 SvCOMPILED_on(repl);
5085 SvREFCNT_dec(PL_lex_repl);
5089 pm->op_pmpermflags = pm->op_pmflags;
5090 PL_lex_op = (OP*)pm;
5091 yylval.ival = OP_SUBST;
5096 scan_trans(char *start)
5105 yylval.ival = OP_NULL;
5107 s = scan_str(start);
5110 SvREFCNT_dec(PL_lex_stuff);
5111 PL_lex_stuff = Nullsv;
5112 croak("Transliteration pattern not terminated");
5114 if (s[-1] == PL_multi_open)
5120 SvREFCNT_dec(PL_lex_stuff);
5121 PL_lex_stuff = Nullsv;
5123 SvREFCNT_dec(PL_lex_repl);
5124 PL_lex_repl = Nullsv;
5125 croak("Transliteration replacement not terminated");
5128 New(803,tbl,256,short);
5129 o = newPVOP(OP_TRANS, 0, (char*)tbl);
5131 complement = Delete = squash = 0;
5132 while (*s == 'c' || *s == 'd' || *s == 's') {
5134 complement = OPpTRANS_COMPLEMENT;
5136 Delete = OPpTRANS_DELETE;
5138 squash = OPpTRANS_SQUASH;
5141 o->op_private = Delete|squash|complement;
5144 yylval.ival = OP_TRANS;
5149 scan_heredoc(register char *s)
5153 I32 op_type = OP_SCALAR;
5160 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
5164 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
5167 for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5168 if (*peek && strchr("`'\"",*peek)) {
5171 s = delimcpy(d, e, s, PL_bufend, term, &len);
5182 deprecate("bare << to mean <<\"\"");
5183 for (; isALNUM(*s); s++) {
5188 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
5189 croak("Delimiter for here document is too long");
5192 len = d - PL_tokenbuf;
5193 #ifndef PERL_STRICT_CR
5194 d = strchr(s, '\r');
5198 while (s < PL_bufend) {
5204 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
5213 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5218 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
5219 herewas = newSVpv(s,PL_bufend-s);
5221 s--, herewas = newSVpv(s,d-s);
5222 s += SvCUR(herewas);
5224 tmpstr = NEWSV(87,79);
5225 sv_upgrade(tmpstr, SVt_PVIV);
5230 else if (term == '`') {
5231 op_type = OP_BACKTICK;
5232 SvIVX(tmpstr) = '\\';
5236 PL_multi_start = PL_curcop->cop_line;
5237 PL_multi_open = PL_multi_close = '<';
5238 term = *PL_tokenbuf;
5241 while (s < PL_bufend &&
5242 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
5244 PL_curcop->cop_line++;
5246 if (s >= PL_bufend) {
5247 PL_curcop->cop_line = PL_multi_start;
5248 missingterm(PL_tokenbuf);
5250 sv_setpvn(tmpstr,d+1,s-d);
5252 PL_curcop->cop_line++; /* the preceding stmt passes a newline */
5254 sv_catpvn(herewas,s,PL_bufend-s);
5255 sv_setsv(PL_linestr,herewas);
5256 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
5257 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5260 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
5261 while (s >= PL_bufend) { /* multiple line string? */
5263 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5264 PL_curcop->cop_line = PL_multi_start;
5265 missingterm(PL_tokenbuf);
5267 PL_curcop->cop_line++;
5268 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5269 #ifndef PERL_STRICT_CR
5270 if (PL_bufend - PL_linestart >= 2) {
5271 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
5272 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
5274 PL_bufend[-2] = '\n';
5276 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5278 else if (PL_bufend[-1] == '\r')
5279 PL_bufend[-1] = '\n';
5281 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
5282 PL_bufend[-1] = '\n';
5284 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5285 SV *sv = NEWSV(88,0);
5287 sv_upgrade(sv, SVt_PVMG);
5288 sv_setsv(sv,PL_linestr);
5289 av_store(GvAV(PL_curcop->cop_filegv),
5290 (I32)PL_curcop->cop_line,sv);
5292 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
5295 sv_catsv(PL_linestr,herewas);
5296 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5300 sv_catsv(tmpstr,PL_linestr);
5303 PL_multi_end = PL_curcop->cop_line;
5305 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
5306 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
5307 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
5309 SvREFCNT_dec(herewas);
5310 PL_lex_stuff = tmpstr;
5311 yylval.ival = op_type;
5316 takes: current position in input buffer
5317 returns: new position in input buffer
5318 side-effects: yylval and lex_op are set.
5323 <FH> read from filehandle
5324 <pkg::FH> read from package qualified filehandle
5325 <pkg'FH> read from package qualified filehandle
5326 <$fh> read from filehandle in $fh
5332 scan_inputsymbol(char *start)
5334 register char *s = start; /* current position in buffer */
5339 d = PL_tokenbuf; /* start of temp holding space */
5340 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
5341 s = delimcpy(d, e, s + 1, PL_bufend, '>', &len); /* extract until > */
5343 /* die if we didn't have space for the contents of the <>,
5347 if (len >= sizeof PL_tokenbuf)
5348 croak("Excessively long <> operator");
5350 croak("Unterminated <> operator");
5355 Remember, only scalar variables are interpreted as filehandles by
5356 this code. Anything more complex (e.g., <$fh{$num}>) will be
5357 treated as a glob() call.
5358 This code makes use of the fact that except for the $ at the front,
5359 a scalar variable and a filehandle look the same.
5361 if (*d == '$' && d[1]) d++;
5363 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
5364 while (*d && (isALNUM(*d) || *d == '\'' || *d == ':'))
5367 /* If we've tried to read what we allow filehandles to look like, and
5368 there's still text left, then it must be a glob() and not a getline.
5369 Use scan_str to pull out the stuff between the <> and treat it
5370 as nothing more than a string.
5373 if (d - PL_tokenbuf != len) {
5374 yylval.ival = OP_GLOB;
5376 s = scan_str(start);
5378 croak("Glob not terminated");
5382 /* we're in a filehandle read situation */
5385 /* turn <> into <ARGV> */
5387 (void)strcpy(d,"ARGV");
5389 /* if <$fh>, create the ops to turn the variable into a
5395 /* try to find it in the pad for this block, otherwise find
5396 add symbol table ops
5398 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
5399 OP *o = newOP(OP_PADSV, 0);
5401 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newUNOP(OP_RV2GV, 0, o));
5404 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
5405 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
5406 newUNOP(OP_RV2GV, 0,
5407 newUNOP(OP_RV2SV, 0,
5408 newGVOP(OP_GV, 0, gv))));
5410 /* we created the ops in lex_op, so make yylval.ival a null op */
5411 yylval.ival = OP_NULL;
5414 /* If it's none of the above, it must be a literal filehandle
5415 (<Foo::BAR> or <FOO>) so build a simple readline OP */
5417 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
5418 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
5419 yylval.ival = OP_NULL;
5428 takes: start position in buffer
5429 returns: position to continue reading from buffer
5430 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
5431 updates the read buffer.
5433 This subroutine pulls a string out of the input. It is called for:
5434 q single quotes q(literal text)
5435 ' single quotes 'literal text'
5436 qq double quotes qq(interpolate $here please)
5437 " double quotes "interpolate $here please"
5438 qx backticks qx(/bin/ls -l)
5439 ` backticks `/bin/ls -l`
5440 qw quote words @EXPORT_OK = qw( func() $spam )
5441 m// regexp match m/this/
5442 s/// regexp substitute s/this/that/
5443 tr/// string transliterate tr/this/that/
5444 y/// string transliterate y/this/that/
5445 ($*@) sub prototypes sub foo ($)
5446 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
5448 In most of these cases (all but <>, patterns and transliterate)
5449 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
5450 calls scan_str(). s/// makes yylex() call scan_subst() which calls
5451 scan_str(). tr/// and y/// make yylex() call scan_trans() which
5454 It skips whitespace before the string starts, and treats the first
5455 character as the delimiter. If the delimiter is one of ([{< then
5456 the corresponding "close" character )]}> is used as the closing
5457 delimiter. It allows quoting of delimiters, and if the string has
5458 balanced delimiters ([{<>}]) it allows nesting.
5460 The lexer always reads these strings into lex_stuff, except in the
5461 case of the operators which take *two* arguments (s/// and tr///)
5462 when it checks to see if lex_stuff is full (presumably with the 1st
5463 arg to s or tr) and if so puts the string into lex_repl.
5468 scan_str(char *start)
5471 SV *sv; /* scalar value: string */
5472 char *tmps; /* temp string, used for delimiter matching */
5473 register char *s = start; /* current position in the buffer */
5474 register char term; /* terminating character */
5475 register char *to; /* current position in the sv's data */
5476 I32 brackets = 1; /* bracket nesting level */
5478 /* skip space before the delimiter */
5482 /* mark where we are, in case we need to report errors */
5485 /* after skipping whitespace, the next character is the terminator */
5487 /* mark where we are */
5488 PL_multi_start = PL_curcop->cop_line;
5489 PL_multi_open = term;
5491 /* find corresponding closing delimiter */
5492 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5494 PL_multi_close = term;
5496 /* create a new SV to hold the contents. 87 is leak category, I'm
5497 assuming. 79 is the SV's initial length. What a random number. */
5499 sv_upgrade(sv, SVt_PVIV);
5501 (void)SvPOK_only(sv); /* validate pointer */
5503 /* move past delimiter and try to read a complete string */
5506 /* extend sv if need be */
5507 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
5508 /* set 'to' to the next character in the sv's string */
5509 to = SvPVX(sv)+SvCUR(sv);
5511 /* if open delimiter is the close delimiter read unbridle */
5512 if (PL_multi_open == PL_multi_close) {
5513 for (; s < PL_bufend; s++,to++) {
5514 /* embedded newlines increment the current line number */
5515 if (*s == '\n' && !PL_rsfp)
5516 PL_curcop->cop_line++;
5517 /* handle quoted delimiters */
5518 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
5521 /* any other quotes are simply copied straight through */
5525 /* terminate when run out of buffer (the for() condition), or
5526 have found the terminator */
5527 else if (*s == term)
5533 /* if the terminator isn't the same as the start character (e.g.,
5534 matched brackets), we have to allow more in the quoting, and
5535 be prepared for nested brackets.
5538 /* read until we run out of string, or we find the terminator */
5539 for (; s < PL_bufend; s++,to++) {
5540 /* embedded newlines increment the line count */
5541 if (*s == '\n' && !PL_rsfp)
5542 PL_curcop->cop_line++;
5543 /* backslashes can escape the open or closing characters */
5544 if (*s == '\\' && s+1 < PL_bufend) {
5545 if ((s[1] == PL_multi_open) || (s[1] == PL_multi_close))
5550 /* allow nested opens and closes */
5551 else if (*s == PL_multi_close && --brackets <= 0)
5553 else if (*s == PL_multi_open)
5558 /* terminate the copied string and update the sv's end-of-string */
5560 SvCUR_set(sv, to - SvPVX(sv));
5563 * this next chunk reads more into the buffer if we're not done yet
5566 if (s < PL_bufend) break; /* handle case where we are done yet :-) */
5568 #ifndef PERL_STRICT_CR
5569 if (to - SvPVX(sv) >= 2) {
5570 if ((to[-2] == '\r' && to[-1] == '\n') ||
5571 (to[-2] == '\n' && to[-1] == '\r'))
5575 SvCUR_set(sv, to - SvPVX(sv));
5577 else if (to[-1] == '\r')
5580 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
5584 /* if we're out of file, or a read fails, bail and reset the current
5585 line marker so we can report where the unterminated string began
5588 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5590 PL_curcop->cop_line = PL_multi_start;
5593 /* we read a line, so increment our line counter */
5594 PL_curcop->cop_line++;
5596 /* update debugger info */
5597 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5598 SV *sv = NEWSV(88,0);
5600 sv_upgrade(sv, SVt_PVMG);
5601 sv_setsv(sv,PL_linestr);
5602 av_store(GvAV(PL_curcop->cop_filegv),
5603 (I32)PL_curcop->cop_line, sv);
5606 /* having changed the buffer, we must update PL_bufend */
5607 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5610 /* at this point, we have successfully read the delimited string */
5612 PL_multi_end = PL_curcop->cop_line;
5615 /* if we allocated too much space, give some back */
5616 if (SvCUR(sv) + 5 < SvLEN(sv)) {
5617 SvLEN_set(sv, SvCUR(sv) + 1);
5618 Renew(SvPVX(sv), SvLEN(sv), char);
5621 /* decide whether this is the first or second quoted string we've read
5634 takes: pointer to position in buffer
5635 returns: pointer to new position in buffer
5636 side-effects: builds ops for the constant in yylval.op
5638 Read a number in any of the formats that Perl accepts:
5640 0(x[0-7A-F]+)|([0-7]+)
5641 [\d_]+(\.[\d_]*)?[Ee](\d+)
5643 Underbars (_) are allowed in decimal numbers. If -w is on,
5644 underbars before a decimal point must be at three digit intervals.
5646 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
5649 If it reads a number without a decimal point or an exponent, it will
5650 try converting the number to an integer and see if it can do so
5651 without loss of precision.
5655 scan_num(char *start)
5657 register char *s = start; /* current position in buffer */
5658 register char *d; /* destination in temp buffer */
5659 register char *e; /* end of temp buffer */
5660 I32 tryiv; /* used to see if it can be an int */
5661 double value; /* number read, as a double */
5662 SV *sv; /* place to put the converted number */
5663 I32 floatit; /* boolean: int or float? */
5664 char *lastub = 0; /* position of last underbar */
5665 static char number_too_long[] = "Number too long";
5667 /* We use the first character to decide what type of number this is */
5671 croak("panic: scan_num");
5673 /* if it starts with a 0, it could be an octal number, a decimal in
5674 0.13 disguise, or a hexadecimal number.
5679 u holds the "number so far"
5680 shift the power of 2 of the base (hex == 4, octal == 3)
5681 overflowed was the number more than we can hold?
5683 Shift is used when we add a digit. It also serves as an "are
5684 we in octal or hex?" indicator to disallow hex characters when
5689 bool overflowed = FALSE;
5696 /* check for a decimal in disguise */
5697 else if (s[1] == '.')
5699 /* so it must be octal */
5704 /* read the rest of the octal number */
5706 UV n, b; /* n is used in the overflow test, b is the digit we're adding on */
5710 /* if we don't mention it, we're done */
5719 /* 8 and 9 are not octal */
5722 yyerror("Illegal octal digit");
5726 case '0': case '1': case '2': case '3': case '4':
5727 case '5': case '6': case '7':
5728 b = *s++ & 15; /* ASCII digit -> value of digit */
5732 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
5733 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
5734 /* make sure they said 0x */
5739 /* Prepare to put the digit we have onto the end
5740 of the number so far. We check for overflows.
5744 n = u << shift; /* make room for the digit */
5745 if (!overflowed && (n >> shift) != u
5746 && !(PL_hints & HINT_NEW_BINARY)) {
5747 warn("Integer overflow in %s number",
5748 (shift == 4) ? "hex" : "octal");
5751 u = n | b; /* add the digit to the end */
5756 /* if we get here, we had success: make a scalar value from
5762 if ( PL_hints & HINT_NEW_BINARY)
5763 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
5768 handle decimal numbers.
5769 we're also sent here when we read a 0 as the first digit
5771 case '1': case '2': case '3': case '4': case '5':
5772 case '6': case '7': case '8': case '9': case '.':
5775 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
5778 /* read next group of digits and _ and copy into d */
5779 while (isDIGIT(*s) || *s == '_') {
5780 /* skip underscores, checking for misplaced ones
5784 if (PL_dowarn && lastub && s - lastub != 3)
5785 warn("Misplaced _ in number");
5789 /* check for end of fixed-length buffer */
5791 croak(number_too_long);
5792 /* if we're ok, copy the character */
5797 /* final misplaced underbar check */
5798 if (PL_dowarn && lastub && s - lastub != 3)
5799 warn("Misplaced _ in number");
5801 /* read a decimal portion if there is one. avoid
5802 3..5 being interpreted as the number 3. followed
5805 if (*s == '.' && s[1] != '.') {
5809 /* copy, ignoring underbars, until we run out of
5810 digits. Note: no misplaced underbar checks!
5812 for (; isDIGIT(*s) || *s == '_'; s++) {
5813 /* fixed length buffer check */
5815 croak(number_too_long);
5821 /* read exponent part, if present */
5822 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
5826 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
5827 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
5829 /* allow positive or negative exponent */
5830 if (*s == '+' || *s == '-')
5833 /* read digits of exponent (no underbars :-) */
5834 while (isDIGIT(*s)) {
5836 croak(number_too_long);
5841 /* terminate the string */
5844 /* make an sv from the string */
5846 /* reset numeric locale in case we were earlier left in Swaziland */
5847 SET_NUMERIC_STANDARD();
5848 value = atof(PL_tokenbuf);
5851 See if we can make do with an integer value without loss of
5852 precision. We use I_V to cast to an int, because some
5853 compilers have issues. Then we try casting it back and see
5854 if it was the same. We only do this if we know we
5855 specifically read an integer.
5857 Note: if floatit is true, then we don't need to do the
5861 if (!floatit && (double)tryiv == value)
5862 sv_setiv(sv, tryiv);
5864 sv_setnv(sv, value);
5865 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) )
5866 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
5867 (floatit ? "float" : "integer"), sv, Nullsv, NULL);
5871 /* make the op for the constant and return */
5873 yylval.opval = newSVOP(OP_CONST, 0, sv);
5879 scan_formline(register char *s)
5884 SV *stuff = newSVpv("",0);
5885 bool needargs = FALSE;
5888 if (*s == '.' || *s == '}') {
5890 for (t = s+1; *t == ' ' || *t == '\t'; t++) ;
5894 if (PL_in_eval && !PL_rsfp) {
5895 eol = strchr(s,'\n');
5900 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5902 for (t = s; t < eol; t++) {
5903 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
5905 goto enough; /* ~~ must be first line in formline */
5907 if (*t == '@' || *t == '^')
5910 sv_catpvn(stuff, s, eol-s);
5914 s = filter_gets(PL_linestr, PL_rsfp, 0);
5915 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
5916 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
5919 yyerror("Format not terminated");
5929 PL_lex_state = LEX_NORMAL;
5930 PL_nextval[PL_nexttoke].ival = 0;
5934 PL_lex_state = LEX_FORMLINE;
5935 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
5937 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
5941 SvREFCNT_dec(stuff);
5942 PL_lex_formbrack = 0;
5953 PL_cshlen = strlen(PL_cshname);
5958 start_subparse(I32 is_format, U32 flags)
5961 I32 oldsavestack_ix = PL_savestack_ix;
5962 CV* outsidecv = PL_compcv;
5966 assert(SvTYPE(PL_compcv) == SVt_PVCV);
5968 save_I32(&PL_subline);
5969 save_item(PL_subname);
5971 SAVESPTR(PL_curpad);
5972 SAVESPTR(PL_comppad);
5973 SAVESPTR(PL_comppad_name);
5974 SAVESPTR(PL_compcv);
5975 SAVEI32(PL_comppad_name_fill);
5976 SAVEI32(PL_min_intro_pending);
5977 SAVEI32(PL_max_intro_pending);
5978 SAVEI32(PL_pad_reset_pending);
5980 PL_compcv = (CV*)NEWSV(1104,0);
5981 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
5982 CvFLAGS(PL_compcv) |= flags;
5984 PL_comppad = newAV();
5985 av_push(PL_comppad, Nullsv);
5986 PL_curpad = AvARRAY(PL_comppad);
5987 PL_comppad_name = newAV();
5988 PL_comppad_name_fill = 0;
5989 PL_min_intro_pending = 0;
5991 PL_subline = PL_curcop->cop_line;
5993 av_store(PL_comppad_name, 0, newSVpv("@_", 2));
5994 PL_curpad[0] = (SV*)newAV();
5995 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
5996 #endif /* USE_THREADS */
5998 comppadlist = newAV();
5999 AvREAL_off(comppadlist);
6000 av_store(comppadlist, 0, (SV*)PL_comppad_name);
6001 av_store(comppadlist, 1, (SV*)PL_comppad);
6003 CvPADLIST(PL_compcv) = comppadlist;
6004 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
6006 CvOWNER(PL_compcv) = 0;
6007 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
6008 MUTEX_INIT(CvMUTEXP(PL_compcv));
6009 #endif /* USE_THREADS */
6011 return oldsavestack_ix;
6030 char *context = NULL;
6034 if (!yychar || (yychar == ';' && !PL_rsfp))
6036 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
6037 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
6038 while (isSPACE(*PL_oldoldbufptr))
6040 context = PL_oldoldbufptr;
6041 contlen = PL_bufptr - PL_oldoldbufptr;
6043 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
6044 PL_oldbufptr != PL_bufptr) {
6045 while (isSPACE(*PL_oldbufptr))
6047 context = PL_oldbufptr;
6048 contlen = PL_bufptr - PL_oldbufptr;
6050 else if (yychar > 255)
6051 where = "next token ???";
6052 else if ((yychar & 127) == 127) {
6053 if (PL_lex_state == LEX_NORMAL ||
6054 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
6055 where = "at end of line";
6056 else if (PL_lex_inpat)
6057 where = "within pattern";
6059 where = "within string";
6062 SV *where_sv = sv_2mortal(newSVpv("next char ", 0));
6064 sv_catpvf(where_sv, "^%c", toCTRL(yychar));
6065 else if (isPRINT_LC(yychar))
6066 sv_catpvf(where_sv, "%c", yychar);
6068 sv_catpvf(where_sv, "\\%03o", yychar & 255);
6069 where = SvPVX(where_sv);
6071 msg = sv_2mortal(newSVpv(s, 0));
6072 sv_catpvf(msg, " at %_ line %ld, ",
6073 GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line);
6075 sv_catpvf(msg, "near \"%.*s\"\n", contlen, context);
6077 sv_catpvf(msg, "%s\n", where);
6078 if (PL_multi_start < PL_multi_end && (U32)(PL_curcop->cop_line - PL_multi_end) <= 1) {
6080 " (Might be a runaway multi-line %c%c string starting on line %ld)\n",
6081 (int)PL_multi_open,(int)PL_multi_close,(long)PL_multi_start);
6086 else if (PL_in_eval)
6087 sv_catsv(ERRSV, msg);
6089 PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
6090 if (++PL_error_count >= 10)
6091 croak("%_ has too many errors.\n", GvSV(PL_curcop->cop_filegv));
6093 PL_in_my_stash = Nullhv;