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