3 * Copyright (c) 1991-1997, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "It all comes from here, the stench and the peril." --Frodo
18 static void check_uni _((void));
19 static void force_next _((I32 type));
20 static char *force_version _((char *start));
21 static char *force_word _((char *start, int token, int check_keyword, int allow_pack, int allow_tick));
22 static SV *tokeq _((SV *sv));
23 static char *scan_const _((char *start));
24 static char *scan_formline _((char *s));
25 static char *scan_heredoc _((char *s));
26 static char *scan_ident _((char *s, char *send, char *dest, STRLEN destlen,
28 static char *scan_inputsymbol _((char *start));
29 static char *scan_pat _((char *start, I32 type));
30 static char *scan_str _((char *start));
31 static char *scan_subst _((char *start));
32 static char *scan_trans _((char *start));
33 static char *scan_word _((char *s, char *dest, STRLEN destlen,
34 int allow_package, STRLEN *slp));
35 static char *skipspace _((char *s));
36 static void checkcomma _((char *s, char *name, char *what));
37 static void force_ident _((char *s, int kind));
38 static void incline _((char *s));
39 static int intuit_method _((char *s, GV *gv));
40 static int intuit_more _((char *s));
41 static I32 lop _((I32 f, expectation x, char *s));
42 static void missingterm _((char *s));
43 static void no_op _((char *what, char *s));
44 static void set_csh _((void));
45 static I32 sublex_done _((void));
46 static I32 sublex_push _((void));
47 static I32 sublex_start _((void));
49 static int uni _((I32 f, char *s));
51 static char * filter_gets _((SV *sv, PerlIO *fp, STRLEN append));
52 static void restore_rsfp _((void *f));
53 static SV *new_constant _((char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type));
54 static void restore_expect _((void *e));
55 static void restore_lex_expect _((void *e));
56 #endif /* PERL_OBJECT */
58 static char ident_too_long[] = "Identifier too long";
60 /* The following are arranged oddly so that the guard on the switch statement
61 * can get by with a single comparison (if the compiler is smart enough).
64 /* #define LEX_NOTPARSING 11 is done in perl.h. */
67 #define LEX_INTERPNORMAL 9
68 #define LEX_INTERPCASEMOD 8
69 #define LEX_INTERPPUSH 7
70 #define LEX_INTERPSTART 6
71 #define LEX_INTERPEND 5
72 #define LEX_INTERPENDMAYBE 4
73 #define LEX_INTERPCONCAT 3
74 #define LEX_INTERPCONST 2
75 #define LEX_FORMLINE 1
76 #define LEX_KNOWNEXT 0
85 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
87 # include <unistd.h> /* Needed for execv() */
100 #define CLINE (PL_copline = (PL_curcop->cop_line < PL_copline ? PL_curcop->cop_line : PL_copline))
102 #define TOKEN(retval) return (PL_bufptr = s,(int)retval)
103 #define OPERATOR(retval) return (PL_expect = XTERM,PL_bufptr = s,(int)retval)
104 #define AOPERATOR(retval) return ao((PL_expect = XTERM,PL_bufptr = s,(int)retval))
105 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s,(int)retval)
106 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval)
107 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s,(int)retval)
108 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR,PL_bufptr = s,(int)retval)
109 #define LOOPX(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX)
110 #define FTST(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)UNIOP)
111 #define FUN0(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0)
112 #define FUN1(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1)
113 #define BOop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITOROP))
114 #define BAop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP))
115 #define SHop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP))
116 #define PWop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)POWOP))
117 #define PMop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP)
118 #define Aop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)ADDOP))
119 #define Mop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MULOP))
120 #define Eop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)EQOP)
121 #define Rop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)RELOP)
123 /* This bit of chicanery makes a unary function followed by
124 * a parenthesis into a function with one argument, highest precedence.
126 #define UNI(f) return(yylval.ival = f, \
129 PL_last_uni = PL_oldbufptr, \
130 PL_last_lop_op = f, \
131 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
133 #define UNIBRACK(f) return(yylval.ival = f, \
135 PL_last_uni = PL_oldbufptr, \
136 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
138 /* grandfather return to old style */
139 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
144 if (*PL_bufptr == '=') {
146 if (toketype == ANDAND)
147 yylval.ival = OP_ANDASSIGN;
148 else if (toketype == OROR)
149 yylval.ival = OP_ORASSIGN;
156 no_op(char *what, char *s)
158 char *oldbp = PL_bufptr;
159 bool is_first = (PL_oldbufptr == PL_linestart);
162 yywarn(form("%s found where operator expected", what));
164 warn("\t(Missing semicolon on previous line?)\n");
165 else if (PL_oldoldbufptr && isIDFIRST(*PL_oldoldbufptr)) {
167 for (t = PL_oldoldbufptr; *t && (isALNUM(*t) || *t == ':'); t++) ;
168 if (t < PL_bufptr && isSPACE(*t))
169 warn("\t(Do you need to predeclare %.*s?)\n",
170 t - PL_oldoldbufptr, PL_oldoldbufptr);
174 warn("\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
184 char *nl = strrchr(s,'\n');
188 else if (PL_multi_close < 32 || PL_multi_close == 127) {
190 tmpbuf[1] = toCTRL(PL_multi_close);
196 *tmpbuf = PL_multi_close;
200 q = strchr(s,'"') ? '\'' : '"';
201 croak("Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
208 warn("Use of %s is deprecated", s);
214 deprecate("comma-less variable list");
220 win32_textfilter(int idx, SV *sv, int maxlen)
222 I32 count = FILTER_READ(idx+1, sv, maxlen);
223 if (count > 0 && !maxlen)
224 win32_strip_return(sv);
237 SAVEI32(PL_lex_dojoin);
238 SAVEI32(PL_lex_brackets);
239 SAVEI32(PL_lex_fakebrack);
240 SAVEI32(PL_lex_casemods);
241 SAVEI32(PL_lex_starts);
242 SAVEI32(PL_lex_state);
243 SAVESPTR(PL_lex_inpat);
244 SAVEI32(PL_lex_inwhat);
245 SAVEI16(PL_curcop->cop_line);
248 SAVEPPTR(PL_oldbufptr);
249 SAVEPPTR(PL_oldoldbufptr);
250 SAVEPPTR(PL_linestart);
251 SAVESPTR(PL_linestr);
252 SAVEPPTR(PL_lex_brackstack);
253 SAVEPPTR(PL_lex_casestack);
254 SAVEDESTRUCTOR(restore_rsfp, PL_rsfp);
255 SAVESPTR(PL_lex_stuff);
256 SAVEI32(PL_lex_defer);
257 SAVESPTR(PL_lex_repl);
258 SAVEDESTRUCTOR(restore_expect, PL_tokenbuf + PL_expect); /* encode as pointer */
259 SAVEDESTRUCTOR(restore_lex_expect, PL_tokenbuf + PL_expect);
261 PL_lex_state = LEX_NORMAL;
265 PL_lex_fakebrack = 0;
266 New(899, PL_lex_brackstack, 120, char);
267 New(899, PL_lex_casestack, 12, char);
268 SAVEFREEPV(PL_lex_brackstack);
269 SAVEFREEPV(PL_lex_casestack);
271 *PL_lex_casestack = '\0';
274 PL_lex_stuff = Nullsv;
275 PL_lex_repl = Nullsv;
279 if (SvREADONLY(PL_linestr))
280 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
281 s = SvPV(PL_linestr, len);
282 if (len && s[len-1] != ';') {
283 if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
284 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
285 sv_catpvn(PL_linestr, "\n;", 2);
287 SvTEMP_off(PL_linestr);
288 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
289 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
291 PL_rs = newSVpv("\n", 1);
298 PL_doextract = FALSE;
302 restore_rsfp(void *f)
304 PerlIO *fp = (PerlIO*)f;
306 if (PL_rsfp == PerlIO_stdin())
307 PerlIO_clearerr(PL_rsfp);
308 else if (PL_rsfp && (PL_rsfp != fp))
309 PerlIO_close(PL_rsfp);
314 restore_expect(void *e)
316 /* a safe way to store a small integer in a pointer */
317 PL_expect = (expectation)((char *)e - PL_tokenbuf);
321 restore_lex_expect(void *e)
323 /* a safe way to store a small integer in a pointer */
324 PL_lex_expect = (expectation)((char *)e - PL_tokenbuf);
336 PL_curcop->cop_line++;
339 while (*s == ' ' || *s == '\t') s++;
340 if (strnEQ(s, "line ", 5)) {
349 while (*s == ' ' || *s == '\t')
351 if (*s == '"' && (t = strchr(s+1, '"')))
355 return; /* false alarm */
356 for (t = s; !isSPACE(*t); t++) ;
361 PL_curcop->cop_filegv = gv_fetchfile(s);
363 PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
365 PL_curcop->cop_line = atoi(n)-1;
369 skipspace(register char *s)
372 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
373 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
379 while (s < PL_bufend && isSPACE(*s))
381 if (s < PL_bufend && *s == '#') {
382 while (s < PL_bufend && *s != '\n')
387 if (s < PL_bufend || !PL_rsfp || PL_lex_state != LEX_NORMAL)
389 if ((s = filter_gets(PL_linestr, PL_rsfp, (prevlen = SvCUR(PL_linestr)))) == Nullch) {
390 if (PL_minus_n || PL_minus_p) {
391 sv_setpv(PL_linestr,PL_minus_p ?
392 ";}continue{print or die qq(-p destination: $!\\n)" :
394 sv_catpv(PL_linestr,";}");
395 PL_minus_n = PL_minus_p = 0;
398 sv_setpv(PL_linestr,";");
399 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
400 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
401 if (PL_preprocess && !PL_in_eval)
402 (void)PerlProc_pclose(PL_rsfp);
403 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
404 PerlIO_clearerr(PL_rsfp);
406 (void)PerlIO_close(PL_rsfp);
410 PL_linestart = PL_bufptr = s + prevlen;
411 PL_bufend = s + SvCUR(PL_linestr);
414 if (PERLDB_LINE && PL_curstash != PL_debstash) {
415 SV *sv = NEWSV(85,0);
417 sv_upgrade(sv, SVt_PVMG);
418 sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
419 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
430 if (PL_oldoldbufptr != PL_last_uni)
432 while (isSPACE(*PL_last_uni))
434 for (s = PL_last_uni; isALNUM(*s) || *s == '-'; s++) ;
435 if ((t = strchr(s, '(')) && t < PL_bufptr)
439 warn("Warning: Use of \"%s\" without parens is ambiguous", PL_last_uni);
446 #define UNI(f) return uni(f,s)
454 PL_last_uni = PL_oldbufptr;
465 #endif /* CRIPPLED_CC */
467 #define LOP(f,x) return lop(f,x,s)
470 lop(I32 f, expectation x, char *s)
477 PL_last_lop = PL_oldbufptr;
493 PL_nexttype[PL_nexttoke] = type;
495 if (PL_lex_state != LEX_KNOWNEXT) {
496 PL_lex_defer = PL_lex_state;
497 PL_lex_expect = PL_expect;
498 PL_lex_state = LEX_KNOWNEXT;
503 force_word(register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
508 start = skipspace(start);
511 (allow_pack && *s == ':') ||
512 (allow_initial_tick && *s == '\'') )
514 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
515 if (check_keyword && keyword(PL_tokenbuf, len))
517 if (token == METHOD) {
522 PL_expect = XOPERATOR;
527 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(PL_tokenbuf,0));
528 PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
535 force_ident(register char *s, int kind)
538 OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
539 PL_nextval[PL_nexttoke].opval = o;
542 dTHR; /* just for in_eval */
543 o->op_private = OPpCONST_ENTERED;
544 /* XXX see note in pp_entereval() for why we forgo typo
545 warnings if the symbol must be introduced in an eval.
547 gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
548 kind == '$' ? SVt_PV :
549 kind == '@' ? SVt_PVAV :
550 kind == '%' ? SVt_PVHV :
558 force_version(char *s)
560 OP *version = Nullop;
564 /* default VERSION number -- GBARR */
569 for( d=s, c = 1; isDIGIT(*d) || *d == '_' || (*d == '.' && c--); d++);
570 if((*d == ';' || isSPACE(*d)) && *(skipspace(d)) != ',') {
572 /* real VERSION number -- GBARR */
573 version = yylval.opval;
577 /* NOTE: The parser sees the package name and the VERSION swapped */
578 PL_nextval[PL_nexttoke].opval = version;
596 s = SvPV_force(sv, len);
600 while (s < send && *s != '\\')
605 if ( PL_hints & HINT_NEW_STRING )
606 pv = sv_2mortal(newSVpv(SvPVX(pv), len));
609 if (s + 1 < send && (s[1] == '\\'))
610 s++; /* all that, just for this */
615 SvCUR_set(sv, d - SvPVX(sv));
617 if ( PL_hints & HINT_NEW_STRING )
618 return new_constant(NULL, 0, "q", sv, pv, "q");
625 register I32 op_type = yylval.ival;
627 if (op_type == OP_NULL) {
628 yylval.opval = PL_lex_op;
632 if (op_type == OP_CONST || op_type == OP_READLINE) {
633 SV *sv = tokeq(PL_lex_stuff);
635 if (SvTYPE(sv) == SVt_PVIV) {
636 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
642 nsv = newSVpv(p, len);
646 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
647 PL_lex_stuff = Nullsv;
651 PL_sublex_info.super_state = PL_lex_state;
652 PL_sublex_info.sub_inwhat = op_type;
653 PL_sublex_info.sub_op = PL_lex_op;
654 PL_lex_state = LEX_INTERPPUSH;
658 yylval.opval = PL_lex_op;
672 PL_lex_state = PL_sublex_info.super_state;
673 SAVEI32(PL_lex_dojoin);
674 SAVEI32(PL_lex_brackets);
675 SAVEI32(PL_lex_fakebrack);
676 SAVEI32(PL_lex_casemods);
677 SAVEI32(PL_lex_starts);
678 SAVEI32(PL_lex_state);
679 SAVESPTR(PL_lex_inpat);
680 SAVEI32(PL_lex_inwhat);
681 SAVEI16(PL_curcop->cop_line);
683 SAVEPPTR(PL_oldbufptr);
684 SAVEPPTR(PL_oldoldbufptr);
685 SAVEPPTR(PL_linestart);
686 SAVESPTR(PL_linestr);
687 SAVEPPTR(PL_lex_brackstack);
688 SAVEPPTR(PL_lex_casestack);
690 PL_linestr = PL_lex_stuff;
691 PL_lex_stuff = Nullsv;
693 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
694 PL_bufend += SvCUR(PL_linestr);
695 SAVEFREESV(PL_linestr);
697 PL_lex_dojoin = FALSE;
699 PL_lex_fakebrack = 0;
700 New(899, PL_lex_brackstack, 120, char);
701 New(899, PL_lex_casestack, 12, char);
702 SAVEFREEPV(PL_lex_brackstack);
703 SAVEFREEPV(PL_lex_casestack);
705 *PL_lex_casestack = '\0';
707 PL_lex_state = LEX_INTERPCONCAT;
708 PL_curcop->cop_line = PL_multi_start;
710 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
711 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
712 PL_lex_inpat = PL_sublex_info.sub_op;
714 PL_lex_inpat = Nullop;
722 if (!PL_lex_starts++) {
723 PL_expect = XOPERATOR;
724 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv("",0));
728 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
729 PL_lex_state = LEX_INTERPCASEMOD;
733 /* Is there a right-hand side to take care of? */
734 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
735 PL_linestr = PL_lex_repl;
737 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
738 PL_bufend += SvCUR(PL_linestr);
739 SAVEFREESV(PL_linestr);
740 PL_lex_dojoin = FALSE;
742 PL_lex_fakebrack = 0;
744 *PL_lex_casestack = '\0';
746 if (SvCOMPILED(PL_lex_repl)) {
747 PL_lex_state = LEX_INTERPNORMAL;
751 PL_lex_state = LEX_INTERPCONCAT;
752 PL_lex_repl = Nullsv;
757 PL_bufend = SvPVX(PL_linestr);
758 PL_bufend += SvCUR(PL_linestr);
759 PL_expect = XOPERATOR;
767 Extracts a pattern, double-quoted string, or transliteration. This
770 It looks at lex_inwhat and PL_lex_inpat to find out whether it's
771 processing a pattern (PL_lex_inpat is true), a transliteration
772 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
774 Returns a pointer to the character scanned up to. Iff this is
775 advanced from the start pointer supplied (ie if anything was
776 successfully parsed), will leave an OP for the substring scanned
777 in yylval. Caller must intuit reason for not parsing further
778 by looking at the next characters herself.
782 double-quoted style: \r and \n
783 regexp special ones: \D \s
785 backrefs: \1 (deprecated in substitution replacements)
786 case and quoting: \U \Q \E
787 stops on @ and $, but not for $ as tail anchor
790 characters are VERY literal, except for - not at the start or end
791 of the string, which indicates a range. scan_const expands the
792 range to the full set of intermediate characters.
794 In double-quoted strings:
796 double-quoted style: \r and \n
798 backrefs: \1 (deprecated)
799 case and quoting: \U \Q \E
802 scan_const does *not* construct ops to handle interpolated strings.
803 It stops processing as soon as it finds an embedded $ or @ variable
804 and leaves it to the caller to work out what's going on.
806 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
808 $ in pattern could be $foo or could be tail anchor. Assumption:
809 it's a tail anchor if $ is the last thing in the string, or if it's
810 followed by one of ")| \n\t"
812 \1 (backreferences) are turned into $1
814 The structure of the code is
815 while (there's a character to process) {
816 handle transliteration ranges
818 skip # initiated comments in //x patterns
819 check for embedded @foo
820 check for embedded scalars
822 leave intact backslashes from leave (below)
823 deprecate \1 in strings and sub replacements
824 handle string-changing backslashes \l \U \Q \E, etc.
825 switch (what was escaped) {
826 handle - in a transliteration (becomes a literal -)
827 handle \132 octal characters
828 handle 0x15 hex characters
829 handle \cV (control V)
830 handle printf backslashes (\f, \r, \n, etc)
833 } (end while character to read)
838 scan_const(char *start)
840 register char *send = PL_bufend; /* end of the constant */
841 SV *sv = NEWSV(93, send - start); /* sv for the constant */
842 register char *s = start; /* start of the constant */
843 register char *d = SvPVX(sv); /* destination for copies */
844 bool dorange = FALSE; /* are we in a translit range? */
847 /* leaveit is the set of acceptably-backslashed characters */
850 ? "\\.^$@AGZdDwWsSbB+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
853 while (s < send || dorange) {
854 /* get transliterations out of the way (they're most literal) */
855 if (PL_lex_inwhat == OP_TRANS) {
856 /* expand a range A-Z to the full set of characters. AIE! */
858 I32 i; /* current expanded character */
859 I32 max; /* last character in range */
861 i = d - SvPVX(sv); /* remember current offset */
862 SvGROW(sv, SvLEN(sv) + 256); /* expand the sv -- there'll never be more'n 256 chars in a range for it to grow by */
863 d = SvPVX(sv) + i; /* restore d after the grow potentially has changed the ptr */
864 d -= 2; /* eat the first char and the - */
866 max = (U8)d[1]; /* last char in range */
868 for (i = (U8)*d; i <= max; i++)
871 /* mark the range as done, and continue */
876 /* range begins (ignore - as first or last char) */
877 else if (*s == '-' && s+1 < send && s != start) {
883 /* if we get here, we're not doing a transliteration */
885 /* skip for regexp comments /(?#comment)/ */
886 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
888 while (s < send && *s != ')')
890 } else if (s[2] == '{') { /* This should march regcomp.c */
892 char *regparse = s + 3;
895 while (count && (c = *regparse)) {
896 if (c == '\\' && regparse[1])
904 if (*regparse == ')')
907 yyerror("Sequence (?{...}) not terminated or not {}-balanced");
908 while (s < regparse && *s != ')')
913 /* likewise skip #-initiated comments in //x patterns */
914 else if (*s == '#' && PL_lex_inpat &&
915 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
916 while (s+1 < send && *s != '\n')
920 /* check for embedded arrays (@foo, @:foo, @'foo, @{foo}, @$foo) */
921 else if (*s == '@' && s[1] && (isALNUM(s[1]) || strchr(":'{$", s[1])))
924 /* check for embedded scalars. only stop if we're sure it's a
927 else if (*s == '$') {
928 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
930 if (s + 1 < send && !strchr("()| \n\t", s[1]))
931 break; /* in regexp, $ might be tail anchor */
935 if (*s == '\\' && s+1 < send) {
938 /* some backslashes we leave behind */
939 if (*s && strchr(leaveit, *s)) {
945 /* deprecate \1 in strings and substitution replacements */
946 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
947 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
950 warn("\\%c better written as $%c", *s, *s);
955 /* string-change backslash escapes */
956 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
961 /* if we get here, it's either a quoted -, or a digit */
964 /* quoted - in transliterations */
966 if (PL_lex_inwhat == OP_TRANS) {
971 /* default action is to copy the quoted character */
976 /* \132 indicates an octal constant */
977 case '0': case '1': case '2': case '3':
978 case '4': case '5': case '6': case '7':
979 *d++ = scan_oct(s, 3, &len);
983 /* \x24 indicates a hex constant */
985 *d++ = scan_hex(++s, 2, &len);
989 /* \c is a control character */
996 /* printf-style backslashes, formfeeds, newlines, etc */
1022 } /* end if (backslash) */
1025 } /* while loop to process each character */
1027 /* terminate the string and set up the sv */
1029 SvCUR_set(sv, d - SvPVX(sv));
1032 /* shrink the sv if we allocated more than we used */
1033 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1034 SvLEN_set(sv, SvCUR(sv) + 1);
1035 Renew(SvPVX(sv), SvLEN(sv), char);
1038 /* return the substring (via yylval) only if we parsed anything */
1039 if (s > PL_bufptr) {
1040 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1041 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1043 ( PL_lex_inwhat == OP_TRANS
1045 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1048 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1054 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1056 intuit_more(register char *s)
1058 if (PL_lex_brackets)
1060 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1062 if (*s != '{' && *s != '[')
1067 /* In a pattern, so maybe we have {n,m}. */
1084 /* On the other hand, maybe we have a character class */
1087 if (*s == ']' || *s == '^')
1090 int weight = 2; /* let's weigh the evidence */
1092 unsigned char un_char = 255, last_un_char;
1093 char *send = strchr(s,']');
1094 char tmpbuf[sizeof PL_tokenbuf * 4];
1096 if (!send) /* has to be an expression */
1099 Zero(seen,256,char);
1102 else if (isDIGIT(*s)) {
1104 if (isDIGIT(s[1]) && s[2] == ']')
1110 for (; s < send; s++) {
1111 last_un_char = un_char;
1112 un_char = (unsigned char)*s;
1117 weight -= seen[un_char] * 10;
1118 if (isALNUM(s[1])) {
1119 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1120 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1125 else if (*s == '$' && s[1] &&
1126 strchr("[#!%*<>()-=",s[1])) {
1127 if (/*{*/ strchr("])} =",s[2]))
1136 if (strchr("wds]",s[1]))
1138 else if (seen['\''] || seen['"'])
1140 else if (strchr("rnftbxcav",s[1]))
1142 else if (isDIGIT(s[1])) {
1144 while (s[1] && isDIGIT(s[1]))
1154 if (strchr("aA01! ",last_un_char))
1156 if (strchr("zZ79~",s[1]))
1158 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1159 weight -= 5; /* cope with negative subscript */
1162 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1163 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1168 if (keyword(tmpbuf, d - tmpbuf))
1171 if (un_char == last_un_char + 1)
1173 weight -= seen[un_char];
1178 if (weight >= 0) /* probably a character class */
1186 intuit_method(char *start, GV *gv)
1188 char *s = start + (*start == '$');
1189 char tmpbuf[sizeof PL_tokenbuf];
1197 if ((cv = GvCVu(gv))) {
1198 char *proto = SvPVX(cv);
1208 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1209 if (*start == '$') {
1210 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1215 return *s == '(' ? FUNCMETH : METHOD;
1217 if (!keyword(tmpbuf, len)) {
1218 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1223 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1224 if (indirgv && GvCVu(indirgv))
1226 /* filehandle or package name makes it a method */
1227 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1229 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1230 return 0; /* no assumptions -- "=>" quotes bearword */
1232 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1234 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1238 return *s == '(' ? FUNCMETH : METHOD;
1248 char *pdb = PerlEnv_getenv("PERL5DB");
1252 SETERRNO(0,SS$_NORMAL);
1253 return "BEGIN { require 'perl5db.pl' }";
1259 /* Encoded script support. filter_add() effectively inserts a
1260 * 'pre-processing' function into the current source input stream.
1261 * Note that the filter function only applies to the current source file
1262 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1264 * The datasv parameter (which may be NULL) can be used to pass
1265 * private data to this instance of the filter. The filter function
1266 * can recover the SV using the FILTER_DATA macro and use it to
1267 * store private buffers and state information.
1269 * The supplied datasv parameter is upgraded to a PVIO type
1270 * and the IoDIRP field is used to store the function pointer.
1271 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1272 * private use must be set using malloc'd pointers.
1274 static int filter_debug = 0;
1277 filter_add(filter_t funcp, SV *datasv)
1279 if (!funcp){ /* temporary handy debugging hack to be deleted */
1280 filter_debug = atoi((char*)datasv);
1283 if (!PL_rsfp_filters)
1284 PL_rsfp_filters = newAV();
1286 datasv = NEWSV(255,0);
1287 if (!SvUPGRADE(datasv, SVt_PVIO))
1288 die("Can't upgrade filter_add data to SVt_PVIO");
1289 IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
1291 warn("filter_add func %p (%s)", funcp, SvPV(datasv,PL_na));
1292 av_unshift(PL_rsfp_filters, 1);
1293 av_store(PL_rsfp_filters, 0, datasv) ;
1298 /* Delete most recently added instance of this filter function. */
1300 filter_del(filter_t funcp)
1303 warn("filter_del func %p", funcp);
1304 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
1306 /* if filter is on top of stack (usual case) just pop it off */
1307 if (IoDIRP(FILTER_DATA(AvFILLp(PL_rsfp_filters))) == (void*)funcp){
1308 sv_free(av_pop(PL_rsfp_filters));
1312 /* we need to search for the correct entry and clear it */
1313 die("filter_del can only delete in reverse order (currently)");
1317 /* Invoke the n'th filter function for the current rsfp. */
1319 filter_read(int idx, SV *buf_sv, int maxlen)
1322 /* 0 = read one text line */
1327 if (!PL_rsfp_filters)
1329 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
1330 /* Provide a default input filter to make life easy. */
1331 /* Note that we append to the line. This is handy. */
1333 warn("filter_read %d: from rsfp\n", idx);
1337 int old_len = SvCUR(buf_sv) ;
1339 /* ensure buf_sv is large enough */
1340 SvGROW(buf_sv, old_len + maxlen) ;
1341 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1342 if (PerlIO_error(PL_rsfp))
1343 return -1; /* error */
1345 return 0 ; /* end of file */
1347 SvCUR_set(buf_sv, old_len + len) ;
1350 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
1351 if (PerlIO_error(PL_rsfp))
1352 return -1; /* error */
1354 return 0 ; /* end of file */
1357 return SvCUR(buf_sv);
1359 /* Skip this filter slot if filter has been deleted */
1360 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
1362 warn("filter_read %d: skipped (filter deleted)\n", idx);
1363 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1365 /* Get function pointer hidden within datasv */
1366 funcp = (filter_t)IoDIRP(datasv);
1368 warn("filter_read %d: via function %p (%s)\n",
1369 idx, funcp, SvPV(datasv,PL_na));
1370 /* Call function. The function is expected to */
1371 /* call "FILTER_READ(idx+1, buf_sv)" first. */
1372 /* Return: <0:error, =0:eof, >0:not eof */
1373 return (*funcp)(PERL_OBJECT_THIS_ idx, buf_sv, maxlen);
1377 filter_gets(register SV *sv, register PerlIO *fp, STRLEN append)
1380 if (!PL_rsfp_filters) {
1381 filter_add(win32_textfilter,NULL);
1384 if (PL_rsfp_filters) {
1387 SvCUR_set(sv, 0); /* start with empty line */
1388 if (FILTER_READ(0, sv, 0) > 0)
1389 return ( SvPVX(sv) ) ;
1394 return (sv_gets(sv, fp, append));
1399 static char* exp_name[] =
1400 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "TERMBLOCK" };
1403 EXT int yychar; /* last token */
1408 Works out what to call the token just pulled out of the input
1409 stream. The yacc parser takes care of taking the ops we return and
1410 stitching them into a tree.
1416 if read an identifier
1417 if we're in a my declaration
1418 croak if they tried to say my($foo::bar)
1419 build the ops for a my() declaration
1420 if it's an access to a my() variable
1421 are we in a sort block?
1422 croak if my($a); $a <=> $b
1423 build ops for access to a my() variable
1424 if in a dq string, and they've said @foo and we can't find @foo
1426 build ops for a bareword
1427 if we already built the token before, use it.
1441 /* check if there's an identifier for us to look at */
1442 if (PL_pending_ident) {
1443 /* pit holds the identifier we read and pending_ident is reset */
1444 char pit = PL_pending_ident;
1445 PL_pending_ident = 0;
1447 /* if we're in a my(), we can't allow dynamics here.
1448 $foo'bar has already been turned into $foo::bar, so
1449 just check for colons.
1451 if it's a legal name, the OP is a PADANY.
1454 if (strchr(PL_tokenbuf,':'))
1455 croak(no_myglob,PL_tokenbuf);
1457 yylval.opval = newOP(OP_PADANY, 0);
1458 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
1463 build the ops for accesses to a my() variable.
1465 Deny my($a) or my($b) in a sort block, *if* $a or $b is
1466 then used in a comparison. This catches most, but not
1467 all cases. For instance, it catches
1468 sort { my($a); $a <=> $b }
1470 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
1471 (although why you'd do that is anyone's guess).
1474 if (!strchr(PL_tokenbuf,':')) {
1476 /* Check for single character per-thread SVs */
1477 if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
1478 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
1479 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
1481 yylval.opval = newOP(OP_THREADSV, 0);
1482 yylval.opval->op_targ = tmp;
1485 #endif /* USE_THREADS */
1486 if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
1487 /* if it's a sort block and they're naming $a or $b */
1488 if (PL_last_lop_op == OP_SORT &&
1489 PL_tokenbuf[0] == '$' &&
1490 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
1493 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
1494 d < PL_bufend && *d != '\n';
1497 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
1498 croak("Can't use \"my %s\" in sort comparison",
1504 yylval.opval = newOP(OP_PADANY, 0);
1505 yylval.opval->op_targ = tmp;
1511 Whine if they've said @foo in a doublequoted string,
1512 and @foo isn't a variable we can find in the symbol
1515 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
1516 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
1517 if (!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
1518 yyerror(form("In string, %s now must be written as \\%s",
1519 PL_tokenbuf, PL_tokenbuf));
1522 /* build ops for a bareword */
1523 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
1524 yylval.opval->op_private = OPpCONST_ENTERED;
1525 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
1526 ((PL_tokenbuf[0] == '$') ? SVt_PV
1527 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
1532 /* no identifier pending identification */
1534 switch (PL_lex_state) {
1536 case LEX_NORMAL: /* Some compilers will produce faster */
1537 case LEX_INTERPNORMAL: /* code if we comment these out. */
1541 /* when we're already built the next token, just pull it out the queue */
1544 yylval = PL_nextval[PL_nexttoke];
1546 PL_lex_state = PL_lex_defer;
1547 PL_expect = PL_lex_expect;
1548 PL_lex_defer = LEX_NORMAL;
1550 return(PL_nexttype[PL_nexttoke]);
1552 /* interpolated case modifiers like \L \U, including \Q and \E.
1553 when we get here, PL_bufptr is at the \
1555 case LEX_INTERPCASEMOD:
1557 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
1558 croak("panic: INTERPCASEMOD");
1560 /* handle \E or end of string */
1561 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
1565 if (PL_lex_casemods) {
1566 oldmod = PL_lex_casestack[--PL_lex_casemods];
1567 PL_lex_casestack[PL_lex_casemods] = '\0';
1569 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
1571 PL_lex_state = LEX_INTERPCONCAT;
1575 if (PL_bufptr != PL_bufend)
1577 PL_lex_state = LEX_INTERPCONCAT;
1582 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
1583 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
1584 if (strchr("LU", *s) &&
1585 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
1587 PL_lex_casestack[--PL_lex_casemods] = '\0';
1590 if (PL_lex_casemods > 10) {
1591 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
1592 if (newlb != PL_lex_casestack) {
1594 PL_lex_casestack = newlb;
1597 PL_lex_casestack[PL_lex_casemods++] = *s;
1598 PL_lex_casestack[PL_lex_casemods] = '\0';
1599 PL_lex_state = LEX_INTERPCONCAT;
1600 PL_nextval[PL_nexttoke].ival = 0;
1603 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
1605 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
1607 PL_nextval[PL_nexttoke].ival = OP_LC;
1609 PL_nextval[PL_nexttoke].ival = OP_UC;
1611 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
1613 croak("panic: yylex");
1616 if (PL_lex_starts) {
1625 case LEX_INTERPPUSH:
1626 return sublex_push();
1628 case LEX_INTERPSTART:
1629 if (PL_bufptr == PL_bufend)
1630 return sublex_done();
1632 PL_lex_dojoin = (*PL_bufptr == '@');
1633 PL_lex_state = LEX_INTERPNORMAL;
1634 if (PL_lex_dojoin) {
1635 PL_nextval[PL_nexttoke].ival = 0;
1638 PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
1639 PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
1640 force_next(PRIVATEREF);
1642 force_ident("\"", '$');
1643 #endif /* USE_THREADS */
1644 PL_nextval[PL_nexttoke].ival = 0;
1646 PL_nextval[PL_nexttoke].ival = 0;
1648 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
1651 if (PL_lex_starts++) {
1657 case LEX_INTERPENDMAYBE:
1658 if (intuit_more(PL_bufptr)) {
1659 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
1665 if (PL_lex_dojoin) {
1666 PL_lex_dojoin = FALSE;
1667 PL_lex_state = LEX_INTERPCONCAT;
1671 case LEX_INTERPCONCAT:
1673 if (PL_lex_brackets)
1674 croak("panic: INTERPCONCAT");
1676 if (PL_bufptr == PL_bufend)
1677 return sublex_done();
1679 if (SvIVX(PL_linestr) == '\'') {
1680 SV *sv = newSVsv(PL_linestr);
1683 else if ( PL_hints & HINT_NEW_RE )
1684 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
1685 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1689 s = scan_const(PL_bufptr);
1691 PL_lex_state = LEX_INTERPCASEMOD;
1693 PL_lex_state = LEX_INTERPSTART;
1696 if (s != PL_bufptr) {
1697 PL_nextval[PL_nexttoke] = yylval;
1700 if (PL_lex_starts++)
1710 PL_lex_state = LEX_NORMAL;
1711 s = scan_formline(PL_bufptr);
1712 if (!PL_lex_formbrack)
1718 PL_oldoldbufptr = PL_oldbufptr;
1721 PerlIO_printf(PerlIO_stderr(), "### Tokener expecting %s at %s\n", exp_name[PL_expect], s);
1727 croak("Unrecognized character \\%03o", *s & 255);
1730 goto fake_eof; /* emulate EOF on ^D or ^Z */
1735 if (PL_lex_brackets)
1736 yyerror("Missing right bracket");
1739 if (s++ < PL_bufend)
1740 goto retry; /* ignore stray nulls */
1743 if (!PL_in_eval && !PL_preambled) {
1744 PL_preambled = TRUE;
1745 sv_setpv(PL_linestr,incl_perldb());
1746 if (SvCUR(PL_linestr))
1747 sv_catpv(PL_linestr,";");
1749 while(AvFILLp(PL_preambleav) >= 0) {
1750 SV *tmpsv = av_shift(PL_preambleav);
1751 sv_catsv(PL_linestr, tmpsv);
1752 sv_catpv(PL_linestr, ";");
1755 sv_free((SV*)PL_preambleav);
1756 PL_preambleav = NULL;
1758 if (PL_minus_n || PL_minus_p) {
1759 sv_catpv(PL_linestr, "LINE: while (<>) {");
1761 sv_catpv(PL_linestr,"chomp;");
1763 GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
1765 GvIMPORTED_AV_on(gv);
1767 if (strchr("/'\"", *PL_splitstr)
1768 && strchr(PL_splitstr + 1, *PL_splitstr))
1769 sv_catpvf(PL_linestr, "@F=split(%s);", PL_splitstr);
1772 s = "'~#\200\1'"; /* surely one char is unused...*/
1773 while (s[1] && strchr(PL_splitstr, *s)) s++;
1775 sv_catpvf(PL_linestr, "@F=split(%s%c",
1776 "q" + (delim == '\''), delim);
1777 for (s = PL_splitstr; *s; s++) {
1779 sv_catpvn(PL_linestr, "\\", 1);
1780 sv_catpvn(PL_linestr, s, 1);
1782 sv_catpvf(PL_linestr, "%c);", delim);
1786 sv_catpv(PL_linestr,"@F=split(' ');");
1789 sv_catpv(PL_linestr, "\n");
1790 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1791 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1792 if (PERLDB_LINE && PL_curstash != PL_debstash) {
1793 SV *sv = NEWSV(85,0);
1795 sv_upgrade(sv, SVt_PVMG);
1796 sv_setsv(sv,PL_linestr);
1797 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
1802 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
1805 if (PL_preprocess && !PL_in_eval)
1806 (void)PerlProc_pclose(PL_rsfp);
1807 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
1808 PerlIO_clearerr(PL_rsfp);
1810 (void)PerlIO_close(PL_rsfp);
1813 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
1814 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
1815 sv_catpv(PL_linestr,";}");
1816 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1817 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1818 PL_minus_n = PL_minus_p = 0;
1821 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1822 sv_setpv(PL_linestr,"");
1823 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
1826 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
1827 PL_doextract = FALSE;
1829 /* Incest with pod. */
1830 if (*s == '=' && strnEQ(s, "=cut", 4)) {
1831 sv_setpv(PL_linestr, "");
1832 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1833 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1834 PL_doextract = FALSE;
1838 } while (PL_doextract);
1839 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
1840 if (PERLDB_LINE && PL_curstash != PL_debstash) {
1841 SV *sv = NEWSV(85,0);
1843 sv_upgrade(sv, SVt_PVMG);
1844 sv_setsv(sv,PL_linestr);
1845 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
1847 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1848 if (PL_curcop->cop_line == 1) {
1849 while (s < PL_bufend && isSPACE(*s))
1851 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
1855 if (*s == '#' && *(s+1) == '!')
1857 #ifdef ALTERNATE_SHEBANG
1859 static char as[] = ALTERNATE_SHEBANG;
1860 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
1861 d = s + (sizeof(as) - 1);
1863 #endif /* ALTERNATE_SHEBANG */
1872 while (*d && !isSPACE(*d))
1876 #ifdef ARG_ZERO_IS_SCRIPT
1877 if (ipathend > ipath) {
1879 * HP-UX (at least) sets argv[0] to the script name,
1880 * which makes $^X incorrect. And Digital UNIX and Linux,
1881 * at least, set argv[0] to the basename of the Perl
1882 * interpreter. So, having found "#!", we'll set it right.
1884 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
1885 assert(SvPOK(x) || SvGMAGICAL(x));
1886 if (sv_eq(x, GvSV(PL_curcop->cop_filegv))) {
1887 sv_setpvn(x, ipath, ipathend - ipath);
1890 TAINT_NOT; /* $^X is always tainted, but that's OK */
1892 #endif /* ARG_ZERO_IS_SCRIPT */
1897 d = instr(s,"perl -");
1899 d = instr(s,"perl");
1900 #ifdef ALTERNATE_SHEBANG
1902 * If the ALTERNATE_SHEBANG on this system starts with a
1903 * character that can be part of a Perl expression, then if
1904 * we see it but not "perl", we're probably looking at the
1905 * start of Perl code, not a request to hand off to some
1906 * other interpreter. Similarly, if "perl" is there, but
1907 * not in the first 'word' of the line, we assume the line
1908 * contains the start of the Perl program.
1910 if (d && *s != '#') {
1912 while (*c && !strchr("; \t\r\n\f\v#", *c))
1915 d = Nullch; /* "perl" not in first word; ignore */
1917 *s = '#'; /* Don't try to parse shebang line */
1919 #endif /* ALTERNATE_SHEBANG */
1924 !instr(s,"indir") &&
1925 instr(PL_origargv[0],"perl"))
1931 while (s < PL_bufend && isSPACE(*s))
1933 if (s < PL_bufend) {
1934 Newz(899,newargv,PL_origargc+3,char*);
1936 while (s < PL_bufend && !isSPACE(*s))
1939 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
1942 newargv = PL_origargv;
1944 execv(ipath, newargv);
1945 croak("Can't exec %s", ipath);
1948 U32 oldpdb = PL_perldb;
1949 bool oldn = PL_minus_n;
1950 bool oldp = PL_minus_p;
1952 while (*d && !isSPACE(*d)) d++;
1953 while (*d == ' ' || *d == '\t') d++;
1957 if (*d == 'M' || *d == 'm') {
1959 while (*d && !isSPACE(*d)) d++;
1960 croak("Too late for \"-%.*s\" option",
1963 d = moreswitches(d);
1965 if (PERLDB_LINE && !oldpdb ||
1966 ( PL_minus_n || PL_minus_p ) && !(oldn || oldp) )
1967 /* if we have already added "LINE: while (<>) {",
1968 we must not do it again */
1970 sv_setpv(PL_linestr, "");
1971 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1972 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1973 PL_preambled = FALSE;
1975 (void)gv_fetchfile(PL_origfilename);
1982 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
1984 PL_lex_state = LEX_FORMLINE;
1989 #ifdef PERL_STRICT_CR
1990 warn("Illegal character \\%03o (carriage return)", '\r');
1992 "(Maybe you didn't strip carriage returns after a network transfer?)\n");
1994 case ' ': case '\t': case '\f': case 013:
1999 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2001 while (s < d && *s != '\n')
2006 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2008 PL_lex_state = LEX_FORMLINE;
2018 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2023 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2026 if (strnEQ(s,"=>",2)) {
2027 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2028 OPERATOR('-'); /* unary minus */
2030 PL_last_uni = PL_oldbufptr;
2031 PL_last_lop_op = OP_FTEREAD; /* good enough */
2033 case 'r': FTST(OP_FTEREAD);
2034 case 'w': FTST(OP_FTEWRITE);
2035 case 'x': FTST(OP_FTEEXEC);
2036 case 'o': FTST(OP_FTEOWNED);
2037 case 'R': FTST(OP_FTRREAD);
2038 case 'W': FTST(OP_FTRWRITE);
2039 case 'X': FTST(OP_FTREXEC);
2040 case 'O': FTST(OP_FTROWNED);
2041 case 'e': FTST(OP_FTIS);
2042 case 'z': FTST(OP_FTZERO);
2043 case 's': FTST(OP_FTSIZE);
2044 case 'f': FTST(OP_FTFILE);
2045 case 'd': FTST(OP_FTDIR);
2046 case 'l': FTST(OP_FTLINK);
2047 case 'p': FTST(OP_FTPIPE);
2048 case 'S': FTST(OP_FTSOCK);
2049 case 'u': FTST(OP_FTSUID);
2050 case 'g': FTST(OP_FTSGID);
2051 case 'k': FTST(OP_FTSVTX);
2052 case 'b': FTST(OP_FTBLK);
2053 case 'c': FTST(OP_FTCHR);
2054 case 't': FTST(OP_FTTTY);
2055 case 'T': FTST(OP_FTTEXT);
2056 case 'B': FTST(OP_FTBINARY);
2057 case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2058 case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2059 case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
2061 croak("Unrecognized file test: -%c", (int)tmp);
2068 if (PL_expect == XOPERATOR)
2073 else if (*s == '>') {
2076 if (isIDFIRST(*s)) {
2077 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2085 if (PL_expect == XOPERATOR)
2088 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2090 OPERATOR('-'); /* unary minus */
2097 if (PL_expect == XOPERATOR)
2102 if (PL_expect == XOPERATOR)
2105 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2111 if (PL_expect != XOPERATOR) {
2112 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2113 PL_expect = XOPERATOR;
2114 force_ident(PL_tokenbuf, '*');
2127 if (PL_expect == XOPERATOR) {
2131 PL_tokenbuf[0] = '%';
2132 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2133 if (!PL_tokenbuf[1]) {
2135 yyerror("Final % should be \\% or %name");
2138 PL_pending_ident = '%';
2160 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
2161 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
2166 if (PL_curcop->cop_line < PL_copline)
2167 PL_copline = PL_curcop->cop_line;
2178 if (PL_lex_brackets <= 0)
2179 yyerror("Unmatched right bracket");
2182 if (PL_lex_state == LEX_INTERPNORMAL) {
2183 if (PL_lex_brackets == 0) {
2184 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
2185 PL_lex_state = LEX_INTERPEND;
2192 if (PL_lex_brackets > 100) {
2193 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
2194 if (newlb != PL_lex_brackstack) {
2196 PL_lex_brackstack = newlb;
2199 switch (PL_expect) {
2201 if (PL_lex_formbrack) {
2205 if (PL_oldoldbufptr == PL_last_lop)
2206 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2208 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2209 OPERATOR(HASHBRACK);
2211 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2214 PL_tokenbuf[0] = '\0';
2215 if (d < PL_bufend && *d == '-') {
2216 PL_tokenbuf[0] = '-';
2218 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2221 if (d < PL_bufend && isIDFIRST(*d)) {
2222 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2224 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2227 char minus = (PL_tokenbuf[0] == '-');
2228 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2235 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
2239 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2244 if (PL_oldoldbufptr == PL_last_lop)
2245 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2247 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2250 OPERATOR(HASHBRACK);
2251 /* This hack serves to disambiguate a pair of curlies
2252 * as being a block or an anon hash. Normally, expectation
2253 * determines that, but in cases where we're not in a
2254 * position to expect anything in particular (like inside
2255 * eval"") we have to resolve the ambiguity. This code
2256 * covers the case where the first term in the curlies is a
2257 * quoted string. Most other cases need to be explicitly
2258 * disambiguated by prepending a `+' before the opening
2259 * curly in order to force resolution as an anon hash.
2261 * XXX should probably propagate the outer expectation
2262 * into eval"" to rely less on this hack, but that could
2263 * potentially break current behavior of eval"".
2267 if (*s == '\'' || *s == '"' || *s == '`') {
2268 /* common case: get past first string, handling escapes */
2269 for (t++; t < PL_bufend && *t != *s;)
2270 if (*t++ == '\\' && (*t == '\\' || *t == *s))
2274 else if (*s == 'q') {
2277 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
2278 && !isALNUM(*t)))) {
2280 char open, close, term;
2283 while (t < PL_bufend && isSPACE(*t))
2287 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
2291 for (t++; t < PL_bufend; t++) {
2292 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
2294 else if (*t == open)
2298 for (t++; t < PL_bufend; t++) {
2299 if (*t == '\\' && t+1 < PL_bufend)
2301 else if (*t == close && --brackets <= 0)
2303 else if (*t == open)
2309 else if (isALPHA(*s)) {
2310 for (t++; t < PL_bufend && isALNUM(*t); t++) ;
2312 while (t < PL_bufend && isSPACE(*t))
2314 /* if comma follows first term, call it an anon hash */
2315 /* XXX it could be a comma expression with loop modifiers */
2316 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
2317 || (*t == '=' && t[1] == '>')))
2318 OPERATOR(HASHBRACK);
2319 if (PL_expect == XREF)
2322 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
2328 yylval.ival = PL_curcop->cop_line;
2329 if (isSPACE(*s) || *s == '#')
2330 PL_copline = NOLINE; /* invalidate current command line number */
2335 if (PL_lex_brackets <= 0)
2336 yyerror("Unmatched right bracket");
2338 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
2339 if (PL_lex_brackets < PL_lex_formbrack)
2340 PL_lex_formbrack = 0;
2341 if (PL_lex_state == LEX_INTERPNORMAL) {
2342 if (PL_lex_brackets == 0) {
2343 if (PL_lex_fakebrack) {
2344 PL_lex_state = LEX_INTERPEND;
2346 return yylex(); /* ignore fake brackets */
2348 if (*s == '-' && s[1] == '>')
2349 PL_lex_state = LEX_INTERPENDMAYBE;
2350 else if (*s != '[' && *s != '{')
2351 PL_lex_state = LEX_INTERPEND;
2354 if (PL_lex_brackets < PL_lex_fakebrack) {
2356 PL_lex_fakebrack = 0;
2357 return yylex(); /* ignore fake brackets */
2367 if (PL_expect == XOPERATOR) {
2368 if (PL_dowarn && isALPHA(*s) && PL_bufptr == PL_linestart) {
2369 PL_curcop->cop_line--;
2371 PL_curcop->cop_line++;
2376 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2378 PL_expect = XOPERATOR;
2379 force_ident(PL_tokenbuf, '&');
2383 yylval.ival = (OPpENTERSUB_AMPER<<8);
2402 if (PL_dowarn && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
2403 warn("Reversed %c= operator",(int)tmp);
2405 if (PL_expect == XSTATE && isALPHA(tmp) &&
2406 (s == PL_linestart+1 || s[-2] == '\n') )
2408 if (PL_in_eval && !PL_rsfp) {
2413 if (strnEQ(s,"=cut",4)) {
2427 PL_doextract = TRUE;
2430 if (PL_lex_brackets < PL_lex_formbrack) {
2432 for (t = s; *t == ' ' || *t == '\t'; t++) ;
2433 if (*t == '\n' || *t == '#') {
2451 if (PL_expect != XOPERATOR) {
2452 if (s[1] != '<' && !strchr(s,'>'))
2455 s = scan_heredoc(s);
2457 s = scan_inputsymbol(s);
2458 TERM(sublex_start());
2463 SHop(OP_LEFT_SHIFT);
2477 SHop(OP_RIGHT_SHIFT);
2486 if (PL_expect == XOPERATOR) {
2487 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2490 return ','; /* grandfather non-comma-format format */
2494 if (s[1] == '#' && (isALPHA(s[2]) || strchr("_{$:", s[2]))) {
2495 if (PL_expect == XOPERATOR)
2496 no_op("Array length", PL_bufptr);
2497 PL_tokenbuf[0] = '@';
2498 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2500 if (!PL_tokenbuf[1])
2502 PL_expect = XOPERATOR;
2503 PL_pending_ident = '#';
2507 if (PL_expect == XOPERATOR)
2508 no_op("Scalar", PL_bufptr);
2509 PL_tokenbuf[0] = '$';
2510 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2511 if (!PL_tokenbuf[1]) {
2513 yyerror("Final $ should be \\$ or $name");
2517 /* This kludge not intended to be bulletproof. */
2518 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
2519 yylval.opval = newSVOP(OP_CONST, 0,
2520 newSViv((IV)PL_compiling.cop_arybase));
2521 yylval.opval->op_private = OPpCONST_ARYBASE;
2526 if (PL_lex_state == LEX_NORMAL)
2529 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2532 PL_tokenbuf[0] = '@';
2535 isSPACE(*t) || isALNUM(*t) || *t == '$';
2538 PL_bufptr = skipspace(PL_bufptr);
2539 while (t < PL_bufend && *t != ']')
2541 warn("Multidimensional syntax %.*s not supported",
2542 (t - PL_bufptr) + 1, PL_bufptr);
2546 else if (*s == '{') {
2547 PL_tokenbuf[0] = '%';
2548 if (PL_dowarn && strEQ(PL_tokenbuf+1, "SIG") &&
2549 (t = strchr(s, '}')) && (t = strchr(t, '=')))
2551 char tmpbuf[sizeof PL_tokenbuf];
2553 for (t++; isSPACE(*t); t++) ;
2554 if (isIDFIRST(*t)) {
2555 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
2556 if (*t != '(' && perl_get_cv(tmpbuf, FALSE))
2557 warn("You need to quote \"%s\"", tmpbuf);
2563 PL_expect = XOPERATOR;
2564 if (PL_lex_state == LEX_NORMAL && isSPACE(*d)) {
2565 bool islop = (PL_last_lop == PL_oldoldbufptr);
2566 if (!islop || PL_last_lop_op == OP_GREPSTART)
2567 PL_expect = XOPERATOR;
2568 else if (strchr("$@\"'`q", *s))
2569 PL_expect = XTERM; /* e.g. print $fh "foo" */
2570 else if (strchr("&*<%", *s) && isIDFIRST(s[1]))
2571 PL_expect = XTERM; /* e.g. print $fh &sub */
2572 else if (isIDFIRST(*s)) {
2573 char tmpbuf[sizeof PL_tokenbuf];
2574 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2575 if (tmp = keyword(tmpbuf, len)) {
2576 /* binary operators exclude handle interpretations */
2588 PL_expect = XTERM; /* e.g. print $fh length() */
2593 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
2594 if (gv && GvCVu(gv))
2595 PL_expect = XTERM; /* e.g. print $fh subr() */
2598 else if (isDIGIT(*s))
2599 PL_expect = XTERM; /* e.g. print $fh 3 */
2600 else if (*s == '.' && isDIGIT(s[1]))
2601 PL_expect = XTERM; /* e.g. print $fh .3 */
2602 else if (strchr("/?-+", *s) && !isSPACE(s[1]))
2603 PL_expect = XTERM; /* e.g. print $fh -1 */
2604 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]))
2605 PL_expect = XTERM; /* print $fh <<"EOF" */
2607 PL_pending_ident = '$';
2611 if (PL_expect == XOPERATOR)
2613 PL_tokenbuf[0] = '@';
2614 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2615 if (!PL_tokenbuf[1]) {
2617 yyerror("Final @ should be \\@ or @name");
2620 if (PL_lex_state == LEX_NORMAL)
2622 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2624 PL_tokenbuf[0] = '%';
2626 /* Warn about @ where they meant $. */
2628 if (*s == '[' || *s == '{') {
2630 while (*t && (isALNUM(*t) || strchr(" \t$#+-'\"", *t)))
2632 if (*t == '}' || *t == ']') {
2634 PL_bufptr = skipspace(PL_bufptr);
2635 warn("Scalar value %.*s better written as $%.*s",
2636 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
2641 PL_pending_ident = '@';
2644 case '/': /* may either be division or pattern */
2645 case '?': /* may either be conditional or pattern */
2646 if (PL_expect != XOPERATOR) {
2647 /* Disable warning on "study /blah/" */
2648 if (PL_oldoldbufptr == PL_last_uni
2649 && (*PL_last_uni != 's' || s - PL_last_uni < 5
2650 || memNE(PL_last_uni, "study", 5) || isALNUM(PL_last_uni[5])))
2652 s = scan_pat(s,OP_MATCH);
2653 TERM(sublex_start());
2661 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack && s[1] == '\n' &&
2662 (s == PL_linestart || s[-1] == '\n') ) {
2663 PL_lex_formbrack = 0;
2667 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
2673 yylval.ival = OPf_SPECIAL;
2679 if (PL_expect != XOPERATOR)
2684 case '0': case '1': case '2': case '3': case '4':
2685 case '5': case '6': case '7': case '8': case '9':
2687 if (PL_expect == XOPERATOR)
2693 if (PL_expect == XOPERATOR) {
2694 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2697 return ','; /* grandfather non-comma-format format */
2703 missingterm((char*)0);
2704 yylval.ival = OP_CONST;
2705 TERM(sublex_start());
2709 if (PL_expect == XOPERATOR) {
2710 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2713 return ','; /* grandfather non-comma-format format */
2719 missingterm((char*)0);
2720 yylval.ival = OP_CONST;
2721 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
2722 if (*d == '$' || *d == '@' || *d == '\\') {
2723 yylval.ival = OP_STRINGIFY;
2727 TERM(sublex_start());
2731 if (PL_expect == XOPERATOR)
2732 no_op("Backticks",s);
2734 missingterm((char*)0);
2735 yylval.ival = OP_BACKTICK;
2737 TERM(sublex_start());
2741 if (PL_dowarn && PL_lex_inwhat && isDIGIT(*s))
2742 warn("Can't use \\%c to mean $%c in expression", *s, *s);
2743 if (PL_expect == XOPERATOR)
2744 no_op("Backslash",s);
2748 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
2787 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2789 /* Some keywords can be followed by any delimiter, including ':' */
2790 tmp = (len == 1 && strchr("msyq", PL_tokenbuf[0]) ||
2791 len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
2792 (PL_tokenbuf[0] == 'q' &&
2793 strchr("qwxr", PL_tokenbuf[1]))));
2795 /* x::* is just a word, unless x is "CORE" */
2796 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
2800 while (d < PL_bufend && isSPACE(*d))
2801 d++; /* no comments skipped here, or s### is misparsed */
2803 /* Is this a label? */
2804 if (!tmp && PL_expect == XSTATE
2805 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
2807 yylval.pval = savepv(PL_tokenbuf);
2812 /* Check for keywords */
2813 tmp = keyword(PL_tokenbuf, len);
2815 /* Is this a word before a => operator? */
2816 if (strnEQ(d,"=>",2)) {
2818 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
2819 yylval.opval->op_private = OPpCONST_BARE;
2823 if (tmp < 0) { /* second-class keyword? */
2824 GV *ogv = Nullgv; /* override (winner) */
2825 GV *hgv = Nullgv; /* hidden (loser) */
2826 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
2828 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
2831 if (GvIMPORTED_CV(gv))
2833 else if (! CvMETHOD(cv))
2837 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
2838 (gv = *gvp) != (GV*)&PL_sv_undef &&
2839 GvCVu(gv) && GvIMPORTED_CV(gv))
2845 tmp = 0; /* overridden by import or by GLOBAL */
2848 && -tmp==KEY_lock /* XXX generalizable kludge */
2849 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
2851 tmp = 0; /* any sub overrides "weak" keyword */
2853 else { /* no override */
2857 if (PL_dowarn && hgv)
2858 warn("Ambiguous call resolved as CORE::%s(), %s",
2859 GvENAME(hgv), "qualify as such or use &");
2866 default: /* not a keyword */
2869 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
2871 /* Get the rest if it looks like a package qualifier */
2873 if (*s == '\'' || *s == ':' && s[1] == ':') {
2875 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
2878 croak("Bad name after %s%s", PL_tokenbuf,
2879 *s == '\'' ? "'" : "::");
2883 if (PL_expect == XOPERATOR) {
2884 if (PL_bufptr == PL_linestart) {
2885 PL_curcop->cop_line--;
2887 PL_curcop->cop_line++;
2890 no_op("Bareword",s);
2893 /* Look for a subroutine with this name in current package,
2894 unless name is "Foo::", in which case Foo is a bearword
2895 (and a package name). */
2898 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
2900 if (PL_dowarn && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
2901 warn("Bareword \"%s\" refers to nonexistent package",
2904 PL_tokenbuf[len] = '\0';
2911 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
2914 /* if we saw a global override before, get the right name */
2917 sv = newSVpv("CORE::GLOBAL::",14);
2918 sv_catpv(sv,PL_tokenbuf);
2921 sv = newSVpv(PL_tokenbuf,0);
2923 /* Presume this is going to be a bareword of some sort. */
2926 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2927 yylval.opval->op_private = OPpCONST_BARE;
2929 /* And if "Foo::", then that's what it certainly is. */
2934 /* See if it's the indirect object for a list operator. */
2936 if (PL_oldoldbufptr &&
2937 PL_oldoldbufptr < PL_bufptr &&
2938 (PL_oldoldbufptr == PL_last_lop || PL_oldoldbufptr == PL_last_uni) &&
2939 /* NO SKIPSPACE BEFORE HERE! */
2941 || ((opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF
2942 || (PL_last_lop_op == OP_ENTERSUB
2944 && PL_last_proto[PL_last_proto[0] == ';' ? 1 : 0] == '*')) )
2946 bool immediate_paren = *s == '(';
2948 /* (Now we can afford to cross potential line boundary.) */
2951 /* Two barewords in a row may indicate method call. */
2953 if ((isALPHA(*s) || *s == '$') && (tmp=intuit_method(s,gv)))
2956 /* If not a declared subroutine, it's an indirect object. */
2957 /* (But it's an indir obj regardless for sort.) */
2959 if ((PL_last_lop_op == OP_SORT ||
2960 (!immediate_paren && (!gv || !GvCVu(gv))) ) &&
2961 (PL_last_lop_op != OP_MAPSTART && PL_last_lop_op != OP_GREPSTART)){
2962 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
2967 /* If followed by a paren, it's certainly a subroutine. */
2969 PL_expect = XOPERATOR;
2973 if (gv && GvCVu(gv)) {
2974 for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
2975 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
2980 PL_nextval[PL_nexttoke].opval = yylval.opval;
2981 PL_expect = XOPERATOR;
2987 /* If followed by var or block, call it a method (unless sub) */
2989 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
2990 PL_last_lop = PL_oldbufptr;
2991 PL_last_lop_op = OP_METHOD;
2995 /* If followed by a bareword, see if it looks like indir obj. */
2997 if ((isALPHA(*s) || *s == '$') && (tmp = intuit_method(s,gv)))
3000 /* Not a method, so call it a subroutine (if defined) */
3002 if (gv && GvCVu(gv)) {
3004 if (lastchar == '-')
3005 warn("Ambiguous use of -%s resolved as -&%s()",
3006 PL_tokenbuf, PL_tokenbuf);
3007 PL_last_lop = PL_oldbufptr;
3008 PL_last_lop_op = OP_ENTERSUB;
3009 /* Check for a constant sub */
3011 if ((sv = cv_const_sv(cv))) {
3013 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3014 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3015 yylval.opval->op_private = 0;
3019 /* Resolve to GV now. */
3020 op_free(yylval.opval);
3021 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3022 /* Is there a prototype? */
3025 PL_last_proto = SvPV((SV*)cv, len);
3028 if (strEQ(PL_last_proto, "$"))
3030 if (*PL_last_proto == '&' && *s == '{') {
3031 sv_setpv(PL_subname,"__ANON__");
3035 PL_last_proto = NULL;
3036 PL_nextval[PL_nexttoke].opval = yylval.opval;
3042 if (PL_hints & HINT_STRICT_SUBS &&
3045 PL_last_lop_op != OP_TRUNCATE && /* S/F prototype in opcode.pl */
3046 PL_last_lop_op != OP_ACCEPT &&
3047 PL_last_lop_op != OP_PIPE_OP &&
3048 PL_last_lop_op != OP_SOCKPAIR)
3051 "Bareword \"%s\" not allowed while \"strict subs\" in use",
3056 /* Call it a bare word */
3060 if (lastchar != '-') {
3061 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3063 warn(warn_reserved, PL_tokenbuf);
3068 if (lastchar && strchr("*%&", lastchar)) {
3069 warn("Operator or semicolon missing before %c%s",
3070 lastchar, PL_tokenbuf);
3071 warn("Ambiguous use of %c resolved as operator %c",
3072 lastchar, lastchar);
3078 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3079 newSVsv(GvSV(PL_curcop->cop_filegv)));
3083 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3084 newSVpvf("%ld", (long)PL_curcop->cop_line));
3087 case KEY___PACKAGE__:
3088 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3090 ? newSVsv(PL_curstname)
3099 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3100 char *pname = "main";
3101 if (PL_tokenbuf[2] == 'D')
3102 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3103 gv = gv_fetchpv(form("%s::DATA", pname), TRUE, SVt_PVIO);
3106 GvIOp(gv) = newIO();
3107 IoIFP(GvIOp(gv)) = PL_rsfp;
3108 #if defined(HAS_FCNTL) && defined(F_SETFD)
3110 int fd = PerlIO_fileno(PL_rsfp);
3111 fcntl(fd,F_SETFD,fd >= 3);
3114 /* Mark this internal pseudo-handle as clean */
3115 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3117 IoTYPE(GvIOp(gv)) = '|';
3118 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
3119 IoTYPE(GvIOp(gv)) = '-';
3121 IoTYPE(GvIOp(gv)) = '<';
3132 if (PL_expect == XSTATE) {
3139 if (*s == ':' && s[1] == ':') {
3142 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3143 tmp = keyword(PL_tokenbuf, len);
3157 LOP(OP_ACCEPT,XTERM);
3163 LOP(OP_ATAN2,XTERM);
3172 LOP(OP_BLESS,XTERM);
3181 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
3198 if (!PL_cryptseen++)
3201 LOP(OP_CRYPT,XTERM);
3205 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
3206 if (*d != '0' && isDIGIT(*d))
3207 yywarn("chmod: mode argument is missing initial 0");
3209 LOP(OP_CHMOD,XTERM);
3212 LOP(OP_CHOWN,XTERM);
3215 LOP(OP_CONNECT,XTERM);
3231 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3235 PL_hints |= HINT_BLOCK_SCOPE;
3245 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3246 LOP(OP_DBMOPEN,XTERM);
3252 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3259 yylval.ival = PL_curcop->cop_line;
3273 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
3274 UNIBRACK(OP_ENTEREVAL);
3289 case KEY_endhostent:
3295 case KEY_endservent:
3298 case KEY_endprotoent:
3309 yylval.ival = PL_curcop->cop_line;
3311 if (PL_expect == XSTATE && isIDFIRST(*s)) {
3313 if ((PL_bufend - p) >= 3 &&
3314 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3318 croak("Missing $ on loop variable");
3323 LOP(OP_FORMLINE,XTERM);
3329 LOP(OP_FCNTL,XTERM);
3335 LOP(OP_FLOCK,XTERM);
3344 LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
3347 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3362 case KEY_getpriority:
3363 LOP(OP_GETPRIORITY,XTERM);
3365 case KEY_getprotobyname:
3368 case KEY_getprotobynumber:
3369 LOP(OP_GPBYNUMBER,XTERM);
3371 case KEY_getprotoent:
3383 case KEY_getpeername:
3384 UNI(OP_GETPEERNAME);
3386 case KEY_gethostbyname:
3389 case KEY_gethostbyaddr:
3390 LOP(OP_GHBYADDR,XTERM);
3392 case KEY_gethostent:
3395 case KEY_getnetbyname:
3398 case KEY_getnetbyaddr:
3399 LOP(OP_GNBYADDR,XTERM);
3404 case KEY_getservbyname:
3405 LOP(OP_GSBYNAME,XTERM);
3407 case KEY_getservbyport:
3408 LOP(OP_GSBYPORT,XTERM);
3410 case KEY_getservent:
3413 case KEY_getsockname:
3414 UNI(OP_GETSOCKNAME);
3416 case KEY_getsockopt:
3417 LOP(OP_GSOCKOPT,XTERM);
3439 yylval.ival = PL_curcop->cop_line;
3443 LOP(OP_INDEX,XTERM);
3449 LOP(OP_IOCTL,XTERM);
3461 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3492 LOP(OP_LISTEN,XTERM);
3501 s = scan_pat(s,OP_MATCH);
3502 TERM(sublex_start());
3505 LOP(OP_MAPSTART,XREF);
3508 LOP(OP_MKDIR,XTERM);
3511 LOP(OP_MSGCTL,XTERM);
3514 LOP(OP_MSGGET,XTERM);
3517 LOP(OP_MSGRCV,XTERM);
3520 LOP(OP_MSGSND,XTERM);
3525 if (isIDFIRST(*s)) {
3526 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
3527 PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
3528 if (!PL_in_my_stash) {
3531 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
3538 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3545 if (PL_expect != XSTATE)
3546 yyerror("\"no\" not allowed in expression");
3547 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3548 s = force_version(s);
3557 if (isIDFIRST(*s)) {
3559 for (d = s; isALNUM(*d); d++) ;
3561 if (strchr("|&*+-=!?:.", *t))
3562 warn("Precedence problem: open %.*s should be open(%.*s)",
3568 yylval.ival = OP_OR;
3578 LOP(OP_OPEN_DIR,XTERM);
3581 checkcomma(s,PL_tokenbuf,"filehandle");
3585 checkcomma(s,PL_tokenbuf,"filehandle");
3604 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3608 LOP(OP_PIPE_OP,XTERM);
3613 missingterm((char*)0);
3614 yylval.ival = OP_CONST;
3615 TERM(sublex_start());
3623 missingterm((char*)0);
3624 if (PL_dowarn && SvLEN(PL_lex_stuff)) {
3625 d = SvPV_force(PL_lex_stuff, len);
3626 for (; len; --len, ++d) {
3628 warn("Possible attempt to separate words with commas");
3632 warn("Possible attempt to put comments in qw() list");
3638 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, tokeq(PL_lex_stuff));
3639 PL_lex_stuff = Nullsv;
3642 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(" ",1));
3645 yylval.ival = OP_SPLIT;
3649 PL_last_lop = PL_oldbufptr;
3650 PL_last_lop_op = OP_SPLIT;
3656 missingterm((char*)0);
3657 yylval.ival = OP_STRINGIFY;
3658 if (SvIVX(PL_lex_stuff) == '\'')
3659 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
3660 TERM(sublex_start());
3663 s = scan_pat(s,OP_QR);
3664 TERM(sublex_start());
3669 missingterm((char*)0);
3670 yylval.ival = OP_BACKTICK;
3672 TERM(sublex_start());
3678 *PL_tokenbuf = '\0';
3679 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3680 if (isIDFIRST(*PL_tokenbuf))
3681 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
3683 yyerror("<> should be quotes");
3690 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3694 LOP(OP_RENAME,XTERM);
3703 LOP(OP_RINDEX,XTERM);
3726 LOP(OP_REVERSE,XTERM);
3737 TERM(sublex_start());
3739 TOKEN(1); /* force error */
3748 LOP(OP_SELECT,XTERM);
3754 LOP(OP_SEMCTL,XTERM);
3757 LOP(OP_SEMGET,XTERM);
3760 LOP(OP_SEMOP,XTERM);
3766 LOP(OP_SETPGRP,XTERM);
3768 case KEY_setpriority:
3769 LOP(OP_SETPRIORITY,XTERM);
3771 case KEY_sethostent:
3777 case KEY_setservent:
3780 case KEY_setprotoent:
3790 LOP(OP_SEEKDIR,XTERM);
3792 case KEY_setsockopt:
3793 LOP(OP_SSOCKOPT,XTERM);
3799 LOP(OP_SHMCTL,XTERM);
3802 LOP(OP_SHMGET,XTERM);
3805 LOP(OP_SHMREAD,XTERM);
3808 LOP(OP_SHMWRITE,XTERM);
3811 LOP(OP_SHUTDOWN,XTERM);
3820 LOP(OP_SOCKET,XTERM);
3822 case KEY_socketpair:
3823 LOP(OP_SOCKPAIR,XTERM);
3826 checkcomma(s,PL_tokenbuf,"subroutine name");
3828 if (*s == ';' || *s == ')') /* probably a close */
3829 croak("sort is now a reserved word");
3831 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3835 LOP(OP_SPLIT,XTERM);
3838 LOP(OP_SPRINTF,XTERM);
3841 LOP(OP_SPLICE,XTERM);
3857 LOP(OP_SUBSTR,XTERM);
3864 if (isIDFIRST(*s) || *s == '\'' || *s == ':') {
3865 char tmpbuf[sizeof PL_tokenbuf];
3867 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3868 if (strchr(tmpbuf, ':'))
3869 sv_setpv(PL_subname, tmpbuf);
3871 sv_setsv(PL_subname,PL_curstname);
3872 sv_catpvn(PL_subname,"::",2);
3873 sv_catpvn(PL_subname,tmpbuf,len);
3875 s = force_word(s,WORD,FALSE,TRUE,TRUE);
3879 PL_expect = XTERMBLOCK;
3880 sv_setpv(PL_subname,"?");
3883 if (tmp == KEY_format) {
3886 PL_lex_formbrack = PL_lex_brackets + 1;
3890 /* Look for a prototype */
3897 SvREFCNT_dec(PL_lex_stuff);
3898 PL_lex_stuff = Nullsv;
3899 croak("Prototype not terminated");
3902 d = SvPVX(PL_lex_stuff);
3904 for (p = d; *p; ++p) {
3909 SvCUR(PL_lex_stuff) = tmp;
3912 PL_nextval[1] = PL_nextval[0];
3913 PL_nexttype[1] = PL_nexttype[0];
3914 PL_nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
3915 PL_nexttype[0] = THING;
3916 if (PL_nexttoke == 1) {
3917 PL_lex_defer = PL_lex_state;
3918 PL_lex_expect = PL_expect;
3919 PL_lex_state = LEX_KNOWNEXT;
3921 PL_lex_stuff = Nullsv;
3924 if (*SvPV(PL_subname,PL_na) == '?') {
3925 sv_setpv(PL_subname,"__ANON__");
3932 LOP(OP_SYSTEM,XREF);
3935 LOP(OP_SYMLINK,XTERM);
3938 LOP(OP_SYSCALL,XTERM);
3941 LOP(OP_SYSOPEN,XTERM);
3944 LOP(OP_SYSSEEK,XTERM);
3947 LOP(OP_SYSREAD,XTERM);
3950 LOP(OP_SYSWRITE,XTERM);
3954 TERM(sublex_start());
3975 LOP(OP_TRUNCATE,XTERM);
3987 yylval.ival = PL_curcop->cop_line;
3991 yylval.ival = PL_curcop->cop_line;
3995 LOP(OP_UNLINK,XTERM);
4001 LOP(OP_UNPACK,XTERM);
4004 LOP(OP_UTIME,XTERM);
4008 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4009 if (*d != '0' && isDIGIT(*d))
4010 yywarn("umask: argument is missing initial 0");
4015 LOP(OP_UNSHIFT,XTERM);
4018 if (PL_expect != XSTATE)
4019 yyerror("\"use\" not allowed in expression");
4022 s = force_version(s);
4023 if(*s == ';' || (s = skipspace(s), *s == ';')) {
4024 PL_nextval[PL_nexttoke].opval = Nullop;
4029 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4030 s = force_version(s);
4043 yylval.ival = PL_curcop->cop_line;
4047 PL_hints |= HINT_BLOCK_SCOPE;
4054 LOP(OP_WAITPID,XTERM);
4060 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
4064 if (PL_expect == XOPERATOR)
4070 yylval.ival = OP_XOR;
4075 TERM(sublex_start());
4081 keyword(register char *d, I32 len)
4086 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
4087 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
4088 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
4089 if (strEQ(d,"__DATA__")) return KEY___DATA__;
4090 if (strEQ(d,"__END__")) return KEY___END__;
4094 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
4099 if (strEQ(d,"and")) return -KEY_and;
4100 if (strEQ(d,"abs")) return -KEY_abs;
4103 if (strEQ(d,"alarm")) return -KEY_alarm;
4104 if (strEQ(d,"atan2")) return -KEY_atan2;
4107 if (strEQ(d,"accept")) return -KEY_accept;
4112 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
4115 if (strEQ(d,"bless")) return -KEY_bless;
4116 if (strEQ(d,"bind")) return -KEY_bind;
4117 if (strEQ(d,"binmode")) return -KEY_binmode;
4120 if (strEQ(d,"CORE")) return -KEY_CORE;
4125 if (strEQ(d,"cmp")) return -KEY_cmp;
4126 if (strEQ(d,"chr")) return -KEY_chr;
4127 if (strEQ(d,"cos")) return -KEY_cos;
4130 if (strEQ(d,"chop")) return KEY_chop;
4133 if (strEQ(d,"close")) return -KEY_close;
4134 if (strEQ(d,"chdir")) return -KEY_chdir;
4135 if (strEQ(d,"chomp")) return KEY_chomp;
4136 if (strEQ(d,"chmod")) return -KEY_chmod;
4137 if (strEQ(d,"chown")) return -KEY_chown;
4138 if (strEQ(d,"crypt")) return -KEY_crypt;
4141 if (strEQ(d,"chroot")) return -KEY_chroot;
4142 if (strEQ(d,"caller")) return -KEY_caller;
4145 if (strEQ(d,"connect")) return -KEY_connect;
4148 if (strEQ(d,"closedir")) return -KEY_closedir;
4149 if (strEQ(d,"continue")) return -KEY_continue;
4154 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
4159 if (strEQ(d,"do")) return KEY_do;
4162 if (strEQ(d,"die")) return -KEY_die;
4165 if (strEQ(d,"dump")) return -KEY_dump;
4168 if (strEQ(d,"delete")) return KEY_delete;
4171 if (strEQ(d,"defined")) return KEY_defined;
4172 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
4175 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
4180 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
4181 if (strEQ(d,"END")) return KEY_END;
4186 if (strEQ(d,"eq")) return -KEY_eq;
4189 if (strEQ(d,"eof")) return -KEY_eof;
4190 if (strEQ(d,"exp")) return -KEY_exp;
4193 if (strEQ(d,"else")) return KEY_else;
4194 if (strEQ(d,"exit")) return -KEY_exit;
4195 if (strEQ(d,"eval")) return KEY_eval;
4196 if (strEQ(d,"exec")) return -KEY_exec;
4197 if (strEQ(d,"each")) return KEY_each;
4200 if (strEQ(d,"elsif")) return KEY_elsif;
4203 if (strEQ(d,"exists")) return KEY_exists;
4204 if (strEQ(d,"elseif")) warn("elseif should be elsif");
4207 if (strEQ(d,"endgrent")) return -KEY_endgrent;
4208 if (strEQ(d,"endpwent")) return -KEY_endpwent;
4211 if (strEQ(d,"endnetent")) return -KEY_endnetent;
4214 if (strEQ(d,"endhostent")) return -KEY_endhostent;
4215 if (strEQ(d,"endservent")) return -KEY_endservent;
4218 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
4225 if (strEQ(d,"for")) return KEY_for;
4228 if (strEQ(d,"fork")) return -KEY_fork;
4231 if (strEQ(d,"fcntl")) return -KEY_fcntl;
4232 if (strEQ(d,"flock")) return -KEY_flock;
4235 if (strEQ(d,"format")) return KEY_format;
4236 if (strEQ(d,"fileno")) return -KEY_fileno;
4239 if (strEQ(d,"foreach")) return KEY_foreach;
4242 if (strEQ(d,"formline")) return -KEY_formline;
4248 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
4249 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
4253 if (strnEQ(d,"get",3)) {
4258 if (strEQ(d,"ppid")) return -KEY_getppid;
4259 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
4262 if (strEQ(d,"pwent")) return -KEY_getpwent;
4263 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
4264 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
4267 if (strEQ(d,"peername")) return -KEY_getpeername;
4268 if (strEQ(d,"protoent")) return -KEY_getprotoent;
4269 if (strEQ(d,"priority")) return -KEY_getpriority;
4272 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
4275 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
4279 else if (*d == 'h') {
4280 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
4281 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
4282 if (strEQ(d,"hostent")) return -KEY_gethostent;
4284 else if (*d == 'n') {
4285 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
4286 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
4287 if (strEQ(d,"netent")) return -KEY_getnetent;
4289 else if (*d == 's') {
4290 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
4291 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
4292 if (strEQ(d,"servent")) return -KEY_getservent;
4293 if (strEQ(d,"sockname")) return -KEY_getsockname;
4294 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
4296 else if (*d == 'g') {
4297 if (strEQ(d,"grent")) return -KEY_getgrent;
4298 if (strEQ(d,"grnam")) return -KEY_getgrnam;
4299 if (strEQ(d,"grgid")) return -KEY_getgrgid;
4301 else if (*d == 'l') {
4302 if (strEQ(d,"login")) return -KEY_getlogin;
4304 else if (strEQ(d,"c")) return -KEY_getc;
4309 if (strEQ(d,"gt")) return -KEY_gt;
4310 if (strEQ(d,"ge")) return -KEY_ge;
4313 if (strEQ(d,"grep")) return KEY_grep;
4314 if (strEQ(d,"goto")) return KEY_goto;
4315 if (strEQ(d,"glob")) return KEY_glob;
4318 if (strEQ(d,"gmtime")) return -KEY_gmtime;
4323 if (strEQ(d,"hex")) return -KEY_hex;
4326 if (strEQ(d,"INIT")) return KEY_INIT;
4331 if (strEQ(d,"if")) return KEY_if;
4334 if (strEQ(d,"int")) return -KEY_int;
4337 if (strEQ(d,"index")) return -KEY_index;
4338 if (strEQ(d,"ioctl")) return -KEY_ioctl;
4343 if (strEQ(d,"join")) return -KEY_join;
4347 if (strEQ(d,"keys")) return KEY_keys;
4348 if (strEQ(d,"kill")) return -KEY_kill;
4353 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
4354 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
4360 if (strEQ(d,"lt")) return -KEY_lt;
4361 if (strEQ(d,"le")) return -KEY_le;
4362 if (strEQ(d,"lc")) return -KEY_lc;
4365 if (strEQ(d,"log")) return -KEY_log;
4368 if (strEQ(d,"last")) return KEY_last;
4369 if (strEQ(d,"link")) return -KEY_link;
4370 if (strEQ(d,"lock")) return -KEY_lock;
4373 if (strEQ(d,"local")) return KEY_local;
4374 if (strEQ(d,"lstat")) return -KEY_lstat;
4377 if (strEQ(d,"length")) return -KEY_length;
4378 if (strEQ(d,"listen")) return -KEY_listen;
4381 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
4384 if (strEQ(d,"localtime")) return -KEY_localtime;
4390 case 1: return KEY_m;
4392 if (strEQ(d,"my")) return KEY_my;
4395 if (strEQ(d,"map")) return KEY_map;
4398 if (strEQ(d,"mkdir")) return -KEY_mkdir;
4401 if (strEQ(d,"msgctl")) return -KEY_msgctl;
4402 if (strEQ(d,"msgget")) return -KEY_msgget;
4403 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
4404 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
4409 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
4412 if (strEQ(d,"next")) return KEY_next;
4413 if (strEQ(d,"ne")) return -KEY_ne;
4414 if (strEQ(d,"not")) return -KEY_not;
4415 if (strEQ(d,"no")) return KEY_no;
4420 if (strEQ(d,"or")) return -KEY_or;
4423 if (strEQ(d,"ord")) return -KEY_ord;
4424 if (strEQ(d,"oct")) return -KEY_oct;
4425 if (strEQ(d,"our")) { deprecate("reserved word \"our\"");
4429 if (strEQ(d,"open")) return -KEY_open;
4432 if (strEQ(d,"opendir")) return -KEY_opendir;
4439 if (strEQ(d,"pop")) return KEY_pop;
4440 if (strEQ(d,"pos")) return KEY_pos;
4443 if (strEQ(d,"push")) return KEY_push;
4444 if (strEQ(d,"pack")) return -KEY_pack;
4445 if (strEQ(d,"pipe")) return -KEY_pipe;
4448 if (strEQ(d,"print")) return KEY_print;
4451 if (strEQ(d,"printf")) return KEY_printf;
4454 if (strEQ(d,"package")) return KEY_package;
4457 if (strEQ(d,"prototype")) return KEY_prototype;
4462 if (strEQ(d,"q")) return KEY_q;
4463 if (strEQ(d,"qr")) return KEY_qr;
4464 if (strEQ(d,"qq")) return KEY_qq;
4465 if (strEQ(d,"qw")) return KEY_qw;
4466 if (strEQ(d,"qx")) return KEY_qx;
4468 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
4473 if (strEQ(d,"ref")) return -KEY_ref;
4476 if (strEQ(d,"read")) return -KEY_read;
4477 if (strEQ(d,"rand")) return -KEY_rand;
4478 if (strEQ(d,"recv")) return -KEY_recv;
4479 if (strEQ(d,"redo")) return KEY_redo;
4482 if (strEQ(d,"rmdir")) return -KEY_rmdir;
4483 if (strEQ(d,"reset")) return -KEY_reset;
4486 if (strEQ(d,"return")) return KEY_return;
4487 if (strEQ(d,"rename")) return -KEY_rename;
4488 if (strEQ(d,"rindex")) return -KEY_rindex;
4491 if (strEQ(d,"require")) return -KEY_require;
4492 if (strEQ(d,"reverse")) return -KEY_reverse;
4493 if (strEQ(d,"readdir")) return -KEY_readdir;
4496 if (strEQ(d,"readlink")) return -KEY_readlink;
4497 if (strEQ(d,"readline")) return -KEY_readline;
4498 if (strEQ(d,"readpipe")) return -KEY_readpipe;
4501 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
4507 case 0: return KEY_s;
4509 if (strEQ(d,"scalar")) return KEY_scalar;
4514 if (strEQ(d,"seek")) return -KEY_seek;
4515 if (strEQ(d,"send")) return -KEY_send;
4518 if (strEQ(d,"semop")) return -KEY_semop;
4521 if (strEQ(d,"select")) return -KEY_select;
4522 if (strEQ(d,"semctl")) return -KEY_semctl;
4523 if (strEQ(d,"semget")) return -KEY_semget;
4526 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
4527 if (strEQ(d,"seekdir")) return -KEY_seekdir;
4530 if (strEQ(d,"setpwent")) return -KEY_setpwent;
4531 if (strEQ(d,"setgrent")) return -KEY_setgrent;
4534 if (strEQ(d,"setnetent")) return -KEY_setnetent;
4537 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
4538 if (strEQ(d,"sethostent")) return -KEY_sethostent;
4539 if (strEQ(d,"setservent")) return -KEY_setservent;
4542 if (strEQ(d,"setpriority")) return -KEY_setpriority;
4543 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
4550 if (strEQ(d,"shift")) return KEY_shift;
4553 if (strEQ(d,"shmctl")) return -KEY_shmctl;
4554 if (strEQ(d,"shmget")) return -KEY_shmget;
4557 if (strEQ(d,"shmread")) return -KEY_shmread;
4560 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
4561 if (strEQ(d,"shutdown")) return -KEY_shutdown;
4566 if (strEQ(d,"sin")) return -KEY_sin;
4569 if (strEQ(d,"sleep")) return -KEY_sleep;
4572 if (strEQ(d,"sort")) return KEY_sort;
4573 if (strEQ(d,"socket")) return -KEY_socket;
4574 if (strEQ(d,"socketpair")) return -KEY_socketpair;
4577 if (strEQ(d,"split")) return KEY_split;
4578 if (strEQ(d,"sprintf")) return -KEY_sprintf;
4579 if (strEQ(d,"splice")) return KEY_splice;
4582 if (strEQ(d,"sqrt")) return -KEY_sqrt;
4585 if (strEQ(d,"srand")) return -KEY_srand;
4588 if (strEQ(d,"stat")) return -KEY_stat;
4589 if (strEQ(d,"study")) return KEY_study;
4592 if (strEQ(d,"substr")) return -KEY_substr;
4593 if (strEQ(d,"sub")) return KEY_sub;
4598 if (strEQ(d,"system")) return -KEY_system;
4601 if (strEQ(d,"symlink")) return -KEY_symlink;
4602 if (strEQ(d,"syscall")) return -KEY_syscall;
4603 if (strEQ(d,"sysopen")) return -KEY_sysopen;
4604 if (strEQ(d,"sysread")) return -KEY_sysread;
4605 if (strEQ(d,"sysseek")) return -KEY_sysseek;
4608 if (strEQ(d,"syswrite")) return -KEY_syswrite;
4617 if (strEQ(d,"tr")) return KEY_tr;
4620 if (strEQ(d,"tie")) return KEY_tie;
4623 if (strEQ(d,"tell")) return -KEY_tell;
4624 if (strEQ(d,"tied")) return KEY_tied;
4625 if (strEQ(d,"time")) return -KEY_time;
4628 if (strEQ(d,"times")) return -KEY_times;
4631 if (strEQ(d,"telldir")) return -KEY_telldir;
4634 if (strEQ(d,"truncate")) return -KEY_truncate;
4641 if (strEQ(d,"uc")) return -KEY_uc;
4644 if (strEQ(d,"use")) return KEY_use;
4647 if (strEQ(d,"undef")) return KEY_undef;
4648 if (strEQ(d,"until")) return KEY_until;
4649 if (strEQ(d,"untie")) return KEY_untie;
4650 if (strEQ(d,"utime")) return -KEY_utime;
4651 if (strEQ(d,"umask")) return -KEY_umask;
4654 if (strEQ(d,"unless")) return KEY_unless;
4655 if (strEQ(d,"unpack")) return -KEY_unpack;
4656 if (strEQ(d,"unlink")) return -KEY_unlink;
4659 if (strEQ(d,"unshift")) return KEY_unshift;
4660 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
4665 if (strEQ(d,"values")) return -KEY_values;
4666 if (strEQ(d,"vec")) return -KEY_vec;
4671 if (strEQ(d,"warn")) return -KEY_warn;
4672 if (strEQ(d,"wait")) return -KEY_wait;
4675 if (strEQ(d,"while")) return KEY_while;
4676 if (strEQ(d,"write")) return -KEY_write;
4679 if (strEQ(d,"waitpid")) return -KEY_waitpid;
4682 if (strEQ(d,"wantarray")) return -KEY_wantarray;
4687 if (len == 1) return -KEY_x;
4688 if (strEQ(d,"xor")) return -KEY_xor;
4691 if (len == 1) return KEY_y;
4700 checkcomma(register char *s, char *name, char *what)
4704 if (PL_dowarn && *s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
4706 for (w = s+2; *w && level; w++) {
4713 for (; *w && isSPACE(*w); w++) ;
4714 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
4715 warn("%s (...) interpreted as function",name);
4717 while (s < PL_bufend && isSPACE(*s))
4721 while (s < PL_bufend && isSPACE(*s))
4723 if (isIDFIRST(*s)) {
4727 while (s < PL_bufend && isSPACE(*s))
4732 kw = keyword(w, s - w) || perl_get_cv(w, FALSE) != 0;
4736 croak("No comma allowed after %s", what);
4742 new_constant(char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)
4745 HV *table = GvHV(PL_hintgv); /* ^H */
4748 bool oldcatch = CATCH_GET;
4754 yyerror("%^H is not defined");
4757 cvp = hv_fetch(table, key, strlen(key), FALSE);
4758 if (!cvp || !SvOK(*cvp)) {
4759 sprintf(buf,"$^H{%s} is not defined", key);
4763 sv_2mortal(sv); /* Parent created it permanently */
4766 pv = sv_2mortal(newSVpv(s, len));
4768 typesv = sv_2mortal(newSVpv(type, 0));
4770 typesv = &PL_sv_undef;
4772 Zero(&myop, 1, BINOP);
4773 myop.op_last = (OP *) &myop;
4774 myop.op_next = Nullop;
4775 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
4777 PUSHSTACKi(PERLSI_OVERLOAD);
4780 PL_op = (OP *) &myop;
4781 if (PERLDB_SUB && PL_curstash != PL_debstash)
4782 PL_op->op_private |= OPpENTERSUB_DB;
4793 if (PL_op = pp_entersub(ARGS))
4800 CATCH_SET(oldcatch);
4804 sprintf(buf,"Call to &{$^H{%s}} did not return a defined value", key);
4807 return SvREFCNT_inc(res);
4811 scan_word(register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
4813 register char *d = dest;
4814 register char *e = d + destlen - 3; /* two-character token, ending NUL */
4817 croak(ident_too_long);
4820 else if (*s == '\'' && allow_package && isIDFIRST(s[1])) {
4825 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
4838 scan_ident(register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
4845 if (PL_lex_brackets == 0)
4846 PL_lex_fakebrack = 0;
4850 e = d + destlen - 3; /* two-character token, ending NUL */
4852 while (isDIGIT(*s)) {
4854 croak(ident_too_long);
4861 croak(ident_too_long);
4864 else if (*s == '\'' && isIDFIRST(s[1])) {
4869 else if (*s == ':' && s[1] == ':') {
4880 if (PL_lex_state != LEX_NORMAL)
4881 PL_lex_state = LEX_INTERPENDMAYBE;
4884 if (*s == '$' && s[1] &&
4885 (isALNUM(s[1]) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
4887 if (isDIGIT(s[1]) && PL_lex_state == LEX_INTERPNORMAL)
4888 deprecate("\"$$<digit>\" to mean \"${$}<digit>\"");
4901 if (*d == '^' && *s && (isUPPER(*s) || strchr("[\\]^_?", *s))) {
4906 if (isSPACE(s[-1])) {
4909 if (ch != ' ' && ch != '\t') {
4915 if (isIDFIRST(*d)) {
4917 while (isALNUM(*s) || *s == ':')
4920 while (s < send && (*s == ' ' || *s == '\t')) s++;
4921 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
4922 if (PL_dowarn && keyword(dest, d - dest)) {
4923 char *brack = *s == '[' ? "[...]" : "{...}";
4924 warn("Ambiguous use of %c{%s%s} resolved to %c%s%s",
4925 funny, dest, brack, funny, dest, brack);
4927 PL_lex_fakebrack = PL_lex_brackets+1;
4929 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4935 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
4936 PL_lex_state = LEX_INTERPEND;
4939 if (PL_dowarn && PL_lex_state == LEX_NORMAL &&
4940 (keyword(dest, d - dest) || perl_get_cv(dest, FALSE)))
4941 warn("Ambiguous use of %c{%s} resolved to %c%s",
4942 funny, dest, funny, dest);
4945 s = bracket; /* let the parser handle it */
4949 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
4950 PL_lex_state = LEX_INTERPEND;
4954 void pmflag(U16 *pmfl, int ch)
4959 *pmfl |= PMf_GLOBAL;
4961 *pmfl |= PMf_CONTINUE;
4965 *pmfl |= PMf_MULTILINE;
4967 *pmfl |= PMf_SINGLELINE;
4969 *pmfl |= PMf_EXTENDED;
4973 scan_pat(char *start, I32 type)
4978 s = scan_str(start);
4981 SvREFCNT_dec(PL_lex_stuff);
4982 PL_lex_stuff = Nullsv;
4983 croak("Search pattern not terminated");
4986 pm = (PMOP*)newPMOP(type, 0);
4987 if (PL_multi_open == '?')
4988 pm->op_pmflags |= PMf_ONCE;
4990 while (*s && strchr("iomsx", *s))
4991 pmflag(&pm->op_pmflags,*s++);
4994 while (*s && strchr("iogcmsx", *s))
4995 pmflag(&pm->op_pmflags,*s++);
4997 pm->op_pmpermflags = pm->op_pmflags;
4999 PL_lex_op = (OP*)pm;
5000 yylval.ival = OP_MATCH;
5005 scan_subst(char *start)
5012 yylval.ival = OP_NULL;
5014 s = scan_str(start);
5018 SvREFCNT_dec(PL_lex_stuff);
5019 PL_lex_stuff = Nullsv;
5020 croak("Substitution pattern not terminated");
5023 if (s[-1] == PL_multi_open)
5026 first_start = PL_multi_start;
5030 SvREFCNT_dec(PL_lex_stuff);
5031 PL_lex_stuff = Nullsv;
5033 SvREFCNT_dec(PL_lex_repl);
5034 PL_lex_repl = Nullsv;
5035 croak("Substitution replacement not terminated");
5037 PL_multi_start = first_start; /* so whole substitution is taken together */
5039 pm = (PMOP*)newPMOP(OP_SUBST, 0);
5045 else if (strchr("iogcmsx", *s))
5046 pmflag(&pm->op_pmflags,*s++);
5053 pm->op_pmflags |= PMf_EVAL;
5054 repl = newSVpv("",0);
5056 sv_catpv(repl, es ? "eval " : "do ");
5057 sv_catpvn(repl, "{ ", 2);
5058 sv_catsv(repl, PL_lex_repl);
5059 sv_catpvn(repl, " };", 2);
5060 SvCOMPILED_on(repl);
5061 SvREFCNT_dec(PL_lex_repl);
5065 pm->op_pmpermflags = pm->op_pmflags;
5066 PL_lex_op = (OP*)pm;
5067 yylval.ival = OP_SUBST;
5072 scan_trans(char *start)
5081 yylval.ival = OP_NULL;
5083 s = scan_str(start);
5086 SvREFCNT_dec(PL_lex_stuff);
5087 PL_lex_stuff = Nullsv;
5088 croak("Transliteration pattern not terminated");
5090 if (s[-1] == PL_multi_open)
5096 SvREFCNT_dec(PL_lex_stuff);
5097 PL_lex_stuff = Nullsv;
5099 SvREFCNT_dec(PL_lex_repl);
5100 PL_lex_repl = Nullsv;
5101 croak("Transliteration replacement not terminated");
5104 New(803,tbl,256,short);
5105 o = newPVOP(OP_TRANS, 0, (char*)tbl);
5107 complement = Delete = squash = 0;
5108 while (*s == 'c' || *s == 'd' || *s == 's') {
5110 complement = OPpTRANS_COMPLEMENT;
5112 Delete = OPpTRANS_DELETE;
5114 squash = OPpTRANS_SQUASH;
5117 o->op_private = Delete|squash|complement;
5120 yylval.ival = OP_TRANS;
5125 scan_heredoc(register char *s)
5129 I32 op_type = OP_SCALAR;
5136 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
5140 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
5143 for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5144 if (*peek && strchr("`'\"",*peek)) {
5147 s = delimcpy(d, e, s, PL_bufend, term, &len);
5158 deprecate("bare << to mean <<\"\"");
5159 for (; isALNUM(*s); s++) {
5164 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
5165 croak("Delimiter for here document is too long");
5168 len = d - PL_tokenbuf;
5169 #ifndef PERL_STRICT_CR
5170 d = strchr(s, '\r');
5174 while (s < PL_bufend) {
5180 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
5189 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5194 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
5195 herewas = newSVpv(s,PL_bufend-s);
5197 s--, herewas = newSVpv(s,d-s);
5198 s += SvCUR(herewas);
5200 tmpstr = NEWSV(87,79);
5201 sv_upgrade(tmpstr, SVt_PVIV);
5206 else if (term == '`') {
5207 op_type = OP_BACKTICK;
5208 SvIVX(tmpstr) = '\\';
5212 PL_multi_start = PL_curcop->cop_line;
5213 PL_multi_open = PL_multi_close = '<';
5214 term = *PL_tokenbuf;
5217 while (s < PL_bufend &&
5218 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
5220 PL_curcop->cop_line++;
5222 if (s >= PL_bufend) {
5223 PL_curcop->cop_line = PL_multi_start;
5224 missingterm(PL_tokenbuf);
5226 sv_setpvn(tmpstr,d+1,s-d);
5228 PL_curcop->cop_line++; /* the preceding stmt passes a newline */
5230 sv_catpvn(herewas,s,PL_bufend-s);
5231 sv_setsv(PL_linestr,herewas);
5232 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
5233 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5236 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
5237 while (s >= PL_bufend) { /* multiple line string? */
5239 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5240 PL_curcop->cop_line = PL_multi_start;
5241 missingterm(PL_tokenbuf);
5243 PL_curcop->cop_line++;
5244 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5245 #ifndef PERL_STRICT_CR
5246 if (PL_bufend - PL_linestart >= 2) {
5247 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
5248 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
5250 PL_bufend[-2] = '\n';
5252 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5254 else if (PL_bufend[-1] == '\r')
5255 PL_bufend[-1] = '\n';
5257 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
5258 PL_bufend[-1] = '\n';
5260 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5261 SV *sv = NEWSV(88,0);
5263 sv_upgrade(sv, SVt_PVMG);
5264 sv_setsv(sv,PL_linestr);
5265 av_store(GvAV(PL_curcop->cop_filegv),
5266 (I32)PL_curcop->cop_line,sv);
5268 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
5271 sv_catsv(PL_linestr,herewas);
5272 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5276 sv_catsv(tmpstr,PL_linestr);
5279 PL_multi_end = PL_curcop->cop_line;
5281 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
5282 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
5283 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
5285 SvREFCNT_dec(herewas);
5286 PL_lex_stuff = tmpstr;
5287 yylval.ival = op_type;
5292 takes: current position in input buffer
5293 returns: new position in input buffer
5294 side-effects: yylval and lex_op are set.
5299 <FH> read from filehandle
5300 <pkg::FH> read from package qualified filehandle
5301 <pkg'FH> read from package qualified filehandle
5302 <$fh> read from filehandle in $fh
5308 scan_inputsymbol(char *start)
5310 register char *s = start; /* current position in buffer */
5315 d = PL_tokenbuf; /* start of temp holding space */
5316 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
5317 s = delimcpy(d, e, s + 1, PL_bufend, '>', &len); /* extract until > */
5319 /* die if we didn't have space for the contents of the <>,
5323 if (len >= sizeof PL_tokenbuf)
5324 croak("Excessively long <> operator");
5326 croak("Unterminated <> operator");
5331 Remember, only scalar variables are interpreted as filehandles by
5332 this code. Anything more complex (e.g., <$fh{$num}>) will be
5333 treated as a glob() call.
5334 This code makes use of the fact that except for the $ at the front,
5335 a scalar variable and a filehandle look the same.
5337 if (*d == '$' && d[1]) d++;
5339 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
5340 while (*d && (isALNUM(*d) || *d == '\'' || *d == ':'))
5343 /* If we've tried to read what we allow filehandles to look like, and
5344 there's still text left, then it must be a glob() and not a getline.
5345 Use scan_str to pull out the stuff between the <> and treat it
5346 as nothing more than a string.
5349 if (d - PL_tokenbuf != len) {
5350 yylval.ival = OP_GLOB;
5352 s = scan_str(start);
5354 croak("Glob not terminated");
5358 /* we're in a filehandle read situation */
5361 /* turn <> into <ARGV> */
5363 (void)strcpy(d,"ARGV");
5365 /* if <$fh>, create the ops to turn the variable into a
5371 /* try to find it in the pad for this block, otherwise find
5372 add symbol table ops
5374 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
5375 OP *o = newOP(OP_PADSV, 0);
5377 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newUNOP(OP_RV2GV, 0, o));
5380 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
5381 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
5382 newUNOP(OP_RV2GV, 0,
5383 newUNOP(OP_RV2SV, 0,
5384 newGVOP(OP_GV, 0, gv))));
5386 /* we created the ops in lex_op, so make yylval.ival a null op */
5387 yylval.ival = OP_NULL;
5390 /* If it's none of the above, it must be a literal filehandle
5391 (<Foo::BAR> or <FOO>) so build a simple readline OP */
5393 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
5394 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
5395 yylval.ival = OP_NULL;
5404 takes: start position in buffer
5405 returns: position to continue reading from buffer
5406 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
5407 updates the read buffer.
5409 This subroutine pulls a string out of the input. It is called for:
5410 q single quotes q(literal text)
5411 ' single quotes 'literal text'
5412 qq double quotes qq(interpolate $here please)
5413 " double quotes "interpolate $here please"
5414 qx backticks qx(/bin/ls -l)
5415 ` backticks `/bin/ls -l`
5416 qw quote words @EXPORT_OK = qw( func() $spam )
5417 m// regexp match m/this/
5418 s/// regexp substitute s/this/that/
5419 tr/// string transliterate tr/this/that/
5420 y/// string transliterate y/this/that/
5421 ($*@) sub prototypes sub foo ($)
5422 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
5424 In most of these cases (all but <>, patterns and transliterate)
5425 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
5426 calls scan_str(). s/// makes yylex() call scan_subst() which calls
5427 scan_str(). tr/// and y/// make yylex() call scan_trans() which
5430 It skips whitespace before the string starts, and treats the first
5431 character as the delimiter. If the delimiter is one of ([{< then
5432 the corresponding "close" character )]}> is used as the closing
5433 delimiter. It allows quoting of delimiters, and if the string has
5434 balanced delimiters ([{<>}]) it allows nesting.
5436 The lexer always reads these strings into lex_stuff, except in the
5437 case of the operators which take *two* arguments (s/// and tr///)
5438 when it checks to see if lex_stuff is full (presumably with the 1st
5439 arg to s or tr) and if so puts the string into lex_repl.
5444 scan_str(char *start)
5447 SV *sv; /* scalar value: string */
5448 char *tmps; /* temp string, used for delimiter matching */
5449 register char *s = start; /* current position in the buffer */
5450 register char term; /* terminating character */
5451 register char *to; /* current position in the sv's data */
5452 I32 brackets = 1; /* bracket nesting level */
5454 /* skip space before the delimiter */
5458 /* mark where we are, in case we need to report errors */
5461 /* after skipping whitespace, the next character is the terminator */
5463 /* mark where we are */
5464 PL_multi_start = PL_curcop->cop_line;
5465 PL_multi_open = term;
5467 /* find corresponding closing delimiter */
5468 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5470 PL_multi_close = term;
5472 /* create a new SV to hold the contents. 87 is leak category, I'm
5473 assuming. 79 is the SV's initial length. What a random number. */
5475 sv_upgrade(sv, SVt_PVIV);
5477 (void)SvPOK_only(sv); /* validate pointer */
5479 /* move past delimiter and try to read a complete string */
5482 /* extend sv if need be */
5483 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
5484 /* set 'to' to the next character in the sv's string */
5485 to = SvPVX(sv)+SvCUR(sv);
5487 /* if open delimiter is the close delimiter read unbridle */
5488 if (PL_multi_open == PL_multi_close) {
5489 for (; s < PL_bufend; s++,to++) {
5490 /* embedded newlines increment the current line number */
5491 if (*s == '\n' && !PL_rsfp)
5492 PL_curcop->cop_line++;
5493 /* handle quoted delimiters */
5494 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
5497 /* any other quotes are simply copied straight through */
5501 /* terminate when run out of buffer (the for() condition), or
5502 have found the terminator */
5503 else if (*s == term)
5509 /* if the terminator isn't the same as the start character (e.g.,
5510 matched brackets), we have to allow more in the quoting, and
5511 be prepared for nested brackets.
5514 /* read until we run out of string, or we find the terminator */
5515 for (; s < PL_bufend; s++,to++) {
5516 /* embedded newlines increment the line count */
5517 if (*s == '\n' && !PL_rsfp)
5518 PL_curcop->cop_line++;
5519 /* backslashes can escape the open or closing characters */
5520 if (*s == '\\' && s+1 < PL_bufend) {
5521 if ((s[1] == PL_multi_open) || (s[1] == PL_multi_close))
5526 /* allow nested opens and closes */
5527 else if (*s == PL_multi_close && --brackets <= 0)
5529 else if (*s == PL_multi_open)
5534 /* terminate the copied string and update the sv's end-of-string */
5536 SvCUR_set(sv, to - SvPVX(sv));
5539 * this next chunk reads more into the buffer if we're not done yet
5542 if (s < PL_bufend) break; /* handle case where we are done yet :-) */
5544 #ifndef PERL_STRICT_CR
5545 if (to - SvPVX(sv) >= 2) {
5546 if ((to[-2] == '\r' && to[-1] == '\n') ||
5547 (to[-2] == '\n' && to[-1] == '\r'))
5551 SvCUR_set(sv, to - SvPVX(sv));
5553 else if (to[-1] == '\r')
5556 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
5560 /* if we're out of file, or a read fails, bail and reset the current
5561 line marker so we can report where the unterminated string began
5564 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5566 PL_curcop->cop_line = PL_multi_start;
5569 /* we read a line, so increment our line counter */
5570 PL_curcop->cop_line++;
5572 /* update debugger info */
5573 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5574 SV *sv = NEWSV(88,0);
5576 sv_upgrade(sv, SVt_PVMG);
5577 sv_setsv(sv,PL_linestr);
5578 av_store(GvAV(PL_curcop->cop_filegv),
5579 (I32)PL_curcop->cop_line, sv);
5582 /* having changed the buffer, we must update PL_bufend */
5583 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5586 /* at this point, we have successfully read the delimited string */
5588 PL_multi_end = PL_curcop->cop_line;
5591 /* if we allocated too much space, give some back */
5592 if (SvCUR(sv) + 5 < SvLEN(sv)) {
5593 SvLEN_set(sv, SvCUR(sv) + 1);
5594 Renew(SvPVX(sv), SvLEN(sv), char);
5597 /* decide whether this is the first or second quoted string we've read
5610 takes: pointer to position in buffer
5611 returns: pointer to new position in buffer
5612 side-effects: builds ops for the constant in yylval.op
5614 Read a number in any of the formats that Perl accepts:
5616 0(x[0-7A-F]+)|([0-7]+)
5617 [\d_]+(\.[\d_]*)?[Ee](\d+)
5619 Underbars (_) are allowed in decimal numbers. If -w is on,
5620 underbars before a decimal point must be at three digit intervals.
5622 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
5625 If it reads a number without a decimal point or an exponent, it will
5626 try converting the number to an integer and see if it can do so
5627 without loss of precision.
5631 scan_num(char *start)
5633 register char *s = start; /* current position in buffer */
5634 register char *d; /* destination in temp buffer */
5635 register char *e; /* end of temp buffer */
5636 I32 tryiv; /* used to see if it can be an int */
5637 double value; /* number read, as a double */
5638 SV *sv; /* place to put the converted number */
5639 I32 floatit; /* boolean: int or float? */
5640 char *lastub = 0; /* position of last underbar */
5641 static char number_too_long[] = "Number too long";
5643 /* We use the first character to decide what type of number this is */
5647 croak("panic: scan_num");
5649 /* if it starts with a 0, it could be an octal number, a decimal in
5650 0.13 disguise, or a hexadecimal number.
5655 u holds the "number so far"
5656 shift the power of 2 of the base (hex == 4, octal == 3)
5657 overflowed was the number more than we can hold?
5659 Shift is used when we add a digit. It also serves as an "are
5660 we in octal or hex?" indicator to disallow hex characters when
5665 bool overflowed = FALSE;
5672 /* check for a decimal in disguise */
5673 else if (s[1] == '.')
5675 /* so it must be octal */
5680 /* read the rest of the octal number */
5682 UV n, b; /* n is used in the overflow test, b is the digit we're adding on */
5686 /* if we don't mention it, we're done */
5695 /* 8 and 9 are not octal */
5698 yyerror("Illegal octal digit");
5702 case '0': case '1': case '2': case '3': case '4':
5703 case '5': case '6': case '7':
5704 b = *s++ & 15; /* ASCII digit -> value of digit */
5708 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
5709 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
5710 /* make sure they said 0x */
5715 /* Prepare to put the digit we have onto the end
5716 of the number so far. We check for overflows.
5720 n = u << shift; /* make room for the digit */
5721 if (!overflowed && (n >> shift) != u
5722 && !(PL_hints & HINT_NEW_BINARY)) {
5723 warn("Integer overflow in %s number",
5724 (shift == 4) ? "hex" : "octal");
5727 u = n | b; /* add the digit to the end */
5732 /* if we get here, we had success: make a scalar value from
5738 if ( PL_hints & HINT_NEW_BINARY)
5739 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
5744 handle decimal numbers.
5745 we're also sent here when we read a 0 as the first digit
5747 case '1': case '2': case '3': case '4': case '5':
5748 case '6': case '7': case '8': case '9': case '.':
5751 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
5754 /* read next group of digits and _ and copy into d */
5755 while (isDIGIT(*s) || *s == '_') {
5756 /* skip underscores, checking for misplaced ones
5760 if (PL_dowarn && lastub && s - lastub != 3)
5761 warn("Misplaced _ in number");
5765 /* check for end of fixed-length buffer */
5767 croak(number_too_long);
5768 /* if we're ok, copy the character */
5773 /* final misplaced underbar check */
5774 if (PL_dowarn && lastub && s - lastub != 3)
5775 warn("Misplaced _ in number");
5777 /* read a decimal portion if there is one. avoid
5778 3..5 being interpreted as the number 3. followed
5781 if (*s == '.' && s[1] != '.') {
5785 /* copy, ignoring underbars, until we run out of
5786 digits. Note: no misplaced underbar checks!
5788 for (; isDIGIT(*s) || *s == '_'; s++) {
5789 /* fixed length buffer check */
5791 croak(number_too_long);
5797 /* read exponent part, if present */
5798 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
5802 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
5803 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
5805 /* allow positive or negative exponent */
5806 if (*s == '+' || *s == '-')
5809 /* read digits of exponent (no underbars :-) */
5810 while (isDIGIT(*s)) {
5812 croak(number_too_long);
5817 /* terminate the string */
5820 /* make an sv from the string */
5822 /* reset numeric locale in case we were earlier left in Swaziland */
5823 SET_NUMERIC_STANDARD();
5824 value = atof(PL_tokenbuf);
5827 See if we can make do with an integer value without loss of
5828 precision. We use I_V to cast to an int, because some
5829 compilers have issues. Then we try casting it back and see
5830 if it was the same. We only do this if we know we
5831 specifically read an integer.
5833 Note: if floatit is true, then we don't need to do the
5837 if (!floatit && (double)tryiv == value)
5838 sv_setiv(sv, tryiv);
5840 sv_setnv(sv, value);
5841 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) )
5842 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
5843 (floatit ? "float" : "integer"), sv, Nullsv, NULL);
5847 /* make the op for the constant and return */
5849 yylval.opval = newSVOP(OP_CONST, 0, sv);
5855 scan_formline(register char *s)
5860 SV *stuff = newSVpv("",0);
5861 bool needargs = FALSE;
5864 if (*s == '.' || *s == '}') {
5866 for (t = s+1; *t == ' ' || *t == '\t'; t++) ;
5870 if (PL_in_eval && !PL_rsfp) {
5871 eol = strchr(s,'\n');
5876 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5878 for (t = s; t < eol; t++) {
5879 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
5881 goto enough; /* ~~ must be first line in formline */
5883 if (*t == '@' || *t == '^')
5886 sv_catpvn(stuff, s, eol-s);
5890 s = filter_gets(PL_linestr, PL_rsfp, 0);
5891 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
5892 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
5895 yyerror("Format not terminated");
5905 PL_lex_state = LEX_NORMAL;
5906 PL_nextval[PL_nexttoke].ival = 0;
5910 PL_lex_state = LEX_FORMLINE;
5911 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
5913 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
5917 SvREFCNT_dec(stuff);
5918 PL_lex_formbrack = 0;
5929 PL_cshlen = strlen(PL_cshname);
5934 start_subparse(I32 is_format, U32 flags)
5937 I32 oldsavestack_ix = PL_savestack_ix;
5938 CV* outsidecv = PL_compcv;
5942 assert(SvTYPE(PL_compcv) == SVt_PVCV);
5944 save_I32(&PL_subline);
5945 save_item(PL_subname);
5947 SAVESPTR(PL_curpad);
5948 SAVESPTR(PL_comppad);
5949 SAVESPTR(PL_comppad_name);
5950 SAVESPTR(PL_compcv);
5951 SAVEI32(PL_comppad_name_fill);
5952 SAVEI32(PL_min_intro_pending);
5953 SAVEI32(PL_max_intro_pending);
5954 SAVEI32(PL_pad_reset_pending);
5956 PL_compcv = (CV*)NEWSV(1104,0);
5957 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
5958 CvFLAGS(PL_compcv) |= flags;
5960 PL_comppad = newAV();
5961 av_push(PL_comppad, Nullsv);
5962 PL_curpad = AvARRAY(PL_comppad);
5963 PL_comppad_name = newAV();
5964 PL_comppad_name_fill = 0;
5965 PL_min_intro_pending = 0;
5967 PL_subline = PL_curcop->cop_line;
5969 av_store(PL_comppad_name, 0, newSVpv("@_", 2));
5970 PL_curpad[0] = (SV*)newAV();
5971 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
5972 #endif /* USE_THREADS */
5974 comppadlist = newAV();
5975 AvREAL_off(comppadlist);
5976 av_store(comppadlist, 0, (SV*)PL_comppad_name);
5977 av_store(comppadlist, 1, (SV*)PL_comppad);
5979 CvPADLIST(PL_compcv) = comppadlist;
5980 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
5982 CvOWNER(PL_compcv) = 0;
5983 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
5984 MUTEX_INIT(CvMUTEXP(PL_compcv));
5985 #endif /* USE_THREADS */
5987 return oldsavestack_ix;
6006 char *context = NULL;
6010 if (!yychar || (yychar == ';' && !PL_rsfp))
6012 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
6013 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
6014 while (isSPACE(*PL_oldoldbufptr))
6016 context = PL_oldoldbufptr;
6017 contlen = PL_bufptr - PL_oldoldbufptr;
6019 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
6020 PL_oldbufptr != PL_bufptr) {
6021 while (isSPACE(*PL_oldbufptr))
6023 context = PL_oldbufptr;
6024 contlen = PL_bufptr - PL_oldbufptr;
6026 else if (yychar > 255)
6027 where = "next token ???";
6028 else if ((yychar & 127) == 127) {
6029 if (PL_lex_state == LEX_NORMAL ||
6030 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
6031 where = "at end of line";
6032 else if (PL_lex_inpat)
6033 where = "within pattern";
6035 where = "within string";
6038 SV *where_sv = sv_2mortal(newSVpv("next char ", 0));
6040 sv_catpvf(where_sv, "^%c", toCTRL(yychar));
6041 else if (isPRINT_LC(yychar))
6042 sv_catpvf(where_sv, "%c", yychar);
6044 sv_catpvf(where_sv, "\\%03o", yychar & 255);
6045 where = SvPVX(where_sv);
6047 msg = sv_2mortal(newSVpv(s, 0));
6048 sv_catpvf(msg, " at %_ line %ld, ",
6049 GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line);
6051 sv_catpvf(msg, "near \"%.*s\"\n", contlen, context);
6053 sv_catpvf(msg, "%s\n", where);
6054 if (PL_multi_start < PL_multi_end && (U32)(PL_curcop->cop_line - PL_multi_end) <= 1) {
6056 " (Might be a runaway multi-line %c%c string starting on line %ld)\n",
6057 (int)PL_multi_open,(int)PL_multi_close,(long)PL_multi_start);
6062 else if (PL_in_eval)
6063 sv_catsv(ERRSV, msg);
6065 PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
6066 if (++PL_error_count >= 10)
6067 croak("%_ has too many errors.\n", GvSV(PL_curcop->cop_filegv));
6069 PL_in_my_stash = Nullhv;