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 && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
2873 warn("Ambiguous call resolved as CORE::%s(), %s",
2874 GvENAME(hgv), "qualify as such or use &");
2881 default: /* not a keyword */
2884 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
2886 /* Get the rest if it looks like a package qualifier */
2888 if (*s == '\'' || *s == ':' && s[1] == ':') {
2890 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
2893 croak("Bad name after %s%s", PL_tokenbuf,
2894 *s == '\'' ? "'" : "::");
2898 if (PL_expect == XOPERATOR) {
2899 if (PL_bufptr == PL_linestart) {
2900 PL_curcop->cop_line--;
2902 PL_curcop->cop_line++;
2905 no_op("Bareword",s);
2908 /* Look for a subroutine with this name in current package,
2909 unless name is "Foo::", in which case Foo is a bearword
2910 (and a package name). */
2913 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
2915 if (PL_dowarn && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
2916 warn("Bareword \"%s\" refers to nonexistent package",
2919 PL_tokenbuf[len] = '\0';
2926 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
2929 /* if we saw a global override before, get the right name */
2932 sv = newSVpv("CORE::GLOBAL::",14);
2933 sv_catpv(sv,PL_tokenbuf);
2936 sv = newSVpv(PL_tokenbuf,0);
2938 /* Presume this is going to be a bareword of some sort. */
2941 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2942 yylval.opval->op_private = OPpCONST_BARE;
2944 /* And if "Foo::", then that's what it certainly is. */
2949 /* See if it's the indirect object for a list operator. */
2951 if (PL_oldoldbufptr &&
2952 PL_oldoldbufptr < PL_bufptr &&
2953 (PL_oldoldbufptr == PL_last_lop || PL_oldoldbufptr == PL_last_uni) &&
2954 /* NO SKIPSPACE BEFORE HERE! */
2956 || ((opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF
2957 || (PL_last_lop_op == OP_ENTERSUB
2959 && PL_last_proto[PL_last_proto[0] == ';' ? 1 : 0] == '*')) )
2961 bool immediate_paren = *s == '(';
2963 /* (Now we can afford to cross potential line boundary.) */
2966 /* Two barewords in a row may indicate method call. */
2968 if ((isALPHA(*s) || *s == '$') && (tmp=intuit_method(s,gv)))
2971 /* If not a declared subroutine, it's an indirect object. */
2972 /* (But it's an indir obj regardless for sort.) */
2974 if ((PL_last_lop_op == OP_SORT ||
2975 (!immediate_paren && (!gv || !GvCVu(gv))) ) &&
2976 (PL_last_lop_op != OP_MAPSTART && PL_last_lop_op != OP_GREPSTART)){
2977 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
2982 /* If followed by a paren, it's certainly a subroutine. */
2984 PL_expect = XOPERATOR;
2988 if (gv && GvCVu(gv)) {
2989 for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
2990 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
2995 PL_nextval[PL_nexttoke].opval = yylval.opval;
2996 PL_expect = XOPERATOR;
3002 /* If followed by var or block, call it a method (unless sub) */
3004 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3005 PL_last_lop = PL_oldbufptr;
3006 PL_last_lop_op = OP_METHOD;
3010 /* If followed by a bareword, see if it looks like indir obj. */
3012 if ((isALPHA(*s) || *s == '$') && (tmp = intuit_method(s,gv)))
3015 /* Not a method, so call it a subroutine (if defined) */
3017 if (gv && GvCVu(gv)) {
3019 if (lastchar == '-')
3020 warn("Ambiguous use of -%s resolved as -&%s()",
3021 PL_tokenbuf, PL_tokenbuf);
3022 PL_last_lop = PL_oldbufptr;
3023 PL_last_lop_op = OP_ENTERSUB;
3024 /* Check for a constant sub */
3026 if ((sv = cv_const_sv(cv))) {
3028 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3029 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3030 yylval.opval->op_private = 0;
3034 /* Resolve to GV now. */
3035 op_free(yylval.opval);
3036 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3037 /* Is there a prototype? */
3040 PL_last_proto = SvPV((SV*)cv, len);
3043 if (strEQ(PL_last_proto, "$"))
3045 if (*PL_last_proto == '&' && *s == '{') {
3046 sv_setpv(PL_subname,"__ANON__");
3050 PL_last_proto = NULL;
3051 PL_nextval[PL_nexttoke].opval = yylval.opval;
3057 if (PL_hints & HINT_STRICT_SUBS &&
3060 PL_last_lop_op != OP_TRUNCATE && /* S/F prototype in opcode.pl */
3061 PL_last_lop_op != OP_ACCEPT &&
3062 PL_last_lop_op != OP_PIPE_OP &&
3063 PL_last_lop_op != OP_SOCKPAIR)
3066 "Bareword \"%s\" not allowed while \"strict subs\" in use",
3071 /* Call it a bare word */
3075 if (lastchar != '-') {
3076 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3078 warn(warn_reserved, PL_tokenbuf);
3083 if (lastchar && strchr("*%&", lastchar)) {
3084 warn("Operator or semicolon missing before %c%s",
3085 lastchar, PL_tokenbuf);
3086 warn("Ambiguous use of %c resolved as operator %c",
3087 lastchar, lastchar);
3093 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3094 newSVsv(GvSV(PL_curcop->cop_filegv)));
3098 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3099 newSVpvf("%ld", (long)PL_curcop->cop_line));
3102 case KEY___PACKAGE__:
3103 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3105 ? newSVsv(PL_curstname)
3114 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3115 char *pname = "main";
3116 if (PL_tokenbuf[2] == 'D')
3117 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3118 gv = gv_fetchpv(form("%s::DATA", pname), TRUE, SVt_PVIO);
3121 GvIOp(gv) = newIO();
3122 IoIFP(GvIOp(gv)) = PL_rsfp;
3123 #if defined(HAS_FCNTL) && defined(F_SETFD)
3125 int fd = PerlIO_fileno(PL_rsfp);
3126 fcntl(fd,F_SETFD,fd >= 3);
3129 /* Mark this internal pseudo-handle as clean */
3130 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3132 IoTYPE(GvIOp(gv)) = '|';
3133 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
3134 IoTYPE(GvIOp(gv)) = '-';
3136 IoTYPE(GvIOp(gv)) = '<';
3147 if (PL_expect == XSTATE) {
3154 if (*s == ':' && s[1] == ':') {
3157 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3158 tmp = keyword(PL_tokenbuf, len);
3172 LOP(OP_ACCEPT,XTERM);
3178 LOP(OP_ATAN2,XTERM);
3187 LOP(OP_BLESS,XTERM);
3196 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
3213 if (!PL_cryptseen++)
3216 LOP(OP_CRYPT,XTERM);
3220 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
3221 if (*d != '0' && isDIGIT(*d))
3222 yywarn("chmod: mode argument is missing initial 0");
3224 LOP(OP_CHMOD,XTERM);
3227 LOP(OP_CHOWN,XTERM);
3230 LOP(OP_CONNECT,XTERM);
3246 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3250 PL_hints |= HINT_BLOCK_SCOPE;
3260 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3261 LOP(OP_DBMOPEN,XTERM);
3267 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3274 yylval.ival = PL_curcop->cop_line;
3288 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
3289 UNIBRACK(OP_ENTEREVAL);
3304 case KEY_endhostent:
3310 case KEY_endservent:
3313 case KEY_endprotoent:
3324 yylval.ival = PL_curcop->cop_line;
3326 if (PL_expect == XSTATE && isIDFIRST(*s)) {
3328 if ((PL_bufend - p) >= 3 &&
3329 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3333 croak("Missing $ on loop variable");
3338 LOP(OP_FORMLINE,XTERM);
3344 LOP(OP_FCNTL,XTERM);
3350 LOP(OP_FLOCK,XTERM);
3359 LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
3362 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3377 case KEY_getpriority:
3378 LOP(OP_GETPRIORITY,XTERM);
3380 case KEY_getprotobyname:
3383 case KEY_getprotobynumber:
3384 LOP(OP_GPBYNUMBER,XTERM);
3386 case KEY_getprotoent:
3398 case KEY_getpeername:
3399 UNI(OP_GETPEERNAME);
3401 case KEY_gethostbyname:
3404 case KEY_gethostbyaddr:
3405 LOP(OP_GHBYADDR,XTERM);
3407 case KEY_gethostent:
3410 case KEY_getnetbyname:
3413 case KEY_getnetbyaddr:
3414 LOP(OP_GNBYADDR,XTERM);
3419 case KEY_getservbyname:
3420 LOP(OP_GSBYNAME,XTERM);
3422 case KEY_getservbyport:
3423 LOP(OP_GSBYPORT,XTERM);
3425 case KEY_getservent:
3428 case KEY_getsockname:
3429 UNI(OP_GETSOCKNAME);
3431 case KEY_getsockopt:
3432 LOP(OP_GSOCKOPT,XTERM);
3454 yylval.ival = PL_curcop->cop_line;
3458 LOP(OP_INDEX,XTERM);
3464 LOP(OP_IOCTL,XTERM);
3476 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3507 LOP(OP_LISTEN,XTERM);
3516 s = scan_pat(s,OP_MATCH);
3517 TERM(sublex_start());
3520 LOP(OP_MAPSTART,XREF);
3523 LOP(OP_MKDIR,XTERM);
3526 LOP(OP_MSGCTL,XTERM);
3529 LOP(OP_MSGGET,XTERM);
3532 LOP(OP_MSGRCV,XTERM);
3535 LOP(OP_MSGSND,XTERM);
3540 if (isIDFIRST(*s)) {
3541 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
3542 PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
3543 if (!PL_in_my_stash) {
3546 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
3553 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3560 if (PL_expect != XSTATE)
3561 yyerror("\"no\" not allowed in expression");
3562 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3563 s = force_version(s);
3572 if (isIDFIRST(*s)) {
3574 for (d = s; isALNUM(*d); d++) ;
3576 if (strchr("|&*+-=!?:.", *t))
3577 warn("Precedence problem: open %.*s should be open(%.*s)",
3583 yylval.ival = OP_OR;
3593 LOP(OP_OPEN_DIR,XTERM);
3596 checkcomma(s,PL_tokenbuf,"filehandle");
3600 checkcomma(s,PL_tokenbuf,"filehandle");
3619 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3623 LOP(OP_PIPE_OP,XTERM);
3628 missingterm((char*)0);
3629 yylval.ival = OP_CONST;
3630 TERM(sublex_start());
3638 missingterm((char*)0);
3639 if (PL_dowarn && SvLEN(PL_lex_stuff)) {
3640 d = SvPV_force(PL_lex_stuff, len);
3641 for (; len; --len, ++d) {
3643 warn("Possible attempt to separate words with commas");
3647 warn("Possible attempt to put comments in qw() list");
3653 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, tokeq(PL_lex_stuff));
3654 PL_lex_stuff = Nullsv;
3657 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(" ",1));
3660 yylval.ival = OP_SPLIT;
3664 PL_last_lop = PL_oldbufptr;
3665 PL_last_lop_op = OP_SPLIT;
3671 missingterm((char*)0);
3672 yylval.ival = OP_STRINGIFY;
3673 if (SvIVX(PL_lex_stuff) == '\'')
3674 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
3675 TERM(sublex_start());
3678 s = scan_pat(s,OP_QR);
3679 TERM(sublex_start());
3684 missingterm((char*)0);
3685 yylval.ival = OP_BACKTICK;
3687 TERM(sublex_start());
3693 *PL_tokenbuf = '\0';
3694 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3695 if (isIDFIRST(*PL_tokenbuf))
3696 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
3698 yyerror("<> should be quotes");
3705 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3709 LOP(OP_RENAME,XTERM);
3718 LOP(OP_RINDEX,XTERM);
3741 LOP(OP_REVERSE,XTERM);
3752 TERM(sublex_start());
3754 TOKEN(1); /* force error */
3763 LOP(OP_SELECT,XTERM);
3769 LOP(OP_SEMCTL,XTERM);
3772 LOP(OP_SEMGET,XTERM);
3775 LOP(OP_SEMOP,XTERM);
3781 LOP(OP_SETPGRP,XTERM);
3783 case KEY_setpriority:
3784 LOP(OP_SETPRIORITY,XTERM);
3786 case KEY_sethostent:
3792 case KEY_setservent:
3795 case KEY_setprotoent:
3805 LOP(OP_SEEKDIR,XTERM);
3807 case KEY_setsockopt:
3808 LOP(OP_SSOCKOPT,XTERM);
3814 LOP(OP_SHMCTL,XTERM);
3817 LOP(OP_SHMGET,XTERM);
3820 LOP(OP_SHMREAD,XTERM);
3823 LOP(OP_SHMWRITE,XTERM);
3826 LOP(OP_SHUTDOWN,XTERM);
3835 LOP(OP_SOCKET,XTERM);
3837 case KEY_socketpair:
3838 LOP(OP_SOCKPAIR,XTERM);
3841 checkcomma(s,PL_tokenbuf,"subroutine name");
3843 if (*s == ';' || *s == ')') /* probably a close */
3844 croak("sort is now a reserved word");
3846 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3850 LOP(OP_SPLIT,XTERM);
3853 LOP(OP_SPRINTF,XTERM);
3856 LOP(OP_SPLICE,XTERM);
3872 LOP(OP_SUBSTR,XTERM);
3879 if (isIDFIRST(*s) || *s == '\'' || *s == ':') {
3880 char tmpbuf[sizeof PL_tokenbuf];
3882 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3883 if (strchr(tmpbuf, ':'))
3884 sv_setpv(PL_subname, tmpbuf);
3886 sv_setsv(PL_subname,PL_curstname);
3887 sv_catpvn(PL_subname,"::",2);
3888 sv_catpvn(PL_subname,tmpbuf,len);
3890 s = force_word(s,WORD,FALSE,TRUE,TRUE);
3894 PL_expect = XTERMBLOCK;
3895 sv_setpv(PL_subname,"?");
3898 if (tmp == KEY_format) {
3901 PL_lex_formbrack = PL_lex_brackets + 1;
3905 /* Look for a prototype */
3912 SvREFCNT_dec(PL_lex_stuff);
3913 PL_lex_stuff = Nullsv;
3914 croak("Prototype not terminated");
3917 d = SvPVX(PL_lex_stuff);
3919 for (p = d; *p; ++p) {
3924 SvCUR(PL_lex_stuff) = tmp;
3927 PL_nextval[1] = PL_nextval[0];
3928 PL_nexttype[1] = PL_nexttype[0];
3929 PL_nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
3930 PL_nexttype[0] = THING;
3931 if (PL_nexttoke == 1) {
3932 PL_lex_defer = PL_lex_state;
3933 PL_lex_expect = PL_expect;
3934 PL_lex_state = LEX_KNOWNEXT;
3936 PL_lex_stuff = Nullsv;
3939 if (*SvPV(PL_subname,PL_na) == '?') {
3940 sv_setpv(PL_subname,"__ANON__");
3947 LOP(OP_SYSTEM,XREF);
3950 LOP(OP_SYMLINK,XTERM);
3953 LOP(OP_SYSCALL,XTERM);
3956 LOP(OP_SYSOPEN,XTERM);
3959 LOP(OP_SYSSEEK,XTERM);
3962 LOP(OP_SYSREAD,XTERM);
3965 LOP(OP_SYSWRITE,XTERM);
3969 TERM(sublex_start());
3990 LOP(OP_TRUNCATE,XTERM);
4002 yylval.ival = PL_curcop->cop_line;
4006 yylval.ival = PL_curcop->cop_line;
4010 LOP(OP_UNLINK,XTERM);
4016 LOP(OP_UNPACK,XTERM);
4019 LOP(OP_UTIME,XTERM);
4023 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4024 if (*d != '0' && isDIGIT(*d))
4025 yywarn("umask: argument is missing initial 0");
4030 LOP(OP_UNSHIFT,XTERM);
4033 if (PL_expect != XSTATE)
4034 yyerror("\"use\" not allowed in expression");
4037 s = force_version(s);
4038 if(*s == ';' || (s = skipspace(s), *s == ';')) {
4039 PL_nextval[PL_nexttoke].opval = Nullop;
4044 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4045 s = force_version(s);
4058 yylval.ival = PL_curcop->cop_line;
4062 PL_hints |= HINT_BLOCK_SCOPE;
4069 LOP(OP_WAITPID,XTERM);
4077 static char ctl_l[2];
4079 if (ctl_l[0] == '\0')
4080 ctl_l[0] = toCTRL('L');
4081 gv_fetchpv(ctl_l,TRUE, SVt_PV);
4084 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
4089 if (PL_expect == XOPERATOR)
4095 yylval.ival = OP_XOR;
4100 TERM(sublex_start());
4106 keyword(register char *d, I32 len)
4111 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
4112 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
4113 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
4114 if (strEQ(d,"__DATA__")) return KEY___DATA__;
4115 if (strEQ(d,"__END__")) return KEY___END__;
4119 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
4124 if (strEQ(d,"and")) return -KEY_and;
4125 if (strEQ(d,"abs")) return -KEY_abs;
4128 if (strEQ(d,"alarm")) return -KEY_alarm;
4129 if (strEQ(d,"atan2")) return -KEY_atan2;
4132 if (strEQ(d,"accept")) return -KEY_accept;
4137 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
4140 if (strEQ(d,"bless")) return -KEY_bless;
4141 if (strEQ(d,"bind")) return -KEY_bind;
4142 if (strEQ(d,"binmode")) return -KEY_binmode;
4145 if (strEQ(d,"CORE")) return -KEY_CORE;
4150 if (strEQ(d,"cmp")) return -KEY_cmp;
4151 if (strEQ(d,"chr")) return -KEY_chr;
4152 if (strEQ(d,"cos")) return -KEY_cos;
4155 if (strEQ(d,"chop")) return KEY_chop;
4158 if (strEQ(d,"close")) return -KEY_close;
4159 if (strEQ(d,"chdir")) return -KEY_chdir;
4160 if (strEQ(d,"chomp")) return KEY_chomp;
4161 if (strEQ(d,"chmod")) return -KEY_chmod;
4162 if (strEQ(d,"chown")) return -KEY_chown;
4163 if (strEQ(d,"crypt")) return -KEY_crypt;
4166 if (strEQ(d,"chroot")) return -KEY_chroot;
4167 if (strEQ(d,"caller")) return -KEY_caller;
4170 if (strEQ(d,"connect")) return -KEY_connect;
4173 if (strEQ(d,"closedir")) return -KEY_closedir;
4174 if (strEQ(d,"continue")) return -KEY_continue;
4179 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
4184 if (strEQ(d,"do")) return KEY_do;
4187 if (strEQ(d,"die")) return -KEY_die;
4190 if (strEQ(d,"dump")) return -KEY_dump;
4193 if (strEQ(d,"delete")) return KEY_delete;
4196 if (strEQ(d,"defined")) return KEY_defined;
4197 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
4200 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
4205 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
4206 if (strEQ(d,"END")) return KEY_END;
4211 if (strEQ(d,"eq")) return -KEY_eq;
4214 if (strEQ(d,"eof")) return -KEY_eof;
4215 if (strEQ(d,"exp")) return -KEY_exp;
4218 if (strEQ(d,"else")) return KEY_else;
4219 if (strEQ(d,"exit")) return -KEY_exit;
4220 if (strEQ(d,"eval")) return KEY_eval;
4221 if (strEQ(d,"exec")) return -KEY_exec;
4222 if (strEQ(d,"each")) return KEY_each;
4225 if (strEQ(d,"elsif")) return KEY_elsif;
4228 if (strEQ(d,"exists")) return KEY_exists;
4229 if (strEQ(d,"elseif")) warn("elseif should be elsif");
4232 if (strEQ(d,"endgrent")) return -KEY_endgrent;
4233 if (strEQ(d,"endpwent")) return -KEY_endpwent;
4236 if (strEQ(d,"endnetent")) return -KEY_endnetent;
4239 if (strEQ(d,"endhostent")) return -KEY_endhostent;
4240 if (strEQ(d,"endservent")) return -KEY_endservent;
4243 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
4250 if (strEQ(d,"for")) return KEY_for;
4253 if (strEQ(d,"fork")) return -KEY_fork;
4256 if (strEQ(d,"fcntl")) return -KEY_fcntl;
4257 if (strEQ(d,"flock")) return -KEY_flock;
4260 if (strEQ(d,"format")) return KEY_format;
4261 if (strEQ(d,"fileno")) return -KEY_fileno;
4264 if (strEQ(d,"foreach")) return KEY_foreach;
4267 if (strEQ(d,"formline")) return -KEY_formline;
4273 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
4274 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
4278 if (strnEQ(d,"get",3)) {
4283 if (strEQ(d,"ppid")) return -KEY_getppid;
4284 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
4287 if (strEQ(d,"pwent")) return -KEY_getpwent;
4288 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
4289 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
4292 if (strEQ(d,"peername")) return -KEY_getpeername;
4293 if (strEQ(d,"protoent")) return -KEY_getprotoent;
4294 if (strEQ(d,"priority")) return -KEY_getpriority;
4297 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
4300 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
4304 else if (*d == 'h') {
4305 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
4306 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
4307 if (strEQ(d,"hostent")) return -KEY_gethostent;
4309 else if (*d == 'n') {
4310 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
4311 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
4312 if (strEQ(d,"netent")) return -KEY_getnetent;
4314 else if (*d == 's') {
4315 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
4316 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
4317 if (strEQ(d,"servent")) return -KEY_getservent;
4318 if (strEQ(d,"sockname")) return -KEY_getsockname;
4319 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
4321 else if (*d == 'g') {
4322 if (strEQ(d,"grent")) return -KEY_getgrent;
4323 if (strEQ(d,"grnam")) return -KEY_getgrnam;
4324 if (strEQ(d,"grgid")) return -KEY_getgrgid;
4326 else if (*d == 'l') {
4327 if (strEQ(d,"login")) return -KEY_getlogin;
4329 else if (strEQ(d,"c")) return -KEY_getc;
4334 if (strEQ(d,"gt")) return -KEY_gt;
4335 if (strEQ(d,"ge")) return -KEY_ge;
4338 if (strEQ(d,"grep")) return KEY_grep;
4339 if (strEQ(d,"goto")) return KEY_goto;
4340 if (strEQ(d,"glob")) return KEY_glob;
4343 if (strEQ(d,"gmtime")) return -KEY_gmtime;
4348 if (strEQ(d,"hex")) return -KEY_hex;
4351 if (strEQ(d,"INIT")) return KEY_INIT;
4356 if (strEQ(d,"if")) return KEY_if;
4359 if (strEQ(d,"int")) return -KEY_int;
4362 if (strEQ(d,"index")) return -KEY_index;
4363 if (strEQ(d,"ioctl")) return -KEY_ioctl;
4368 if (strEQ(d,"join")) return -KEY_join;
4372 if (strEQ(d,"keys")) return KEY_keys;
4373 if (strEQ(d,"kill")) return -KEY_kill;
4378 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
4379 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
4385 if (strEQ(d,"lt")) return -KEY_lt;
4386 if (strEQ(d,"le")) return -KEY_le;
4387 if (strEQ(d,"lc")) return -KEY_lc;
4390 if (strEQ(d,"log")) return -KEY_log;
4393 if (strEQ(d,"last")) return KEY_last;
4394 if (strEQ(d,"link")) return -KEY_link;
4395 if (strEQ(d,"lock")) return -KEY_lock;
4398 if (strEQ(d,"local")) return KEY_local;
4399 if (strEQ(d,"lstat")) return -KEY_lstat;
4402 if (strEQ(d,"length")) return -KEY_length;
4403 if (strEQ(d,"listen")) return -KEY_listen;
4406 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
4409 if (strEQ(d,"localtime")) return -KEY_localtime;
4415 case 1: return KEY_m;
4417 if (strEQ(d,"my")) return KEY_my;
4420 if (strEQ(d,"map")) return KEY_map;
4423 if (strEQ(d,"mkdir")) return -KEY_mkdir;
4426 if (strEQ(d,"msgctl")) return -KEY_msgctl;
4427 if (strEQ(d,"msgget")) return -KEY_msgget;
4428 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
4429 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
4434 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
4437 if (strEQ(d,"next")) return KEY_next;
4438 if (strEQ(d,"ne")) return -KEY_ne;
4439 if (strEQ(d,"not")) return -KEY_not;
4440 if (strEQ(d,"no")) return KEY_no;
4445 if (strEQ(d,"or")) return -KEY_or;
4448 if (strEQ(d,"ord")) return -KEY_ord;
4449 if (strEQ(d,"oct")) return -KEY_oct;
4450 if (strEQ(d,"our")) { deprecate("reserved word \"our\"");
4454 if (strEQ(d,"open")) return -KEY_open;
4457 if (strEQ(d,"opendir")) return -KEY_opendir;
4464 if (strEQ(d,"pop")) return KEY_pop;
4465 if (strEQ(d,"pos")) return KEY_pos;
4468 if (strEQ(d,"push")) return KEY_push;
4469 if (strEQ(d,"pack")) return -KEY_pack;
4470 if (strEQ(d,"pipe")) return -KEY_pipe;
4473 if (strEQ(d,"print")) return KEY_print;
4476 if (strEQ(d,"printf")) return KEY_printf;
4479 if (strEQ(d,"package")) return KEY_package;
4482 if (strEQ(d,"prototype")) return KEY_prototype;
4487 if (strEQ(d,"q")) return KEY_q;
4488 if (strEQ(d,"qr")) return KEY_qr;
4489 if (strEQ(d,"qq")) return KEY_qq;
4490 if (strEQ(d,"qw")) return KEY_qw;
4491 if (strEQ(d,"qx")) return KEY_qx;
4493 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
4498 if (strEQ(d,"ref")) return -KEY_ref;
4501 if (strEQ(d,"read")) return -KEY_read;
4502 if (strEQ(d,"rand")) return -KEY_rand;
4503 if (strEQ(d,"recv")) return -KEY_recv;
4504 if (strEQ(d,"redo")) return KEY_redo;
4507 if (strEQ(d,"rmdir")) return -KEY_rmdir;
4508 if (strEQ(d,"reset")) return -KEY_reset;
4511 if (strEQ(d,"return")) return KEY_return;
4512 if (strEQ(d,"rename")) return -KEY_rename;
4513 if (strEQ(d,"rindex")) return -KEY_rindex;
4516 if (strEQ(d,"require")) return -KEY_require;
4517 if (strEQ(d,"reverse")) return -KEY_reverse;
4518 if (strEQ(d,"readdir")) return -KEY_readdir;
4521 if (strEQ(d,"readlink")) return -KEY_readlink;
4522 if (strEQ(d,"readline")) return -KEY_readline;
4523 if (strEQ(d,"readpipe")) return -KEY_readpipe;
4526 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
4532 case 0: return KEY_s;
4534 if (strEQ(d,"scalar")) return KEY_scalar;
4539 if (strEQ(d,"seek")) return -KEY_seek;
4540 if (strEQ(d,"send")) return -KEY_send;
4543 if (strEQ(d,"semop")) return -KEY_semop;
4546 if (strEQ(d,"select")) return -KEY_select;
4547 if (strEQ(d,"semctl")) return -KEY_semctl;
4548 if (strEQ(d,"semget")) return -KEY_semget;
4551 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
4552 if (strEQ(d,"seekdir")) return -KEY_seekdir;
4555 if (strEQ(d,"setpwent")) return -KEY_setpwent;
4556 if (strEQ(d,"setgrent")) return -KEY_setgrent;
4559 if (strEQ(d,"setnetent")) return -KEY_setnetent;
4562 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
4563 if (strEQ(d,"sethostent")) return -KEY_sethostent;
4564 if (strEQ(d,"setservent")) return -KEY_setservent;
4567 if (strEQ(d,"setpriority")) return -KEY_setpriority;
4568 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
4575 if (strEQ(d,"shift")) return KEY_shift;
4578 if (strEQ(d,"shmctl")) return -KEY_shmctl;
4579 if (strEQ(d,"shmget")) return -KEY_shmget;
4582 if (strEQ(d,"shmread")) return -KEY_shmread;
4585 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
4586 if (strEQ(d,"shutdown")) return -KEY_shutdown;
4591 if (strEQ(d,"sin")) return -KEY_sin;
4594 if (strEQ(d,"sleep")) return -KEY_sleep;
4597 if (strEQ(d,"sort")) return KEY_sort;
4598 if (strEQ(d,"socket")) return -KEY_socket;
4599 if (strEQ(d,"socketpair")) return -KEY_socketpair;
4602 if (strEQ(d,"split")) return KEY_split;
4603 if (strEQ(d,"sprintf")) return -KEY_sprintf;
4604 if (strEQ(d,"splice")) return KEY_splice;
4607 if (strEQ(d,"sqrt")) return -KEY_sqrt;
4610 if (strEQ(d,"srand")) return -KEY_srand;
4613 if (strEQ(d,"stat")) return -KEY_stat;
4614 if (strEQ(d,"study")) return KEY_study;
4617 if (strEQ(d,"substr")) return -KEY_substr;
4618 if (strEQ(d,"sub")) return KEY_sub;
4623 if (strEQ(d,"system")) return -KEY_system;
4626 if (strEQ(d,"symlink")) return -KEY_symlink;
4627 if (strEQ(d,"syscall")) return -KEY_syscall;
4628 if (strEQ(d,"sysopen")) return -KEY_sysopen;
4629 if (strEQ(d,"sysread")) return -KEY_sysread;
4630 if (strEQ(d,"sysseek")) return -KEY_sysseek;
4633 if (strEQ(d,"syswrite")) return -KEY_syswrite;
4642 if (strEQ(d,"tr")) return KEY_tr;
4645 if (strEQ(d,"tie")) return KEY_tie;
4648 if (strEQ(d,"tell")) return -KEY_tell;
4649 if (strEQ(d,"tied")) return KEY_tied;
4650 if (strEQ(d,"time")) return -KEY_time;
4653 if (strEQ(d,"times")) return -KEY_times;
4656 if (strEQ(d,"telldir")) return -KEY_telldir;
4659 if (strEQ(d,"truncate")) return -KEY_truncate;
4666 if (strEQ(d,"uc")) return -KEY_uc;
4669 if (strEQ(d,"use")) return KEY_use;
4672 if (strEQ(d,"undef")) return KEY_undef;
4673 if (strEQ(d,"until")) return KEY_until;
4674 if (strEQ(d,"untie")) return KEY_untie;
4675 if (strEQ(d,"utime")) return -KEY_utime;
4676 if (strEQ(d,"umask")) return -KEY_umask;
4679 if (strEQ(d,"unless")) return KEY_unless;
4680 if (strEQ(d,"unpack")) return -KEY_unpack;
4681 if (strEQ(d,"unlink")) return -KEY_unlink;
4684 if (strEQ(d,"unshift")) return KEY_unshift;
4685 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
4690 if (strEQ(d,"values")) return -KEY_values;
4691 if (strEQ(d,"vec")) return -KEY_vec;
4696 if (strEQ(d,"warn")) return -KEY_warn;
4697 if (strEQ(d,"wait")) return -KEY_wait;
4700 if (strEQ(d,"while")) return KEY_while;
4701 if (strEQ(d,"write")) return -KEY_write;
4704 if (strEQ(d,"waitpid")) return -KEY_waitpid;
4707 if (strEQ(d,"wantarray")) return -KEY_wantarray;
4712 if (len == 1) return -KEY_x;
4713 if (strEQ(d,"xor")) return -KEY_xor;
4716 if (len == 1) return KEY_y;
4725 checkcomma(register char *s, char *name, char *what)
4729 if (PL_dowarn && *s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
4731 for (w = s+2; *w && level; w++) {
4738 for (; *w && isSPACE(*w); w++) ;
4739 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
4740 warn("%s (...) interpreted as function",name);
4742 while (s < PL_bufend && isSPACE(*s))
4746 while (s < PL_bufend && isSPACE(*s))
4748 if (isIDFIRST(*s)) {
4752 while (s < PL_bufend && isSPACE(*s))
4757 kw = keyword(w, s - w) || perl_get_cv(w, FALSE) != 0;
4761 croak("No comma allowed after %s", what);
4767 new_constant(char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)
4770 HV *table = GvHV(PL_hintgv); /* ^H */
4773 bool oldcatch = CATCH_GET;
4779 yyerror("%^H is not defined");
4782 cvp = hv_fetch(table, key, strlen(key), FALSE);
4783 if (!cvp || !SvOK(*cvp)) {
4784 sprintf(buf,"$^H{%s} is not defined", key);
4788 sv_2mortal(sv); /* Parent created it permanently */
4791 pv = sv_2mortal(newSVpv(s, len));
4793 typesv = sv_2mortal(newSVpv(type, 0));
4795 typesv = &PL_sv_undef;
4797 Zero(&myop, 1, BINOP);
4798 myop.op_last = (OP *) &myop;
4799 myop.op_next = Nullop;
4800 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
4802 PUSHSTACKi(PERLSI_OVERLOAD);
4805 PL_op = (OP *) &myop;
4806 if (PERLDB_SUB && PL_curstash != PL_debstash)
4807 PL_op->op_private |= OPpENTERSUB_DB;
4818 if (PL_op = pp_entersub(ARGS))
4825 CATCH_SET(oldcatch);
4829 sprintf(buf,"Call to &{$^H{%s}} did not return a defined value", key);
4832 return SvREFCNT_inc(res);
4836 scan_word(register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
4838 register char *d = dest;
4839 register char *e = d + destlen - 3; /* two-character token, ending NUL */
4842 croak(ident_too_long);
4845 else if (*s == '\'' && allow_package && isIDFIRST(s[1])) {
4850 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
4863 scan_ident(register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
4870 if (PL_lex_brackets == 0)
4871 PL_lex_fakebrack = 0;
4875 e = d + destlen - 3; /* two-character token, ending NUL */
4877 while (isDIGIT(*s)) {
4879 croak(ident_too_long);
4886 croak(ident_too_long);
4889 else if (*s == '\'' && isIDFIRST(s[1])) {
4894 else if (*s == ':' && s[1] == ':') {
4905 if (PL_lex_state != LEX_NORMAL)
4906 PL_lex_state = LEX_INTERPENDMAYBE;
4909 if (*s == '$' && s[1] &&
4910 (isALNUM(s[1]) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
4912 if (isDIGIT(s[1]) && PL_lex_state == LEX_INTERPNORMAL)
4913 deprecate("\"$$<digit>\" to mean \"${$}<digit>\"");
4926 if (*d == '^' && *s && (isUPPER(*s) || strchr("[\\]^_?", *s))) {
4931 if (isSPACE(s[-1])) {
4934 if (ch != ' ' && ch != '\t') {
4940 if (isIDFIRST(*d)) {
4942 while (isALNUM(*s) || *s == ':')
4945 while (s < send && (*s == ' ' || *s == '\t')) s++;
4946 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
4947 if (PL_dowarn && keyword(dest, d - dest)) {
4948 char *brack = *s == '[' ? "[...]" : "{...}";
4949 warn("Ambiguous use of %c{%s%s} resolved to %c%s%s",
4950 funny, dest, brack, funny, dest, brack);
4952 PL_lex_fakebrack = PL_lex_brackets+1;
4954 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4960 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
4961 PL_lex_state = LEX_INTERPEND;
4964 if (PL_dowarn && PL_lex_state == LEX_NORMAL &&
4965 (keyword(dest, d - dest) || perl_get_cv(dest, FALSE)))
4966 warn("Ambiguous use of %c{%s} resolved to %c%s",
4967 funny, dest, funny, dest);
4970 s = bracket; /* let the parser handle it */
4974 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
4975 PL_lex_state = LEX_INTERPEND;
4979 void pmflag(U16 *pmfl, int ch)
4984 *pmfl |= PMf_GLOBAL;
4986 *pmfl |= PMf_CONTINUE;
4990 *pmfl |= PMf_MULTILINE;
4992 *pmfl |= PMf_SINGLELINE;
4994 *pmfl |= PMf_EXTENDED;
4998 scan_pat(char *start, I32 type)
5003 s = scan_str(start);
5006 SvREFCNT_dec(PL_lex_stuff);
5007 PL_lex_stuff = Nullsv;
5008 croak("Search pattern not terminated");
5011 pm = (PMOP*)newPMOP(type, 0);
5012 if (PL_multi_open == '?')
5013 pm->op_pmflags |= PMf_ONCE;
5015 while (*s && strchr("iomsx", *s))
5016 pmflag(&pm->op_pmflags,*s++);
5019 while (*s && strchr("iogcmsx", *s))
5020 pmflag(&pm->op_pmflags,*s++);
5022 pm->op_pmpermflags = pm->op_pmflags;
5024 PL_lex_op = (OP*)pm;
5025 yylval.ival = OP_MATCH;
5030 scan_subst(char *start)
5037 yylval.ival = OP_NULL;
5039 s = scan_str(start);
5043 SvREFCNT_dec(PL_lex_stuff);
5044 PL_lex_stuff = Nullsv;
5045 croak("Substitution pattern not terminated");
5048 if (s[-1] == PL_multi_open)
5051 first_start = PL_multi_start;
5055 SvREFCNT_dec(PL_lex_stuff);
5056 PL_lex_stuff = Nullsv;
5058 SvREFCNT_dec(PL_lex_repl);
5059 PL_lex_repl = Nullsv;
5060 croak("Substitution replacement not terminated");
5062 PL_multi_start = first_start; /* so whole substitution is taken together */
5064 pm = (PMOP*)newPMOP(OP_SUBST, 0);
5070 else if (strchr("iogcmsx", *s))
5071 pmflag(&pm->op_pmflags,*s++);
5078 pm->op_pmflags |= PMf_EVAL;
5079 repl = newSVpv("",0);
5081 sv_catpv(repl, es ? "eval " : "do ");
5082 sv_catpvn(repl, "{ ", 2);
5083 sv_catsv(repl, PL_lex_repl);
5084 sv_catpvn(repl, " };", 2);
5085 SvCOMPILED_on(repl);
5086 SvREFCNT_dec(PL_lex_repl);
5090 pm->op_pmpermflags = pm->op_pmflags;
5091 PL_lex_op = (OP*)pm;
5092 yylval.ival = OP_SUBST;
5097 scan_trans(char *start)
5106 yylval.ival = OP_NULL;
5108 s = scan_str(start);
5111 SvREFCNT_dec(PL_lex_stuff);
5112 PL_lex_stuff = Nullsv;
5113 croak("Transliteration pattern not terminated");
5115 if (s[-1] == PL_multi_open)
5121 SvREFCNT_dec(PL_lex_stuff);
5122 PL_lex_stuff = Nullsv;
5124 SvREFCNT_dec(PL_lex_repl);
5125 PL_lex_repl = Nullsv;
5126 croak("Transliteration replacement not terminated");
5129 New(803,tbl,256,short);
5130 o = newPVOP(OP_TRANS, 0, (char*)tbl);
5132 complement = Delete = squash = 0;
5133 while (*s == 'c' || *s == 'd' || *s == 's') {
5135 complement = OPpTRANS_COMPLEMENT;
5137 Delete = OPpTRANS_DELETE;
5139 squash = OPpTRANS_SQUASH;
5142 o->op_private = Delete|squash|complement;
5145 yylval.ival = OP_TRANS;
5150 scan_heredoc(register char *s)
5154 I32 op_type = OP_SCALAR;
5161 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
5165 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
5168 for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5169 if (*peek && strchr("`'\"",*peek)) {
5172 s = delimcpy(d, e, s, PL_bufend, term, &len);
5183 deprecate("bare << to mean <<\"\"");
5184 for (; isALNUM(*s); s++) {
5189 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
5190 croak("Delimiter for here document is too long");
5193 len = d - PL_tokenbuf;
5194 #ifndef PERL_STRICT_CR
5195 d = strchr(s, '\r');
5199 while (s < PL_bufend) {
5205 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
5214 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5219 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
5220 herewas = newSVpv(s,PL_bufend-s);
5222 s--, herewas = newSVpv(s,d-s);
5223 s += SvCUR(herewas);
5225 tmpstr = NEWSV(87,79);
5226 sv_upgrade(tmpstr, SVt_PVIV);
5231 else if (term == '`') {
5232 op_type = OP_BACKTICK;
5233 SvIVX(tmpstr) = '\\';
5237 PL_multi_start = PL_curcop->cop_line;
5238 PL_multi_open = PL_multi_close = '<';
5239 term = *PL_tokenbuf;
5242 while (s < PL_bufend &&
5243 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
5245 PL_curcop->cop_line++;
5247 if (s >= PL_bufend) {
5248 PL_curcop->cop_line = PL_multi_start;
5249 missingterm(PL_tokenbuf);
5251 sv_setpvn(tmpstr,d+1,s-d);
5253 PL_curcop->cop_line++; /* the preceding stmt passes a newline */
5255 sv_catpvn(herewas,s,PL_bufend-s);
5256 sv_setsv(PL_linestr,herewas);
5257 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
5258 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5261 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
5262 while (s >= PL_bufend) { /* multiple line string? */
5264 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5265 PL_curcop->cop_line = PL_multi_start;
5266 missingterm(PL_tokenbuf);
5268 PL_curcop->cop_line++;
5269 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5270 #ifndef PERL_STRICT_CR
5271 if (PL_bufend - PL_linestart >= 2) {
5272 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
5273 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
5275 PL_bufend[-2] = '\n';
5277 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5279 else if (PL_bufend[-1] == '\r')
5280 PL_bufend[-1] = '\n';
5282 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
5283 PL_bufend[-1] = '\n';
5285 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5286 SV *sv = NEWSV(88,0);
5288 sv_upgrade(sv, SVt_PVMG);
5289 sv_setsv(sv,PL_linestr);
5290 av_store(GvAV(PL_curcop->cop_filegv),
5291 (I32)PL_curcop->cop_line,sv);
5293 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
5296 sv_catsv(PL_linestr,herewas);
5297 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5301 sv_catsv(tmpstr,PL_linestr);
5304 PL_multi_end = PL_curcop->cop_line;
5306 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
5307 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
5308 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
5310 SvREFCNT_dec(herewas);
5311 PL_lex_stuff = tmpstr;
5312 yylval.ival = op_type;
5317 takes: current position in input buffer
5318 returns: new position in input buffer
5319 side-effects: yylval and lex_op are set.
5324 <FH> read from filehandle
5325 <pkg::FH> read from package qualified filehandle
5326 <pkg'FH> read from package qualified filehandle
5327 <$fh> read from filehandle in $fh
5333 scan_inputsymbol(char *start)
5335 register char *s = start; /* current position in buffer */
5340 d = PL_tokenbuf; /* start of temp holding space */
5341 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
5342 s = delimcpy(d, e, s + 1, PL_bufend, '>', &len); /* extract until > */
5344 /* die if we didn't have space for the contents of the <>,
5348 if (len >= sizeof PL_tokenbuf)
5349 croak("Excessively long <> operator");
5351 croak("Unterminated <> operator");
5356 Remember, only scalar variables are interpreted as filehandles by
5357 this code. Anything more complex (e.g., <$fh{$num}>) will be
5358 treated as a glob() call.
5359 This code makes use of the fact that except for the $ at the front,
5360 a scalar variable and a filehandle look the same.
5362 if (*d == '$' && d[1]) d++;
5364 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
5365 while (*d && (isALNUM(*d) || *d == '\'' || *d == ':'))
5368 /* If we've tried to read what we allow filehandles to look like, and
5369 there's still text left, then it must be a glob() and not a getline.
5370 Use scan_str to pull out the stuff between the <> and treat it
5371 as nothing more than a string.
5374 if (d - PL_tokenbuf != len) {
5375 yylval.ival = OP_GLOB;
5377 s = scan_str(start);
5379 croak("Glob not terminated");
5383 /* we're in a filehandle read situation */
5386 /* turn <> into <ARGV> */
5388 (void)strcpy(d,"ARGV");
5390 /* if <$fh>, create the ops to turn the variable into a
5396 /* try to find it in the pad for this block, otherwise find
5397 add symbol table ops
5399 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
5400 OP *o = newOP(OP_PADSV, 0);
5402 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newUNOP(OP_RV2GV, 0, o));
5405 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
5406 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
5407 newUNOP(OP_RV2GV, 0,
5408 newUNOP(OP_RV2SV, 0,
5409 newGVOP(OP_GV, 0, gv))));
5411 /* we created the ops in lex_op, so make yylval.ival a null op */
5412 yylval.ival = OP_NULL;
5415 /* If it's none of the above, it must be a literal filehandle
5416 (<Foo::BAR> or <FOO>) so build a simple readline OP */
5418 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
5419 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
5420 yylval.ival = OP_NULL;
5429 takes: start position in buffer
5430 returns: position to continue reading from buffer
5431 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
5432 updates the read buffer.
5434 This subroutine pulls a string out of the input. It is called for:
5435 q single quotes q(literal text)
5436 ' single quotes 'literal text'
5437 qq double quotes qq(interpolate $here please)
5438 " double quotes "interpolate $here please"
5439 qx backticks qx(/bin/ls -l)
5440 ` backticks `/bin/ls -l`
5441 qw quote words @EXPORT_OK = qw( func() $spam )
5442 m// regexp match m/this/
5443 s/// regexp substitute s/this/that/
5444 tr/// string transliterate tr/this/that/
5445 y/// string transliterate y/this/that/
5446 ($*@) sub prototypes sub foo ($)
5447 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
5449 In most of these cases (all but <>, patterns and transliterate)
5450 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
5451 calls scan_str(). s/// makes yylex() call scan_subst() which calls
5452 scan_str(). tr/// and y/// make yylex() call scan_trans() which
5455 It skips whitespace before the string starts, and treats the first
5456 character as the delimiter. If the delimiter is one of ([{< then
5457 the corresponding "close" character )]}> is used as the closing
5458 delimiter. It allows quoting of delimiters, and if the string has
5459 balanced delimiters ([{<>}]) it allows nesting.
5461 The lexer always reads these strings into lex_stuff, except in the
5462 case of the operators which take *two* arguments (s/// and tr///)
5463 when it checks to see if lex_stuff is full (presumably with the 1st
5464 arg to s or tr) and if so puts the string into lex_repl.
5469 scan_str(char *start)
5472 SV *sv; /* scalar value: string */
5473 char *tmps; /* temp string, used for delimiter matching */
5474 register char *s = start; /* current position in the buffer */
5475 register char term; /* terminating character */
5476 register char *to; /* current position in the sv's data */
5477 I32 brackets = 1; /* bracket nesting level */
5479 /* skip space before the delimiter */
5483 /* mark where we are, in case we need to report errors */
5486 /* after skipping whitespace, the next character is the terminator */
5488 /* mark where we are */
5489 PL_multi_start = PL_curcop->cop_line;
5490 PL_multi_open = term;
5492 /* find corresponding closing delimiter */
5493 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5495 PL_multi_close = term;
5497 /* create a new SV to hold the contents. 87 is leak category, I'm
5498 assuming. 79 is the SV's initial length. What a random number. */
5500 sv_upgrade(sv, SVt_PVIV);
5502 (void)SvPOK_only(sv); /* validate pointer */
5504 /* move past delimiter and try to read a complete string */
5507 /* extend sv if need be */
5508 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
5509 /* set 'to' to the next character in the sv's string */
5510 to = SvPVX(sv)+SvCUR(sv);
5512 /* if open delimiter is the close delimiter read unbridle */
5513 if (PL_multi_open == PL_multi_close) {
5514 for (; s < PL_bufend; s++,to++) {
5515 /* embedded newlines increment the current line number */
5516 if (*s == '\n' && !PL_rsfp)
5517 PL_curcop->cop_line++;
5518 /* handle quoted delimiters */
5519 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
5522 /* any other quotes are simply copied straight through */
5526 /* terminate when run out of buffer (the for() condition), or
5527 have found the terminator */
5528 else if (*s == term)
5534 /* if the terminator isn't the same as the start character (e.g.,
5535 matched brackets), we have to allow more in the quoting, and
5536 be prepared for nested brackets.
5539 /* read until we run out of string, or we find the terminator */
5540 for (; s < PL_bufend; s++,to++) {
5541 /* embedded newlines increment the line count */
5542 if (*s == '\n' && !PL_rsfp)
5543 PL_curcop->cop_line++;
5544 /* backslashes can escape the open or closing characters */
5545 if (*s == '\\' && s+1 < PL_bufend) {
5546 if ((s[1] == PL_multi_open) || (s[1] == PL_multi_close))
5551 /* allow nested opens and closes */
5552 else if (*s == PL_multi_close && --brackets <= 0)
5554 else if (*s == PL_multi_open)
5559 /* terminate the copied string and update the sv's end-of-string */
5561 SvCUR_set(sv, to - SvPVX(sv));
5564 * this next chunk reads more into the buffer if we're not done yet
5567 if (s < PL_bufend) break; /* handle case where we are done yet :-) */
5569 #ifndef PERL_STRICT_CR
5570 if (to - SvPVX(sv) >= 2) {
5571 if ((to[-2] == '\r' && to[-1] == '\n') ||
5572 (to[-2] == '\n' && to[-1] == '\r'))
5576 SvCUR_set(sv, to - SvPVX(sv));
5578 else if (to[-1] == '\r')
5581 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
5585 /* if we're out of file, or a read fails, bail and reset the current
5586 line marker so we can report where the unterminated string began
5589 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5591 PL_curcop->cop_line = PL_multi_start;
5594 /* we read a line, so increment our line counter */
5595 PL_curcop->cop_line++;
5597 /* update debugger info */
5598 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5599 SV *sv = NEWSV(88,0);
5601 sv_upgrade(sv, SVt_PVMG);
5602 sv_setsv(sv,PL_linestr);
5603 av_store(GvAV(PL_curcop->cop_filegv),
5604 (I32)PL_curcop->cop_line, sv);
5607 /* having changed the buffer, we must update PL_bufend */
5608 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5611 /* at this point, we have successfully read the delimited string */
5613 PL_multi_end = PL_curcop->cop_line;
5616 /* if we allocated too much space, give some back */
5617 if (SvCUR(sv) + 5 < SvLEN(sv)) {
5618 SvLEN_set(sv, SvCUR(sv) + 1);
5619 Renew(SvPVX(sv), SvLEN(sv), char);
5622 /* decide whether this is the first or second quoted string we've read
5635 takes: pointer to position in buffer
5636 returns: pointer to new position in buffer
5637 side-effects: builds ops for the constant in yylval.op
5639 Read a number in any of the formats that Perl accepts:
5641 0(x[0-7A-F]+)|([0-7]+)
5642 [\d_]+(\.[\d_]*)?[Ee](\d+)
5644 Underbars (_) are allowed in decimal numbers. If -w is on,
5645 underbars before a decimal point must be at three digit intervals.
5647 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
5650 If it reads a number without a decimal point or an exponent, it will
5651 try converting the number to an integer and see if it can do so
5652 without loss of precision.
5656 scan_num(char *start)
5658 register char *s = start; /* current position in buffer */
5659 register char *d; /* destination in temp buffer */
5660 register char *e; /* end of temp buffer */
5661 I32 tryiv; /* used to see if it can be an int */
5662 double value; /* number read, as a double */
5663 SV *sv; /* place to put the converted number */
5664 I32 floatit; /* boolean: int or float? */
5665 char *lastub = 0; /* position of last underbar */
5666 static char number_too_long[] = "Number too long";
5668 /* We use the first character to decide what type of number this is */
5672 croak("panic: scan_num");
5674 /* if it starts with a 0, it could be an octal number, a decimal in
5675 0.13 disguise, or a hexadecimal number.
5680 u holds the "number so far"
5681 shift the power of 2 of the base (hex == 4, octal == 3)
5682 overflowed was the number more than we can hold?
5684 Shift is used when we add a digit. It also serves as an "are
5685 we in octal or hex?" indicator to disallow hex characters when
5690 bool overflowed = FALSE;
5697 /* check for a decimal in disguise */
5698 else if (s[1] == '.')
5700 /* so it must be octal */
5705 /* read the rest of the octal number */
5707 UV n, b; /* n is used in the overflow test, b is the digit we're adding on */
5711 /* if we don't mention it, we're done */
5720 /* 8 and 9 are not octal */
5723 yyerror("Illegal octal digit");
5727 case '0': case '1': case '2': case '3': case '4':
5728 case '5': case '6': case '7':
5729 b = *s++ & 15; /* ASCII digit -> value of digit */
5733 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
5734 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
5735 /* make sure they said 0x */
5740 /* Prepare to put the digit we have onto the end
5741 of the number so far. We check for overflows.
5745 n = u << shift; /* make room for the digit */
5746 if (!overflowed && (n >> shift) != u
5747 && !(PL_hints & HINT_NEW_BINARY)) {
5748 warn("Integer overflow in %s number",
5749 (shift == 4) ? "hex" : "octal");
5752 u = n | b; /* add the digit to the end */
5757 /* if we get here, we had success: make a scalar value from
5763 if ( PL_hints & HINT_NEW_BINARY)
5764 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
5769 handle decimal numbers.
5770 we're also sent here when we read a 0 as the first digit
5772 case '1': case '2': case '3': case '4': case '5':
5773 case '6': case '7': case '8': case '9': case '.':
5776 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
5779 /* read next group of digits and _ and copy into d */
5780 while (isDIGIT(*s) || *s == '_') {
5781 /* skip underscores, checking for misplaced ones
5785 if (PL_dowarn && lastub && s - lastub != 3)
5786 warn("Misplaced _ in number");
5790 /* check for end of fixed-length buffer */
5792 croak(number_too_long);
5793 /* if we're ok, copy the character */
5798 /* final misplaced underbar check */
5799 if (PL_dowarn && lastub && s - lastub != 3)
5800 warn("Misplaced _ in number");
5802 /* read a decimal portion if there is one. avoid
5803 3..5 being interpreted as the number 3. followed
5806 if (*s == '.' && s[1] != '.') {
5810 /* copy, ignoring underbars, until we run out of
5811 digits. Note: no misplaced underbar checks!
5813 for (; isDIGIT(*s) || *s == '_'; s++) {
5814 /* fixed length buffer check */
5816 croak(number_too_long);
5822 /* read exponent part, if present */
5823 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
5827 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
5828 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
5830 /* allow positive or negative exponent */
5831 if (*s == '+' || *s == '-')
5834 /* read digits of exponent (no underbars :-) */
5835 while (isDIGIT(*s)) {
5837 croak(number_too_long);
5842 /* terminate the string */
5845 /* make an sv from the string */
5847 /* reset numeric locale in case we were earlier left in Swaziland */
5848 SET_NUMERIC_STANDARD();
5849 value = atof(PL_tokenbuf);
5852 See if we can make do with an integer value without loss of
5853 precision. We use I_V to cast to an int, because some
5854 compilers have issues. Then we try casting it back and see
5855 if it was the same. We only do this if we know we
5856 specifically read an integer.
5858 Note: if floatit is true, then we don't need to do the
5862 if (!floatit && (double)tryiv == value)
5863 sv_setiv(sv, tryiv);
5865 sv_setnv(sv, value);
5866 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) )
5867 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
5868 (floatit ? "float" : "integer"), sv, Nullsv, NULL);
5872 /* make the op for the constant and return */
5874 yylval.opval = newSVOP(OP_CONST, 0, sv);
5880 scan_formline(register char *s)
5885 SV *stuff = newSVpv("",0);
5886 bool needargs = FALSE;
5889 if (*s == '.' || *s == '}') {
5891 for (t = s+1; *t == ' ' || *t == '\t'; t++) ;
5895 if (PL_in_eval && !PL_rsfp) {
5896 eol = strchr(s,'\n');
5901 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5903 for (t = s; t < eol; t++) {
5904 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
5906 goto enough; /* ~~ must be first line in formline */
5908 if (*t == '@' || *t == '^')
5911 sv_catpvn(stuff, s, eol-s);
5915 s = filter_gets(PL_linestr, PL_rsfp, 0);
5916 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
5917 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
5920 yyerror("Format not terminated");
5930 PL_lex_state = LEX_NORMAL;
5931 PL_nextval[PL_nexttoke].ival = 0;
5935 PL_lex_state = LEX_FORMLINE;
5936 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
5938 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
5942 SvREFCNT_dec(stuff);
5943 PL_lex_formbrack = 0;
5954 PL_cshlen = strlen(PL_cshname);
5959 start_subparse(I32 is_format, U32 flags)
5962 I32 oldsavestack_ix = PL_savestack_ix;
5963 CV* outsidecv = PL_compcv;
5967 assert(SvTYPE(PL_compcv) == SVt_PVCV);
5969 save_I32(&PL_subline);
5970 save_item(PL_subname);
5972 SAVESPTR(PL_curpad);
5973 SAVESPTR(PL_comppad);
5974 SAVESPTR(PL_comppad_name);
5975 SAVESPTR(PL_compcv);
5976 SAVEI32(PL_comppad_name_fill);
5977 SAVEI32(PL_min_intro_pending);
5978 SAVEI32(PL_max_intro_pending);
5979 SAVEI32(PL_pad_reset_pending);
5981 PL_compcv = (CV*)NEWSV(1104,0);
5982 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
5983 CvFLAGS(PL_compcv) |= flags;
5985 PL_comppad = newAV();
5986 av_push(PL_comppad, Nullsv);
5987 PL_curpad = AvARRAY(PL_comppad);
5988 PL_comppad_name = newAV();
5989 PL_comppad_name_fill = 0;
5990 PL_min_intro_pending = 0;
5992 PL_subline = PL_curcop->cop_line;
5994 av_store(PL_comppad_name, 0, newSVpv("@_", 2));
5995 PL_curpad[0] = (SV*)newAV();
5996 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
5997 #endif /* USE_THREADS */
5999 comppadlist = newAV();
6000 AvREAL_off(comppadlist);
6001 av_store(comppadlist, 0, (SV*)PL_comppad_name);
6002 av_store(comppadlist, 1, (SV*)PL_comppad);
6004 CvPADLIST(PL_compcv) = comppadlist;
6005 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
6007 CvOWNER(PL_compcv) = 0;
6008 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
6009 MUTEX_INIT(CvMUTEXP(PL_compcv));
6010 #endif /* USE_THREADS */
6012 return oldsavestack_ix;
6031 char *context = NULL;
6035 if (!yychar || (yychar == ';' && !PL_rsfp))
6037 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
6038 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
6039 while (isSPACE(*PL_oldoldbufptr))
6041 context = PL_oldoldbufptr;
6042 contlen = PL_bufptr - PL_oldoldbufptr;
6044 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
6045 PL_oldbufptr != PL_bufptr) {
6046 while (isSPACE(*PL_oldbufptr))
6048 context = PL_oldbufptr;
6049 contlen = PL_bufptr - PL_oldbufptr;
6051 else if (yychar > 255)
6052 where = "next token ???";
6053 else if ((yychar & 127) == 127) {
6054 if (PL_lex_state == LEX_NORMAL ||
6055 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
6056 where = "at end of line";
6057 else if (PL_lex_inpat)
6058 where = "within pattern";
6060 where = "within string";
6063 SV *where_sv = sv_2mortal(newSVpv("next char ", 0));
6065 sv_catpvf(where_sv, "^%c", toCTRL(yychar));
6066 else if (isPRINT_LC(yychar))
6067 sv_catpvf(where_sv, "%c", yychar);
6069 sv_catpvf(where_sv, "\\%03o", yychar & 255);
6070 where = SvPVX(where_sv);
6072 msg = sv_2mortal(newSVpv(s, 0));
6073 sv_catpvf(msg, " at %_ line %ld, ",
6074 GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line);
6076 sv_catpvf(msg, "near \"%.*s\"\n", contlen, context);
6078 sv_catpvf(msg, "%s\n", where);
6079 if (PL_multi_start < PL_multi_end && (U32)(PL_curcop->cop_line - PL_multi_end) <= 1) {
6081 " (Might be a runaway multi-line %c%c string starting on line %ld)\n",
6082 (int)PL_multi_open,(int)PL_multi_close,(long)PL_multi_start);
6087 else if (PL_in_eval)
6088 sv_catsv(ERRSV, msg);
6090 PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
6091 if (++PL_error_count >= 10)
6092 croak("%_ has too many errors.\n", GvSV(PL_curcop->cop_filegv));
6094 PL_in_my_stash = Nullhv;