3 * Copyright (c) 1991-1999, 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
15 #define PERL_IN_TOKE_C
18 #define yychar PL_yychar
19 #define yylval PL_yylval
21 static char ident_too_long[] = "Identifier too long";
23 #define UTF (PL_hints & HINT_UTF8)
25 * Note: we try to be careful never to call the isXXX_utf8() functions
26 * unless we're pretty sure we've seen the beginning of a UTF-8 character
27 * (that is, the two high bits are set). Otherwise we risk loading in the
28 * heavy-duty SWASHINIT and SWASHGET routines unnecessarily.
30 #define isIDFIRST_lazy(p) ((!UTF || (*((U8*)p) < 0xc0)) \
32 : isIDFIRST_utf8((U8*)p))
33 #define isALNUM_lazy(p) ((!UTF || (*((U8*)p) < 0xc0)) \
35 : isALNUM_utf8((U8*)p))
37 /* In variables name $^X, these are the legal values for X.
38 * 1999-02-27 mjd-perl-patch@plover.com */
39 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
41 /* The following are arranged oddly so that the guard on the switch statement
42 * can get by with a single comparison (if the compiler is smart enough).
45 /* #define LEX_NOTPARSING 11 is done in perl.h. */
48 #define LEX_INTERPNORMAL 9
49 #define LEX_INTERPCASEMOD 8
50 #define LEX_INTERPPUSH 7
51 #define LEX_INTERPSTART 6
52 #define LEX_INTERPEND 5
53 #define LEX_INTERPENDMAYBE 4
54 #define LEX_INTERPCONCAT 3
55 #define LEX_INTERPCONST 2
56 #define LEX_FORMLINE 1
57 #define LEX_KNOWNEXT 0
66 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
68 # include <unistd.h> /* Needed for execv() */
77 YYSTYPE* yylval_pointer = NULL;
78 int* yychar_pointer = NULL;
81 # define yylval (*yylval_pointer)
82 # define yychar (*yychar_pointer)
83 # define PERL_YYLEX_PARAM yylval_pointer,yychar_pointer
85 # define yylex() Perl_yylex(aTHX_ yylval_pointer, yychar_pointer)
93 #define CLINE (PL_copline = (PL_curcop->cop_line < PL_copline ? PL_curcop->cop_line : PL_copline))
95 #define TOKEN(retval) return (PL_bufptr = s,(int)retval)
96 #define OPERATOR(retval) return (PL_expect = XTERM,PL_bufptr = s,(int)retval)
97 #define AOPERATOR(retval) return ao((PL_expect = XTERM,PL_bufptr = s,(int)retval))
98 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s,(int)retval)
99 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval)
100 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s,(int)retval)
101 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR,PL_bufptr = s,(int)retval)
102 #define LOOPX(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX)
103 #define FTST(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)UNIOP)
104 #define FUN0(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0)
105 #define FUN1(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1)
106 #define BOop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITOROP))
107 #define BAop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP))
108 #define SHop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP))
109 #define PWop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)POWOP))
110 #define PMop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP)
111 #define Aop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)ADDOP))
112 #define Mop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MULOP))
113 #define Eop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)EQOP)
114 #define Rop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)RELOP)
116 /* This bit of chicanery makes a unary function followed by
117 * a parenthesis into a function with one argument, highest precedence.
119 #define UNI(f) return(yylval.ival = f, \
122 PL_last_uni = PL_oldbufptr, \
123 PL_last_lop_op = f, \
124 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
126 #define UNIBRACK(f) return(yylval.ival = f, \
128 PL_last_uni = PL_oldbufptr, \
129 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
131 /* grandfather return to old style */
132 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
135 S_ao(pTHX_ int toketype)
137 if (*PL_bufptr == '=') {
139 if (toketype == ANDAND)
140 yylval.ival = OP_ANDASSIGN;
141 else if (toketype == OROR)
142 yylval.ival = OP_ORASSIGN;
149 S_no_op(pTHX_ char *what, char *s)
151 char *oldbp = PL_bufptr;
152 bool is_first = (PL_oldbufptr == PL_linestart);
155 yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
157 Perl_warn(aTHX_ "\t(Missing semicolon on previous line?)\n");
158 else if (PL_oldoldbufptr && isIDFIRST_lazy(PL_oldoldbufptr)) {
160 for (t = PL_oldoldbufptr; *t && (isALNUM_lazy(t) || *t == ':'); t++) ;
161 if (t < PL_bufptr && isSPACE(*t))
162 Perl_warn(aTHX_ "\t(Do you need to predeclare %.*s?)\n",
163 t - PL_oldoldbufptr, PL_oldoldbufptr);
167 Perl_warn(aTHX_ "\t(Missing operator before end of line?)\n");
169 Perl_warn(aTHX_ "\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
174 S_missingterm(pTHX_ char *s)
179 char *nl = strrchr(s,'\n');
185 iscntrl(PL_multi_close)
187 PL_multi_close < 32 || PL_multi_close == 127
191 tmpbuf[1] = toCTRL(PL_multi_close);
197 *tmpbuf = PL_multi_close;
201 q = strchr(s,'"') ? '\'' : '"';
202 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
206 Perl_deprecate(pTHX_ char *s)
209 if (ckWARN(WARN_DEPRECATED))
210 Perl_warner(aTHX_ WARN_DEPRECATED, "Use of %s is deprecated", s);
216 deprecate("comma-less variable list");
222 S_win32_textfilter(pTHX_ int idx, SV *sv, int maxlen)
224 I32 count = FILTER_READ(idx+1, sv, maxlen);
225 if (count > 0 && !maxlen)
226 win32_strip_return(sv);
232 S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
234 I32 count = FILTER_READ(idx+1, sv, maxlen);
238 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
239 tend = utf16_to_utf8((U16*)SvPVX(sv), tmps, SvCUR(sv));
240 sv_usepvn(sv, (char*)tmps, tend - tmps);
247 S_utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
249 I32 count = FILTER_READ(idx+1, sv, maxlen);
253 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
254 tend = utf16_to_utf8_reversed((U16*)SvPVX(sv), tmps, SvCUR(sv));
255 sv_usepvn(sv, (char*)tmps, tend - tmps);
262 Perl_lex_start(pTHX_ SV *line)
268 SAVEI32(PL_lex_dojoin);
269 SAVEI32(PL_lex_brackets);
270 SAVEI32(PL_lex_fakebrack);
271 SAVEI32(PL_lex_casemods);
272 SAVEI32(PL_lex_starts);
273 SAVEI32(PL_lex_state);
274 SAVESPTR(PL_lex_inpat);
275 SAVEI32(PL_lex_inwhat);
276 SAVEI16(PL_curcop->cop_line);
279 SAVEPPTR(PL_oldbufptr);
280 SAVEPPTR(PL_oldoldbufptr);
281 SAVEPPTR(PL_linestart);
282 SAVESPTR(PL_linestr);
283 SAVEPPTR(PL_lex_brackstack);
284 SAVEPPTR(PL_lex_casestack);
285 SAVEDESTRUCTOR(S_restore_rsfp, PL_rsfp);
286 SAVESPTR(PL_lex_stuff);
287 SAVEI32(PL_lex_defer);
288 SAVESPTR(PL_lex_repl);
289 SAVEDESTRUCTOR(S_restore_expect, PL_tokenbuf + PL_expect); /* encode as pointer */
290 SAVEDESTRUCTOR(S_restore_lex_expect, PL_tokenbuf + PL_expect);
292 PL_lex_state = LEX_NORMAL;
296 PL_lex_fakebrack = 0;
297 New(899, PL_lex_brackstack, 120, char);
298 New(899, PL_lex_casestack, 12, char);
299 SAVEFREEPV(PL_lex_brackstack);
300 SAVEFREEPV(PL_lex_casestack);
302 *PL_lex_casestack = '\0';
305 PL_lex_stuff = Nullsv;
306 PL_lex_repl = Nullsv;
310 if (SvREADONLY(PL_linestr))
311 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
312 s = SvPV(PL_linestr, len);
313 if (len && s[len-1] != ';') {
314 if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
315 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
316 sv_catpvn(PL_linestr, "\n;", 2);
318 SvTEMP_off(PL_linestr);
319 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
320 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
322 PL_rs = newSVpvn("\n", 1);
329 PL_doextract = FALSE;
333 S_restore_rsfp(pTHX_ void *f)
335 PerlIO *fp = (PerlIO*)f;
337 if (PL_rsfp == PerlIO_stdin())
338 PerlIO_clearerr(PL_rsfp);
339 else if (PL_rsfp && (PL_rsfp != fp))
340 PerlIO_close(PL_rsfp);
345 S_restore_expect(pTHX_ void *e)
347 /* a safe way to store a small integer in a pointer */
348 PL_expect = (expectation)((char *)e - PL_tokenbuf);
352 S_restore_lex_expect(pTHX_ void *e)
354 /* a safe way to store a small integer in a pointer */
355 PL_lex_expect = (expectation)((char *)e - PL_tokenbuf);
359 S_incline(pTHX_ char *s)
367 PL_curcop->cop_line++;
370 while (*s == ' ' || *s == '\t') s++;
371 if (strnEQ(s, "line ", 5)) {
380 while (*s == ' ' || *s == '\t')
382 if (*s == '"' && (t = strchr(s+1, '"')))
386 return; /* false alarm */
387 for (t = s; !isSPACE(*t); t++) ;
392 PL_curcop->cop_filegv = gv_fetchfile(s);
394 PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
396 PL_curcop->cop_line = atoi(n)-1;
400 S_skipspace(pTHX_ register char *s)
403 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
404 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
410 while (s < PL_bufend && isSPACE(*s)) {
411 if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
414 if (s < PL_bufend && *s == '#') {
415 while (s < PL_bufend && *s != '\n')
419 if (PL_in_eval && !PL_rsfp) {
425 if (s < PL_bufend || !PL_rsfp || PL_lex_state != LEX_NORMAL)
427 if ((s = filter_gets(PL_linestr, PL_rsfp, (prevlen = SvCUR(PL_linestr)))) == Nullch) {
428 if (PL_minus_n || PL_minus_p) {
429 sv_setpv(PL_linestr,PL_minus_p ?
430 ";}continue{print or die qq(-p destination: $!\\n)" :
432 sv_catpv(PL_linestr,";}");
433 PL_minus_n = PL_minus_p = 0;
436 sv_setpv(PL_linestr,";");
437 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
438 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
439 if (PL_preprocess && !PL_in_eval)
440 (void)PerlProc_pclose(PL_rsfp);
441 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
442 PerlIO_clearerr(PL_rsfp);
444 (void)PerlIO_close(PL_rsfp);
448 PL_linestart = PL_bufptr = s + prevlen;
449 PL_bufend = s + SvCUR(PL_linestr);
452 if (PERLDB_LINE && PL_curstash != PL_debstash) {
453 SV *sv = NEWSV(85,0);
455 sv_upgrade(sv, SVt_PVMG);
456 sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
457 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
469 if (PL_oldoldbufptr != PL_last_uni)
471 while (isSPACE(*PL_last_uni))
473 for (s = PL_last_uni; isALNUM_lazy(s) || *s == '-'; s++) ;
474 if ((t = strchr(s, '(')) && t < PL_bufptr)
476 if (ckWARN_d(WARN_AMBIGUOUS)){
479 Perl_warner(aTHX_ WARN_AMBIGUOUS,
480 "Warning: Use of \"%s\" without parens is ambiguous",
489 #define UNI(f) return uni(f,s)
492 S_uni(pTHX_ I32 f, char *s)
497 PL_last_uni = PL_oldbufptr;
508 #endif /* CRIPPLED_CC */
510 #define LOP(f,x) return lop(f,x,s)
513 S_lop(pTHX_ I32 f, expectation x, char *s)
520 PL_last_lop = PL_oldbufptr;
534 S_force_next(pTHX_ I32 type)
536 PL_nexttype[PL_nexttoke] = type;
538 if (PL_lex_state != LEX_KNOWNEXT) {
539 PL_lex_defer = PL_lex_state;
540 PL_lex_expect = PL_expect;
541 PL_lex_state = LEX_KNOWNEXT;
546 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
551 start = skipspace(start);
553 if (isIDFIRST_lazy(s) ||
554 (allow_pack && *s == ':') ||
555 (allow_initial_tick && *s == '\'') )
557 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
558 if (check_keyword && keyword(PL_tokenbuf, len))
560 if (token == METHOD) {
565 PL_expect = XOPERATOR;
568 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(PL_tokenbuf,0));
569 PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
576 S_force_ident(pTHX_ register char *s, int kind)
579 OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
580 PL_nextval[PL_nexttoke].opval = o;
583 dTHR; /* just for in_eval */
584 o->op_private = OPpCONST_ENTERED;
585 /* XXX see note in pp_entereval() for why we forgo typo
586 warnings if the symbol must be introduced in an eval.
588 gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
589 kind == '$' ? SVt_PV :
590 kind == '@' ? SVt_PVAV :
591 kind == '%' ? SVt_PVHV :
599 S_force_version(pTHX_ char *s)
601 OP *version = Nullop;
605 /* default VERSION number -- GBARR */
610 for( d=s, c = 1; isDIGIT(*d) || *d == '_' || (*d == '.' && c--); d++);
611 if((*d == ';' || isSPACE(*d)) && *(skipspace(d)) != ',') {
613 /* real VERSION number -- GBARR */
614 version = yylval.opval;
618 /* NOTE: The parser sees the package name and the VERSION swapped */
619 PL_nextval[PL_nexttoke].opval = version;
626 S_tokeq(pTHX_ SV *sv)
637 s = SvPV_force(sv, len);
641 while (s < send && *s != '\\')
646 if ( PL_hints & HINT_NEW_STRING )
647 pv = sv_2mortal(newSVpvn(SvPVX(pv), len));
650 if (s + 1 < send && (s[1] == '\\'))
651 s++; /* all that, just for this */
656 SvCUR_set(sv, d - SvPVX(sv));
658 if ( PL_hints & HINT_NEW_STRING )
659 return new_constant(NULL, 0, "q", sv, pv, "q");
666 register I32 op_type = yylval.ival;
668 if (op_type == OP_NULL) {
669 yylval.opval = PL_lex_op;
673 if (op_type == OP_CONST || op_type == OP_READLINE) {
674 SV *sv = tokeq(PL_lex_stuff);
676 if (SvTYPE(sv) == SVt_PVIV) {
677 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
683 nsv = newSVpvn(p, len);
687 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
688 PL_lex_stuff = Nullsv;
692 PL_sublex_info.super_state = PL_lex_state;
693 PL_sublex_info.sub_inwhat = op_type;
694 PL_sublex_info.sub_op = PL_lex_op;
695 PL_lex_state = LEX_INTERPPUSH;
699 yylval.opval = PL_lex_op;
713 PL_lex_state = PL_sublex_info.super_state;
714 SAVEI32(PL_lex_dojoin);
715 SAVEI32(PL_lex_brackets);
716 SAVEI32(PL_lex_fakebrack);
717 SAVEI32(PL_lex_casemods);
718 SAVEI32(PL_lex_starts);
719 SAVEI32(PL_lex_state);
720 SAVESPTR(PL_lex_inpat);
721 SAVEI32(PL_lex_inwhat);
722 SAVEI16(PL_curcop->cop_line);
724 SAVEPPTR(PL_oldbufptr);
725 SAVEPPTR(PL_oldoldbufptr);
726 SAVEPPTR(PL_linestart);
727 SAVESPTR(PL_linestr);
728 SAVEPPTR(PL_lex_brackstack);
729 SAVEPPTR(PL_lex_casestack);
731 PL_linestr = PL_lex_stuff;
732 PL_lex_stuff = Nullsv;
734 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
735 PL_bufend += SvCUR(PL_linestr);
736 SAVEFREESV(PL_linestr);
738 PL_lex_dojoin = FALSE;
740 PL_lex_fakebrack = 0;
741 New(899, PL_lex_brackstack, 120, char);
742 New(899, PL_lex_casestack, 12, char);
743 SAVEFREEPV(PL_lex_brackstack);
744 SAVEFREEPV(PL_lex_casestack);
746 *PL_lex_casestack = '\0';
748 PL_lex_state = LEX_INTERPCONCAT;
749 PL_curcop->cop_line = PL_multi_start;
751 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
752 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
753 PL_lex_inpat = PL_sublex_info.sub_op;
755 PL_lex_inpat = Nullop;
763 if (!PL_lex_starts++) {
764 PL_expect = XOPERATOR;
765 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpvn("",0));
769 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
770 PL_lex_state = LEX_INTERPCASEMOD;
774 /* Is there a right-hand side to take care of? */
775 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
776 PL_linestr = PL_lex_repl;
778 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
779 PL_bufend += SvCUR(PL_linestr);
780 SAVEFREESV(PL_linestr);
781 PL_lex_dojoin = FALSE;
783 PL_lex_fakebrack = 0;
785 *PL_lex_casestack = '\0';
787 if (SvEVALED(PL_lex_repl)) {
788 PL_lex_state = LEX_INTERPNORMAL;
790 /* we don't clear PL_lex_repl here, so that we can check later
791 whether this is an evalled subst; that means we rely on the
792 logic to ensure sublex_done() is called again only via the
793 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
796 PL_lex_state = LEX_INTERPCONCAT;
797 PL_lex_repl = Nullsv;
803 PL_bufend = SvPVX(PL_linestr);
804 PL_bufend += SvCUR(PL_linestr);
805 PL_expect = XOPERATOR;
813 Extracts a pattern, double-quoted string, or transliteration. This
816 It looks at lex_inwhat and PL_lex_inpat to find out whether it's
817 processing a pattern (PL_lex_inpat is true), a transliteration
818 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
820 Returns a pointer to the character scanned up to. Iff this is
821 advanced from the start pointer supplied (ie if anything was
822 successfully parsed), will leave an OP for the substring scanned
823 in yylval. Caller must intuit reason for not parsing further
824 by looking at the next characters herself.
828 double-quoted style: \r and \n
829 regexp special ones: \D \s
831 backrefs: \1 (deprecated in substitution replacements)
832 case and quoting: \U \Q \E
833 stops on @ and $, but not for $ as tail anchor
836 characters are VERY literal, except for - not at the start or end
837 of the string, which indicates a range. scan_const expands the
838 range to the full set of intermediate characters.
840 In double-quoted strings:
842 double-quoted style: \r and \n
844 backrefs: \1 (deprecated)
845 case and quoting: \U \Q \E
848 scan_const does *not* construct ops to handle interpolated strings.
849 It stops processing as soon as it finds an embedded $ or @ variable
850 and leaves it to the caller to work out what's going on.
852 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
854 $ in pattern could be $foo or could be tail anchor. Assumption:
855 it's a tail anchor if $ is the last thing in the string, or if it's
856 followed by one of ")| \n\t"
858 \1 (backreferences) are turned into $1
860 The structure of the code is
861 while (there's a character to process) {
862 handle transliteration ranges
864 skip # initiated comments in //x patterns
865 check for embedded @foo
866 check for embedded scalars
868 leave intact backslashes from leave (below)
869 deprecate \1 in strings and sub replacements
870 handle string-changing backslashes \l \U \Q \E, etc.
871 switch (what was escaped) {
872 handle - in a transliteration (becomes a literal -)
873 handle \132 octal characters
874 handle 0x15 hex characters
875 handle \cV (control V)
876 handle printf backslashes (\f, \r, \n, etc)
879 } (end while character to read)
884 S_scan_const(pTHX_ char *start)
886 register char *send = PL_bufend; /* end of the constant */
887 SV *sv = NEWSV(93, send - start); /* sv for the constant */
888 register char *s = start; /* start of the constant */
889 register char *d = SvPVX(sv); /* destination for copies */
890 bool dorange = FALSE; /* are we in a translit range? */
892 I32 utf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op)
893 ? (PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
895 I32 thisutf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op)
896 ? (PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF))
899 /* leaveit is the set of acceptably-backslashed characters */
902 ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
905 while (s < send || dorange) {
906 /* get transliterations out of the way (they're most literal) */
907 if (PL_lex_inwhat == OP_TRANS) {
908 /* expand a range A-Z to the full set of characters. AIE! */
910 I32 i; /* current expanded character */
911 I32 min; /* first character in range */
912 I32 max; /* last character in range */
914 i = d - SvPVX(sv); /* remember current offset */
915 SvGROW(sv, SvLEN(sv) + 256); /* expand the sv -- there'll never be more'n 256 chars in a range for it to grow by */
916 d = SvPVX(sv) + i; /* restore d after the grow potentially has changed the ptr */
917 d -= 2; /* eat the first char and the - */
919 min = (U8)*d; /* first char in range */
920 max = (U8)d[1]; /* last char in range */
923 if ((isLOWER(min) && isLOWER(max)) ||
924 (isUPPER(min) && isUPPER(max))) {
926 for (i = min; i <= max; i++)
930 for (i = min; i <= max; i++)
937 for (i = min; i <= max; i++)
940 /* mark the range as done, and continue */
945 /* range begins (ignore - as first or last char) */
946 else if (*s == '-' && s+1 < send && s != start) {
948 *d++ = (char)0xff; /* use illegal utf8 byte--see pmtrans */
957 /* if we get here, we're not doing a transliteration */
959 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
960 except for the last char, which will be done separately. */
961 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
963 while (s < send && *s != ')')
965 } else if (s[2] == '{'
966 || s[2] == 'p' && s[3] == '{') { /* This should march regcomp.c */
968 char *regparse = s + (s[2] == '{' ? 3 : 4);
971 while (count && (c = *regparse)) {
972 if (c == '\\' && regparse[1])
980 if (*regparse != ')') {
981 regparse--; /* Leave one char for continuation. */
982 yyerror("Sequence (?{...}) not terminated or not {}-balanced");
989 /* likewise skip #-initiated comments in //x patterns */
990 else if (*s == '#' && PL_lex_inpat &&
991 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
992 while (s+1 < send && *s != '\n')
996 /* check for embedded arrays (@foo, @:foo, @'foo, @{foo}, @$foo) */
997 else if (*s == '@' && s[1] && (isALNUM_lazy(s+1) || strchr(":'{$", s[1])))
1000 /* check for embedded scalars. only stop if we're sure it's a
1003 else if (*s == '$') {
1004 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
1006 if (s + 1 < send && !strchr("()| \n\t", s[1]))
1007 break; /* in regexp, $ might be tail anchor */
1010 /* (now in tr/// code again) */
1012 if (*s & 0x80 && thisutf) {
1013 dTHR; /* only for ckWARN */
1014 if (ckWARN(WARN_UTF8)) {
1015 (void)utf8_to_uv((U8*)s, &len); /* could cvt latin-1 to utf8 here... */
1025 if (*s == '\\' && s+1 < send) {
1028 /* some backslashes we leave behind */
1029 if (*leaveit && *s && strchr(leaveit, *s)) {
1035 /* deprecate \1 in strings and substitution replacements */
1036 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1037 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1039 dTHR; /* only for ckWARN */
1040 if (ckWARN(WARN_SYNTAX))
1041 Perl_warner(aTHX_ WARN_SYNTAX, "\\%c better written as $%c", *s, *s);
1046 /* string-change backslash escapes */
1047 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1052 /* if we get here, it's either a quoted -, or a digit */
1055 /* quoted - in transliterations */
1057 if (PL_lex_inwhat == OP_TRANS) {
1065 if (ckWARN(WARN_UNSAFE) && isALPHA(*s))
1066 Perl_warner(aTHX_ WARN_UNSAFE,
1067 "Unrecognized escape \\%c passed through",
1069 /* default action is to copy the quoted character */
1074 /* \132 indicates an octal constant */
1075 case '0': case '1': case '2': case '3':
1076 case '4': case '5': case '6': case '7':
1077 *d++ = scan_oct(s, 3, &len);
1081 /* \x24 indicates a hex constant */
1085 char* e = strchr(s, '}');
1088 yyerror("Missing right brace on \\x{}");
1093 if (ckWARN(WARN_UTF8))
1094 Perl_warner(aTHX_ WARN_UTF8,
1095 "Use of \\x{} without utf8 declaration");
1097 /* note: utf always shorter than hex */
1098 d = (char*)uv_to_utf8((U8*)d,
1099 scan_hex(s + 1, e - s - 1, &len));
1104 UV uv = (UV)scan_hex(s, 2, &len);
1105 if (utf && PL_lex_inwhat == OP_TRANS &&
1106 utf != (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
1108 d = (char*)uv_to_utf8((U8*)d, uv); /* doing a CU or UC */
1111 if (uv >= 127 && UTF) {
1113 if (ckWARN(WARN_UTF8))
1114 Perl_warner(aTHX_ WARN_UTF8,
1115 "\\x%.*s will produce malformed UTF-8 character; use \\x{%.*s} for that",
1124 /* \c is a control character */
1138 /* printf-style backslashes, formfeeds, newlines, etc */
1156 *d++ = '\047'; /* CP 1047 */
1159 *d++ = '\057'; /* CP 1047 */
1173 } /* end if (backslash) */
1176 } /* while loop to process each character */
1178 /* terminate the string and set up the sv */
1180 SvCUR_set(sv, d - SvPVX(sv));
1183 /* shrink the sv if we allocated more than we used */
1184 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1185 SvLEN_set(sv, SvCUR(sv) + 1);
1186 Renew(SvPVX(sv), SvLEN(sv), char);
1189 /* return the substring (via yylval) only if we parsed anything */
1190 if (s > PL_bufptr) {
1191 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1192 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1194 ( PL_lex_inwhat == OP_TRANS
1196 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1199 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1205 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1207 S_intuit_more(pTHX_ register char *s)
1209 if (PL_lex_brackets)
1211 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1213 if (*s != '{' && *s != '[')
1218 /* In a pattern, so maybe we have {n,m}. */
1235 /* On the other hand, maybe we have a character class */
1238 if (*s == ']' || *s == '^')
1241 int weight = 2; /* let's weigh the evidence */
1243 unsigned char un_char = 255, last_un_char;
1244 char *send = strchr(s,']');
1245 char tmpbuf[sizeof PL_tokenbuf * 4];
1247 if (!send) /* has to be an expression */
1250 Zero(seen,256,char);
1253 else if (isDIGIT(*s)) {
1255 if (isDIGIT(s[1]) && s[2] == ']')
1261 for (; s < send; s++) {
1262 last_un_char = un_char;
1263 un_char = (unsigned char)*s;
1268 weight -= seen[un_char] * 10;
1269 if (isALNUM_lazy(s+1)) {
1270 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1271 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1276 else if (*s == '$' && s[1] &&
1277 strchr("[#!%*<>()-=",s[1])) {
1278 if (/*{*/ strchr("])} =",s[2]))
1287 if (strchr("wds]",s[1]))
1289 else if (seen['\''] || seen['"'])
1291 else if (strchr("rnftbxcav",s[1]))
1293 else if (isDIGIT(s[1])) {
1295 while (s[1] && isDIGIT(s[1]))
1305 if (strchr("aA01! ",last_un_char))
1307 if (strchr("zZ79~",s[1]))
1309 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1310 weight -= 5; /* cope with negative subscript */
1313 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1314 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1319 if (keyword(tmpbuf, d - tmpbuf))
1322 if (un_char == last_un_char + 1)
1324 weight -= seen[un_char];
1329 if (weight >= 0) /* probably a character class */
1337 S_intuit_method(pTHX_ char *start, GV *gv)
1339 char *s = start + (*start == '$');
1340 char tmpbuf[sizeof PL_tokenbuf];
1348 if ((cv = GvCVu(gv))) {
1349 char *proto = SvPVX(cv);
1359 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1360 if (*start == '$') {
1361 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1366 return *s == '(' ? FUNCMETH : METHOD;
1368 if (!keyword(tmpbuf, len)) {
1369 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1374 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1375 if (indirgv && GvCVu(indirgv))
1377 /* filehandle or package name makes it a method */
1378 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1380 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1381 return 0; /* no assumptions -- "=>" quotes bearword */
1383 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1384 newSVpvn(tmpbuf,len));
1385 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1389 return *s == '(' ? FUNCMETH : METHOD;
1399 char *pdb = PerlEnv_getenv("PERL5DB");
1403 SETERRNO(0,SS$_NORMAL);
1404 return "BEGIN { require 'perl5db.pl' }";
1410 /* Encoded script support. filter_add() effectively inserts a
1411 * 'pre-processing' function into the current source input stream.
1412 * Note that the filter function only applies to the current source file
1413 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1415 * The datasv parameter (which may be NULL) can be used to pass
1416 * private data to this instance of the filter. The filter function
1417 * can recover the SV using the FILTER_DATA macro and use it to
1418 * store private buffers and state information.
1420 * The supplied datasv parameter is upgraded to a PVIO type
1421 * and the IoDIRP field is used to store the function pointer.
1422 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1423 * private use must be set using malloc'd pointers.
1427 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
1429 if (!funcp){ /* temporary handy debugging hack to be deleted */
1430 PL_filter_debug = atoi((char*)datasv);
1433 if (!PL_rsfp_filters)
1434 PL_rsfp_filters = newAV();
1436 datasv = NEWSV(255,0);
1437 if (!SvUPGRADE(datasv, SVt_PVIO))
1438 Perl_die(aTHX_ "Can't upgrade filter_add data to SVt_PVIO");
1439 IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
1441 if (PL_filter_debug) {
1443 Perl_warn(aTHX_ "filter_add func %p (%s)", funcp, SvPV(datasv, n_a));
1445 #endif /* DEBUGGING */
1446 av_unshift(PL_rsfp_filters, 1);
1447 av_store(PL_rsfp_filters, 0, datasv) ;
1452 /* Delete most recently added instance of this filter function. */
1454 Perl_filter_del(pTHX_ filter_t funcp)
1457 if (PL_filter_debug)
1458 Perl_warn(aTHX_ "filter_del func %p", funcp);
1459 #endif /* DEBUGGING */
1460 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
1462 /* if filter is on top of stack (usual case) just pop it off */
1463 if (IoDIRP(FILTER_DATA(AvFILLp(PL_rsfp_filters))) == (DIR*)funcp){
1464 IoDIRP(FILTER_DATA(AvFILLp(PL_rsfp_filters))) = NULL;
1465 sv_free(av_pop(PL_rsfp_filters));
1469 /* we need to search for the correct entry and clear it */
1470 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
1474 /* Invoke the n'th filter function for the current rsfp. */
1476 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
1479 /* 0 = read one text line */
1484 if (!PL_rsfp_filters)
1486 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
1487 /* Provide a default input filter to make life easy. */
1488 /* Note that we append to the line. This is handy. */
1490 if (PL_filter_debug)
1491 Perl_warn(aTHX_ "filter_read %d: from rsfp\n", idx);
1492 #endif /* DEBUGGING */
1496 int old_len = SvCUR(buf_sv) ;
1498 /* ensure buf_sv is large enough */
1499 SvGROW(buf_sv, old_len + maxlen) ;
1500 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1501 if (PerlIO_error(PL_rsfp))
1502 return -1; /* error */
1504 return 0 ; /* end of file */
1506 SvCUR_set(buf_sv, old_len + len) ;
1509 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
1510 if (PerlIO_error(PL_rsfp))
1511 return -1; /* error */
1513 return 0 ; /* end of file */
1516 return SvCUR(buf_sv);
1518 /* Skip this filter slot if filter has been deleted */
1519 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
1521 if (PL_filter_debug)
1522 Perl_warn(aTHX_ "filter_read %d: skipped (filter deleted)\n", idx);
1523 #endif /* DEBUGGING */
1524 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1526 /* Get function pointer hidden within datasv */
1527 funcp = (filter_t)IoDIRP(datasv);
1529 if (PL_filter_debug) {
1531 Perl_warn(aTHX_ "filter_read %d: via function %p (%s)\n",
1532 idx, funcp, SvPV(datasv,n_a));
1534 #endif /* DEBUGGING */
1535 /* Call function. The function is expected to */
1536 /* call "FILTER_READ(idx+1, buf_sv)" first. */
1537 /* Return: <0:error, =0:eof, >0:not eof */
1538 return (*funcp)(aTHXo_ idx, buf_sv, maxlen);
1542 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
1545 if (!PL_rsfp_filters) {
1546 filter_add(win32_textfilter,NULL);
1549 if (PL_rsfp_filters) {
1552 SvCUR_set(sv, 0); /* start with empty line */
1553 if (FILTER_READ(0, sv, 0) > 0)
1554 return ( SvPVX(sv) ) ;
1559 return (sv_gets(sv, fp, append));
1564 static char* exp_name[] =
1565 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "TERMBLOCK" };
1571 Works out what to call the token just pulled out of the input
1572 stream. The yacc parser takes care of taking the ops we return and
1573 stitching them into a tree.
1579 if read an identifier
1580 if we're in a my declaration
1581 croak if they tried to say my($foo::bar)
1582 build the ops for a my() declaration
1583 if it's an access to a my() variable
1584 are we in a sort block?
1585 croak if my($a); $a <=> $b
1586 build ops for access to a my() variable
1587 if in a dq string, and they've said @foo and we can't find @foo
1589 build ops for a bareword
1590 if we already built the token before, use it.
1594 #ifdef USE_PURE_BISON
1595 Perl_yylex(pTHX_ YYSTYPE *lvalp, int *lcharp)
1608 #ifdef USE_PURE_BISON
1609 yylval_pointer = lvalp;
1610 yychar_pointer = lcharp;
1613 /* check if there's an identifier for us to look at */
1614 if (PL_pending_ident) {
1615 /* pit holds the identifier we read and pending_ident is reset */
1616 char pit = PL_pending_ident;
1617 PL_pending_ident = 0;
1619 /* if we're in a my(), we can't allow dynamics here.
1620 $foo'bar has already been turned into $foo::bar, so
1621 just check for colons.
1623 if it's a legal name, the OP is a PADANY.
1626 if (strchr(PL_tokenbuf,':'))
1627 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
1629 yylval.opval = newOP(OP_PADANY, 0);
1630 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
1635 build the ops for accesses to a my() variable.
1637 Deny my($a) or my($b) in a sort block, *if* $a or $b is
1638 then used in a comparison. This catches most, but not
1639 all cases. For instance, it catches
1640 sort { my($a); $a <=> $b }
1642 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
1643 (although why you'd do that is anyone's guess).
1646 if (!strchr(PL_tokenbuf,':')) {
1648 /* Check for single character per-thread SVs */
1649 if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
1650 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
1651 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
1653 yylval.opval = newOP(OP_THREADSV, 0);
1654 yylval.opval->op_targ = tmp;
1657 #endif /* USE_THREADS */
1658 if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
1659 /* if it's a sort block and they're naming $a or $b */
1660 if (PL_last_lop_op == OP_SORT &&
1661 PL_tokenbuf[0] == '$' &&
1662 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
1665 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
1666 d < PL_bufend && *d != '\n';
1669 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
1670 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
1676 yylval.opval = newOP(OP_PADANY, 0);
1677 yylval.opval->op_targ = tmp;
1683 Whine if they've said @foo in a doublequoted string,
1684 and @foo isn't a variable we can find in the symbol
1687 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
1688 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
1689 if (!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
1690 yyerror(Perl_form(aTHX_ "In string, %s now must be written as \\%s",
1691 PL_tokenbuf, PL_tokenbuf));
1694 /* build ops for a bareword */
1695 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
1696 yylval.opval->op_private = OPpCONST_ENTERED;
1697 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
1698 ((PL_tokenbuf[0] == '$') ? SVt_PV
1699 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
1704 /* no identifier pending identification */
1706 switch (PL_lex_state) {
1708 case LEX_NORMAL: /* Some compilers will produce faster */
1709 case LEX_INTERPNORMAL: /* code if we comment these out. */
1713 /* when we're already built the next token, just pull it out the queue */
1716 yylval = PL_nextval[PL_nexttoke];
1718 PL_lex_state = PL_lex_defer;
1719 PL_expect = PL_lex_expect;
1720 PL_lex_defer = LEX_NORMAL;
1722 return(PL_nexttype[PL_nexttoke]);
1724 /* interpolated case modifiers like \L \U, including \Q and \E.
1725 when we get here, PL_bufptr is at the \
1727 case LEX_INTERPCASEMOD:
1729 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
1730 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
1732 /* handle \E or end of string */
1733 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
1737 if (PL_lex_casemods) {
1738 oldmod = PL_lex_casestack[--PL_lex_casemods];
1739 PL_lex_casestack[PL_lex_casemods] = '\0';
1741 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
1743 PL_lex_state = LEX_INTERPCONCAT;
1747 if (PL_bufptr != PL_bufend)
1749 PL_lex_state = LEX_INTERPCONCAT;
1754 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
1755 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
1756 if (strchr("LU", *s) &&
1757 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
1759 PL_lex_casestack[--PL_lex_casemods] = '\0';
1762 if (PL_lex_casemods > 10) {
1763 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
1764 if (newlb != PL_lex_casestack) {
1766 PL_lex_casestack = newlb;
1769 PL_lex_casestack[PL_lex_casemods++] = *s;
1770 PL_lex_casestack[PL_lex_casemods] = '\0';
1771 PL_lex_state = LEX_INTERPCONCAT;
1772 PL_nextval[PL_nexttoke].ival = 0;
1775 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
1777 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
1779 PL_nextval[PL_nexttoke].ival = OP_LC;
1781 PL_nextval[PL_nexttoke].ival = OP_UC;
1783 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
1785 Perl_croak(aTHX_ "panic: yylex");
1788 if (PL_lex_starts) {
1797 case LEX_INTERPPUSH:
1798 return sublex_push();
1800 case LEX_INTERPSTART:
1801 if (PL_bufptr == PL_bufend)
1802 return sublex_done();
1804 PL_lex_dojoin = (*PL_bufptr == '@');
1805 PL_lex_state = LEX_INTERPNORMAL;
1806 if (PL_lex_dojoin) {
1807 PL_nextval[PL_nexttoke].ival = 0;
1810 PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
1811 PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
1812 force_next(PRIVATEREF);
1814 force_ident("\"", '$');
1815 #endif /* USE_THREADS */
1816 PL_nextval[PL_nexttoke].ival = 0;
1818 PL_nextval[PL_nexttoke].ival = 0;
1820 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
1823 if (PL_lex_starts++) {
1829 case LEX_INTERPENDMAYBE:
1830 if (intuit_more(PL_bufptr)) {
1831 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
1837 if (PL_lex_dojoin) {
1838 PL_lex_dojoin = FALSE;
1839 PL_lex_state = LEX_INTERPCONCAT;
1842 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
1843 && SvEVALED(PL_lex_repl))
1845 if (PL_bufptr != PL_bufend)
1846 Perl_croak(aTHX_ "Bad evalled substitution pattern");
1847 PL_lex_repl = Nullsv;
1850 case LEX_INTERPCONCAT:
1852 if (PL_lex_brackets)
1853 Perl_croak(aTHX_ "panic: INTERPCONCAT");
1855 if (PL_bufptr == PL_bufend)
1856 return sublex_done();
1858 if (SvIVX(PL_linestr) == '\'') {
1859 SV *sv = newSVsv(PL_linestr);
1862 else if ( PL_hints & HINT_NEW_RE )
1863 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
1864 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1868 s = scan_const(PL_bufptr);
1870 PL_lex_state = LEX_INTERPCASEMOD;
1872 PL_lex_state = LEX_INTERPSTART;
1875 if (s != PL_bufptr) {
1876 PL_nextval[PL_nexttoke] = yylval;
1879 if (PL_lex_starts++)
1889 PL_lex_state = LEX_NORMAL;
1890 s = scan_formline(PL_bufptr);
1891 if (!PL_lex_formbrack)
1897 PL_oldoldbufptr = PL_oldbufptr;
1900 PerlIO_printf(PerlIO_stderr(), "### Tokener expecting %s at %s\n", exp_name[PL_expect], s);
1906 if (isIDFIRST_lazy(s))
1908 Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
1911 goto fake_eof; /* emulate EOF on ^D or ^Z */
1916 if (PL_lex_brackets)
1917 yyerror("Missing right curly or square bracket");
1920 if (s++ < PL_bufend)
1921 goto retry; /* ignore stray nulls */
1924 if (!PL_in_eval && !PL_preambled) {
1925 PL_preambled = TRUE;
1926 sv_setpv(PL_linestr,incl_perldb());
1927 if (SvCUR(PL_linestr))
1928 sv_catpv(PL_linestr,";");
1930 while(AvFILLp(PL_preambleav) >= 0) {
1931 SV *tmpsv = av_shift(PL_preambleav);
1932 sv_catsv(PL_linestr, tmpsv);
1933 sv_catpv(PL_linestr, ";");
1936 sv_free((SV*)PL_preambleav);
1937 PL_preambleav = NULL;
1939 if (PL_minus_n || PL_minus_p) {
1940 sv_catpv(PL_linestr, "LINE: while (<>) {");
1942 sv_catpv(PL_linestr,"chomp;");
1944 GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
1946 GvIMPORTED_AV_on(gv);
1948 if (strchr("/'\"", *PL_splitstr)
1949 && strchr(PL_splitstr + 1, *PL_splitstr))
1950 Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s);", PL_splitstr);
1953 s = "'~#\200\1'"; /* surely one char is unused...*/
1954 while (s[1] && strchr(PL_splitstr, *s)) s++;
1956 Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s%c",
1957 "q" + (delim == '\''), delim);
1958 for (s = PL_splitstr; *s; s++) {
1960 sv_catpvn(PL_linestr, "\\", 1);
1961 sv_catpvn(PL_linestr, s, 1);
1963 Perl_sv_catpvf(aTHX_ PL_linestr, "%c);", delim);
1967 sv_catpv(PL_linestr,"@F=split(' ');");
1970 sv_catpv(PL_linestr, "\n");
1971 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1972 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1973 if (PERLDB_LINE && PL_curstash != PL_debstash) {
1974 SV *sv = NEWSV(85,0);
1976 sv_upgrade(sv, SVt_PVMG);
1977 sv_setsv(sv,PL_linestr);
1978 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
1983 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
1986 if (PL_preprocess && !PL_in_eval)
1987 (void)PerlProc_pclose(PL_rsfp);
1988 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
1989 PerlIO_clearerr(PL_rsfp);
1991 (void)PerlIO_close(PL_rsfp);
1993 PL_doextract = FALSE;
1995 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
1996 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
1997 sv_catpv(PL_linestr,";}");
1998 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1999 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2000 PL_minus_n = PL_minus_p = 0;
2003 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2004 sv_setpv(PL_linestr,"");
2005 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
2008 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
2009 PL_doextract = FALSE;
2011 /* Incest with pod. */
2012 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2013 sv_setpv(PL_linestr, "");
2014 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2015 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2016 PL_doextract = FALSE;
2020 } while (PL_doextract);
2021 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2022 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2023 SV *sv = NEWSV(85,0);
2025 sv_upgrade(sv, SVt_PVMG);
2026 sv_setsv(sv,PL_linestr);
2027 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
2029 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2030 if (PL_curcop->cop_line == 1) {
2031 while (s < PL_bufend && isSPACE(*s))
2033 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2037 if (*s == '#' && *(s+1) == '!')
2039 #ifdef ALTERNATE_SHEBANG
2041 static char as[] = ALTERNATE_SHEBANG;
2042 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2043 d = s + (sizeof(as) - 1);
2045 #endif /* ALTERNATE_SHEBANG */
2054 while (*d && !isSPACE(*d))
2058 #ifdef ARG_ZERO_IS_SCRIPT
2059 if (ipathend > ipath) {
2061 * HP-UX (at least) sets argv[0] to the script name,
2062 * which makes $^X incorrect. And Digital UNIX and Linux,
2063 * at least, set argv[0] to the basename of the Perl
2064 * interpreter. So, having found "#!", we'll set it right.
2066 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
2067 assert(SvPOK(x) || SvGMAGICAL(x));
2068 if (sv_eq(x, GvSV(PL_curcop->cop_filegv))) {
2069 sv_setpvn(x, ipath, ipathend - ipath);
2072 TAINT_NOT; /* $^X is always tainted, but that's OK */
2074 #endif /* ARG_ZERO_IS_SCRIPT */
2079 d = instr(s,"perl -");
2081 d = instr(s,"perl");
2082 #ifdef ALTERNATE_SHEBANG
2084 * If the ALTERNATE_SHEBANG on this system starts with a
2085 * character that can be part of a Perl expression, then if
2086 * we see it but not "perl", we're probably looking at the
2087 * start of Perl code, not a request to hand off to some
2088 * other interpreter. Similarly, if "perl" is there, but
2089 * not in the first 'word' of the line, we assume the line
2090 * contains the start of the Perl program.
2092 if (d && *s != '#') {
2094 while (*c && !strchr("; \t\r\n\f\v#", *c))
2097 d = Nullch; /* "perl" not in first word; ignore */
2099 *s = '#'; /* Don't try to parse shebang line */
2101 #endif /* ALTERNATE_SHEBANG */
2106 !instr(s,"indir") &&
2107 instr(PL_origargv[0],"perl"))
2113 while (s < PL_bufend && isSPACE(*s))
2115 if (s < PL_bufend) {
2116 Newz(899,newargv,PL_origargc+3,char*);
2118 while (s < PL_bufend && !isSPACE(*s))
2121 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2124 newargv = PL_origargv;
2126 PerlProc_execv(ipath, newargv);
2127 Perl_croak(aTHX_ "Can't exec %s", ipath);
2130 U32 oldpdb = PL_perldb;
2131 bool oldn = PL_minus_n;
2132 bool oldp = PL_minus_p;
2134 while (*d && !isSPACE(*d)) d++;
2135 while (*d == ' ' || *d == '\t') d++;
2139 if (*d == 'M' || *d == 'm') {
2141 while (*d && !isSPACE(*d)) d++;
2142 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2145 d = moreswitches(d);
2147 if (PERLDB_LINE && !oldpdb ||
2148 ( PL_minus_n || PL_minus_p ) && !(oldn || oldp) )
2149 /* if we have already added "LINE: while (<>) {",
2150 we must not do it again */
2152 sv_setpv(PL_linestr, "");
2153 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2154 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2155 PL_preambled = FALSE;
2157 (void)gv_fetchfile(PL_origfilename);
2164 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2166 PL_lex_state = LEX_FORMLINE;
2171 #ifdef PERL_STRICT_CR
2172 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2174 "(Maybe you didn't strip carriage returns after a network transfer?)\n");
2176 case ' ': case '\t': case '\f': case 013:
2181 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2183 while (s < d && *s != '\n')
2188 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2190 PL_lex_state = LEX_FORMLINE;
2200 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2205 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2208 if (strnEQ(s,"=>",2)) {
2209 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2210 OPERATOR('-'); /* unary minus */
2212 PL_last_uni = PL_oldbufptr;
2213 PL_last_lop_op = OP_FTEREAD; /* good enough */
2215 case 'r': FTST(OP_FTEREAD);
2216 case 'w': FTST(OP_FTEWRITE);
2217 case 'x': FTST(OP_FTEEXEC);
2218 case 'o': FTST(OP_FTEOWNED);
2219 case 'R': FTST(OP_FTRREAD);
2220 case 'W': FTST(OP_FTRWRITE);
2221 case 'X': FTST(OP_FTREXEC);
2222 case 'O': FTST(OP_FTROWNED);
2223 case 'e': FTST(OP_FTIS);
2224 case 'z': FTST(OP_FTZERO);
2225 case 's': FTST(OP_FTSIZE);
2226 case 'f': FTST(OP_FTFILE);
2227 case 'd': FTST(OP_FTDIR);
2228 case 'l': FTST(OP_FTLINK);
2229 case 'p': FTST(OP_FTPIPE);
2230 case 'S': FTST(OP_FTSOCK);
2231 case 'u': FTST(OP_FTSUID);
2232 case 'g': FTST(OP_FTSGID);
2233 case 'k': FTST(OP_FTSVTX);
2234 case 'b': FTST(OP_FTBLK);
2235 case 'c': FTST(OP_FTCHR);
2236 case 't': FTST(OP_FTTTY);
2237 case 'T': FTST(OP_FTTEXT);
2238 case 'B': FTST(OP_FTBINARY);
2239 case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2240 case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2241 case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
2243 Perl_croak(aTHX_ "Unrecognized file test: -%c", (int)tmp);
2250 if (PL_expect == XOPERATOR)
2255 else if (*s == '>') {
2258 if (isIDFIRST_lazy(s)) {
2259 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2267 if (PL_expect == XOPERATOR)
2270 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2272 OPERATOR('-'); /* unary minus */
2279 if (PL_expect == XOPERATOR)
2284 if (PL_expect == XOPERATOR)
2287 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2293 if (PL_expect != XOPERATOR) {
2294 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2295 PL_expect = XOPERATOR;
2296 force_ident(PL_tokenbuf, '*');
2309 if (PL_expect == XOPERATOR) {
2313 PL_tokenbuf[0] = '%';
2314 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2315 if (!PL_tokenbuf[1]) {
2317 yyerror("Final % should be \\% or %name");
2320 PL_pending_ident = '%';
2342 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
2343 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
2348 if (PL_curcop->cop_line < PL_copline)
2349 PL_copline = PL_curcop->cop_line;
2360 if (PL_lex_brackets <= 0)
2361 yyerror("Unmatched right square bracket");
2364 if (PL_lex_state == LEX_INTERPNORMAL) {
2365 if (PL_lex_brackets == 0) {
2366 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
2367 PL_lex_state = LEX_INTERPEND;
2374 if (PL_lex_brackets > 100) {
2375 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
2376 if (newlb != PL_lex_brackstack) {
2378 PL_lex_brackstack = newlb;
2381 switch (PL_expect) {
2383 if (PL_lex_formbrack) {
2387 if (PL_oldoldbufptr == PL_last_lop)
2388 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2390 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2391 OPERATOR(HASHBRACK);
2393 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2396 PL_tokenbuf[0] = '\0';
2397 if (d < PL_bufend && *d == '-') {
2398 PL_tokenbuf[0] = '-';
2400 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2403 if (d < PL_bufend && isIDFIRST_lazy(d)) {
2404 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2406 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2409 char minus = (PL_tokenbuf[0] == '-');
2410 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2417 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
2421 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2426 if (PL_oldoldbufptr == PL_last_lop)
2427 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2429 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2432 OPERATOR(HASHBRACK);
2433 /* This hack serves to disambiguate a pair of curlies
2434 * as being a block or an anon hash. Normally, expectation
2435 * determines that, but in cases where we're not in a
2436 * position to expect anything in particular (like inside
2437 * eval"") we have to resolve the ambiguity. This code
2438 * covers the case where the first term in the curlies is a
2439 * quoted string. Most other cases need to be explicitly
2440 * disambiguated by prepending a `+' before the opening
2441 * curly in order to force resolution as an anon hash.
2443 * XXX should probably propagate the outer expectation
2444 * into eval"" to rely less on this hack, but that could
2445 * potentially break current behavior of eval"".
2449 if (*s == '\'' || *s == '"' || *s == '`') {
2450 /* common case: get past first string, handling escapes */
2451 for (t++; t < PL_bufend && *t != *s;)
2452 if (*t++ == '\\' && (*t == '\\' || *t == *s))
2456 else if (*s == 'q') {
2459 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
2460 && !isALNUM(*t)))) {
2462 char open, close, term;
2465 while (t < PL_bufend && isSPACE(*t))
2469 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
2473 for (t++; t < PL_bufend; t++) {
2474 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
2476 else if (*t == open)
2480 for (t++; t < PL_bufend; t++) {
2481 if (*t == '\\' && t+1 < PL_bufend)
2483 else if (*t == close && --brackets <= 0)
2485 else if (*t == open)
2491 else if (isIDFIRST_lazy(s)) {
2492 for (t++; t < PL_bufend && isALNUM_lazy(t); t++) ;
2494 while (t < PL_bufend && isSPACE(*t))
2496 /* if comma follows first term, call it an anon hash */
2497 /* XXX it could be a comma expression with loop modifiers */
2498 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
2499 || (*t == '=' && t[1] == '>')))
2500 OPERATOR(HASHBRACK);
2501 if (PL_expect == XREF)
2502 PL_expect = XSTATE; /* was XTERM, trying XSTATE */
2504 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
2510 yylval.ival = PL_curcop->cop_line;
2511 if (isSPACE(*s) || *s == '#')
2512 PL_copline = NOLINE; /* invalidate current command line number */
2517 if (PL_lex_brackets <= 0)
2518 yyerror("Unmatched right curly bracket");
2520 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
2521 if (PL_lex_brackets < PL_lex_formbrack)
2522 PL_lex_formbrack = 0;
2523 if (PL_lex_state == LEX_INTERPNORMAL) {
2524 if (PL_lex_brackets == 0) {
2525 if (PL_lex_fakebrack) {
2526 PL_lex_state = LEX_INTERPEND;
2528 return yylex(); /* ignore fake brackets */
2530 if (*s == '-' && s[1] == '>')
2531 PL_lex_state = LEX_INTERPENDMAYBE;
2532 else if (*s != '[' && *s != '{')
2533 PL_lex_state = LEX_INTERPEND;
2536 if (PL_lex_brackets < PL_lex_fakebrack) {
2538 PL_lex_fakebrack = 0;
2539 return yylex(); /* ignore fake brackets */
2549 if (PL_expect == XOPERATOR) {
2550 if (ckWARN(WARN_SEMICOLON) && isIDFIRST_lazy(s) && PL_bufptr == PL_linestart) {
2551 PL_curcop->cop_line--;
2552 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
2553 PL_curcop->cop_line++;
2558 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2560 PL_expect = XOPERATOR;
2561 force_ident(PL_tokenbuf, '&');
2565 yylval.ival = (OPpENTERSUB_AMPER<<8);
2584 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
2585 Perl_warner(aTHX_ WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
2587 if (PL_expect == XSTATE && isALPHA(tmp) &&
2588 (s == PL_linestart+1 || s[-2] == '\n') )
2590 if (PL_in_eval && !PL_rsfp) {
2595 if (strnEQ(s,"=cut",4)) {
2609 PL_doextract = TRUE;
2612 if (PL_lex_brackets < PL_lex_formbrack) {
2614 #ifdef PERL_STRICT_CR
2615 for (t = s; *t == ' ' || *t == '\t'; t++) ;
2617 for (t = s; *t == ' ' || *t == '\t' || *t == '\r'; t++) ;
2619 if (*t == '\n' || *t == '#') {
2637 if (PL_expect != XOPERATOR) {
2638 if (s[1] != '<' && !strchr(s,'>'))
2641 s = scan_heredoc(s);
2643 s = scan_inputsymbol(s);
2644 TERM(sublex_start());
2649 SHop(OP_LEFT_SHIFT);
2663 SHop(OP_RIGHT_SHIFT);
2672 if (PL_expect == XOPERATOR) {
2673 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2676 return ','; /* grandfather non-comma-format format */
2680 if (s[1] == '#' && (isIDFIRST_lazy(s+2) || strchr("{$:+-", s[2]))) {
2681 if (PL_expect == XOPERATOR)
2682 no_op("Array length", PL_bufptr);
2683 PL_tokenbuf[0] = '@';
2684 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2686 if (!PL_tokenbuf[1])
2688 PL_expect = XOPERATOR;
2689 PL_pending_ident = '#';
2693 if (PL_expect == XOPERATOR)
2694 no_op("Scalar", PL_bufptr);
2695 PL_tokenbuf[0] = '$';
2696 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2697 if (!PL_tokenbuf[1]) {
2699 yyerror("Final $ should be \\$ or $name");
2703 /* This kludge not intended to be bulletproof. */
2704 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
2705 yylval.opval = newSVOP(OP_CONST, 0,
2706 newSViv((IV)PL_compiling.cop_arybase));
2707 yylval.opval->op_private = OPpCONST_ARYBASE;
2713 if (PL_lex_state == LEX_NORMAL)
2716 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2719 PL_tokenbuf[0] = '@';
2720 if (ckWARN(WARN_SYNTAX)) {
2722 isSPACE(*t) || isALNUM_lazy(t) || *t == '$';
2725 PL_bufptr = skipspace(PL_bufptr);
2726 while (t < PL_bufend && *t != ']')
2728 Perl_warner(aTHX_ WARN_SYNTAX,
2729 "Multidimensional syntax %.*s not supported",
2730 (t - PL_bufptr) + 1, PL_bufptr);
2734 else if (*s == '{') {
2735 PL_tokenbuf[0] = '%';
2736 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
2737 (t = strchr(s, '}')) && (t = strchr(t, '=')))
2739 char tmpbuf[sizeof PL_tokenbuf];
2741 for (t++; isSPACE(*t); t++) ;
2742 if (isIDFIRST_lazy(t)) {
2743 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
2744 for (; isSPACE(*t); t++) ;
2745 if (*t == ';' && get_cv(tmpbuf, FALSE))
2746 Perl_warner(aTHX_ WARN_SYNTAX,
2747 "You need to quote \"%s\"", tmpbuf);
2753 PL_expect = XOPERATOR;
2754 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
2755 bool islop = (PL_last_lop == PL_oldoldbufptr);
2756 if (!islop || PL_last_lop_op == OP_GREPSTART)
2757 PL_expect = XOPERATOR;
2758 else if (strchr("$@\"'`q", *s))
2759 PL_expect = XTERM; /* e.g. print $fh "foo" */
2760 else if (strchr("&*<%", *s) && isIDFIRST_lazy(s+1))
2761 PL_expect = XTERM; /* e.g. print $fh &sub */
2762 else if (isIDFIRST_lazy(s)) {
2763 char tmpbuf[sizeof PL_tokenbuf];
2764 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2765 if (tmp = keyword(tmpbuf, len)) {
2766 /* binary operators exclude handle interpretations */
2778 PL_expect = XTERM; /* e.g. print $fh length() */
2783 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
2784 if (gv && GvCVu(gv))
2785 PL_expect = XTERM; /* e.g. print $fh subr() */
2788 else if (isDIGIT(*s))
2789 PL_expect = XTERM; /* e.g. print $fh 3 */
2790 else if (*s == '.' && isDIGIT(s[1]))
2791 PL_expect = XTERM; /* e.g. print $fh .3 */
2792 else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
2793 PL_expect = XTERM; /* e.g. print $fh -1 */
2794 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
2795 PL_expect = XTERM; /* print $fh <<"EOF" */
2797 PL_pending_ident = '$';
2801 if (PL_expect == XOPERATOR)
2803 PL_tokenbuf[0] = '@';
2804 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2805 if (!PL_tokenbuf[1]) {
2807 yyerror("Final @ should be \\@ or @name");
2810 if (PL_lex_state == LEX_NORMAL)
2812 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2814 PL_tokenbuf[0] = '%';
2816 /* Warn about @ where they meant $. */
2817 if (ckWARN(WARN_SYNTAX)) {
2818 if (*s == '[' || *s == '{') {
2820 while (*t && (isALNUM_lazy(t) || strchr(" \t$#+-'\"", *t)))
2822 if (*t == '}' || *t == ']') {
2824 PL_bufptr = skipspace(PL_bufptr);
2825 Perl_warner(aTHX_ WARN_SYNTAX,
2826 "Scalar value %.*s better written as $%.*s",
2827 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
2832 PL_pending_ident = '@';
2835 case '/': /* may either be division or pattern */
2836 case '?': /* may either be conditional or pattern */
2837 if (PL_expect != XOPERATOR) {
2838 /* Disable warning on "study /blah/" */
2839 if (PL_oldoldbufptr == PL_last_uni
2840 && (*PL_last_uni != 's' || s - PL_last_uni < 5
2841 || memNE(PL_last_uni, "study", 5) || isALNUM_lazy(PL_last_uni+5)))
2843 s = scan_pat(s,OP_MATCH);
2844 TERM(sublex_start());
2852 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
2853 #ifdef PERL_STRICT_CR
2856 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
2858 && (s == PL_linestart || s[-1] == '\n') )
2860 PL_lex_formbrack = 0;
2864 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
2870 yylval.ival = OPf_SPECIAL;
2876 if (PL_expect != XOPERATOR)
2881 case '0': case '1': case '2': case '3': case '4':
2882 case '5': case '6': case '7': case '8': case '9':
2884 if (PL_expect == XOPERATOR)
2890 if (PL_expect == XOPERATOR) {
2891 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2894 return ','; /* grandfather non-comma-format format */
2900 missingterm((char*)0);
2901 yylval.ival = OP_CONST;
2902 TERM(sublex_start());
2906 if (PL_expect == XOPERATOR) {
2907 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2910 return ','; /* grandfather non-comma-format format */
2916 missingterm((char*)0);
2917 yylval.ival = OP_CONST;
2918 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
2919 if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
2920 yylval.ival = OP_STRINGIFY;
2924 TERM(sublex_start());
2928 if (PL_expect == XOPERATOR)
2929 no_op("Backticks",s);
2931 missingterm((char*)0);
2932 yylval.ival = OP_BACKTICK;
2934 TERM(sublex_start());
2938 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
2939 Perl_warner(aTHX_ WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
2941 if (PL_expect == XOPERATOR)
2942 no_op("Backslash",s);
2946 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
2986 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2988 /* Some keywords can be followed by any delimiter, including ':' */
2989 tmp = (len == 1 && strchr("msyq", PL_tokenbuf[0]) ||
2990 len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
2991 (PL_tokenbuf[0] == 'q' &&
2992 strchr("qwxr", PL_tokenbuf[1]))));
2994 /* x::* is just a word, unless x is "CORE" */
2995 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
2999 while (d < PL_bufend && isSPACE(*d))
3000 d++; /* no comments skipped here, or s### is misparsed */
3002 /* Is this a label? */
3003 if (!tmp && PL_expect == XSTATE
3004 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
3006 yylval.pval = savepv(PL_tokenbuf);
3011 /* Check for keywords */
3012 tmp = keyword(PL_tokenbuf, len);
3014 /* Is this a word before a => operator? */
3015 if (strnEQ(d,"=>",2)) {
3017 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
3018 yylval.opval->op_private = OPpCONST_BARE;
3022 if (tmp < 0) { /* second-class keyword? */
3023 GV *ogv = Nullgv; /* override (winner) */
3024 GV *hgv = Nullgv; /* hidden (loser) */
3025 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3027 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3030 if (GvIMPORTED_CV(gv))
3032 else if (! CvMETHOD(cv))
3036 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3037 (gv = *gvp) != (GV*)&PL_sv_undef &&
3038 GvCVu(gv) && GvIMPORTED_CV(gv))
3044 tmp = 0; /* overridden by import or by GLOBAL */
3047 && -tmp==KEY_lock /* XXX generalizable kludge */
3048 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3050 tmp = 0; /* any sub overrides "weak" keyword */
3052 else { /* no override */
3056 if (ckWARN(WARN_AMBIGUOUS) && hgv
3057 && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3058 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3059 "Ambiguous call resolved as CORE::%s(), %s",
3060 GvENAME(hgv), "qualify as such or use &");
3067 default: /* not a keyword */
3070 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3072 /* Get the rest if it looks like a package qualifier */
3074 if (*s == '\'' || *s == ':' && s[1] == ':') {
3076 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3079 Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
3080 *s == '\'' ? "'" : "::");
3084 if (PL_expect == XOPERATOR) {
3085 if (PL_bufptr == PL_linestart) {
3086 PL_curcop->cop_line--;
3087 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3088 PL_curcop->cop_line++;
3091 no_op("Bareword",s);
3094 /* Look for a subroutine with this name in current package,
3095 unless name is "Foo::", in which case Foo is a bearword
3096 (and a package name). */
3099 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3101 if (ckWARN(WARN_UNSAFE) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3102 Perl_warner(aTHX_ WARN_UNSAFE,
3103 "Bareword \"%s\" refers to nonexistent package",
3106 PL_tokenbuf[len] = '\0';
3113 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3116 /* if we saw a global override before, get the right name */
3119 sv = newSVpvn("CORE::GLOBAL::",14);
3120 sv_catpv(sv,PL_tokenbuf);
3123 sv = newSVpv(PL_tokenbuf,0);
3125 /* Presume this is going to be a bareword of some sort. */
3128 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3129 yylval.opval->op_private = OPpCONST_BARE;
3131 /* And if "Foo::", then that's what it certainly is. */
3136 /* See if it's the indirect object for a list operator. */
3138 if (PL_oldoldbufptr &&
3139 PL_oldoldbufptr < PL_bufptr &&
3140 (PL_oldoldbufptr == PL_last_lop || PL_oldoldbufptr == PL_last_uni) &&
3141 /* NO SKIPSPACE BEFORE HERE! */
3142 (PL_expect == XREF ||
3143 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
3145 bool immediate_paren = *s == '(';
3147 /* (Now we can afford to cross potential line boundary.) */
3150 /* Two barewords in a row may indicate method call. */
3152 if ((isIDFIRST_lazy(s) || *s == '$') && (tmp=intuit_method(s,gv)))
3155 /* If not a declared subroutine, it's an indirect object. */
3156 /* (But it's an indir obj regardless for sort.) */
3158 if ((PL_last_lop_op == OP_SORT ||
3159 (!immediate_paren && (!gv || !GvCVu(gv)))) &&
3160 (PL_last_lop_op != OP_MAPSTART &&
3161 PL_last_lop_op != OP_GREPSTART))
3163 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3168 /* If followed by a paren, it's certainly a subroutine. */
3170 PL_expect = XOPERATOR;
3174 if (gv && GvCVu(gv)) {
3175 for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
3176 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
3181 PL_nextval[PL_nexttoke].opval = yylval.opval;
3182 PL_expect = XOPERATOR;
3188 /* If followed by var or block, call it a method (unless sub) */
3190 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3191 PL_last_lop = PL_oldbufptr;
3192 PL_last_lop_op = OP_METHOD;
3196 /* If followed by a bareword, see if it looks like indir obj. */
3198 if ((isIDFIRST_lazy(s) || *s == '$') && (tmp = intuit_method(s,gv)))
3201 /* Not a method, so call it a subroutine (if defined) */
3203 if (gv && GvCVu(gv)) {
3205 if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
3206 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3207 "Ambiguous use of -%s resolved as -&%s()",
3208 PL_tokenbuf, PL_tokenbuf);
3209 /* Check for a constant sub */
3211 if ((sv = cv_const_sv(cv))) {
3213 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3214 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3215 yylval.opval->op_private = 0;
3219 /* Resolve to GV now. */
3220 op_free(yylval.opval);
3221 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3222 yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
3223 PL_last_lop = PL_oldbufptr;
3224 PL_last_lop_op = OP_ENTERSUB;
3225 /* Is there a prototype? */
3228 char *proto = SvPV((SV*)cv, len);
3231 if (strEQ(proto, "$"))
3233 if (*proto == '&' && *s == '{') {
3234 sv_setpv(PL_subname,"__ANON__");
3238 PL_nextval[PL_nexttoke].opval = yylval.opval;
3244 /* Call it a bare word */
3246 if (PL_hints & HINT_STRICT_SUBS)
3247 yylval.opval->op_private |= OPpCONST_STRICT;
3250 if (ckWARN(WARN_RESERVED)) {
3251 if (lastchar != '-') {
3252 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3254 Perl_warner(aTHX_ WARN_RESERVED, PL_warn_reserved,
3261 if (lastchar && strchr("*%&", lastchar) && ckWARN_d(WARN_AMBIGUOUS)) {
3262 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3263 "Operator or semicolon missing before %c%s",
3264 lastchar, PL_tokenbuf);
3265 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3266 "Ambiguous use of %c resolved as operator %c",
3267 lastchar, lastchar);
3273 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3274 newSVsv(GvSV(PL_curcop->cop_filegv)));
3278 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3279 Perl_newSVpvf(aTHX_ "%ld", (long)PL_curcop->cop_line));
3282 case KEY___PACKAGE__:
3283 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3285 ? newSVsv(PL_curstname)
3294 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3295 char *pname = "main";
3296 if (PL_tokenbuf[2] == 'D')
3297 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3298 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
3301 GvIOp(gv) = newIO();
3302 IoIFP(GvIOp(gv)) = PL_rsfp;
3303 #if defined(HAS_FCNTL) && defined(F_SETFD)
3305 int fd = PerlIO_fileno(PL_rsfp);
3306 fcntl(fd,F_SETFD,fd >= 3);
3309 /* Mark this internal pseudo-handle as clean */
3310 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3312 IoTYPE(GvIOp(gv)) = '|';
3313 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
3314 IoTYPE(GvIOp(gv)) = '-';
3316 IoTYPE(GvIOp(gv)) = '<';
3327 if (PL_expect == XSTATE) {
3334 if (*s == ':' && s[1] == ':') {
3337 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3338 tmp = keyword(PL_tokenbuf, len);
3352 LOP(OP_ACCEPT,XTERM);
3358 LOP(OP_ATAN2,XTERM);
3367 LOP(OP_BLESS,XTERM);
3376 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
3393 if (!PL_cryptseen++)
3396 LOP(OP_CRYPT,XTERM);
3399 if (ckWARN(WARN_OCTAL)) {
3400 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
3401 if (*d != '0' && isDIGIT(*d))
3402 yywarn("chmod: mode argument is missing initial 0");
3404 LOP(OP_CHMOD,XTERM);
3407 LOP(OP_CHOWN,XTERM);
3410 LOP(OP_CONNECT,XTERM);
3426 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3430 PL_hints |= HINT_BLOCK_SCOPE;
3440 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3441 LOP(OP_DBMOPEN,XTERM);
3447 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3454 yylval.ival = PL_curcop->cop_line;
3468 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
3469 UNIBRACK(OP_ENTEREVAL);
3484 case KEY_endhostent:
3490 case KEY_endservent:
3493 case KEY_endprotoent:
3504 yylval.ival = PL_curcop->cop_line;
3506 if (PL_expect == XSTATE && isIDFIRST_lazy(s)) {
3508 if ((PL_bufend - p) >= 3 &&
3509 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3512 if (isIDFIRST_lazy(p))
3513 Perl_croak(aTHX_ "Missing $ on loop variable");
3518 LOP(OP_FORMLINE,XTERM);
3524 LOP(OP_FCNTL,XTERM);
3530 LOP(OP_FLOCK,XTERM);
3539 LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
3542 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3557 case KEY_getpriority:
3558 LOP(OP_GETPRIORITY,XTERM);
3560 case KEY_getprotobyname:
3563 case KEY_getprotobynumber:
3564 LOP(OP_GPBYNUMBER,XTERM);
3566 case KEY_getprotoent:
3578 case KEY_getpeername:
3579 UNI(OP_GETPEERNAME);
3581 case KEY_gethostbyname:
3584 case KEY_gethostbyaddr:
3585 LOP(OP_GHBYADDR,XTERM);
3587 case KEY_gethostent:
3590 case KEY_getnetbyname:
3593 case KEY_getnetbyaddr:
3594 LOP(OP_GNBYADDR,XTERM);
3599 case KEY_getservbyname:
3600 LOP(OP_GSBYNAME,XTERM);
3602 case KEY_getservbyport:
3603 LOP(OP_GSBYPORT,XTERM);
3605 case KEY_getservent:
3608 case KEY_getsockname:
3609 UNI(OP_GETSOCKNAME);
3611 case KEY_getsockopt:
3612 LOP(OP_GSOCKOPT,XTERM);
3634 yylval.ival = PL_curcop->cop_line;
3638 LOP(OP_INDEX,XTERM);
3644 LOP(OP_IOCTL,XTERM);
3656 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3687 LOP(OP_LISTEN,XTERM);
3696 s = scan_pat(s,OP_MATCH);
3697 TERM(sublex_start());
3700 LOP(OP_MAPSTART, XREF);
3703 LOP(OP_MKDIR,XTERM);
3706 LOP(OP_MSGCTL,XTERM);
3709 LOP(OP_MSGGET,XTERM);
3712 LOP(OP_MSGRCV,XTERM);
3715 LOP(OP_MSGSND,XTERM);
3720 if (isIDFIRST_lazy(s)) {
3721 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
3722 PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
3723 if (!PL_in_my_stash) {
3726 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
3733 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3740 if (PL_expect != XSTATE)
3741 yyerror("\"no\" not allowed in expression");
3742 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3743 s = force_version(s);
3752 if (isIDFIRST_lazy(s)) {
3754 for (d = s; isALNUM_lazy(d); d++) ;
3756 if (strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_AMBIGUOUS))
3757 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3758 "Precedence problem: open %.*s should be open(%.*s)",
3764 yylval.ival = OP_OR;
3774 LOP(OP_OPEN_DIR,XTERM);
3777 checkcomma(s,PL_tokenbuf,"filehandle");
3781 checkcomma(s,PL_tokenbuf,"filehandle");
3800 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3804 LOP(OP_PIPE_OP,XTERM);
3809 missingterm((char*)0);
3810 yylval.ival = OP_CONST;
3811 TERM(sublex_start());
3819 missingterm((char*)0);
3821 if (SvCUR(PL_lex_stuff)) {
3824 d = SvPV_force(PL_lex_stuff, len);
3826 for (; isSPACE(*d) && len; --len, ++d) ;
3829 if (!warned && ckWARN(WARN_SYNTAX)) {
3830 for (; !isSPACE(*d) && len; --len, ++d) {
3832 Perl_warner(aTHX_ WARN_SYNTAX,
3833 "Possible attempt to separate words with commas");
3836 else if (*d == '#') {
3837 Perl_warner(aTHX_ WARN_SYNTAX,
3838 "Possible attempt to put comments in qw() list");
3844 for (; !isSPACE(*d) && len; --len, ++d) ;
3846 words = append_elem(OP_LIST, words,
3847 newSVOP(OP_CONST, 0, newSVpvn(b, d-b)));
3851 PL_nextval[PL_nexttoke].opval = words;
3856 SvREFCNT_dec(PL_lex_stuff);
3857 PL_lex_stuff = Nullsv;
3864 missingterm((char*)0);
3865 yylval.ival = OP_STRINGIFY;
3866 if (SvIVX(PL_lex_stuff) == '\'')
3867 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
3868 TERM(sublex_start());
3871 s = scan_pat(s,OP_QR);
3872 TERM(sublex_start());
3877 missingterm((char*)0);
3878 yylval.ival = OP_BACKTICK;
3880 TERM(sublex_start());
3886 *PL_tokenbuf = '\0';
3887 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3888 if (isIDFIRST_lazy(PL_tokenbuf))
3889 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
3891 yyerror("<> should be quotes");
3898 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3902 LOP(OP_RENAME,XTERM);
3911 LOP(OP_RINDEX,XTERM);
3934 LOP(OP_REVERSE,XTERM);
3945 TERM(sublex_start());
3947 TOKEN(1); /* force error */
3956 LOP(OP_SELECT,XTERM);
3962 LOP(OP_SEMCTL,XTERM);
3965 LOP(OP_SEMGET,XTERM);
3968 LOP(OP_SEMOP,XTERM);
3974 LOP(OP_SETPGRP,XTERM);
3976 case KEY_setpriority:
3977 LOP(OP_SETPRIORITY,XTERM);
3979 case KEY_sethostent:
3985 case KEY_setservent:
3988 case KEY_setprotoent:
3998 LOP(OP_SEEKDIR,XTERM);
4000 case KEY_setsockopt:
4001 LOP(OP_SSOCKOPT,XTERM);
4007 LOP(OP_SHMCTL,XTERM);
4010 LOP(OP_SHMGET,XTERM);
4013 LOP(OP_SHMREAD,XTERM);
4016 LOP(OP_SHMWRITE,XTERM);
4019 LOP(OP_SHUTDOWN,XTERM);
4028 LOP(OP_SOCKET,XTERM);
4030 case KEY_socketpair:
4031 LOP(OP_SOCKPAIR,XTERM);
4034 checkcomma(s,PL_tokenbuf,"subroutine name");
4036 if (*s == ';' || *s == ')') /* probably a close */
4037 Perl_croak(aTHX_ "sort is now a reserved word");
4039 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4043 LOP(OP_SPLIT,XTERM);
4046 LOP(OP_SPRINTF,XTERM);
4049 LOP(OP_SPLICE,XTERM);
4065 LOP(OP_SUBSTR,XTERM);
4072 if (isIDFIRST_lazy(s) || *s == '\'' || *s == ':') {
4073 char tmpbuf[sizeof PL_tokenbuf];
4075 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4076 if (strchr(tmpbuf, ':'))
4077 sv_setpv(PL_subname, tmpbuf);
4079 sv_setsv(PL_subname,PL_curstname);
4080 sv_catpvn(PL_subname,"::",2);
4081 sv_catpvn(PL_subname,tmpbuf,len);
4083 s = force_word(s,WORD,FALSE,TRUE,TRUE);
4087 PL_expect = XTERMBLOCK;
4088 sv_setpv(PL_subname,"?");
4091 if (tmp == KEY_format) {
4094 PL_lex_formbrack = PL_lex_brackets + 1;
4098 /* Look for a prototype */
4105 SvREFCNT_dec(PL_lex_stuff);
4106 PL_lex_stuff = Nullsv;
4107 Perl_croak(aTHX_ "Prototype not terminated");
4110 d = SvPVX(PL_lex_stuff);
4112 for (p = d; *p; ++p) {
4117 SvCUR(PL_lex_stuff) = tmp;
4120 PL_nextval[1] = PL_nextval[0];
4121 PL_nexttype[1] = PL_nexttype[0];
4122 PL_nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4123 PL_nexttype[0] = THING;
4124 if (PL_nexttoke == 1) {
4125 PL_lex_defer = PL_lex_state;
4126 PL_lex_expect = PL_expect;
4127 PL_lex_state = LEX_KNOWNEXT;
4129 PL_lex_stuff = Nullsv;
4132 if (*SvPV(PL_subname,n_a) == '?') {
4133 sv_setpv(PL_subname,"__ANON__");
4140 LOP(OP_SYSTEM,XREF);
4143 LOP(OP_SYMLINK,XTERM);
4146 LOP(OP_SYSCALL,XTERM);
4149 LOP(OP_SYSOPEN,XTERM);
4152 LOP(OP_SYSSEEK,XTERM);
4155 LOP(OP_SYSREAD,XTERM);
4158 LOP(OP_SYSWRITE,XTERM);
4162 TERM(sublex_start());
4183 LOP(OP_TRUNCATE,XTERM);
4195 yylval.ival = PL_curcop->cop_line;
4199 yylval.ival = PL_curcop->cop_line;
4203 LOP(OP_UNLINK,XTERM);
4209 LOP(OP_UNPACK,XTERM);
4212 LOP(OP_UTIME,XTERM);
4215 if (ckWARN(WARN_OCTAL)) {
4216 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4217 if (*d != '0' && isDIGIT(*d))
4218 yywarn("umask: argument is missing initial 0");
4223 LOP(OP_UNSHIFT,XTERM);
4226 if (PL_expect != XSTATE)
4227 yyerror("\"use\" not allowed in expression");
4230 s = force_version(s);
4231 if(*s == ';' || (s = skipspace(s), *s == ';')) {
4232 PL_nextval[PL_nexttoke].opval = Nullop;
4237 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4238 s = force_version(s);
4251 yylval.ival = PL_curcop->cop_line;
4255 PL_hints |= HINT_BLOCK_SCOPE;
4262 LOP(OP_WAITPID,XTERM);
4270 static char ctl_l[2];
4272 if (ctl_l[0] == '\0')
4273 ctl_l[0] = toCTRL('L');
4274 gv_fetchpv(ctl_l,TRUE, SVt_PV);
4277 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
4282 if (PL_expect == XOPERATOR)
4288 yylval.ival = OP_XOR;
4293 TERM(sublex_start());
4299 Perl_keyword(pTHX_ register char *d, I32 len)
4304 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
4305 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
4306 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
4307 if (strEQ(d,"__DATA__")) return KEY___DATA__;
4308 if (strEQ(d,"__END__")) return KEY___END__;
4312 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
4317 if (strEQ(d,"and")) return -KEY_and;
4318 if (strEQ(d,"abs")) return -KEY_abs;
4321 if (strEQ(d,"alarm")) return -KEY_alarm;
4322 if (strEQ(d,"atan2")) return -KEY_atan2;
4325 if (strEQ(d,"accept")) return -KEY_accept;
4330 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
4333 if (strEQ(d,"bless")) return -KEY_bless;
4334 if (strEQ(d,"bind")) return -KEY_bind;
4335 if (strEQ(d,"binmode")) return -KEY_binmode;
4338 if (strEQ(d,"CORE")) return -KEY_CORE;
4343 if (strEQ(d,"cmp")) return -KEY_cmp;
4344 if (strEQ(d,"chr")) return -KEY_chr;
4345 if (strEQ(d,"cos")) return -KEY_cos;
4348 if (strEQ(d,"chop")) return KEY_chop;
4351 if (strEQ(d,"close")) return -KEY_close;
4352 if (strEQ(d,"chdir")) return -KEY_chdir;
4353 if (strEQ(d,"chomp")) return KEY_chomp;
4354 if (strEQ(d,"chmod")) return -KEY_chmod;
4355 if (strEQ(d,"chown")) return -KEY_chown;
4356 if (strEQ(d,"crypt")) return -KEY_crypt;
4359 if (strEQ(d,"chroot")) return -KEY_chroot;
4360 if (strEQ(d,"caller")) return -KEY_caller;
4363 if (strEQ(d,"connect")) return -KEY_connect;
4366 if (strEQ(d,"closedir")) return -KEY_closedir;
4367 if (strEQ(d,"continue")) return -KEY_continue;
4372 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
4377 if (strEQ(d,"do")) return KEY_do;
4380 if (strEQ(d,"die")) return -KEY_die;
4383 if (strEQ(d,"dump")) return -KEY_dump;
4386 if (strEQ(d,"delete")) return KEY_delete;
4389 if (strEQ(d,"defined")) return KEY_defined;
4390 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
4393 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
4398 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
4399 if (strEQ(d,"END")) return KEY_END;
4404 if (strEQ(d,"eq")) return -KEY_eq;
4407 if (strEQ(d,"eof")) return -KEY_eof;
4408 if (strEQ(d,"exp")) return -KEY_exp;
4411 if (strEQ(d,"else")) return KEY_else;
4412 if (strEQ(d,"exit")) return -KEY_exit;
4413 if (strEQ(d,"eval")) return KEY_eval;
4414 if (strEQ(d,"exec")) return -KEY_exec;
4415 if (strEQ(d,"each")) return KEY_each;
4418 if (strEQ(d,"elsif")) return KEY_elsif;
4421 if (strEQ(d,"exists")) return KEY_exists;
4422 if (strEQ(d,"elseif")) Perl_warn(aTHX_ "elseif should be elsif");
4425 if (strEQ(d,"endgrent")) return -KEY_endgrent;
4426 if (strEQ(d,"endpwent")) return -KEY_endpwent;
4429 if (strEQ(d,"endnetent")) return -KEY_endnetent;
4432 if (strEQ(d,"endhostent")) return -KEY_endhostent;
4433 if (strEQ(d,"endservent")) return -KEY_endservent;
4436 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
4443 if (strEQ(d,"for")) return KEY_for;
4446 if (strEQ(d,"fork")) return -KEY_fork;
4449 if (strEQ(d,"fcntl")) return -KEY_fcntl;
4450 if (strEQ(d,"flock")) return -KEY_flock;
4453 if (strEQ(d,"format")) return KEY_format;
4454 if (strEQ(d,"fileno")) return -KEY_fileno;
4457 if (strEQ(d,"foreach")) return KEY_foreach;
4460 if (strEQ(d,"formline")) return -KEY_formline;
4466 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
4467 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
4471 if (strnEQ(d,"get",3)) {
4476 if (strEQ(d,"ppid")) return -KEY_getppid;
4477 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
4480 if (strEQ(d,"pwent")) return -KEY_getpwent;
4481 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
4482 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
4485 if (strEQ(d,"peername")) return -KEY_getpeername;
4486 if (strEQ(d,"protoent")) return -KEY_getprotoent;
4487 if (strEQ(d,"priority")) return -KEY_getpriority;
4490 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
4493 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
4497 else if (*d == 'h') {
4498 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
4499 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
4500 if (strEQ(d,"hostent")) return -KEY_gethostent;
4502 else if (*d == 'n') {
4503 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
4504 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
4505 if (strEQ(d,"netent")) return -KEY_getnetent;
4507 else if (*d == 's') {
4508 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
4509 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
4510 if (strEQ(d,"servent")) return -KEY_getservent;
4511 if (strEQ(d,"sockname")) return -KEY_getsockname;
4512 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
4514 else if (*d == 'g') {
4515 if (strEQ(d,"grent")) return -KEY_getgrent;
4516 if (strEQ(d,"grnam")) return -KEY_getgrnam;
4517 if (strEQ(d,"grgid")) return -KEY_getgrgid;
4519 else if (*d == 'l') {
4520 if (strEQ(d,"login")) return -KEY_getlogin;
4522 else if (strEQ(d,"c")) return -KEY_getc;
4527 if (strEQ(d,"gt")) return -KEY_gt;
4528 if (strEQ(d,"ge")) return -KEY_ge;
4531 if (strEQ(d,"grep")) return KEY_grep;
4532 if (strEQ(d,"goto")) return KEY_goto;
4533 if (strEQ(d,"glob")) return KEY_glob;
4536 if (strEQ(d,"gmtime")) return -KEY_gmtime;
4541 if (strEQ(d,"hex")) return -KEY_hex;
4544 if (strEQ(d,"INIT")) return KEY_INIT;
4549 if (strEQ(d,"if")) return KEY_if;
4552 if (strEQ(d,"int")) return -KEY_int;
4555 if (strEQ(d,"index")) return -KEY_index;
4556 if (strEQ(d,"ioctl")) return -KEY_ioctl;
4561 if (strEQ(d,"join")) return -KEY_join;
4565 if (strEQ(d,"keys")) return KEY_keys;
4566 if (strEQ(d,"kill")) return -KEY_kill;
4571 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
4572 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
4578 if (strEQ(d,"lt")) return -KEY_lt;
4579 if (strEQ(d,"le")) return -KEY_le;
4580 if (strEQ(d,"lc")) return -KEY_lc;
4583 if (strEQ(d,"log")) return -KEY_log;
4586 if (strEQ(d,"last")) return KEY_last;
4587 if (strEQ(d,"link")) return -KEY_link;
4588 if (strEQ(d,"lock")) return -KEY_lock;
4591 if (strEQ(d,"local")) return KEY_local;
4592 if (strEQ(d,"lstat")) return -KEY_lstat;
4595 if (strEQ(d,"length")) return -KEY_length;
4596 if (strEQ(d,"listen")) return -KEY_listen;
4599 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
4602 if (strEQ(d,"localtime")) return -KEY_localtime;
4608 case 1: return KEY_m;
4610 if (strEQ(d,"my")) return KEY_my;
4613 if (strEQ(d,"map")) return KEY_map;
4616 if (strEQ(d,"mkdir")) return -KEY_mkdir;
4619 if (strEQ(d,"msgctl")) return -KEY_msgctl;
4620 if (strEQ(d,"msgget")) return -KEY_msgget;
4621 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
4622 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
4627 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
4630 if (strEQ(d,"next")) return KEY_next;
4631 if (strEQ(d,"ne")) return -KEY_ne;
4632 if (strEQ(d,"not")) return -KEY_not;
4633 if (strEQ(d,"no")) return KEY_no;
4638 if (strEQ(d,"or")) return -KEY_or;
4641 if (strEQ(d,"ord")) return -KEY_ord;
4642 if (strEQ(d,"oct")) return -KEY_oct;
4643 if (strEQ(d,"our")) { deprecate("reserved word \"our\"");
4647 if (strEQ(d,"open")) return -KEY_open;
4650 if (strEQ(d,"opendir")) return -KEY_opendir;
4657 if (strEQ(d,"pop")) return KEY_pop;
4658 if (strEQ(d,"pos")) return KEY_pos;
4661 if (strEQ(d,"push")) return KEY_push;
4662 if (strEQ(d,"pack")) return -KEY_pack;
4663 if (strEQ(d,"pipe")) return -KEY_pipe;
4666 if (strEQ(d,"print")) return KEY_print;
4669 if (strEQ(d,"printf")) return KEY_printf;
4672 if (strEQ(d,"package")) return KEY_package;
4675 if (strEQ(d,"prototype")) return KEY_prototype;
4680 if (strEQ(d,"q")) return KEY_q;
4681 if (strEQ(d,"qr")) return KEY_qr;
4682 if (strEQ(d,"qq")) return KEY_qq;
4683 if (strEQ(d,"qw")) return KEY_qw;
4684 if (strEQ(d,"qx")) return KEY_qx;
4686 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
4691 if (strEQ(d,"ref")) return -KEY_ref;
4694 if (strEQ(d,"read")) return -KEY_read;
4695 if (strEQ(d,"rand")) return -KEY_rand;
4696 if (strEQ(d,"recv")) return -KEY_recv;
4697 if (strEQ(d,"redo")) return KEY_redo;
4700 if (strEQ(d,"rmdir")) return -KEY_rmdir;
4701 if (strEQ(d,"reset")) return -KEY_reset;
4704 if (strEQ(d,"return")) return KEY_return;
4705 if (strEQ(d,"rename")) return -KEY_rename;
4706 if (strEQ(d,"rindex")) return -KEY_rindex;
4709 if (strEQ(d,"require")) return -KEY_require;
4710 if (strEQ(d,"reverse")) return -KEY_reverse;
4711 if (strEQ(d,"readdir")) return -KEY_readdir;
4714 if (strEQ(d,"readlink")) return -KEY_readlink;
4715 if (strEQ(d,"readline")) return -KEY_readline;
4716 if (strEQ(d,"readpipe")) return -KEY_readpipe;
4719 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
4725 case 0: return KEY_s;
4727 if (strEQ(d,"scalar")) return KEY_scalar;
4732 if (strEQ(d,"seek")) return -KEY_seek;
4733 if (strEQ(d,"send")) return -KEY_send;
4736 if (strEQ(d,"semop")) return -KEY_semop;
4739 if (strEQ(d,"select")) return -KEY_select;
4740 if (strEQ(d,"semctl")) return -KEY_semctl;
4741 if (strEQ(d,"semget")) return -KEY_semget;
4744 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
4745 if (strEQ(d,"seekdir")) return -KEY_seekdir;
4748 if (strEQ(d,"setpwent")) return -KEY_setpwent;
4749 if (strEQ(d,"setgrent")) return -KEY_setgrent;
4752 if (strEQ(d,"setnetent")) return -KEY_setnetent;
4755 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
4756 if (strEQ(d,"sethostent")) return -KEY_sethostent;
4757 if (strEQ(d,"setservent")) return -KEY_setservent;
4760 if (strEQ(d,"setpriority")) return -KEY_setpriority;
4761 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
4768 if (strEQ(d,"shift")) return KEY_shift;
4771 if (strEQ(d,"shmctl")) return -KEY_shmctl;
4772 if (strEQ(d,"shmget")) return -KEY_shmget;
4775 if (strEQ(d,"shmread")) return -KEY_shmread;
4778 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
4779 if (strEQ(d,"shutdown")) return -KEY_shutdown;
4784 if (strEQ(d,"sin")) return -KEY_sin;
4787 if (strEQ(d,"sleep")) return -KEY_sleep;
4790 if (strEQ(d,"sort")) return KEY_sort;
4791 if (strEQ(d,"socket")) return -KEY_socket;
4792 if (strEQ(d,"socketpair")) return -KEY_socketpair;
4795 if (strEQ(d,"split")) return KEY_split;
4796 if (strEQ(d,"sprintf")) return -KEY_sprintf;
4797 if (strEQ(d,"splice")) return KEY_splice;
4800 if (strEQ(d,"sqrt")) return -KEY_sqrt;
4803 if (strEQ(d,"srand")) return -KEY_srand;
4806 if (strEQ(d,"stat")) return -KEY_stat;
4807 if (strEQ(d,"study")) return KEY_study;
4810 if (strEQ(d,"substr")) return -KEY_substr;
4811 if (strEQ(d,"sub")) return KEY_sub;
4816 if (strEQ(d,"system")) return -KEY_system;
4819 if (strEQ(d,"symlink")) return -KEY_symlink;
4820 if (strEQ(d,"syscall")) return -KEY_syscall;
4821 if (strEQ(d,"sysopen")) return -KEY_sysopen;
4822 if (strEQ(d,"sysread")) return -KEY_sysread;
4823 if (strEQ(d,"sysseek")) return -KEY_sysseek;
4826 if (strEQ(d,"syswrite")) return -KEY_syswrite;
4835 if (strEQ(d,"tr")) return KEY_tr;
4838 if (strEQ(d,"tie")) return KEY_tie;
4841 if (strEQ(d,"tell")) return -KEY_tell;
4842 if (strEQ(d,"tied")) return KEY_tied;
4843 if (strEQ(d,"time")) return -KEY_time;
4846 if (strEQ(d,"times")) return -KEY_times;
4849 if (strEQ(d,"telldir")) return -KEY_telldir;
4852 if (strEQ(d,"truncate")) return -KEY_truncate;
4859 if (strEQ(d,"uc")) return -KEY_uc;
4862 if (strEQ(d,"use")) return KEY_use;
4865 if (strEQ(d,"undef")) return KEY_undef;
4866 if (strEQ(d,"until")) return KEY_until;
4867 if (strEQ(d,"untie")) return KEY_untie;
4868 if (strEQ(d,"utime")) return -KEY_utime;
4869 if (strEQ(d,"umask")) return -KEY_umask;
4872 if (strEQ(d,"unless")) return KEY_unless;
4873 if (strEQ(d,"unpack")) return -KEY_unpack;
4874 if (strEQ(d,"unlink")) return -KEY_unlink;
4877 if (strEQ(d,"unshift")) return KEY_unshift;
4878 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
4883 if (strEQ(d,"values")) return -KEY_values;
4884 if (strEQ(d,"vec")) return -KEY_vec;
4889 if (strEQ(d,"warn")) return -KEY_warn;
4890 if (strEQ(d,"wait")) return -KEY_wait;
4893 if (strEQ(d,"while")) return KEY_while;
4894 if (strEQ(d,"write")) return -KEY_write;
4897 if (strEQ(d,"waitpid")) return -KEY_waitpid;
4900 if (strEQ(d,"wantarray")) return -KEY_wantarray;
4905 if (len == 1) return -KEY_x;
4906 if (strEQ(d,"xor")) return -KEY_xor;
4909 if (len == 1) return KEY_y;
4918 S_checkcomma(pTHX_ register char *s, char *name, char *what)
4922 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
4923 dTHR; /* only for ckWARN */
4924 if (ckWARN(WARN_SYNTAX)) {
4926 for (w = s+2; *w && level; w++) {
4933 for (; *w && isSPACE(*w); w++) ;
4934 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
4935 Perl_warner(aTHX_ WARN_SYNTAX, "%s (...) interpreted as function",name);
4938 while (s < PL_bufend && isSPACE(*s))
4942 while (s < PL_bufend && isSPACE(*s))
4944 if (isIDFIRST_lazy(s)) {
4946 while (isALNUM_lazy(s))
4948 while (s < PL_bufend && isSPACE(*s))
4953 kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
4957 Perl_croak(aTHX_ "No comma allowed after %s", what);
4963 S_new_constant(pTHX_ char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)
4966 HV *table = GvHV(PL_hintgv); /* ^H */
4969 bool oldcatch = CATCH_GET;
4974 yyerror("%^H is not defined");
4977 cvp = hv_fetch(table, key, strlen(key), FALSE);
4978 if (!cvp || !SvOK(*cvp)) {
4980 sprintf(buf,"$^H{%s} is not defined", key);
4984 sv_2mortal(sv); /* Parent created it permanently */
4987 pv = sv_2mortal(newSVpvn(s, len));
4989 typesv = sv_2mortal(newSVpv(type, 0));
4991 typesv = &PL_sv_undef;
4993 Zero(&myop, 1, BINOP);
4994 myop.op_last = (OP *) &myop;
4995 myop.op_next = Nullop;
4996 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
4998 PUSHSTACKi(PERLSI_OVERLOAD);
5001 PL_op = (OP *) &myop;
5002 if (PERLDB_SUB && PL_curstash != PL_debstash)
5003 PL_op->op_private |= OPpENTERSUB_DB;
5005 Perl_pp_pushmark(aTHX);
5014 if (PL_op = Perl_pp_entersub(aTHX))
5021 CATCH_SET(oldcatch);
5026 sprintf(buf,"Call to &{$^H{%s}} did not return a defined value", key);
5029 return SvREFCNT_inc(res);
5033 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
5035 register char *d = dest;
5036 register char *e = d + destlen - 3; /* two-character token, ending NUL */
5039 Perl_croak(aTHX_ ident_too_long);
5040 if (isALNUM(*s)) /* UTF handled below */
5042 else if (*s == '\'' && allow_package && isIDFIRST_lazy(s+1)) {
5047 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
5051 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5052 char *t = s + UTF8SKIP(s);
5053 while (*t & 0x80 && is_utf8_mark((U8*)t))
5055 if (d + (t - s) > e)
5056 Perl_croak(aTHX_ ident_too_long);
5057 Copy(s, d, t - s, char);
5070 S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
5077 if (PL_lex_brackets == 0)
5078 PL_lex_fakebrack = 0;
5082 e = d + destlen - 3; /* two-character token, ending NUL */
5084 while (isDIGIT(*s)) {
5086 Perl_croak(aTHX_ ident_too_long);
5093 Perl_croak(aTHX_ ident_too_long);
5094 if (isALNUM(*s)) /* UTF handled below */
5096 else if (*s == '\'' && isIDFIRST_lazy(s+1)) {
5101 else if (*s == ':' && s[1] == ':') {
5105 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5106 char *t = s + UTF8SKIP(s);
5107 while (*t & 0x80 && is_utf8_mark((U8*)t))
5109 if (d + (t - s) > e)
5110 Perl_croak(aTHX_ ident_too_long);
5111 Copy(s, d, t - s, char);
5122 if (PL_lex_state != LEX_NORMAL)
5123 PL_lex_state = LEX_INTERPENDMAYBE;
5126 if (*s == '$' && s[1] &&
5127 (isALNUM_lazy(s+1) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
5140 if (*d == '^' && *s && isCONTROLVAR(*s)) {
5145 if (isSPACE(s[-1])) {
5148 if (ch != ' ' && ch != '\t') {
5154 if (isIDFIRST_lazy(d)) {
5158 while (e < send && isALNUM_lazy(e) || *e == ':') {
5160 while (e < send && *e & 0x80 && is_utf8_mark((U8*)e))
5163 Copy(s, d, e - s, char);
5168 while ((isALNUM(*s) || *s == ':') && d < e)
5171 Perl_croak(aTHX_ ident_too_long);
5174 while (s < send && (*s == ' ' || *s == '\t')) s++;
5175 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
5176 dTHR; /* only for ckWARN */
5177 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
5178 char *brack = *s == '[' ? "[...]" : "{...}";
5179 Perl_warner(aTHX_ WARN_AMBIGUOUS,
5180 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
5181 funny, dest, brack, funny, dest, brack);
5183 PL_lex_fakebrack = PL_lex_brackets+1;
5185 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5189 /* Handle extended ${^Foo} variables
5190 * 1999-02-27 mjd-perl-patch@plover.com */
5191 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
5195 while (isALNUM(*s) && d < e) {
5199 Perl_croak(aTHX_ ident_too_long);
5204 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
5205 PL_lex_state = LEX_INTERPEND;
5208 if (PL_lex_state == LEX_NORMAL) {
5209 dTHR; /* only for ckWARN */
5210 if (ckWARN(WARN_AMBIGUOUS) &&
5211 (keyword(dest, d - dest) || get_cv(dest, FALSE)))
5213 Perl_warner(aTHX_ WARN_AMBIGUOUS,
5214 "Ambiguous use of %c{%s} resolved to %c%s",
5215 funny, dest, funny, dest);
5220 s = bracket; /* let the parser handle it */
5224 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
5225 PL_lex_state = LEX_INTERPEND;
5230 Perl_pmflag(pTHX_ U16 *pmfl, int ch)
5235 *pmfl |= PMf_GLOBAL;
5237 *pmfl |= PMf_CONTINUE;
5241 *pmfl |= PMf_MULTILINE;
5243 *pmfl |= PMf_SINGLELINE;
5245 *pmfl |= PMf_EXTENDED;
5249 S_scan_pat(pTHX_ char *start, I32 type)
5254 s = scan_str(start);
5257 SvREFCNT_dec(PL_lex_stuff);
5258 PL_lex_stuff = Nullsv;
5259 Perl_croak(aTHX_ "Search pattern not terminated");
5262 pm = (PMOP*)newPMOP(type, 0);
5263 if (PL_multi_open == '?')
5264 pm->op_pmflags |= PMf_ONCE;
5266 while (*s && strchr("iomsx", *s))
5267 pmflag(&pm->op_pmflags,*s++);
5270 while (*s && strchr("iogcmsx", *s))
5271 pmflag(&pm->op_pmflags,*s++);
5273 pm->op_pmpermflags = pm->op_pmflags;
5275 PL_lex_op = (OP*)pm;
5276 yylval.ival = OP_MATCH;
5281 S_scan_subst(pTHX_ char *start)
5288 yylval.ival = OP_NULL;
5290 s = scan_str(start);
5294 SvREFCNT_dec(PL_lex_stuff);
5295 PL_lex_stuff = Nullsv;
5296 Perl_croak(aTHX_ "Substitution pattern not terminated");
5299 if (s[-1] == PL_multi_open)
5302 first_start = PL_multi_start;
5306 SvREFCNT_dec(PL_lex_stuff);
5307 PL_lex_stuff = Nullsv;
5309 SvREFCNT_dec(PL_lex_repl);
5310 PL_lex_repl = Nullsv;
5311 Perl_croak(aTHX_ "Substitution replacement not terminated");
5313 PL_multi_start = first_start; /* so whole substitution is taken together */
5315 pm = (PMOP*)newPMOP(OP_SUBST, 0);
5321 else if (strchr("iogcmsx", *s))
5322 pmflag(&pm->op_pmflags,*s++);
5329 PL_sublex_info.super_bufptr = s;
5330 PL_sublex_info.super_bufend = PL_bufend;
5332 pm->op_pmflags |= PMf_EVAL;
5333 repl = newSVpvn("",0);
5335 sv_catpv(repl, es ? "eval " : "do ");
5336 sv_catpvn(repl, "{ ", 2);
5337 sv_catsv(repl, PL_lex_repl);
5338 sv_catpvn(repl, " };", 2);
5340 SvREFCNT_dec(PL_lex_repl);
5344 pm->op_pmpermflags = pm->op_pmflags;
5345 PL_lex_op = (OP*)pm;
5346 yylval.ival = OP_SUBST;
5351 S_scan_trans(pTHX_ char *start)
5362 yylval.ival = OP_NULL;
5364 s = scan_str(start);
5367 SvREFCNT_dec(PL_lex_stuff);
5368 PL_lex_stuff = Nullsv;
5369 Perl_croak(aTHX_ "Transliteration pattern not terminated");
5371 if (s[-1] == PL_multi_open)
5377 SvREFCNT_dec(PL_lex_stuff);
5378 PL_lex_stuff = Nullsv;
5380 SvREFCNT_dec(PL_lex_repl);
5381 PL_lex_repl = Nullsv;
5382 Perl_croak(aTHX_ "Transliteration replacement not terminated");
5386 o = newSVOP(OP_TRANS, 0, 0);
5387 utf8 = OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF;
5390 New(803,tbl,256,short);
5391 o = newPVOP(OP_TRANS, 0, (char*)tbl);
5395 complement = del = squash = 0;
5396 while (strchr("cdsCU", *s)) {
5398 complement = OPpTRANS_COMPLEMENT;
5400 del = OPpTRANS_DELETE;
5402 squash = OPpTRANS_SQUASH;
5407 utf8 &= ~OPpTRANS_FROM_UTF;
5409 utf8 |= OPpTRANS_FROM_UTF;
5413 utf8 &= ~OPpTRANS_TO_UTF;
5415 utf8 |= OPpTRANS_TO_UTF;
5418 Perl_croak(aTHX_ "Too many /C and /U options");
5423 o->op_private = del|squash|complement|utf8;
5426 yylval.ival = OP_TRANS;
5431 S_scan_heredoc(pTHX_ register char *s)
5435 I32 op_type = OP_SCALAR;
5442 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
5446 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
5449 for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5450 if (*peek && strchr("`'\"",*peek)) {
5453 s = delimcpy(d, e, s, PL_bufend, term, &len);
5463 if (!isALNUM_lazy(s))
5464 deprecate("bare << to mean <<\"\"");
5465 for (; isALNUM_lazy(s); s++) {
5470 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
5471 Perl_croak(aTHX_ "Delimiter for here document is too long");
5474 len = d - PL_tokenbuf;
5475 #ifndef PERL_STRICT_CR
5476 d = strchr(s, '\r');
5480 while (s < PL_bufend) {
5486 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
5495 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5500 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
5501 herewas = newSVpvn(s,PL_bufend-s);
5503 s--, herewas = newSVpvn(s,d-s);
5504 s += SvCUR(herewas);
5506 tmpstr = NEWSV(87,79);
5507 sv_upgrade(tmpstr, SVt_PVIV);
5512 else if (term == '`') {
5513 op_type = OP_BACKTICK;
5514 SvIVX(tmpstr) = '\\';
5518 PL_multi_start = PL_curcop->cop_line;
5519 PL_multi_open = PL_multi_close = '<';
5520 term = *PL_tokenbuf;
5521 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
5522 char *bufptr = PL_sublex_info.super_bufptr;
5523 char *bufend = PL_sublex_info.super_bufend;
5524 char *olds = s - SvCUR(herewas);
5525 s = strchr(bufptr, '\n');
5529 while (s < bufend &&
5530 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
5532 PL_curcop->cop_line++;
5535 PL_curcop->cop_line = PL_multi_start;
5536 missingterm(PL_tokenbuf);
5538 sv_setpvn(herewas,bufptr,d-bufptr+1);
5539 sv_setpvn(tmpstr,d+1,s-d);
5541 sv_catpvn(herewas,s,bufend-s);
5542 (void)strcpy(bufptr,SvPVX(herewas));
5549 while (s < PL_bufend &&
5550 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
5552 PL_curcop->cop_line++;
5554 if (s >= PL_bufend) {
5555 PL_curcop->cop_line = PL_multi_start;
5556 missingterm(PL_tokenbuf);
5558 sv_setpvn(tmpstr,d+1,s-d);
5560 PL_curcop->cop_line++; /* the preceding stmt passes a newline */
5562 sv_catpvn(herewas,s,PL_bufend-s);
5563 sv_setsv(PL_linestr,herewas);
5564 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
5565 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5568 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
5569 while (s >= PL_bufend) { /* multiple line string? */
5571 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5572 PL_curcop->cop_line = PL_multi_start;
5573 missingterm(PL_tokenbuf);
5575 PL_curcop->cop_line++;
5576 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5577 #ifndef PERL_STRICT_CR
5578 if (PL_bufend - PL_linestart >= 2) {
5579 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
5580 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
5582 PL_bufend[-2] = '\n';
5584 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5586 else if (PL_bufend[-1] == '\r')
5587 PL_bufend[-1] = '\n';
5589 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
5590 PL_bufend[-1] = '\n';
5592 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5593 SV *sv = NEWSV(88,0);
5595 sv_upgrade(sv, SVt_PVMG);
5596 sv_setsv(sv,PL_linestr);
5597 av_store(GvAV(PL_curcop->cop_filegv),
5598 (I32)PL_curcop->cop_line,sv);
5600 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
5603 sv_catsv(PL_linestr,herewas);
5604 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5608 sv_catsv(tmpstr,PL_linestr);
5613 PL_multi_end = PL_curcop->cop_line;
5614 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
5615 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
5616 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
5618 SvREFCNT_dec(herewas);
5619 PL_lex_stuff = tmpstr;
5620 yylval.ival = op_type;
5625 takes: current position in input buffer
5626 returns: new position in input buffer
5627 side-effects: yylval and lex_op are set.
5632 <FH> read from filehandle
5633 <pkg::FH> read from package qualified filehandle
5634 <pkg'FH> read from package qualified filehandle
5635 <$fh> read from filehandle in $fh
5641 S_scan_inputsymbol(pTHX_ char *start)
5643 register char *s = start; /* current position in buffer */
5649 d = PL_tokenbuf; /* start of temp holding space */
5650 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
5651 end = strchr(s, '\n');
5654 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
5656 /* die if we didn't have space for the contents of the <>,
5657 or if it didn't end, or if we see a newline
5660 if (len >= sizeof PL_tokenbuf)
5661 Perl_croak(aTHX_ "Excessively long <> operator");
5663 Perl_croak(aTHX_ "Unterminated <> operator");
5668 Remember, only scalar variables are interpreted as filehandles by
5669 this code. Anything more complex (e.g., <$fh{$num}>) will be
5670 treated as a glob() call.
5671 This code makes use of the fact that except for the $ at the front,
5672 a scalar variable and a filehandle look the same.
5674 if (*d == '$' && d[1]) d++;
5676 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
5677 while (*d && (isALNUM_lazy(d) || *d == '\'' || *d == ':'))
5680 /* If we've tried to read what we allow filehandles to look like, and
5681 there's still text left, then it must be a glob() and not a getline.
5682 Use scan_str to pull out the stuff between the <> and treat it
5683 as nothing more than a string.
5686 if (d - PL_tokenbuf != len) {
5687 yylval.ival = OP_GLOB;
5689 s = scan_str(start);
5691 Perl_croak(aTHX_ "Glob not terminated");
5695 /* we're in a filehandle read situation */
5698 /* turn <> into <ARGV> */
5700 (void)strcpy(d,"ARGV");
5702 /* if <$fh>, create the ops to turn the variable into a
5708 /* try to find it in the pad for this block, otherwise find
5709 add symbol table ops
5711 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
5712 OP *o = newOP(OP_PADSV, 0);
5714 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, o);
5717 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
5718 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
5719 newUNOP(OP_RV2SV, 0,
5720 newGVOP(OP_GV, 0, gv)));
5722 PL_lex_op->op_flags |= OPf_SPECIAL;
5723 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
5724 yylval.ival = OP_NULL;
5727 /* If it's none of the above, it must be a literal filehandle
5728 (<Foo::BAR> or <FOO>) so build a simple readline OP */
5730 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
5731 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
5732 yylval.ival = OP_NULL;
5741 takes: start position in buffer
5742 returns: position to continue reading from buffer
5743 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
5744 updates the read buffer.
5746 This subroutine pulls a string out of the input. It is called for:
5747 q single quotes q(literal text)
5748 ' single quotes 'literal text'
5749 qq double quotes qq(interpolate $here please)
5750 " double quotes "interpolate $here please"
5751 qx backticks qx(/bin/ls -l)
5752 ` backticks `/bin/ls -l`
5753 qw quote words @EXPORT_OK = qw( func() $spam )
5754 m// regexp match m/this/
5755 s/// regexp substitute s/this/that/
5756 tr/// string transliterate tr/this/that/
5757 y/// string transliterate y/this/that/
5758 ($*@) sub prototypes sub foo ($)
5759 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
5761 In most of these cases (all but <>, patterns and transliterate)
5762 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
5763 calls scan_str(). s/// makes yylex() call scan_subst() which calls
5764 scan_str(). tr/// and y/// make yylex() call scan_trans() which
5767 It skips whitespace before the string starts, and treats the first
5768 character as the delimiter. If the delimiter is one of ([{< then
5769 the corresponding "close" character )]}> is used as the closing
5770 delimiter. It allows quoting of delimiters, and if the string has
5771 balanced delimiters ([{<>}]) it allows nesting.
5773 The lexer always reads these strings into lex_stuff, except in the
5774 case of the operators which take *two* arguments (s/// and tr///)
5775 when it checks to see if lex_stuff is full (presumably with the 1st
5776 arg to s or tr) and if so puts the string into lex_repl.
5781 S_scan_str(pTHX_ char *start)
5784 SV *sv; /* scalar value: string */
5785 char *tmps; /* temp string, used for delimiter matching */
5786 register char *s = start; /* current position in the buffer */
5787 register char term; /* terminating character */
5788 register char *to; /* current position in the sv's data */
5789 I32 brackets = 1; /* bracket nesting level */
5791 /* skip space before the delimiter */
5795 /* mark where we are, in case we need to report errors */
5798 /* after skipping whitespace, the next character is the terminator */
5800 /* mark where we are */
5801 PL_multi_start = PL_curcop->cop_line;
5802 PL_multi_open = term;
5804 /* find corresponding closing delimiter */
5805 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5807 PL_multi_close = term;
5809 /* create a new SV to hold the contents. 87 is leak category, I'm
5810 assuming. 79 is the SV's initial length. What a random number. */
5812 sv_upgrade(sv, SVt_PVIV);
5814 (void)SvPOK_only(sv); /* validate pointer */
5816 /* move past delimiter and try to read a complete string */
5819 /* extend sv if need be */
5820 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
5821 /* set 'to' to the next character in the sv's string */
5822 to = SvPVX(sv)+SvCUR(sv);
5824 /* if open delimiter is the close delimiter read unbridle */
5825 if (PL_multi_open == PL_multi_close) {
5826 for (; s < PL_bufend; s++,to++) {
5827 /* embedded newlines increment the current line number */
5828 if (*s == '\n' && !PL_rsfp)
5829 PL_curcop->cop_line++;
5830 /* handle quoted delimiters */
5831 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
5834 /* any other quotes are simply copied straight through */
5838 /* terminate when run out of buffer (the for() condition), or
5839 have found the terminator */
5840 else if (*s == term)
5846 /* if the terminator isn't the same as the start character (e.g.,
5847 matched brackets), we have to allow more in the quoting, and
5848 be prepared for nested brackets.
5851 /* read until we run out of string, or we find the terminator */
5852 for (; s < PL_bufend; s++,to++) {
5853 /* embedded newlines increment the line count */
5854 if (*s == '\n' && !PL_rsfp)
5855 PL_curcop->cop_line++;
5856 /* backslashes can escape the open or closing characters */
5857 if (*s == '\\' && s+1 < PL_bufend) {
5858 if ((s[1] == PL_multi_open) || (s[1] == PL_multi_close))
5863 /* allow nested opens and closes */
5864 else if (*s == PL_multi_close && --brackets <= 0)
5866 else if (*s == PL_multi_open)
5871 /* terminate the copied string and update the sv's end-of-string */
5873 SvCUR_set(sv, to - SvPVX(sv));
5876 * this next chunk reads more into the buffer if we're not done yet
5879 if (s < PL_bufend) break; /* handle case where we are done yet :-) */
5881 #ifndef PERL_STRICT_CR
5882 if (to - SvPVX(sv) >= 2) {
5883 if ((to[-2] == '\r' && to[-1] == '\n') ||
5884 (to[-2] == '\n' && to[-1] == '\r'))
5888 SvCUR_set(sv, to - SvPVX(sv));
5890 else if (to[-1] == '\r')
5893 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
5897 /* if we're out of file, or a read fails, bail and reset the current
5898 line marker so we can report where the unterminated string began
5901 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5903 PL_curcop->cop_line = PL_multi_start;
5906 /* we read a line, so increment our line counter */
5907 PL_curcop->cop_line++;
5909 /* update debugger info */
5910 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5911 SV *sv = NEWSV(88,0);
5913 sv_upgrade(sv, SVt_PVMG);
5914 sv_setsv(sv,PL_linestr);
5915 av_store(GvAV(PL_curcop->cop_filegv),
5916 (I32)PL_curcop->cop_line, sv);
5919 /* having changed the buffer, we must update PL_bufend */
5920 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5923 /* at this point, we have successfully read the delimited string */
5925 PL_multi_end = PL_curcop->cop_line;
5928 /* if we allocated too much space, give some back */
5929 if (SvCUR(sv) + 5 < SvLEN(sv)) {
5930 SvLEN_set(sv, SvCUR(sv) + 1);
5931 Renew(SvPVX(sv), SvLEN(sv), char);
5934 /* decide whether this is the first or second quoted string we've read
5947 takes: pointer to position in buffer
5948 returns: pointer to new position in buffer
5949 side-effects: builds ops for the constant in yylval.op
5951 Read a number in any of the formats that Perl accepts:
5953 0(x[0-7A-F]+)|([0-7]+)|(b[01])
5954 [\d_]+(\.[\d_]*)?[Ee](\d+)
5956 Underbars (_) are allowed in decimal numbers. If -w is on,
5957 underbars before a decimal point must be at three digit intervals.
5959 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
5962 If it reads a number without a decimal point or an exponent, it will
5963 try converting the number to an integer and see if it can do so
5964 without loss of precision.
5968 Perl_scan_num(pTHX_ char *start)
5970 register char *s = start; /* current position in buffer */
5971 register char *d; /* destination in temp buffer */
5972 register char *e; /* end of temp buffer */
5973 I32 tryiv; /* used to see if it can be an int */
5974 NV value; /* number read, as a double */
5975 SV *sv; /* place to put the converted number */
5976 I32 floatit; /* boolean: int or float? */
5977 char *lastub = 0; /* position of last underbar */
5978 static char number_too_long[] = "Number too long";
5980 /* We use the first character to decide what type of number this is */
5984 Perl_croak(aTHX_ "panic: scan_num");
5986 /* if it starts with a 0, it could be an octal number, a decimal in
5987 0.13 disguise, or a hexadecimal number, or a binary number.
5992 u holds the "number so far"
5993 shift the power of 2 of the base
5994 (hex == 4, octal == 3, binary == 1)
5995 overflowed was the number more than we can hold?
5997 Shift is used when we add a digit. It also serves as an "are
5998 we in octal/hex/binary?" indicator to disallow hex characters
6004 bool overflowed = FALSE;
6010 } else if (s[1] == 'b') {
6014 /* check for a decimal in disguise */
6015 else if (s[1] == '.')
6017 /* so it must be octal */
6022 /* read the rest of the number */
6024 UV n, b; /* n is used in the overflow test, b is the digit we're adding on */
6028 /* if we don't mention it, we're done */
6037 /* 8 and 9 are not octal */
6040 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
6043 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
6047 case '2': case '3': case '4':
6048 case '5': case '6': case '7':
6050 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
6054 b = *s++ & 15; /* ASCII digit -> value of digit */
6058 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
6059 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
6060 /* make sure they said 0x */
6065 /* Prepare to put the digit we have onto the end
6066 of the number so far. We check for overflows.
6070 n = u << shift; /* make room for the digit */
6071 if (!overflowed && (n >> shift) != u
6072 && !(PL_hints & HINT_NEW_BINARY))
6074 if (ckWARN_d(WARN_UNSAFE))
6075 Perl_warner(aTHX_ WARN_UNSAFE,
6076 "Integer overflow in %s number",
6077 (shift == 4) ? "hex"
6078 : ((shift == 3) ? "octal" : "binary"));
6081 u = n | b; /* add the digit to the end */
6086 /* if we get here, we had success: make a scalar value from
6092 if ( PL_hints & HINT_NEW_BINARY)
6093 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
6098 handle decimal numbers.
6099 we're also sent here when we read a 0 as the first digit
6101 case '1': case '2': case '3': case '4': case '5':
6102 case '6': case '7': case '8': case '9': case '.':
6105 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
6108 /* read next group of digits and _ and copy into d */
6109 while (isDIGIT(*s) || *s == '_') {
6110 /* skip underscores, checking for misplaced ones
6114 dTHR; /* only for ckWARN */
6115 if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
6116 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
6120 /* check for end of fixed-length buffer */
6122 Perl_croak(aTHX_ number_too_long);
6123 /* if we're ok, copy the character */
6128 /* final misplaced underbar check */
6129 if (lastub && s - lastub != 3) {
6131 if (ckWARN(WARN_SYNTAX))
6132 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
6135 /* read a decimal portion if there is one. avoid
6136 3..5 being interpreted as the number 3. followed
6139 if (*s == '.' && s[1] != '.') {
6143 /* copy, ignoring underbars, until we run out of
6144 digits. Note: no misplaced underbar checks!
6146 for (; isDIGIT(*s) || *s == '_'; s++) {
6147 /* fixed length buffer check */
6149 Perl_croak(aTHX_ number_too_long);
6155 /* read exponent part, if present */
6156 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
6160 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
6161 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
6163 /* allow positive or negative exponent */
6164 if (*s == '+' || *s == '-')
6167 /* read digits of exponent (no underbars :-) */
6168 while (isDIGIT(*s)) {
6170 Perl_croak(aTHX_ number_too_long);
6175 /* terminate the string */
6178 /* make an sv from the string */
6181 value = Atof(PL_tokenbuf);
6184 See if we can make do with an integer value without loss of
6185 precision. We use I_V to cast to an int, because some
6186 compilers have issues. Then we try casting it back and see
6187 if it was the same. We only do this if we know we
6188 specifically read an integer.
6190 Note: if floatit is true, then we don't need to do the
6194 if (!floatit && (NV)tryiv == value)
6195 sv_setiv(sv, tryiv);
6197 sv_setnv(sv, value);
6198 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) )
6199 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
6200 (floatit ? "float" : "integer"), sv, Nullsv, NULL);
6204 /* make the op for the constant and return */
6206 yylval.opval = newSVOP(OP_CONST, 0, sv);
6212 S_scan_formline(pTHX_ register char *s)
6217 SV *stuff = newSVpvn("",0);
6218 bool needargs = FALSE;
6221 if (*s == '.' || *s == '}') {
6223 #ifdef PERL_STRICT_CR
6224 for (t = s+1;*t == ' ' || *t == '\t'; t++) ;
6226 for (t = s+1;*t == ' ' || *t == '\t' || *t == '\r'; t++) ;
6228 if (*t == '\n' || t == PL_bufend)
6231 if (PL_in_eval && !PL_rsfp) {
6232 eol = strchr(s,'\n');
6237 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6239 for (t = s; t < eol; t++) {
6240 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
6242 goto enough; /* ~~ must be first line in formline */
6244 if (*t == '@' || *t == '^')
6247 sv_catpvn(stuff, s, eol-s);
6251 s = filter_gets(PL_linestr, PL_rsfp, 0);
6252 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
6253 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
6256 yyerror("Format not terminated");
6266 PL_lex_state = LEX_NORMAL;
6267 PL_nextval[PL_nexttoke].ival = 0;
6271 PL_lex_state = LEX_FORMLINE;
6272 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
6274 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
6278 SvREFCNT_dec(stuff);
6279 PL_lex_formbrack = 0;
6290 PL_cshlen = strlen(PL_cshname);
6295 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
6298 I32 oldsavestack_ix = PL_savestack_ix;
6299 CV* outsidecv = PL_compcv;
6303 assert(SvTYPE(PL_compcv) == SVt_PVCV);
6305 save_I32(&PL_subline);
6306 save_item(PL_subname);
6308 SAVESPTR(PL_curpad);
6309 SAVESPTR(PL_comppad);
6310 SAVESPTR(PL_comppad_name);
6311 SAVESPTR(PL_compcv);
6312 SAVEI32(PL_comppad_name_fill);
6313 SAVEI32(PL_min_intro_pending);
6314 SAVEI32(PL_max_intro_pending);
6315 SAVEI32(PL_pad_reset_pending);
6317 PL_compcv = (CV*)NEWSV(1104,0);
6318 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
6319 CvFLAGS(PL_compcv) |= flags;
6321 PL_comppad = newAV();
6322 av_push(PL_comppad, Nullsv);
6323 PL_curpad = AvARRAY(PL_comppad);
6324 PL_comppad_name = newAV();
6325 PL_comppad_name_fill = 0;
6326 PL_min_intro_pending = 0;
6328 PL_subline = PL_curcop->cop_line;
6330 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
6331 PL_curpad[0] = (SV*)newAV();
6332 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
6333 #endif /* USE_THREADS */
6335 comppadlist = newAV();
6336 AvREAL_off(comppadlist);
6337 av_store(comppadlist, 0, (SV*)PL_comppad_name);
6338 av_store(comppadlist, 1, (SV*)PL_comppad);
6340 CvPADLIST(PL_compcv) = comppadlist;
6341 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
6343 CvOWNER(PL_compcv) = 0;
6344 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
6345 MUTEX_INIT(CvMUTEXP(PL_compcv));
6346 #endif /* USE_THREADS */
6348 return oldsavestack_ix;
6352 Perl_yywarn(pTHX_ char *s)
6356 PL_in_eval |= EVAL_WARNONLY;
6358 PL_in_eval &= ~EVAL_WARNONLY;
6363 Perl_yyerror(pTHX_ char *s)
6367 char *context = NULL;
6371 if (!yychar || (yychar == ';' && !PL_rsfp))
6373 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
6374 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
6375 while (isSPACE(*PL_oldoldbufptr))
6377 context = PL_oldoldbufptr;
6378 contlen = PL_bufptr - PL_oldoldbufptr;
6380 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
6381 PL_oldbufptr != PL_bufptr) {
6382 while (isSPACE(*PL_oldbufptr))
6384 context = PL_oldbufptr;
6385 contlen = PL_bufptr - PL_oldbufptr;
6387 else if (yychar > 255)
6388 where = "next token ???";
6389 else if ((yychar & 127) == 127) {
6390 if (PL_lex_state == LEX_NORMAL ||
6391 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
6392 where = "at end of line";
6393 else if (PL_lex_inpat)
6394 where = "within pattern";
6396 where = "within string";
6399 SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
6401 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
6402 else if (isPRINT_LC(yychar))
6403 Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
6405 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
6406 where = SvPVX(where_sv);
6408 msg = sv_2mortal(newSVpv(s, 0));
6409 Perl_sv_catpvf(aTHX_ msg, " at %_ line %ld, ",
6410 GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line);
6412 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
6414 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
6415 if (PL_multi_start < PL_multi_end && (U32)(PL_curcop->cop_line - PL_multi_end) <= 1) {
6416 Perl_sv_catpvf(aTHX_ msg,
6417 " (Might be a runaway multi-line %c%c string starting on line %ld)\n",
6418 (int)PL_multi_open,(int)PL_multi_close,(long)PL_multi_start);
6421 if (PL_in_eval & EVAL_WARNONLY)
6422 Perl_warn(aTHX_ "%_", msg);
6423 else if (PL_in_eval)
6424 sv_catsv(ERRSV, msg);
6426 PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
6427 if (++PL_error_count >= 10)
6428 Perl_croak(aTHX_ "%_ has too many errors.\n", GvSV(PL_curcop->cop_filegv));
6430 PL_in_my_stash = Nullhv;